BRK '.ENTRY ' /*Z1STBRK*/; /* PHASE - QRGSF DATE - 06/14/94 */ /*SVP*/ /* PHASE - QRGSI DATE - 04/15/94 */ /*SVP*/ /* PHASE - QRGSC DATE - 09/14/98 */ /*SVP*/ /* PHASE - QRGSO DATE - 10/17/94 */ /*SVP*/ /* PHASE - QRGD1 DATE - 08/31/98 */ /*SVP*/ /* PHASE - QRGAE DATE - 11/30/96 */ /*SVP*/ SETIEXIT .RPGXIEX,.RPXIEXP /*SET UP INVOCATION EXIT PGM*/; B .START /*BEGIN OF PROGRAM */; BRK '.STOP' ; .STOP: ; SUBN(S) .INVOCNT, 1 /*ALLOW CALL TO THIS PGM*/; RTX * /* RETURN */ /*ZSTAR*/; /*START OF THE PROGRAM*/ ; /* STATIC AREA FOR INDIC/FIELDS */ ; /* START OF STRUCTURE POINTED BY .DMPTRLT*/ ; DCL DD .RPGPGM CHAR(1) BDRY(16) INIT; DCL DD .FIRSTSW CHAR(1) INIT('0')/* PGM CALLED BEFORE */; DCL DD .EOJSW CHAR(1) INIT('0') /*PROGRAM WENT TO EOJ*/; DCL DD .DUMPSW CHAR(1) INIT('0') /* DUMP REQUESTED*/; DCL DD .ERRTERM CHAR(1) INIT('0') /*PROGRAM TERMINATED */; DCL DD .INVOCNT ZND(1,0) INIT(Z'0'); DCL DD .INVOCER CHAR(4) INIT('8888'); DCL SYSPTR .RPGXIEX INIT('QRGXINVX', TYPE(PGM,1)) /*INVOCATION EXIT PROGRAM*/ ; DCL DD .INVXLVL BIN(2) INIT(2) /*INTERFACE LEVEL FOR QRGX INVX*/ /*END OF STATIC AREA STRUC TURE*/ ; DCL DD .BLANKS CHAR(140) INIT((140)' '); DCL DD .ZEROS CHAR(30) INIT((30)'0'); DCL CON *ON CHAR(1) INIT('1') /* SET/CHECK INDICATORS ON */; DCL CON *OFF CHAR(1) INIT('0') /* SET/CHECK INDICATORS OF F */; DCL DD .INDIC CHAR(1) BAS(*); DCL DD *INIT CHAR(1) INIT('0') /*START INDIC AREA, DUMMY INDIC*/; DCL DD *INXX CHAR(1) INIT('1') /*INDICATOR ALWAYS ON*/ /*ZSTART*/ ; DCL DD *INKA CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKB CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKC CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKD CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKE CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKF CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKG CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKH CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKI CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKJ CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKK CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKL CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKM CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKN CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKP CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKQ CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKR CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKS CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKT CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKU CHAR(1) INIT('0') /*ZFIXIND*/; DCL DD *INKV CHAR(1) INIT('0') /*ZFIXIND*/ ; DCL DD *INKW CHAR(1) INIT('0') /*ZFIXIND*/ ; DCL DD *INKX CHAR(1) INIT('0') /*ZFIXIND*/ ; DCL DD *INKY CHAR(1) INIT('0') /*ZFIXIND*/ ; DCL DD .INLVLS CHAR(1) INIT('0'); DCL DD *INLR CHAR(1) DEF(.INLVLS) POS(1) /*ZLVLIN1*/; /* DECLARE FOR THE GENERAL INDICATORS*/ DCL DD *IN(99) CHAR(1) INIT((99)'0'); DCL DD .INALL CHAR(99) DEF(*IN) /*ZINDARR*/; DCL DD *IN99 CHAR(1) DEF(*IN) POS(99) /*ZGENIND*/; DCL DD .INCKEYS CHAR(24) DEF(*INKA) POS(1); DCL DD .INCKEYA(24) CHAR(1) DEF(*INKA) POS(1) /*ZCKEY*/; /* FIELD DEFINITIONS */ /*ZFLDSTRT*/ DCL DD COUNT PKD (05,0) INIT(P'0') /*ZFLDDCL*/; BRK '500 ' /* FILE INFORMATION DATA S TRUCTURE */; DCL SPCPTR .FDS0001 INIT(.F01XFLN); DCL DD FILINF CHAR(0512) BAS(.FDS0001) /*ZINFDS*/; DCL DD .WORKBC CHAR(4) BDRY(4) * BINARY WORK AREA */; DCL DD .WORKB2 BIN(2) DEF(.WORKBC) /* HALF WORD */ ; DCL DD .WORKB3 BIN(2) DEF(.WORKBC) POS(3)/*HWRD */; DCL DD .WORKB4 BIN(4) DEF(.WORKBC) /* FULL WORD */ ; DCL DD .WORK CHAR(0256) BDRY(4) INIT; DCL DD WORK. CHAR(0260) DEF(.WORKBC); DCL DD .INVMARK CHAR(4) /*INITIAL INV MARK*/ ; DCL DD .CURROP CHAR(5); DCL DD .STRF2WK CHAR(0001) /* Temp string F2 */; DCL DD .INZSRSW CHAR(1) INIT('0') /* INZSR BEEN COMPLTD?*/; DCL DD .I BIN(4) BDRY(4) /* ARRAY LOOP CTRL */; DCL DD .FILEIDX BIN(2) BDRY(2) /* FILE LOOP */; DCL DD .P1 BIN(2) BDRY(2) /* GENERAL USAGE HALF WORD */; DCL DD .ARRSIZE BIN(4) BDRY(2) /* ARRAY LOOP CONTROL */ ; DCL DD .BINTEMP BIN(4) BDRY(2) /* ARRAY LOOP CONTROL */ ; DCL DD .BININDX BIN(4) BDRY(2) /* INDEX LOOP CONTROL */ ; DCL DD .F2INDX BIN(4) BDRY(2) /* INDEX LOOP CONTROL */ ; DCL DD .F1INDX BIN(4) BDRY(2) /* INDEX LOOP CONTROL */ ; DCL DD .RINDX BIN(4) BDRY(2) /* INDEX LOOP CONTROL */ ; DCL DD .TEMPSBS BIN(4) BDRY(2) /* INDEX LOOP CONTROL */ ; DCL DD .SCANTMP BIN(4) BDRY(2) /* INDEX LOOP CONTROL */ ; DCL DD .SCANOFF BIN(4) BDRY(2) /* Temp var for SCAN */ ; DCL DD .ENDOFF2 BIN(4) BDRY(2); DCL DD .ENDOFRF BIN(4) BDRY(2); DCL SPCPTR .XLATPTR; DCL SPCPTR .XLATPT1; DCL INSPTR ..CLRRTN /*CLEAR PTR*/; DCL INSPTR ..RSTRTN /*RESET PTR*/; DCL DD .P2 BIN(2) BDRY(2) /* GENERAL USAGE */ ; DCL DD .PX BIN(4) BDRY(4) /* GENERAL USAGE */ ; DCL DD .PY BIN(4) BDRY(4) /* GENERAL USAGE */ ; DCL SPCPTR .INITPTR INIT(.FACELVL) /*ERR PARM PTR*/; DCL SPCPTR .NULLSPC /*NULL SPC PTR*/ /*ZWKFLDS*/; DCL DD *DATE ZND(8,0) /* *DATE FIELDS */; DCL DD UDATE ZND(6,0) /* UDATE FIELD */; DCL DD *YEAR ZND(4,0) DEF(*DATE) POS(5); DCL DD UYEAR ZND(2,0) DEF(*YEAR) POS(3); DCL DD *MONTH ZND(2,0) DEF(*DATE) POS(1) ; DCL DD UMONTH ZND(2,0) DEF(*MONTH) POS(1); DCL DD *DAY ZND(2,0) DEF(*DATE) POS(3); DCL DD UDAY ZND(2,0) DEF(*DAY) POS(1) /*ZUDATMDY*/ ; DCL DD M.UDATE ZND(6,0) DEF(UDATE) POS(1); DCL DD M.UDAY ZND(2,0) DEF(UDAY) POS(1); DCL DD M.UMONTH ZND(2,0) DEF(UMONTH) POS(1); DCL DD M.UYEAR ZND(2,0) DEF(UYEAR) POS(1); DCL DD M.*DATE ZND(8,0) DEF(*DATE) POS(1); DCL DD M.*DAY ZND(2,0) DEF(*DAY) POS(1); DCL DD M.*MONTH ZND(2,0) DEF(*MONTH) POS(1); DCL DD M.*YEAR ZND(4,0) DEF(*YEAR) POS(1) /*ZUDATE*/; BRK 'PROG DS ' /* PROGRAM INFORMATION DAT A STURCTURE */; DCL DD .PGMERMD CHAR(10) INIT /*NAME OF THIS PROGRAM*/; DCL DD .PGMERST ZND(5,0) INIT(Z'0') /*STATUS*/ ; DCL DD .PGMPROR ZND(5,0) INIT(Z'0') /*PREVIOUS STATUS NUMBER*/; DCL DD .PGMERSQ CHAR(8) INIT /*SEQUENCE NUMBER*/; DCL DD .PGMERRN CHAR(8) INIT /*ROUTINE*/; DCL DD .PGMNUMP ZND(3,0) INIT(Z'0') /*NUM PARMS PASSED*/; DCL DD .PGMEXTP CHAR(3) INIT /*EXCEPTION TYPE*/; DCL DD .PGMEREX CHAR(4) INIT /*EXCEPTION NUMBER*/ ; DCL DD .PGMERIN CHAR(4) INIT /*MI/ODT NUMBER*/; DCL DD .PGMERAD CHAR(30) INIT /*WORK AREA FOR MSGS*/ /*ZPGMDS*/ ; DCL DD .PGMERCX CHAR(10) INIT /*LIB NAME FOR PROGRAM*/; DCL DD .PGMERA CHAR(80) INIT /*RTRVD EXCEPTION DATA*/; DCL DD .PGMSVID CHAR(4) INIT /*SAV EXCID FOR QRGXSIGE*/; DCL DD * CHAR(24) INIT /*UNUSED*/ ; DCL DD .PGMJCNT ZND(2,0) INIT /*USER CENTURY*/; DCL DD .PGMERFN CHAR(08) INIT; DCL DD .PGMERFL CHAR(35) INIT; DCL DD .PGMJOBN CHAR(10) INIT; DCL DD .PGMUSRN CHAR(10) INIT; DCL DD .PGMWK# ZND(6,0) INIT; DCL DD .PGMJTME ZND(6,0) INIT; DCL DD .PGMERDT ZND(6,0) INIT(Z'0'); DCL DD .PGMERTM ZND(6,0) INIT(Z'0'); DCL DD .PGMERCD CHAR(6) INIT('122900'); DCL DD .PGMERCT CHAR(6) INIT('221648'); DCL DD .PGMERLV CHAR(4) INIT('0001'); DCL DD .PGMSRCF CHAR(10) INIT('QRPGSRC '); DCL DD .PGMSRCL CHAR(10) INIT('LSVALGAARD'); DCL DD .PGMSRCM CHAR(10) INIT('MYINVITE '); DCL DD * CHAR(096) INIT /*UNUSED*/; DCL DD ZPGMSTUS CHAR(400) DEF(.PGMERMD) ; DCL DD .DSDEF CHAR(0001) DEF(.PGMERMD) /*ZPGMDS01*/; BRK '.DUMP' ; .DUMP: /*QSYS0*/; /*LINK TO DUMP PROGRAM*/ ; DCL SYSPTR .DMPCALL INIT('QRGXDUMP',TYPE(PGM,1)); DCL SPCPTR .DMPPTRS INIT(.DMPTRLT); DCL SPCPTR .DMPTRLT INIT(.RPGPGM); DCL SPCPTR * INIT(.PGMERMD); DCL SYSPTR .DMPPGMP /*LOC PROGRAM*/; DCL DD * BIN(4) INIT(0001); DCL DD .TEMPOPC CHAR(1) INIT('0'); DCL DD .DMPTYPE CHAR(1) INIT; DCL DD * CHAR(10) INIT; DCL DD .DMPTITL CHAR(1) INIT('0'); DCL DD * CHAR(1) INIT /*UNUSED*/ ; DCL DD * BIN(4) INIT(0240); DCL DD * CHAR(06) INIT /*UNUSED*/ ; DCL DD .DMPTLE CHAR(132) INIT; DCL SPCPTR * INIT(.F01FIB); CPYBWP .DMPPGMP,.ACTPTR /*LOC PROGRAM*/; CPYBLA .CALLSW,*ON; CPYNV .FACELVL,3 /*INTERFACE LVL*/; SETIP .CALLERR,.ERRDMP /*GO TO IF ERR*/; CALLX .DMPCALL,.DMPLIST,*; CMPNV(B) .RLSTATS,970/EQ(.ERA); CMPNV(B) .RLSTATS,0/NEQ(.ERRDMP); CPYBLA .CALLSW,*OFF; /*END OF DUMP*/ /*QSYSDMPA*/ ; B .DMPRTN; .ERRDMP: /*FAILURE IN CALLING DUMP* / ; CPYBLA .CALLSW,*OFF /*RESET ERR SW*/; CPYBLA .PGMPROR,.PGMERST /*SAVE PRIOR STATUS*/; CPYBLA .PGMERST,C'00299' /*DUMP FAILED*/ ; CPYBLA .TYPERR,'P'; CPYBLA .SAVPSTS,.PGMERST; CMPBLA(B) .DUMPSW,*ON/EQ(.ERR); CMPBLA(B) .TERRSW,*ON/EQ(.ERR); B .ERX; DCL DD .TERRSW CHAR(1) INIT('0'); DCL INSPTR .DMPRTN /*QSYS3*/; /* PHASE - QRGCR DATE - 08/26/93 */ /*SVP*/ ; /* PHASE - QRGC1 DATE - 11/17/95 */ /*SVP*/ ; BRK '*GETIN'; *GETIN: /*BEGIN OF GET INPUT RECOR D*/; CPYBLA .PGMERRN,'*GETIN ' /*ZDRBEG*/ ; CMPBLA(B) *INLR,*OFF/EQ(.DRLROFF) /* LR OFF?*/; CPYBREP .INLVLS,*ON /* SET ON ALL LEVEL INDICA TORS */; B *TOTC /* GOTO TOTAL CALCS */; .DRLROFF:; CPYBREP .INLVLS,*OFF /* SET OFF L1-L9,LR */ /*ZDLVLCK*/; CMPBLA(B) .LVLSW,*ON/EQ(*TOTC) /* BYPASS SW */ /*ZDRL03*/ ; CPYBLA .LVLSW,*ON /* DO TOTALS, START NEXT C YCLE*/ ; B *OFL; DCL DD .LVLSW CHAR(1) INIT('0') /*ZDRL05*/ ; BRK 'A000000 '; .DRT0001: /* DETERMINE RECORD TYPE - FILE 'MYDSPF ' */; SETSPP .FIBPTR,.F01FIB /* LOCATE FIB */; CPYBWP .BUFPTR,.U01BUFI /*INPUT I/O AREA */ /*ZRECSTRT*/; CMPBLA(B) .IOFZFNM,C'DUMMY '/NEQ(.DTL0001) /*FORMAT NAME */ /*ZRECDDF*/; CPYBLA .F01XRCN,'DUMMY ' /*SET RECORD NAME IN FEEDB ACK AREA*/ /*ZSETRN*/ ; SETSPP .F01RIDP,*INIT /* ADDRESS OF RECORD ID IN DICATOR */ /*ZRECIND*/; CPYNV .F01NFET,0001 /*ZFLDEXTN*/; B .DRTRTN /* RETURN TO GETIN */ /*ZDRTN*/; .DTL0001: /* CHECK THIS RECORD TYPE */ /*ZRIDLBL*/; BRK 'B000000 '; CMPBLA(B) .IOFZFNM,C'SCREEN '/NEQ(.DTL0002) /*FORMAT NAME */ /*ZRECDDF*/; CPYBLA .F01XRCN,'SCREEN ' /*SET RECORD NAME IN FEEDB ACK AREA*/ /*ZSETRN*/ ; SETSPP .F01RIDP,*INIT /* ADDRESS OF RECORD ID IN DICATOR */ /*ZRECIND*/; CPYNV .F01NFET,0002 /*ZFLDEXTN*/; B .DRTRTN /* RETURN TO GETIN */ /*ZDRTN*/; .DTL0002: /* CHECK THIS RECORD TYPE */ /*ZRIDLBL*/; CPYBLA .FIBXSTS,'01011' /*UNDEFINED REC TYPE*/; CPYBLA .FIBRCSW,*OFF /* NEED NEW RECORD IF CONT INUE */; CPYNV .FIBNFET,0 /* NO FIELD EXTRACT */; B .DMEXGO /* BRANCH TO ERROR ROUTINE */ /*ZBRIDERR*/; DCL INSPTR .DRTRTN /* RETURN FROM DET REC TYP E */; /* IDL (BRANCH TABLE) FOR DETERMINE RECORD TYPE */ ; DCL IDL .DRTYPE /*ZDRTIDL1*/ (.DRT0001 /*ZDRTIDL2*/ ) /* END OF LIST */ /*ZDRTIDL3*/; DCL INSPTR .IEFRTN /* FLD EXTRACT RETURN */; /* IDL (BRANCH TABLE) FOR FIELD EXTRACT */ ; DCL IDL .FLDETRT /*ZFIELDE1*/ (.IEF0001 /*ZFIELDE2*/ ,.IEF0002 /*ZFIELDE2*/ ) /* END OF LIST */ /*ZFIELDE3*/; BRK '.ERX '; .ERX: /* ERROR ROUTINE */; CPYBLA .TYPERR,'P' /*PROG ERR NOT FILE ERR*/ ; CPYBLA .SAVPSTS,.PGMERST /*SAVE PROG STATUS*/ /*ZERRL1*/ ; CMPPTRT(B) .FIBPTR, */EQ(=+3); CPYBLA .PGMERFN,.FIBNAME /*LAST FILE USED*/; CPYBLA .PGMERFL,.FIBXSET /*STATUS OF FILE*/; : /*ZERRL1A*/; CMPBLA(B) .TERRSW,*ON/EQ(.ERXERR) /*STOP LOOP IN ERR HANDLIN G*/; CPYBLA .TERRSW,*ON; B .ERR /* TERMINATE PROGRAM */; .ERXERR:; CPYBLA .SAVPSTS,'09998' /*INTERNAL ERROR*/; B .ERR /* TERMINATE PROGRAM */ /*ZERRL3*/ ; /* ROOT PHASE GENERATES THE FOLLOWING CODE*/ /*ZROOTMSG*/ ; BRK '*TOTC '; *TOTC: /* BEGIN OF TOTAL CALCULAT IONS */ ; CPYBLA .PGMERRN,'*TOTC ' /*ZTC*/; /* ROOT PHASE GENERATES THE FOLLOWING CODE*/ /*ZROOTMSG*/ ; BRK '*TOTL '; *TOTL: /* BEGIN OF TOTAL LINES */ ; CPYBLA .PGMERRN,'*TOTL ' /*ZTL*/; /* ROOT PHASE GENERATES THE FOLLOWING CODE*/ /*ZROOTMSG*/ ; BRK '*OFL '; *OFL: /* TOTAL LINE EPILOG*/; CPYBLA .PGMERRN,'*OFL ' /*ZOFL*/; CMPBLA(B) *INLR,*ON/EQ(.END) /* END OF PROGRAM*/ /*ZCKLR*/; BRK '*DETC '; *DETC: /* BEGIN OF DETAIL CALCULA TIONS */ ; CPYBLA .PGMERRN,'*DETC ' /*ZDC*/; /* PHASE - QRGGC DATE - 11/30/96 */ /*SVP*/ ; /* GC DETAIL BASE CALC CODE GEN */ ; BRK '700 '; /* PHASE - QRGCC DATE - 11/30/96 */ /*SVP*/ ; .DOF0001:; CMPBLA(B) *INKC,C'0' /NEQ(.ELF0001) ; .BLF0001:; BRK '800 '; /* PHASE - QRGAC DATE - 08/29/91 */ /*SVP*/ ; ADDN (S) COUNT,P'1'; /* QRGGC 11/30/96 */ ; BRK '900 '; /* PHASE - QRGIC DATE - 01/15/98 */ /*SVP*/ ; CPYBLA .CURROP,C'WRITE' /* SET OP */ /*ZIOSUR*/ ; SETSPP .FIBPTR,.F01FIB /* LOCATE FIB */ /*ZIOSUB*/ ; CPYBLA .F01EIND ,*OFF /* SET ERROR INDIC COND */ /*ZIOB*/; CMPBLA(B) .F01OPEN,*ON/EQ (.IOD0002) /*ZIOSUPB*/; CPYBLA .F01XSET , C'00000WRITER*DETC 900 SCREEN ' /*ZIOSUA*/ ; B .DMEXL2 /* ERROR IF NOT OPEN*/; .IOD0002: /*ZIOSUPC*/; CALLI SCREEN ,*,.LINERTN /*ZEXP*/; CPYBLA .EXTRECN,C'SCREEN ' /*ZEXT*/; CPYBLA .F01XSET , C'00000WRITER*DETC 900 SCREEN ' /*ZIOSUA*/ ; CALLI .XRVRW01,*,.DRIVRTN /*ZICALLI*/; /* QRGGC 11/30/96 */ ; BRK '1000 '; /* PHASE - QRGIC DATE - 01/15/98 */ /*SVP*/ ; CPYBLA *IN99,*OFF /*ZSETIND*/; CPYBLA *IN99,*OFF /*ZSETIND*/; CPYBLA .F01XSET ,C'00000READ F*DETC 1000 ' /*ZIOSUA*/ ; SETSPP .FIBPTR,.F01FIB /* LOCATE FIB */ /*ZIOSUB*/ ; CPYBLA .F01EIND ,*ON /* SET ERROR INDIC COND */ /*ZIOB*/; SETIP .DRIVRTN,.IOD0003 /*ZIOBX*/; CMPBLA(B) .F01OPEN,*OFF/EQ(.DMEXL2) /* ERROR IF NOT OPEN*/ /*ZIOSUPA*/; CPYBLA ..MDFNDI,*OFF /*RESET NDI CONDITION*/ /*ZMDFNDI*/; B .DRVFR01; .IOD0003: /*ZIO1*/; CMPBLA(B) ..MDFNDI,*ON/NEQ(.OID0001) /*NO DEV INVITED ON*/; CPYBLA *IN99,..MDFNDI ; .OID0001: /*ZMDFIO2*/; CMPNV(B) .F01XSTS,P'00100'/LO (.OID0003) /*ERROR OCURRED*/; CPYBLA *IN99,*ON /* SET ON ERROR INDICATOR */; B .IOD0004; .OID0003: /*ZIO7*/; CMPBLA(B) ..MDFNDI,*ON/EQ(.OID0002) /*ZMDFIO5*/; SETIP .DRTRTN,.IOD0005; B .DRTYPE(.F01NDRT) /*DETERMINE RECORD TYPE*/ ; .IOD0005: /*ZIO6*/; CPYBLA .F01RIDP->.INDIC,*ON /* SET RECORD ID */; SETIP .IEFRTN,.OID0002; B .FLDETRT(.F01NFET) /*EXTRACT FIELDS*/ /*ZIO6 /* EXTRACT FIELDS * / /*ZIO6A*/; .OID0002: /*ZLABL*/; .IOD0004: /*ZLABL*/; /* QRGGC 11/30/96 */ ; BRK '1100 '; /* PHASE - QRGCC DATE - 11/30/96 */ /*SVP*/ ; B .DOF0001 /*ZBR*/; .ELF0001:; BRK '1200 '; /* PHASE - QRGMC DATE - 10/05/95 */ /*SVP*/ ; CPYBRA *INLR,C'1'; /* QRGGC 11/30/96 */ ; /* ROOT PHASE GENERATES THE FOLLOWING CODE*/ /*ZROOTMSG*/ ; B *DETL /*SEPERATES BRK POINTS,LAS T DCALC AND DLINE*/; BRK '*DETL '; *DETL: /* BEGIN OF DETAIL LINES * / ; CPYBLA .PGMERRN,'*DETL ' /*ZDL*/; /* ROOT PHASE GENERATES THE FOLLOWING CODE*/ /*ZROOTMSG*/ ; B *GETIN /* GOTO GET NEXT RECORD */ /*ZDLEND*/ ; /* PHASE - QRGGO DATE - 12/06/96 */ /*SVP*/ /************************************* GEN TIME - O ********/ /*ZCOMENT*/ ; DCL INSPTR .LINERTN /*EXCPTION RETURN POINTER* / /*ZDCLLRT*/; /* SCREEN RECORD OUTPUT ***********************/ /*ZFLCOM*/ ; /* FOR FILE MYDSPF ***********************/ /*ZFLCOM*/ ; ENTRY SCREEN INT /*ZLABX*/; BRK 'C000000 ' /*BRK POINT*/ /*ZBRKPT*/ ; /* SCREEN RECORD OUTPUT FOR FILE MYDSPF */ /*ZFLCOM*/ ; SETSPP .FIBPTR,.F01FIB /*SET FIB PTR*/ /*ZFIBPT*/ ; CPYBLA .EXTRECN,'SCREEN ' /*RECORD NAME*/ /*ZRECNAME*/; CPYBWP .BUFPTR,.U01BUFO /*LOCATE BUFFER*/ /*ZBUFADD*/; CPYBLA .BUFFER(1:ZL,.F01PPRL),.BLANKS /*ZCLRBUF*/; BRK 'C000001 ' /*BRK POINT*/ /*ZBRKPT*/ ; CVTNC .BUFFER(0001:0005), COUNT ,X'02000500000000' /*NUM TO CHAR*/ /*ZNNUM*/; B .LINERTN /*BRANCH*/ /*ZUNBR*/; /* PHASE - QRGGI DATE - 08/31/98 */ /*SVP*/ ; .IF0001E: /*DUMMY EXTRACT*/ /*ZRECLAB*/; .IEF0001: /*DUMMY EXTRACT*/ /*ZEXTRLAB*/; BRK 'A000000 ' /*BRK POINT*/ /*ZBRKPT*/ ; SETSPP .FIBPTR,.F01FIB /*SET FIB PTR*/ /*ZFIBPT*/ ; CPYBLAP .INCKEYS,*OFF,*OFF /*SET KEYS OFF*/; CMPNV(B) .F01CMDK,0/EQ(.IGI0001) /*NO KEY*/ ; CPYBLA .INCKEYA(.F01CMDK),*ON /*SET KEY ON*/; .IGI0001: /*ZCMDKEY*/; CPYBWP .BUFPTR,.U01BUFI /*LOCATE BUFFER*/ /*ZBUFADD*/; B .IEFRTN /*RETURN*/ /*ZRETURN*/; .IF0002E: /*SCREEN EXTRACT*/ /*ZRECLAB*/; .IEF0002: /*SCREEN EXTRACT*/ /*ZEXTRLAB*/; BRK 'B000000 ' /*BRK POINT*/ /*ZBRKPT*/ ; SETSPP .FIBPTR,.F01FIB /*SET FIB PTR*/ /*ZFIBPT*/ ; CPYBLAP .INCKEYS,*OFF,*OFF /*SET KEYS OFF*/; CMPNV(B) .F01CMDK,0/EQ(.IGI0002) /*NO KEY*/ ; CPYBLA .INCKEYA(.F01CMDK),*ON /*SET KEY ON*/; .IGI0002: /*ZCMDKEY*/; CPYBWP .BUFPTR,.U01BUFI /*LOCATE BUFFER*/ /*ZBUFADD*/; B .IEFRTN /*RETURN*/ /*ZRETURN*/; /* PHASE - QRGGB DATE - 08/31/98 */ /*SVP*/ ; /* PHASE - QRGGB DATE - 11/30/96 */ /*SVP*/ ; BRK 'I/O DCLS'; DCL SPCPTR .FIBPTR /* LOCATE FIB */; DCL SPCPTR .UFCBPTR /* LOCATE UFCB */; DCL SPCPTR .ODPBPTR /* LOCATE ODP */; DCL SPCPTR .BUFPTR /* LOCATE I/O BUFFER */; DCL SPCPTR .IOFDBEX /* LOCATE I/O FDBACK EXTEN */; DCL SPCPTR .DMCENTR(32767) BAS(.SEPT); DCL SPCPTR ..MDFDVP INIT(..MDFDEV) /*PTR TO DEVICE NAME*/; DCL DD ..MDFDEV CHAR(10) /*DEVICE NAME PARM*/ ; DCL DD .FIBI CHAR(3) /*DEFAULT INDICATOR BKT*/ ; DCL DD .NULLCL CHAR(1) INIT(X'FF') /*NO CONTROL LIST*/; DCL DD .DMCLINK BIN(2) /*LOC DEVICE TABLE*/ ; DCL DD .BUFFER CHAR(00116) BAS(.BUFPTR) /*NAME I/O BUF*/; DCL INSPTR .DRIVRTN /* RETURN FROM DRIVERS */ ; /* I/O OPERAND LIST AND COMMON POINTERS */ ; DCL SYSPTR .IOEPTR /* ENTRY POINTER FOR DATA MAN I/O */ ; DCL SPCPTR .IOOPTR /* LOCATE GET/PUT OPTIONS */; DCL SPCPTR .IOCPTR /* LOCATE CONTROL FUNCTION S */; DCL OL .IOPARM(.UFCBPTR,.IOOPTR,.IOCPTR) /* OPERAND LIST */ /*ZCODE1*/ ; DCL DD .ZBUFLEN BIN(4); DCL DD .VBUFFER CHAR(00116); DCL SPCPTR .VBUFPTR INIT(.VBUFFER) /*NAME OF VAR LEN BUF*/; DCL SYSPTR .RPGXTRC INIT('QRNXXTRC',TYPE(PGM,1)) /*EXTRACT RESPONSE POSITIO N*/; DCL DD .XTCFMT CHAR(10); DCL DD .XTCRSP BIN(4) ; DCL DD .XTCFLIB CHAR(20); DCL DD .XTCFILE CHAR(10) DEF(.XTCFLIB) POS(1) ; DCL DD .XTCLIB CHAR(10) DEF(.XTCFLIB) POS(11) ; DCL SPCPTR .PTRFILE INIT(.XTCFLIB); DCL SPCPTR .PTRFMT INIT(.XTCFMT); DCL SPCPTR .PTRRSP INIT(.XTCRSP); DCL OL .XTCPRM(.PTRFILE,.PTRFMT,.PTRRSP) /*FILE, FNSE*/ /*ZCODE2*/ ; /* ----- ODP DEVICE NAME LIST ----- */ ; DCL DD .DMCDVL(33284) CHAR(1) BAS(.FIBEPTR); DCL DD .DMCNDEV BIN(2) DEF(.DMCDVL) POS(3) ; DCL DD .DMCDENT(256) CHAR(130) DEF(.DMCDVL) POS(5) /*ARRAY OF DNL ENTRIES IN ODP DNL*/; /*----- STRUCTURE OF ARRAY .DMCDENT (IN ODP DEVICE NAME LIST) */ ; /*----- EACH ENTRY IN THE ARRAY IS FOR ONE DEVICE IN THE ODP. */ ; DCL DD .DMCDVNM(256) CHAR(10) DEF(.DMCDENT) AEO(130) /*DEVICE NAME*/ ; /*----- DMC ENTRY POINTS */ ; DCL DD .DMCGET(256) BIN(2) DEF(.DMCDENT) POS(21) AEO(130) /*GET NEXT*/; DCL DD .DMCGETD(256) BIN(2) DEF(.DMCDENT) POS(23) AEO(130) /*GET RRN*/; DCL DD .DMCGETK(256) BIN(2) DEF(.DMCDENT) POS(25) AEO(130) /*GET KEY*/; DCL DD .DMCPUTD(256) BIN(2) DEF(.DMCDENT) POS(27) AEO(130) /*PUT RRN*/; DCL DD .DMCPUT(256) BIN(2) DEF(.DMCDENT) POS(29) AEO(130) /*PUT*/; DCL DD .DMCPTGT(256) BIN(2) DEF(.DMCDENT) POS(31) AEO(130) /*PUT/GET*/; DCL DD .DMCUPD(256) BIN(2) DEF(.DMCDENT) POS(33) AEO(130) /*UPDATE*/ ; DCL DD .DMCDELT(256) BIN(2) DEF(.DMCDENT) POS(35) AEO(130) /*DELETE*/ ; DCL DD .DMCFEOD(256) BIN(2) DEF(.DMCDENT) POS(37) AEO(130) /*FEOD*/; DCL DD .DMCRLSE(256) BIN(2) DEF(.DMCDENT) POS(45) AEO(130) /*RELEASE*/; /*----- END OF DMC ENTRY POINTS */ ; DCL DD .DMCROW(256) BIN(2) DEF(.DMCDENT) POS(73) AEO(130) /*# OF ROWS*/; DCL DD .DMCCOL(256) BIN(2) DEF(.DMCDENT) POS(75) AEO(130) /*# OF COLUMNS*/; DCL DD .DMCBF(256) CHAR(2) DEF(.DMCDENT) POS(77) AEO(130) /*BIT FLAGS*/; /* BIT 1 - DISPLAY ALLOW BLINK CAPABILITY */ ; /* BIT 2 - DEVICE LOCATION (0-LOCAL, 1-REMOTE) */ ; /* BIT 3 - ACQUIRE STATUS (0-NOT ACQ, 1-ACQ) */ ; /* BIT 4 - INVITE STATUS (0-NOT INVITED,1-INVITED) */ ; /* BIT 5 - DATA AVAILABLE STATUS */ ; /* BIT 6 - SESSION STATUS */ ; /* BIT 7 - REQUESTER DEVICE (0-NO, 1-YES) */ ; /* BITS 8-16 RESERVED */ ; /* ----- END OF ODP DEVICE NAME LIST ----- */ ; DCL SPC .DMCODP BAS(.ODPBPTR) /* BEGIN OF ODP*/; DCL DD * CHAR(16) DIR ; DCL DD .DMCOFFS BIN(4) DIR /* OFFSET TO DEVICE TABLE* / /*ZODP*/; DCL DD .DUMREC CHAR(0100) /*NEED ADDRESSING FOR U1-U 8 CONTROLED FILES*/ /*ZDUMREC*/; /* PHASE - QRGGB DATE - 02/01/94 */ /*SVP*/ ; BRK 'FIBDSECT'; DCL SPC .FIBFIB /*ZFIB*/ BAS(.FIBPTR) /* DSECT FOR FIB */ /*ZCODE2*/ ; DCL DD .FIBNAME CHAR(16) BDRY(16) DIR ; DCL SPCPTR .FIBUFCB DIR /*INIT(.UFCBIB) ADDRESS OF UFCB */; DCL SPCPTR .FIBEPTR DIR /* ENTRY POINT */; DCL SPCPTR .FIBOPTN DIR /*INIT(.FOLSTIB) LOCATE GET/PUT OPTIONS */; DCL SPCPTR .FIBCTL DIR /*INIT(.FCLSTIB) LOCATE CONTROL FUNCTIONS */; DCL SPCPTR .FIBRIDP DIR /*ZCODE4*/ /*INIT(*INIT) RECORD ID I NDICATOR */; DCL SPCPTR .FIBUIND DIR /* INIT(*****) ICATOR */; DCL SPCPTR .FIBOFLI DIR /* INIT(*****) INDICATOR */; DCL DD .FIBFNUM BIN(2) DIR BDRY(2) /*INIT(* FILE*/; DCL DD .FIBNDRT BIN(2) DIR BDRY(2) /*INIT(0 IDL ENTRY */; DCL DD .FIBNFET BIN(2) DIR BDRY(2) /*INIT(0 XTRACT IDL ENTRY */; DCL DD .FIBNLKA BIN(2) DIR BDRY(2) /*INIT(* D EXTRACT IDL */; DCL DD .FIBNDRV BIN(2) DIR BDRY(2) /*INIT(* ER IN DRIVER IDL */; DCL DD .FIBLINE BIN(2) DIR BDRY(2) /* INIT( NUMBER */ /*ZCODE4AA*/; DCL DD .FIBEOPG BIN(2) DIR BDRY(2) /* INIT( VERFLOW AREA */ ; DCL DD .FIBPGLN BIN(2) DIR BDRY(2) /* INIT( PAGE */; DCL DD .FIBRRNM BIN(4) DEF(.FIBEOPG) /*RECN*/ ; DCL DD .FIBNCTL BIN(2) DIR BDRY(2) /*INIT(0 OL FLD EXTRACT IDL*/ ; DCL DD .FIBCMDK BIN(2) DIR BDRY(2) /*INIT(0 AND KEY ENTRED*/; DCL DD .FIBSSEL BIN(2) DIR BDRY(2) /*INIT(** T POCKET*/ ; ; DCL DD .FIBTRIN CHAR(8) DIR /*INIT((8)X'0') HEADER/T RAILER LENGTHS,NUM PER REC */ /*ZCODE4AB*/; DCL DD .FIBPOPT CHAR(3) DIR /* INIT(' ') PUNCH OPT IONS*/ ; DCL DD .FIBRCSW CHAR(1) DIR /* INIT('0') RECORD IN CO RE*/; /* ON PRINTER FILES RCSW USED TO INDICATE OVERFLOW*/ ; DCL DD .FIBEOF CHAR(1) DIR /*INIT('0') END OF FILE* / ; DCL DD .FIBEIND CHAR(1) DIR /*INIT('0') ERR INDIC ON CALC OP*/ ; DCL DD .FIBNOFL CHAR(1) DIR /*INIT('0') NON-OFLO IND USED FOR OVERFLOW*/ ; DCL DD .FIBMSW CHAR(1)DIR /*INIT('0') MATCH FIELDS IN RECORD*/; DCL DD .FIBE17 CHAR(1) DIR /*INIT('0') 'E' IN POS 1 7 FDS*/ /*ZCODE4A*/; DCL DD .FIBUSER CHAR(1) DIR /*USER INDICATOR SPECIFIED */; DCL DD .FIBHDTR CHAR(1) DIR /*PROCESSING HEADER/TRAILE R REC */; /*FIBHDTR ALSO INDICATES RELEASE RECORD ON UPDATE FILE*/ ; DCL DD .FIBMERR CHAR(1) DIR /*MATCH FIELD SEQUENCE ERR OR*/; DCL DD .FIBNSER CHAR(1) DIR /*NUMERIC SEQUENCE ERROR*/; DCL DD .FIBOPEN CHAR(1) DIR /*FILE OPEN */ ; DCL DD .FIBGPSW CHAR(1) DIR /*GET,NO PUT*/; DCL DD .FIBPRIM CHAR(1) DIR /* PRI/SEC FILE */; DCL DD .FIBSPCL CHAR(1) DIR /* SPECIAL FILE */; DCL DD .FIBDVCE CHAR(1) DIR /* DEVICE TYPE*/; /*DEVICE TYPE ENTRIES ARE 1 PRINTER, 2 CARD, 3 DISK, 4 SEQ, 5 UNU , 6 WORKSTN, 7 SPECIAL*/ ; DCL SPCPTR .FIBDNTP DIR /*POINTER TO DNT*/; DCL DD * CHAR(18) DIR ; DCL DD .FIBCLSD CHAR(1) DIR /* FILE CLOSED*/; DCL DD .FIBBLSW CHAR(1) DIR /* I,O-INPUT OR OUTPUT*/; DCL DD .FIBIBLK BIN(2) DIR /* INDEX TO BPCA PTR*/; DCL DD .FIBMDF CHAR(1) DIR /* MDF FILE */; DCL DD .FIBSVDS CHAR(1) DIR /* SAVDS USED */; DCL DD .FIBIND BIN(2) DIR /* IND */; DCL DD .FIBPPRL BIN(2) DIR /* ODP REC LEN */; DCL DD .FIBFBLN BIN(2) DIR /* I/O FIB LEN */; DCL DD .FIBKYLN BIN(2) DIR /* MAX KEY LEN */; DCL DD * CHAR(4) DIR /* RESERVED */ /*ZCODE4A2*/; DCL DD .FIBMHLD CHAR(001) DIR /*MATCH FIELD HOLD AREA*/ ; DCL DD .FIBLMBR CHAR(10) DIR /*LAST MBR READ*/ /*ZCODE4A3*/; DCL DD * CHAR(0001) DIR /*ZCODE4A4*/; /* BEGIN OF FILE FEEDBACK AREA */ ; DCL DD .FIBXFLN CHAR(8) BDRY(4) DIR /* INIT('********') ENAME, POS 7-14 FDS */; DCL DD .FIBXOPN CHAR(1) DIR /* OPEN INDIC */; DCL DD .FIBXEOF CHAR(1) DIR /* END OF FILE */; DCL DD .FIBXSTS ZND(5,0) DIR /* ERROR STATUS */; DCL DD .FIBXOP CHAR(06) DIR /* OPERATION */; DCL DD .FIBXRT CHAR(08) DIR /* ROUTINE */; DCL DD .FIBXSEQ CHAR(08) DIR /* SEQ NUMBER */; DCL DD .FIBXRCN CHAR(08) DIR /* RECORD NAME */; DCL DD .FIBXEX# CHAR(07) DIR /* EXCEPTION # */; DCL DD .FIBXEM# CHAR(04) DIR /* MI/ODT NUMBER*/; DCL DD .FIBXEXN CHAR(10) DIR /*UNUSED*/ ; DCL DD .FIBSIZE ZND(4,0)DIR /* *SIZE */; DCL DD .FIBINP ZND(2,0)DIR /* *INP */ ; DCL DD .FIBOUT ZND(2,0)DIR /* *OUT */ ; DCL DD .FIBMODE ZND(2,0)DIR /* *MODE */; DCL DD .FIBXXXX CHAR(4) DIR /* UNUSED */; DCL DD .FIBXSTC CHAR(05) DEF(.FIBXSTS) POS(01) /*REDEF FIBXSTS*/; DCL DD .FIBXSET CHAR(35) DEF(.FIBXSTS) POS(1) /* USE TO SET INFO*/ ; DCL DD .FIBXST1 CHAR(53) DEF(.FIBXSTS) POS(1) /* USE TO SET INFO*/ /*ZFEEDBK1*/; /* OPEN FEEDBACK INFORMATION */ ; /* DISPLACEMENT TO .FIBYTYP IS 81 */ ; DCL DD .FIBYTYP CHAR(02) DIR /*ODP TYPE, DS DB OR SP*/ ; DCL DD .FIBYFLN CHAR(10) DIR /*NAME OF FILE*/; DCL DD .FIBYLIB CHAR(10) DIR /*LIBRARY FOR FILE*/ ; DCL DD .FIBYSFL CHAR(10) DIR /*SPOOL FILE NAME*/; DCL DD .FIBYSLB CHAR(10) DIR /*LIBRARY FOR SPOOL*/; DCL DD .FIBYSFN BIN(2) DIR /*NUMBER OF SPOOL FILE*/; DCL DD .FIBYPRL BIN(2) DIR /*PRIMARY RECORD LENGTH*/ ; DCL DD .FIBYSRL BIN(2) DIR /*SECONARY REC LENGTH*/; DCL DD .FIBYMN CHAR(10) DIR /*MEMBER NAME*/ ; DCL DD .FIBYIBL BIN(4) DIR /*INPUT BLOCK LENGTH*/; DCL DD .FIBYOBL BIN(4) DIR /*OUTPUT BLOCK LENGTH*/; DCL DD .FIBYDVC BIN(2) DIR /*DEVICE CLASS*/; DCL DD .FIBYOLC CHAR(3) DIR /*OPEN LOCATION*/; DCL DD .FIBYROW BIN(2) DIR /*ROWS/LINES PER PAGE*/; DCL DD .FIBYCOL BIN(2) DIR /*NUMBER OF COLUMNS*/; DCL DD .FIBYRCN BIN(4) DIR /*NUM RECORDS IN FILE*/; DCL DD .FIBYACT CHAR(02) DIR /*ACESS TYPE - KY OR AR*/ ; DCL DD .FIBYDUP CHAR(01) DIR /*ALLOW DUPLICATE KEYS*/ /*ZFEEDBK2*/; DCL DD .FIBYSRC CHAR(01) DIR /*SOURCE/DATA FILE*/ ; DCL DD .FIBYUPM CHAR(10) DIR /*UFCB PARMETERS*/; DCL DD .FIBYOVR CHAR(10) DIR /*UFCB OVERRIDES*/; DCL DD .FIBYYYY BIN(2) DIR /*OFFSET TO LAB*/; DCL DD .FIBFBNR BIN(2) DIR /*NUM REC PER BLK*/; DCL DD .FIBYOFL BIN(2) DIR /*NUMBER OF PRINTER OVERFL OW LINE*/; DCL DD .FIBFBRI BIN(2) DIR /*LEN REC IN BLK*/; DCL DD * CHAR(4) DIR /*UNUSED*/ ; DCL DD .FIBEOFD CHAR(1) DIR /*EOFDLY BIT 8 */; DCL DD * CHAR(44) DIR /*UNUSED*/ /*ZFEEDB2A*/; /* I/O OPERATION FEEDBACK AREA */ ; /* DISPLACEMENT TO .FIBZOFF IS 241 */ ; DCL DD .FIBZOFF BIN(2) DIR /*OFFSET TO DEP I/O FBAREA */; DCL DD .FIBZPUT BIN(4) DIR /*NUMBER OF PUTS*/; DCL DD .FIBZGET BIN(4) DIR /*NUMBER OF GETS*/; DCL DD .FIBZPG BIN(4) DIR /*NUMBER OF PUTGETS*/; DCL DD .FIBZOTH BIN(4) DIR /*NUMBER OF OTHERS*/ ; DCL DD .FIBZCOP CHAR(02) DIR /*CURRENT OPERATION*/; DCL DD .FIBZFNM CHAR(10) DIR /*RECORD FORMAT NAME*/; DCL DD .FIBZDCL CHAR(02) DIR /*DEVICE CLASS*/; DCL DD .FIBZDVN CHAR(10) DIR /*DEVICE NAME*/ ; DCL DD * BIN(4) DIR /*LENGTH LAST REC PROCESSE D*/; DCL DD .FIBZTID CHAR(80) DIR /*INFO FROM DDS STMNTS*/ /*ZFEEDBK3*/; /* START OF DEVICE DEPENDENT FEED BACK INFORMATION */ ; DCL DD .FIBZDVD CHAR(0162) DIR; DCL DD .FIBWCKY CHAR(1) DEF(.FIBZDVD) POS(1) /* CMD KEY PRESSED */; DCL DD .FIBWAID CHAR(1) DEF(.FIBZDVD) POS(3) /* AID BYTE */; DCL DD .FIBWRRN BIN(2) DEF(.FIBZDVD) POS(10); DCL DD .FIBWDLT CHAR(1) DEF(.FIBZDVD) POS(20) /*BIT 4 REC IS DELETED*/; DCL DD .FIBWNRR BIN(4) DEF(.FIBZDVD) POS(31); DCL DD .FIBWKLN BIN(2) DEF(.FIBZDVD) POS(1) ; DCL DD .FIBWKEY CHAR(0128) DEF(.FIBZDVD) POS(35) /* KEY OF RECORD */; DCL DD .FIBMJMN CHAR(4) DEF(.FIBZDVD) POS(35) /* major/minor rc */ /*ZFEEDB3A*/; DCL DD * CHAR(0156) DIR /*ZFEEDBK4*/; DCL SPC ..MDFDNT BAS(.FIBDNTP) ; /* DEVICE NAME TABLE */ ; DCL DD ..MDFIBA CHAR(10) DIR /*DEVICE ID*/; DCL DD ..MDFIBM BIN(2) DIR /*# OF DEVICES LEFT TO ACQ UIRE*/ ; DCL DD ..MDFIBQ BIN(2) DIR /*MAX # OF DEVICES TO ACQU IRE*/; DCL DD ..MDFIBN CHAR(10) DIR /*NAME OF DEVICE FROM NEXT OPCODE*/ /*ZMDFIB1*/; DCL DD ..MDFIBI BIN(2) DIR /*DEVICE INDEX*/; DCL DD * CHAR(6) DIR /*UNUSED*/ ; DCL INSPTR ..MDFIBR DIR /*PTR TO OCCURANCE SWPING SUB*/; DCL INSPTR ..MDFIBE DIR /*PTR TO CLEARING SUBROUTI NE*/; DCL DD ..MDFIBD(257) BIN(2) DIR /*DEVICE NAME LIST INDEX*/ /*ZMDFIB2*/; /* UFCB DSECT */ ; DCL SPC .UFCB BAS(.UFCBPTR); DCL SPCPTR .UCBODPB DIR /* OPEN DATA PATH */ ; DCL SPCPTR .UCBBUFI DIR /* INPUT BUFFER */; DCL SPCPTR .UCBBUFO DIR /* OUTPUT BUFFER */; DCL SYSPTR .UCBOFBK DIR /* OPEN FEEDBACK AREA*/; DCL SPCPTR .UCBIFBK DIR /* I/O FEEDBACK AREA */; DCL SPCPTR .UCBNXTU DIR /*NEXT */; DCL SPCPTR .UCBSIA DIR /* SEP IND AREA */; /*FIXED DATA AREA*/ ; DCL DD * CHAR(16) DIR /* UNUSED */; DCL DD .UCBFNAM CHAR(10) DIR /*FILENAME*/; DCL DD .UCBLBLN BIN(2) DIR /* ID FOR LIBRARY NAME */ ; DCL DD .UCBLIBN CHAR(10) DIR /* LIBRARY NAME */; DCL DD .UCBMBID BIN(2) DIR /*ID FOR MEMBER*/; DCL DD .UCBMBER CHAR(10) DIR /*MEMBER NAME*/ ; DCL DD .UCBLSTD CHAR(10) DIR /* LAST DEVICE USED */; DCL DD .UCBINDX BIN(2) DIR /* LINKAGE TABLE INDEX */ ; DCL DD .UCBFLG1 CHAR(2) DIR /* FLAGS*/ ; /*BIT 0-2 CLOSE OPTIONS*/ ; /*BIT 3-4 SHARE ODP OPTIONS*/ ; /*BIT 5-6 SECURE OPTIONS*/ ; /*BIT 7-9 UFCB STATE*/ ; /*BIT 10-13 INPUT, OUTPUT, UPDATE, DELETE*/ ; /*BIT 14-15 UNUSED*/ ; DCL DD * CHAR(4) DIR /*VER REL*/; DCL DD .UCBIMRK BIN(4) DIR /*INVOC MARK CNT*/; DCL DD .UCBFLG2 CHAR(1) DIR /* FLAGS*/ ; /*BIT 0 COUNT INVOC MARKS*/ ; /*BIT 1 TAPE CLOSE PARMS*/ ; /*BIT 2 MULTRCD SPECIFIED*/ ; /*BIT 3-7 UNSED*/ ; DCL DD * CHAR(1) DIR /*TAPE CLOSE OPTION*/; DCL DD * CHAR(22) DIR /*UNUSED*/ ; /* END OF COMMON PART OF UFCB */ /*ZUFCBDS*/ ; /* REDEFINE FEEDBACK AREAS*/ ; DCL DD .DMPOFB1 CHAR(147) BAS(.UCBOFBK) ; DCL DD .DMPFLN CHAR(10) DEF(.DMPOFB1) POS(3) /*FILE BEING OPENED */ ; DCL DD .DMPLBN CHAR(10) DEF(.DMPOFB1) POS(13) /*LIBRARY OF OPEN FILE */ ; DCL DD .DMPPRL BIN(2) DEF(.DMPOFB1) POS(45) ; DCL DD .DMPMISC CHAR(1) DEF(.DMPOFB1) POS(116) /*MISC BITS*/; /*BIT 1 - COMMITMENT CONTROL */ ; /*BIT 2 - GET OR ACCINPUT FLAG*/ ; /*BIT 3 - SHARABLE FILE FLAG*/ ; /*BITS 4-8 UNUSED*/ ; DCL DD .DMPREQN CHAR(10) DEF(.DMPOFB1) POS(117) /*REQUESTER*/; DCL DD .DMPMINI BIN(2) DEF(.DMPOFB1) POS(129) /*LOWEST RSPNS IND*/ ; DCL SPCPTR .UCBOFDX; DCL DD .FIBFBEX CHAR(0162) BAS(.IOFDBEX) ; DCL DD .DVDWCKY CHAR(1) DEF(.FIBFBEX) POS(1); DCL DD .DVDWAID CHAR(1) DEF(.FIBFBEX) POS(3); DCL DD .DVDWARL BIN(4) DEF(.FIBFBEX) POS(6) ; DCL DD .DVDWRRN BIN(2) DEF(.FIBFBEX) POS(10); DCL DD .DVDLOCK BIN(2) DEF(.FIBFBEX) POS(11)/ ; DCL DD .DVDWGKE CHAR(1) DEF(.FIBFBEX) POS(19) ; DCL DD .DVDWDLT CHAR(1) DEF(.FIBFBEX) POS(20) ; DCL DD .DVDWNRR BIN(4) DEF(.FIBFBEX) POS(31); DCL DD .DVDWKEY CHAR(0128) DEF(.FIBFBEX) POS(35); DCL DD .DVDMJMN CHAR(4) DEF(.FIBFBEX) POS(35) /* MAJOR/MINOR RETURN CODE */; DCL DD .DVDMAJ CHAR(2) DEF(.FIBFBEX) POS(35); DCL DD .DVDMIN CHAR(2) DEF(.FIBFBEX) POS(37); DCL DD .FIBOPNF CHAR(147) DEF(.FIBYTYP) POS(1); DCL DD .FIBFDBO CHAR(147) BAS(.UCBOFDX); DCL DD .FIBIOFB CHAR(126) DEF(.FIBZOFF) POS(1); DCL DD .FIBFBIO CHAR(126) BAS(.UCBIFBK); DCL DD .IODVDFB CHAR(0444) DEF(.FIBZOFF) POS(1); DCL DD .IOFZOFF BIN(2) DEF(.FIBFBIO) POS(1) ; DCL DD .IOFZFNM CHAR(10) DEF(.FIBFBIO) POS(21) /*RECORD FMT NAME*/; DCL DD .IOFZDVT CHAR(1) DEF(.FIBFBIO) POS(31) /*DEVICE CLASS*/; DCL DD .IOFZDVC CHAR(1) DEF(.FIBFBIO) POS(32) /*DEVICE TYPE: 11, 12: IDE OGRAPHIC */; DCL DD .OFBMBRN CHAR(10) BAS(.UCBOFBK) POS(49) /*DB FILE MEMBER NAME*/ /*ZFDBKL*/ ; /* GET/PUT OPTIONS */ ; DCL DD .FOLST01 CHAR(4)INIT(X'00000005') ; DCL DD .FOTYP01 CHAR(1) DEF(.FOLST01) POS(1) /* OPTION TYPE */; DCL DD .FOPOS01 CHAR(1) DEF(.FOLST01) POS(2) /* POSITIONING */; DCL DD .FOSHR01 CHAR(1) DEF(.FOLST01) POS(3) /* SHARE PATH */; DCL DD .FOIND01 CHAR(1) DEF(.FOLST01) POS(4) /* INDICATE */ /*ZOPTNS*/ ; /* PHASE - QRGGB DATE - 02/01/94 */ /*SVP*/ ; BRK 'MYDSPF ' /*ZFLXNXA*/; /* FIB FOR FILE - MYDSPF */ /*ZCODE3*/ ; DCL DD .F01NAME CHAR(16) BDRY(16) INIT('MYDSPF ') /*NAME OF THE FILE */; DCL DD .F01FIB CHAR(1) DEF(.F01NAME) POS(1) /*ZREDOF*/ ; DCL SPCPTR .F01UFCB INIT(.UFCB01) /* ADDRESS OF UFCB */; DCL SPCPTR .F01EPTR /* ENTRY POINT */; DCL SPCPTR .F01OPTN INIT(.FOLST01) /* LOCATE GET/PUT */; DCL SPCPTR .F01CTL /*INIT(.FCLST01) LOCATE CONTROL FUNCTIONS */; DCL SPCPTR .F01RIDP /*ZCODE4*/ INIT(*INIT) /*RECORD ID INDICATOR */; DCL SPCPTR .F01UIND INIT(*INIT) /* USER INDICATOR */ ; DCL SPCPTR .F01OFLI INIT(.FIBI) /* OVERFLOW INDICATOR */; DCL DD .F01FNUM BIN(2) INIT(01) /*NUMBER OF THE FILE*/; DCL DD .F01NDRT BIN(2) INIT(01) /*INDEX TO IDL ENTRY */ ; DCL DD .F01NFET BIN(2) INIT(0) /*INDEX TO FLD EXTRACT IDL ENTRY */; DCL DD .F01NLKA BIN(2) INIT(00) /*INDEX TO LKAHD EXTRACT I DL */; DCL DD .F01NDRV BIN(2) INIT(00) /*INDEX TO DRIVER IN DRIVE R IDL */; DCL DD .F01LINE BIN(2) INIT(1) /* CURRENT LINE NUMBER */ /*ZCODE4AA*/; DCL DD .F01EOPG BIN(2) INIT(000) /* BEGIN OF OVERFLOW AREA */; DCL DD .F01PGLN BIN(2) INIT(000) /* LENGTH OF PAGE */ ; DCL DD .F01RRNM BIN(4) DEF(.F01EOPG) ; DCL DD .F01NCTL BIN(2) INIT(0) /*INDEX TO CONTROL FLD EXT RACT IDL*/ ; DCL DD .F01CMDK BIN(2) INIT(0 ) /*INDEX TO COMMAND KEY ENT RED*/; DCL DD .F01SSEL BIN(2) INIT(01) ; ; DCL DD .F01TRIN CHAR(8) INIT((8)X'0') /*ZCODE4AB*/; DCL DD .F01POPT CHAR(3) INIT(' ') /*PUNCH OPTIONS*/; DCL DD .F01RCSW CHAR(1) INIT('0') /*RECORD IN CORE*/; /* ON PRINTER FILES RCSW USED TO INDICATE OVERFLOW*/ ; DCL DD .F01EOF CHAR(1) INIT('0') /*END OF FILE*/ ; DCL DD .F01EIND CHAR(1) INIT('0') /*ERR INDIC ON CALC OP*/; DCL DD .F01NOFL CHAR(1) INIT('0') /*NON-OFLO IND USE ERFLOW*/; DCL DD .F01MSW CHAR(1) INIT('0') ; DCL DD .F01E17 CHAR(1) INIT('0') /*'E' IN POS 17 FDS*/ /*ZCODE4A*/; DCL DD .F01USER CHAR(1) INIT('0') /*USER INDICATOR */; DCL DD .F01HDTR CHAR(1) INIT('0') /*PROCESSING H R REC */; /*FIBHDTR ALSO INDICATES RELEASE RECORD ON UPDATE FILE*/ ; DCL DD .F01MERR CHAR(1) INIT('0') /*MATCH FI OR*/; DCL DD .F01NSER CHAR(1) INIT('0') ; DCL DD .F01OPEN CHAR(1) INIT('0') /*FILE OPEN */ ; DCL DD .F01GPSW CHAR(1) INIT('0') /*GET,NO PUT*/; DCL DD * CHAR(3) INIT('006') /* PRI/SEC:SPECIAL:DEVICE */; /* BYTE 1 - PRI/SEC FILE */ /* BYTE 2 - SPECIAL FILE */ /* BYTE 3 - DEVICE TYPE: 1 PRINTER, 2 CARD, 3 DISK, */ /* 4 SEQ, 6 WORKSTN, 7 SPECIAL. */ ; DCL SPCPTR .F01DNTP INIT(..MDF01A) /* POINTER TO DNT */ ; DCL DD * CHAR(18) /* UNUSED */ ; DCL DD .F01CLSD CHAR(1) INIT('0') /* FILE CLOSED*/; DCL DD .F01BLSW CHAR(1) INIT(' ') /* I,O-INPUT UT*/; DCL DD .F01IBLK BIN(2) INIT(00) /* INDEX TO BPCA PTR*/; DCL DD .F01MDF CHAR(1) INIT('1') /* MDF FILE */; DCL DD .F01SVDS CHAR(1) INIT('0') /* SAVDS USED */; DCL DD .F01IND BIN(2) INIT(00) /* IND */; DCL DD .F01PPRL BIN(2) INIT(0100) /* ODP REC LEN */; DCL DD .F01FBLN BIN(2) INIT(0162) /* I/O FDBK LEN */; DCL DD .F01KYLN BIN(2) INIT(0000) /* KEY LEN */; DCL DD * CHAR(4) /* RESERVED */ /*ZCODE4A1*/; DCL DD .F01MHLD CHAR(001) INIT /*MATCH FIEEA*/ ; DCL DD .F01LMBR CHAR(10) INIT /*LAST MBR READ*/ /*ZCODE4A3*/; DCL DD * CHAR(0001) /*ZCODE4A4*/; /* BEGIN OF FILE FEEDBACK AREA */ ; DCL DD .F01XFLN CHAR(8) BDRY(4) INIT('MYDSPF ') /* FILENAME, POS 7-14 FDS */; DCL DD .F01XOPN CHAR(1) INIT /* OPEN INDIC */; DCL DD .F01XEOF CHAR(1) INIT /* END OF FILE */; DCL DD .F01XSTS ZND(5,0) INIT /* ERROR STATUS */; DCL DD .F01XOP CHAR(06) INIT /* OPERATION */; DCL DD .F01XRT CHAR(08) INIT /* ROUTINE */; DCL DD .F01XSEQ CHAR(08) INIT /* SEQ NUMBER */; DCL DD .F01XRCN CHAR(08) INIT /* RECORD NAME */; DCL DD .F01XEX# CHAR(07) INIT /* EXCEPTION # */; DCL DD .F01XEM# CHAR(04) INIT /* MI/ODT NUMBER*/; DCL DD .F01XEXN CHAR(10) INIT /*UNUSED*/ ; DCL DD .F01SIZE ZND(4,0)INIT /* *SIZE */; DCL DD .F01INP ZND(2,0)INIT /* *INP */ ; DCL DD .F01OUT ZND(2,0)INIT /* *OUT */ ; DCL DD .F01MODE ZND(2,0)INIT /* *MODE */; DCL DD .F01XXXX CHAR(4) INIT /* UNUSED */; DCL DD .F01XSTC CHAR(05) DEF(.F01XSTS) POS(01) /*REDEF FIBXSTS*/; DCL DD .F01XSET CHAR(35) DEF(.F01XSTS) POS(1) /* USE TO SET INFO*/ ; DCL DD .F01XST1 CHAR(53) DEF(.F01XSTS) POS(1) /* USE TO SET INFO*/ /*ZFEEDBK1*/; DCL DD * CHAR(286) INIT /*ZFDBK2X*/; /* START OF DEVICE DEPENDENT FEED BACK INFORMATION */ ; DCL DD .F01ZDVD CHAR(0162) INIT; DCL DD .F01WCKY CHAR(1) DEF(.F01ZDVD) POS(1) /* CMD KEY PRESSED */; DCL DD .F01WAID CHAR(1) DEF(.F01ZDVD) POS(3) /* AID BYTE */; DCL DD .F01WRRN BIN(2) DEF(.F01ZDVD) POS(10)/* */; DCL DD .F01WDLT CHAR(1) DEF(.F01ZDVD) POS(20) /*BIT 4 REC IS DELETED*/; DCL DD .F01WNRR BIN(4) DEF(.F01ZDVD) POS(31)/* DM */; DCL DD .F01WKLN BIN(2) DEF(.F01ZDVD) POS(1) /*LIR*/ ; DCL DD .F01WKEY CHAR(0128) DEF(.F01ZDVD) POS(35) /* KEY OF RECORD */; DCL DD .F01MJMN CHAR(4) DEF(.F01ZDVD) POS(35) /* major/minor rc */ /*ZFEEDB3A*/; DCL DD * CHAR(0156) /*ZFEEDBK4*/; /* DEVICE NAME TABLE */ ; DCL DD ..MDF01A CHAR(10) BDRY(16) INIT /*DEVICE ID*/; DCL DD ..MDF01M BIN(2) INIT /*# OF DEVICES LEFT TO ACQ UIRE*/ ; DCL DD ..MDF01Q BIN(2) INIT(002) /*MAX # OF DE IRE*/; DCL DD ..MDF01N CHAR(10) INIT /*NAME OF DEVICE FROM NEXT OPCODE*/ /*ZMDFIB1*/; /* UFCB FOR THE FILE */ ; DCL SPCPTR .U01ODPB /*LOC ODP */; DCL DD .UFCB01 CHAR(1) DEF(.U01ODPB) POS(1); DCL SPCPTR .U01BUFI /*INPUT BUFFER */; DCL SPCPTR .U01BUFO /*OUTPUT BUFFER */; DCL SPCPTR .U01OFBK /* OPEN FEEDBACK*/; DCL SPCPTR .U01IFBK /* I/O FEEDBACK AREA */; DCL SPCPTR .U01NXTU /*NEXT */; DCL SPCPTR .U01SIA /* SEPARATE INDICATOR AREA */; /* FIXED DATA AREA */ ; DCL DD * CHAR(16) /*UNUSED*/ ; DCL DD .U01FNAM CHAR(10) INIT('MYDSPF ') /* FILENAME */; DCL DD .U01LBLN BIN(2) INIT(-75) /* ID - LIBRARY NAME */; DCL DD .U01LIBN CHAR(10) INIT('*LIBL ') /* LIBRAME */; DCL DD * BIN(2) INIT(-71) /* ID - MEMBER NAME*/; ; DCL DD * CHAR(20) /* NAME OF MEMBER (10 BYTE S), AND LAST DEVICE USED * / ; DCL DD .U01INDX BIN(2) INIT(0) /* LINKAGE TANDEX */ ; DCL DD .U01FLG1 CHAR(2) INIT(X'8030'); /*BIT 0-2 CLOSE OPTIONS, PERMENENT*/ ; /*BIT 3-4 SHARE*/ ; /*BIT 5-6 SECURE, NO*/ ; /*BIT 7-9 UFCB STATE*/ ; /*BIT 10-13 INPUT,OUTPUT,UPDATE,DELETE*/ ; /*BIT 14-15 UNUSED*/ ; DCL DD * CHAR(13) INIT(X'F0F1F0F0000000008040000020'); /* BYTE 1-4 - VER/REL, UNUSED */ /* BYTE 5-8 - INVOC MARK CNT */ /* BYTE 9 - BIT 2 - MULTRCD USED */ /* BYTE 10 - TAPE CLOSE OPT */ /* BYTE 11-12 - BIT FLAGS, UNUSED */ /* BYTE 13 - BIT FLAGS, BIT 3 IS S/3X BIT */ ; DCL DD * CHAR(19) /*UNUSED*/ ; /* END OF COMMON PART OF UFCB */ /*ZUFCB*/ ; /*OPTION - FORMATS USED FROM THE FILE */ ; DCL DD .U01FMT BIN(2) INIT(07); DCL DD * BIN(2) INIT(0002) ; DCL DD .U01FMTN BIN(2) INIT(0002) /* NUATS */ /*ZFORMATS*/; DCL DD .U01B001 CHAR(10) INIT('DUMMY ') /* FOR */ ; DCL DD .U01C001 CHAR(13) INIT(C'0052514D4E881') /*FORMAT SEQUENCE NUMBER * / /*ZFMTS*/; DCL DD .U01B002 CHAR(10) INIT('SCREEN ') /* FO N */ ; DCL DD .U01C002 CHAR(13) INIT(C'140D9DEA94759') /*FORMAT SEQUENCE NUMBER * / /*ZFMTS*/; /* OPTION - PRIMARY RECORD LENGTH */ ; DCL DD .U01RECL BIN(2) INIT(01); DCL DD .U01RLEN BIN(2) INIT(0100) /* LENGRD */ /*ZRECLEN*/; /*USE ARRIVAL SEQ NOT KEY SEQ */ ; DCL DD * CHAR(3) INIT(X'003C80') /*ZARVSEQ*/; /* OPTION - CONTROL LIST USED */ ; DCL DD .U01DVDP BIN(2) INIT(03); DCL DD .U01DVDT CHAR(1) INIT(X'80') /* DEVISED */ /*ZDVDPNT*/; DCL DD .U01END CHAR(2) INIT(X'7FFF') /* END OF UFCB */ /*ZUFCBEND*/; DCL DD .U01BIN CHAR(0100) BAS(.U01BUFI) /*INAY*/; DCL DD .U01BOUT CHAR(0100) BAS(.U01BUFO) /*OUAY*/ ; DCL DD ZZ01BIN CHAR(0100) BAS(.U01BUFI) /*INPLAY*/; DCL DD ZZ01BOUT CHAR(0100) BAS(.U01BUFO) /*OUTLAY*/ /*ZIOBUF*/ ; /* PHASE - QRGGB DATE - 12/09/93 */ /*SVP*/ ; /* PHASE - QRGGS DATE - 05/09/94 */ /*SVP*/ ; DCL DD .EXTRECN CHAR(10) INIT /*EXTERNAL FORMAT NAME*/ /*ZEXTREC*/; DCL DD .READNOL CHAR(1) INIT('0') /*ZDCLRNL*/; /* PHASE - QRGGS DATE - 01/20/93 */ /*SVP*/ ; BRK '..MDFDES'; DCL INSPTR ..MDFRTN /*RETURN PTR*/; /* DEVICE NAME SEARCH SUBROUTINE */ ; ENTRY ..MDFDES INT; CMPBLA(B) ..MDFDEV,.BLANKS/NEQ(..DES1) /*DEVANK?*/ ; CPYBLA ..MDFDEV,.DMPREQN /*YES- USE REQUESTER DEVIC E*/; ..DES1:; CMPBLA(B) ..MDFDEV,.UCBLSTD/EQ(..DES3A) /*DEVICED?*/; CPYNV .I,1 /*INIT LOOP COUNTER*/; ..DES2: /*LOOP THROUGH DNL TO FIND THE DEV NAME INDX*/ ; CMPBLA(B) ..MDFDEV,.DMCDVNM(.I)/EQ(..DES3) /*FOUND? */; ADDN(S) .I,1 /*INC LOOP COUNTER*/ ; CMPNV(B) .I,.DMCNDEV/NHI(..DES2); B ..DES4 /*NOT FOUND*/; ..DES3: /*DEVICE DEFINED*/; CPYNV .UCBINDX,.I /*PUT INDX IN UFCB*/ ; CPYBLA .UCBLSTD,..MDFDEV /*PUT DEV NM IN UFCB*/; ..DES3A: /*CHECK if ACQUIRED*/; TSTBUM(B) .DMCBF(.UCBINDX),X'20'/ONES(..MDFRTN) /*YES- RETURN*/ ; ..DES4: /*DEVICE NOT ACQUIRED OR D EFINED TO THE FILE*/ ; CPYBLA .FIBXSTS,'01281' /*SET *STATUS*/ ; CPYBLA .FIBMJMN,' ' /*clear maj/min*/; B .DMEXGO /*BRANCH TO ERR ROUTINE*/ /*ZMDFDES*/; BRK 'CKAIDCHR'; DCL DD .WKSINX BIN(2) INIT(0) /*USE AS INDEX*/; DCL DD .WKSCKLT CHAR(32) INIT( X'3FF1F6F5F4BDF3F83132333435363738393A3B3CB1B2B3B4B5B6B7B8B9BABBBC') /*COMMAND KEY ENTRIES*/; DCL INSPTR .WKSRTN /*USE AS RETURN*/; ENTRY .WKSCMDK INT /*CHECK COMMAND KEY ENTRY* / ; CMPBLA(B) .IOFZDVT,X'01'/NEQ(.WKSRTN) /*DEVIOT WORKSTN*/; CPYNV .FIBCMDK,0 /*ASSUME NO ENTRY*/; SCAN .WKSINX,.WKSCKLT,.DVDWAID; CMPNV(B) .WKSINX,0/EQ(.WKSLAB2) /*I/O ERROR ON CMDKEY*/; CMPNV(B) .WKSINX,3/LO(.WKSRTN) /*ENTER OR AUTOENTER*/; CMPNV(B) .WKSINX,8/HI(.WKSLAB1) /*COMMAND KEY ENTRED*/; TSTBUM(B) .DVDWCKY,X'20'/NONES(.WKSRTN) /* WKEY IS ON?*/; CPYBLA .FIBXSTS,'01118' /*SET FILE STATUS*/; ADDN(S) .FIBXSTS,.WKSINX /*SPECIAL FUNCTION KEY ENT ERED*/ ; B .DMEXGO; .WKSLAB1:; SUBN .FIBCMDK,.WKSINX,8 /*SET INDEX TO COMMAND KEY INDIC*/; CPYBLA .FIBXSTS,'00002' /*INDIC COMMAND KEY ENTERE D*/; B .WKSRTN; .WKSLAB2:; CMPBLA(B) .DVDWAID,X'00'/NEQ(=+2); CMPBLA(B) .DVDMAJ,'00'/EQ(.WKSRTN); :; CPYBLA .FIBXSTS,'01299' /*ERROR ON CMD KEY ENTERED */; B .DMEXGO /*ZCMDKEYC*/; /* READ OP CODE FOR FILE - MYDSPF */ /*ZAOPTY*/ ; DCL DD .OC01001 CHAR(1) INIT(X'01') /*FO LIST*/; DCL DD .NL01001 BIN(2) INIT(10); DCL DD .RN01001 CHAR(10) INIT(' ') /*ZACL1*/; DCL DD .EN01001 CHAR(1) INIT(X'FF') /* END L LIST*/ /*ZENDCLST*/; DCL DD .OP01001 CHAR(4) INIT(X'03000001') /*OPTS LIST*/; DCL SPCPTR .PO01001 INIT(.OP01001); DCL SPCPTR .CO01001; DCL OL .OL01001(.F01UFCB,.PO01001,.CO01001) /*ZADCL*/; DCL DD ..MDFGSW CHAR(1) INIT /*DEV SPECIFIC GET SW*/ /*ZMDFGETS*/; BRK '.DRVRR01' /* RECORD NAME I/O*/ ; .DRVRR01:; ENTRY .XRVRR01 INT; CPYBLA .RN01001,.EXTRECN /*RECORD NAME*/ ; SETSPP .CO01001,.OC01001 /* USE CONTROL LIST */ /*ZMDFARDX*/; CPYBLA ..MDFDEV,..MDF01A /*GET DEVICE ID*/; CPYBLA ..MDFGSW,*ON /*INDICATE SPECIFIC GET*/ ; B .DR01001; .DRVFR01: /*READ FILE*/; ENTRY .XRVFR01 INT; SETSPP .CO01001,.NULLCL /*NO CONTROL LIST*/; CMPBLA(B) ..MDF01N,.BLANKS/EQ(..M01001) /*NEXT ID?*/; CPYBLA ..MDFDEV,..MDF01N /*GET DEVICE ID*/; CPYBLA ..MDF01N,.BLANKS /*RESET NEXT*/; CPYBLA ..MDFGSW,*ON /*INDICATE SPECIFIC GET*/ ; B .DR01001; ..M01001: /*NO NEXT ISSUED*/; CPYBLA ..MDFGSW,*OFF /*INDICATE GENERAL GET*/; .DR01001: /*ZMDFARDQ*/; CPYBWP .UFCBPTR,.FIBUFCB /*LOCATE UFCF*/ ; CPYBWP .ODPBPTR,.UCBODPB /*LOCATE ODP*/; CMPBLA(B) ..MDFGSW,*OFF/EQ(..M01002) /*DEVGET?*/; CALLI ..MDFDES,*,..MDFRTN /*SEARCH ODP*/; CPYNV .DMCLINK,.DMCGET(.U01INDX); CPYBWP .IOEPTR,.DMCENTR(.DMCLINK) /*DM ENTRY*/; CPYBLA .DMIOSW,*ON /*INDICATE I/O OPERATION*/; CALLX .IOEPTR,.OL01001,* /*I/O REQUEST*/ ; CPYBLA .DMIOSW,*OFF /*RESET INDICATION*/ ; B ..M01003; ..M01002: /*GENERAL GET*/ ; DCL CON ..ACC BIN(2) INIT(121) /*ETP ACCINPUT*/; DCL OL ..L01001(.F01UFCB,.CO01001); CPYBWP .IOEPTR,.DMCENTR(..ACC) /*ACCINPUT*/; CPYBLA .DMIOSW,*ON /*INDICATE I/O OPERATION*/; CALLX .IOEPTR,..L01001,* /*I/O REQUEST*/ ; CPYBLA .DMIOSW,*OFF /*RESET INDICATION*/ ; ..M01003: /*ZMDFCALY*/; CPYBLA .FIBIOFB,.FIBFBIO /*SET FEEDBACK AREA*/; ADDSPP .IOFDBEX,.UCBIFBK,.IOFZOFF; CPYBLA .FIBZDVD,.FIBFBEX(1:.FIBFBLN) /*DEVDBK*/ /*ZIOFB*/; CALLI .WKSCMDK,*,.WKSRTN /*CHECK ENTER OF COMMAND K EY*/ /*ZWKSLNK*/; CPYBLA ..MDF01A,.FIBFBIO(33:10) /*GET DEVICE ID*/ /*ZMDFRD1*/; B .DRIVRTN /* RETURN */ /*ZSEQIN1*/; BRK '.EXEOF '; .EXEOF: /* END OF FILE */; CPYBLA .FIBXSTS,'00011' /*INDICATE EOF IN STATUS*/; CPYBLA .DMIOSW,*OFF /* RESET I/O PROCESSING SW ITCH*/ ; CMPBLA(B) .FIBMDF,*ON/EQ(.DRIVRTN) /*MXD-FILE SET EOF*/ ; CMPBLA(B) .FIBEOF,*ON/EQ(=+8); CMPBLA(B) .FIBLMBR,.OFBMBRN/EQ(=+6) /*CHECBER CHANGED*/ ; CPYBLA .FIBLMBR,.OFBMBRN /*UPDATE LAST MBR*/; CPYBWP .UCBOFDX,.UCBOFBK /*POINT TO OPEN FDBK*/; CPYBLA .FIBOPNF,.FIBFDBO /*GET OPEN FEEDBACK*/; CPYBWP .ODPBPTR,.UCBODPB /*POINT TO ODP*/; ADDSPP .FIBEPTR,.ODPBPTR,.DMCOFFS /*POINT TO SEPT*/; : CPYBLA .FIBEOF,*ON; : CPYBLA .FIBXEOF,*ON /*SET EOF IN FDBACK AREA*/; B .DRIVRTN; DCL EXCM * EXCID(H'5025') BP(.EXEOF) CV('CPF') /*BEYOND EOF IS STILL EOF* / ; DCL EXCM .EXFEF EXCID(H'5001') BP(.EXEOF) CV('CPF') /* EXCEPTION DESCRIPTION F OR END OF FILE */; .MDFNDI: /*NO DEVICES INVITED*/; DCL DD ..MDFNDI CHAR(1) INIT('0') /* NO DEVICES IT CH */; CPYBLA ..MDFNDI,*ON /*INDICATE NO NDI*/; CPYBLA .FIBXSTS,'00011' /*INDICATE EOF IN STATUS*/; CPYBLA .DMIOSW,*OFF /* RESET I/O PROCESSING SW ITCH*/ ; CPYBLA .FIBIOFB,.FIBFBIO /*SET FEEDBACK INFO */; ADDSPP .IOFDBEX,.UCBIFBK,.FIBZOFF; CPYBLA .FIBZDVD,.FIBFBEX(1:.FIBFBLN) /*DEVICE DE*/; B .DRIVRTN; DCL EXCM * EXCID(H'4740') BP(.MDFNDI) CV('CPF') /* CPF4740 NO DEVICES INVI TED */ /*ZEOF*/; /* WRITE OP CODE FOR FILE - MYDSPF */ /*ZAOPTY*/ ; DCL DD .OC01002 CHAR(1) INIT(X'01') /*FORMAT NAIST*/; DCL DD .NL01002 BIN(2) INIT(10); DCL DD .RN01002 CHAR(10) INIT(' ') /*ZACL1*/; DCL DD .EN01002 CHAR(1) INIT(X'FF') /* END OF C LIST*/ /*ZENDCLST*/; DCL DD .OP01002 CHAR(4) INIT(X'00000005') /*OPTILIST*/; DCL SPCPTR .PO01002 INIT(.OP01002); DCL SPCPTR .CO01002; DCL OL .OL01002(.F01UFCB,.PO01002,.CO01002) /*ZADCL*/; BRK '.DRVRW01' /* RECORD NAME I/O*/ ; .DRVRW01:; ENTRY .XRVRW01 INT; CPYBLA .RN01002,.EXTRECN /*RECORD NAME*/ ; SETSPP .CO01002,.OC01002 /*USE CONTROL LIST*/ ; B .DR01002; .DRVFW01: /* WRITE FILE */; ENTRY .XRVFW01 INT; SETSPP .CO01002,.NULLCL /*NO CONTROL LIST*/; .DR01002: /*ZAW1*/; CPYBLA ..MDFDEV,..MDF01A /*USE CURRENT DEVICE*/; CPYBWP .UFCBPTR,.FIBUFCB /*LOCATE UFCF*/ ; CPYBWP .ODPBPTR,.UCBODPB /*LOCATE ODP*/; CALLI ..MDFDES,*,..MDFRTN /*SEARCH ODP*/; CPYNV .DMCLINK,.DMCPUT (.U01INDX) /*ENTRY POINT NDEX*/ ; CPYBWP .IOEPTR,.DMCENTR(.DMCLINK) /*DM ENTRY*/; CPYBLA .DMIOSW,*ON /*INDICATE I/O OPERATION*/; CALLX .IOEPTR,.OL01002,* /*I/O REQUEST*/ ; CPYBLA .DMIOSW,*OFF /*RESET INDICATION*/ /*ZMDFCALX*/; TSTBUM(B) .DMCBF(.UCBINDX),X'20'/ONES(=+2) /*EOTED*/; ADDN(S) ..MDFIBM,1 /*UPDATE KNUM*/ ; : /*ZCHKEOS*/; CPYBLA .FIBIOFB,.FIBFBIO /*SET FEEDBACK AREA*/; ADDSPP .IOFDBEX,.UCBIFBK,.IOFZOFF; CPYBLA .FIBZDVD,.FIBFBEX(1:.FIBFBLN) /*DEVICE DEDBK*/ /*ZIOFB*/; B .DRIVRTN /* RETURN */ /*ZSEQIN1*/; B .SFLDUPB; /*CPF5008 SUBFILE DUPLICATE RELATIVE RECORD OUTPUT*/ ; DCL EXCM * EXCID(H'5008') BP(.SFLDUPR) CV('CPF'); .SFLDUPR:; CPYBLA .FIBXEX#,'CPF5008'; CPYBLA .FIBXSTS,'01021' /*SET DUP REC SATUS*/; B .DMEXGO; .SFLDUPB: /*ZSFLDUPR*/; /* QRGGS 05/09/94 */ ; BRK '.DMEXCPT' /* DATA MANAGEMENT EXCEPTI ON HANDLER */; DCL DD .OPNCLSW CHAR(1) INIT('1'); .DMEXCPT:; CPYBLA .DMIOSW,*OFF /*RESET I/O OPER INDIC*/; CPYBLA .FIBXEX#,.EXNUMBR /* EXCEPTION NUMBER */; CPYBLA .FIBXEXN,' ' /* CLEAR*/ ; CMPBLA(B) .OPNCLSW,*ON/EQ(.DMEXCLS) /*ERR OPEN/CLOSE*/; CMPBLA(B) .FIBXOP,C'OPEN '/EQ(.DMEXCLS); CMPBLA(B) .FIBXOP,C'CLOSE'/EQ(.DMEXCLS); CPYBWP .UFCBPTR,.FIBUFCB /*LOCATE UFCB*/ ; CMPPTRT(B) .UCBODPB,*/NEQ(.DMOPEN); CPYBLA .FIBOPEN,*OFF; CPYBLA .FIBRCSW,*OFF; CPYBLA .FIBEOF,*ON; CPYBLA .FIBXEOF,*ON; CPYBLA .FIBCLSD,*ON; CPYBLA .FIBXOPN,*OFF; B .DMEXGO /* STATUS ALREADY SET */; .DMOPEN:; CMPBLA(B) .FIBSPCL,*OFF/EQ(.DMOPEN2) /* NOT SPECIAL */; CPYBLA .FIBXSTS,'01231' /* SPECIAL FILE ERROR */; B .DMEXGO /* STATUS ALREADY SET */; .DMOPEN2: /* NOT A SPECIAL FILE */; CPYBLA .FIBIOFB,.FIBFBIO /*SET FEEDBACK INFO */; ADDSPP .IOFDBEX,.UCBIFBK,.FIBZOFF; CPYBLA .FIBZDVD,.FIBFBEX(1:.FIBFBLN) /*DEVICE DEP FDBK*/; B .DMEXGO /* STATUS ALREADY SET */; .DMEXL0:; CPYBLA .FIBXSTS,'01299' /*INDIC GENERAL I/O ERROR* / ; .DMEXGO: /*ZDMEX*/; CPYBLA .RCLKSW,*OFF /*RESET RECORD LOCK SWITCH */; CPYBLA .DMIOSW,*OFF /*RESET I/O OPER INDIC*/; CPYBLA .PGMERFN,.FIBNAME /*FILENAME INTO INFO DS*/ ; CPYBLA .PGMERFL,.FIBXSET /*STATUS TO PGM INFO DS*/ ; CPYBLA .TYPERR,'F' /*FILE ERR*/; CPYBLA .SAVFSTS,.FIBXSTS /*SAVE STATUS*/ ; CPYBWP .ERRFIB,.FIBPTR /*LOC FILE IN ERR*/; CPYBLA .INFFLG,*OFF /*RESET INFSR FLAG*/ ; CMPBLA(B) .FIBEIND,*ON/EQ(.DRIVRTN) /*ERR INDIC */; CPYBLA .INFFLG,*ON /*INVOKING INFSR*/; DCL DD .INFFLG CHAR(1) INIT('0'); B .FERRSUB(.FIBFNUM) /* GO TO ERR SUBROUTINE */ /*ZDMEXB*/ ; .DMNOE: /* NO FILE ERROR SUBROUTIN E */; CPYBLA .INFFLG,*OFF /*RESET INFSR FLAG*/ ; CMPBLA(B) .FIBXSTS,'01121'/LO(.FILERR) /*ISSUE MUSER*/; CMPBLA(B) .FIBXSTS,'01126'/HI(.FILERR) /*ISSUE MUSER*/; B .DRIVRTN /*RETURN TO NEXT CALC*/ /*ZDME2*/; /* ERR AT INITIALIZATION/TERMINATION */ ; .DMOPNEX:; CPYBLA .FIBXSTS,'01216' /*IMPLICIT OPEN/CLOSE ERR* / ; CPYBLA .TYPERR,'F' /*FILE ERR*/; CPYBLA .SAVFSTS,.FIBXSTS /*SAVE STATUS*/ ; CPYBWP .ERRFIB,.FIBPTR /*LOC FILE IN ERR*/; CPYBLA .PGMERFN,.FIBNAME /*FILENAME INTO INFO DS*/ ; CPYBLA .PGMERFL,.FIBXSET /*STATUS TO PGM INFO DS*/ ; B .DMNOE; .DMEXL1:; CPYBLA .FIBXSTS,'01217' /*EXPLICIT OPEN/CLOSE ERR* / ; B .DMEXGO; .DMEXL2:; CPYBLA .FIBXSTS,'01211' /*FILE NOT OPEN */; B .DMEXGO; .DMEXL3:; CPYBLA .FIBIOFB,.FIBFBIO; ADDSPP .IOFDBEX,.UCBIFBK,.FIBZOFF; CPYBLA .FIBZDVD,.FIBFBEX(1:.FIBFBLN) /*DEVICE DEP FDBK*/; B .DMEXGO /*ZDME3*/; .DMEXCLS: /*DM ERROR RE-CLOSE*/; DCL INSPTR .DMLVLRT /*SAVED INST PTR*/; DCL DD .DMLVLST CHAR(35) /*SAVED OPER STS*/; DCL DD .DMLVLCL CHAR(1); DCL DD .RCRCLSW CHAR(1) /*RECURSIVE CLOSE SW*/; DCL DD .DMLVLSW CHAR(1) /*SAVED CLOSE ALL SW*/ /*SAVED EXPL CLOSE FLAG*/ ; CMPBLA(B) .RCRCLSW,*ON/EQ(.DMCLSR); CPYBLA .RCRCLSW,*ON; CMPBLA(B) .FIBXOP,'CLOSE'/EQ(=+4); CMPBLA(B) .FIBXOP,'OPEN '/NEQ(.DMCLSR); CMPBLA(B) .FIBOPEN,*ON/EQ(.DMCLSR) /*FILE OPEN SET?*/; B =+4; : CMPBLA(B) .FIBCLSD,*ON/EQ(.DMCLSR); CMPBLA(B) .FIBBLSW,'I'/EQ(=+2) /* INPUT? */; CMPNV(B) .FIBFBNR,1/HI(.DMCLSR) /* BLOCK > 1 */ /*FILE CLOSED*/ ; : CMPBLA(B) .FIBSPCL,*ON/EQ(.DMCLSR) /*NOT DATABASE FILE?*/; CMPPTRT(B) .UCBODPB,*/EQ(.DMCLSR) /*NOT DM OPEN?*/; CPYBLA .DMLVLST,.FIBXSET; CPYBLA .DMLVLCL,.FIBCLSD; CPYBLA .DMLVLSW,.CLOSASW; CPYBLA .WORK,.FIBXSET ; CPYBLA .WORK(36:1),.FIBEIND /*ERROR IND*/; CPYBWP .DMLVLRT,.DRIVRTN /*SAVE DRIVER RETURN*/; CPYBLA .CLOSASW,*OFF; CPYBLA .FIBOPEN,*ON /*SET FILE OPEN*/; SETIP .DRIVRTN,=+2 /*SET DRIVER RETURN*/; B .CLOSE /*CLOSE FILE*/; : CPYBWP .DRIVRTN,.DMLVLRT /*RESTORE RTN POINT*/; CPYBLA .FIBXSET,.DMLVLST /*RESTORE ORIGINAL STS*/; CPYBLA .CLOSASW,.DMLVLSW; CMPBLA(B) .FIBXOP,'CLOSE'/EQ(.DMCLSR); CPYBLA .FIBCLSD,.DMLVLCL /*RESTORE OTHER FIB INFO*/; CPYBLA .FIBEOF,*OFF; CPYBLA .FIBXEOF,*OFF; .DMCLSR: /*DM ERROR RE-CLOSE RTN*/ ; CPYBLA .RCRCLSW,*OFF /*RESET RECURSIVE SW*/; CMPBLA(B) .OPNCLSW,*ON/EQ(.DMOPNEX) ; B .DMEXL1 /*ZDME3A*/ ; DCL IDL .FERRSUB /*ZDME4*/ (.DMNOE /*ZIDLESUB*/ ) /*ZPARN*/; BRK '.WRTEXC '; .WRTEXC1: /* DUP KEY THIS PATH */; CPYBLA .FIBXEX#,'CPF5026'; B .WRTEXC; .WRTEXC2: /* DUP KEY DIFF PATH */; CPYBLA .FIBXEX#,'CPF5034'; .WRTEXC: /* SET STATUS*/ ; CPYBLA .FIBXSTS,'01021' /*INDICATE DUP REC STATUS* / ; B .DMEXGO; DCL EXCM * EXCID(H'5026') BP(.WRTEXC1) CV('CPF') /* CPF5026 DUP KEY ON THIS PATH*/; DCL EXCM * EXCID(H'5034') BP(.WRTEXC2) CV('CPF') /* CPF5034 DUP KEY ON DIFF PATH*/ /*ZWRTEXC*/; /* PHASE - QRGEC DATE - 11/18/98 */ /*SVP*/ ; DCL SPCPTR .OCFIRST INIT(.F01FIB) /*FIB ADDR*/ /*ZUFCBPTR*/; DCL SPCPTR .OCLIST(01) DEF(.OCFIRST) /*ZLIST*/; DCL SYSPTR .OPENPTR BAS(.SEPT) POS(177); DCL SYSPTR .CLOSPTR BAS(.SEPT) POS(161); DCL SPCPTR .OCBSPR1 /*WORKING SYSTEM PTR */ /*ZSTART4*/; BRK '*INIT '; DCL DD .EROPCLS CHAR(1) INIT('0') /*ERR OPT CLS FLAG*/ ; DCL SYSPTR .SYPWK1 /*WORKING SYSTEM PTR */; DCL SPCPTR .SPPWK1 /*WORKING SPACE PTR*/; DCL DD .FACELVL BIN(2) BDRY(16) INIT(1) /*INTFACE LVL*/; DCL DD * BIN(2) INIT(0240 ) /*FEEDBACK OFFSET*/; DCL DD * CHAR(12) INIT /*UNUSED*/ ; DCL SYSPTR .ACTPTR /*CURRENT ACT*/ ; DCL DD .ACTPTRC CHAR(16) DEF(.ACTPTR); DCL SPCPTR .SEPT /*SYSTEM ENTRY POINT*/; DCL SYSPTR .PGMTMP; DCL SPCPTR .PGMTPTR; DCL SPCPTR * INIT(.PGMERMD); DCL SPCPTR .ERRFIB /*FILE IN ERROR*/; DCL SPCPTR .RPGRCPT INIT(.WORK) /* R#P#G#R#C DATAREA*/; DCL SPCPTR .REXPTR INIT(.REXID) /*PTR TO EXDATA*/; DCL DD .RLSTATS BIN(2) BDRY(16) INIT(970); DCL DD * CHAR(4) /*SUBROUTINE NAME*/; DCL DD * CHAR(8) /*ALIGNMENT*/; DCL DD * BIN(2) /*EXCPTION LENGTH*/; DCL DD * CHAR(50) /*EXCPTION AREA*/; DCL DD * CHAR(1) INIT('0') ; DCL DD .SUBERSW CHAR(1) INIT('0') /*SUBROUTINE SW*/; DCL DD * CHAR(1) INIT(' ') /*DATE FMT*/; DCL DD .WCBUIND CHAR(8) /*USER INDS*/; DCL DD .CALLSW CHAR(1) INIT('0'); DCL DD .DMIOSW CHAR(1) INIT('0'); DCL DD .EXNUMBR CHAR(7) INIT /*ZINIT1*/ ; DCL DD .JOBTYPE CHAR(1) /*JOB TYPE*/; DCL DD * CHAR(9) INIT /*UNUSED*/ ; DCL SYSPTR .TMLBPTR /* ADDRESS OF LIB QTEMP */; DCL SPCPTR * /* ADDRESS OF ALT SEQ TABL E */; DCL DD * CHAR(20) /* EXTERNAL SORT SEQUENCE REQUIRED */; DCL DD * CHAR(10) /* LANGUAGE ID FOR SORTSEQ */; DCL DD * BIN(4) /* CCSID OF SORTSEQ TABLE */; DCL DD * CHAR(1) INIT(X'00'); /* BIT 0 - RETRIEVE EXTERNAL ALTSEQ */ ; /* BIT 1 - CONVERT EXTERNAL ALTSEQ */ /*ZINIT2*/ ; DCL DD .RCLKSW CHAR(1) INIT('0'); DCL DD ZIGNDECD CHAR(1) INIT('0') /*IGN DECDT*/; DCL DD * CHAR(8) INIT /*UNUSED*/ ; DCL DD .CLOSASW CHAR(1) INIT('0') /*CLOSE ALL SW*/; DCL DD .REXID BIN(4) BDRY(16) INIT(142); DCL DD * CHAR(140) INIT; DCL DD .RPGRC BIN(2) BAS(.RPGRCPT) POS(1); DCL OL .OLINIT(.INITPTR); DCL OL .DMPLIST (.INITPTR,.DMPPTRS) ; DCL INSPTR .TIMERTN /*RETURN*/ ; DCL INSPTR .CALLERR /*RETURN*/ ; DCL SYSPTR .RPGINIT INIT('QRGXINIT',TYPE(PGM,1)); DCL DD .TYPERR CHAR(1) INIT('P') /*PROG OR FILE ERR*/ ; DCL DD .SAVPSTS CHAR(5) INIT('00000') /*PGM ERR STAT*/; DCL DD .SAVFSTS CHAR(5) INIT('00000') /*FIL ERR STAT*/; /*START OF PGM INIT*/ ; .START:; ADDN(S) .INVOCNT, 1 /*PGM CALLED*/; CMPNV(B) .INVOCNT, 1/EQ(.STARTA); /*RECURSIVE CALL TO THIS PGM*/ ; CPYNV .RPGRC,2 /*TERM WITH ERR*/; CPYBLA .MSGID,.INVOCER /*MESSAGE NUMBER*/; B .FILERR1 /*PUT OUT THE MESSAGE*/; .STARTA:; CPYBLA .PGMERRN,'*INIT ' /*SET ROUTINE NAME*/ ; CPYBLA .PGMERSQ,'*INIT ' /*SET STMT NUMBER*/; CPYNV .RPGRC,0 /*SET RETURN CODE*/; CMPBLA(B) .FIRSTSW,*ON/EQ(.INIT001) /*NOT FIRST TIME*/; CPYBLA .FIRSTSW,*ON /* SET FIRST SW ON*/ ; MATINVE .ACTPTRC,*,X'01' /*GET CURRENT PASAPTR*/; MATINVE .INVMARK,*,X'02' /*GET INIT INV MRK*/ ; CPYBWP .NULLSPC,* /*INIT NULL PTR*/; CPYNV .FACELVL,4 /*SET INTERFACE LEVEL*/; CALLX .RPGINIT,.OLINIT,* /*EXIT TO INIT ROUTINE*/; CMPNV(B) .RLSTATS,970/EQ(.DEACTPG) /*LEVEL ERROR*/ ; MODEXCPD .EXFCK,.SPPWK2,X'01' /*ENABLE FUNCTION CK*/ /*ZINIT3*/ ; CPYBRA UDATE,.PGMJTME /*SET CL DATE INTO UDATE*/; CPYBLA C*DATE(1:4),C.PGMJTM(1:4) /*Day Month*/; CPYBLA C*DATE(7:2),C.PGMJTM(5:2) /*Year*/; CPYBLA C*DATE(5:2),.PGMJCNT /*Century*/; DCL DD C.PGMJTM CHAR(6) DEF(.PGMJTME); DCL DD C*DATE CHAR(8) DEF(*DATE) /*ZUDATMDY*/; CPYNV .FILEIDX,01 /*SET OPEN COUNT*/; SETIP .DRIVRTN,.OPE0003 /*SET RETURN POINT*/ ; .OPE0001:; CPYBWP .FIBPTR,.OCLIST(.FILEIDX) /*SET FIB ADDR*/ /*ZOPEN1*/ ; CPYBLA .FIBXSET,'00000OPEN I*INIT *INIT ' /*IN IT FEED BACK*/; CPYBLA .FIBEIND,*OFF /*NO ERROR IND*/; B .OPEN /*OPEN SUBROUTINE*/; .OPE0003:; SUBN (SB) .FILEIDX,1/NZER(.OPE0001) /*DONE ?*/ /*ZOPEN1B*/; CPYBLA .WCBUIND,.BLANKS /*CLEAR USER INDS*/; CPYBLA .PGMERSQ,'00000000' /*SET STMT NUMBER*/; CPYBLA .OPNCLSW,*OFF /*INIT COMPLETE*/; CPYNV .RPGRC,0 /*INIT RETURN CODE*/ /*ZDETL*/; .INIT001:; MODEXCPD .EXFCK,.SPPWK2,X'01' /*ENABLE FUNCTION CK*/ /*ZSTART6A*/; CMPBLA (B) .INZSRSW,*ON/EQ(*GETIN) /*COMPLETER YET? */ /*ZSTART2A*/; CPYBLA .INZSRSW,*ON /*SET INZSR SW ON*/; B *DETL /*ZSTART2B*/; BRK '.SENDMSG'; DCL SYSPTR .SMSGPGM INIT('QRGXMSG',TYPE(PGM,1)) /*SEND MSG PGM*/; DCL INSPTR .SMSGRTN /*RETURN*/ ; DCL DD .REPTXT CHAR(100) INIT /*REPLACEMENT TEXT*/ ; DCL DD .MSGID CHAR(4) ; DCL DD .MESSAGE CHAR(1)INIT; DCL SPCPTR .MSGPTR INIT(.REPTXT); DCL OL .SMSGOL (.INITPTR,.MSGPTR); ENTRY .SENDMSG INT /*MESSAGE SUBROUTINE*/; CPYNV .FACELVL,4 /*INTERFACE LVL*/; CALLX .SMSGPGM,.SMSGOL,* /*SEND MSG*/; CMPNV(B) .RLSTATS,0/EQ(.SMSGRTN); B *CANCL /*ERROR IN SEND MESSAGE GE T OUT*/ /*ZSMSG1*/ ; DCL OL .RPXIEXP (.INITPTR,.NULLSPC,.DMPTRLT)/*PAINVX WI TH DUMMY 2ND ARG*/ /*ZIEXNODA*/; BRK '.CLOSE '; .CLOSE:; DCL OL .OCOLIST (.UFCBPTR) /*O/C OPERAND LIST*/ ; CPYBLA .FIBXSET,.WORK(1:35) /*SET I/O FEEDBACK*/ ; CPYBLA .FIBEIND,.WORK(36:1) /*SET ERROR IND*/; CMPBLA(B) .FIBOPEN,*OFF/EQ(.DRIVRTN) /*NOT OPEN ?*/; CPYBLA .FIBOPEN,*OFF /*SET FILE CLOSED*/; CPYBWP .UFCBPTR,.FIBUFCB /*SET UFCB PTR*/ /*ZCLOSE2*/; CMPBLA(B) .EROPCLS,*OFF/EQ(.NORMCLS) /*NORMAL CLOSE?*/; AND(S) .UCBFLG1,X'1FFF' /*NO-ZERO OUT CLOSE OPTION S*/; OR(S) .UCBFLG1,X'A000' /*PUT IN ERR CLS OPTIONS*/; .NORMCLS:; CPYBWP .UCBNXTU,* /*NULL NEXT PTR*/; CPYBLA .DMIOSW,*ON; CALLX .CLOSPTR,.OCOLIST,* /*DO CLOSE*/; CPYBLA .DMIOSW,*OFF; .CLO3001:; CPYBLA .FIBRCSW,*OFF /*SET RECORD IN CORE OFF*/; CPYBLA .FIBEOF,*ON /*SET EOF ON*/; CPYBLA .FIBXEOF,*ON /*SET EOF ON*/; CPYBLA .FIBCLSD,*ON /*FILE CLOSED*/ ; CPYBLA .FIBXOPN,*OFF /*SET FILE CLOSED*/ /*ZCLOSE3*/; CMPBLA(B) .CLOSASW,*ON/EQ(.CL10002) /*CLOSE ALL ?*/ /*ZCLOSE4*/; B .DRIVRTN /*RETURN*/ /*ZOPEN5*/ ; BRK '.OPEN '; .OPEN: ; CPYBWP .UFCBPTR,.FIBUFCB /*LOCATE UFCB*/ ; CMPBLA(B) .FIBOPEN,*OFF/EQ(=+3) /* FILE MUST BE */ ; CPYBLA .FIBXSTS,'01215' /*SET ERROR STATUS*/ ; B .DMEXGO; : CPYBLA .FIBXEOF,*OFF /*SET EOF OFF*/ ; CPYBLA .FIBEOF,*OFF /*SET EOF OFF*/ ; CPYBLA .FIBXOPN,*OFF /*SET OPEN OFF*/; CPYBLA .FIBRCSW,*OFF /*SET RECORD IN CORE OFF*/; CPYBLA .FIBGPSW,*OFF /*SET GET UPDATE SW OFF*/ ; CPYBREP .FIBXEX#,' ' /*CLEAR*/; CPYBREP .FIBXEM#,' ' /*CLEAR*/; CPYBREP .FIBXEXN,' ' /*CLEAR*/ ; CPYBWP .UCBODPB,* /*NULL ODP PTR*/; CPYBWP .UCBNXTU,* /*NULL NEXT PTR*/; CPYBLA .DMIOSW,*ON; CPYBLA .UCBIMRK,.INVMARK /*USE INIT INV MARK*/; CALLX .OPENPTR,.OCOLIST,* /*DO OPEN*/; CPYBLA .DMIOSW,*OFF; CPYBLA .FIBOPEN,*ON /*SET OPEN*/; CPYBLA .FIBXOPN,*ON /*SET OPEN*/; CPYBWP .UCBOFDX,.UCBOFBK /*SET FBK POINTER*/; CPYBWP .ODPBPTR,.UCBODPB /*LOCATE ODP*/; ADDSPP .FIBEPTR,.ODPBPTR,.DMCOFFS /*LOCATE DEV LIST*/; CPYBLA .FIBOPNF,.FIBFDBO /*SET OPEN FEED BACK*/; CMPNV(B) .FIBPPRL,.DMPPRL/LO(=+2); CPYNV .FIBPPRL,.DMPPRL /*SET ODP BUF LENGTH*/; : CPYBLA .FIBLMBR,.OFBMBRN /*SET LAST MBR NME*/ /*ZOPEN2*/ ; CMPPTRT(B) .UCBBUFO,*/NEQ(..NOTNUL) /*IS BUFFERED*/; SETSPP .UCBBUFO,.DUMREC /*NO - SET TO DUMMY BUFFER */; ..NOTNUL: /*ZOPEN3*/ ; DCL DD ..MDFOI BIN(2) /* MDF INDEX */ ; DCL INSPTR ..MDFRT2 /*MDFFFS RETURN PTR*/; CMPBLA(B) .FIBMDF,*ON/NEQ(..MDFO99) /* MDF FILE ?*/ ; TSTBUM(B) .DMPMISC,X'40'/NONES(..MDFO01) /*YES-SD?*/ ; CMPBLA(B) .FIBSVDS,*ON/EQ(..MDFO00) /*YES-SAVDS?*/; CMPNV(B) .FIBIND,0/EQ(..MDFO01) /*NO-IND?*/; ..MDFO00: /* - ERROR- */; CPYBLA .FIBXSTS,'01286' /*YES-SET STATUS*/; B ..MDFO02; ..MDFO01:; CMPNV(B) .DMPMINI,0/EQ(..MDFO03) /*NO SEP IND ORSPNS I ND*/; CMPNV(B) .DMPMINI,.FIBIND/HI(..MDFO03) /*IND-OVERLAP*/; CPYBLA .FIBXSTS,'01287' /*YES-SET STATUS*/; ..MDFO02: /* - ERROR DETECTED- */ ; CPYBLA .FIBOPEN,*OFF /*SET FILE CLOSED*/; CPYBWP .UCBNXTU,* /*NULL NEXT PTR*/; CPYBLA .DMIOSW,*ON; CALLX .CLOSPTR,.OCOLIST,* /* DO CLOSE */; CPYBLA .DMIOSW,*OFF; CPYBLA .FIBXOPN,*OFF /*FILE COND*/; CPYBLA .FIBCLSD,*ON /*SET FILE CLOSED*/; B .DMEXGO /*GOTO ERROR HANDLER*/; ..MDFO03: /*NO MDF ERROR*/; CPYBLA ..MDFIBA,.BLANKS /*SET ID*/ ; SUBN ..MDFIBM,..MDFIBQ,1 /*SET ACQUIRE COUNTER*/; CPYBLA ..MDFIBN,.BLANKS /*SET NEXT DEVICE*/; CMPBLA(B) .FIBSVDS,*ON/EQ(..MDFO04) /* SAVDS ? */; CMPNV(B) .FIBIND,0/EQ(..MDFO05) /* NO - IND? */ ; ..MDFO04:; CPYNV ..MDFOI,..MDFIBQ /*SET LOOP COUNTER*/ ; ..MDFO10:; CPYNV ..MDFIBD(..MDFOI),0 /* SET TO ZERO */; SUBN(BS) ..MDFOI,1/NZER(..MDFO10) /* END OF LOOP ? */; CPYNV ..MDFIBI,0 /*SET CURRENT INDEX*/; ..MDFO05:; CPYNV(B) ..MDFOI,.DMCNDEV/ZER(..MDFO99); ..MDFO06:; TSTBUM(B) .DMCBF(..MDFOI),X'20'/ONES(..MDFO07) /* ACQUIRED */; SUBN(BS) ..MDFOI,1/NZER(..MDFO06) /* LOOP */ ; B ..MDFO99 /*NO DEVICES ACQUIRED AT O PEN*/; ..MDFO07: /* DEVICE ACQUIRED */; SUBN(S) ..MDFIBM,1 /* DEC ACQ COUNTER */; CMPBLA(B) .FIBSVDS,*ON/EQ(..MDFO08) /* SAVDS ? */; CMPNV(B) .FIBIND,0/EQ(..MDFO99) /* NO IND ? */; ..MDFO08:; CPYNV ..MDFIBD(..MDFIBQ),..MDFOI /* SAVE ODP INDEX */ ; SETIP ..MDFRTN,..MDFO09; CPYNV .WORKB2,..MDFIBQ /*SET PARM*/; B ..MDFIBE /* CLEAR SWAPPING STRUCTUR ES */; ..MDFO09:; CMPBLA(B) .FIBSVDS,*OFF/EQ(..MDFO99) /*NO SAVDS*/; SETIP ..MDFRT2,..MDFO99 /*SET RTRN PTR*/; CPYNV .WORKB2,1 /*RESET SAVDS PTR*/; B ..MDFIBR /*CALL SET SAVDS SUB*/; ..MDFO99: /*ZMDFOPN*/; B .DRIVRTN /*RETURN*/ /*ZOPEN5*/ ; BRK '*CANCL '; *CANCL: /*ZEND*/; CPYNV .RPGRC,2 /*SET ERROR TERMINATION*/ ; CPYBLA .EROPCLS,*ON /*SET ERR OPT ON CLS*/; CMPBLA(B) .TYPERR,'P'/NEQ(.CANPS) /*PGM ERR*/; CPYBRA .PGMSVID,.SAVPSTS /*PGM ERR ID*/; B .END0001; .CANPS:; CMPBLA(B) .TYPERR,'F'/NEQ(.END0001) /*F ERR*/; CPYBRA .PGMSVID,.SAVFSTS /*FILE ERR */; B .END0001; *TERM: ; BRK '*TERM '; /*START OF PGM TERMINATION*/ ; .END: /*ZENDZ2*/ ; /* HANDLE VARIOUS TYPES OF RETURNS*/ ; .RETURN: /*ZRETURN1*/; CPYNV .RPGRC,1 /*ASSUME LR END*/; CMPBLA(B) *INLR,*ON/EQ(.END0001) /*LR END*/ /*ZRETURN3*/; CPYNV .RPGRC,0 /*RETURN OP CODE*/; B .STOP /*ZRETURN5*/; BRK '.FILERR'; .FILERR: /*ZEND1*/; CMPBLA(B) .TYPERR,'P'/EQ(.ERR) /*PROG ERR*/; CPYBWP .FIBPTR,.ERRFIB /*LOC FILE IN ERR*/; CPYBLA .FIBXSTS,.SAVFSTS /*INSURE ERR STATUS*/; CPYBLA .PGMERFN,.FIBNAME /*FILE NAME*/; CPYBWP .ERRFIB,.FIBPTR /*FILE IN ERROR*/; CPYBLA .PGMERAD,.BLANKS; CPYBLA .PGMERAD,.PGMERFN; CPYBRA .MSGID,.FIBXSTS /*STATUS*/ ; CPYBREP .REPTXT,.BLANKS /*CLEAR REPLACEMENT AREA*/; CPYBLA .REPTXT(11:10),.FIBXSEQ; CPYBLA .PGMERAD(11:17),.FIBXEX# /*ZEND1A*/ ; CPYBLA .PGMERAD(21:10),..MDFDEV /*DEV NAME TO R*/ /*ZMDFEND*/; B .FILERR1; BRK '.ERR'; .ERR:; CMPBLA(B) .TYPERR,'F'/EQ(.FILERR) /*FILE ERR*/; CPYBLA .PGMERST,.SAVPSTS /*INSURE ERR STATUS*/; .ERA:; CPYBRA .MSGID,.PGMERST /*SET ERROR NUMBER*/ ; CPYBREP .REPTXT,.BLANKS /*CLEAR REPLACEMENT AREA*/; CPYBLA .REPTXT(11:10),.PGMERSQ /*STMT NUMBER*/ ; .FILERR1:; CPYBLA .OPNCLSW,*ON /*TERMINATION*/ ; CPYBLA .ERRTERM,*ON /*SET ERROR TERMINATION*/ ; CPYBLA .PGMSVID,.MSGID /*SAVE MESSAGE ID*/ /*ZEND1B*/ ; CALLI .SENDMSG,*,.SMSGRTN /*SEND MESSAGE*/; CMPBLA(B) .PGMSVID,.INVOCER/EQ(.TERMPGM) /*RECUERR*/; CPYBLA .PGMERAD,.BLANKS /*ERROR INFO AREA*/; CMPBLA(B) .MESSAGE,'R'/EQ(.END0005) /*retry stmt?*/ ; CMPBLA(B) .MESSAGE,'D'/EQ(.END0002) /*DUMP RPG FMT?*/; CMPBLA(B) .MESSAGE,'F'/EQ(.END0002) /*FULL FORTED*/; CMPBLA(B) .PGMERRN,'*INIT '/EQ(*CANCL) ; CMPBLA(B) .PGMERRN,'*TERM '/EQ(*CANCL) ; CMPBLA(B) .MESSAGE,'G'/EQ(.END0004) /*CONTINUE?*/; CMPBLA(B) .HALTSW,*ON/EQ(.END0001),NEQ(*CANCL) /*HALT ?*/ ; .END0004:; CMPBLA(B) .HALTSW,*ON/NEQ(.END0005) /*CONTINUE*/; CPYBLA .SPPWK1->.INDIC,*OFF /*SET OFF HALT INDICATOR*/; CPYBLA .HALTSW,*OFF /*RESET HALT INDIC BEING P ROCESSED*/ ; DCL DD .HALTSW CHAR(1) INIT('0'); .END0005:; CPYBLA .OPNCLSW,*OFF /*RESET CLOSE SW*/; CPYBLA .ERRTERM,*OFF /*RESET TERMINAL ERR SW*/ /*ZEND3*/; CPYBLA .TERRSW,*OFF /*RESET TERMINAL ERR SW*/ /*ZEND4*/; CPYNV .RPGRC,0 /*RESET RETURN CODE*/; CMPBLA(B) .MESSAGE,'R'/EQ(.RETRYOP) /*retry stmt?*/ ; B *GETIN; DCL INSPTR .RETRYOP; BRK '.END0002'; .END0002:; CPYBLA .DUMPSW,*ON /*SET DUMP SWITCH ON*/; CPYBLA .DMPTYPE,.MESSAGE /*SET DUMP TYPE*/; SETIP .DMPRTN,*CANCL; B .DUMP ; BRK '.END0001'; /* .RPGRC MUST BE SET BEFORE .END0001*/ ; .END0001:; CPYBLA .PGMERSQ,'*TERM ' ; CPYBLA .PGMERRN,'*TERM ' /*SET ROUTINE NAME*/ /*ZEND6*/; CPYBLA .OPNCLSW,*ON /*TERMINATION ACTIVE*/ /*ZEND6XX*/; CPYBLA .WORK,'00000CLOSEI*TERM *TERM ' /*FEED BACK*/; CPYBLA .CLOSASW,*OFF /*RESET SW*/; CPYBLA .WORK(34:1),*OFF /*SET ERROR IND*/; SETIP .DRIVRTN,.CL10002 /*SET RETURN PT*/; B .CL10004; .CLOSALL:; CPYBLA .CLOSASW,*ON /*SET CLOSE ALL ON*/ ; .CL10004:; CPYNV .FILEIDX,0001 /*SET CLOSE COUNT*/; .CL10001: /*CLOSE FILES*/ ; CPYBWP .FIBPTR,.OCLIST(.FILEIDX) /*SET FIB ADDR*/; CMPBLA(B) .FIBOPEN,*OFF/EQ(.CL10002) /*NOT OPEN*/; CMPBLA(B) .FIBXSTC,'01216'/EQ(.CL10002) /*PREV ERR*/; CMPBLA(B) .FIBXSTC,'01217'/EQ(.CL10002) /*PREV ERR*/; B .CLOSE /*GO DO CLOSE*/ ; .CL10002:; SUBN (SB) .FILEIDX,1/POS(.CL10001) /*DONE ?*/ ; CMPBLA(B) .CLOSASW,*OFF/EQ(.CL10003) /*CLOSALL ?*/; CPYBLA .CLOSASW,*OFF /*RESET SW*/; B .DRIVRTN /*RETURN*/ ; .CL10003: /*ZCLOSE1*/; .NRSTORE:; BRK '.DEACTPG'; .DEACTPG:; CMPBLA(B) .DEACTSW,*ON/EQ(.NODEACT) /*TRIED BEFORE*/; CPYBLA .DEACTSW,*ON /*SET TRIED*/; DEACTPG * /*DEACTIVATE PROGRAM*/; .NODEACT:; CMPNV(B) .RPGRC,2/LO(.STOP) /*SUCCESSFUL RETURN*/; .TERMPGM:; CPYBLA .MODEXD1,X'20' /*DO NOT HANDLE EXC HERE*/; MODEXCPD .EXFCK,.SPPWK2,X'01' /*DISABLE FUNCTN CH*/; CALLX .RPGSIGE,.OLSIGE,* /*SIGNAL EXCEPTION*/ ; DCL DD .DEACTSW CHAR(1) INIT('0'); DCL OL .OLSIGE(.INITPTR) /*PGM ERR AREA*/ /*ZFINE*/; DCL EXCM * EXCID(H'5027') BP(.DMLKOUT)CV('CPF') /*CPF5027*/; .DMLKOUT:; CPYBLA .RCLKSW,*ON /*SET RECORD LOCK SWITCH*/; CPYNV .RLSTATS,5100 /*INDICATE DM ERROR */; CPYNV .FIBXSTS,1218 /*SET STATUS NUMBER */; CPYBLA .FIBXEX#,'CPF5027' /* CPF MSG ID */; B .MITOSN /*FILL IN ERROR INFO*/ /*ZEXCPTR*/; BRK '.EXCPTON'; /* EXCEPTIONS LISTENED FOR IN EVERY PROGRAM*/ ; DCL EXCM * EXCID(H'0603') BP(.SUBERR) /* SUBSCR*/; DCL EXCM * EXCID(H'0C02') BP(.DTAERR) /*MCH120A ERROR*/; DCL EXCM * EXCID(H'0C0A') BP(.END)IGN /*IGN MCIZE ERR*/; DCL EXCM * EXCID(H'4018') BP(.SUBERR)CV('CPF')IGN /*IGN OPEN NOTIFY MSG*/ /*ZEXCPT*/ ; DCL EXCM * EXCID(H'4000') BP(.DMERRS)CV('CPF') /* CPF40XX */; DCL EXCM * EXCID(H'4100') BP(.DMERRS)CV('CPF') /* CPF41XX */; DCL EXCM * EXCID(H'4200') BP(.DMERRS)CV('CPF') /* CPF42XX */; DCL EXCM * EXCID(H'4300') BP(.DMERRS)CV('CPF') /* CPF43XX */; DCL EXCM * EXCID(H'4500') BP(.DMERRS)CV('CPF') /* CPF45XX */; DCL EXCM * EXCID(H'4600') BP(.DMERRS)CV('CPF') /* CPF46XX */; DCL EXCM * EXCID(H'4741') BP(.ST01282)CV('CPF') /* CPF4741 */; DCL EXCM * EXCID(H'4742') BP(.ST01331)CV('CPF') /* CPF4742 */; DCL EXCM * EXCID(H'4743') BP(.ST01331)CV('CPF') /* CPF4743 */; DCL EXCM * EXCID(H'4700') BP(.DMERRS)CV('CPF') /* CPF47XX */; DCL EXCM * EXCID(H'4800') BP(.DMERRS)CV('CPF') /* CPF48XX */; DCL EXCM * EXCID(H'5000') BP(.DMERRS)CV('CPF') /* CPF50XX */; DCL EXCM * EXCID(H'5100') BP(.DMERRS)CV('CPF') /* CPF51XX */; DCL EXCM * EXCID(H'5200') BP(.DMERRS)CV('CPF') /* CPF52XX */; DCL EXCM * EXCID(H'5300') BP(.DMERRS)CV('CPF') /* CPF53XX */; DCL EXCM * EXCID(H'5400') BP(.DMERRS)CV('CPF') /* CPF54XX */; DCL EXCM * EXCID(H'5500') BP(.DMERRS)CV('CPF') /* CPF55XX */; DCL EXCM * EXCID(H'5600') BP(.DMERRS)CV('CPF') /* CPF56XX */ /*ZEXCPT2*/; DCL EXCM * EXCID(H'9001') BP(.MITSIG)CV('RPG') /*RPG9001 MESSAGE*/; DCL EXCM * EXCID(H'2201') BP(.MITSIGX)CV('MCH') /*MCH3401*/; DCL EXCM .EXFCK EXCID(H'9999') BP(.FUNCCHK) SKP CV('CPF') /*CPF9999 FUNCTION CK*/; DCL DD .MODEXD BIN(4) BDRY(16) INIT(10); DCL DD * BIN(4); DCL DD .MODEXD1 CHAR(2) INIT(X'A000'); DCL SPCPTR .SPPWK2 INIT(.MODEXD); DCL SYSPTR .RPGXERR INIT('QRGXERR',TYPE(PGM,1)); DCL SYSPTR .RPGSIGE INIT('QRGXSIGE',TYPE(PGM,1)); .FUNCCHK: /*FUNCTION CHECK*/; CPYNV .RLSTATS,9999 /*SET ERROR NUMBER*/ ; B .MITOSN /*FILL IN ERROR INFO*/; .PARMERR: /*PARAMETER ERROR*/; CPYNV .RLSTATS,801 /*SET ERROR NUMBER*/ ; B .MITOSNX /*FILL IN ERROR INFO*/; .SUBERR: /*SUBSCRIPT ERROR*/; CPYNV .RLSTATS,121 /*SET ERROR NUMBER*/ ; B .MITOSNX /*FILL IN ERROR INFO*/; .DTAERR: /*SUBSCRIPT ERROR*/; CPYNV .RLSTATS,907 /*SET ERROR NUMBER*/ ; B .MITOSNX /*FILL IN ERROR INFO*/; .DMERRS: /*DM ERRORS*/; CPYNV .RLSTATS,5100 /*SET ERROR NUMBER*/ /*ZEXCPT3*/; CMPBLA(B) .FIBDVCE,'6'/NEQ(.ST01299) /* WORKSTN*/ ; .CHKMJMN:; CPYBWP .UFCBPTR,.FIBUFCB /*LOCATE UFCB*/ ; CMPPTRT(B) .UCBIFBK,*/EQ(.ST01299) /*FDBK INIL?*/ ; ADDSPP .IOFDBEX,.UCBIFBK,.IOFZOFF; CPYBLA .FIBZDVD,.FIBFBEX(1:.FIBFBLN); CMPBLA(B) .DVDMAJ,'04'/NHI(.ST01299); CMPBLA(B) .DVDMAJ,'08'/EQ(.ST01285) ; CMPBLA(B) .DVDMAJ,'28'/EQ(.ST01281) ; CMPBLA(B) .DVDMAJ,'34'/EQ(.ST01201) ; CMPBLA(B) .DVDMAJ,'80'/EQ(.ST01251) ; CMPBLA(B) .DVDMAJ,'81'/EQ(.ST01251) ; CMPBLA(B) .DVDMAJ,'82'/EQ(.ST01255) ; CMPBLA(B) .DVDMAJ,'83'/EQ(.ST01255) ; B .ST01299 /* use gen I/O for unknown maj */; .ST01201: CPYBLA .FIBXSTS,'01201'; B .MITOSN; .ST01215: CPYBLA .FIBXSTS,'01215'; B .MITOSN; .ST01251: CPYBLA .FIBXSTS,'01251'; TSTBUM(B) .DMCBF(.UCBINDX),X'20'/ONES(=+2); ADDN(S) ..MDFIBM,1 /*UPDATE KNUM*/ ; :; B .MITOSN; .ST01255: CPYBLA .FIBXSTS,'01255'; B .MITOSN; .ST01261: CPYBLA .FIBXSTS,'01261'; B .MITOSN; .ST01281: CPYBLA .FIBXSTS,'01281'; B .MITOSN; .ST01282: CPYBLA .FIBXSTS,'01282'; B .MITOSN; .ST01285: CPYBLA .FIBXSTS,'01285'; B .MITOSN; .ST01299: CPYBLA .FIBXSTS,'01299' /* GENERAL I/O ERROR */; B .MITOSN /*FILL IN ERROR INFO*/; .ST01331: CPYBLA .FIBXSTS,'01331'; B .MITOSN; .MITOSNX:; RETEXCPD .REXPTR,X'00' /*GET EXCPTION INFO*/; .MITOSN:; CPYNV .FACELVL,1 /*INTERFACE LEVEL*/; CALLX .RPGXERR,.OLINIT,* /*EXIT TO ERR ROUTINE*/; CMPNV(B) .RLSTATS,970/EQ(.ERA) /*INTERFACE ERR*/; .MITSIG: /*ZEXCPTS*/; CMPBLA(B) .RCLKSW,*ON/EQ(.DMEXGO) /*RECORD LRROR? */ /*ZEXCPTT*/; /*BYPASS CALL STATUS RTN IF NOT A CALL/FREE OPERATION*/ ; CMPBLA(B) .CALLSW,*OFF/EQ(.MITSIG1) /*CALL ERROR?*/ ; .GDDMSTS: /*GDDM STATUS ENTRY*/; ENTRY .CALLSTS INT /*CALL STATUS ROUTINE*/; CPYBLA .PGMERAD,.BLANKS; CPYBLA .CALLSW,*OFF /*RESET CALL SWITCH*/; CPYBLA .PGMERST,'00231' /*ASSUME HALT INDIC ON*/; CMPNV(B) .RPGRC,3/EQ(.CALLERR); CPYBLA .PGMERST,'00202' /*CALLED PGM FAILED*/; B .CALLERR; .MITSIGX: /*MCH3401 EXCEPTION*/; CMPBLA(B) .CALLSW,*ON/EQ(=+2) /*MCH3401 ON CALL OP?*/; CMPBLA(B) .DMIOSW,*ON/EQ(.DMERRS),NEQ(.ERX) /*MCH?*/; : CPYBLA .PGMERAD,.BLANKS; RETEXCPD .REXPTR,X'00' /*GET EXCPTION INFO*/; CPYNV .FACELVL, 1 /*INTERFACE LEVEL*/; CALLX .RPGXERR,.OLINIT,* /*EXIT TO ERR ROUTINE*/; CMPNV(B) .RLSTATS,970/EQ(.ERA) /*INTERFACE ERR*/; CPYBLA .CALLSW,*OFF /*RESET CALL SWITCH*/; CPYBLA .PGMERST,'00211' /*PGM NOT FOUND*/; B .CALLERR; .MITSIG1: /*CALL STATUS END*/; CMPBLA(B) .DMIOSW,*OFF/NEQ(.DMEXCPT),EQ(.ERX) ; DCL DD * CHAR(48) BDRY(16) INIT( '-------- END OF RPG STATIC AREA ------'); DCL DD * CHAR(16) BDRY(16) INIT('END OF RPG AREA '); DCL DD * CHAR(16) BDRY(16) INIT('END OF RPG AREA ') /*ZEXCPTU*/; PEND;