PRINT GEN TITLE 'ALC$PUT - WRITE OPERATIONS TO EXTRACT/USER FILES' *********************************************************************** * A L C $ P U T * *---------------------------------------------------------------------* *********************************************************************** * R7 =INPUT/OUTPUT RECORD RETURN AREA * R8 =FILE WORK AREA * R9 =ADDRESS OF SAVED INPUT PARMS * R10=INTERNAL RETURN ADDRESS FOR EACH PARAGRAPH * R11=BASE REGISTER * R12=BASE REGISTER *********************************************************************** R0 EQU 0 R1 EQU 1 R2 EQU 2 R3 EQU 3 R4 EQU 4 R5 EQU 5 R6 EQU 6 R7 EQU 7 R8 EQU 8 R9 EQU 9 R10 EQU 10 R11 EQU 11 R12 EQU 12 R13 EQU 13 R14 EQU 14 R15 EQU 15 R00 EQU 0 R01 EQU 1 R02 EQU 2 R03 EQU 3 R04 EQU 4 R05 EQU 5 R06 EQU 6 R07 EQU 7 R08 EQU 8 R09 EQU 9 EJECT ALC$PUT CSECT USING *,R11,R12 R11,R12=BASE REGISTERS STM R14,R12,12(R13) SAVE REGISTERS LR R11,R15 ADDRESSIBILITY LA R12,2048(0,R11) LA R12,2048(0,R12) LR R1,R13 SAVE SAVE AREA POINTER LA R13,SAVEAREA POINT TO MY SAVEAREA ST R13,8(0,R1) SET FORW CHAIN IN CALLERS SAREA ST R1,4(0,R13) SET BACK CHAIN IN MY SAVEAREA L R1,24(0,R1) REACQUIRE R1 AS IT CAME HERE L R9,0(R1) GET "PARM=" STUFF USING PUT$PARM,R9 R9=INPUT PARMS L R7,4(,R1) get address of input rec USING PUT$REC,R7 R7=INPUT/OUTPUT RECORD USING IHADCB,R8 R8=addr of dcb layout B START DS 0F DC C'*' PGMID DC CL8'ALC$PUT' DC C'*' COMPDATE DC CL8'&SYSDATE' COMPTIME DC CL8'&SYSTIME' SAVEAREA DC 18F'0' START EQU * LA R10,$GOBACK SET RETURN ADDRESS MVC PUT$RC,=H'-1' SET RETURN CODE CLC PUT$FUNC,=C'OPEN ' OPEN FILES BE $OPEN CLC PUT$FUNC,=C'CLOSE ' CLOSE FILES BE $CLOSE CLC PUT$FUNC,=C'GET ' READ INPUT FILES BE $GET CLC PUT$FUNC,=C'PUT ' WRITE FILES BE $PUT $GOBACK EQU * L R13,4(0,R13) POINT BACK TO CALLERS SAVEAREA RETURN (14,12),,RC=0 SET RC=0 BR R14 GOBACK TO MOMMA EJECT *================================================================== * OPEN FILES *================================================================== $OPEN EQU * ST R10,$OPENR10 SAVE RETURN ADDRESS CLC PUT$FILE,=C'EXTRACT ' EXTRACT FILE? BNE $OPEN020 NO---CONTINUE LA R8,EXTRACT POINT TO DCB=FILE AND MVC DCBDDNAM,PUT$DD GET DD NAME OPEN (EXTRACT,OUTPUT),MODE=31 B $OPEN900 $OPEN020 EQU * CLC PUT$FILE,=C'USER ' USER FILE? BNE $OPEN040 NO---CONTINUE LA R8,USER POINT TO DCB=FILE AND MVC DCBDDNAM,PUT$DD GET DD NAME OPEN (USER,OUTPUT),MODE=31 B $OPEN900 $OPEN040 EQU * B $OPEN999 CANNOT FIND INPUT FILE $OPEN900 EQU * XC PUT$RC,PUT$RC CLEAR RET CODE MVC PUT$RECL,DCBLRECL GET RECORD LENGTH MVC PUT$BLK,DCBBLKSI GET BLOCK SIZE MVC TUDDL,=X'0008' INITIALIZE LENGTH MVC TUDSNL,=X'002C' " " MVC TUDSOL,=X'0002' " " MVC TUDDNAME,PUT$DD GET THE DDNAME TO LOOK AT MVC TUDSNAME(1),=C' ' CLEAR THE DATASET NAME MVC TUDSNAME+1(43),TUDSNAME CLEAR THE DATASET NAME MVC TUDSORG,=C' ' CLEAR DSORG FIELD LA R2,RBADDR POINT TO BEG OF REQ BLOCK PNTR USING S99RBP,R2 LA R3,RBWORK POINT TO REQ BLOCK WORK AREA USING S99RB,R3 ST R3,S99RBPTR SAVE ADDR OF REQ BLOCK OI S99RBPTR,S99RBPND INDICATE LAST POINTER XC S99RB(RBLEN),S99RB CLEAR REQ BLOCK WORK AREA MVI S99RBLN,RBLEN SET LENGTH OF REQ BLOCK MVI S99VERB,S99VRBIN SET VERB FOR INFO ONLY LA R6,TUPTRS POINT TO TEXT UNIT POINTER AREA USING S99TUPL,R6 ST R6,S99TXTPP SAVE ADDR OF TEXT UNIT POINTER LA R5,TUDD POINT TO 1ST TEXT UNIT ST R5,S99TUPTR SAVE THIS ADDR LA R6,S99TUPL+4 POINT TO NEXT TEXT UNIT POINTER LA R5,TUDSN POINT TO 2ND TEXT UNIT ST R5,S99TUPTR SAVE THIS ADDR LA R6,S99TUPL+4 POINT TO NEXT TEXT UNIT POINTER LA R5,TUDSO POINT TO 3RD TEXT UNIT ST R5,S99TUPTR SAVE THIS ADDR OI S99TUPTR,S99TUPLN INDICATE LAST TEXT POINTER LR R1,R2 POINT R1 TO REQUEST BLOCK DYNALLOC MVC PUT$DSN,TUDSNAME AND RETURN IT TO CALLER MVC PUT$RECF,DCBRECFM default to native code TM DCBRECFM,DCBRECV VARIABLE? BNO $OPEN901 NO---cONTINUE MVC PUT$RECF,=C'V ' SET AS VARIABLE B $OPEN909 CONTINUE $OPEN901 EQU * TM DCBRECFM,DCBRECU UNDEFINED? BNO $OPEN902 NO---CONTINUE MVC PUT$RECF,=C'U ' SET AS UNDEFINED B $OPEN909 CONTINUE $OPEN902 EQU * TM DCBRECFM,DCBRECF FIXED? BNO $OPEN909 NO---CONTINUE MVC PUT$RECF,=C'F ' SET AS FIXED $OPEN909 EQU * MVC PUT$DSOR,=C'????' SET DSORG LA R10,DSORG$TB $OPEN910 EQU * CLC 0(2,R10),=X'FFFF' end-of-table? BE $OPEN920 YES---EXIT CLC 0(2,R10),TUDSORG IS THIS THE DSORG WE WANT? BE $OPEN911 YES--CONTINUE LA R10,6(R10) POINT TO NEXT ENTRY B $OPEN910 CONTINUE $OPEN911 EQU * MVC PUT$DSOR,2(R10) GET DSORG $OPEN920 EQU * TM DCBRECFM,DCBRECBR BLOCKED RECORDS? BNO $OPEN921 NO CONTINUE MVI PUT$RECF+1,C'B' SET AS BLOCKED B $OPEN930 $OPEN921 EQU * TM DCBRECFM,DCBRECSB SPANNED RECORDS? BNO $OPEN930 NO CONTINUE MVI PUT$RECF+1,C'S' SET AS SPANNED $OPEN930 EQU * TM DCBRECFM,DCBRECCA ASA CARRIAGE CONTROL? BNO $OPEN931 NO, CONTINUE MVI PUT$RECF+2,C'A' SET AS ASA CC B $OPEN999 $OPEN931 EQU * TM DCBRECFM,DCBRECCM MACHINE CARRIAGE CONTROL? BNO $OPEN999 NO, CONTINUE MVI PUT$RECF+2,C'M' SET AS MACHINE CARRIAGE CONTROL $OPEN999 EQU * * DROP R2,R3,R6 L R10,$OPENR10 GET RETURN ADDRESS BR R10 RETURN TO MOMMA EJECT *================================================================== * CLOSE FILES *================================================================== $CLOSE EQU * ST R10,$CLOSR10 SAVE RETURN ADDRESS CLC PUT$FILE,=C'EXTRACT ' EXTRACT FILE? BNE $CLOS020 NO---CONTINUE CLOSE (EXTRACT,),MODE=31 B $CLOS900 $CLOS020 EQU * CLC PUT$FILE,=C'USER ' USER FILE? BNE $CLOS040 NO---CONTINUE CLOSE (USER,),MODE=31 B $CLOS900 $CLOS040 EQU * B $CLOS999 CANNOT FIND INPUT FILE $CLOS900 EQU * XC PUT$RC,PUT$RC CLEAR RET CODE $CLOS999 EQU * L R10,$CLOSR10 GET RETURN ADDRESS BR R10 RETURN TO MOMMA EJECT *================================================================== * READ INPUT FILES *================================================================== $GET EQU * BR R10 RETURN TO MOMMA EJECT *================================================================== * WRITE OUTPUT RECORDS *================================================================== $PUT EQU * ST R10,$PUTR10 CLC PUT$FILE,=C'EXTRACT ' EXTRACT FILE? BNE $PUT010 NO---> CONTINUE LA R8,EXTRACT POINT TO DCB=OXTRACT MVC DCBLRECL,PUT$RECL GET RECORD LENGTH PUT EXTRACT,PUT$REC B $PUT900 CONTINUE $PUT010 EQU * CLC PUT$FILE,=C'USER ' USER FILE? BNE $PUT030 NO---> CONTINUE LA R8,USER POINT TO DCB=USER MVC DCBLRECL,PUT$RECL GET RECORD LENGTH PUT USER,PUT$REC B $PUT900 CONTINUE $PUT030 EQU * $PUT050 EQU * B $PUT9999 EXIT $PUT900 EQU * XC PUT$RC,PUT$RC INDICATE GOOD RETURN $PUT9999 EQU * L R10,$PUTR10 GET RETURN ADDRESS BR R10 RETURN TO MOMMA EJECT ********************************************************************** * CONSTANTS,DSECTS * ********************************************************************** DS 0D LTORG DBLEWORD DS D ABNDCODE DC F'0' $GETR10 DS F * SAVE RETURN ADDRESSS $OPENR10 DS F * SAVE RETURN ADDRESSS $PUTR10 DS F * SAVE RETURN ADDRESSS $CLOSR10 DS F * SAVE RETURN ADDRESSS DS 0D *---------------------------------------------------------------------- * WORK AREA FOR DYNAMIC ALLOCATION FACILITIES *---------------------------------------------------------------------- RBLEN EQU (S99RBEND-S99RB) LEN OF REQUEST BLOCK RBADDR DS F ADDR OF REQUEST BLOCK RBWORK DS XL20 REQ BLOCK WORK AREA TUPTRS DS 20F TEXT UNIT POINTERS *---------------------------------------------------------------------- * INFO USED TO REQUEST INFORMATION ABOUNT A PARTICULAR DATASET * DA$FCN = 'I ' *---------------------------------------------------------------------- TUDD EQU * DDNAME WORK AREA DC AL2(DINDDNAM) DDNAME INFO REQ INDICATOR DC XL2'0001' NUM OF ENTRIES TUDDL DC XL2'0008' LENGTH OF WORK AREA TUDDNAME DC CL8'????????' DDNAME * TUDSN EQU * DSNAME WORK AREA DC AL2(DINRTDSN) DSNAME INFO REQ INDICATOR DC XL2'0001' NUM OF ENTRIES TUDSNL DC XL2'002C' LENGTH OF WORK AREA TUDSNAME DC CL44' ' DATASET NAME * TUDSO EQU * DSORG WORK AREA DC AL2(DINRTORG) DSORG INFO REQ INDICATOR DC XL2'0001' NUM OF ENTRIES TUDSOL DC XL2'0002' LENGTH OF ENTRY WORK AREA TUDSORG DC CL2' ' DATASET ORGINAZATION DS 0F DSORG$TB EQU * DC X'0000',C'????' DC X'0004',C'TR ' DC X'0008',C'VSAM' DC X'0020',C'TQ ' DC X'0040',C'TX ' DC X'0080',C'GS ' DC X'0200',C'PO ' DC X'0300',C'POU ' DC X'0400',C'MQ ' DC X'0800',C'CQ ' DC X'1000',C'CX ' DC X'2000',C'DA ' DC X'2100',C'DAU ' DC X'4000',C'PS ' DC X'4100',C'PSU ' DC X'8000',C'IS ' DC X'8100',C'ISU ' DC X'FFFF',C'????' EJECT DS 0D EXTRACT DCB DSORG=PS,MACRF=PM,RECFM=VB,DDNAME=OEXTRACT,DCBE=ABV1 USER DCB DSORG=PS,MACRF=PM,RECFM=VB,DDNAME=OUSER,DCBE=ABV2 ABV1 DCBE RMODE31=BUFF ABV2 DCBE RMODE31=BUFF DCBD DSORG=PS,DEVD=DA PUT$PARM DSECT PUT$FUNC DS CL6 PUT$FILE DS CL8 PUT$DD DS CL8 PUT$RC DS H PUT$RECL DS H PUT$BLK DS H PUT$RECF DS CL3 PUT$DSOR DS CL4 PUT$DSN DS CL44 DS CL1 PUT$REC DSECT DS 0CL4096 DS CL4 * LL/BB AREA PUT$DATA DS CL4092 EJECT * DYNAMIC ALLOCATION PARM LIST IEFZB4D0 EJECT * DYNAMIC ALLOCATION KEY TABLE IEFZB4D2 END