PRINT NOGEN TITLE 'MQERROR - Issue reply retry, wait or cancel' MQERROR AMODE 31 MQERROR RMODE ANY MQERROR BEGIN R12,VER=2.0 *---------------------------------------------------------------------* *---* W E L C O M E T O M Q E R R O R *---* *---------------------------------------------------------------------* *---* PURPOSE : *---* *---* Issues a reply retry, wait or cancel message *---* *---* The text of this message is passed by the calling *---* *---* program, or a generic message will be issued *---* *---------------------------------------------------------------------* COPY BSLEQUC L R1,0(R1) Pick up the passed parm LA R10,2(R1) ... and point to message XR R7,R7 Clear R7 LH R7,0(R1) Get length CH R7,=H'53' Make sure length is < 53 BH Length_Error C R7,=F'0' Is length 0? BNE START No - go to start WTP 'MQERR01E - NO PARMS PASSED. RC=16' ABEND EQU * LA R15,16 Set return code 16 B EXIT_ERROR Length_Error EQU * WTP 'MQERR02E - INVALID PARM PASSED. RC=16' B ABEND Now fail START EQU * BCTR R7,0 Subtract length ST R7,Parm_Length EXTRACT TIOTADDR,FIELDS=TIOT L R3,TIOTADDR Load TIOT address into R3 MVC REALJOB,0(R3) Move our jobname to message * MVC WTOR+27(8),8(R3) INTO MESSAGE AREA * ** Establish default values * MVI WTOR_NEEDED,C'Y' Set flag off NO_DCB EQU * DEVTYPE =CL8'NOWTOR ',CVBAREA Do we need a WTOR? LTR R15,R15 Did we find a NOWTOR? BNZ NO_WTOR No - Skip to NO_NOWTOR MVI WTOR_NEEDED,C'N' Set flag off NO_WTOR EQU * XR R1,R1 Clear R1 LA R2,CIBAREA LOAD ADDRESS OF WHERE TO PUT IT EXTRACT (R2),FIELDS=(COMM) EXTRACT COMMS ID L R2,CIBAREA GET THE RETURNED ADDRESS USING COMLIST,R2 ADDRESSABILITY TO COMLIST L R5,COMCIBPT GET ADDRESS OF CIB USING CIBNEXT,R5 ADDRESSABILITY TO CIB MVC DATAAREA(16),CIBDATA Populate the Dataarea CLI CIBVERB,CIBSTART FIRST CIB (START COMMAND) ? BNE SETLIMIT NO - GO SET LIMIT QEDIT ORIGIN=COMCIBPT,BLOCK=(R5) FREE CIB LTR R15,R15 Did it work ? BZ SETLIMIT Yes - Go set some limits WTO 'MQERR03I - FREE OF START CIB UNSUCCESSFUL' SETLIMIT EQU * QEDIT ORIGIN=COMCIBPT,CIBCTR=2 Set Command limit to 2 L R4,COMECBPT Pointer to the com ECB ST R4,ECBADDR Save the COM ECB in the ECBLIST Issue_it EQU * L R7,Parm_Length Restore parameter length EX R7,Move_Message Move parm to Our_Message Re_issue_it equ * CLI WTOR_NEEDED,C'Y' WTOR needed? BE ISSUE_WTOR If yes - go issue it * ** Now construct the WTO * MVC Mess+7(1),=C'I' Set to informational A R7,=f'20' Add enough for 1st bits ... EX R7,Move_WTO ... and move it to the WTOR LA R1,Wtolist+5 Skip the systemy bits AR R1,R7 and point at end of message MVC 0(4,R1),WTOCODES Move in the rout and desc codes LA R7,5(R7) Increase length by systemy bits * .. add 1 cos we took 1 off for * .. the original execute intr STH R7,WTOLIST WTO MF=(E,WTOLIST) ST R1,SAVER1 Save R1 for DOM B wait Now go wait for response ISSUE_WTOR Equ * LA R1,Our_Message Point at our message AR R1,R7 Skip to the end of it ... MVC 1(33,R1),Tail_end .. and bung the tail_end in A R7,=f'53' Add enough for all bits ... EX R7,Move_WTOR ... and move it to the WTOR WTOR Equ * A R7,=F'5' Add enough for the systemy bits STH R7,WTOR_LENGTH .. and save in temp length MVC WTORLIST+9(1),REAL_WTOR_LENGTH Grab one byte WTOR MF=(E,WTORLIST) Issue the WTOR ST R1,SAVER1 Save R1 for DOM WAIT EQU * LA R4,REPLY_ECB Address of REPLY_ECB in R4 ST R4,Lastone Save it in list OI Lastone+0,x'80' Flag end of list WAIT 1,ECBLIST=ECBADDR,LONG=YES WAIT for ECB to pop TM REPLY_ECB,X'40' Was it a reply pop? BNO TRYMOD No - Try modify NI REPLY_ECB,X'00' Reset ECB TR REPLYFLD,TRTABLE Make it reponse uppercase CLC REPLYFLD(5),=C'RETRY' Was it "RETRY"? BE Issue_retry If yes - then go retry it CLC REPLYFLD(6),=C'CANCEL' Was is "CANCEL"? BE CANCEL_OUT If Yes - then go cancel out CLC REPLYFLD(4),=C'WAIT' Was it "WAIT"? BNE WTOR If not - re-issue WTOR CLC REPLYFLD+5(3),=c' ' BE Now_Wait LA R6,REPLYFLD+4 Load R6 with end of WAIT BAS R11,CHECK_Wait Go validate the wait value Now_wait equ * STIMER WAIT,BINTVL=DELAY Wait for xx seconds B exit Now try again TRYMOD EQU * L R2,CIBAREA Reload R2 L R5,COMCIBPT Obtain CIB address CLI CIBVERB,CIBMODFY Was it a modify? BNE COMMAND_INVALID No - Then is must be invalid CLC CIBDATA(5),=C'RETRY' Is it a "RETRY" command? BNE TRY_CANCEL No _ skip to try cancel L R1,SAVER1 Restore R1 for DOM DOM MSG=(R1) Delete previous message QEDIT ORIGIN=COMCIBPT,BLOCK=(R5) Free CIB Issue_retry EQU * WTO 'MQERR05I - Retry command accepted' B EXIT TRY_CANCEL EQU * CLC CIBDATA(6),=C'CANCEL' Is it a cancel? BE Cancel_out Yep - Go cancel out then CLC CIBDATA(4),=C'WAIT' Is it a WAIT? BNE COMMAND_INVALID No - Then it must be invalid Clc CIBDATLN,=h'4' Check for Valid wait BE SKip_wait_check Invalid length - Then skip LA R6,WORK Load R6 with Work address XR R0,R0 Clear R0 LH R0,CIBDATLN Load our length into R0 BCTR R0,0 Take one off EX R0,Move_it And move in the length BAS R11,CHECK_Wait Now go and validate it SKip_wait_check EQU * L R1,SAVER1 Restore R1 for DOM DOM MSG=(R1) Delete previous message QEDIT ORIGIN=COMCIBPT,BLOCK=(R5) Free CIB B NOW_WAIT And go and wait COMMAND_INVALID EQU * CLI CIBVERB,CIBSTOP Is it a STOP(P) Command? BE Cancel_out No - Forget it WTO 'MQERR06E - Invalid command' L R1,SAVER1 Restore R1 for DOM DOM MSG=(R1) Delete previous message QEDIT ORIGIN=COMCIBPT,BLOCK=(R5) Free CIB B Re_Issue_it and go re-issue the message *---------------------------------------------------------------------* *** This subroutine checks the wait value passed *** *---------------------------------------------------------------------* CHECK_WAIT EQU * MVC WORK(4),0(r6) Move passed value in work area TR work,TRTABLE Make '40' low values L R6,WORK Load R6 with modified wait LTR R6,R6 Is it 0? BZ Exit_wait_routine Yes - Stay with default and exit Next_attempt equ * * CLI Work+3,x'00' * Drop low order low values BNE Done_messing * SRL R6,8 * ST R6,WORK * B Next_attempt * Done_messing equ * ST R6,WORK Save R6 MVI Start_flag,C'N' Set Start indicator LA r3,4 Maximum Loop count LA R6,Work-1 Point to one byte before WORK Next_Digit EQU * LA R6,1(R6) Up R6 to next byte CLI 0(r6),x'00' Low values? BE Test_Flag Yes - Go check start flag CLI 0(R6),C'0' Make sure it is a number BL SET_20 No - Go Set default CLI 0(R6),C'9' Make sure it is a number BH SET_20 No - Go Set default MVI Start_flag,C'Y' Set flag to indicate we started BCT r3,Next_Digit and go check next digit PACK WORK,WORK Pack the validated number L R6,WORK and load it into R6 SRL R6,4 Drop the F...... SLL R6,12 ...and shuffle it along for * because we need binary 100ths ST R6,WORK Save it back OI WORK+3,X'0F' now reset the pack digit again CVB R6,DOUBLE Convert it ST R6,DELAY and save new value as delay B Exit_Wait_Routine Now get the heck out Test_flag EQU * BCTR R3,0 Subtract 1 CLI Start_flag,c'N' Have we hit a start yet? BE Next_Digit No - Then process next digit Set_20 EQU * WTO 'MQERR07E - Invalid wait value. Set to 60 seconds' MVC Delay,=F'6000' Set Default Exit_wait_routine equ * BR R11 *-------------------------------------------------------------------* EXIT EQU * EXIT_PROCESS EQU * XR R15,R15 Clear R0 for cond code EXIT_ERROR equ * EOJ C=(R15) and exit CANCEL_OUT EQU * MVC DUMPWTP+19(8),realjob Move our jobname to wto dumpwtp WTP 'MQERR08I - xxxxxxxx Job Cancelled' LA R15,8 B Exit_Error Now dump * * Executed instructions * Move_it MVC WORK+0(*-*),CIBDATA+4 Move wait value TRANSIT TR 0(*-*,R10),TRTABLE Make it uppercase Move_Message MVC Our_message(*-*),0(R10) Move message text Move_Tail MVC Our_message(*-*),0(R10) Move message text Move_WTOR MVC WTORLIST+12(*-*),MESS Move message to WTOR Move_WTO MVC WTOLIST+4(*-*),MESS Move message to WTO * * End of Executed instructions * CVBAREA DS D DOUBLE DS 0D DS F WORK DS F DATAAREA DS 4F SAVER1 DS F CIBAREA DS F *---------------------------------------------------------------------* * Write to operator Skeleton * *---------------------------------------------------------------------* PRINT GEN WTOLIST WTO 'BSL002I ¦0123456789012345678901234567890123456789012345x 67890123456789012345678901234567890123456789012345678901x 234567890',ROUTCDE=(2,11),DESC=(2),MF=L WTOCODES EQU WTOLIST+124,4 PRINT NOGEN WTORLIST WTOR '1234567890123456789012345678901234567890123456789012345x 67890123456789012345678901234567890123456789012345678901x 234567890', x REPLYFLD,8,REPLY_ECB,MF=L Parm_Length DS F WTOR_LENGTH DS H REAL_WTOR_LENGTH EQU WTOR_LENGTH+1,1 * * Flags * WTOR_NEEDED DS CL1 WTOR required flag Start_Flag DS CL1 * REPLYFLD DS CL8 Reply field for WTOR DS 0H MESS DS 0CL106 DC CL11'MQERR04A - ' REALJOB DS CL8 DC CL1' ' Our_Message DS CL53 Tail_End DC CL33' Reply ''RETRY'',''WAIT'' or ''CANCEL''' *********************************************************************** * | THIS IS THE DEFAULT WAIT TIME * V DELAY DC F'6000' WAIT 60 SECONDS * ** Here are the ECB's to be waited on * TIOTADDR DC F'0' REPLY_ECB DC F'0' ECBADDR DC A(0) lastone DC A(reply_ecb) * TRTABLE DS 0CL256 * 0 1 2 3 4 5 6 7 8 9 A B C D E F DC X'40000000000000000000000000000000' 00-0F DC X'00000000000000000000000000000000' 10-1F DC X'00000000000000000000000000000000' 20-2F DC X'00000000000000000000000000000000' 30-3F DC X'00000000000000000000000000000000' 40-4F DC X'0000000000000000000000005C000000' 50-5F DC X'00000000000000000000000000000000' 60-6F DC X'00000000000000000000000000000000' 70-7F DC X'00C1C2C3C4C5C6C7C8C9000000000000' 80-8F DC X'00D1D2D3D4D5D6D7D8D9000000000000' 90-9F DC X'00E1E2E3E4E5E6E7E8E9000000000000' A0-AF DC X'00000000000000000000000000000000' B0-BF DC X'00C1C2C3C4C5C6C7C8C9000000000000' C0-CF DC X'00D1D2D3D4D5D6D7D8D9000000000000' D0-DF DC X'00E1E2E3E4E5E6E7E8E9000000000000' E0-EF DC X'F0F1F2F3F4F5F6F7F8F9000000000040' F0-FF ORG LTORG DSECT IEZCOM DSECT IEZCIB END MQERROR PUNCH ' MODE AMODE(31)' Binder AMODE statement. PUNCH ' MODE RMODE(ANY)' Binder RMODE statement. PUNCH ' ENTRY MQERROR' Binder Module entry point. PUNCH ' NAME MQERROR(R)' BINDER MODULE NAME. END , END OF BINDER INPUT.