000100 ID DIVISION. 00010000 000200 PROGRAM-ID. TRPGM75. 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 displays a VSAM record. 00110000 001200* It is a Non-Conversational program. 00120000 001300* This program can execute as a 3270 or subprogram. 00130000 001400* If it is LINK'd to it performs RETURN. 00140000 001500* If it is XCTL'd to it XCTL's back. 00150000 001600* It processes the VSAM record in the commarea. 00160000 001700* It uses the BMS ACCUM parameter. 00170000 001800* It can execute as a Distributed Program Link (DPL). 00180000 001900* 00190000 002000 DATA DIVISION. 00200000 002100 WORKING-STORAGE SECTION. 00210000 002200 01. 00220000 002300 05 result. 00230000 002400 10 user-area. 00240000 002500 15 user-input. 00250000 002600 20 PIC X(5) VALUE SPACES. 00260000 002700 20 user-team PIC X(5) VALUE SPACES. 00270000 002800 20 user-num PIC X(2) VALUE SPACES. 00280000 002900 15 PIC X(67) VALUE SPACES. 00290000 003000 10 msg1 PIC X(79). 00300000 003100 10 msg2 PIC X(79) VALUE 00310000 003200 'Change your choice and press ENTER to play again. Cle00320000 003300- 'ar screen to stop playing.'. 00330000 003400 10 msg3. 00340000 003500 15 PIC X(10) VALUE 'Facility: '. 00350000 003600 15 facility PIC X(4) VALUE SPACES. 00360000 003700 15 PIC X(8) VALUE ' Sysid: '. 00370000 003800 15 sysid PIC X(4). 00380000 003900 15 PIC X(13) VALUE ' Start Code: '.00390000 004000 15 start-code PIC X(2). 00400000 004100 88 start-dpl VALUE 'D ', 'DS'. 00410000 004200 15 PIC X(2) VALUE SPACES. 00420000 004300 15 PIC X(11) VALUE ' From Pgm: '. 00430000 004400 15 invoking-pgm PIC X(8). 00440000 004500 15 PIC X(9) VALUE ' To Pgm: '. 00450000 004600 15 return-pgm PIC X(8). 00460000 004700 00470000 004800 LINKAGE SECTION. 00480000 004900 01 dfhcommarea. 00490000 005000 COPY TRRECORD REPLACING ==01== BY ==05== 00500000 005100 ==05== BY ==10== 00510000 005200 ==10== BY ==15==. 00520000 005300 00530000 005400 PROCEDURE DIVISION. 00540000 005500 Main. 00550000 005600 EXEC CICS IGNORE CONDITION INVREQ END-EXEC. 00560000 005700 EXEC CICS ASSIGN FACILITY(facility) 00570000 005800 SYSID(sysid) 00580000 005900 INVOKINGPROG(invoking-pgm) 00590000 006000 RETURNPROG(return-pgm) 00600000 006100 STARTCODE(start-code) 00610000 006200 END-EXEC. 00620000 006300 00630000 006400 Check-First-Time. 00640000 006500 IF eibcalen = ZERO 00650000 006600 THEN EXEC CICS GETMAIN SET(ADDRESS OF dfhcommarea) 00660000 006700 FLENGTH(LENGTH OF dfhcommarea) 00670000 006800 END-EXEC 00680000 006900 END-IF. 00690000 007000 00700000 007100 Receive-Trans-Input. 00710000 007200 IF start-dpl 00720000 007300 THEN MOVE tr-key-team TO user-team 00730000 007400 MOVE tr-key-num TO user-num 00740000 007500 GO TO Process-Data 00750000 007600 END-IF. 00760000 007700 00770000 007800 EXEC CICS IGNORE CONDITION LENGERR END-EXEC. 00780000 007900* Receive updates eibcposn. 00790000 008000 EXEC CICS RECEIVE INTO(user-input) 00800000 008100 MAXFLENGTH(LENGTH OF user-input) 00810000 008200 END-EXEC. 00820000 008300 00830000 008400 Process-Data. 00840000 008500 EXEC CICS HANDLE CONDITION NOTFND(No-Record) END-EXEC. 00850000 008600 00860000 008700 EVALUATE user-team ALSO user-num 00870000 008800 WHEN SPACES ALSO SPACES 00880000 008900 MOVE 'No key information entered. 1st record displayed.' 00890000 009000 TO msg1 00900000 009100 MOVE LOW-VALUES TO tr-key 00910000 009200 EXEC CICS READ FILE('TRVSAM') INTO(tr-record) 00920000 009300 RIDFLD(tr-key) 00930000 009400 GTEQ 00940000 009500 END-EXEC 00950000 009600 WHEN NOT SPACES ALSO SPACES 00960000 009700 MOVE 'Teamid only entered. 1st record for team displayed.' 00970000 009800 TO msg1 00980000 009900 MOVE user-team TO tr-key-team 00990000 010000 EXEC CICS READ FILE('TRVSAM') INTO(tr-record) 01000000 010100 RIDFLD(tr-key) 01010000 010200 KEYLENGTH(LENGTH OF tr-key-team) 01020000 010300 GENERIC 01030000 010400 EQUAL 01040000 010500 END-EXEC 01050000 010600 WHEN OTHER 01060000 010700 MOVE 'Teamid and number entered. Exact match required.' 01070000 010800 TO msg1 01080000 010900 MOVE user-team TO tr-key-team 01090000 011000 MOVE user-num TO tr-key-num 01100000 011100 EXEC CICS READ FILE('TRVSAM') INTO(tr-record) 01110000 011200 RIDFLD(tr-key) 01120000 011300 EQUAL 01130000 011400 END-EXEC 01140000 011500 END-EVALUATE. 01150000 011600 01160000 011700 Send-Result. 01170000 011800 IF start-dpl 01180000 011900 THEN GO TO Process-Exit 01190000 012000 END-IF. 01200000 012100 01210000 012200 EXEC CICS SEND TEXT FROM(user-area) ACCUM ERASE END-EXEC. 01220000 012300 EXEC CICS SEND TEXT FROM(msg1) ACCUM END-EXEC. 01230000 012400 EXEC CICS SEND TEXT FROM(tr-record) ACCUM 01240000 012500 LENGTH(LENGTH OF msg1) END-EXEC. 01250000 012600 EXEC CICS SEND TEXT FROM(msg2) ACCUM END-EXEC. 01260000 012700 EXEC CICS SEND TEXT FROM(msg3) ACCUM END-EXEC. 01270000 012800 MOVE SPACES TO msg1. 01280000 012900 EXEC CICS SEND TEXT FROM(msg1) ACCUM END-EXEC. 01290000 013000 01300000 013100 IF invoking-pgm = SPACES 01310000 013200 THEN EXEC CICS SEND PAGE RETAIN END-EXEC 01320000 013300 END-IF. 01330000 013400 01340000 013500 Process-Exit. 01350000 013600 EVALUATE invoking-pgm ALSO return-pgm 01360000 013700 WHEN SPACES ALSO SPACES 01370000 013800 WHEN NOT SPACES ALSO NOT SPACES 01380000 013900 EXEC CICS RETURN END-EXEC 01390000 014000 WHEN NOT SPACES ALSO SPACES 01400000 014100 EXEC CICS XCTL PROGRAM(invoking-pgm) 01410000 014200 COMMAREA(tr-record) 01420000 014300 END-EXEC 01430000 014400 END-EVALUATE. 01440000 014500 01450000 014600* Dummy GOBACK. 01460000 014700 GOBACK. 01470000 014800 01480000 014900 No-Record. 01490000 015000 MOVE 'No record found with provided information.' TO msg1. 01500000 015100 MOVE SPACES TO tr-record. 01510000 015200 GO TO Send-Result. 01520000