PRINT ON,GEN,NODATA 00010000 *---------------------------------------------------------------------* 00020000 * * 00030000 * THIS ROUTINE IS DESIGNED TO PROVIDE VSAM DATASET INPUT/OUTPUT * 00040000 * CAPABILITY TO PROGRAMS WRITTEN WITH THE MVT COBOL COMPILER, AND * 00050000 * EXECUTED UNDER THE MVS 3.8J OPERATING SYSTEM RUNNING ON EMULATED * 00060000 * HARDWARE UNDER THE HERCULES EMULATOR. * 00070000 * * 00080000 * THE ROUTINE IS DESIGNED TO PROVIDE ACCESS TO ONE OR MORE VSAM * 00090000 * DATASETS (CLUSTERS). THE REQUIRED ACB AND RPL (VSAM DATASET * 00100000 * CONTROL BLOCKS) ARE GENERATED AND STORED IN MEMORY ALLOCATED BY * 00110000 * THE CALLING COBOL PROGRAM. DURING THE CALLS TO OPEN AND ACCESS A * 00120000 * PARTICULAR DATASET, THE ACB AND RPL ARE MODIFIED AS REQUIRED TO * 00130000 * SATISFY THE REQUESTS AGAINST THAT PARTICULAR DATASET. THERE IS * 00140000 * NO NECESSITY TO MODIFY THE ALC CODE AND REASSEMBLE PRIOR TO CALLING * 00150000 * THE ROUTINE. * 00160000 * * 00170000 * BECAUSE THE MVT COBOL COMPILER IS UNABLE TO UTILIZE DYNAMIC CALLING * 00180000 * OF SUBROUTINES, IT IS NECESSARY TO LINK THE OBJECT MODULE FOR THIS * 00190000 * ROUTINE TO EACH CALLING COBOL PROGRAM. AS THIS IS THE CASE, IT IS * 00200000 * NOT NECESSARY FOR THE ROUTINE TO BE SERIALLY REENTRANT, AND I HAVE * 00210000 * NOT DEVOTED THE EFFORT TO MAKE IT SO. * 00220000 * * 00230000 * THIS CODE IS PLACED IN THE PUBLIC DOMAIN AND MAY BE FREELY USED * 00240000 * AND INCORPORATED INTO DERIVED WORKS AS LONG AS ATTRIBUTION TO THE * 00250000 * ORIGINAL AUTHORSHIP REMAINS IN ANY DISTRIBUTED COPIES OF THE ALC * 00260000 * SOURCE. * 00270000 * * 00280000 * WRITTEN NOVEMBER, 2001 BY JAY MOSELEY, CCP * 00290000 * HTTP://WWW.JAYMOSELEY.COM/HERCULES/ * 00300000 * * 00310000 *---------------------------------------------------------------------* 00320000 EJECT 00330000 * 00340000 LCLC &SYSECT 00350000 &SYSECT SETC 'VSAMIO' ROUTINE IDENTIFICATION 00360000 * 00370000 &SYSECT CSECT 00380000 * 00390000 @IDENT01 B @IDENT04(R15) BRANCH AROUND IDENT CONSTANTS 00400000 DC AL1(@IDENT03-@IDENT02) 00410000 @IDENT02 DC C'&SYSECT V2' 00420000 DC C'&SYSDATE &SYSTIME - ' 00430000 DC C'VSAM INPUT/OUTPUT ROUTINE FOR MVS 3.8J' 00440000 @IDENT03 DS 0H 00450000 @IDENT04 EQU *-@IDENT01 00460000 * 00470000 SAVE (14,12) 00480000 * 00490000 BALR R12,0 BASE REGISTERS ARE 12 AND 11 00500000 USING *,R12,R11 00510000 LA R11,4095(,R12) 00520000 LA R11,1(,R11) 00530000 * 00540000 LR R5,R13 COPY CALLER'S SAVEAREA ADDR 00550000 LA R13,SAVEAREA ESTABLISH MY SAVEAREA 00560000 ST R5,4(,R13) BACK CHAIN SAVE AREAS 00570000 ST R13,8(,R5) FORWARD CHAIN SAVE AREAS 00580000 * 00590000 *---------------------------------------------------------------------* 00600000 * THREE BLOCKS OF STORAGE ARE PASSED AS PARAMETERS FROM THE CALLER. * 00610000 * THE FIRST CONTAINS THE COMMAND TO BE PROCESSED AND RETURN CODE/ * 00620000 * FEEDBACK FIELDS. THE SECOND CONTAINS DATASET SPECIFICATION FIELDS * 00630000 * AND CONTROL BLOCKS MAINTAINED BY THIS ROUTINE ON SUBSEQUENT CALLS. * 00640000 * THE THIRD IS THE RECORD AREA USED FOR INPUT/OUTPUT FOR THE DATASET. * 00650000 *---------------------------------------------------------------------* 00660000 LM R8,R10,0(R1) ADDRESS PASSED PARAMETER BLOCKS 00670000 USING $CCOMM,R8 00680000 USING $FCOMM,R9 00690000 USING $RECORD,R10 00700000 * 00710000 *---------------------------------------------------------------------* 00720000 * RESET FIELDS USED TO RETURN STATUS INFORMATION TO THE CALLER * 00730000 *---------------------------------------------------------------------* 00740000 XC $RC,$RC CLEAR RETURN CODE 00750000 XC $VSRC,$VSRC CLEAR VSAM RETURN CODE 00760000 XC $VSFUNC,$VSFUNC CLEAR VSAM FUNCTION CODE 00770000 XC $VSREAS,$VSREAS CLEAR VSAM REASON CODE 00780000 * 00790000 *---------------------------------------------------------------------* 00800000 * PERFORM REQUESTED FUNCTION * 00810000 *---------------------------------------------------------------------* 00820000 CLC $COMMAND,$OPEN 00830000 BE @OPEN 00840000 * 00850000 CLI $OPENSW,C'O' IS DATASET OPEN? 00860000 BE @COMM02 YES, OTHER COMMANDS ARE VALID 00870000 * 00880000 MVC $RC,=H'22' INDICATE CLOSED DATASET 00890000 B GOBACK 00900000 * 00910000 @COMM02 DS 0H 00920000 CLC $COMMAND,$CLOSE 00930000 BE @CLOSE 00940000 CLC $COMMAND,$READ 00950000 BE @READ 00960000 CLC $COMMAND,$WRITE 00970000 BE @WRITE 00980000 CLC $COMMAND,$REWRITE 00990000 BE @REWRITE 01000000 CLC $COMMAND,$DELETE 01010000 BE @DELETE 01020000 CLC $COMMAND,$STARTEQ 01030000 BE @START 01040000 CLC $COMMAND,$STARTGE 01050000 BE @START 01060000 * 01070000 MVC $RC,=H'20' INDICATE PARAMETER ERROR 01080000 * 01090000 GOBACK DS 0H 01100000 *---------------------------------------------------------------------* 01110000 * RETURN TO CALLING PROGRAM WITH ZERO RETURN CODE IN R15 * 01120000 *---------------------------------------------------------------------* 01130000 L R13,4(,R13) RETRIEVE CALLER'S SAVE AREA 01140000 RETURN (14,12),RC=0 01150000 * 01160000 @OPEN DS 0H 01170000 *---------------------------------------------------------------------* 01180000 * PROCESSING "OPEN" COMMAND FROM CALLER * 01190000 *---------------------------------------------------------------------* 01200000 CLI $OPENSW,C'C' IS DATASET CLOSED? 01210000 BE @OPEN02 YES, OPEN IS VALID 01220000 * 01230000 MVC $RC,=H'21' ERROR: OPEN DATASET 01240000 B GOBACK 01250000 * 01260000 @OPEN02 DS 0H 01270000 CLC $DDNAME,$BLANK IS DDNAME BLANK? 01280000 BNE @OPEN03 NO, CONTINUE 01290000 * 01300000 MVC $RC,=H'28' ERROR: NO DDNAME SUPPLIED 01310000 B GOBACK 01320000 * 01330000 @OPEN03 DS 0H 01340000 *---------------------------------------------------------------------* 01350000 * BUILD ACCESS CONTROL BLOCK IN CALLER'S STORAGE USING MODEL. * 01360000 *---------------------------------------------------------------------* 01370000 MVC IFGACB($ACBLEN),ACBMODEL 01380000 LA R2,IFGACB 01390000 MODCB ACB=(R2),DDNAME=(*,$DDNAME) 01400000 * 01410000 *---------------------------------------------------------------------* 01420000 * BUILD REQUEST PARAMETER LIST BLOCK IN CALLER'S STORAGE USING MODEL. * 01430000 *---------------------------------------------------------------------* 01440000 MVC IFGRPL($RPLLEN),RPLMODEL 01450000 LA R2,IFGRPL 01460000 MODCB RPL=(R2),ACB=(S,IFGACB) 01470000 * 01480000 *---------------------------------------------------------------------* 01490000 * THE COMBINATION OF ORGANIZATION, ACCESS, AND MODE WILL BE USED TO * 01500000 * DERIVE A NUMERIC VALUE WHICH IS USED TO ENSURE VALID PERMUTATIONS. * 01510000 *---------------------------------------------------------------------* 01520000 SR R7,R7 CLEAR TO COMPUTE MODE KEY VALUE 01530000 * 01540000 *---------------------------------------------------------------------* 01550000 * PARSE ORGANIZATION KEYWORD * 01560000 *---------------------------------------------------------------------* 01570000 CLC $ORG,$ESDS 01580000 BE @OES 01590000 CLC $ORG,$RRDS 01600000 BE @ORR 01610000 CLC $ORG,$KSDS 01620000 BE @OKS 01630000 * 01640000 MVC $RC,=H'23' ERROR: UNKNOWN ORGANIZATION 01650000 * 01660000 B GOBACK 01670000 * 01680000 @OES DS 0H 01690000 *---------------------------------------------------------------------* 01700000 * ORGANIZATION = ESDS * 01710000 *---------------------------------------------------------------------* 01720000 ***> LA R7,0 01730000 LA R2,IFGACB 01740000 MODCB ACB=(R2),MACRF=(ADR) 01750000 LA R2,IFGRPL 01760000 MODCB RPL=(R2),OPTCD=(ADR) 01770000 * 01780000 B @OPEN10 01790000 * 01800000 @ORR DS 0H 01810000 *---------------------------------------------------------------------* 01820000 * ORGANIZATION = RRDS * 01830000 *---------------------------------------------------------------------* 01840000 LA R7,9 01850000 LA R2,IFGACB 01860000 MODCB ACB=(R2),MACRF=(KEY) 01870000 LA R2,IFGRPL 01880000 MODCB RPL=(R2),OPTCD=(KEY) 01890000 * 01900000 B @OPEN10 01910000 * 01920000 @OKS DS 0H 01930000 *---------------------------------------------------------------------* 01940000 * ORGANIZATION = KSDS * 01950000 *---------------------------------------------------------------------* 01960000 LA R7,18 01970000 LA R2,IFGACB 01980000 MODCB ACB=(R2),MACRF=(KEY) 01990000 LA R2,IFGRPL 02000000 MODCB RPL=(R2),OPTCD=(KEY) 02010000 * 02020000 @OPEN10 DS 0H 02030000 *---------------------------------------------------------------------* 02040000 * PARSE ACCESS KEYWORD * 02050000 *---------------------------------------------------------------------* 02060000 CLC $ACCESS,$SEQ 02070000 BE @OSEQ 02080000 CLC $ACCESS,$DIR 02090000 BE @ODIR 02100000 CLC $ACCESS,$DYN 02110000 BE @ODYN 02120000 * 02130000 MVC $RC,=H'24' ERROR: UNKNOWN ACCESS 02140000 * 02150000 B GOBACK 02160000 * 02170000 @OSEQ DS 0H 02180000 *---------------------------------------------------------------------* 02190000 * ACCESS = SEQUENTIAL * 02200000 *---------------------------------------------------------------------* 02210000 ***> LA R7,0(,R7) 02220000 LA R2,IFGACB 02230000 MODCB ACB=(R2),MACRF=(SEQ) 02240000 LA R2,IFGRPL 02250000 MODCB RPL=(R2),OPTCD=(SEQ) 02260000 * 02270000 B @OPEN20 02280000 * 02290000 @ODIR DS 0H 02300000 *---------------------------------------------------------------------* 02310000 * ACCESS = DIRECT * 02320000 *---------------------------------------------------------------------* 02330000 LA R7,3(,R7) 02340000 * 02350000 CLC $ORG,$ESDS 02360000 BNE @ODIROK 02370000 * 02380000 MVC $RC,=H'25' ERROR: BAD ACCESS FOR ESDS 02390000 * 02400000 B GOBACK 02410000 * 02420000 @ODIROK DS 0H 02430000 LA R2,IFGACB 02440000 MODCB ACB=(R2),MACRF=(DIR) 02450000 LA R2,IFGRPL 02460000 MODCB RPL=(R2),OPTCD=(DIR) 02470000 * 02480000 B @OPEN20 02490000 * 02500000 @ODYN DS 0H 02510000 *---------------------------------------------------------------------* 02520000 * ACCESS = DYNAMIC * 02530000 *---------------------------------------------------------------------* 02540000 LA R7,6(,R7) 02550000 * 02560000 CLC $ORG,$ESDS 02570000 BNE @ODYNOK 02580000 * 02590000 MVC $RC,=H'25' ERROR: BAD ACCESS FOR ESDS 02600000 * 02610000 B GOBACK 02620000 * 02630000 @ODYNOK DS 0H 02640000 LA R2,IFGACB 02650000 MODCB ACB=(R2),MACRF=(SEQ,DIR) 02660000 LA R2,IFGRPL 02670000 MODCB RPL=(R2),OPTCD=(SEQ) 02680000 * 02690000 @OPEN20 DS 0H 02700000 *---------------------------------------------------------------------* 02710000 * PARSE MODE KEYWORD * 02720000 *---------------------------------------------------------------------* 02730000 CLC $MODE,$INPUT 02740000 BE @OIN 02750000 CLC $MODE,$OUTPUT 02760000 BE @OOUT 02770000 CLC $MODE,$UPDATE 02780000 BE @OBOTH 02790000 * 02800000 MVC $RC,=H'26' ERROR: BAD MODE 02810000 * 02820000 B GOBACK 02830000 * 02840000 @OIN DS 0H 02850000 *---------------------------------------------------------------------* 02860000 * MODE = INPUT * 02870000 *---------------------------------------------------------------------* 02880000 ***> LA R7,0(,R7) 02890000 LA R2,IFGACB 02900000 MODCB ACB=(R2),MACRF=(IN) 02910000 LA R2,IFGRPL 02920000 MODCB RPL=(R2),OPTCD=(NUP) 02930000 * 02940000 B @OPEN30 02950000 * 02960000 @OOUT DS 0H 02970000 *---------------------------------------------------------------------* 02980000 * MODE = OUTPUT * 02990000 *---------------------------------------------------------------------* 03000000 LA R7,1(,R7) 03010000 * 03020000 C R7,=F'16' ORG = RRDS AND ACCESS = DYNAMIC 03030000 BE @OOUTNO OUTPUT NOT PERMITTED 03040000 C R7,=F'22' ORG = KSDS AND ACCESS = DIRECT 03050000 BE @OOUTNO OUTPUT NOT PERMITTED 03060000 C R7,=F'25' ORG = KSDS AND ACCESS = DYNAMIC 03070000 BE @OOUTNO OUTPUT NOT PERMITTED 03080000 * 03090000 LA R2,IFGACB 03100000 MODCB ACB=(R2),MACRF=(OUT) 03110000 LA R2,IFGRPL 03120000 MODCB RPL=(R2),OPTCD=(NUP) 03130000 * 03140000 B @OPEN30 03150000 * 03160000 @OOUTNO DS 0H 03170000 MVC $RC,=H'27' ERROR: BAD MODE FOR ORG/ACCESS 03180000 * 03190000 B GOBACK 03200000 * 03210000 @OBOTH DS 0H 03220000 *---------------------------------------------------------------------* 03230000 * MODE = INPUT/OUTPUT * 03240000 *---------------------------------------------------------------------* 03250000 LA R7,2(,R7) 03260000 LA R2,IFGACB 03270000 MODCB ACB=(R2),MACRF=(OUT) 03280000 LA R2,IFGRPL 03290000 MODCB RPL=(R2),OPTCD=(UPD) 03300000 * 03310000 @OPEN30 DS 0H 03320000 *---------------------------------------------------------------------* 03330000 * FINISH MODIFICATIONS AND OPEN DATASET * 03340000 *---------------------------------------------------------------------* 03350000 BAL R14,MODIFY MODIFY COMMON RPL PARAMETERS 03360000 * 03370000 LA R2,IFGACB 03380000 OPEN ((R2)) 03390000 MVI $OPENSW,C'O' 03400000 * 03410000 B GOBACK 03420000 * 03430000 @CLOSE DS 0H 03440000 *---------------------------------------------------------------------* 03450000 * CLOSE THE DATASET. * 03460000 *---------------------------------------------------------------------* 03470000 * 03480000 LA R2,IFGACB 03490000 CLOSE ((R2)) 03500000 MVI $OPENSW,C'C' 03510000 * 03520000 B GOBACK 03530000 * 03540000 @READ DS 0H 03550000 *---------------------------------------------------------------------* 03560000 * READ RECORD USING KEY/RRN FROM THE DATASET * 03570000 *---------------------------------------------------------------------* 03580000 BAL R14,MODIFY MODIFY COMMON RPL PARAMETERS 03590000 * 03600000 GET RPL=(R2) 03610000 * 03620000 SHOWCB RPL=(R2),FIELDS=RECLEN,AREA=FEEDBACK,LENGTH=4 03630000 L R7,FEEDBACK 03640000 STH R7,$RECLEN 03650000 * 03660000 B GOBACK 03670000 * 03680000 @WRITE DS 0H 03690000 *---------------------------------------------------------------------* 03700000 * WRITE PASSED RECORD TO THE DATASET (LOAD OR INSERTION) * 03710000 *---------------------------------------------------------------------* 03720000 BAL R14,MODIFY MODIFY COMMON RPL PARAMETERS 03730000 * 03740000 SR R7,R7 03750000 CLC $MODE,$UPDATE IF ACB IS OPEN FOR UPDATE 03760000 BE @WRITE20 MUST MODIFY FOR THIS INSERTION 03770000 * 03780000 B @WRITE50 NO NEED TO MODIFY 03790000 * 03800000 @WRITE20 DS 0H 03810000 MODCB RPL=(R2),OPTCD=(NUP) 03820000 L R7,=A(@WRITERS) ADDRESS TO RESTORE DEFAULT 03830000 * 03840000 @WRITE50 DS 0H 03850000 PUT RPL=(R2) 03860000 * 03870000 LTR R7,R7 WAS RPL MODIFIED FOR THIS WRITE? 03880000 BZ GOBACK NO, JUST RETURN 03890000 * 03900000 @WRITERS DS 0H 03910000 * 03920000 SR R7,R7 TO AVOID LOOPING IF ERROR ON MODCB 03930000 MODCB RPL=(R2),OPTCD=(UPD) 03940000 * 03950000 B GOBACK 03960000 * 03970000 @REWRITE DS 0H 03980000 *---------------------------------------------------------------------* 03990000 * REWRITE THE RECORD PREVIOUSLY READ FROM THE DATASET * 04000000 *---------------------------------------------------------------------* 04010000 LA R2,IFGRPL 04020000 * 04030000 SR R3,R3 CLEAR R4 TO LOAD 04040000 LH R3,$RECLEN LENGTH OF RECORD 04050000 * 04060000 MODCB RPL=(R2),RECLEN=(R3),AREALEN=(R3),AREA=(R10) 04070000 * 04080000 PUT RPL=(R2) 04090000 * 04100000 B GOBACK 04110000 * 04120000 @DELETE DS 0H 04130000 *---------------------------------------------------------------------* 04140000 * DELETE THE PREVIOUSLY READ RECORD FROM THE DATASET * 04150000 *---------------------------------------------------------------------* 04160000 LA R2,IFGRPL 04170000 * 04180000 SR R4,R4 CLEAR R4 TO LOAD 04190000 LH R4,$RECLEN LENGTH OF RECORD 04200000 * 04210000 MODCB RPL=(R2),RECLEN=(R3),AREALEN=(R3),AREA=(R10) 04220000 * 04230000 ERASE RPL=(R2) 04240000 * 04250000 B GOBACK 04260000 * 04270000 @START DS 0H 04280000 *---------------------------------------------------------------------* 04290000 * POSITION RECORD POINTER BASED UPON PROVIDED ARGUMENT * 04300000 *---------------------------------------------------------------------* 04310000 BAL R14,MODIFY MODIFY COMMON RPL PARAMETERS 04320000 * 04330000 CLI $COMMAND+5,C'E' KEY 'EQ' REQUESTED 04340000 BE @STARTEQ 04350000 * 04360000 B @STARTGE 04370000 * 04380000 @STARTEQ DS 0H 04390000 * 04400000 MODCB RPL=(R2),OPTCD=(KEQ) 04410000 SR R7,R7 NO NEED TO RESTORE IF ERROR 04420000 * 04430000 B @START50 04440000 * 04450000 @STARTGE DS 0H 04460000 * 04470000 MODCB RPL=(R2),OPTCD=(KGE) 04480000 L R7,=A(@STARTRS) ADDRESS TO RESTORE DEFAULT 04490000 * 04500000 @START50 DS 0H 04510000 * 04520000 POINT RPL=(R2) 04530000 * 04540000 @STARTRS DS 0H 04550000 * 04560000 SR R7,R7 TO AVOID LOOPING IF ERROR ON MODCB 04570000 MODCB RPL=(R2),OPTCD=(KEQ) 04580000 * 04590000 B GOBACK 04600000 * 04610000 MODIFY DS 0H 04620000 *---------------------------------------------------------------------* 04630000 * THIS ROUTINE IS PERFORMED FOR EACH COMMAND TO MODIFY THE RPL * 04640000 * CONTROL BLOCK BASED UPON THE ORGANIZATION, ACCESS, AND OPEN MODE. * 04650000 *---------------------------------------------------------------------* 04660000 ST R14,SAVER14 SAVE RETURN ADDRESS 04670000 * 04680000 LA R2,IFGRPL ADDRESS GENERATED RPL 04690000 * 04700000 SR R3,R3 CLEAR R3 TO LOAD 04710000 LH R3,$RECLEN LENGTH OF RECORD 04720000 * 04730000 SR R4,R4 CLEAR R4 TO CONTAIN KEY ADDRESS 04740000 SR R5,R5 CLEAR R5 TO CONTAIN KEY LENGTH 04750000 * 04760000 CLC $ORG,$ESDS IF ORGANIZATION NOT ESDS 04770000 BNE MOD20 MORE MODCB PARMS TO LOAD 04780000 * 04790000 MODCB RPL=(R2),RECLEN=(R3),AREALEN=(R3),AREA=(R10) 04800000 * 04810000 B MOD80 04820000 * 04830000 MOD20 DS 0H 04840000 LA R4,$RRN ADDRESS RELATIVE RECORD NUMBER 04850000 * 04860000 CLC $ORG,$RRDS IF ORGANIZATION NOT RRDS 04870000 BNE MOD40 MORE MODCB PARMS TO LOAD 04880000 * 04890000 MODCB RPL=(R2),RECLEN=(R3),AREALEN=(R3),AREA=(R10),ARG=(R4) 04900000 * 04910000 B MOD80 04920000 * 04930000 MOD40 DS 0H 04940000 LH R4,$RKP LOAD KEY OFFSET 04950000 AR R4,R10 ADD RECORD ADDRESS 04960000 * 04970000 LH R5,$KEYLEN LOAD KEY LENGTH 04980000 * 04990000 MODCB RPL=(R2),RECLEN=(R3),AREALEN=(R3),AREA=(R10), C05000000 ARG=(R4),KEYLEN=(R5) 05010000 * 05020000 MOD80 DS 0H 05030000 L R14,SAVER14 RELOAD RETURN ADDRESS 05040000 BR R14 05050000 * 05060000 SAVER14 DS F SAVE LOCAL RETURN ADDRESS 05070000 * 05080000 VSERROR DS 0H 05090000 *---------------------------------------------------------------------* 05100000 * ERROR OCCURED DURING VSAM PROCESSING AND EXIT LIST BROUGHT US HERE. * 05110000 * RETRIEVE FEEDBACK INFORMATION AND PLACE IN THE PARAMETER BLOCK TO * 05120000 * RETURN TO CALLER. * 05130000 *---------------------------------------------------------------------* 05140000 MVC $RC,=H'8' INDICATE LOGICAL OR PHYSICAL ERROR 05150000 * 05160000 LA R2,IFGRPL 05170000 SHOWCB RPL=(R2),FIELDS=FDBK,AREA=FEEDBACK,LENGTH=4 05180000 * 05190000 ICM R5,B'1111',FEEDBACK RETRIEVE FEEDBACK CODES 05200000 STCM R5,B'0100',$VSRC+1 AND VSAM RETURN CODE 05210000 STCM R5,B'0010',$VSFUNC+1 AND VSAM FUNCTION CODE 05220000 STCM R5,B'0001',$VSREAS+1 AND VSAM FEEDBACK CODE 05230000 * 05240000 *---------------------------------------------------------------------* 05250000 * STARTGE AND WRITE COMMANDS MODIFY THE RPL, IF AN ERROR OCCURRED * 05260000 * THOSE MODIFICATIONS NEED TO BE RESET. IF R7 IS NOT ZERO, A BRANCH * 05270000 * TO R7 WILL GO TO THE APPROPRIATE RESET CODE. * 05280000 *---------------------------------------------------------------------* 05290000 CLC $COMMAND,$STARTGE 05300000 BE VSERR20 05310000 CLC $COMMAND,$WRITE 05320000 BNE GOBACK 05330000 * 05340000 VSERR20 DS 0H 05350000 LTR R7,R7 IF R7=0 THEN NO RESET NECESSARY 05360000 BZ GOBACK 05370000 * 05380000 BR R7 GO TO RESET MODCB 05390000 * 05400000 VSEOF DS 0H 05410000 *---------------------------------------------------------------------* 05420000 * END OF INPUT OCCURED DURING READ AND THE EXIT LIST BROUGHT US HERE. * 05430000 * PLACE SPECIAL VALUE OF 9999 IN $RC TO INDICATE END OF FILE TO THE * 05440000 * CALLING PROGRAM. * 05450000 *---------------------------------------------------------------------* 05460000 MVC $RC,=H'9999' 05470000 * 05480000 B GOBACK 05490000 * 05500000 *---------------------------------------------------------------------* 05510000 * THE ACCESS CONTROL BLOCK BELOW IS USED AS A MODEL TO BUILD ACB'S * 05520000 * DYNAMICALLY AS REQUIRED TO OPEN FILES FOR THE CALLER. * 05530000 *---------------------------------------------------------------------* 05540000 ACBMODEL ACB DDNAME=VSAMDD,EXLST=EXL001 05550000 * 05560000 *---------------------------------------------------------------------* 05570000 * THE REQUEST PARAMETER BLOCK BELOW IS USED AS A MODEL TO BUILD RPL'S * 05580000 * DYNAMICALLY AS REQUIRED TO PROCESS FILES FOR THE CALLER. * 05590000 *---------------------------------------------------------------------* 05600000 RPLMODEL RPL ACB=ACBMODEL 05610000 * 05620000 *---------------------------------------------------------------------* 05630000 * THE EXIT ROUTINE LIST BLOCK PROVIDES THE ADDRESSES FOR ERROR * 05640000 * HANDLING AND END OF DATASET CONDITIONS. * 05650000 *---------------------------------------------------------------------* 05660000 EXL001 EXLST LERAD=VSERROR,SYNAD=VSERROR,EODAD=VSEOF 05670000 * 05680000 *---------------------------------------------------------------------* 05690000 * FEEDBACK AFTER LOGIC OR I/O ERROR WILL BE RETRIEVED IN THE FULLWORD * 05700000 * BELOW TO BE RETURNED TO THE CALLER. * 05710000 *---------------------------------------------------------------------* 05720000 FEEDBACK DS F 05730000 * 05740000 *---------------------------------------------------------------------* 05750000 * MY REGISTER SAVE AREA * 05760000 *---------------------------------------------------------------------* 05770000 SAVEAREA DS 18F 05780000 * 05790000 *---------------------------------------------------------------------* 05800000 * THE FOLLOWING CONSTANTS ARE USED TO PARSE PARAMETERS PASSED FROM * 05810000 * THE CALLER. * 05820000 *---------------------------------------------------------------------* 05830000 $BLANK DC CL08' ' 05840000 * 05850000 $ESDS DC CL04'ESDS' 05860000 $KSDS DC CL04'KSDS' 05870000 $RRDS DC CL04'RRDS' 05880000 * 05890000 $DIR DC CL10'DIRECT ' 05900000 $SEQ DC CL10'SEQUENTIAL' 05910000 $DYN DC CL10'DYNAMIC ' 05920000 * 05930000 $INPUT DC CL06'INPUT ' 05940000 $OUTPUT DC CL06'OUTPUT' 05950000 $UPDATE DC CL06'UPDATE' 05960000 * 05970000 $OPEN DC CL08'OPEN ' 05980000 $CLOSE DC CL08'CLOSE ' 05990000 $READ DC CL08'READ ' 06000000 $WRITE DC CL08'WRITE ' 06010000 $REWRITE DC CL08'REWRITE ' 06020000 $DELETE DC CL08'DELETE ' 06030000 $STARTEQ DC CL08'STARTEQ ' 06040000 $STARTGE DC CL08'STARTGE ' 06050000 * 06060000 LTORG 06070000 * 06080000 $CCOMM DSECT ACCESSED VIA R8 06090000 *---------------------------------------------------------------------* 06100000 * THE DUMMY SECTION BELOW MAPS THE COMMAND COMMUNICATION PARAMETER * 06110000 * BLOCK PASSED FROM THE CALLING PROGRAM. * 06120000 *---------------------------------------------------------------------* 06130000 $COMMAND DS CL08 COMMAND FUNCTION 06140000 $RC DS H RETURN CODE 06150000 $VSRC DS H VSAM RETURN CODE 06160000 $VSFUNC DS H VSAM FUNCTION CODE 06170000 $VSREAS DS H VSAM REASON CODE 06180000 * 06190000 $FCOMM DSECT ACCESSED VIA R9 06200000 *---------------------------------------------------------------------* 06210000 * THE DUMMY SECTION BELOW MAPS THE DATASET CONTROL PARAMETER BLOCK * 06220000 * PASSED FROM THE CALLING PROGRAM. * 06230000 *---------------------------------------------------------------------* 06240000 * THE PARAMETERS BELOW MUST BE SET BEFORE THE DATASET IS OPENED AND * 06250000 * (GENERALLY) SHOULD NOT BE MODIFIED WHILE THE DATASET IS OPEN. * 06260000 *---------------------------------------------------------------------* 06270000 $DDNAME DS CL08 DD NAME 06280000 $ORG DS CL04 ORGANIZATION (KS/ES/RR) 06290000 $ACCESS DS CL10 ACCESS MODE (DIR/SEQ/DYNAM) 06300000 $MODE DS CL06 MODE (INPUT/OUTPUT/UPDATE) 06310000 $RECLEN DS H RECORD LENGTH 06320000 $RKP DS H KEY OFFSET FROM BEGINNING OF RECORD 06330000 $KEYLEN DS H KEY LENGTH 06340000 $RRN EQU $RKP RELATIVE RECORD NUMBER 06350000 $OPENSW DS CL1 OPEN FLAG (O=OPEN/C=CLOSED) 06360000 DS CL1 FORCE ALIGNMENT 06370000 IFGACB DSECT=NO AREA IN WHICH ACB WILL BE BUILT 06380000 $ACBLEN EQU (*-IFGACB) 06390000 IFGRPL DSECT=NO AREA IN WHICH RPL WILL BE BUILT 06400000 $RPLLEN EQU (*-IFGRPL) 06410000 * 06420000 $RECORD DSECT ACCESSED VIA R10 06430000 *---------------------------------------------------------------------* 06440000 * THE FOLLOWING AREA IS MAPPED TO THE CALLER'S STORAGE WHICH CONTAINS * 06450000 * THE DATA RECORD. THE STORAGE ALLOCATED MUST MATCH THE RECORD * 06460000 * LENGTH SET IN THE FILE PARAMETER BLOCK ABOVE OR IT MAY RESULT IN * 06470000 * DESTRUCTIVE OVERLAP OF OTHER STORAGE IN THE CALLING PROGRAM WHICH * 06480000 * COULD RESULT IN AN ABEND. * 06490000 *---------------------------------------------------------------------* 06500000 $IOAREA DS 0CL500 06510000 * 06520000 R0 EQU 0 06530000 R1 EQU 1 06540000 R2 EQU 2 06550000 R3 EQU 3 06560000 R4 EQU 4 06570000 R5 EQU 5 06580000 R6 EQU 6 06590000 R7 EQU 7 06600000 R8 EQU 8 06610000 R9 EQU 9 06620000 R10 EQU 10 06630000 R11 EQU 11 06640000 R12 EQU 12 06650000 R13 EQU 13 06660000 R14 EQU 14 06670000 R15 EQU 15 06680000 * 06690000 END 06700000