000100 ID DIVISION. 00010000
000200 PROGRAM-ID. TRPGM86. 00020000
000300*AUTHOR. Kenneth W. Caldwell. 00030000
000400*INSTALLATION. Train-Right. 00040000
000500*DATE-WRITTEN. January 29, 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 is a TCP/IP Web based program. 00110000
001200* It displays a VSAM record. 00120000
001300* It uses a URL query string to receive key data. 00130000
001400* The client is a Web Browser. 00140000
001500* 00150000
001600 DATA DIVISION. 00160000
001700 WORKING-STORAGE SECTION. 00170000
001800 01. 00180000
001900 05 query-string-length PIC S9(8) BINARY. 00190000
002000 05 query-string PIC X(30) VALUE SPACES. 00200001
002100 05 symbol-key-team PIC X(11) VALUE SPACES. 00210001
002200 05 symbol-key-num PIC X(10) VALUE SPACES. 00220001
002300 05 user-team PIC X(4) VALUE SPACES. 00230000
002400 05 user-num PIC X(2) VALUE SPACES. 00240000
002500 00250000
002600 05 msg1 PIC X(80). 00260000
002700 00270000
002800 05 html-length PIC S9(8) BINARY VALUE +1. 00280000
002900 05 html-text PIC X(450). 00290000
003000 00300000
003100 COPY TRRECORD. 00310000
003200 00320000
003300 PROCEDURE DIVISION. 00330000
003400 Main. 00340000
003500 EXEC CICS HANDLE CONDITION INVREQ(Not-Web) END-EXEC. 00350000
003600 00360000
003700 Receive-Trans-Input. 00370000
003800 MOVE LENGTH OF query-string TO query-string-length. 00380000
003900 00390000
004000 EXEC CICS IGNORE CONDITION LENGERR END-EXEC. 00400000
004100 EXEC CICS WEB EXTRACT QUERYSTRING(query-string) 00410000
004200 QUERYSTRLEN(query-string-length) 00420000
004300 END-EXEC. 00430000
004400 00440000
004500 IF query-string-length > 0 00450000
004600 THEN MOVE FUNCTION UPPER-CASE(query-string) 00460003
004610 TO query-string 00461003
004620 00462003
004700 UNSTRING query-string(1:query-string-length) 00470003
005000 DELIMITED BY '=' OR '&' 00500000
005100 INTO symbol-key-team 00510001
005200 user-team 00520001
005300 symbol-key-num 00530001
005400 user-num 00540001
005500 ON OVERFLOW CONTINUE 00550000
005600 END-UNSTRING 00560000
005700 END-IF. 00570000
005800 00580000
005900 Process-Data. 00590000
006000 EXEC CICS HANDLE CONDITION NOTFND(No-Record) END-EXEC. 00600000
006100 00610000
006200 EVALUATE user-team ALSO user-num 00620000
006300 WHEN SPACES ALSO SPACES 00630000
006400 MOVE 'No key information entered. First record displayed.' 00640000
006500 TO msg1 00650000
006600 MOVE LOW-VALUES TO tr-key 00660000
006700 EXEC CICS READ FILE('TRVSAM') INTO(tr-record) 00670000
006800 RIDFLD(tr-key) GTEQ 00680000
006900 END-EXEC 00690000
007000 WHEN NOT SPACES ALSO SPACES 00700000
007100 MOVE 'Teamid only entered. Next best record displayed.' 00710000
007200 TO msg1 00720000
007300 MOVE user-team TO tr-key-team 00730000
007400 EXEC CICS READ FILE('TRVSAM') INTO(tr-record) 00740000
007500 RIDFLD(tr-key) 00750000
007600 KEYLENGTH(LENGTH OF tr-key-team) 00760000
007700 GENERIC 00770000
007800 END-EXEC 00780000
007900 WHEN OTHER 00790000
008000 MOVE 'Teamid and number entered. Exact match required.' 00800000
008100 TO msg1 00810000
008200 MOVE user-team TO tr-key-team 00820000
008300 MOVE user-num TO tr-key-num 00830000
008400 EXEC CICS READ FILE('TRVSAM') INTO(tr-record) 00840000
008500 RIDFLD(tr-key) 00850000
008600 EQUAL 00860000
008700 END-EXEC 00870000
008800 END-EVALUATE. 00880000
008900 00890000
009000 Send-Result. 00900000
009100 STRING '' 00910000
009200 'Train-Right Advanced CICS Programming Concepts' 00920000
009300 '' 00930000
009400 '' 00940000
009500 '
' 00950000
009600 'Train-Right CICS WEB COBOL - TRPGM86
' 00960000
009700 '' 00970000
009800 ' tr-key-team=' user-team 00980003
009900 ' tr-key-num=' user-num 00990003
010000 '
' 01000000
010100 msg1 01010000
010200 '
' 01020000
010300 tr-record 01030000
010400 '
' 01040000
010500 DELIMITED BY SIZE 01050000
010600 INTO html-text 01060000
010700 WITH POINTER html-length 01070000
010800 END-STRING. 01080000
010900 SUBTRACT +1 FROM html-length. 01090000
011000 01100000
011100* CICS converts EBCDIC to ASCII. 01110000
011200 EXEC CICS WEB SEND FROM(html-text) 01120000
011300 FROMLENGTH(html-length) 01130000
011400 SERVERCONV(DFHVALUE(SRVCONVERT)) 01140000
011500 END-EXEC. 01150000
011600 01160000
011700 Process-Exit. 01170000
011800 EXEC CICS RETURN END-EXEC. 01180000
011900* Dummy GOBACK. 01190000
012000 GOBACK. 01200000
012100 01210000
012200 Not-Web. 01220000
012300 MOVE 'Client is not an HTTP Web Browser.' TO html-text. 01230000
012400 EXEC CICS SEND FROM(html-text) LENGTH(34) ERASE END-EXEC. 01240000
012500 EXEC CICS RETURN END-EXEC. 01250000
012600 01260000
012700 No-Record. 01270000
012800 MOVE 'No record found with provided information.' TO msg1. 01280000
012900 MOVE SPACES TO tr-record. 01290000
013000 GO TO Send-Result. 01300000