000100 ID DIVISION. 00010000 000200 PROGRAM-ID. TRPGM76. 00020000 000300*AUTHOR. Kenneth W. Caldwell. 00030000 000400*INSTALLATION. Train-Right. 00040000 000500*DATE-WRITTEN. January 15, 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 program LINK's or XCTL's to program TRPGM75.00110000 001200* Program TRPGM75 either RETURN's or XCTL's back. 00120000 001300* It is a Non-Conversational program. 00130000 001400* It can perform a Distributed Program Link (DPL). 00140000 001500* 00150000 001600 DATA DIVISION. 00160000 001700 WORKING-STORAGE SECTION. 00170000 001800 01. 00180000 001900 05 invoking-pgm PIC X(8). 00190000 002000 05 user-input. 00200000 002100 10 PIC X(5) VALUE SPACES. 00210000 002200 10 user-data PIC X(5) VALUE SPACES. 00220000 002300 10 user-sysid PIC X(4) VALUE SPACES. 00230000 002400 00240000 002500 05 input-msg PIC X(12) VALUE 'TR76 TR00 08'. 00250000 002600* 05 input-msg PIC X(9) VALUE 'TR76 TR00'. 00260000 002700* 05 input-msg PIC X(4) VALUE 'TR76'. 00270000 002800* 05 input-msg PIC X(4) VALUE 'TRxx'. 00280000 002900 00290000 003000 LINKAGE SECTION. 00300000 003100 01 dfhcommarea. 00310000 003200 COPY TRRECORD REPLACING ==01== BY ==10== 00320000 003300 ==05== BY ==15== 00330000 003400 ==10== BY ==20==. 00340000 003500 00350000 003600 PROCEDURE DIVISION. 00360000 003700 Main. 00370000 003800 EXEC CICS ASSIGN INVOKINGPROG(invoking-pgm) END-EXEC. 00380000 003900 00390000 004000 IF invoking-pgm > SPACES 00400000 004100 THEN GO TO Send-Result 00410000 004200 END-IF. 00420000 004300 00430000 004400 Receive-Trans-Input. 00440000 004500 EXEC CICS IGNORE CONDITION LENGERR END-EXEC. 00450000 004600 EXEC CICS RECEIVE INTO(user-input) 00460000 004700 MAXFLENGTH(LENGTH OF user-input) 00470000 004800 END-EXEC. 00480000 004900 00490000 005000 Process-Data. 00500000 005100 EVALUATE user-data ALSO user-sysid 00510000 005200 WHEN 'XCTL' ALSO ANY 00520000 005300 EXEC CICS XCTL PROGRAM('TRPGM75') 00530000 005400 INPUTMSG(input-msg) 00540000 005500 INPUTMSGLEN(LENGTH OF input-msg) 00550000 005600 END-EXEC 00560000 005700* WHEN 'LINK' 00570000 005800 WHEN ANY ALSO SPACES 00580000 005900 EXEC CICS GETMAIN SET(ADDRESS OF dfhcommarea) 00590000 006000 FLENGTH(LENGTH OF dfhcommarea) 00600000 006100 END-EXEC 00610000 006200 00620000 006300 EXEC CICS LINK PROGRAM('TRPGM75') 00630000 006400 INPUTMSG(input-msg) 00640000 006500 INPUTMSGLEN(LENGTH OF input-msg) 00650000 006600 COMMAREA(tr-record) 00660000 006700 END-EXEC 00670000 006800 00680000 006900 WHEN ANY ALSO NOT SPACES 00690000 007000 EXEC CICS GETMAIN SET(ADDRESS OF dfhcommarea) 00700000 007100 FLENGTH(LENGTH OF dfhcommarea) 00710000 007200 END-EXEC 00720000 007300 00730000 007400 MOVE input-msg(6:4) TO tr-key-team 00740000 007500 MOVE input-msg(11:2) TO tr-key-num 00750000 007600 00760000 007700 EXEC CICS HANDLE CONDITION SYSIDERR(No-Sysid) END-EXEC 00770000 007800 EXEC CICS LINK PROGRAM('TRPGM75') 00780000 007900 SYSID(user-sysid) 00790000 008000 SYNCONRETURN 00800000 008100 COMMAREA(tr-record) 00810000 008200 END-EXEC 00820000 008300 00830000 008400 IF tr-record = SPACES 00840000 008500 THEN STRING 'Record with key ' input-msg(6:4) ' ' 00850000 008600 input-msg(11:2) 00860000 008700 ' does not exist on system ' user-sysid '.' 00870000 008800 DELIMITED BY SIZE 00880000 008900 INTO tr-record 00890000 009000 END-STRING 00900000 009100 END-IF 00910000 009200 END-EVALUATE. 00920000 009300 00930000 009400 Send-Result. 00940000 009500 EXEC CICS SEND TEXT FROM(tr-record) 00950000 009600 ACCUM 00960000 009700 LENGTH(79) 00970000 009800 END-EXEC. 00980000 009900 EXEC CICS SEND PAGE RETAIN END-EXEC. 00990000 010000 01000000 010100 Process-Exit. 01010000 010200 EXEC CICS RETURN END-EXEC. 01020000 010300* Dummy GOBACK. 01030000 010400 GOBACK. 01040000 010500 01050000 010600 No-Sysid. 01060000 010700 MOVE SPACES TO tr-record. 01070000 010800 STRING 'System ' user-sysid ' does not exist.' 01080000 010900 DELIMITED BY SIZE 01090000 011000 INTO tr-record 01100000 011100 END-STRING. 01110000 011200 01120000 011300 GO TO Send-Result. 01130000