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* 00160000 001700 DATA DIVISION. 00170000 001800 WORKING-STORAGE SECTION. 00180000 001900 01. 00190000 002000 05 result. 00200000 002100 10 user-area. 00210000 002200 15 user-input. 00220000 002300 20 PIC X(5) VALUE SPACES. 00230000 002400 20 user-team PIC X(5) VALUE SPACES. 00240000 002500 20 user-num PIC X(2) VALUE SPACES. 00250000 002600 15 PIC X(68) VALUE SPACES. 00260000 002700 10 msg1 PIC X(80). 00270000 002800 COPY TRRECORD REPLACING ==01== BY ==10== 00280000 002900 ==05== BY ==15== 00290000 003000 ==10== BY ==20==. 00300000 003100 10 msg2 PIC X(80) 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 15 PIC X(2) VALUE SPACES. 00410000 004200 15 PIC X(11) VALUE ' From Pgm: '. 00420000 004300 15 invoking-pgm PIC X(8). 00430000 004400 15 PIC X(9) VALUE ' To Pgm: '. 00440000 004500 15 return-pgm PIC X(8). 00450000 004600 00460000 004700 LINKAGE SECTION. 00470000 004800 01 dfhcommarea. 00480000 004900 COPY TRRECORD REPLACING ==01== BY ==05== 00490000 005000 ==05== BY ==10== 00500000 005100 ==10== BY ==15==. 00510000 005200 00520000 005300 PROCEDURE DIVISION. 00530000 005400 Main. 00540000 005500 EXEC CICS ASSIGN FACILITY(facility) 00550000 005600 SYSID(sysid) 00560000 005700 INVOKINGPROG(invoking-pgm) 00570000 005800 RETURNPROG(return-pgm) 00580000 005900 STARTCODE(start-code) 00590000 006000 END-EXEC. 00600000 006100 00610000 006200 Receive-Trans-Input. 00620000 006300 EXEC CICS IGNORE CONDITION LENGERR END-EXEC. 00630000 006400* Receive updates eibcposn. 00640000 006500 EXEC CICS RECEIVE INTO(user-input) 00650000 006600 MAXFLENGTH(LENGTH OF user-input) 00660000 006700 END-EXEC. 00670000 006800 00680000 006900 Process-Data. 00690000 007000 EXEC CICS HANDLE CONDITION NOTFND(No-Record) END-EXEC. 00700000 007100 00710000 007200 EVALUATE user-team ALSO user-num 00720000 007300 WHEN SPACES ALSO SPACES 00730000 007400 MOVE 'No key information entered. 1st record displayed.' 00740000 007500 TO msg1 00750000 007600 MOVE LOW-VALUES TO tr-key OF result 00760000 007700 EXEC CICS READ FILE('TRVSAM') INTO(tr-record OF result) 00770000 007800 RIDFLD(tr-key OF result) 00780000 007900 GTEQ 00790000 008000 END-EXEC 00800000 008100 WHEN NOT SPACES ALSO SPACES 00810000 008200 MOVE 'Teamid only entered. 1st record for team displayed.' 00820000 008300 TO msg1 00830000 008400 MOVE user-team TO tr-key-team OF result 00840000 008500 EXEC CICS READ FILE('TRVSAM') INTO(tr-record OF result) 00850000 008600 RIDFLD(tr-key OF result) 00860000 008700 KEYLENGTH(LENGTH OF tr-key-team OF result) 00870000 008800 GENERIC 00880000 008900 EQUAL 00890000 009000 END-EXEC 00900000 009100 WHEN OTHER 00910000 009200 MOVE 'Teamid and number entered. Exact match required.' 00920000 009300 TO msg1 00930000 009400 MOVE user-team TO tr-key-team OF result 00940000 009500 MOVE user-num TO tr-key-num OF result 00950000 009600 EXEC CICS READ FILE('TRVSAM') INTO(tr-record OF result) 00960000 009700 RIDFLD(tr-key OF result) 00970000 009800 EQUAL 00980000 009900 END-EXEC 00990000 010000 END-EVALUATE. 01000000 010100 01010000 010200 Send-Result. 01020000 010300 EXEC CICS SEND FROM(result) ERASE END-EXEC. 01030000 010400 01040000 010500 Process-Exit. 01050000 010600 EVALUATE invoking-pgm ALSO return-pgm 01060000 010700 WHEN SPACES ALSO SPACES 01070000 010800 EXEC CICS RETURN END-EXEC 01080000 010900 WHEN NOT SPACES ALSO NOT SPACES 01090000 011000 MOVE tr-record OF result TO tr-record OF dfhcommarea 01100000 011100 EXEC CICS RETURN END-EXEC 01110000 011200 WHEN NOT SPACES ALSO SPACES 01120000 011300 EXEC CICS XCTL PROGRAM(invoking-pgm) 01130000 011400 COMMAREA(tr-record OF result) 01140000 011500 END-EXEC 01150000 011600 END-EVALUATE. 01160000 011700 01170000 011800* Dummy GOBACK. 01180000 011900 GOBACK. 01190000 012000 01200000 012100 No-Record. 01210000 012200 MOVE 'No record found with provided information.' TO msg1. 01220000 012300 MOVE SPACES TO tr-record OF result. 01230000 012400 GO TO Send-Result. 01240000