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