*** Top of Data *** ESDSIO CSECT ********************************************************************** *** THIS PROGRAM MAY BE STATICALLY CALLED BY A COBOL PROGRAM *** TO OPEN, CLOSE OR PUT AN ESDS FILE. *** THE PURPOSE IS TO SAVE THE RBA OF THE LAST PUT RECORD AND *** PASS IT BACK TO THE CALLER IN THE LINK AREA. ********************************************************************** STM R14,R12,12(R13) SAVE REGS IN CALLER'S AREA LR R12,R15 LOAD BASE REG USING ESDSIO,R12 LA R15,SAVEAREA ST R15,8(,R13) LOAD CALLER'S FORWARD POINTER ST R13,4(,R15) LOAD SAVEAREA'S BACKWARD POINTER LR R13,R15 R13 - SAVE AREA ADDR * B TESTREQ DATE & TIME STAMP OBJECT MODULE DC CL8'&SYSDATE',CL1'-',CL8'&SYSTIME' * TESTREQ DS 0H L R2,0(,R1) R2 - LINK AREA ADDR USING LINKAREA,R2 * CLI LINKREQ,C'O' TEST FOR OPEN BE OPENRTN CLI LINKREQ,C'W' TEST FOR WRITE BE WRITERTN CLI LINKREQ,C'C' TEST FOR CLOSE BE CLOSERTN * OPENRTN DS 0H ********************************************************************** *** OPEN THE ESDS FILE ********************************************************************** MVI OPIND,OPENOP SET OPERATION IND TO OPEN * OPEN ESDSFILE OPEN THE ESDS FILE LTR R15,R15 BNZ BADOPCL LOAD THE BAD RETURN CODE * B NOPROB * WRITERTN DS 0H ********************************************************************** *** WRITE AN ESDS RECORD ********************************************************************** MVI OPIND,PUTOP SET OPERATION IND TO PUT * TM 0(R1),X'80' MAKE SURE THERE IS A SECOND ARG BNZ ERROR FOR THE ESDS RECORD AREA * L R3,4(,R1) R3 - ESDS RECORD ADDRESS USING ESDSREC,R3 MVC IOAREA,ESDSREC LOAD ESDS RECORD TO I/O AREA * PUT RPL=ESDSPUT PUT THE RECORD LTR R15,R15 BNZ BADPUT LOAD THE BAD RETURN CODE * MVI OPIND,SHOWOP SET OPERATION IND TO SHOWCB * SHOWCB RPL=ESDSPUT, SAVE THE RECORD'S RBA X AREA=ESDSRBA, IN FULL-WORD ALIGNED AREA X LENGTH=4, X FIELDS=RBA LTR R15,R15 BNZ ERROR * MVC LINKRBA,ESDSRBA LOAD RBA TO LINK AREA B NOPROB * CLOSERTN DS 0H ********************************************************************** *** CLOSE THE ESDS FILE ********************************************************************** MVI OPIND,CLOSEOP SET OPERATION IND TO CLOSE * CLOSE ESDSFILE CLOSE THE ESDS FILE LTR R15,R15 BNZ BADOPCL LOAD THE BAD RETURN CODE * B NOPROB * NOPROB DS 0H ********************************************************************** *** SET STATUS FIELDS TO SPACES ********************************************************************** MVI LINKSTAT,C' ' SET LINK STATUS TO OK MVC LINKRETC,=CL3' ' SET RETURN CODE TO OK * RETURN DS 0H ********************************************************************** *** RETURN TO CALLER ********************************************************************** L R13,4(,R13) RESTORE CALLER'S LM R14,R12,12(R13) REGS XR R15,R15 SET COBOL RETURN-CODE TO ZERO BR R14 * ERROR DS 0H ********************************************************************** *** ERROR PROCESSING ROUTINE ********************************************************************** MVC LINKRETC,=C'999' SET RETURN CODE TO ERROR MVC LINKSTAT,OPIND SET STATUS TO FAILED OPERATION B RETURN * BADOPCL DS 0H ********************************************************************** *** EXIT FROM BAD OPEN/CLOSE *** SAVE THE I/O RETURN CODE FROM THE ACB ********************************************************************** ST R15,SAVR15 SAVE R15 FOR LATER DISPLAY * SHOWCB ACB=ESDSFILE, SAVE THE VSAM RETURN CODE X AREA=RETCODE, IN FULL-WORD ALIGNED AREA X LENGTH=4, X FIELDS=ERROR LTR R15,R15 BNZ ERROR * B LOADCODE * BADPUT DS 0H ********************************************************************** *** EXIT FROM BAD PUT *** SAVE THE I/O FEEDBACK CODE FROM THE RPL ********************************************************************** ST R15,SAVR15 SAVE R15 FOR LATER DISPLAY * SHOWCB RPL=ESDSPUT, SAVE THE VSAM FEEDBACK REASON CODE X AREA=RETCODE, IN FULL-WORD ALIGNED AREA X LENGTH=4, X FIELDS=FDBK LTR R15,R15 BNZ ERROR * B LOADCODE * LOADCODE DS 0H ********************************************************************** *** LOAD RETURN CODE TO BYTES 2-4 OF LINKRETC ********************************************************************** L R10,RETCODE CONVERT RETURN CODE FROM BINARY CVD R10,PACKCDE TO ZONED UNPK LINKRETC+1(3),PACKCDE+6(2) OI LINKRETC+3,X'F0' SET LOW-ORDER ZONE BITS * ********************************************************************** *** FORMAT SAVED R15 INTO A HEX DIGIT IN BYTE 1 OF LINKRETC *** R15 SHOULD NEVER CONTAIN A VALUE > 12 ********************************************************************** L R15,SAVR15 RELOAD R15 OI HEX15,X'F0' ZONE BITS FOR HEX 1-9 CH R15,=H'9' CHECK FOR HEX VALUES A-F BNH STORCODE SH R15,=H'9' ST R15,SAVR15 STORE ADJUSTED R15 OI HEX15,X'C0' ZONE BITS FOR HEX A-F STORCODE DS 0H MVC LINKRETC(1),HEX15 INSERT INTO RETURN CODE * MVC LINKSTAT,OPIND SET STATUS TO FAILED OPERATION B RETURN * ********************************************************************** *** PROGRAM WORK AREA ********************************************************************** SAVEAREA DS 18F REGISTER SAVE AREA * PACKCDE DS D PACKED DECIMAL RETCODE RETCODE DS F VSAM RETURN CODE FROM SHOWCB ESDSRBA DS F RBA OF OUTPUT ESDS RECORD IOAREA DS CL250 ESDS RECORD I/O AREA * OPIND DC C' ' OPERATION INDICATOR OPENOP EQU C'O' CLOSEOP EQU C'C' PUTOP EQU C'P' SHOWOP EQU C'S' * SAVR15 DS F SAVE R15 FOR LATER DISPLAY ORG SAVR15+3 HEX15 DS CL1 HEX DISPLAY OF R15 ORG * ********************************************************************** *** ACCESS CONTROL BLOCK - ESDS FILE ********************************************************************** ESDSFILE ACB MACRF=(ADR,SEQ,OUT) * ********************************************************************** *** REQUEST PARAMETER LIST - ESDS FILE PUT MACRO ********************************************************************** ESDSPUT RPL ACB=ESDSFILE, X AREA=IOAREA, X AREALEN=250, X RECLEN=250, X OPTCD=(ADR,SEQ,SYN,MVE) * ********************************************************************** *** LINK AREA - REQUEST CODE, RBA VALUE, RETURN STATUS ********************************************************************** LINKAREA DSECT LINKRBA DS F LINKREQ DS CL1 LINKSTAT DS CL1 LINKRETC DS CL4 * ********************************************************************** *** I/O AREA ********************************************************************** ESDSREC DSECT DS CL250 * ********************************************************************** 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 * END *** Bottom of Data ***

Copyright © 2003 The Stevens Computing Services Company, Inc.  All rights reserved.