Title : TCO Exits Submitter : Doug Lawson National Westminster Bank plc IT Central Computer Services Technical Development Goodmans Fields 74 Alie Street London E1 8HL Phone : 071-480-4118 Release Submitter Details - Y Text :- The following 2 modules are TCO Exits (DFSTXIT0). The first (ZXTCOXIT) is used to schedule different TCO scripts on different days. The second issues MVS commands via SVC34 from a TCO script. ZXTCOXIT CSECT *---------------------------------------------------------------------* * * 00500000 * M O D U L E P R O L O G * 00600000 * BOGGED FROM DFSTXIT0 * 00700000 *---------------------------------------------------------------------* * * 00900000 * MODULE NAME: ZXTCOXIT * 01000000 * * 01100000 * DESCRIPTIVE NAME: NWB SMART TCO EXIT ROUTINE * 01200000 * * 01300000 * FUNCTION: THIS EXIT ROUTINE WILL PASS THE INPUT SUPPLIED BY THE * 01600000 * USER IN THE MESSAGE STATEMENTS OR SCHEDULE REQUEST * 01700000 * STATEMENTS FOUND IN THE DFSTCF SCRIPT MEMBER CURRENTLY * 01800000 * BEING PROCESSED. IT CAN PRODUCE ONE OR MORE SINGLE * 01900000 * AND/OR MULTI SEGMENT INPUT MESSAGES TO BE PROCESSED BY * 02000000 * THE TCO DDM. IF THE MESSAGE RETURNED BY A GU CALL IS 8 * 02100000 * BYTES LONG, THE CHAIN OF INPUT MESSAGES LOCATED AT MSG+4 * 02200000 * IS PROCESSED AND PASSED TO THE TCO INTERFACE PRODUCING * 02300000 * ALL MESSAGES SUPPLIED BY THE USER IN THE DFSTCF SCRIPT * 02400000 * IF THE MESSAGE RETURNED BY THE GU CALL IS 20 BYTES LONG * 02500000 * THE TEXT FOUND AT LOCATION MSG+4 FOR A LENGTH OF 16 BYTES * 02600000 * (20 WITH LLZZ), IS PASSED TO THE TCO INTERFACE TO FORM A * 02700000 * SINGLE SEGMENT MESSAGE FOR PROCESSING BY THE IMS DDM. * 02800000 * * 02850000 * NWB additions to the basic TCO exit: * 02850000 * Before passing the segments to the TCO DDM we edit them. * 02850000 * This will change the first occurance of the special * 02850000 * strings "DAY" "MTH" and "##" to todays name eg TUE, this * 02850000 * months name eg APR and todays date eg 21. * 02850000 * This can allow us to load a different script for each * 02850000 * day of the week with the following as the last entry in * 02850000 * the standard script DFSTCF. * 02850000 * (This is because TCF cannot load more than one script at * 02850000 * a single scheduling) * 02850000 * * 02850000 * COLS: 1---+----10---+----20---+----30---+----40---+----50 * 02850000 * DFSTCF LOAD DAYTCF * 02850000 * *TIME ZXTCOXIT S * 02850000 * * 02850000 * * 02850000 * Amendments: * * #1 * * Having had success with the additions there are two more * * items that can be used as variables, year and time, they * * will be implemented with this first amendment. * * The values that will be substituted are "YEAR" and "TIME" * * * 02950000 * * 02950000 * THE EXPECTED INPUT IS * 03000000 * 0008 0000 PPPPPPPP * 03100000 * LL ZZ POINTER * 03200000 * OR * 03300000 * 0014 0000 INPUTDATA.............. * 03400000 * * 03500000 * IF A POINTER IS PASSED, IT IS EXPECTED TO POINT TO A * 03600000 * CHAIN OF MESSAGE SEGMENTS OF THE FOLLOWING FORMAT. * 03700000 * NEXT PTR LL ZZ DATA * 03800000 * I 4 I 2I 2I VARIABLE * 03900000 * * 04000000 * WHERE NEXT PTR CONTAINS THE ADDRESS OF THE NEXT SEGMENT * 04100000 * OR IS 0 AT END OF CHAIN. * 04200000 * * 04300000 * LL IS LENGTH INCLUDING ITSELF * 04400000 * * 04500000 * ZZ IS 03 FOR SINGLE SEGMENT MSG * 04600000 * 01 FOR 1ST SEG OF MULTI SEG MSG * 04700000 * 00 FOR MIDDLE SEG OF MULTI SEG MSG * 04800000 * 02 FOR LAST SEG OF MULTI SEG MSG * 04900000 * * 05000000 * AT ENTRY THE ADDRESS OF A SINGLE ENTRY PARM LIST IS IN * 05100000 * THE REGISTER R1 * 05200000 * CONTAINING THE ADDRESS OF THE TCO PCB TO BE USED FOR ALL * 05300000 * CALLS TO THE TCO INTERFACE. * 05400000 * * 05500000 * THE TIME OF SCHEDULING IS FOUND IN THE TIME AREA OF THE * 05600000 * PCB (PCB+16) IN HHMM FORMAT. * 05700000 * THE DATE IS FOUND IN THE DATE AREA OF THE PCB (PCB+12) IN * 05800000 * PACKED DECIMAL FORMAT. * 05900000 * * 06000000 * 0CYYDDDS * 06100000 * WHERE C IS THE CENTURY (0=1900,1=2000 etc.) * 06200000 * YY IS THE YEAR * 06200000 * DDD IS THE DAY * 06300000 * AND S IS A +SIGN * 06400000 * * 06500000 * * 06600000 * MODULE TYPE: DC FEATURE * 06700000 * PROCESSOR: ASSEMBLER H ONLY * 06600000 * ATTRIBUTES: NON-REENTRANT,REUSABLE,MVS/ESA ONLY * 06800000 * * 06900000 * ENTRY POINT: ZXTCOXIT * 07000000 * LINKAGE: BALR FROM DFSTTIM0 * 07200000 * * 07300000 * INPUT: * 07400000 * REGISTERS AT ENTRY: * 07500000 * R1 = PARM LIST CONTAINING ADDRESS OF TCO PCB @PL44023 07600000 * R10 = RESERVED FOR DFSTDLI0 (DO NOT USE IN USER EXIT) * 07650000 * R13 = SAVEAREA ADDRESS * 07700000 * R14 = RETURN ADDRESS * 07800000 * R15 = ENTRY POINT ADDRESS * 07900000 * * 08000000 * OUTPUT: * 08100000 * R15 IS IGNORED BY DFSTTIM0 * 08500000 * SINGLE AND/OR MULTI SEGMENT INPUT MESSAGES TO BE * 08200000 * PROCESSED BY DFSTDDM0, THE TCO DDM ROUTINE. * 08300000 * AN ERROR MESSAGE. * 08400000 * * 08500000 * EXIT-NORMAL: * 08600000 * RETURN CODE: R15 = ZERO * 08700000 * ALL OTHER REGS RESTORED TO INPUT VALUE * 08800000 * * 08900000 * EXTERNAL REFERENCES: * 09900000 * ROUTINES: DFSTDLI0 - LANGUAGE INTERFACE ROUTINE * 10000000 * * 10100000 * * 10300000 * IMS MACROS: CHANGEID LEAVE REQUATE * 10400000 * * 10500000 * * 10700000 * WARNING: * 10900000 * The use of ABEND in TCO will leave your system up but with TCO * 10900000 * disabled until the next IMS restart. * 10900000 * * 10900000 *---------------------------------------------------------------------* EJECT 11200000 *---------------------------------------------------------------------* * * 11400000 * M O D U L E P S E U D O C O D E * 11500000 * * 11600000 *---------------------------------------------------------------------* * In the great tradition of IBM programming they have invented many * * useless things - one of these is the pissdo code. Can't these boys * * read simple basic assembler instructions? So to keep the purists * * happy I suppose that some psuedo code might come in handy. * * * * * * CALL INITIALISE * * MAIN-LOOP: * * CALL GU-PROCESS * * IF TIME-TO-GO THEN GO TO RETURN * * ELSEIF BAD-GU-STATUS THEN GO TO ERROR * * CALL DATE-PROCESS * * CALL EDIT-PROCESS * * IF BAD-ISRT-STATUS THEN GO TO ERROR * * ELSEIF BAD-PURG-STATUS THEN GO TO ERROR * * GO TO MAIN-LOOP * * * * ERROR: * * ISSUE ERROR MESSAGES /* not implemented */ * * * * RETURN: * * LEAVE RC=0 * * * * * * INITIALISE: * * SAVE PARM REGISTER * * INITIALISE PROCESS FLAGS * * * * * * GU-PROCESS: * * CALL DFSTDLI0 USING GU,PCB,IO_AREA * * IF STATUSbb THEN GO TO GU-RETURN * * ELSEIF STATUSQC THEN SET TIME-TO-GO FLAG * * ELSE SET BAD-GU-STATUS FLAG * * * * GU-RETURN: * * RETURN. * * * * * * DATE-PROCESS: * * GET DATE FROM PCB. * * SAVE TIME FROM PCB. * DIVIDE DATE INTO century-year AND days * * DIVIDE century-year BY 4 * * SPLIT RESULT INTO number-of-leap-days AND remainder * * /* if the year is divisible by 4 then this will result in the * * number of days since 1900 being over by 1 */ * * MULTIPLY century-year BY 365 * * ADD number-of-leap-days * * ADD days * * /* The result is the number of days since 1900 */ * * MOVE year * * ADD 1900 /* this gives a true century value */ * * DIVIDE INTO century AND year * * IF remainder = 0 THEN DO * * CORRECT THE result * * IF remainder(century-year / 400) = 0 THEN GOTO A-LEAP-YEAR * * ELSEIF year = 0 THEN GO TO NOT-A-LEAP-YEAR * * ELSE GO TO A-LEAP-YEAR * * END * * GO TO NOT-A-LEAP-YEAR * * * * A-LEAP-YEAR: * * MOVE 29 TO FEBRUARY * * GO TO A-LEAP-YEAR-1. * * * * NOT-A-LEAP-YEAR: * * MOVE 28 TO FEBRUARY * * * * A-LEAP-YEAR-1: * * * * POINT TO START-OF-MONTHS * * SET result TO days * * DATE-LOOP-1: * * SUBTRACT DAYS-IN-MONTH FROM result * * IF THE result < 0 THEN GO TO DATE-LOOP-1-END * * MOVE TO THE NEXT MONTH * * GO TO DATE-LOOP-1 * * DATE-LOOP-1-END: * * /* pointer now has this month. */ * * ADD DAYS-IN-THIS-MONTH TO result * * MOVE result TO SCR## * * MOVE MONTH-NAME TO SCRMTH * * * * POINT TO DAY-NAMES * * DIVIDE daynum / 7 /* This gives remainder 0=MON, 1=TUE etc. */ * * SET counter TO 0 * * DATE-LOOP-2: * * IF result = counter THEN GO TO DATE-LOOP-2-END * * ADD 1 TO counter * * MOVE TO THE NEXT DAY-NAME * * GO TO DATE-LOOP-2 * * DATE-LOOP-2-END: * * MOVE DAY-NAME TO SCRDAY * * MOVE YEAR TO SCRYEAR * * RETURN. * * * * * * EDIT-PROCESS: * * IF mess-length ª= 8 THEN GO TO EDIT-NOT-MSGSET * * * * PRIME SEGMENT POINTER * * EDIT-NEXT-MSG: * * IF SEGMENT POINTER = 0 THEN GO TO EDIT-NO-MORE * * * * SET INDEX = LENGTH * * EDIT-LOOP-1: * * IF message-text(INDEX) = "MTH" THEN GO TO EDIT-LOOP-1-END * * SKIP TO NEXT BYTE * * SUBTRACT 1 FROM INDEX * * IF INDEX ª= 0 THEN GO TO EDIT-LOOP-1 * * GO TO EDIT-MTH-NOT-FND * * EDIT-LOOP-1-END: * * MOVE SCRMTH TO message-text(INDEX) * * EDIT-MTH-NOT-FND: * * * * SET INDEX = LENGTH * * EDIT-LOOP-2: * * IF message-text(INDEX) = "DAY" THEN GO TO EDIT-LOOP-2-END * * SKIP TO NEXT BYTE * * SUBTRACT 1 FROM INDEX * * IF INDEX ª= 0 THEN GO TO EDIT-LOOP-2 * * GO TO EDIT-DAY-NOT-FND * * EDIT-LOOP-2-END: * * MOVE SCRDAY TO message-text(INDEX) * * EDIT-DAY-NOT-FND: * * * * SET INDEX = LENGTH * * EDIT-LOOP-3: * * IF message-text(INDEX) = "##" THEN GO TO EDIT-LOOP-3-END * * SKIP TO NEXT BYTE * * SUBTRACT 1 FROM INDEX * * IF INDEX ª= 0 THEN GO TO EDIT-LOOP-3 * * GO TO EDIT-##-NOT-FND * * EDIT-LOOP-3-END: * * MOVE SCRDAY TO message-text * * EDIT-##-NOT-FND: * * * * SET INDEX = LENGTH * * EDIT-LOOP-4: * * IF message-text(INDEX) = "YEAR" THEN GO TO EDIT-LOOP-4-END * * SKIP TO NEXT BYTE * * SUBTRACT 1 FROM INDEX * * IF INDEX ª= 0 THEN GO TO EDIT-LOOP-4 * * GO TO EDIT-YEAR-NOT-FND * * EDIT-LOOP-4-END: * * MOVE SCRYEAR TO message-text * * EDIT-YEAR-NOT-FND: * * * * SET INDEX = LENGTH * * EDIT-LOOP-5: * * IF message-text(INDEX) = "TIME" THEN GO TO EDIT-LOOP-5-END * * SKIP TO NEXT BYTE * * SUBTRACT 1 FROM INDEX * * IF INDEX ª= 0 THEN GO TO EDIT-LOOP-5 * * GO TO EDIT-TIME-NOT-FND * * EDIT-LOOP-5-END: * * MOVE SCRTIME TO message-text * * EDIT-TIME-NOT-FND: * * * * CALL ISRT-PROCESS * * IF LAST SEGMENT WAS NOT EOM THEN RESET PURG FLAG * * SKIP TO NEXT SEGMENT * * GO TO EDIT-NEXT-MSG * * * * EDIT-NOT-MSG-SET * * CALL ISRT-PROCESS * * IF BAD-ISRT-STATUS THEN GO TO EDIT-ERROR * * GO TO EDIT-NO-MORE * * * * EDIT-ERROR: * * SEND ERROR MESSAGES /* not implemented */ * * * * EDIT-NO-MORE: * * RETURN. * * * * * * ISRT-PROCESS: * * IF PURG THEN GO TO PURG-PROCESS * * SET PURG FLAG * * CALL DFSTDLI0 USING ISRT,PCB,IO_AREA * * IF STATUSbb THEN GO TO ISRT-DONE * * ELSE SET BAD-ISRT-STATUS FLAG * * GO TO ISRT-RETURN * * * * PURG-PROCESS * * CALL DFSTDLI0 USING PURG,PCB,IO_AREA * * IF STATUSbb THEN GO TO ISRT-RETURN * * ELSE SET BAD-PURG-STATUS FLAG * * * * ISRT-RETURN: * * RETURN. * *---------------------------------------------------------------------* REQUATE CHANGEID NAME=ZXTCOXIT.ASSEMBLED.AT.&SYSTIME..ON.&SYSDATE..(C)X .1992.COPYRIGHT.NATIONAL.WESTMINSTER.BANK.PLC,BASE=R12 CHANGEID IDEND=YES EJECT LA R15,INIT_PARMS BASR R14,R15 Initialise parms etc. MAIN_LOOP DS 0H LA R15,GU_PROC BASR R14,R15 TCO GU processing TM PROCESS,BAD_GU_STATUS BO MAIN_ERROR TM PROCESS,TIME_TO_GO BO MAIN_RETURN LA R15,DATE_PROC BASR R14,R15 find day and month names LA R15,EDIT_PROC BASR R14,R15 edit input message TM PROCESS,BAD_ISRT_STATUS BO MAIN_ERROR TM PROCESS,BAD_PURG_STATUS BO MAIN_ERROR B MAIN_LOOP MAIN_ERROR DS 0H * error handling can go here. MAIN_RETURN DS 0H LEAVE RC=0 EJECT INIT_PARMS DS 0H BAKR R14,0 L R1,0(R1) load I/O PCB address LA R1,0(,R1) reset the top bit ST R1,IO_PCB_A save IO_PCB for later NI PROCESS,B'00000000' reset ALL flags PR EJECT GU_PROC DS 0H BAKR R14,0 L R4,IO_PCB_A load I/O PCB address USING IO_PCB,R4 address I/O pcb LA R5,IO_AREA load I/O area address CALL DFSTDLI0,(=CL4'GU',(R4),(R5)),VL, c MF=(E,CALLLIST) CLC =C' ',IO_STATUS blank status code ? BE GU_RETURN yes - happiness CLC =C'QC',IO_STATUS QC status code ? BE GU_QC_STATUS nearly time to go home B GU_BAD_STATUS anything else GU_QC_STATUS DS 0H OI PROCESS,TIME_TO_GO set QC status received B GU_RETURN GU_BAD_STATUS DS 0H OI PROCESS,BAD_GU_STATUS set bad status code GU_RETURN DS 0H DROP R4 PR EJECT DATE_PROC DS 0H BAKR R14,0 L R4,IO_PCB_A address the io-pcb to get date USING IO_PCB,R4 MVC DATE,IO_MSG_DATE date = 0cyydddf from io-pcb MVC SCRTIME,IO_MSG_TIME move the time from pcb DROP R4 ZAP YEAR,DATE year = 0000cyydddC DP YEAR,=P'1000' year = 0cyyC00dddC ZAP DATE,YEAR+3(3) date = 0000dddC ZAP YEAR,YEAR(3) year = 0000000cyyC ZAP WORK1,YEAR work1 = 0000cyyC DP WORK1,=P'4' work1 = 000llCrC ZAP WORK3,WORK1+3(1) work3 = 000000rC ZAP WORK1,WORK1(3) work1 = 00000llC ZAP DAYNUM,YEAR daynum = 0000cyyC MP DAYNUM,=P'365' daynum = 0nnnnnnC AP DAYNUM,WORK1 daynum = 0mmmmmmC AP DAYNUM,DATE daynum = 0ooooooC AP YEAR,=P'1900' year = 000000yyyyC ZAP WORK2,YEAR work2 = 000yyyyC DP WORK2,=P'100' work2 = 0hhC0llC ZAP YEAR1,WORK2(2) year1 = century digits of yyyy ZAP YEAR2,WORK2+2(2) year2 = lo order digits of yyyy CP WORK3,=P'0' is year divisible by 4 ? BNE DATE_NOTALEAP no - not a leap year SP DAYNUM,=P'1' yes so subtract 1 from daynum ZAP WORK3,YEAR work3 = 000yyyyC DP WORK3,=P'400' work3 = 0llCrrrC ZAP WORK3,WORK3+2(2) work3 = 0000rrrC CP WORK3,=P'0' is year divisible by 400 ? BE DATE_ISALEAP yes - is a leap year CP YEAR2,=P'0' is year divisible by 100 ? BE DATE_NOTALEAP yes - not a leap year DATE_ISALEAP DS 0H MVC FEB(2),=P'29' set 29 days for February B DATE_ISALEAP1 DATE_NOTALEAP DS 0H MVC FEB(2),=P'28' set 28 days for February DATE_ISALEAP1 DS 0H LA R4,MONTHS point to January USING THISMTH,R4 ZAP WORK4,DATE work4 = 0000dddC DATE_LOOP1 DS 0H SP WORK4,THISMTHD work4 = work4 - days in month CP WORK4,=P'0' is it less than equal 0 ? BNP DATE_FOUNDIT LA R4,THISMTHL(R4) next month B DATE_LOOP1 DATE_FOUNDIT DS 0H AP WORK4,THISMTHD work4 = day.of.month UNPK SCR##,WORK4 make todays date printable OI SCR##+1,X'F0' and correct the last character MVC SCRMTH,THISMTHN move English.mth.name DROP R4 LA R4,DAYNAMES point to Monday ZAP WORK1,DAYNUM DP WORK1,=P'7' remainder - 0=MON, 1=TUE etc. ZAP WORK1,WORK1+3(1) ZAP WORK2,=P'0' DATE_LOOP2 DS 0H CP WORK1,WORK2 does it match ? BE DATE_LOOP2_END yes - we've found todays entry AP WORK2,=P'1' work2 = work2 + 1 LA R4,3(R4) next day B DATE_LOOP2 DATE_LOOP2_END DS 0H MVC SCRDAY,0(R4) move English.day.name UNPK SCRYEAR,YEAR make year printable OI SCRYEAR+3,X'F0' and correct the last character PR EJECT EDIT_PROC DS 0H BAKR R14,0 LA R3,IO_AREA address input segment LH R5,0(R3) load up the length CH R5,=H'8' BNE EDIT_NOT_MSGSET its a time-schd-req without **** L R3,4(R3) prime segment pointer EDIT_NEXT_MSG DS 0H LTR R3,R3 do we have a segment ? BZ EDIT_NO_MORE no - exit loop LA R4,4(R3) skip next msg pointer ST R4,MSGADDR save for later and for ISRT. LH R5,0(R4) load up the length SH R5,=H'4' subtract prefix length LA R4,4(R4) skip ll/zz EDIT_LOOP1 DS 0H CLC =C'MTH',0(R4) look for MTH to substitute BE EDIT_LOOP1_END found it LA R4,1(R4) next position BCT R5,EDIT_LOOP1 and around we go B EDIT_MTH_NOTFND EDIT_LOOP1_END DS 0H MVC 0(3,R4),SCRMTH replace MTH with month name EDIT_MTH_NOTFND DS 0H L R4,MSGADDR point to input segment LH R5,0(R4) load up the length SH R5,=H'4' subtract prefix length LA R4,4(R4) skip ll/zz EDIT_LOOP2 DS 0H CLC =C'DAY',0(R4) look for DAY to substitute BE EDIT_LOOP2_END found it LA R4,1(R4) next position BCT R5,EDIT_LOOP2 and around we go B EDIT_DAY_NOTFND EDIT_LOOP2_END DS 0H MVC 0(3,R4),SCRDAY replace DAY with todays name EDIT_DAY_NOTFND DS 0H L R4,MSGADDR point to input segment LH R5,0(R4) load up the length SH R5,=H'4' subtract prefix length LA R4,4(R4) skip ll/zz EDIT_LOOP3 DS 0H CLC =C'##',0(R4) look for ## to substitute BE EDIT_LOOP3_END found it LA R4,1(R4) next position BCT R5,EDIT_LOOP3 and around we go B EDIT_##_NOTFND EDIT_LOOP3_END DS 0H MVC 0(2,R4),SCR## replace ## with todays date EDIT_##_NOTFND DS 0H L R4,MSGADDR point to input segment LH R5,0(R4) load up the length SH R5,=H'4' subtract prefix length LA R4,4(R4) skip ll/zz EDIT_LOOP4 DS 0H CLC =C'YEAR',0(R4) look for YEAR to substitute BE EDIT_LOOP4_END found it LA R4,1(R4) next position BCT R5,EDIT_LOOP4 and around we go B EDIT_YEAR_NOTFND EDIT_LOOP4_END DS 0H MVC 0(4,R4),SCRYEAR replace YEAR with todays value EDIT_YEAR_NOTFND DS 0H L R4,MSGADDR point to input segment LH R5,0(R4) load up the length SH R5,=H'4' subtract prefix length LA R4,4(R4) skip ll/zz EDIT_LOOP5 DS 0H CLC =C'TIME',0(R4) look for TIME to substitute BE EDIT_LOOP5_END found it LA R4,1(R4) next position BCT R5,EDIT_LOOP5 and around we go B EDIT_TIME_NOTFND EDIT_LOOP5_END DS 0H MVC 0(4,R4),SCRTIME replace TIME with message time EDIT_TIME_NOTFND DS 0H LA R15,ISRT_PROC BASR R14,R15 TCO ISRT processing TM PROCESS,BAD_ISRT_STATUS BO EDIT_ERROR TM PROCESS,BAD_PURG_STATUS BO EDIT_ERROR TM 7(R3),X'02' was last segment an end-of-msg ? BNZ EDIT_NO_RESET yes - PURG next time. NI PROCESS,X'FF'-PURG_NEEDED reset PURG flag EDIT_NO_RESET DS 0H L R3,0(R3) pick up next segment B EDIT_NEXT_MSG EDIT_NOT_MSGSET DS 0H ST R3,MSGADDR LA R15,ISRT_PROC BASR R14,R15 TCO ISRT processing TM PROCESS,BAD_ISRT_STATUS BO EDIT_ERROR B EDIT_NO_MORE EDIT_ERROR DS 0H * error handling can go here. EDIT_NO_MORE DS 0H PR EJECT ISRT_PROC DS 0H BAKR R14,0 L R4,IO_PCB_A load I/O PCB address USING IO_PCB,R4 ... and keep assembler sweet. L R5,MSGADDR load output message address TM PROCESS,PURG_NEEDED BO PURG_PROC PURG is required. OI PROCESS,PURG_NEEDED set PURG for next message CALL DFSTDLI0,(=CL4'ISRT',(R4),(R5)),VL, X MF=(E,CALLLIST) CLC =C' ',IO_STATUS blank status code ? BE ISRT_RETURN yes - happiness OI PROCESS,BAD_ISRT_STATUS set bad status code B ISRT_RETURN PURG_PROC DS 0H CALL DFSTDLI0,(=CL4'PURG',(R4),(R5)),VL, X MF=(E,CALLLIST) CLC =C' ',IO_STATUS blank status code ? BE ISRT_RETURN yes - happiness OI PROCESS,BAD_PURG_STATUS set bad status code ISRT_RETURN DS 0H DROP R4 PR EJECT IO_AREA DS 5F MSGADDR DS F DAYNAMES DS 0CL3 DC CL3'SUN' DC CL3'MON' DC CL3'TUE' DC CL3'WED' DC CL3'THU' DC CL3'FRI' DC CL3'SAT' MONTHS DS 0F DC P'31',P'01',CL3'JAN' FEB DC P'00',P'02',CL3'FEB' DC P'31',P'03',CL3'MAR' DC P'30',P'04',CL3'APR' DC P'31',P'05',CL3'MAY' DC P'30',P'06',CL3'JUN' DC P'31',P'07',CL3'JUL' DC P'31',P'08',CL3'AUG' DC P'30',P'09',CL3'SEP' DC P'31',P'10',CL3'OCT' DC P'30',P'11',CL3'NOV' DC P'31',P'12',CL3'DEC' CALLLIST DS 6F IO_PCB_A DS F DATE DS PL4 YEAR DS PL6 YEAR1 DS PL2 YEAR2 DS PL2 DAYNUM DS PL4 WORK1 DS PL4 WORK2 DS PL4 WORK3 DS PL4 WORK4 DS PL2 PROCESS DS X TIME_TO_GO EQU X'80' BAD_GU_STATUS EQU X'40' BAD_ISRT_STATUS EQU X'20' BAD_PURG_STATUS EQU X'10' PURG_NEEDED EQU X'08' PROCESS_FLAG_5 EQU X'04' spare PROCESS_FLAG_6 EQU X'02' spare PROCESS_FLAG_7 EQU X'01' spare SCRDAY DS CL3 SCR## DS CL2 SCRMTH DS CL3 SCRYEAR DS CL4 SCRTIME DS CL4 LTORG THISMTH DSECT THISMTHD DS PL2 THISMTH# DS PL2 THISMTHN DS CL3 THISMTHL EQU *-THISMTH IO_PCB DSECT DS CL8 DS CL2 IO_STATUS DS CL2 IO_MSG_DATE DS PL4 IO_MSG_TIME DS CL4 END ZXTCOMVS CSECT REQUATE CHANGEID NAME=ZXTCOMVS.ASSEMBLED.AT.&SYSTIME..ON.&SYSDATE..(C)X .1992.COPYRIGHT.NATIONAL.WESTMINSTER.BANK.PLC,BASE=R12 CHANGEID IDEND=YES EJECT LA R15,INIT_PARMS BASR R14,R15 Initialise parms etc. MAIN_LOOP DS 0H LA R15,GU_PROC BASR R14,R15 TCO GU processing TM PROCESS,BAD_GU_STATUS BO MAIN_ERROR TM PROCESS,TIME_TO_GO BO MAIN_RETURN LA R15,EDIT_PROC BASR R14,R15 edit input message B MAIN_LOOP MAIN_ERROR DS 0H * error handling can go here. MAIN_RETURN DS 0H LEAVE RC=0 EJECT INIT_PARMS DS 0H BAKR R14,0 L R1,0(R1) load I/O PCB address LA R1,0(,R1) reset the top bit ST R1,IO_PCB_A save IO_PCB for later NI PROCESS,B'00000000' reset ALL flags PR EJECT GU_PROC DS 0H BAKR R14,0 L R4,IO_PCB_A load I/O PCB address USING IO_PCB,R4 address I/O pcb LA R5,IO_AREA load I/O area address CALL DFSTDLI0,(=CL4'GU',(R4),(R5)),VL, c MF=(E,CALLLIST) CLC =C' ',IO_STATUS blank status code ? BE GU_RETURN yes - happiness CLC =C'QC',IO_STATUS QC status code ? BE GU_QC_STATUS nearly time to go home B GU_BAD_STATUS anything else GU_QC_STATUS DS 0H OI PROCESS,TIME_TO_GO set QC status received B GU_RETURN GU_BAD_STATUS DS 0H OI PROCESS,BAD_GU_STATUS set bad status code GU_RETURN DS 0H DROP R4 PR EJECT EJECT EDIT_PROC DS 0H BAKR R14,0 LA R3,IO_AREA address input segment LH R5,0(R3) load up the length CH R5,=H'8' BNE EDIT_NOT_MSGSET its a time-schd-req without **** L R3,4(R3) prime segment pointer EDIT_NEXT_MSG DS 0H LTR R3,R3 do we have a segment ? BZ EDIT_NO_MORE no - exit loop LA R4,4(R3) skip next msg pointer ST R4,MSGADDR save for MGCR. LA R15,MGCR_PROC BASR R14,R15 MVS MGCR processing L R3,0(R3) pick up next segment B EDIT_NEXT_MSG EDIT_NOT_MSGSET DS 0H ST R3,MSGADDR LA R15,MGCR_PROC BASR R14,R15 MVS MGCR processing B EDIT_NO_MORE EDIT_NO_MORE DS 0H PR EJECT MGCR_PROC DS 0H BAKR R14,0 L R5,MSGADDR load output message address USING MSG,R5 OI MSGLL,X'80' XC MSGZZ,MSGZZ XR R0,R0 MGCR (R5) DROP R5 PR EJECT IO_AREA DS 5F MSGADDR DS F CALLLIST DS 6F IO_PCB_A DS F PROCESS DS X TIME_TO_GO EQU X'80' BAD_GU_STATUS EQU X'40' PROCESS_FLAG_2 EQU X'20' spare PROCESS_FLAG_3 EQU X'10' spare PROCESS_FLAG_4 EQU X'08' spare PROCESS_FLAG_5 EQU X'04' spare PROCESS_FLAG_6 EQU X'02' spare PROCESS_FLAG_7 EQU X'01' spare IO_PCB DSECT DS CL8 DS CL2 IO_STATUS DS CL2 IO_MSG_DATE DS PL4 IO_MSG_TIME DS PL4 MSG DSECT MSGLL DS H MSGZZ DS H MSGTEXT DS CL126 END