000010 IDENTIFICATION DIVISION. 000020 PROGRAM-ID. CICS1. 000030 AUTHOR. IBMUSER (Using Jazz, Version 0.12.4.59) 000040 DATE-WRITTEN. 29/12/2014 9:00:13 a.m. 000050 ENVIRONMENT DIVISION. 000060*# Last Updated by IBMUSER at 29/12/2014 9:00:13 a.m. 000070* PROGRAM CICS1 CICS INSCREEN(CICS1S) TRANSID(TRN1) 000080* COMMAREA(CICS1C) EXIT(menu1); 000090*COPY custf; 000100*ACCEPT (CICS1S.Account OR CICS1S.Name); 000110*DEFINE TS1 TYPE(TS) DATA( 000120* Account LIKE CustF.Account); 000130*GET custf KEY(CustF.Account OR CustF.Name)$TS(1); 000140*#373 I GET statement returns one record at a time for Name 000150*IF custf.$Found = 'N' THEN; 000160* CICS1S.error = 'No Record Found'; 000170*END IF; 000180*SEND CICS1S(CICS1S.*); 000190****************************************************************** 000200** ** 000210** Data Division ** 000220** ** 000230****************************************************************** 000240 DATA DIVISION. 000250****************************************************************** 000260** ** 000270** Working Storage Section: General Program Data ** 000280** ** 000290****************************************************************** 000300* 000310 WORKING-STORAGE SECTION. 000320****************************************************************** 000330** ** 000340** Screen Areas ** 000350** ** 000360****************************************************************** 000370* 000380 COPY DFHAID. 000390* 000400 01 CICS1S. 000410 03 FILLER PIC X(12). 000420* SpecialConstant VALUE 'TMPL01' 000430 03 SCNST1. 000440 05 LTH PIC S9(4) COMP. 000450 05 ATTR PIC X. 000460 05 COLR PIC X. 000470 05 HLIT PIC X. 000480 05 FILLER PIC X(6). 000490* Constant VALUE 'CustF Enquiry ' 000500 03 CNST5. 000510 05 LTH PIC S9(4) COMP. 000520 05 ATTR PIC X. 000530 05 COLR PIC X. 000540 05 HLIT PIC X. 000550 05 FILLER PIC X(14). 000560* SpecialConstant VALUE '@Trn' 000570 03 SCNST4. 000580 05 LTH PIC S9(4) COMP. 000590 05 ATTR PIC X. 000600 05 COLR PIC X. 000610 05 HLIT PIC X. 000620 05 FILLER PIC X(4). 000630* Constant VALUE 'Enter =>' 000640 03 CNST6. 000650 05 LTH PIC S9(4) COMP. 000660 05 ATTR PIC X. 000670 05 COLR PIC X. 000680 05 HLIT PIC X. 000690 05 FILLER PIC X(8). 000700* Constant VALUE 'Account Number.' 000710 03 CNST7. 000720 05 LTH PIC S9(4) COMP. 000730 05 ATTR PIC X. 000740 05 COLR PIC X. 000750 05 HLIT PIC X. 000760 05 FILLER PIC X(15). 000770* Field ='CustF.Account' VALUE '999999' 000780 03 Account. 000790 05 LTH PIC S9(4) COMP. 000800 05 ATTR PIC X. 000810 05 COLR PIC X. 000820 05 HLIT PIC X. 000830 05 INPT PIC X(6). 000840 05 OUT REDEFINES INPT PIC 999999. 000850* ErrorFlag VALUE '*' 000860 03 EFLD9. 000870 05 LTH PIC S9(4) COMP. 000880 05 ATTR PIC X. 000890 05 COLR PIC X. 000900 05 HLIT PIC X. 000910 05 OUT PIC X(1). 000920* Constant VALUE ' OR =>' 000930 03 CNST10. 000940 05 LTH PIC S9(4) COMP. 000950 05 ATTR PIC X. 000960 05 COLR PIC X. 000970 05 HLIT PIC X. 000980 05 FILLER PIC X(8). 000990* Constant VALUE 'Name.' 001000 03 CNST11. 001010 05 LTH PIC S9(4) COMP. 001020 05 ATTR PIC X. 001030 05 COLR PIC X. 001040 05 HLIT PIC X. 001050 05 FILLER PIC X(5). 001060* Field ='CustF.Name' VALUE 'X(15)__________' 001070 03 Name. 001080 05 LTH PIC S9(4) COMP. 001090 05 ATTR PIC X. 001100 05 COLR PIC X. 001110 05 HLIT PIC X. 001120 05 INPT PIC X(15). 001130 05 OUT REDEFINES INPT PIC X(15). 001140* ErrorFlag VALUE '*' 001150 03 EFLD13. 001160 05 LTH PIC S9(4) COMP. 001170 05 ATTR PIC X. 001180 05 COLR PIC X. 001190 05 HLIT PIC X. 001200 05 OUT PIC X(1). 001210* Constant VALUE 'and press Enter' 001220 03 CNST14. 001230 05 LTH PIC S9(4) COMP. 001240 05 ATTR PIC X. 001250 05 COLR PIC X. 001260 05 HLIT PIC X. 001270 05 FILLER PIC X(15). 001280* Constant VALUE 'Region.' 001290 03 CNST15. 001300 05 LTH PIC S9(4) COMP. 001310 05 ATTR PIC X. 001320 05 COLR PIC X. 001330 05 HLIT PIC X. 001340 05 FILLER PIC X(7). 001350* Field ='CustF.Region' VALUE '---9' 001360 03 Region. 001370 05 LTH PIC S9(4) COMP. 001380 05 ATTR PIC X. 001390 05 COLR PIC X. 001400 05 HLIT PIC X. 001410 05 INPT PIC X(4). 001420 05 OUT REDEFINES INPT PIC ---9. 001430* ErrorFlag VALUE '*' 001440 03 EFLD17. 001450 05 LTH PIC S9(4) COMP. 001460 05 ATTR PIC X. 001470 05 COLR PIC X. 001480 05 HLIT PIC X. 001490 05 OUT PIC X(1). 001500* Constant VALUE 'District.' 001510 03 CNST18. 001520 05 LTH PIC S9(4) COMP. 001530 05 ATTR PIC X. 001540 05 COLR PIC X. 001550 05 HLIT PIC X. 001560 05 FILLER PIC X(9). 001570* Field ='CustF.District' VALUE '---9' 001580 03 District. 001590 05 LTH PIC S9(4) COMP. 001600 05 ATTR PIC X. 001610 05 COLR PIC X. 001620 05 HLIT PIC X. 001630 05 INPT PIC X(4). 001640 05 OUT REDEFINES INPT PIC ---9. 001650* ErrorFlag VALUE '*' 001660 03 EFLD20. 001670 05 LTH PIC S9(4) COMP. 001680 05 ATTR PIC X. 001690 05 COLR PIC X. 001700 05 HLIT PIC X. 001710 05 OUT PIC X(1). 001720* Constant VALUE 'SalesThisMonth.' 001730 03 CNST21. 001740 05 LTH PIC S9(4) COMP. 001750 05 ATTR PIC X. 001760 05 COLR PIC X. 001770 05 HLIT PIC X. 001780 05 FILLER PIC X(15). 001790* Field ='CustF.SalesThisMonth' VALUE '$$$,$$9.99' 001800 03 SalesThisMonth. 001810 05 LTH PIC S9(4) COMP. 001820 05 ATTR PIC X. 001830 05 COLR PIC X. 001840 05 HLIT PIC X. 001850 05 INPT PIC X(10). 001860 05 OUT REDEFINES INPT PIC $$$,$$9.99. 001870* ErrorFlag VALUE '*' 001880 03 EFLD23. 001890 05 LTH PIC S9(4) COMP. 001900 05 ATTR PIC X. 001910 05 COLR PIC X. 001920 05 HLIT PIC X. 001930 05 OUT PIC X(1). 001940* Constant VALUE 'SalesYTD.' 001950 03 CNST24. 001960 05 LTH PIC S9(4) COMP. 001970 05 ATTR PIC X. 001980 05 COLR PIC X. 001990 05 HLIT PIC X. 002000 05 FILLER PIC X(9). 002010* Field ='CustF.SalesYTD' VALUE '$$$,$$9.99' 002020 03 SalesYTD. 002030 05 LTH PIC S9(4) COMP. 002040 05 ATTR PIC X. 002050 05 COLR PIC X. 002060 05 HLIT PIC X. 002070 05 INPT PIC X(10). 002080 05 OUT REDEFINES INPT PIC $$$,$$9.99. 002090* ErrorFlag VALUE '*' 002100 03 EFLD26. 002110 05 LTH PIC S9(4) COMP. 002120 05 ATTR PIC X. 002130 05 COLR PIC X. 002140 05 HLIT PIC X. 002150 05 OUT PIC X(1). 002160* Constant VALUE 'Billingcycle.' 002170 03 CNST27. 002180 05 LTH PIC S9(4) COMP. 002190 05 ATTR PIC X. 002200 05 COLR PIC X. 002210 05 HLIT PIC X. 002220 05 FILLER PIC X(13). 002230* Field ='CustF.Billingcycle' VALUE '99' 002240 03 Billingcycle. 002250 05 LTH PIC S9(4) COMP. 002260 05 ATTR PIC X. 002270 05 COLR PIC X. 002280 05 HLIT PIC X. 002290 05 INPT PIC X(2). 002300 05 OUT REDEFINES INPT PIC 99. 002310* ErrorFlag VALUE '*********' 002320 03 EFLD29. 002330 05 LTH PIC S9(4) COMP. 002340 05 ATTR PIC X. 002350 05 COLR PIC X. 002360 05 HLIT PIC X. 002370 05 OUT PIC X(9). 002380* Constant VALUE 'DateCommenced.' 002390 03 CNST30. 002400 05 LTH PIC S9(4) COMP. 002410 05 ATTR PIC X. 002420 05 COLR PIC X. 002430 05 HLIT PIC X. 002440 05 FILLER PIC X(14). 002450* Field ='CustF.DateCommenced' VALUE 'X(10)_____' 002460 03 DateCommenced. 002470 05 LTH PIC S9(4) COMP. 002480 05 ATTR PIC X. 002490 05 COLR PIC X. 002500 05 HLIT PIC X. 002510 05 INPT PIC X(10). 002520 05 OUT REDEFINES INPT PIC X(10). 002530* ErrorFlag VALUE '*' 002540 03 EFLD32. 002550 05 LTH PIC S9(4) COMP. 002560 05 ATTR PIC X. 002570 05 COLR PIC X. 002580 05 HLIT PIC X. 002590 05 OUT PIC X(1). 002600* ErrorFlag VALUE 002610* '#xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx 002620* xxxxxxxxxxxxxxxxxxxxx' 002630 03 JZ-Error. 002640 05 LTH PIC S9(4) COMP. 002650 05 ATTR PIC X. 002660 05 COLR PIC X. 002670 05 HLIT PIC X. 002680 05 OUT PIC X(80). 002690* OutputField ='' VALUE 'PF Keys. PF3=Return, PF12 = Exit 002700* .' 002710 03 JZAidHelp. 002720 05 LTH PIC S9(4) COMP. 002730 05 ATTR PIC X. 002740 05 COLR PIC X. 002750 05 HLIT PIC X. 002760 05 OUT PIC X(77). 002770****************************************************************** 002780** ** 002790** VSAM Files ** 002800** ** 002810****************************************************************** 002820* 002830 01 JZ-CustF. 002840 03 Account PIC 999999. 002850 03 Region PIC S9(3) COMP-3. 002860 03 District PIC S9(3) COMP-3. 002870 03 Name PIC X(15). 002880 03 SalesThisMonth PIC S9(5)V9(2) COMP-3. 002890 03 SalesYTD PIC S9(5)V9(2) COMP-3. 002900 03 Billingcycle PIC X. 002910 03 DateCommenced PIC X(10). 002920* 002930* Program ID etc - in case of errors 002940 01 JZ-Program-Info. 002950 03 PROG-ID PIC X(20) VALUE 'PROGRAM CICS1'. 002960 03 AUTH PIC X(40) VALUE 'IBMUSER (Using Jazz, 0.12.4.59)'. 002970 03 DTE-WRITTEN PIC X(24) VALUE '29/12/2014 9:00:13 a.m.'. 002980 03 JZ-Jazz-Stmt PIC X(80) VALUE SPACES. 002990 03 JZ-CICS-Stmt PIC X(80) VALUE SPACES. 003000 03 JZ-Response PIC S9(8) BINARY VALUE 0. 003010 03 JZ-Response2 PIC S9(8) BINARY VALUE 0. 003020* 003030* Status Flags and control data 003040 01 JZ-FileControl. 003050 03 CICS1S-Error-Flag PIC X VALUE 'Y'. 003060 03 CustF-ENDFILE PIC X VALUE 'N'. 003070 03 CustF-STATUS PIC S9(8) VALUE 0. 003080 03 CustF-FOUND-FLAG PIC X VALUE 'Y'. 003090 88 CustF-FOUND VALUE 'Y'. 003100 03 CustF-UPDATEPENDING-FLAG PIC X VALUE 'N'. 003110 88 CustF-UPDATEPENDING VALUE 'Y'. 003120 03 TS1-ENDFILE PIC X VALUE 'N'. 003130 03 TS1-STATUS PIC S9(8) VALUE 0. 003140 03 TS1-FOUND-FLAG PIC X VALUE 'Y'. 003150 88 TS1-FOUND VALUE 'Y'. 003160 03 TS1-UPDATEPENDING-FLAG PIC X VALUE 'N'. 003170 88 TS1-UPDATEPENDING VALUE 'Y'. 003180* 003190 LOCAL-STORAGE SECTION. 003200****************************************************************** 003210** ** 003220** JZ - Jazz Sundry fields ** 003230** ** 003240****************************************************************** 003250* 003260 01 JZ. 003270 03 JZ-AL PIC S9(4) COMP VALUE 0. 003280 03 JZ-ALIM PIC S9(4) COMP VALUE 0. 003290 03 JZ-NOFML PIC S9(4) COMP VALUE 0. 003300 03 JZ-BLANK PIC XXXX VALUE SPACES. 003310 03 JZ-CHAR80 PIC X(80) VALUE SPACES. 003320 03 JZ-FNAME PIC X(30) VALUE SPACES. 003330 03 JZ-KL PIC S9(4) COMP VALUE 0. 003340 03 JZ-MLTH PIC S9(4) COMP VALUE 0. 003350 03 JZ-TinyNbr PIC S9(4) COMP VALUE ZERO. 003360 03 JZ-TinyGr REDEFINES JZ-TinyNbr. 003370 05 FILLER PIC X. 003380 05 JZ-Tiny PIC X. 003390 03 CustF-Name PIC X(15). 003400****************************************************************** 003410** ** 003420** CICS1C (COMMAREA) ** 003430** ** 003440****************************************************************** 003450* 003460 01 CICS1C. 003470 03 JZ-Function PIC X VALUE SPACES. 003480 03 Restart PIC X VALUE 'N'. 003490 03 UpEnabled PIC X VALUE 'N'. 003500 03 DownEnabled PIC X VALUE 'N'. 003510 03 PrevEnabled PIC X VALUE 'N'. 003520 03 NextEnabled PIC X VALUE 'N'. 003530 03 TS1QName PIC X(16) VALUE SPACES. 003540 03 TS1Current-Record PIC S9(4) COMP VALUE ZERO. 003550 03 TS1Record-Count PIC S9(4) COMP VALUE ZERO. 003560****************************************************************** 003570** ** 003580** CustF1 ** 003590** ** 003600****************************************************************** 003610* VSAM Alternate index, DSN=ibmuser.vsam.custf1 003620****************************************************************** 003630** ** 003640** TS1 ** 003650** ** 003660****************************************************************** 003670* 003680 01 TS1. 003690 03 Account PIC 999999 VALUE ZERO. 003700****************************************************************** 003710** ** 003720** Code Tables ** 003730** ** 003740****************************************************************** 003750* 003760* Types.Month 003770 01 JZCodes-Types-Month. 003780 03 JZValues. 003790 05 FILLER PIC X(9) VALUE 'January '. 003800 05 FILLER PIC X(9) VALUE 'February '. 003810 05 FILLER PIC X(9) VALUE 'March '. 003820 05 FILLER PIC X(9) VALUE 'April '. 003830 05 FILLER PIC X(9) VALUE 'May '. 003840 05 FILLER PIC X(9) VALUE 'June '. 003850 05 FILLER PIC X(9) VALUE 'July '. 003860 05 FILLER PIC X(9) VALUE 'August '. 003870 05 FILLER PIC X(9) VALUE 'September'. 003880 05 FILLER PIC X(9) VALUE 'October '. 003890 05 FILLER PIC X(9) VALUE 'November '. 003900 05 FILLER PIC X(9) VALUE 'December '. 003910 03 JZTABLE REDEFINES JZValues. 003920 05 ITEM-VALUES OCCURS 12 INDEXED BY JZIX-Types-Month. 003930 07 CODE-VALUE PIC X(9). 003940 03 FILLER. 003950 05 SEARCH-FOR PIC S9(4) COMP. 003960 05 FOUND-VALUE PIC X(9) VALUE '*********'. 003970****************************************************************** 003980** ** 003990** Linkage Section: Commarea ** 004000** ** 004010****************************************************************** 004020* 004030 LINKAGE SECTION. 004040* 004050 01 DFHCOMMAREA. 004060 05 JZ-Function PIC X. 004070 05 Restart PIC X. 004080 05 UpEnabled PIC X. 004090 05 DownEnabled PIC X. 004100 05 PrevEnabled PIC X. 004110 05 NextEnabled PIC X. 004120 05 TS1QName PIC X(16). 004130 05 TS1Current-Record PIC S9(4) COMP. 004140 05 TS1Record-Count PIC S9(4) COMP. 004150****************************************************************** 004160** ** 004170** Procedure Division. ** 004180** ** 004190****************************************************************** 004200* 004210 PROCEDURE DIVISION. 004220 EXEC CICS 004230 HANDLE ABEND LABEL(JZ-Abend-Exit) RESP(JZ-RESPONSE) 004240 END-EXEC. 004250 PERFORM CICS-CheckStatus. 004260* No message is returned with CLEAR or PA1-3 004270 IF EIBAID = DFHCLEAR OR DFHPA1 OR DFHPA2 OR DFHPA3 004280 GO TO JZ-Main-Program-Logic 004290 END-IF. 004300* Check that there is a message to read 004310 IF EIBCALEN = 0 004320 MOVE LOW-VALUE TO CICS1S 004330 MOVE '004320 SEND MAP(''CICS1S'') FROM(CICS1S) ERASE' TO 004340 JZ-CICS-Stmt 004350 EXEC CICS 004360 SEND MAP('CICS1S') FROM(CICS1S) ERASE RESP(JZ-RESPONSE) 004370 END-EXEC 004380 PERFORM CICS-CheckStatus 004390* Read Input Screen 004400 Else 004410 MOVE DFHCOMMAREA TO CICS1C 004420 MOVE '004410 RECEIVE MAP(''CICS1S'') INTO(CICS1S)' TO 004430 JZ-CICS-Stmt 004440 EXEC CICS 004450 RECEIVE MAP('CICS1S') INTO(CICS1S) RESP(JZ-RESPONSE) 004460 END-EXEC 004470 PERFORM CICS-CheckStatus 004480* Clear error flags (in case prior ACCEPT found errors) 004490 MOVE SPACE TO OUT OF EFLD9 OF CICS1S 004500 MOVE SPACE TO OUT OF EFLD13 OF CICS1S 004510 MOVE SPACE TO OUT OF EFLD17 OF CICS1S 004520 MOVE SPACE TO OUT OF EFLD20 OF CICS1S 004530 MOVE SPACE TO OUT OF EFLD23 OF CICS1S 004540 MOVE SPACE TO OUT OF EFLD26 OF CICS1S 004550 MOVE SPACE TO OUT OF EFLD32 OF CICS1S 004560 PERFORM JZ-SET-AidHelp 004570 PERFORM JZ-Main-Program-Logic 004580 END-IF. 004590* 004600 JZ-Normal-Exit. 004610 MOVE '004600 RETURN TRANSID(''TRN1'') COMMAREA(CICS1C)' TO 004620 JZ-CICS-Stmt. 004630 EXEC CICS 004640 RETURN TRANSID('TRN1') COMMAREA(CICS1C) RESP(JZ-RESPONSE) 004650 END-EXEC. 004660 GOBACK. 004670* 004680 JZ-Abend-Exit. 004690 CALL 'JZABNDC' USING DFHEIBLK DFHCOMMAREA JZ-Program-Info. 004700* 004710 JZ-Restart. 004720 MOVE '004710 RETURN TRANSID(''TRN1'')' TO JZ-CICS-Stmt. 004730 EXEC CICS 004740 RETURN TRANSID('TRN1') RESP(JZ-RESPONSE) 004750 END-EXEC. 004760 GOBACK. 004770****************************************************************** 004780** ** 004790** Main Program Logic ** 004800** ** 004810****************************************************************** 004820* 004830 JZ-Main-Program-Logic. 004840* 004850* Detect and handle Aid Keys 004860 EVALUATE EIBAID 004870 WHEN DFHENTER 004880 PERFORM JZ-AID-ENTER 004890 WHEN DFHCLEAR 004900 PERFORM JZ-AID-CLEAR 004910 WHEN DFHPF3 004920 PERFORM JZ-AID-PF3 004930 WHEN DFHPF10 004940 PERFORM JZ-AID-ENTER 004950 WHEN DFHPF11 004960 PERFORM JZ-AID-ENTER 004970 WHEN DFHPF12 004980 PERFORM JZ-AID-PF12 004990 WHEN OTHER 005000 PERFORM JZ-AID-OTHER 005010 END-EVALUATE. 005020 GO TO JZ-NORMAL-EXIT. 005030****************************************************************** 005040** ** 005050** Process Default AID keys ** 005060** ** 005070****************************************************************** 005080* 005090 JZ-AID-CLEAR. 005100 MOVE '005090 SEND TEXT FROM(JZ-BLANK) ERASE FREEKB' TO 005110 JZ-CICS-Stmt. 005120 EXEC CICS 005130 SEND TEXT FROM(JZ-BLANK) ERASE FREEKB RESP(JZ-RESPONSE) 005140 END-EXEC. 005150 PERFORM CICS-CheckStatus. 005160 GOBACK. 005170* 005180 JZ-AID-PF3. 005190 GO TO JZ-Restart. 005200* 005210 JZ-AID-PF12. 005220 MOVE '005210 XCTL PROGRAM(''MENU1'')' TO JZ-CICS-Stmt. 005230 EXEC CICS 005240 XCTL PROGRAM('MENU1') RESP(JZ-RESPONSE) 005250 END-EXEC. 005260 PERFORM CICS-CheckStatus. 005270 GOBACK. 005280* 005290 JZ-AID-OTHER. 005300 MOVE 'INVALID FUNCTION KEY' TO OUT OF JZ-Error OF CICS1S. 005310 MOVE '005300 SEND MAP(''CICS1S'') FROM(CICS1S) ALARM DATAONLY 005320- '' TO JZ-CICS-Stmt. 005330 EXEC CICS 005340 SEND MAP('CICS1S') FROM(CICS1S) ALARM DATAONLY 005350 RESP(JZ-RESPONSE) 005360 END-EXEC. 005370 PERFORM CICS-CheckStatus. 005380 GO TO JZ-NORMAL-EXIT. 005390* 005400 JZ-AID-ENTER. 005410****************************************************************** 005420** ** 005430** Normal Processing Logic (ENTER etc. clicked) ** 005440** ** 005450****************************************************************** 005460* ACCEPT (CICS1S.Account OR CICS1S.Name); 005470 Move '000100 ACCEPT (CICS1S.Account OR CICS1S.Name);' TO 005480 JZ-Jazz-Stmt. 005490 MOVE SPACES TO OUT OF JZ-Error OF CICS1S. 005500 MOVE ZERO TO LTH OF JZ-Error OF CICS1S. 005510 MOVE 'N' TO CICS1S-Error-Flag. 005520* Validate CICS1S.Account, assign to CustF.Account 005530 MOVE SPACES TO JZ-CHAR80. 005540 MOVE 'Account' TO JZ-FNAME. 005550 MOVE ZERO TO Account OF JZ-CustF. 005560 IF LTH OF Account OF CICS1S > ZERO 005570 IF INPT OF Account OF CICS1S IS NUMERIC 005580 COMPUTE Account OF JZ-CustF = FUNCTION NUMVAL(INPT OF 005590 Account OF CICS1S) 005600 ELSE 005610 MOVE 'not numeric' TO JZ-CHAR80 005620 END-IF 005630 END-IF. 005640 IF JZ-CHAR80 NOT = SPACE 005650 MOVE 'Y' TO CICS1S-Error-Flag 005660 MOVE '*' TO OUT OF EFLD9 OF CICS1S 005670 MOVE -1 TO LTH OF Account OF CICS1S 005680 MOVE 80 TO JZ-MLTH 005690 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 005700 CICS1S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 005710 END-IF. 005720* Validate CICS1S.Name, assign to CustF.Name 005730 MOVE SPACES TO JZ-CHAR80. 005740 MOVE 'Name' TO JZ-FNAME. 005750 MOVE SPACES TO Name OF JZ-CustF. 005760 IF LTH OF Name OF CICS1S > ZERO 005770 MOVE INPT OF Name OF CICS1S TO Name OF JZ-CustF 005780 IF LTH OF Name OF CICS1S > 15 005790 MOVE 'too long' TO JZ-CHAR80 005800 END-IF 005810 END-IF. 005820* Test that one of the OR-list fields are present 005830 IF Account OF JZ-CustF = ZERO AND Name OF JZ-CustF = SPACES 005840 MOVE 'value required' TO JZ-CHAR80 005850 MOVE 'Account,Name' TO JZ-FNAME 005860 END-IF. 005870 IF JZ-CHAR80 NOT = SPACE 005880 MOVE 'Y' TO CICS1S-Error-Flag 005890 MOVE '*' TO OUT OF EFLD13 OF CICS1S 005900 MOVE -1 TO LTH OF Name OF CICS1S 005910 MOVE 80 TO JZ-MLTH 005920 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 005930 CICS1S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 005940 END-IF. 005950 IF CICS1S-Error-Flag = 'Y' 005960* Respond with error messages and exit program 005970 MOVE '005960 SEND MAP(''CICS1S'') FROM(CICS1S) CURSOR ALA 005980- 'RM' TO JZ-CICS-Stmt 005990 EXEC CICS 006000 SEND MAP('CICS1S') FROM(CICS1S) CURSOR ALARM 006010 RESP(JZ-RESPONSE) 006020 END-EXEC 006030 PERFORM CICS-CheckStatus 006040 GO TO JZ-Normal-Exit 006050 END-IF. 006060* GET custf KEY(CustF.Account OR CustF.Name)$TS(1); 006070 Move '000130 GET custf KEY(CustF.Account OR CustF.Name)$TS(1) 006080- ';' TO JZ-Jazz-Stmt. 006090 PERFORM CustF-Initialize-17. 006100 MOVE 'Y' TO CustF-Found-Flag. 006110 IF Account OF JZ-CustF NOT = ZERO 006120 MOVE '006110 READ FILE(''CUSTF'') INTO(JZ-CustF) RIDFLD(A 006130- 'ccount OF JZ-CustF)' TO JZ-CICS-Stmt 006140 EXEC CICS 006150 READ FILE('CUSTF') INTO(JZ-CustF) RIDFLD(Account OF 006160 JZ-CustF) RESP(JZ-RESPONSE) 006170 END-EXEC 006180 ELSE 006190 IF Name OF JZ-CustF NOT = SPACES 006200 MOVE LTH OF Name OF CICS1S TO JZ-KL 006210* Set unique name for TS Queue 006220 MOVE EIBTRMID TO TS1QName OF CICS1C(1:4) 006230 MOVE 'CICS1' TO TS1QName OF CICS1C(5:7) 006240 MOVE 'TS1' TO TS1QName OF CICS1C(12:5) 006250 EVALUATE EIBAID 006260 WHEN DFHENTER 006270* Read relevant record keys into TS (Temporary Storage) 006280* Initialize TS and its control fields 006290 MOVE 'N' TO CUSTF-ENDFILE 006300 MOVE ZERO TO TS1Record-Count OF CICS1C 006310 MOVE ZERO TO TS1Current-Record OF CICS1C 006320 MOVE '006310 DELETEQ TS QNAME(TS1QName OF CIC 006330- 'S1C)' TO JZ-CICS-Stmt 006340 EXEC CICS 006350 DELETEQ TS QNAME(TS1QName OF CICS1C) RESP 006360 (JZ-RESPONSE) 006370 END-EXEC 006380 MOVE Name OF JZ-CustF(1:JZ-KL) TO CustF-Name 006390 OF JZ 006400 IF JZ-KL NOT = 15 006410 MOVE '006400 STARTBR FILE(''CUSTF1'') RID 006420- 'FLD(Name OF JZ-CustF) GENERIC KEYLEN 006430- 'GTH(JZ-KL) EQUAL' TO JZ-CICS-Stmt 006440 EXEC CICS 006450 STARTBR FILE('CUSTF1') RIDFLD(Name OF 006460 JZ-CustF) GENERIC 006470 KEYLENGTH(JZ-KL) EQUAL 006480 RESP(JZ-RESPONSE) 006490 END-EXEC 006500 ELSE 006510 MOVE '006500 STARTBR FILE(''CUSTF1'') RID 006520- 'FLD(Name OF JZ-CustF)' TO JZ-CICS-Stmt 006530 EXEC CICS 006540 STARTBR FILE('CUSTF1') RIDFLD(Name OF 006550 JZ-CustF) RESP(JZ-RESPONSE) 006560 END-EXEC 006570 END-IF 006580 IF JZ-Response = DFHRESP(NORMAL) OR 006590 JZ-Response = DFHRESP(DUPKEY) 006600 PERFORM UNTIL CUSTF-ENDFILE = 'Y' 006610 IF JZ-KL NOT = 15 006620 MOVE '006610 READNEXT FILE(''CUST 006630- 'F1'') INTO(JZ-CustF) RIDFLD( 006640- 'Name OF JZ-CustF) KEYLENGTH( 006650- 'JZ-KL)' TO JZ-CICS-Stmt 006660 EXEC CICS 006670 READNEXT FILE('CUSTF1') INTO( 006680 JZ-CustF) RIDFLD(Name OF 006690 JZ-CustF) KEYLENGTH(JZ-KL 006700 ) RESP(JZ-RESPONSE) 006710 END-EXEC 006720 ELSE 006730 MOVE '006720 READNEXT FILE(''CUST 006740- 'F1'') INTO(JZ-CustF) RIDFLD( 006750- 'Name OF JZ-CustF)' TO 006760 JZ-CICS-Stmt 006770 EXEC CICS 006780 READNEXT FILE('CUSTF1') INTO( 006790 JZ-CustF) RIDFLD(Name OF 006800 JZ-CustF) RESP(JZ-RESPONSE) 006810 END-EXEC 006820 END-IF 006830 PERFORM CustF-CheckStatus 006840* Check that READNEXT hasn't run past end 006850 IF Name OF JZ-CustF(1:JZ-KL) NOT = 006860 CustF-Name OF JZ(1:JZ-KL) 006870 MOVE 'Y' TO CUSTF-ENDFILE 006880 ELSE 006890 MOVE Account OF JZ-CustF TO 006900 Account OF TS1 006910 MOVE '006900 WRITEQ TS QNAME(TS1Q 006920- 'Name OF CICS1C) FROM(TS1) MA 006930- 'IN NUMITEMS(TS1Record-Count 006940- 'OF C' TO JZ-CICS-Stmt 006950 EXEC CICS 006960 WRITEQ TS QNAME(TS1QName OF 006970 CICS1C) FROM(TS1) MAIN 006980 NUMITEMS(TS1Record-Count 006990 OF CICS1C) RESP(JZ-RESPONSE) 007000 END-EXEC 007010 PERFORM CICS-CheckStatus 007020 END-IF 007030 END-PERFORM 007040 ELSE 007050 MOVE 'Y' TO CUSTF-ENDFILE 007060 END-IF 007070 MOVE '007060 ENDBR FILE(''CUSTF1'')' TO 007080 JZ-CICS-Stmt 007090 EXEC CICS 007100 ENDBR FILE('CUSTF1') RESP(JZ-RESPONSE) 007110 END-EXEC 007120 PERFORM CICS-CheckStatus 007130 IF TS1Record-Count OF CICS1C > 0 007140* Read 1st record 007150 MOVE 1 TO TS1Current-Record OF CICS1C 007160 PERFORM JZ-READ-TS1 007170 END-IF 007180 WHEN DFHPF10 007190 SUBTRACT 1 FROM TS1Current-Record OF CICS1C 007200 IF TS1Current-Record OF CICS1C > 0 007210 PERFORM JZ-READ-TS1 007220 Else 007230 MOVE 'PF10 Disabled - outside range of Pr 007240- 'evious/next records' TO OUT OF 007250 JZ-Error OF CICS1S 007260 MOVE '007250 SEND MAP(''CICS1S'') FROM(CI 007270- 'CS1S) ALARM DATAONLY' TO JZ-CICS-Stmt 007280 EXEC CICS 007290 SEND MAP('CICS1S') FROM(CICS1S) ALARM 007300 DATAONLY RESP(JZ-RESPONSE) 007310 END-EXEC 007320 PERFORM CICS-CheckStatus 007330 GO TO JZ-NORMAL-EXIT 007340 END-IF 007350 WHEN DFHPF11 007360 ADD 1 TO TS1Current-Record OF CICS1C 007370 IF TS1Current-Record OF CICS1C <= 007380 TS1Record-Count OF CICS1C 007390 PERFORM JZ-READ-TS1 007400 Else 007410 MOVE 'PF11 Disabled - outside range of Pr 007420- 'evious/next records' TO OUT OF 007430 JZ-Error OF CICS1S 007440 MOVE '007430 SEND MAP(''CICS1S'') FROM(CI 007450- 'CS1S) ALARM DATAONLY' TO JZ-CICS-Stmt 007460 EXEC CICS 007470 SEND MAP('CICS1S') FROM(CICS1S) ALARM 007480 DATAONLY RESP(JZ-RESPONSE) 007490 END-EXEC 007500 PERFORM CICS-CheckStatus 007510 GO TO JZ-NORMAL-EXIT 007520 END-IF 007530 END-EVALUATE 007540 PERFORM JZ-SET-AIDHELP 007550 ELSE 007560 MOVE DFHRESP(NOTFND) TO JZ-RESPONSE 007570 END-IF 007580 END-IF. 007590 PERFORM CustF-CheckStatus. 007600* IF custf.$Found = 'N' THEN; 007610 Move '000150 IF custf.$Found = ''N'' THEN;' TO JZ-Jazz-Stmt. 007620 IF CustF-FOUND-FLAG = 'N' 007630* CICS1S.error = 'No Record Found'; 007640 Move '000160 CICS1S.error = ''No Record Found'';' TO 007650 JZ-Jazz-Stmt 007660 MOVE 'No Record Found' TO OUT OF JZ-Error OF CICS1S 007670* END IF; 007680 END-IF. 007690* SEND CICS1S(CICS1S.*); 007700 Move '000180 SEND CICS1S(CICS1S.*);' TO JZ-Jazz-Stmt. 007710 MOVE Account OF JZ-CustF TO OUT OF Account OF CICS1S. 007720 MOVE LOW-VALUE TO ATTR OF Account OF CICS1S. 007730 MOVE Name OF JZ-CustF TO OUT OF Name OF CICS1S. 007740 MOVE LOW-VALUE TO ATTR OF Name OF CICS1S. 007750 MOVE Region OF JZ-CustF TO OUT OF Region OF CICS1S. 007760 MOVE LOW-VALUE TO ATTR OF Region OF CICS1S. 007770 MOVE District OF JZ-CustF TO OUT OF District OF CICS1S. 007780 MOVE LOW-VALUE TO ATTR OF District OF CICS1S. 007790 MOVE SalesThisMonth OF JZ-CustF TO OUT OF SalesThisMonth OF 007800 CICS1S. 007810 MOVE LOW-VALUE TO ATTR OF SalesThisMonth OF CICS1S. 007820 MOVE SalesYTD OF JZ-CustF TO OUT OF SalesYTD OF CICS1S. 007830 MOVE LOW-VALUE TO ATTR OF SalesYTD OF CICS1S. 007840 MOVE ZERO TO JZ-TinyNbr. 007850 MOVE Billingcycle OF JZ-CustF TO JZ-Tiny. 007860 MOVE JZ-TinyNbr TO OUT OF Billingcycle OF CICS1S. 007870 MOVE ZERO TO JZ-TinyNbr. 007880 MOVE Billingcycle OF JZ-CustF TO JZ-Tiny. 007890 MOVE JZ-TinyNbr TO SEARCH-FOR OF JZCodes-Types-Month. 007900 PERFORM JZCvt-Types-Month. 007910 MOVE FOUND-VALUE OF JZCodes-Types-Month TO OUT OF EFLD29 OF 007920 CICS1S. 007930 MOVE LOW-VALUE TO ATTR OF Billingcycle OF CICS1S. 007940 MOVE DateCommenced OF JZ-CustF TO OUT OF DateCommenced OF 007950 CICS1S. 007960 MOVE LOW-VALUE TO ATTR OF DateCommenced OF CICS1S. 007970 MOVE '007960 SEND MAP(''CICS1S'') FROM(CICS1S) DATAONLY' TO 007980 JZ-CICS-Stmt. 007990 EXEC CICS 008000 SEND MAP('CICS1S') FROM(CICS1S) DATAONLY RESP(JZ-RESPONSE) 008010 END-EXEC. 008020 PERFORM CICS-CheckStatus. 008030 GO TO JZ-Normal-Exit. 008040****************************************************************** 008050** ** 008060** Code Conversion Routines ** 008070** ** 008080****************************************************************** 008090* 008100* Convert Types-Month code to value 008110 JZCvt-Types-Month. 008120* Input: SEARCH-FOR OF JZCodes-Types-Month 008130* Output: FOUND-VALUE OF JZCodes-Types-Month 008140* If Invalid, FOUND-VALUE will be set to '****', 008150* field JZ-CHAR80 will contain an error message 008160 SET JZIX-Types-Month TO SEARCH-FOR OF JZCodes-Types-Month. 008170 IF JZIX-Types-Month < 1 OR JZIX-Types-Month > 12 008180 MOVE 'Outside Code Range' TO JZ-CHAR80 008190 MOVE '*********' TO FOUND-VALUE OF JZCodes-Types-Month 008200 ELSE 008210 MOVE CODE-Value OF JZCodes-Types-Month(JZIX-Types-Month) 008220 TO FOUND-VALUE OF JZCodes-Types-Month 008230 END-IF. 008240****************************************************************** 008250** ** 008260** CICS Support Routines ** 008270** ** 008280****************************************************************** 008290* 008300 JZ-SET-AidHelp. 008310 MOVE 'F3=Return,' TO OUT OF JZAidHelp OF CICS1S. 008320 MOVE 11 TO JZ-AL. 008330 IF TS1Record-Count OF CICS1C > 1 008340 CALL 'JZNOFM' USING DFHEIBLK DFHCOMMAREA 008350 TS1Current-Record OF CICS1C, TS1Record-Count OF 008360 CICS1C, JZ-CHAR80, JZ-NOFML 008370 IF JZ-NOFML > 0 008380 MOVE JZ-CHAR80 TO OUT OF JZAidHelp OF 008390 CICS1S(JZ-AL:JZ-NOFML) 008400 ADD JZ-NOFML TO JZ-AL 008410 END-IF 008420 END-IF. 008430 IF TS1Current-Record OF CICS1C > 1 008440 MOVE 'F10=Previous,' TO OUT OF JZAidHelp OF CICS1S(JZ-AL:14) 008450 ADD 14 TO JZ-AL 008460 END-IF. 008470 IF TS1Current-Record OF CICS1C < TS1Record-Count OF CICS1C 008480 MOVE 'F11=Next,' TO OUT OF JZAidHelp OF CICS1S(JZ-AL:9) 008490 ADD 9 TO JZ-AL 008500 END-IF. 008510 COMPUTE JZ-MLTH = JZ-AL + 8. 008520 IF JZ-MLTH > 80 008530 COMPUTE JZ-ALIM = 80 - JZ-AL 008540 ELSE 008550 MOVE 8 TO JZ-ALIM 008560 END-IF. 008570 IF JZ-ALIM > 0 008580 MOVE 'F12=Exit' TO OUT OF JZAidHelp OF CICS1S(JZ-AL:JZ-ALIM) 008590 ADD JZ-ALIM TO JZ-AL 008600 END-IF. 008610* 008620 CICS-CheckStatus. 008630 EVALUATE JZ-Response 008640 WHEN DFHRESP(NORMAL) 008650 CONTINUE 008660 WHEN OTHER 008670 GO TO JZ-Abend-Exit 008680 END-EVALUATE. 008690* 008700 CustF-Initialize-17. 008710 PERFORM CustF-Initialize. 008720* 008730 CustF-Initialize. 008740* Initialize non-key fields 008750 Move ZERO TO Region OF JZ-CustF. 008760 Move ZERO TO District OF JZ-CustF. 008770 Move ZERO TO SalesThisMonth OF JZ-CustF. 008780 Move ZERO TO SalesYTD OF JZ-CustF. 008790 Move LOW-VALUE TO Billingcycle OF JZ-CustF. 008800 Move SPACES TO DateCommenced OF JZ-CustF. 008810* 008820 CustF-CheckStatus. 008830 EVALUATE JZ-Response 008840 WHEN DFHRESP(NORMAL) 008850 CONTINUE 008860* GET and DELETE: check that record found 008870 WHEN DFHRESP(NOTFND) 008880 MOVE 'N' TO CustF-Found-Flag 008890* Process (Browse): check that one of the duplicate records 008900* has been returned 008910 WHEN DFHRESP(ENDINPT) 008920 MOVE 'Y' TO CustF-ENDFILE 008930 WHEN DFHRESP(DUPKEY) 008940 CONTINUE 008950 WHEN OTHER 008960 GO TO JZ-Abend-Exit 008970 END-EVALUATE. 008980* 008990 JZ-READ-TS1. 009000* Read CUSTF with key from nth item in TS 009010* IF condition should always be true 009020 IF TS1Current-Record OF CICS1C >= 1 AND TS1Current-Record OF 009030 CICS1C <= TS1Record-Count OF CICS1C 009040 MOVE '009030 READQ TS QNAME(TS1QName OF CICS1C) INTO(Acco 009050- 'unt OF JZ-CustF) ITEM(TS1Current-Rec' TO JZ-CICS-Stmt 009060 EXEC CICS 009070 READQ TS QNAME(TS1QName OF CICS1C) INTO(Account OF 009080 JZ-CustF) ITEM(TS1Current-Record OF CICS1C) RESP( 009090 JZ-RESPONSE) 009100 END-EXEC 009110 PERFORM CICS-CheckStatus 009120 MOVE '009110 READ FILE(''CUSTF'') INTO(JZ-CustF) RIDFLD(A 009130- 'ccount OF JZ-CustF)' TO JZ-CICS-Stmt 009140 EXEC CICS 009150 READ FILE('CUSTF') INTO(JZ-CustF) RIDFLD(Account OF 009160 JZ-CustF) RESP(JZ-RESPONSE) 009170 END-EXEC 009180 PERFORM CICS-CheckStatus 009190 END-IF.