000010* C:\tutorials\TstSQL\cbl\CICS1.CBL 000020 IDENTIFICATION DIVISION. CICS1 000030 PROGRAM-ID. CICS1. CICS1 000040 AUTHOR. JAZZUSR (Using Jazz from Visual Studio) CICS1 000050 DATE-WRITTEN. 31/10/2021 1:57:18 PM CICS1 000060 ENVIRONMENT DIVISION. CICS1 000070*# Last Updated by JAZZUSR at 31/10/2021 1:57:18 PM CICS1 000080*PROGRAM CICS1 CICS INSCREEN(CICS1S) TRANSID(TRN1) CICS1 000090* COMMAREA(CICS1C) EXIT(Menu1); CICS1 000100*COPY Custf; CICS1 000110*#388 E FR.Region and CustF.Region have different types CICS1 000120*ACCEPT (CICS1S.Account OR CICS1S.Name); CICS1 000130*#562 I CICS1S.Error used as message field CICS1 000140*DEFINE TS1 TS DATA( CICS1 000150* Account LIKE CustF.Account); CICS1 000160*GET Custf KEY(CustF.Account OR CustF.Name) TS(1); CICS1 000170* #373 I GET KEY not unique - one record at a time returned CICS1 000180*END GET CustF; CICS1 000190*IF Custf.$Found = false THEN; CICS1 000200* CICS1S.Error = 'No Record Found'; CICS1 000210*END IF; CICS1 000220*COPY JZSMth; CICS1 000230*SEND Inscreen; CICS1 000240******************************************************************CICS1 000250** **CICS1 000260** Data Division **CICS1 000270** **CICS1 000280******************************************************************CICS1 000290 DATA DIVISION. CICS1 000300******************************************************************CICS1 000310** **CICS1 000320** Working Storage Section: General Program Data **CICS1 000330** **CICS1 000340******************************************************************CICS1 000350* CICS1 000360 WORKING-STORAGE SECTION. CICS1 000370******************************************************************CICS1 000380** **CICS1 000390** Screen Areas **CICS1 000400** **CICS1 000410******************************************************************CICS1 000420* CICS1 000430 COPY DFHAID. CICS1 000440* CICS1 000450 01 CICS1S. CICS1 000460 03 FILLER PIC X(12). CICS1 000470* SpecialConstant VALUE 'CICS1S' CICS1 000480 03 SCNST1. CICS1 000490 05 LTH PIC S9(4) COMP. CICS1 000500 05 ATTR PIC X. CICS1 000510 05 COLR PIC X. CICS1 000520 05 HLIT PIC X. CICS1 000530 05 FILLER PIC X(6). CICS1 000540* Constant VALUE 'CustF Enquiry ' CICS1 000550 03 CNST5. CICS1 000560 05 LTH PIC S9(4) COMP. CICS1 000570 05 ATTR PIC X. CICS1 000580 05 COLR PIC X. CICS1 000590 05 HLIT PIC X. CICS1 000600 05 FILLER PIC X(14). CICS1 000610* SpecialConstant VALUE 'TRN1' CICS1 000620 03 SCNST4. CICS1 000630 05 LTH PIC S9(4) COMP. CICS1 000640 05 ATTR PIC X. CICS1 000650 05 COLR PIC X. CICS1 000660 05 HLIT PIC X. CICS1 000670 05 FILLER PIC X(4). CICS1 000680* Constant VALUE 'Enter =>' CICS1 000690 03 CNST6. CICS1 000700 05 LTH PIC S9(4) COMP. CICS1 000710 05 ATTR PIC X. CICS1 000720 05 COLR PIC X. CICS1 000730 05 HLIT PIC X. CICS1 000740 05 FILLER PIC X(8). CICS1 000750* Constant VALUE 'Account.' CICS1 000760 03 CNST7. CICS1 000770 05 LTH PIC S9(4) COMP. CICS1 000780 05 ATTR PIC X. CICS1 000790 05 COLR PIC X. CICS1 000800 05 HLIT PIC X. CICS1 000810 05 FILLER PIC X(8). CICS1 000820* Field ='CustF.Account' VALUE '999999' CICS1 000830 03 Account. CICS1 000840 05 LTH PIC S9(4) COMP. CICS1 000850 05 ATTR PIC X. CICS1 000860 05 COLR PIC X. CICS1 000870 05 HLIT PIC X. CICS1 000880 05 INPT PIC X(6). CICS1 000890 05 OUT REDEFINES INPT PIC 999999. CICS1 000900* ErrorFlag VALUE '*' CICS1 000910 03 EFLD8. CICS1 000920 05 LTH PIC S9(4) COMP. CICS1 000930 05 ATTR PIC X. CICS1 000940 05 COLR PIC X. CICS1 000950 05 HLIT PIC X. CICS1 000960 05 OUT PIC X(1). CICS1 000970* Constant VALUE 'OR =>' CICS1 000980 03 CNST9. CICS1 000990 05 LTH PIC S9(4) COMP. CICS1 001000 05 ATTR PIC X. CICS1 001010 05 COLR PIC X. CICS1 001020 05 HLIT PIC X. CICS1 001030 05 FILLER PIC X(5). CICS1 001040* Constant VALUE 'Name.' CICS1 001050 03 CNST10. CICS1 001060 05 LTH PIC S9(4) COMP. CICS1 001070 05 ATTR PIC X. CICS1 001080 05 COLR PIC X. CICS1 001090 05 HLIT PIC X. CICS1 001100 05 FILLER PIC X(5). CICS1 001110* Field ='CustF.Name' VALUE 'X(30)_________________________' CICS1 001120 03 JZ-Name. CICS1 001130 05 LTH PIC S9(4) COMP. CICS1 001140 05 ATTR PIC X. CICS1 001150 05 COLR PIC X. CICS1 001160 05 HLIT PIC X. CICS1 001170 05 INPT PIC X(30). CICS1 001180 05 OUT REDEFINES INPT PIC X(30). CICS1 001190* ErrorFlag VALUE '*' CICS1 001200 03 EFLD11. CICS1 001210 05 LTH PIC S9(4) COMP. CICS1 001220 05 ATTR PIC X. CICS1 001230 05 COLR PIC X. CICS1 001240 05 HLIT PIC X. CICS1 001250 05 OUT PIC X(1). CICS1 001260* Constant VALUE 'and press Enter' CICS1 001270 03 CNST12. CICS1 001280 05 LTH PIC S9(4) COMP. CICS1 001290 05 ATTR PIC X. CICS1 001300 05 COLR PIC X. CICS1 001310 05 HLIT PIC X. CICS1 001320 05 FILLER PIC X(15). CICS1 001330* Constant VALUE 'Region.' CICS1 001340 03 CNST13. CICS1 001350 05 LTH PIC S9(4) COMP. CICS1 001360 05 ATTR PIC X. CICS1 001370 05 COLR PIC X. CICS1 001380 05 HLIT PIC X. CICS1 001390 05 FILLER PIC X(7). CICS1 001400* Field ='CustF.Region' VALUE '---9' CICS1 001410 03 Region. CICS1 001420 05 LTH PIC S9(4) COMP. CICS1 001430 05 ATTR PIC X. CICS1 001440 05 COLR PIC X. CICS1 001450 05 HLIT PIC X. CICS1 001460 05 INPT PIC X(4). CICS1 001470 05 OUT REDEFINES INPT PIC ---9. CICS1 001480* ErrorFlag VALUE '*' CICS1 001490 03 EFLD14. CICS1 001500 05 LTH PIC S9(4) COMP. CICS1 001510 05 ATTR PIC X. CICS1 001520 05 COLR PIC X. CICS1 001530 05 HLIT PIC X. CICS1 001540 05 OUT PIC X(1). CICS1 001550* Constant VALUE 'District.' CICS1 001560 03 CNST15. CICS1 001570 05 LTH PIC S9(4) COMP. CICS1 001580 05 ATTR PIC X. CICS1 001590 05 COLR PIC X. CICS1 001600 05 HLIT PIC X. CICS1 001610 05 FILLER PIC X(9). CICS1 001620* Field ='CustF.District' VALUE '---9' CICS1 001630 03 District. CICS1 001640 05 LTH PIC S9(4) COMP. CICS1 001650 05 ATTR PIC X. CICS1 001660 05 COLR PIC X. CICS1 001670 05 HLIT PIC X. CICS1 001680 05 INPT PIC X(4). CICS1 001690 05 OUT REDEFINES INPT PIC ---9. CICS1 001700* ErrorFlag VALUE '*' CICS1 001710 03 EFLD16. CICS1 001720 05 LTH PIC S9(4) COMP. CICS1 001730 05 ATTR PIC X. CICS1 001740 05 COLR PIC X. CICS1 001750 05 HLIT PIC X. CICS1 001760 05 OUT PIC X(1). CICS1 001770* Constant VALUE 'SalesThisMonth.' CICS1 001780 03 CNST17. CICS1 001790 05 LTH PIC S9(4) COMP. CICS1 001800 05 ATTR PIC X. CICS1 001810 05 COLR PIC X. CICS1 001820 05 HLIT PIC X. CICS1 001830 05 FILLER PIC X(15). CICS1 001840* Field ='CustF.SalesThisMonth' VALUE '$$$,$$9.99CR' CICS1 001850 03 SalesThisMonth. CICS1 001860 05 LTH PIC S9(4) COMP. CICS1 001870 05 ATTR PIC X. CICS1 001880 05 COLR PIC X. CICS1 001890 05 HLIT PIC X. CICS1 001900 05 INPT PIC X(12). CICS1 001910 05 OUT REDEFINES INPT PIC $$$,$$9.99CR. CICS1 001920* ErrorFlag VALUE '*' CICS1 001930 03 EFLD18. CICS1 001940 05 LTH PIC S9(4) COMP. CICS1 001950 05 ATTR PIC X. CICS1 001960 05 COLR PIC X. CICS1 001970 05 HLIT PIC X. CICS1 001980 05 OUT PIC X(1). CICS1 001990* Constant VALUE 'SalesYTD.' CICS1 002000 03 CNST19. CICS1 002010 05 LTH PIC S9(4) COMP. CICS1 002020 05 ATTR PIC X. CICS1 002030 05 COLR PIC X. CICS1 002040 05 HLIT PIC X. CICS1 002050 05 FILLER PIC X(9). CICS1 002060* Field ='CustF.SalesYTD' VALUE '$$$,$$9.99CR' CICS1 002070 03 SalesYTD. CICS1 002080 05 LTH PIC S9(4) COMP. CICS1 002090 05 ATTR PIC X. CICS1 002100 05 COLR PIC X. CICS1 002110 05 HLIT PIC X. CICS1 002120 05 INPT PIC X(12). CICS1 002130 05 OUT REDEFINES INPT PIC $$$,$$9.99CR. CICS1 002140* ErrorFlag VALUE '*' CICS1 002150 03 EFLD20. CICS1 002160 05 LTH PIC S9(4) COMP. CICS1 002170 05 ATTR PIC X. CICS1 002180 05 COLR PIC X. CICS1 002190 05 HLIT PIC X. CICS1 002200 05 OUT PIC X(1). CICS1 002210* Constant VALUE 'Billingcycle.' CICS1 002220 03 CNST21. CICS1 002230 05 LTH PIC S9(4) COMP. CICS1 002240 05 ATTR PIC X. CICS1 002250 05 COLR PIC X. CICS1 002260 05 HLIT PIC X. CICS1 002270 05 FILLER PIC X(13). CICS1 002280* Field ='CustF.Billingcycle' VALUE '99' CICS1 002290 03 Billingcycle. CICS1 002300 05 LTH PIC S9(4) COMP. CICS1 002310 05 ATTR PIC X. CICS1 002320 05 COLR PIC X. CICS1 002330 05 HLIT PIC X. CICS1 002340 05 INPT PIC X(2). CICS1 002350 05 OUT REDEFINES INPT PIC 99. CICS1 002360* ErrorFlag VALUE '***' CICS1 002370 03 EFLD22. CICS1 002380 05 LTH PIC S9(4) COMP. CICS1 002390 05 ATTR PIC X. CICS1 002400 05 COLR PIC X. CICS1 002410 05 HLIT PIC X. CICS1 002420 05 OUT PIC X(3). CICS1 002430* Constant VALUE 'DateCommenced.' CICS1 002440 03 CNST23. CICS1 002450 05 LTH PIC S9(4) COMP. CICS1 002460 05 ATTR PIC X. CICS1 002470 05 COLR PIC X. CICS1 002480 05 HLIT PIC X. CICS1 002490 05 FILLER PIC X(14). CICS1 002500* Field ='CustF.DateCommenced' VALUE 'dd MMM yy' CICS1 002510 03 DateCommenced. CICS1 002520 05 LTH PIC S9(4) COMP. CICS1 002530 05 ATTR PIC X. CICS1 002540 05 COLR PIC X. CICS1 002550 05 HLIT PIC X. CICS1 002560 05 INPT PIC X(9). CICS1 002570 05 OUT REDEFINES INPT PIC X(9). CICS1 002580* ErrorFlag VALUE '*' CICS1 002590 03 EFLD24. CICS1 002600 05 LTH PIC S9(4) COMP. CICS1 002610 05 ATTR PIC X. CICS1 002620 05 COLR PIC X. CICS1 002630 05 HLIT PIC X. CICS1 002640 05 OUT PIC X(1). CICS1 002650* ErrorFlag VALUE CICS1 002660* '#xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx CICS1 002670* xxxxxxxxxxxxxxxxxxxxx'CICS1 002680 03 JZ-Error. CICS1 002690 05 LTH PIC S9(4) COMP. CICS1 002700 05 ATTR PIC X. CICS1 002710 05 COLR PIC X. CICS1 002720 05 HLIT PIC X. CICS1 002730 05 OUT PIC X(80). CICS1 002740* OutputField ='' VALUE 'PF Keys. PF3=Return, PF12 = Exit CICS1 002750* .'CICS1 002760 03 JZAidHelp. CICS1 002770 05 LTH PIC S9(4) COMP. CICS1 002780 05 ATTR PIC X. CICS1 002790 05 COLR PIC X. CICS1 002800 05 HLIT PIC X. CICS1 002810 05 OUT PIC X(77). CICS1 002820 05 BLK REDEFINES OUT PIC X(77). CICS1 002830******************************************************************CICS1 002840** **CICS1 002850** VSAM Files **CICS1 002860** **CICS1 002870******************************************************************CICS1 002880* CICS1 002890 01 JZ-FR. CICS1 002900 03 Region PIC 999 VALUE ZERO. CICS1 002910 03 JZ-Name PIC X(30) VALUE 'No Record found'. CICS1 002920 03 Fill PIC X(47) VALUE SPACES. CICS1 002930* CICS1 002940 01 JZ-CustF. CICS1 002950 03 Account PIC 999999 VALUE ZERO. CICS1 002960 03 Region PIC S9(3) COMP-3 VALUE ZERO. CICS1 002970 03 District PIC S9(3) COMP-3 VALUE ZERO. CICS1 002980 03 JZ-Name PIC X(30) VALUE SPACES. CICS1 002990 03 SalesThisMonth PIC S9(5)V9(2) COMP-3 VALUE ZERO. CICS1 003000 03 SalesYTD PIC S9(5)V9(2) COMP-3 VALUE ZERO. CICS1 003010 03 Billingcycle PIC X VALUE LOW-VALUE. CICS1 003020 03 DateCommenced PIC S9(9) COMP VALUE ZERO. CICS1 003030******************************************************************CICS1 003040** **CICS1 003050** General Program Information **CICS1 003060** **CICS1 003070******************************************************************CICS1 003080* CICS1 003090* Program ID etc - in case of errors CICS1 003100 01 JZ-Program-Info. CICS1 003110 03 PROG-ID PIC X(20) VALUE 'PROGRAM CICS1'. CICS1 003120 03 AUTH PIC X(40) VALUE 'JAZZUSR (Using Jazz, 3.16.3.254)'. CICS1 003130 03 DTE-WRITTEN PIC X(24) VALUE '31/10/2021 1:57:18 PM'. CICS1 003140 03 JZ-Jazz-Stmt PIC X(80) VALUE SPACES. CICS1 003150 03 JZ-CICS-Stmt PIC X(80) VALUE SPACES. CICS1 003160 03 JZ-Response PIC S9(8) BINARY VALUE 0. CICS1 003170 03 JZ-Response2 PIC S9(8) BINARY VALUE 0. CICS1 003180 03 JZ-SQLIsUsed PIC X VALUE 'N'. CICS1 003190 03 JZ-IsWebService PIC X VALUE 'N'. CICS1 003200* SQL diagnostics ignored unless JZ-SQLIsUsed = 'Y' CICS1 003210 03 JZ-SQL-Stmt PIC X(80) VALUE SPACES. CICS1 003220 03 JZ-SQLCA PIC X(80) VALUE SPACES. CICS1 003230 03 JZ-SQLCODE PIC S9(7) DISPLAY VALUE ZERO. CICS1 003240* Web Service Info ignored unless JZ-IsWebService = 'Y' CICS1 003250 03 JZ-WSTYPE PIC XXXX VALUE 'CWS '. CICS1 003260 03 JZ-WSTransportTYPE PIC XXXX VALUE ' '. CICS1 003270 03 JZ-WSSourceTYPE PIC XXXX VALUE 'COMM'. CICS1 003280* CICS1 003290* Status Flags and control data CICS1 003300 01 JZ-FileControl. CICS1 003310 03 SORTWORK-ENDFILE PIC X VALUE 'N'. CICS1 003320 03 FR-ENDFILE PIC X VALUE 'N'. CICS1 003330 03 FR-STATUS PIC S9(8) VALUE 0. CICS1 003340 03 FR-FOUND-FLAG PIC X VALUE 'Y'. CICS1 003350 88 FR-FOUND VALUE 'Y'. CICS1 003360 03 FR-UPDATEPENDING-FLAG PIC X VALUE 'N'. CICS1 003370 88 FR-UPDATEPENDING VALUE 'Y'. CICS1 003380 03 FR-Get4Update-FLAG PIC X VALUE 'N'. CICS1 003390 88 FR-Get4Update VALUE 'Y'. CICS1 003400 03 FR-HighKey PIC X(3) VALUE HIGH-VALUES. CICS1 003410 03 CustF-ENDFILE PIC X VALUE 'N'. CICS1 003420 03 CustF-STATUS PIC S9(8) VALUE 0. CICS1 003430 03 CustF-FOUND-FLAG PIC X VALUE 'Y'. CICS1 003440 88 CustF-FOUND VALUE 'Y'. CICS1 003450 03 CustF-UPDATEPENDING-FLAG PIC X VALUE 'N'. CICS1 003460 88 CustF-UPDATEPENDING VALUE 'Y'. CICS1 003470 03 CustF-Get4Update-FLAG PIC X VALUE 'N'. CICS1 003480 88 CustF-Get4Update VALUE 'Y'. CICS1 003490 03 CustF-HighKey PIC X(6) VALUE HIGH-VALUES. CICS1 003500 03 TS1-ENDFILE PIC X VALUE 'N'. CICS1 003510 03 TS1-STATUS PIC S9(8) VALUE 0. CICS1 003520 03 TS1-FOUND-FLAG PIC X VALUE 'Y'. CICS1 003530 88 TS1-FOUND VALUE 'Y'. CICS1 003540 03 TS1-UPDATEPENDING-FLAG PIC X VALUE 'N'. CICS1 003550 88 TS1-UPDATEPENDING VALUE 'Y'. CICS1 003560 03 TS1-Get4Update-FLAG PIC X VALUE 'N'. CICS1 003570 88 TS1-Get4Update VALUE 'Y'. CICS1 003580* CICS1 003590 LOCAL-STORAGE SECTION. CICS1 003600******************************************************************CICS1 003610** **CICS1 003620** JZ - Jazz Sundry fields **CICS1 003630** **CICS1 003640******************************************************************CICS1 003650* CICS1 003660 01 JZ. CICS1 003670 03 JZ-AL PIC S9(4) COMP VALUE ZERO. CICS1 003680 03 JZ-ALIM PIC S9(4) COMP VALUE ZERO. CICS1 003690 03 JZ-NOFML PIC S9(4) COMP VALUE ZERO. CICS1 003700 03 JZ-INDEX PIC S9(4) COMP VALUE ZERO. CICS1 003710 03 JZ-INDEX2 PIC S9(4) COMP VALUE ZERO. CICS1 003720 03 JZ-IXMth PIC S9(4) COMP VALUE ZERO. CICS1 003730 03 IX1 PIC S9(4) COMP VALUE ZERO. CICS1 003740 03 IX2 PIC S9(4) COMP VALUE ZERO. CICS1 003750 03 IX3 PIC S9(4) COMP VALUE ZERO. CICS1 003760 03 IX4 PIC S9(4) COMP VALUE ZERO. CICS1 003770 03 IX5 PIC S9(4) COMP VALUE ZERO. CICS1 003780 03 IX6 PIC S9(4) COMP VALUE ZERO. CICS1 003790 03 IX7 PIC S9(4) COMP VALUE ZERO. CICS1 003800 03 JZ-ST PIC S9(4) COMP VALUE ZERO. CICS1 003810 03 JZ-SL PIC S9(4) COMP VALUE ZERO. CICS1 003820 03 JZ-BLANK PIC XXXX VALUE SPACES. CICS1 003830 03 JZ-CHAR80 PIC X(80) VALUE SPACES. CICS1 003840 03 JZ-FNAME PIC X(30) VALUE SPACES. CICS1 003850 03 JZ-KL PIC S9(4) COMP VALUE ZERO. CICS1 003860 03 JZ-MLTH PIC S9(4) COMP VALUE ZERO. CICS1 003870 03 JZ-INT PIC S9(9) COMP VALUE ZERO. CICS1 003880 03 JZ-TRUEFALSE PIC XXXXX VALUE SPACES. CICS1 003890 03 JZ-TinyNbr PIC S9(9) COMP VALUE ZERO. CICS1 003900 03 JZ-TinyGr REDEFINES JZ-TinyNbr. CICS1 003910 05 FILLER PIC XXX. CICS1 003920 05 JZ-Tiny PIC X. CICS1 003930 03 JZ-Error PIC X VALUE 'N'. CICS1 003940 03 JZ-NBR1 PIC 9999 VALUE ZERO. CICS1 003950 03 JZ-NBR1X REDEFINES JZ-NBR1 PIC XXXX. CICS1 003960 03 JZ-NBR2 PIC 9999 VALUE ZERO. CICS1 003970 03 JZ-NBR2X REDEFINES JZ-NBR2 PIC XXXX. CICS1 003980 03 JZ-SUBVAL PIC ZZZZZ9 VALUE ZERO. CICS1 003990 03 JZ-SUBVALR REDEFINES JZ-SUBVAL PIC X(6). CICS1 004000 03 JZ-SUBDIGIT PIC S9(4) COMP VALUE ZERO. CICS1 004010 03 JZ-INDEXES OCCURS 7 INDEXED BY JZIX1 PIC X(6) VALUE CICS1 004020 SPACES. CICS1 004030 03 JZ-INDEXPR PIC X(6) VALUE SPACES. CICS1 004040 03 CustF-Name PIC X(30) VALUE SPACES. CICS1 004050 03 IsDateArith PIC X VALUE 'N'. CICS1 004060 03 LeapYear PIC X VALUE 'N'. CICS1 004070 03 DateFormPic PIC 99999999 VALUE ZERO. CICS1 004080 03 DateFormPicR REDEFINES DateFormPic. CICS1 004090 05 DateFormCYear PIC 9999. CICS1 004100 05 DateFormCYearR REDEFINES DateFormCYear. CICS1 004110 07 FILLER PIC 99. CICS1 004120 07 DateFormYear PIC 99. CICS1 004130 05 DateFormMth PIC 99. CICS1 004140 05 DateFormDay PIC 99. CICS1 004150 03 JZ-DateDiff. CICS1 004160 05 DFYears PIC S9(4) COMP VALUE ZERO. CICS1 004170 05 DFMonths PIC S9(4) COMP VALUE ZERO. CICS1 004180 05 DFDays PIC S9(4) COMP VALUE ZERO. CICS1 004190 05 DFOrdDays PIC S9(4) COMP VALUE ZERO. CICS1 004200 03 DateFormddbMMMbyy PIC X(9) VALUE SPACES. CICS1 004210 03 DateFormddbMMMbyyR REDEFINES DateFormddbMMMbyy. CICS1 004220 05 JZ-Day PIC 99. CICS1 004230 05 FILLER PIC X. CICS1 004240 05 SMth PIC XXX. CICS1 004250 05 FILLER PIC X. CICS1 004260 05 Year PIC 99. CICS1 004270******************************************************************CICS1 004280** **CICS1 004290** CICS1C (COMMAREA) **CICS1 004300** **CICS1 004310******************************************************************CICS1 004320* CICS1 004330 01 CICS1C. CICS1 004340 03 JZ-XCTL PIC X VALUE 'N'. CICS1 004350 03 TS1QName PIC X(16) VALUE SPACES. CICS1 004360 03 TS1Current-Record PIC S9(4) COMP VALUE ZERO. CICS1 004370 03 TS1Record-Count PIC S9(4) COMP VALUE ZERO. CICS1 004380 03 TS1Start PIC S9(4) COMP VALUE ZERO. CICS1 004390******************************************************************CICS1 004400** **CICS1 004410** TS1 **CICS1 004420** **CICS1 004430******************************************************************CICS1 004440* CICS1 004450 01 TS1. CICS1 004460 03 Account PIC 999999 VALUE ZERO. CICS1 004470******************************************************************CICS1 004480** **CICS1 004490** JZSMth **CICS1 004500** **CICS1 004510******************************************************************CICS1 004520* CICS1 004530 01 JZSMth. CICS1 004540 03 SMth PIC S9(4) COMP VALUE ZERO. CICS1 004550******************************************************************CICS1 004560** **CICS1 004570** Code Tables **CICS1 004580** **CICS1 004590******************************************************************CICS1 004600* CICS1 004610* Types.Month CICS1 004620 01 JZCodes-Types-Month. CICS1 004630 03 JZValues. CICS1 004640 05 FILLER PIC X(3) VALUE 'Jan'. CICS1 004650 05 FILLER PIC X(3) VALUE 'Feb'. CICS1 004660 05 FILLER PIC X(3) VALUE 'Mar'. CICS1 004670 05 FILLER PIC X(3) VALUE 'Apr'. CICS1 004680 05 FILLER PIC X(3) VALUE 'May'. CICS1 004690 05 FILLER PIC X(3) VALUE 'Jun'. CICS1 004700 05 FILLER PIC X(3) VALUE 'Jul'. CICS1 004710 05 FILLER PIC X(3) VALUE 'Aug'. CICS1 004720 05 FILLER PIC X(3) VALUE 'Sep'. CICS1 004730 05 FILLER PIC X(3) VALUE 'Oct'. CICS1 004740 05 FILLER PIC X(3) VALUE 'Nov'. CICS1 004750 05 FILLER PIC X(3) VALUE 'Dec'. CICS1 004760 03 JZTABLE REDEFINES JZValues. CICS1 004770 05 ITEM-VALUES OCCURS 12 INDEXED BY JZIX-Types-Month. CICS1 004780 07 CODE-VALUE PIC X(3). CICS1 004790 03 FILLER. CICS1 004800 05 SEARCH-FOR PIC S9(4) COMP. CICS1 004810 05 FOUND-VALUE PIC X(3) VALUE '***'. CICS1 004820* CICS1 004830* JZSMth.SMth CICS1 004840 01 JZCodes-JZSMth-SMth. CICS1 004850 03 JZValues. CICS1 004860 05 FILLER PIC X(3) VALUE 'Jan'. CICS1 004870 05 FILLER PIC X(3) VALUE 'Feb'. CICS1 004880 05 FILLER PIC X(3) VALUE 'Mar'. CICS1 004890 05 FILLER PIC X(3) VALUE 'Apr'. CICS1 004900 05 FILLER PIC X(3) VALUE 'May'. CICS1 004910 05 FILLER PIC X(3) VALUE 'Jun'. CICS1 004920 05 FILLER PIC X(3) VALUE 'Jul'. CICS1 004930 05 FILLER PIC X(3) VALUE 'Aug'. CICS1 004940 05 FILLER PIC X(3) VALUE 'Sep'. CICS1 004950 05 FILLER PIC X(3) VALUE 'Oct'. CICS1 004960 05 FILLER PIC X(3) VALUE 'Nov'. CICS1 004970 05 FILLER PIC X(3) VALUE 'Dec'. CICS1 004980 03 JZTABLE REDEFINES JZValues. CICS1 004990 05 ITEM-VALUES OCCURS 12 INDEXED BY JZIX-JZSMth-SMth. CICS1 005000 07 CODE-VALUE PIC X(3). CICS1 005010 03 FILLER. CICS1 005020 05 SEARCH-FOR PIC S9(4) COMP. CICS1 005030 05 FOUND-VALUE PIC X(3) VALUE '***'. CICS1 005040******************************************************************CICS1 005050** **CICS1 005060** Linkage Section: Commarea **CICS1 005070** **CICS1 005080******************************************************************CICS1 005090* CICS1 005100 LINKAGE SECTION. CICS1 005110* CICS1 005120 01 DFHCOMMAREA. CICS1 005130 05 JZ-XCTL PIC X. CICS1 005140 05 TS1QName PIC X(16). CICS1 005150 05 TS1Current-Record PIC S9(4) COMP. CICS1 005160 05 TS1Record-Count PIC S9(4) COMP. CICS1 005170 05 TS1Start PIC S9(4) COMP. CICS1 005180******************************************************************CICS1 005190** **CICS1 005200** Procedure Division. **CICS1 005210** **CICS1 005220******************************************************************CICS1 005230* CICS1 005240 PROCEDURE DIVISION. CICS1 005250 EXEC CICS CICS1 005260 HANDLE ABEND LABEL(JZ-Abend-Exit) RESP(JZ-RESPONSE) CICS1 005270 END-EXEC. CICS1 005280 PERFORM CICS-CheckStatus. CICS1 005290* No message is returned with CLEAR or PA1-3 CICS1 005300 IF EIBAID = DFHCLEAR OR DFHPA1 OR DFHPA2 OR DFHPA3 CICS1 005310 GO TO JZ-Main-Program-Logic CICS1 005320 END-IF. CICS1 005330* Check that there is a message to read CICS1 005340 IF EIBCALEN = 0 CICS1 005350 MOVE LOW-VALUE TO CICS1S CICS1 005360 EXEC CICS CICS1 005370 SEND MAP('CICS1S') FROM(CICS1S) FREEKB ERASE CICS1 005380 RESP(JZ-RESPONSE) CICS1 005390 END-EXEC CICS1 005400 PERFORM CICS-CheckStatus CICS1 005410* Read Input Screen CICS1 005420 Else CICS1 005430 MOVE DFHCOMMAREA TO CICS1C CICS1 005440 IF JZ-XCTL OF CICS1C = 'Y' CICS1 005450* MOVE 'N' TO JZ-XCTL OF CICS1C in JZ-SEND-INSCREEN CICS1 005460 MOVE LOW-VALUES TO CICS1S CICS1 005470* Restore SAVE fields CICS1 005480 PERFORM JZ-SEND-INSCREEN CICS1 005490 END-IF CICS1 005500 EXEC CICS CICS1 005510 RECEIVE MAP('CICS1S') INTO(CICS1S) RESP(JZ-RESPONSE) CICS1 005520 END-EXEC CICS1 005530 PERFORM CICS-CheckStatus CICS1 005540* Clear error flags (in case prior ACCEPT found errors) CICS1 005550 MOVE SPACE TO OUT OF EFLD8 OF CICS1S CICS1 005560 MOVE SPACE TO OUT OF EFLD11 OF CICS1S CICS1 005570 MOVE SPACE TO OUT OF EFLD14 OF CICS1S CICS1 005580 MOVE SPACE TO OUT OF EFLD16 OF CICS1S CICS1 005590 MOVE SPACE TO OUT OF EFLD18 OF CICS1S CICS1 005600 MOVE SPACE TO OUT OF EFLD20 OF CICS1S CICS1 005610 MOVE SPACE TO OUT OF EFLD24 OF CICS1S CICS1 005620 MOVE SPACES TO OUT OF JZ-Error OF CICS1S CICS1 005630 MOVE ZERO TO LTH OF JZ-Error OF CICS1S CICS1 005640 MOVE 'N' TO JZ-Error OF JZ CICS1 005650 PERFORM JZ-SET-AidHelp CICS1 005660 PERFORM JZ-Main-Program-Logic CICS1 005670 END-IF. CICS1 005680* CICS1 005690 JZ-Normal-Exit. CICS1 005700 EXEC CICS CICS1 005710 RETURN TRANSID('TRN1') COMMAREA(CICS1C) RESP(JZ-RESPONSE)CICS1 005720 END-EXEC. CICS1 005730 GOBACK. CICS1 005740* CICS1 005750 JZ-Abend-Exit. CICS1 005760* BR14 does nothing, but is useful for CEDF/CEDX debugging CICS1 005770 EXEC CICS LINK PROGRAM('JZBR14 ') COMMAREA(JZ-Program-Info) CICS1 005780 END-EXEC. CICS1 005790 CALL 'JZABNDC' USING DFHEIBLK DFHCOMMAREA JZ-Program-Info. CICS1 005800* CICS1 005810 JZ-Restart. CICS1 005820 EXEC CICS CICS1 005830 RETURN TRANSID('TRN1') RESP(JZ-RESPONSE) CICS1 005840 END-EXEC. CICS1 005850 GOBACK. CICS1 005860******************************************************************CICS1 005870** **CICS1 005880** Main Program Logic **CICS1 005890** **CICS1 005900******************************************************************CICS1 005910* CICS1 005920 JZ-Main-Program-Logic. CICS1 005930* CICS1 005940* Detect and handle Aid Keys CICS1 005950 EVALUATE EIBAID CICS1 005960 WHEN DFHENTER CICS1 005970 PERFORM JZ-AID-ENTER CICS1 005980 WHEN DFHCLEAR CICS1 005990 PERFORM JZ-AID-CLEAR CICS1 006000 WHEN DFHPF3 CICS1 006010 PERFORM JZ-AID-PF3 CICS1 006020 WHEN DFHPF10 CICS1 006030 PERFORM JZ-AID-PF10 CICS1 006040 WHEN DFHPF11 CICS1 006050 PERFORM JZ-AID-PF11 CICS1 006060 WHEN DFHPF12 CICS1 006070 PERFORM JZ-AID-PF12 CICS1 006080 WHEN OTHER CICS1 006090 PERFORM JZ-AID-OTHER CICS1 006100 END-EVALUATE. CICS1 006110 GO TO JZ-NORMAL-EXIT. CICS1 006120******************************************************************CICS1 006130** **CICS1 006140** Process Default AID keys **CICS1 006150** **CICS1 006160******************************************************************CICS1 006170* CICS1 006180 JZ-AID-CLEAR. CICS1 006190 EXEC CICS CICS1 006200 SEND TEXT FROM(JZ-BLANK) ERASE FREEKB RESP(JZ-RESPONSE) CICS1 006210 END-EXEC. CICS1 006220 PERFORM CICS-CheckStatus. CICS1 006230 GOBACK. CICS1 006240* CICS1 006250 JZ-AID-PF3. CICS1 006260 PERFORM JZ-DeleteAllTS. CICS1 006270 EXEC CICS CICS1 006280 XCTL PROGRAM('CICS1') RESP(JZ-RESPONSE) CICS1 006290 END-EXEC. CICS1 006300 PERFORM CICS-CheckStatus. CICS1 006310* CICS1 006320 JZ-AID-PF10. CICS1 006330 IF TS1Current-Record OF CICS1C > 1 CICS1 006340 SUBTRACT 1 FROM TS1Current-Record OF CICS1C CICS1 006350 PERFORM JZ-SET-AIDHELP CICS1 006360 PERFORM JZ-READ-TS1 CICS1 006370 PERFORM JZ-SEND-INSCREEN CICS1 006380 Else CICS1 006390 MOVE 'PF10 Disabled - outside range of Previous/Next recoCICS1 006400- 'rds' TO OUT OF JZ-Error OF CICS1S CICS1 006410 EXEC CICS CICS1 006420 SEND MAP('CICS1S') FROM(CICS1S) ALARM DATAONLY FREEKBCICS1 006430 RESP(JZ-RESPONSE) CICS1 006440 END-EXEC CICS1 006450 PERFORM CICS-CheckStatus CICS1 006460 GO TO JZ-NORMAL-EXIT CICS1 006470 END-IF. CICS1 006480* CICS1 006490 JZ-AID-PF11. CICS1 006500 IF TS1Current-Record OF CICS1C < TS1Record-Count OF CICS1C CICS1 006510 ADD 1 TO TS1Current-Record OF CICS1C CICS1 006520 PERFORM JZ-SET-AIDHELP CICS1 006530 PERFORM JZ-READ-TS1 CICS1 006540 PERFORM JZ-SEND-INSCREEN CICS1 006550 Else CICS1 006560 MOVE 'PF11 Disabled - outside range of Previous/Next recoCICS1 006570- 'rds' TO OUT OF JZ-Error OF CICS1S CICS1 006580 EXEC CICS CICS1 006590 SEND MAP('CICS1S') FROM(CICS1S) ALARM DATAONLY FREEKBCICS1 006600 RESP(JZ-RESPONSE) CICS1 006610 END-EXEC CICS1 006620 PERFORM CICS-CheckStatus CICS1 006630 GO TO JZ-NORMAL-EXIT CICS1 006640 END-IF. CICS1 006650* CICS1 006660 JZ-AID-PF12. CICS1 006670 PERFORM JZ-DeleteAllTS. CICS1 006680 EXEC CICS CICS1 006690 XCTL PROGRAM('MENU1') RESP(JZ-RESPONSE) CICS1 006700 END-EXEC. CICS1 006710 PERFORM CICS-CheckStatus. CICS1 006720 GOBACK. CICS1 006730* CICS1 006740 JZ-AID-OTHER. CICS1 006750 MOVE 'INVALID FUNCTION KEY' TO OUT OF JZ-Error OF CICS1S. CICS1 006760 EXEC CICS CICS1 006770 SEND MAP('CICS1S') FROM(CICS1S) ALARM DATAONLY FREEKB CICS1 006780 RESP(JZ-RESPONSE) CICS1 006790 END-EXEC. CICS1 006800 PERFORM CICS-CheckStatus. CICS1 006810 GO TO JZ-NORMAL-EXIT. CICS1 006820* CICS1 006830 JZ-AID-ENTER. CICS1 006840******************************************************************CICS1 006850** **CICS1 006860** Normal Processing Logic (ENTER clicked) **CICS1 006870** **CICS1 006880******************************************************************CICS1 006890* ACCEPT (CICS1S.Account OR CICS1S.Name); CICS1 006900 PERFORM JZ-25-ACCEPT. CICS1 006910* GET Custf KEY(CustF.Account OR CustF.Name) TS(1); CICS1 006920 PERFORM JZ-27-GET. CICS1 006930* IF Custf.$Found = false THEN; CICS1 006940 IF CustF-FOUND-FLAG NOT = 'Y' CICS1 006950* CICS1S.Error = 'No Record Found'; CICS1 006960 MOVE 'No Record Found' TO OUT OF JZ-Error OF CICS1S CICS1 006970* END IF; CICS1 006980 END-IF. CICS1 006990* SEND Inscreen; CICS1 007000 PERFORM JZ-35-SEND-Inscreen. CICS1 007010* CICS1 007020 JZ-25-ACCEPT. CICS1 007030* ACCEPT (CICS1S.Account OR CICS1S.Name); CICS1 007040 MOVE 'N' TO JZ-Error OF JZ. CICS1 007050* Validate CICS1S.Account, assign to CustF.Account CICS1 007060 MOVE SPACES TO JZ-CHAR80. CICS1 007070 MOVE 'Account' TO JZ-FNAME. CICS1 007080 IF LTH OF Account OF CICS1S > ZERO CICS1 007090 IF FUNCTION TEST-NUMVAL(INPT OF Account OF CICS1S) = 0 CICS1 007100 COMPUTE Account OF JZ-CustF = FUNCTION NUMVAL(INPT OFCICS1 007110 Account OF CICS1S) CICS1 007120 ELSE CICS1 007130 MOVE 'not numeric' TO JZ-CHAR80 CICS1 007140 END-IF CICS1 007150 ELSE CICS1 007160 MOVE ZERO TO Account OF JZ-CustF CICS1 007170 END-IF. CICS1 007180 IF JZ-CHAR80 NOT = SPACE CICS1 007190 MOVE 'Y' TO JZ-Error OF JZ CICS1 007200 MOVE '*' TO OUT OF EFLD8 OF CICS1S CICS1 007210 MOVE -1 TO LTH OF Account OF CICS1S CICS1 007220 MOVE 80 TO JZ-MLTH CICS1 007230 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF CICS1 007240 CICS1S, JZ-FNAME, JZ-CHAR80, JZ-MLTH CICS1 007250 END-IF. CICS1 007260* CICS1S.Name:Nothing to check, assign to CustF.Name CICS1 007270 IF LTH OF JZ-Name OF CICS1S > ZERO CICS1 007280 MOVE FUNCTION UPPER-CASE(INPT OF JZ-Name OF CICS1S) TO CICS1 007290 INPT OF JZ-Name OF CICS1S CICS1 007300 MOVE INPT OF JZ-Name OF CICS1S TO JZ-Name OF JZ-CustF CICS1 007310* Test that one of the OR-list fields are present CICS1 007320 IF Account OF JZ-CustF = ZERO AND JZ-Name OF JZ-CustF = CICS1 007330 SPACES CICS1 007340 MOVE 'value required' TO JZ-CHAR80 CICS1 007350 MOVE 'Account,Name' TO JZ-FNAME CICS1 007360 END-IF CICS1 007370 END-IF. CICS1 007380 IF JZ-Error OF JZ = 'Y' CICS1 007390* Respond with error messages and exit program CICS1 007400 EXEC CICS CICS1 007410 SEND MAP('CICS1S') FROM(CICS1S) CURSOR ALARM FREEKB CICS1 007420 RESP(JZ-RESPONSE) CICS1 007430 END-EXEC CICS1 007440 PERFORM CICS-CheckStatus CICS1 007450 GO TO JZ-Normal-Exit CICS1 007460 END-IF. CICS1 007470* CICS1 007480 JZ-27-GET. CICS1 007490* GET Custf KEY(CustF.Account OR CustF.Name) TS(1); CICS1 007500 MOVE 'N' TO CUSTF-Get4Update-FLAG. CICS1 007510 IF Account OF JZ-CustF NOT = ZERO CICS1 007520 PERFORM JZ-CustF-ReadBy1ryKey CICS1 007530 PERFORM JZ-27-GETGroup CICS1 007540 MOVE ZERO TO TS1Record-Count OF CICS1C CICS1 007550 MOVE ZERO TO TS1Current-Record OF CICS1C CICS1 007560 PERFORM JZ-SET-AIDHELP CICS1 007570 ELSE CICS1 007580 IF JZ-Name OF JZ-CustF NOT = SPACES CICS1 007590 MOVE LTH OF JZ-Name OF CICS1S TO JZ-KL CICS1 007600 PERFORM JZ-INIT-TS1 CICS1 007610* Browse CUSTF BY Name(1:JZ-KL) to TS1 CICS1 007620 PERFORM JZ-27-BROWSE-Name CICS1 007630 IF TS1Record-Count OF CICS1C > 0 CICS1 007640* Read 1st record CICS1 007650 MOVE 1 TO TS1Current-Record OF CICS1C CICS1 007660 PERFORM JZ-READ-TS1 CICS1 007670 ELSE CICS1 007680 MOVE 'N' TO CUSTF-Found-Flag CICS1 007690 PERFORM CUSTF-Initialize CICS1 007700 MOVE ZERO TO Account OF JZ-CustF CICS1 007710 MOVE CustF-Name OF JZ TO JZ-Name OF JZ-CustF CICS1 007720 PERFORM JZ-27-GETGroup CICS1 007730 END-IF CICS1 007740 PERFORM JZ-SET-AIDHELP CICS1 007750 ELSE CICS1 007760 MOVE DFHRESP(NOTFND) TO JZ-RESPONSE CICS1 007770 END-IF CICS1 007780 END-IF. CICS1 007790* CICS1 007800* Browse CUSTF BY Name(1:JZ-KL) to TS1 CICS1 007810 JZ-27-BROWSE-Name. CICS1 007820 MOVE 'N' TO CUSTF-ENDFILE. CICS1 007830 MOVE 'N' TO CUSTF-FOUND-FLAG. CICS1 007840 MOVE JZ-Name OF JZ-CustF(1:JZ-KL) TO CustF-Name OF JZ. CICS1 007850 IF JZ-KL NOT = 30 CICS1 007860 EXEC CICS CICS1 007870 STARTBR FILE('CUSTF1') RIDFLD(JZ-Name OF JZ-CustF) CICS1 007880 GENERIC KEYLENGTH(JZ-KL) EQUAL RESP(JZ-RESPONSE) CICS1 007890 END-EXEC CICS1 007900 ELSE CICS1 007910 EXEC CICS CICS1 007920 STARTBR FILE('CUSTF1') RIDFLD(JZ-Name OF JZ-CustF) CICS1 007930 RESP(JZ-RESPONSE) CICS1 007940 END-EXEC CICS1 007950 END-IF. CICS1 007960 IF JZ-Response = DFHRESP(NORMAL) OR JZ-Response = CICS1 007970 DFHRESP(DUPKEY) CICS1 007980 PERFORM UNTIL CUSTF-ENDFILE = 'Y' CICS1 007990 IF JZ-KL NOT = 30 CICS1 008000 EXEC CICS CICS1 008010 READNEXT FILE('CUSTF1') INTO(JZ-CustF) CICS1 008020 RIDFLD(JZ-Name OF JZ-CustF) CICS1 008030 KEYLENGTH(JZ-KL) RESP(JZ-RESPONSE) CICS1 008040 END-EXEC CICS1 008050 ELSE CICS1 008060 EXEC CICS CICS1 008070 READNEXT FILE('CUSTF1') INTO(JZ-CustF) CICS1 008080 RIDFLD(JZ-Name OF JZ-CustF) CICS1 008090 RESP(JZ-RESPONSE) CICS1 008100 END-EXEC CICS1 008110 END-IF CICS1 008120* Check that READNEXT hasn't run past end CICS1 008130 IF JZ-RESPONSE = DFHRESP(ENDFILE) OR JZ-Name OF CICS1 008140 JZ-CustF(1:JZ-KL) NOT = CustF-Name OF JZ(1:JZ-KL)CICS1 008150 MOVE 'Y' TO CUSTF-ENDFILE CICS1 008160 END-IF CICS1 008170 IF CUSTF-ENDFILE = 'N' CICS1 008180 MOVE Account OF JZ-CustF TO Account OF TS1 CICS1 008190 EXEC CICS CICS1 008200 WRITEQ TS QNAME(TS1QName OF CICS1C) FROM(TS1)CICS1 008210 MAIN NUMITEMS(TS1Record-Count OF CICS1C)CICS1 008220 RESP(JZ-RESPONSE) CICS1 008230 END-EXEC CICS1 008240 END-IF CICS1 008250 END-PERFORM CICS1 008260 END-IF. CICS1 008270 EXEC CICS CICS1 008280 ENDBR FILE('CUSTF1') RESP(JZ-RESPONSE) CICS1 008290 END-EXEC. CICS1 008300* CICS1 008310 JZ-27-GETGroup. CICS1 008320* END GET CustF; CICS1 008330 CONTINUE. CICS1 008340* CICS1 008350 JZ-35-SEND-Inscreen. CICS1 008360* SEND Inscreen; CICS1 008370 PERFORM JZ-SEND-INSCREEN. CICS1 008380******************************************************************CICS1 008390** **CICS1 008400** CICS Support Routines **CICS1 008410** **CICS1 008420******************************************************************CICS1 008430* CICS1 008440* Assign program data to inscreen and Send it. Normal exit CICS1 008450 JZ-SEND-INSCREEN. CICS1 008460* Assign program data to screen CICS1 008470 MOVE Account OF JZ-CustF TO OUT OF Account OF CICS1S. CICS1 008480 MOVE LOW-VALUE TO ATTR OF Account OF CICS1S. CICS1 008490 MOVE JZ-Name OF JZ-CustF TO OUT OF JZ-Name OF CICS1S. CICS1 008500 MOVE LOW-VALUE TO ATTR OF JZ-Name OF CICS1S. CICS1 008510 MOVE Region OF JZ-CustF TO OUT OF Region OF CICS1S. CICS1 008520 MOVE LOW-VALUE TO ATTR OF Region OF CICS1S. CICS1 008530 MOVE District OF JZ-CustF TO OUT OF District OF CICS1S. CICS1 008540 MOVE LOW-VALUE TO ATTR OF District OF CICS1S. CICS1 008550 MOVE SalesThisMonth OF JZ-CustF TO OUT OF SalesThisMonth OF CICS1 008560 CICS1S. CICS1 008570 MOVE LOW-VALUE TO ATTR OF SalesThisMonth OF CICS1S. CICS1 008580 MOVE SalesYTD OF JZ-CustF TO OUT OF SalesYTD OF CICS1S. CICS1 008590 MOVE LOW-VALUE TO ATTR OF SalesYTD OF CICS1S. CICS1 008600 MOVE ZERO TO JZ-TinyNbr. CICS1 008610 MOVE Billingcycle OF JZ-CustF TO JZ-Tiny. CICS1 008620 MOVE JZ-TinyNbr TO OUT OF Billingcycle OF CICS1S. CICS1 008630 MOVE ZERO TO JZ-TinyNbr. CICS1 008640 MOVE Billingcycle OF JZ-CustF TO JZ-Tiny. CICS1 008650 MOVE JZ-TinyNbr TO SEARCH-FOR OF JZCodes-Types-Month. CICS1 008660 PERFORM JZCvt-Types-Month. CICS1 008670 MOVE FOUND-VALUE OF JZCodes-Types-Month TO OUT OF EFLD22 OF CICS1 008680 CICS1S. CICS1 008690 MOVE LOW-VALUE TO ATTR OF Billingcycle OF CICS1S. CICS1 008700 MOVE DateCommenced OF JZ-CustF TO DateFormPic OF JZ. CICS1 008710 PERFORM JZDateFormddbMMMbyy. CICS1 008720 MOVE DateFormddbMMMbyy TO OUT OF DateCommenced OF CICS1S. CICS1 008730 MOVE LOW-VALUE TO ATTR OF DateCommenced OF CICS1S. CICS1 008740* Now send screen CICS1 008750 IF JZ-XCTL OF CICS1C = 'Y' CICS1 008760 MOVE 'N' TO JZ-XCTL OF CICS1C CICS1 008770 EXEC CICS CICS1 008780 SEND MAP('CICS1S') FROM(CICS1S) FREEKB ERASE CICS1 008790 RESP(JZ-RESPONSE) CICS1 008800 END-EXEC CICS1 008810 PERFORM CICS-CheckStatus CICS1 008820 ELSE CICS1 008830 EXEC CICS CICS1 008840 SEND MAP('CICS1S') FROM(CICS1S) FREEKB DATAONLY CICS1 008850 RESP(JZ-RESPONSE) CICS1 008860 END-EXEC CICS1 008870 PERFORM CICS-CheckStatus CICS1 008880 END-IF. CICS1 008890 GO TO JZ-Normal-Exit. CICS1 008900* CICS1 008910 JZ-SET-AidHelp. CICS1 008920 MOVE 'F3=Return,' TO OUT OF JZAidHelp OF CICS1S. CICS1 008930 MOVE 11 TO JZ-AL. CICS1 008940 IF TS1Record-Count OF CICS1C > 1 CICS1 008950 CALL 'JZNOFM' USING DFHEIBLK DFHCOMMAREA CICS1 008960 TS1Current-Record OF CICS1C, TS1Record-Count OF CICS1 008970 CICS1C, JZ-CHAR80, JZ-NOFML CICS1 008980 IF JZ-NOFML > 0 CICS1 008990 MOVE JZ-CHAR80 TO OUT OF JZAidHelp OF CICS1 009000 CICS1S(JZ-AL:JZ-NOFML) CICS1 009010 ADD JZ-NOFML TO JZ-AL CICS1 009020 END-IF CICS1 009030 END-IF. CICS1 009040 IF TS1Current-Record OF CICS1C > 1 CICS1 009050 MOVE 'F10=Previous,' TO OUT OF JZAidHelp OF CICS1S(JZ-AL:14)CICS1 009060 ADD 14 TO JZ-AL CICS1 009070 END-IF. CICS1 009080 IF TS1Current-Record OF CICS1C < TS1Record-Count OF CICS1C CICS1 009090 COMPUTE JZ-MLTH = JZ-AL + 9 CICS1 009100 IF JZ-MLTH > 77 CICS1 009110 COMPUTE JZ-ALIM = 77 - JZ-AL CICS1 009120 ELSE CICS1 009130 MOVE 9 TO JZ-ALIM CICS1 009140 END-IF CICS1 009150 MOVE 'F11=Next,' TO OUT OF JZAidHelp OF CICS1S(JZ-AL:9) CICS1 009160 ADD JZ-ALIM TO JZ-AL CICS1 009170 END-IF. CICS1 009180 COMPUTE JZ-MLTH = JZ-AL + 8. CICS1 009190 IF JZ-MLTH > 77 CICS1 009200 COMPUTE JZ-ALIM = 77 - JZ-AL CICS1 009210 ELSE CICS1 009220 MOVE 8 TO JZ-ALIM CICS1 009230 END-IF. CICS1 009240 IF JZ-ALIM > 0 CICS1 009250 MOVE 'F12=Exit' TO OUT OF JZAidHelp OF CICS1S(JZ-AL:JZ-ALIM)CICS1 009260 ADD JZ-ALIM TO JZ-AL CICS1 009270 END-IF. CICS1 009280* CICS1 009290* Clean up on Exit and Return CICS1 009300 JZ-DeleteAllTS. CICS1 009310 EXEC CICS CICS1 009320 DELETEQ TS QNAME(TS1QName OF CICS1C) RESP(JZ-RESPONSE) CICS1 009330 END-EXEC. CICS1 009340******************************************************************CICS1 009350** **CICS1 009360** Code Conversion Routines **CICS1 009370** **CICS1 009380******************************************************************CICS1 009390* CICS1 009400* Convert Types-Month code to value CICS1 009410 JZCvt-Types-Month. CICS1 009420* Input: SEARCH-FOR OF JZCodes-Types-Month CICS1 009430* Output: FOUND-VALUE OF JZCodes-Types-Month CICS1 009440* If Invalid, FOUND-VALUE will be set to '****', CICS1 009450* field JZ-CHAR80 will contain an error message CICS1 009460 SET JZIX-Types-Month TO SEARCH-FOR OF JZCodes-Types-Month. CICS1 009470 IF JZIX-Types-Month < 1 OR JZIX-Types-Month > 12 CICS1 009480 MOVE 'Outside Code Range' TO JZ-CHAR80 CICS1 009490 MOVE '***' TO FOUND-VALUE OF JZCodes-Types-Month CICS1 009500 ELSE CICS1 009510 MOVE CODE-Value OF JZCodes-Types-Month(JZIX-Types-Month) CICS1 009520 TO FOUND-VALUE OF JZCodes-Types-Month CICS1 009530 END-IF. CICS1 009540* CICS1 009550* Convert JZSMth-SMth code to value CICS1 009560 JZCvt-JZSMth-SMth. CICS1 009570* Input: SEARCH-FOR OF JZCodes-JZSMth-SMth CICS1 009580* Output: FOUND-VALUE OF JZCodes-JZSMth-SMth CICS1 009590* If Invalid, FOUND-VALUE will be set to '****', CICS1 009600* field JZ-CHAR80 will contain an error message CICS1 009610 SET JZIX-JZSMth-SMth TO SEARCH-FOR OF JZCodes-JZSMth-SMth. CICS1 009620 IF JZIX-JZSMth-SMth < 1 OR JZIX-JZSMth-SMth > 12 CICS1 009630 MOVE 'Outside Code Range' TO JZ-CHAR80 CICS1 009640 MOVE '***' TO FOUND-VALUE OF JZCodes-JZSMth-SMth CICS1 009650 ELSE CICS1 009660 MOVE CODE-Value OF JZCodes-JZSMth-SMth(JZIX-JZSMth-SMth) CICS1 009670 TO FOUND-VALUE OF JZCodes-JZSMth-SMth CICS1 009680 END-IF. CICS1 009690******************************************************************CICS1 009700** **CICS1 009710** Sundry Routines **CICS1 009720** **CICS1 009730******************************************************************CICS1 009740* CICS1 009750 CICS-CheckStatus. CICS1 009760 EVALUATE JZ-Response CICS1 009770 WHEN DFHRESP(NORMAL) CICS1 009780 WHEN DFHRESP(DUPKEY) CICS1 009790 CONTINUE CICS1 009800 WHEN OTHER CICS1 009810 GO TO JZ-Abend-Exit CICS1 009820 END-EVALUATE. CICS1 009830* CICS1 009840* Date Format dd MMM yy CICS1 009850 JZDateFormddbMMMbyy. CICS1 009860 MOVE DateFormDay OF JZ TO JZ-DAY OF DateFormddbMMMbyyR OF JZ.CICS1 009870 MOVE DateFormMth OF JZ TO SMth OF JZSMth. CICS1 009880 MOVE SMth OF JZSMth TO SEARCH-FOR OF JZCodes-JZSMth-SMth. CICS1 009890 PERFORM JZCvt-JZSMth-SMth. CICS1 009900 MOVE FOUND-VALUE OF JZCodes-JZSMth-SMth TO SMth OF CICS1 009910 DateFormddbMMMbyyR OF JZ. CICS1 009920 MOVE DateFormYear OF JZ TO Year OF DateFormddbMMMbyyR OF JZ. CICS1 009930* CICS1 009940 JZ-CUSTF-ReadBy1ryKey. CICS1 009950 IF CUSTF-Get4Update CICS1 009960 EXEC CICS CICS1 009970 READ FILE('CUSTF') INTO(JZ-CustF) UPDATE CICS1 009980 RIDFLD(Account OF JZ-CustF) RESP(JZ-RESPONSE) CICS1 009990 END-EXEC CICS1 010000 ELSE CICS1 010010 EXEC CICS CICS1 010020 READ FILE('CUSTF') INTO(JZ-CustF) RIDFLD(Account OF CICS1 010030 JZ-CustF) RESP(JZ-RESPONSE) CICS1 010040 END-EXEC CICS1 010050 END-IF. CICS1 010060 EVALUATE JZ-Response CICS1 010070 WHEN DFHRESP(NORMAL) CICS1 010080 WHEN DFHRESP(DUPKEY) CICS1 010090 MOVE 'Y' TO CustF-Found-Flag CICS1 010100 WHEN DFHRESP(NOTFND) CICS1 010110 MOVE 'N' TO CustF-Found-Flag CICS1 010120 PERFORM CustF-Initialize CICS1 010130 WHEN OTHER CICS1 010140 GO TO JZ-Abend-Exit CICS1 010150 END-EVALUATE. CICS1 010160* CICS1 010170 CustF-Initialize. CICS1 010180* Initialize non-key fields CICS1 010190 Move ZERO TO Region OF JZ-CustF. CICS1 010200 Move ZERO TO District OF JZ-CustF. CICS1 010210 Move SPACES TO JZ-Name OF JZ-CustF. CICS1 010220 Move ZERO TO SalesThisMonth OF JZ-CustF. CICS1 010230 Move ZERO TO SalesYTD OF JZ-CustF. CICS1 010240 Move LOW-VALUE TO Billingcycle OF JZ-CustF. CICS1 010250 Move ZERO TO DateCommenced OF JZ-CustF. CICS1 010260* CICS1 010270 JZ-READ-TS1. CICS1 010280* Read TS1 with key from nth item in TS CICS1 010290* IF condition should always be true CICS1 010300 IF TS1Current-Record OF CICS1C >= 1 AND TS1Current-Record OF CICS1 010310 CICS1C <= TS1Record-Count OF CICS1C CICS1 010320 EXEC CICS CICS1 010330 READQ TS QNAME(TS1QName OF CICS1C) INTO(Account OF CICS1 010340 JZ-CustF) ITEM(TS1Current-Record OF CICS1C) CICS1 010350 RESP(JZ-RESPONSE) CICS1 010360 END-EXEC CICS1 010370 PERFORM CICS-CheckStatus CICS1 010380 PERFORM JZ-CustF-ReadBy1ryKey CICS1 010390 PERFORM JZ-27-GETGroup CICS1 010400 END-IF. CICS1 010410* CICS1 010420 JZ-INIT-TS1. CICS1 010430* Set unique name for TS Queue CICS1 010440 MOVE EIBTRMID TO TS1QName OF CICS1C(1:4). CICS1 010450 MOVE 'CICS1' TO TS1QName OF CICS1C(5:7). CICS1 010460 MOVE 'TS1' TO TS1QName OF CICS1C(12:5). CICS1 010470* Read relevant record keys into TS (Temporary Storage) CICS1 010480* Initialize TS and its control fields CICS1 010490 MOVE ZERO TO TS1Record-Count OF CICS1C. CICS1 010500 MOVE ZERO TO TS1Current-Record OF CICS1C. CICS1 010510 EXEC CICS CICS1 010520 DELETEQ TS QNAME(TS1QName OF CICS1C) RESP(JZ-RESPONSE) CICS1 010530 END-EXEC. CICS1