OS/2 Shareware BBS: 10 Tools

home *** CD-ROM | disk | FTP | other *** search

/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / viscobv6.zip / vac22os2 / ibmcobol / samples / cstut / cicssamp.cbl < prev next >

Wrap

Text File | 1998-03-04 | 31KB | 379 lines

000100 IDENTIFICATION DIVISION. 00200000 000200 PROGRAM-ID. CICSSAMP. 00400000 000300* PROGRAM CONVERTED BY 00400000 000400* COBOL CONVERSION AID PO 5785-ABJ 00400000 000500* CONVERSION DATE 24/01/89 13:33:31. 00400000 000600*REMARKS. THIS PROGRAM IS THE FIRST INVOKED BY THE 'AC01' 00600000 000700* TRANSACTION. IT ANALYZES ALL REQUESTS, AND COMPLETES 00800000 000800* THOSE FOR NAME INQUIRIES AND RECORD DISPLAYS. FOR 01000000 000900* UPDATE TRANSACTIONS, IT SENDS THE APPROPRIATE DATA ENTRY01200000 001000* SCREEN AND SETS THE NEXT TRANSACTION IDENTIFIER TO 01400000 001100* 'AC02', WHICH COMPLETES THE UPDATE OPERATION. FOR PRINT 01600000 001200* REQUESTS, IT STARTS TRANSACTION 'AC03' TO DO THE ACTUAL 01800000 001300* PRINTING. 02000000 001400 ENVIRONMENT DIVISION. 02200000 001500 DATA DIVISION. 02400000 001600 WORKING-STORAGE SECTION. 02600000 001700 01 MISC. 02800000 001800 02 RESPONSE PIC S9(8) COMP. 03000000 001900 02 MSG-NO PIC S9(4) COMP VALUE +0. 03000000 002000 02 ACCT-LNG PIC S9(4) COMP VALUE +383. 03200000 002100 02 ACIX-LNG PIC S9(4) COMP VALUE +63. 03400000 002200 02 DTL-LNG PIC S9(4) COMP VALUE +751. 03600000 002300 02 STARS PIC X(12) VALUE '************'. 03800000 002400 02 USE-QID. 04000000 002500 04 USE-QID1 PIC X(3) VALUE 'AC0'. 04200000 002600 04 USE-QID2 PIC X(5). 04400000 002700 02 USE-REC. 04600000 002800 04 USE-TERM PIC X(4) VALUE SPACES. 04800000 002900 04 USE-TIME PIC S9(7) COMP-3. 05000000 003000 04 USE-DATE PIC S9(7) COMP-3. 05200000 003100 02 USE-LIMIT PIC S9(7) COMP-3 VALUE +1000. 05400000 003200 02 USE-ITEM PIC S9(4) COMP VALUE +1. 05600000 003300 02 USE-LNG PIC S9(4) COMP VALUE +12. 05800000 003400 02 IN-AREA. 06000000 003500 04 IN-TYPE PIC X VALUE 'R'. 06200000 003600 04 IN-REQ. 06400000 003700 06 REQC PIC X VALUE SPACES. 06600000 003800 06 ACCTC PIC X(5) VALUE SPACES. 06800000 003900 06 PRTRC PIC X(4) VALUE SPACES. 07000000 004000 04 IN-NAMES. 07200000 004100 06 SNAMEC PIC X(18) VALUE SPACES. 07400000 004200 06 FNAMEC PIC X(12) VALUE SPACES. 07600000 004300 02 COMMAREA-FOR-ACCT04. 07800000 004400 04 ERR-PGRMID PIC X(8) VALUE 'ACCT01'. 08000000 004500 04 ERR-FN PIC X. 08200000 004600 04 ERR-RCODE PIC X. 08400000 004700 02 LINE-CNT PIC S9(4) COMP VALUE +0. 08600000 004800 02 MAX-LINES PIC S9(4) COMP VALUE +6. 08800000 004900 02 IX PIC S9(4) COMP. 09000000 005000 02 SRCH-CTRL. 09200000 005100 04 FILLER PIC X VALUE 'S'. 09400000 005200 04 BRKEY. 09600000 005300 06 BRKEY-SNAME PIC X(12). 09800000 005400 06 BRKEY-ACCT PIC X(5). 10000000 005500 04 MAX-SNAME PIC X(12). 10200000 005600 04 MAX-FNAME PIC X(7). 10400000 005700 04 MIN-FNAME PIC X(7). 10600000 005800 02 SUM-LINE. 10800000 005900 04 ACCTDO PIC X(5). 11000000 006000 04 FILLER PIC X(3) VALUE SPACES. 11200000 006100 04 SNAMEDO PIC X(12). 11400000 006200 04 FILLER PIC X(2) VALUE SPACES. 11600000 006300 04 FNAMEDO PIC X(7). 11800000 006400 04 FILLER PIC X(2) VALUE SPACES. 12000000 006500 04 MIDO PIC X(1). 12200000 006600 04 FILLER PIC X(2) VALUE SPACES. 12400000 006700 04 TTLDO PIC X(4). 12600000 006800 04 FILLER PIC X(2) VALUE SPACES. 12800000 006900 04 ADDR1DO PIC X(24). 13000000 007000 04 FILLER PIC X(2) VALUE SPACES. 13200000 007100 04 STATDO PIC X(2). 13400000 007200 04 FILLER PIC X(3) VALUE SPACES. 13600000 007300 04 LIMITDO PIC X(8). 13800000 007400 02 PAY-LINE. 14000000 007500 04 BAL PIC X(8). 14200000 007600 04 FILLER PIC X(6) VALUE SPACES. 14400000 007700 04 BMO PIC 9(2). 14600000 007800 04 FILLER PIC X VALUE '/'. 14800000 007900 04 BDAY PIC 9(2). 15000000 008000 04 FILLER PIC X VALUE '/'. 15200000 008100 04 BYR PIC 9(2). 15400000 008200 04 FILLER PIC X(4) VALUE SPACES. 15600000 008300 04 BAMT PIC X(8). 15800000 008400 04 FILLER PIC X(7) VALUE SPACES. 16000000 008500 04 PMO PIC 9(2). 16200000 008600 04 FILLER PIC X VALUE '/'. 16400000 008700 04 PDAY PIC 9(2). 16600000 008800 04 FILLER PIC X VALUE '/'. 16800000 008900 04 PYR PIC 9(2). 17000000 009000 04 FILLER PIC X(4) VALUE SPACES. 17200000 009100 04 PAMT PIC X(8). 17400000 009200 COPY DFHBMSCA. 17600000 009300 COPY DFHAID. 17800000 009400 01 ACCTREC. COPY ACCTREC. 18000000 009500 01 ACIXREC. COPY ACIXREC. 18200000 009600 COPY ACCTSET. 18400000 009700 01 MSG-LIST. 18600000 009800 02 FILLER PIC X(60) VALUE 18800000 009900 'NAMES MUST BE ALPHABETIC, AND SURNAME IS REQUIRED.'. 19000000 010000 02 FILLER PIC X(60) VALUE 19200000 010100 'ENTER SOME INPUT AND USE ONLY "CLEAR" OR "ENTER".'. 19400000 010200 02 FILLER PIC X(60) VALUE 19600000 010300 'REQUEST TYPE REQUIRED; MUST BE "D", "P", "A", "M" OR "X".'. 19800000 010400 02 FILLER PIC X(60) VALUE 20000000 010500 'PRINTER NAME REQUIRED ON PRINT REQUESTS'. 20200000 010600 02 FILLER PIC X(60) VALUE 20400000 010700 'ACCOUNT NUMBER REQUIRED (BETWEEN 10000 AND 79999)'. 20600000 010800 02 FILLER PIC X(60) VALUE 20800000 010900 'ACCOUNT NO. MUST BE NUMERIC AND FROM 10000 TO 79999'. 21000000 011000 02 FILLER PIC X(60) VALUE 21200000 011100 'NO NAMES ON FILE MATCHING YOUR REQUEST'. 21400000 011200 02 FILLER PIC X(60) VALUE 21600000 011300 'ENTER EITHER NAME OR A REQUEST TYPE AND ACCOUNT NUMBER'.21800000 011400 02 FILLER PIC X(60) VALUE 22000000 011500 'THIS ACCOUNT NUMBER ALREADY EXISTS'. 22300000 011600 02 FILLER PIC X(60) VALUE 22600000 011700 'NO RECORD OF THIS ACCOUNT NUMBER'. 22900000 011800 02 FILLER PIC X(47) VALUE 23200000 011900 'THIS ACCOUNT NUMBER ALREADY IN USE AT TERMINAL '. 23500000 012000 02 MSG-TERM PIC X(13). 23800000 012100 02 FILLER PIC X(60) VALUE 24100000 012200 'PRINT REQUEST SCHEDULED'. 24400000 012300 02 FILLER PIC X(60) VALUE 24700000 012400 'PRINTER NAME NOT RECOGNIZED'. 25000000 012500 02 FILLER PIC X(60) VALUE 25300000 012600 'INPUT ERROR; PLEASE RETRY; USE ONLY "CLEAR" OR "ENTER" KEY'.25600000 012700 02 FILLER PIC X(60) VALUE 25900000 012800 'THERE ARE MORE MATCHING NAMES. PRESS PA2 TO CONTINUE.'. 26200000 012900 01 FILLER REDEFINES MSG-LIST. 26500000 013000 02 MSG-TEXT PIC X(60) OCCURS 15. 26800000 013100 LINKAGE SECTION. 27100000 013200 01 DFHCOMMAREA. 27400000 013300 02 SRCH-COMM PIC X(44). 27700000 013400 02 IN-COMM REDEFINES SRCH-COMM PIC X(41). 28000000 013500 02 CTYPE REDEFINES SRCH-COMM PIC X. 28300000 013600* 28600000 013700 PROCEDURE DIVISION. 28900000 013800* 29200000 013900* 29500000 014000* INITIALIZE. 29800000 014100 EXEC CICS HANDLE CONDITION MAPFAIL(NO-MAP) 30100000 014200 NOTFND(SRCH-ANY) 30400000 014300 ENDFILE(SRCH-DONE) 30700000 014400 QIDERR(RSRV-1) 31000000 014500 TERMIDERR(TERMID-ERR) 31300000 014600 ERROR(OTHER-ERRORS) END-EXEC. 31600000 014700 MOVE LOW-VALUES TO ACCTMNUI, ACCTDTLI. 31900000 014800* 32200000 014900* CHECK BASIC REQUEST TYPE. 32500000 015000 IF EIBAID = DFHCLEAR 32800000 015100 IF EIBCALEN = 0, 33100000 015200 EXEC CICS SEND CONTROL FREEKB END-EXEC 33400000 015300 EXEC CICS RETURN END-EXEC 33700000 015400 ELSE GO TO NEW-MENU. 34000000 015500 IF EIBAID = DFHPA2 AND EIBCALEN > 0 AND CTYPE = 'S', 34300000 015600 MOVE SRCH-COMM TO SRCH-CTRL, GO TO SRCH-RESUME. 34600000 015700 IF EIBCALEN > 0 AND CTYPE = 'R', MOVE IN-COMM TO IN-AREA. 34900000 015800* 35200000 015900* GET INPUT AND CHECK REQUEST TYPE FURTHER. 35500000 016000 EXEC CICS RECEIVE MAP('ACCTMNU') MAPSET('ACCTSET') END-EXEC. 35800000 016100 IF REQML > 0 MOVE REQMI TO REQC. 36100000 016200 IF REQMF NOT = LOW-VALUE, MOVE SPACE TO REQC. 36400000 016300 IF ACCTML > 0 MOVE ACCTMI TO ACCTC. 36700000 016400 IF ACCTMF NOT = LOW-VALUE, MOVE SPACES TO ACCTC. 37000000 016500 IF PRTRML > 0 MOVE PRTRMI TO PRTRC. 37300000 016600 IF PRTRMF NOT = LOW-VALUE, MOVE SPACES TO PRTRC. 37600000 016700 IF SNAMEML > 0 MOVE SNAMEMI TO SNAMEC. 37900000 016800 IF SNAMEMF NOT = LOW-VALUE, MOVE SPACES TO SNAMEC. 38200000 016900 IF FNAMEML > 0 MOVE FNAMEMI TO FNAMEC. 38500000 017000 IF FNAMEMF NOT = LOW-VALUE, MOVE SPACES TO FNAMEC. 38800000 017100 MOVE LOW-VALUES TO ACCTMNUI. 39100000 017200 IF IN-NAMES = SPACES GO TO CK-ANY. 39400000 017300* 39700000 017400* NAME INQUIRY PROCESSING. 40000000 017500* VALIDATE NAME INPUT. 40300000 017600 IF FNAMEC NOT ALPHABETIC, MOVE 1 TO MSG-NO, 40600000 017700 MOVE -1 TO FNAMEML, MOVE DFHBMBRY TO FNAMEMA. 40900000 017800 IF SNAMEC = SPACES, MOVE STARS TO SNAMEMO, 41200000 017900 ELSE IF SNAMEC ALPHABETIC, GO TO CK-NAME. 41500000 018000 MOVE 1 TO MSG-NO. 41800000 018100 MOVE -1 TO SNAMEML, MOVE DFHBMBRY TO SNAMEMA. 42100000 018200 CK-NAME. 42400000 018300 IF MSG-NO > 0 GO TO MENU-RESEND. 42700000 018400* 43000000 018500* BUILD KEY AND LIMITING NAME VALUES FOR SEARCH. 43300000 018600 SRCH-INIT. 43600000 018700 MOVE SNAMEC TO BRKEY-SNAME, MAX-SNAME. 43900000 018800 MOVE LOW-VALUES TO BRKEY-ACCT. 44200000 018900 INSPECT MAX-SNAME REPLACING ALL SPACES BY HIGH-VALUES. 44500000 019000 MOVE FNAMEC TO MIN-FNAME, MAX-FNAME. 44800000 019100 INSPECT MIN-FNAME REPLACING ALL SPACES BY LOW-VALUES. 45100000 019200 INSPECT MAX-FNAME REPLACING ALL SPACES BY HIGH-VALUES. 45400000 019300* 45700000 019400* INITIALIZE FOR SEQUENTIAL SEARCH. 46000000 019500 SRCH-RESUME. 46300000 019600 EXEC CICS STARTBR DATASET('ACCTIX') RIDFLD(BRKEY) GTEQ 46600000 019700 END-EXEC. 46900000 019800 47200000 019900* 47500000 020000* BUILD NAME DISPLAY. 47800000 020100 SRCH-LOOP. 48100000 020200 EXEC CICS READNEXT DATASET('ACCTIX') INTO(ACIXREC) 48400000 020300 LENGTH(ACIX-LNG) RIDFLD(BRKEY) END-EXEC. 48700000 020400 IF SNAMEDO IN ACIXREC > MAX-SNAME GO TO SRCH-DONE. 49000000 020500 IF FNAMEDO IN ACIXREC < MIN-FNAME OR 49300000 020600 FNAMEDO IN ACIXREC > MAX-FNAME, GO TO SRCH-LOOP. 49600000 020700 ADD 1 TO LINE-CNT. 49900000 020800 IF LINE-CNT > MAX-LINES, 50200000 020900 MOVE MSG-TEXT (15) TO MSGMO, 50500000 021000 MOVE DFHBMBRY TO MSGMA, GO TO SRCH-DONE. 50800000 021100 MOVE CORRESPONDING ACIXREC TO SUM-LINE. 51100000 021200 MOVE SUM-LINE TO SUMLNMO (LINE-CNT). 51400000 021300 GO TO SRCH-LOOP. 51700000 021400 SRCH-DONE. 52000000 021500 EXEC CICS ENDBR DATASET('ACCTIX') END-EXEC. 52300000 021600 SRCH-ANY. 52600000 021700 IF LINE-CNT = 0, MOVE 7 TO MSG-NO, 52900000 021800 MOVE -1 TO SNAMEML, GO TO MENU-RESEND. 53200000 021900* 53500000 022000* SEND THE NAME SEARCH RESULTS TO TERMINAL. 53800000 022100 MOVE DFHBMUNP TO SUMLNMA (1), SUMLNMA (2), SUMLNMA (3), 54100000 022200 SUMLNMA (4), SUMLNMA (5), SUMLNMA (6). 54400000 022300 MOVE DFHBMBRY TO MSGMA, MOVE DFHBMASB TO SUMTTLMA. 54700000 022400 EXEC CICS SEND MAP('ACCTMNU') MAPSET('ACCTSET') 55000000 022500 FREEKB DATAONLY ERASEAUP END-EXEC. 55300000 022600 IF LINE-CNT NOT > MAX-LINES, 55600000 022700 EXEC CICS RETURN TRANSID('AC01') END-EXEC 55900000 022800 ELSE EXEC CICS RETURN TRANSID('AC01') COMMAREA(SRCH-CTRL) 56200000 022900 LENGTH(44) END-EXEC. 56500000 023000* 56800000 023100* DISPLAY, PRINT, ADD, MODIFY AND DELETE PROCESSING. 57100000 023200* CHECK ACCOUNT NUMBER. 57400000 023300 CK-ANY. 57700000 023400 IF IN-REQ = SPACES, MOVE -1 TO SNAMEML, 58000000 023500 MOVE 8 TO MSG-NO, GO TO MENU-RESEND. 58300000 023600 CK-ACCTNO-1. 58600000 023700 IF ACCTC = SPACES, MOVE STARS TO ACCTMO, 58900000 023800 MOVE 5 TO MSG-NO, GO TO ACCT-ERR. 59200000 023900 IF (ACCTC < '10000' OR ACCTC > '79999' OR ACCTC NOT NUMERIC),59500000 024000 MOVE 6 TO MSG-NO, GO TO ACCT-ERR. 59800000 024100 CK-ACCTNO-2. 60100000 024200 EXEC CICS HANDLE CONDITION NOTFND(NO-ACCT-RECORD) END-EXEC. 60400000 024300 EXEC CICS READ DATASET('ACCTFIL') RIDFLD(ACCTC) 60700000 024400 INTO(ACCTREC) LENGTH(ACCT-LNG) END-EXEC. 61000000 024500 IF REQC = 'A', 61300000 024600 MOVE 9 TO MSG-NO, GO TO ACCT-ERR, 61600000 024700 ELSE GO TO CK-REQ. 61900000 024800 NO-ACCT-RECORD. 62200000 024900 IF REQC = 'A', GO TO CK-REQ. 62500000 025000 MOVE 10 TO MSG-NO. 62800000 025100 ACCT-ERR. 63100000 025200 MOVE -1 TO ACCTML, MOVE DFHBMBRY TO ACCTMA. 63400000 025300* 63700000 025400* CHECK REQUEST TYPE. 64000000 025500 CK-REQ. 64300000 025600 IF REQC = 'D' OR 'P' OR 'A' OR 'M' OR 'X', 64600000 025700 IF MSG-NO = 0 GO TO CK-USE, ELSE GO TO MENU-RESEND. 64900000 025800 IF REQC = SPACE, MOVE STARS TO REQMO. 65200000 025900 MOVE -1 TO REQML, MOVE DFHBMBRY TO REQMA, 65500000 026000 MOVE 3 TO MSG-NO. 65800000 026100 GO TO MENU-RESEND. 66100000 026200* 66400000 026300* TEST IF ACCOUNT NUMBER IN USE, ON UPDATES ONLY. 66700000 026400 CK-USE. 67000000 026500 IF REQC = 'P' OR 'D' GO TO BUILD-MAP. 67300000 026600 MOVE ACCTC TO USE-QID2. 67600000 026700 EXEC CICS READQ TS QUEUE(USE-QID) INTO(USE-REC) 67900000 026800 ITEM(USE-ITEM) LENGTH(USE-LNG) 68200000 026900 RESP(RESPONSE) END-EXEC. 027000 IF RESPONSE = DFHRESP(QIDERR) 027100 THEN CONTINUE 027200 ELSE CONTINUE 027300 ADD USE-LIMIT TO USE-TIME. 68500000 027400 IF USE-TIME > 236000, ADD 1 TO USE-DATE, 68800000 027500 SUBTRACT 236000 FROM USE-TIME. 69100000 027600 IF USE-DATE > EIBDATE OR 69400000 027700 (USE-DATE = EIBDATE AND USE-TIME NOT < EIBTIME) 69700000 027800 MOVE USE-TERM TO MSG-TERM, MOVE 11 TO MSG-NO, 70000000 027900 MOVE -1 TO ACCTML, MOVE DFHBMBRY TO ACCTMA, 70300000 028000 GO TO MENU-RESEND. 70600000 028100* 70900000 028200* RESERVE ACCOUNT NUMBER. 71200000 028300 RSRV. 71500000 028400 MOVE EIBTRMID TO USE-TERM, MOVE EIBTIME TO USE-TIME. 71800000 028500 MOVE EIBDATE TO USE-DATE. 72100000 028600 EXEC CICS WRITEQ TS QUEUE(USE-QID) FROM(USE-REC) 72400000 028700 LENGTH(12) ITEM(USE-ITEM) REWRITE END-EXEC. 72700000 028800 GO TO BUILD-MAP. 73000000 028900 RSRV-1. 73300000 029000 MOVE EIBTRMID TO USE-TERM, MOVE EIBTIME TO USE-TIME. 73600000 029100 MOVE EIBDATE TO USE-DATE. 73900000 029200 EXEC CICS WRITEQ TS QUEUE(USE-QID) FROM(USE-REC) 74200000 029300 LENGTH(12) END-EXEC. 74500000 029400* 74800000 029500* BUILD THE RECORD DISPLAY. 75100000 029600 BUILD-MAP. 75400000 029700 IF REQC = 'X' MOVE 'DELETION' TO TITLEDO, 75700000 029800 MOVE -1 TO VFYDL, MOVE DFHBMUNP TO VFYDA, 76000000 029900 MOVE 'ENTER "Y" TO CONFIRM OR "CLEAR" TO CANCEL' 76300000 030000 TO MSGDO, 76600000 030100 ELSE MOVE -1 TO SNAMEDL. 76900000 030200 IF REQC = 'A' MOVE 'NEW RECORD' TO TITLEDO, 77200000 030300 MOVE DFHPROTN TO STATTLDA, LIMTTLDA, HISTTLDA, 77500000 030400 MOVE ACCTC TO ACCTDI, 77800000 030500 MOVE 'FILL IN AND PRESS "ENTER," OR "CLEAR" TO CANCEL' 78100000 030600 TO MSGDO, 78400000 030700 GO TO SEND-DETAIL. 78700000 030800 IF REQC = 'M' MOVE 'RECORD CHANGE' TO TITLEDO, 79000000 030900 MOVE 'MAKE CHANGES AND "ENTER" OR "CLEAR" TO CANCEL' 79300000 031000 TO MSGDO, 79600000 031100 ELSE IF REQC = 'D', 79900000 031200 MOVE 'PRESS "CLEAR" OR "ENTER" WHEN FINISHED' 80200000 031300 TO MSGDO. 80500000 031400 MOVE CORRESPONDING ACCTREC TO ACCTDTLO. 80800000 031500 MOVE CORRESPONDING PAY-HIST (1) TO PAY-LINE. 81100000 031600 MOVE PAY-LINE TO HIST1DO. 81400000 031700 MOVE CORRESPONDING PAY-HIST (2) TO PAY-LINE. 81700000 031800 MOVE PAY-LINE TO HIST2DO. 82000000 031900 MOVE CORRESPONDING PAY-HIST (3) TO PAY-LINE. 82300000 032000 MOVE PAY-LINE TO HIST3DO. 82600000 032100 IF REQC = 'M' GO TO SEND-DETAIL, 82900000 032200 ELSE IF REQC = 'P' GO TO PRINT-PROC. 83200000 032300 MOVE DFHBMASK TO 83500000 032400 SNAMEDA, FNAMEDA, MIDA, TTLDA, TELDA, ADDR1DA, 83800000 032500 ADDR2DA, ADDR3DA, AUTH1DA, AUTH2DA, AUTH3DA, 84100000 032600 AUTH4DA, CARDSDA, IMODA, IDAYDA, IYRDA, RSNDA, 84400000 032700 CCODEDA, APPRDA, SCODE1DA, SCODE2DA, SCODE3DA. 84700000 032800* 85000000 032900* SEND THE RECORD DETAIL MAP TO THE TERMINAL. 85300000 033000 SEND-DETAIL. 85600000 033100 EXEC CICS SEND MAP('ACCTDTL') MAPSET('ACCTSET') ERASE FREEKB 85900000 033200 CURSOR END-EXEC. 86200000 033300 IF REQC = 'D', EXEC CICS RETURN TRANSID('ACCT') END-EXEC, 86500000 033400 ELSE EXEC CICS RETURN TRANSID('AC02') 86800000 033500 COMMAREA(IN-REQ) LENGTH(6) END-EXEC. 87100000 033600* 87400000 033700* START UP A TASK TO PRINT THE RECORD. 87700000 033800 PRINT-PROC. 88000000 033900 IF PRTRC = SPACES, MOVE STARS TO PRTRMO 88300000 034000 MOVE 4 TO MSG-NO, GO TO TERMID-ERR1. 88600000 034100 EXEC CICS START TRANSID('AC03') FROM(ACCTDTLO) 88900000 034200 LENGTH(DTL-LNG) TERMID(PRTRC) END-EXEC. 89200000 034300 MOVE MSG-TEXT (12) TO MSGMO. 89500000 034400 EXEC CICS SEND MAP('ACCTMNU') MAPSET ('ACCTSET') DATAONLY 89800000 034500 ERASEAUP FREEKB END-EXEC. 90100000 034600 EXEC CICS RETURN TRANSID('AC01') END-EXEC. 90400000 034700 TERMID-ERR. 90700000 034800 MOVE 13 TO MSG-NO. 91000000 034900 TERMID-ERR1. 91300000 035000 MOVE -1 TO PRTRML, MOVE DFHBMBRY TO PRTRMA. 91600000 035100* 91900000 035200* ERROR PROCESSING, FOR ALL REQUESTS. 92200000 035300* RESEND MENU SCREEN. 92500000 035400 MENU-RESEND. 92800000 035500 MOVE MSG-TEXT (MSG-NO) TO MSGMO. 93100000 035600* EXEC CICS SEND MAP('ACCTMNU') MAPSET('ACCTSET') 93400000 035700* CURSOR DATAONLY FRSET FREEKB END-EXEC. 93700000 035800 EXEC CICS RETURN TRANSID('AC01') COMMAREA(IN-AREA) 94000000 035900 LENGTH(41) END-EXEC. 94300000 036000* 94600000 036100* PROCESSING FOR MAP FAILURES, CLEARS. 94900000 036200 NO-MAP. 95200000 036300 IF (EIBAID = DFHPA1 OR DFHPA2 OR DFHPA3 OR DFHENTER) 95500000 036400 MOVE 2 TO MSG-NO, MOVE -1 TO SNAMEML, GO TO MENU-RESEND. 95800000 036500 MOVE MSG-TEXT (14) TO MSGMO. 96100000 036600 NEW-MENU. 96400000 036700 EXEC CICS SEND MAP('ACCTMNU') MAPSET('ACCTSET') 96700000 036800 FREEKB ERASE END-EXEC. 97000000 036900 EXEC CICS RETURN TRANSID ('AC01') END-EXEC. 97300000 037000* 97600000 037100* PROCESSING FOR UNEXPECTED ERRORS. 97900000 037200 OTHER-ERRORS. 98200000 037300 MOVE EIBFN TO ERR-FN, MOVE EIBRCODE TO ERR-RCODE. 98500000 037400 EXEC CICS HANDLE CONDITION ERROR END-EXEC. 98800000 037500 EXEC CICS RETURN TRANSID ('AC01') END-EXEC. 97300000 037600* EXEC CICS LINK PROGRAM('ACCT04') 99100000 037700* COMMAREA(COMMAREA-FOR-ACCT04) LENGTH(10) END-EXEC. 99400000 037800 GOBACK. 99700000