000100 ID DIVISION. 00010000 000200 PROGRAM-ID. TRPGM93. 00020000 000300*AUTHOR. Kenneth W. Caldwell. 00030000 000400*INSTALLATION. Train-Right. 00040000 000500*DATE-WRITTEN. February 3, 2011. 00050000 000600*DATE-COMPILED. 00060000 000700* 00070000 000800*SECURITY. This program is for students of Train-Right 00080000 000900* courses ONLY!. 00090000 001000* 00100000 001100*REMARKS. This writes/reads a temporary storage queue 00110000 001200* to/from another CICS system. 00120000 001300* It is an asynchronous processing transaction. 00130000 001400* It uses function request shipping. 00140000 001500* 00150000 001600 DATA DIVISION. 00160000 001700 WORKING-STORAGE SECTION. 00170000 001800 01. 00180000 001900 05 start-code PIC X(2). 00190000 002000 88 start-terminal VALUE 'TD'. 00200000 002100 88 start-command-no-data VALUE 'S'. 00210000 002200 88 start-command-data VALUE 'SD'. 00220000 002300 00230000 002400 05 local-sysid PIC X(4). 00240000 002500 05 tr-pgm PIC X(8). 00250000 002600 05 tr-termid PIC X(4). 00260000 002700 00270000 002800 05 user-input. 00280000 002900 10 PIC X(5) VALUE SPACES. 00290000 003000 10 user-sysid PIC X(4) VALUE SPACES. 00300000 003100 00310000 003200 05 ts-queue-name. 00320000 003300 10 ts-queue-name-tranid PIC X(4). 00330000 003400 10 ts-queue-name-termid PIC X(4). 00340000 003500 00350000 003600 05 result. 00360000 003700 10 msg1 PIC X(80) VALUE SPACES. 00370000 003800 10 msg2 PIC X(80) VALUE SPACES. 00380000 003900 00390000 004000 LINKAGE SECTION. 00400000 004100 00410000 004200 PROCEDURE DIVISION. 00420000 004300 Main. 00430000 004400 EXEC CICS ASSIGN STARTCODE(start-code) 00440000 004500 SYSID(local-sysid) 00450000 004600 PROGRAM(tr-pgm) 00460000 004700 END-EXEC. 00470000 004800 00480000 004900 EXEC CICS HANDLE CONDITION SYSIDERR(No-Sysid) 00490000 005000 ENVDEFERR(No-Retreive-Supported) END-EXEC. 00500000 005100 EXEC CICS IGNORE CONDITION LENGERR END-EXEC. 00510000 005200 00520000 005300 EVALUATE TRUE ALSO eibtrmid 00530000 005400 WHEN start-terminal ALSO NOT LOW-VALUES 00540000 005500 GO TO Receive-Trans-Input 00550000 005600 WHEN start-command-data ALSO LOW-VALUES 00560000 005700 GO TO Process-Data-Second 00570000 005800 WHEN start-command-data ALSO NOT LOW-VALUES 00580000 005900 GO TO Process-Data-Last 00590000 006000 WHEN ANY ALSO NOT LOW-VALUES 00600000 006100 GO TO No-Start-Supported 00610000 006200 WHEN OTHER 00620000 006300 GO TO Process-Exit 00630000 006400 END-EVALUATE. 00640000 006500 00650000 006600 Receive-Trans-Input. 00660000 006700 EXEC CICS RECEIVE INTO(user-input) END-EXEC. 00670000 006800 00680000 006900 IF local-sysid = user-sysid 00690000 007000 THEN GO TO No-user-sysid 00700000 007100 END-IF. 00710000 007200 00720000 007300 Process-Data. 00730000 007400 MOVE eibtrnid TO ts-queue-name-tranid. 00740000 007500 MOVE eibtrmid TO ts-queue-name-termid. 00750000 007600 00760000 007700 EXEC CICS IGNORE CONDITION QIDERR END-EXEC. 00770000 007800 EXEC CICS DELETEQ TS QUEUE(ts-queue-name) 00780000 007900 SYSID(user-sysid) 00790000 008000 END-EXEC. 00800000 008100 00810000 008200 STRING 'This 1st message from ' tr-pgm 00820000 008300 ' on system ' local-sysid 00830000 008400 ' using terminal ' eibtrmid '.' 00840000 008500 DELIMITED BY SIZE 00850000 008600 INTO msg1 00860000 008700 END-STRING. 00870000 008800 00880000 008900 EXEC CICS WRITEQ TS QUEUE(ts-queue-name) 00890000 009000 SYSID(user-sysid) 00900000 009100 FROM(msg1) 00910000 009200 END-EXEC. 00920000 009300 00930000 009400 EXEC CICS START TRANSID(eibtrnid) 00940000 009500 SYSID(user-sysid) 00950000 009600 FROM(local-sysid) 00960000 009700 QUEUE(ts-queue-name) 00970000 009800 RTERMID(eibtrmid) 00980000 009900 AFTER SECONDS(20) 00990000 010000 END-EXEC. 01000000 010100 01010000 010200 GO TO Send-Result. 01020000 010300 01030000 010400 Process-Data-Second. 01040000 010500 EXEC CICS RETRIEVE INTO(user-sysid) 01050000 010600 QUEUE(ts-queue-name) 01060000 010700 RTERMID(tr-termid) 01070000 010800 END-EXEC. 01080000 010900 01090000 011000 STRING 'This 2nd message from ' tr-pgm 01100000 011100 ' on system ' local-sysid 01110000 011200 ' using terminal ' eibtrmid '.' 01120000 011300 DELIMITED BY SIZE 01130000 011400 INTO msg1 01140000 011500 END-STRING. 01150000 011600 01160000 011700 EXEC CICS WRITEQ TS QUEUE(ts-queue-name) 01170000 011800 FROM(msg1) 01180000 011900 END-EXEC 01190000 012000 01200000 012100 EXEC CICS START TRANSID(eibtrnid) 01210000 012200 SYSID(user-sysid) 01220000 012300 FROM(local-sysid) 01230000 012400 TERMID(tr-termid) 01240000 012500 AFTER SECONDS(10) 01250000 012600 END-EXEC. 01260000 012700 01270000 012800 GO TO Process-Exit. 01280000 012900 01290000 013000 Process-Data-Last. 01300000 013100 EXEC CICS RETRIEVE INTO(user-sysid) 01310000 013200 END-EXEC. 01320000 013300 01330000 013400 MOVE eibtrnid TO ts-queue-name-tranid. 01340000 013500 MOVE eibtrmid TO ts-queue-name-termid. 01350000 013600 01360000 013700 EXEC CICS HANDLE CONDITION QIDERR(No-Queue) END-EXEC. 01370000 013800 EXEC CICS IGNORE CONDITION ITEMERR END-EXEC. 01380000 013900 01390000 014000 EXEC CICS READQ TS QUEUE(ts-queue-name) 01400000 014100 SYSID(user-sysid) 01410000 014200 INTO(msg1) 01420000 014300 END-EXEC. 01430000 014400 01440000 014500 EXEC CICS READQ TS QUEUE(ts-queue-name) 01450000 014600 SYSID(user-sysid) 01460000 014700 INTO(msg2) 01470000 014800 END-EXEC. 01480000 014900 01490000 015000 EXEC CICS DELETEQ TS QUEUE(ts-queue-name) 01500000 015100 SYSID(user-sysid) 01510000 015200 END-EXEC. 01520000 015300 01530000 015400 Send-Result. 01540000 015500 IF eibtrmid NOT = LOW-VALUES 01550000 015600 THEN EXEC CICS SEND FROM(result) ERASE END-EXEC. 01560000 015700 01570000 015800 Process-Exit. 01580000 015900 EXEC CICS RETURN END-EXEC. 01590000 016000* Dummy GOBACK. 01600000 016100 GOBACK. 01610000 016200 01620000 016300 No-Queue. 01630000 016400 STRING 'Temporary Storage Queue ' ts-queue-name 01640000 016500 ' does not exist on system ' user-sysid '.' 01650000 016600 DELIMITED BY SIZE 01660000 016700 INTO msg1 01670000 016800 END-STRING. 01680000 016900 01690000 017000 GO TO Send-Result. 01700000 017100 01710000 017200 No-user-sysid. 01720000 017300 STRING 'System ' user-sysid ' is not remote.' 01730000 017400 DELIMITED BY SIZE 01740000 017500 INTO msg1 01750000 017600 END-STRING. 01760000 017700 01770000 017800 GO TO Send-Result. 01780000 017900 01790000 018000 No-Sysid. 01800000 018100 STRING 'System ' user-sysid ' does not exist.' 01810000 018200 DELIMITED BY SIZE 01820000 018300 INTO msg1 01830000 018400 END-STRING. 01840000 018500 01850000 018600 GO TO Send-Result. 01860000 018700 01870000 018800 No-Start-Supported. 01880000 018900 STRING 'Start code ' start-code ' on terminal ' eibtrmid 01890000 019000 ' not supported by program ' tr-pgm '.' 01900000 019100 DELIMITED BY SIZE 01910000 019200 INTO msg1 01920000 019300 END-STRING. 01930000 019400 01940000 019500 GO TO Send-Result. 01950000 019600 01960000 019700 No-Retreive-Supported. 01970000 019800 STRING 'START command issued not compatible with RETRIEVE ' 01980000 019900 ' command used by program ' tr-pgm '.' 01990000 020000 DELIMITED BY SIZE 02000000 020100 INTO msg1 02010000 020200 END-STRING. 02020000 020300 02030000 020400 GO TO Send-Result. 02040000