000010 IDENTIFICATION DIVISION. 000020 PROGRAM-ID. CICS2. 000030 AUTHOR. IBMUSER (Using Jazz from Visual Studio) 000040 DATE-WRITTEN. 18/04/2018 4:05:30 p.m. 000050 ENVIRONMENT DIVISION. 000060*# Last Updated by IBMUSER at 18/04/2018 4:05:30 p.m. 000070* PROGRAM CICS2 CICS INSCREEN(CICS2S) TRANSID(TRN2) 000080* COMMAREA(CICS2C) EXIT(menu1); 000090*ACCEPT (CICS2S.Function); 000100*#562 I CICS2S.Error used as message field 000110*CASE (CICS2C.Function); 000120* WHEN (Enquiry); 000130* ACCEPT (CICS2S.Account OR CICS2S.Name); 000140* #562 I CICS2S.Error used as message field 000150* DEFINE TS1 TS DATA( 000160* Account LIKE CustF.Account); 000170* GET Custf KEY(CustF.Account OR CustF.Name) SAVECOPY 000180* CICS2C.SAVE TS(1); 000190* #373 I GET statement returns one record at a time 000200* for Name 000210* END GET Custf RESETFUNCTION; 000220* WHEN (Update); 000230* GET Custf WHERE(CustF.Account=CICS2C.SAVE.Account) 000240* REWRITE CHECKCOPY(CICS2C.SAVE); 000250* COPY JZSMth; 000260* COPY JZMDays; 000270* ACCEPT 000280* (CICS2S.Region,CICS2S.District,CICS2S.Name,CICS2 000290* S.SalesThisMonth,CICS2S.SalesYTD,CICS2S.Billingc 000300* ycle,CICS2S.DateCommenced); 000310* #562 I CICS2S.Error used as message field 000320* END GET Custf REWRITE RESETFUNCTION; 000330* WHEN (Add); 000340* CustF.Account = CustF.$LastKey + 1; [Will need to be 000350* changed if key is not a number 000360* #361 E Assignment to a key field 000370* GET Custf KEY(CustF.Account) CREATE; 000380* ACCEPT 000390* (CICS2S.Region,CICS2S.District,CICS2S.Name,CICS2 000400* S.SalesThisMonth,CICS2S.SalesYTD,CICS2S.Billingc 000410* ycle,CICS2S.DateCommenced) SETMDT; 000420* #562 I CICS2S.Error used as message field 000430* END GET Custf CREATE RESETFUNCTION; 000440* WHEN (Delete); 000450* DELETE Custf WHERE(CustF.Account=CICS2C.SAVE.Account) 000460* CHECKCOPY(CICS2C.SAVE) RESETFUNCTION; 000470*END CASE; 000480*SEND Inscreen; 000490****************************************************************** 000500** ** 000510** Data Division ** 000520** ** 000530****************************************************************** 000540 DATA DIVISION. 000550****************************************************************** 000560** ** 000570** Working Storage Section: General Program Data ** 000580** ** 000590****************************************************************** 000600* 000610 WORKING-STORAGE SECTION. 000620****************************************************************** 000630** ** 000640** Screen Areas ** 000650** ** 000660****************************************************************** 000670* 000680 COPY DFHAID. 000690* 000700 01 CICS2S. 000710 03 FILLER PIC X(12). 000720* SpecialConstant VALUE 'CICS2S' 000730 03 SCNST1. 000740 05 LTH PIC S9(4) COMP. 000750 05 ATTR PIC X. 000760 05 COLR PIC X. 000770 05 HLIT PIC X. 000780 05 FILLER PIC X(6). 000790* Constant VALUE 'UPDATE CustF' 000800 03 CNST5. 000810 05 LTH PIC S9(4) COMP. 000820 05 ATTR PIC X. 000830 05 COLR PIC X. 000840 05 HLIT PIC X. 000850 05 FILLER PIC X(12). 000860* SpecialConstant VALUE 'TRN2' 000870 03 SCNST4. 000880 05 LTH PIC S9(4) COMP. 000890 05 ATTR PIC X. 000900 05 COLR PIC X. 000910 05 HLIT PIC X. 000920 05 FILLER PIC X(4). 000930* Constant VALUE 'Enter =>' 000940 03 CNST6. 000950 05 LTH PIC S9(4) COMP. 000960 05 ATTR PIC X. 000970 05 COLR PIC X. 000980 05 HLIT PIC X. 000990 05 FILLER PIC X(8). 001000* Constant VALUE 'Account Number.' 001010 03 CNST7. 001020 05 LTH PIC S9(4) COMP. 001030 05 ATTR PIC X. 001040 05 COLR PIC X. 001050 05 HLIT PIC X. 001060 05 FILLER PIC X(15). 001070* Field ='CustF.Account' VALUE '999999' 001080 03 Account. 001090 05 LTH PIC S9(4) COMP. 001100 05 ATTR PIC X. 001110 05 COLR PIC X. 001120 05 HLIT PIC X. 001130 05 INPT PIC X(6). 001140 05 OUT REDEFINES INPT PIC 999999. 001150* ErrorFlag VALUE '*' 001160 03 EFLD8. 001170 05 LTH PIC S9(4) COMP. 001180 05 ATTR PIC X. 001190 05 COLR PIC X. 001200 05 HLIT PIC X. 001210 05 OUT PIC X(1). 001220* Constant VALUE 'OR =>' 001230 03 CNST9. 001240 05 LTH PIC S9(4) COMP. 001250 05 ATTR PIC X. 001260 05 COLR PIC X. 001270 05 HLIT PIC X. 001280 05 FILLER PIC X(5). 001290* Constant VALUE 'Name.' 001300 03 CNST10. 001310 05 LTH PIC S9(4) COMP. 001320 05 ATTR PIC X. 001330 05 COLR PIC X. 001340 05 HLIT PIC X. 001350 05 FILLER PIC X(5). 001360* Field ='CustF.Name' VALUE 'X(30)_________________________' 001370 03 JZ-Name. 001380 05 LTH PIC S9(4) COMP. 001390 05 ATTR PIC X. 001400 05 COLR PIC X. 001410 05 HLIT PIC X. 001420 05 INPT PIC X(30). 001430 05 OUT REDEFINES INPT PIC X(30). 001440* ErrorFlag VALUE '*' 001450 03 EFLD11. 001460 05 LTH PIC S9(4) COMP. 001470 05 ATTR PIC X. 001480 05 COLR PIC X. 001490 05 HLIT PIC X. 001500 05 OUT PIC X(1). 001510* Constant VALUE 'and' 001520 03 CNST12. 001530 05 LTH PIC S9(4) COMP. 001540 05 ATTR PIC X. 001550 05 COLR PIC X. 001560 05 HLIT PIC X. 001570 05 FILLER PIC X(3). 001580* Field ='CICS2C.Function' VALUE 'X' 001590 03 JZ-Function. 001600 05 LTH PIC S9(4) COMP. 001610 05 ATTR PIC X. 001620 05 COLR PIC X. 001630 05 HLIT PIC X. 001640 05 INPT PIC X(1). 001650 05 OUT REDEFINES INPT PIC X. 001660* ErrorFlag VALUE '*******' 001670 03 EFLD13. 001680 05 LTH PIC S9(4) COMP. 001690 05 ATTR PIC X. 001700 05 COLR PIC X. 001710 05 HLIT PIC X. 001720 05 OUT PIC X(7). 001730* Constant VALUE 'E, U, A, or D' 001740 03 CNST14. 001750 05 LTH PIC S9(4) COMP. 001760 05 ATTR PIC X. 001770 05 COLR PIC X. 001780 05 HLIT PIC X. 001790 05 FILLER PIC X(13). 001800* Constant VALUE 'and press Enter' 001810 03 CNST15. 001820 05 LTH PIC S9(4) COMP. 001830 05 ATTR PIC X. 001840 05 COLR PIC X. 001850 05 HLIT PIC X. 001860 05 FILLER PIC X(15). 001870* Constant VALUE 'Region.' 001880 03 CNST16. 001890 05 LTH PIC S9(4) COMP. 001900 05 ATTR PIC X. 001910 05 COLR PIC X. 001920 05 HLIT PIC X. 001930 05 FILLER PIC X(7). 001940* Field ='CustF.Region' VALUE '---9' 001950 03 Region. 001960 05 LTH PIC S9(4) COMP. 001970 05 ATTR PIC X. 001980 05 COLR PIC X. 001990 05 HLIT PIC X. 002000 05 INPT PIC X(4). 002010 05 OUT REDEFINES INPT PIC ---9. 002020* ErrorFlag VALUE '*' 002030 03 EFLD17. 002040 05 LTH PIC S9(4) COMP. 002050 05 ATTR PIC X. 002060 05 COLR PIC X. 002070 05 HLIT PIC X. 002080 05 OUT PIC X(1). 002090* Constant VALUE 'District.' 002100 03 CNST18. 002110 05 LTH PIC S9(4) COMP. 002120 05 ATTR PIC X. 002130 05 COLR PIC X. 002140 05 HLIT PIC X. 002150 05 FILLER PIC X(9). 002160* Field ='CustF.District' VALUE '---9' 002170 03 District. 002180 05 LTH PIC S9(4) COMP. 002190 05 ATTR PIC X. 002200 05 COLR PIC X. 002210 05 HLIT PIC X. 002220 05 INPT PIC X(4). 002230 05 OUT REDEFINES INPT PIC ---9. 002240* ErrorFlag VALUE '*' 002250 03 EFLD19. 002260 05 LTH PIC S9(4) COMP. 002270 05 ATTR PIC X. 002280 05 COLR PIC X. 002290 05 HLIT PIC X. 002300 05 OUT PIC X(1). 002310* Constant VALUE 'SalesThisMonth.' 002320 03 CNST20. 002330 05 LTH PIC S9(4) COMP. 002340 05 ATTR PIC X. 002350 05 COLR PIC X. 002360 05 HLIT PIC X. 002370 05 FILLER PIC X(15). 002380* Field ='CustF.SalesThisMonth' VALUE '$$$,$$9.99CR' 002390 03 SalesThisMonth. 002400 05 LTH PIC S9(4) COMP. 002410 05 ATTR PIC X. 002420 05 COLR PIC X. 002430 05 HLIT PIC X. 002440 05 INPT PIC X(12). 002450 05 OUT REDEFINES INPT PIC $$$,$$9.99CR. 002460* ErrorFlag VALUE '*' 002470 03 EFLD21. 002480 05 LTH PIC S9(4) COMP. 002490 05 ATTR PIC X. 002500 05 COLR PIC X. 002510 05 HLIT PIC X. 002520 05 OUT PIC X(1). 002530* Constant VALUE 'SalesYTD.' 002540 03 CNST22. 002550 05 LTH PIC S9(4) COMP. 002560 05 ATTR PIC X. 002570 05 COLR PIC X. 002580 05 HLIT PIC X. 002590 05 FILLER PIC X(9). 002600* Field ='CustF.SalesYTD' VALUE '$$$,$$9.99CR' 002610 03 SalesYTD. 002620 05 LTH PIC S9(4) COMP. 002630 05 ATTR PIC X. 002640 05 COLR PIC X. 002650 05 HLIT PIC X. 002660 05 INPT PIC X(12). 002670 05 OUT REDEFINES INPT PIC $$$,$$9.99CR. 002680* ErrorFlag VALUE '*' 002690 03 EFLD23. 002700 05 LTH PIC S9(4) COMP. 002710 05 ATTR PIC X. 002720 05 COLR PIC X. 002730 05 HLIT PIC X. 002740 05 OUT PIC X(1). 002750* Constant VALUE 'Billingcycle.' 002760 03 CNST24. 002770 05 LTH PIC S9(4) COMP. 002780 05 ATTR PIC X. 002790 05 COLR PIC X. 002800 05 HLIT PIC X. 002810 05 FILLER PIC X(13). 002820* Field ='CustF.Billingcycle' VALUE '99' 002830 03 Billingcycle. 002840 05 LTH PIC S9(4) COMP. 002850 05 ATTR PIC X. 002860 05 COLR PIC X. 002870 05 HLIT PIC X. 002880 05 INPT PIC X(2). 002890 05 OUT REDEFINES INPT PIC 99. 002900* ErrorFlag VALUE '*********' 002910 03 EFLD25. 002920 05 LTH PIC S9(4) COMP. 002930 05 ATTR PIC X. 002940 05 COLR PIC X. 002950 05 HLIT PIC X. 002960 05 OUT PIC X(9). 002970* Constant VALUE 'DateCommenced.' 002980 03 CNST26. 002990 05 LTH PIC S9(4) COMP. 003000 05 ATTR PIC X. 003010 05 COLR PIC X. 003020 05 HLIT PIC X. 003030 05 FILLER PIC X(14). 003040* Field ='CustF.DateCommenced' VALUE 'dd MMM yy' 003050 03 DateCommenced. 003060 05 LTH PIC S9(4) COMP. 003070 05 ATTR PIC X. 003080 05 COLR PIC X. 003090 05 HLIT PIC X. 003100 05 INPT PIC X(9). 003110 05 OUT REDEFINES INPT PIC X(9). 003120* ErrorFlag VALUE '*' 003130 03 EFLD27. 003140 05 LTH PIC S9(4) COMP. 003150 05 ATTR PIC X. 003160 05 COLR PIC X. 003170 05 HLIT PIC X. 003180 05 OUT PIC X(1). 003190* ErrorFlag VALUE 003200* '#xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx 003210* xxxxxxxxxxxxxxxxxxxxx' 003220 03 JZ-Error. 003230 05 LTH PIC S9(4) COMP. 003240 05 ATTR PIC X. 003250 05 COLR PIC X. 003260 05 HLIT PIC X. 003270 05 OUT PIC X(80). 003280* OutputField ='' VALUE 'PF Keys. PF3=Return, PF12 = Exit 003290* .' 003300 03 JZAidHelp. 003310 05 LTH PIC S9(4) COMP. 003320 05 ATTR PIC X. 003330 05 COLR PIC X. 003340 05 HLIT PIC X. 003350 05 OUT PIC X(77). 003360 05 BLK REDEFINES OUT PIC X(77). 003370****************************************************************** 003380** ** 003390** VSAM Files ** 003400** ** 003410****************************************************************** 003420* 003430 01 JZ-CustF. 003440 03 Account PIC 999999 VALUE ZERO. 003450 03 Region PIC S9(3) COMP-3 VALUE ZERO. 003460 03 District PIC S9(3) COMP-3 VALUE ZERO. 003470 03 JZ-Name PIC X(30) VALUE SPACES. 003480 03 SalesThisMonth PIC S9(5)V9(2) COMP-3 VALUE ZERO. 003490 03 SalesYTD PIC S9(5)V9(2) COMP-3 VALUE ZERO. 003500 03 Billingcycle PIC X VALUE LOW-VALUE. 003510 03 DateCommenced PIC S9(9) COMP VALUE ZERO. 003520****************************************************************** 003530** ** 003540** General Program Information ** 003550** ** 003560****************************************************************** 003570* 003580* Program ID etc - in case of errors 003590 01 JZ-Program-Info. 003600 03 PROG-ID PIC X(20) VALUE 'PROGRAM CICS2'. 003610 03 AUTH PIC X(40) VALUE 'IBMUSER (Using Jazz, 1.14.2.177)'. 003620 03 DTE-WRITTEN PIC X(24) VALUE '18/04/2018 4:05:30 p.m.'. 003630 03 JZ-Jazz-Stmt PIC X(80) VALUE SPACES. 003640 03 JZ-CICS-Stmt PIC X(80) VALUE SPACES. 003650 03 JZ-Response PIC S9(8) BINARY VALUE 0. 003660 03 JZ-Response2 PIC S9(8) BINARY VALUE 0. 003670 03 JZ-SQLIsUsed PIC X VALUE 'N'. 003680* SQL diagnostics ignored unless JZ-SQLIsUsed = 'Y' 003690 03 JZ-SQL-Stmt PIC X(80) VALUE SPACES. 003700 03 JZ-SQLCA PIC X(80) VALUE SPACES. 003710* 003720* Status Flags and control data 003730 01 JZ-FileControl. 003740 03 SORTWORK-ENDFILE PIC X VALUE 'N'. 003750 03 CustF-ENDFILE PIC X VALUE 'N'. 003760 03 CustF-STATUS PIC S9(8) VALUE 0. 003770 03 CustF-FOUND-FLAG PIC X VALUE 'Y'. 003780 88 CustF-FOUND VALUE 'Y'. 003790 03 CustF-UPDATEPENDING-FLAG PIC X VALUE 'N'. 003800 88 CustF-UPDATEPENDING VALUE 'Y'. 003810 03 CustF-Get4Update-FLAG PIC X VALUE 'N'. 003820 88 CustF-Get4Update VALUE 'Y'. 003830 03 CustF-LastKey PIC 999999 VALUE ZERO. 003840 03 CustF-HighKey PIC XXXXXX VALUE HIGH-VALUES. 003850 03 TS1-ENDFILE PIC X VALUE 'N'. 003860 03 TS1-STATUS PIC S9(8) VALUE 0. 003870 03 TS1-FOUND-FLAG PIC X VALUE 'Y'. 003880 88 TS1-FOUND VALUE 'Y'. 003890 03 TS1-UPDATEPENDING-FLAG PIC X VALUE 'N'. 003900 88 TS1-UPDATEPENDING VALUE 'Y'. 003910 03 TS1-Get4Update-FLAG PIC X VALUE 'N'. 003920 88 TS1-Get4Update VALUE 'Y'. 003930 01 CustF-CheckCopy PIC X(53). 003940* 003950 LOCAL-STORAGE SECTION. 003960****************************************************************** 003970** ** 003980** JZ - Jazz Sundry fields ** 003990** ** 004000****************************************************************** 004010* 004020 01 JZ. 004030 03 JZ-AL PIC S9(4) COMP VALUE ZERO. 004040 03 JZ-ALIM PIC S9(4) COMP VALUE ZERO. 004050 03 JZ-NOFML PIC S9(4) COMP VALUE ZERO. 004060 03 JZ-INDEX PIC S9(4) COMP VALUE ZERO. 004070 03 JZ-INDEX2 PIC S9(4) COMP VALUE ZERO. 004080 03 JZ-IXMth PIC S9(4) COMP VALUE ZERO. 004090 03 IX1 PIC S9(4) COMP VALUE ZERO. 004100 03 IX2 PIC S9(4) COMP VALUE ZERO. 004110 03 IX3 PIC S9(4) COMP VALUE ZERO. 004120 03 IX4 PIC S9(4) COMP VALUE ZERO. 004130 03 IX5 PIC S9(4) COMP VALUE ZERO. 004140 03 IX6 PIC S9(4) COMP VALUE ZERO. 004150 03 IX7 PIC S9(4) COMP VALUE ZERO. 004160 03 JZ-BLANK PIC XXXX VALUE SPACES. 004170 03 JZ-CHAR80 PIC X(80) VALUE SPACES. 004180 03 JZ-FNAME PIC X(30) VALUE SPACES. 004190 03 JZ-KL PIC S9(4) COMP VALUE ZERO. 004200 03 JZ-MLTH PIC S9(4) COMP VALUE ZERO. 004210 03 JZ-INT PIC S9(9) COMP VALUE ZERO. 004220 03 JZ-TRUEFALSE PIC XXXXX VALUE SPACES. 004230 03 JZ-TinyNbr PIC S9(9) COMP VALUE ZERO. 004240 03 JZ-TinyGr REDEFINES JZ-TinyNbr. 004250 05 FILLER PIC XXX. 004260 05 JZ-Tiny PIC X. 004270 03 JZ-Error PIC X VALUE 'N'. 004280 03 JZ-NBR1 PIC 9999 VALUE ZERO. 004290 03 JZ-NBR1X REDEFINES JZ-NBR1 PIC XXXX. 004300 03 JZ-NBR2 PIC 9999 VALUE ZERO. 004310 03 JZ-NBR2X REDEFINES JZ-NBR2 PIC XXXX. 004320 03 JZ-SUBVAL PIC ZZZZZ9 VALUE ZERO. 004330 03 JZ-SUBVALR REDEFINES JZ-SUBVAL PIC X(6). 004340 03 JZ-SUBDIGIT PIC S9(4) COMP VALUE ZERO. 004350 03 JZ-INDEXES OCCURS 7 INDEXED BY JZIX1 PIC X(6) VALUE 004360 SPACES. 004370 03 JZ-INDEXPR PIC X(6) VALUE SPACES. 004380 03 CustF-Name PIC X(30) VALUE SPACES. 004390 03 CustF-Account PIC 999999 VALUE ZERO. 004400 03 IsDateArith PIC X VALUE 'N'. 004410 03 DateFormPic PIC 99999999 VALUE ZERO. 004420 03 DateFormPicR REDEFINES DateFormPic. 004430 05 DateFormCYear PIC 9999. 004440 05 DateFormCYearR REDEFINES DateFormCYear. 004450 07 FILLER PIC 99. 004460 07 DateFormYear PIC 99. 004470 05 DateFormMth PIC 99. 004480 05 DateFormDay PIC 99. 004490 03 JZ-DateDiff. 004500 05 DFYears PIC S9(4) COMP VALUE ZERO. 004510 05 DFMonths PIC S9(4) COMP VALUE ZERO. 004520 05 DFDays PIC S9(4) COMP VALUE ZERO. 004530 03 DateFormddbMMMbyy PIC X(9) VALUE SPACES. 004540 03 DateFormddbMMMbyyR REDEFINES DateFormddbMMMbyy. 004550 05 JZ-Day PIC 99. 004560 05 FILLER PIC X. 004570 05 SMth PIC XXX. 004580 05 FILLER PIC X. 004590 05 Year PIC 99. 004600 03 LeapYear PIC X VALUE 'N'. 004610 03 JulianDay PIC S9(3) COMP-3 VALUE ZERO. 004620 03 WJulianDay PIC XXX VALUE SPACES. 004630****************************************************************** 004640** ** 004650** ATTRIBUTES ** 004660** ** 004670****************************************************************** 004680* 004690 01 ATTRIBUTES. 004700 03 MDT PIC X VALUE X'41'. 004710****************************************************************** 004720** ** 004730** CICS2C (COMMAREA) ** 004740** ** 004750****************************************************************** 004760* 004770 01 CICS2C. 004780 03 JZ-Function PIC X VALUE 'E'. 004790 03 SAVE. 004800 05 Account PIC 999999 VALUE ZERO. 004810 05 Region PIC S9(3) COMP-3 VALUE ZERO. 004820 05 District PIC S9(3) COMP-3 VALUE ZERO. 004830 05 JZ-Name PIC X(30) VALUE SPACES. 004840 05 SalesThisMonth PIC S9(5)V9(2) COMP-3 VALUE ZERO. 004850 05 SalesYTD PIC S9(5)V9(2) COMP-3 VALUE ZERO. 004860 05 Billingcycle PIC X VALUE LOW-VALUE. 004870 05 DateCommenced PIC S9(9) COMP VALUE ZERO. 004880 03 JZ-XCTL PIC X VALUE 'N'. 004890 03 TS1QName PIC X(16) VALUE SPACES. 004900 03 TS1Current-Record PIC S9(4) COMP VALUE ZERO. 004910 03 TS1Record-Count PIC S9(4) COMP VALUE ZERO. 004920 03 TS1Start PIC S9(4) COMP VALUE ZERO. 004930****************************************************************** 004940** ** 004950** TS1 ** 004960** ** 004970****************************************************************** 004980* 004990 01 TS1. 005000 03 Account PIC 999999 VALUE ZERO. 005010****************************************************************** 005020** ** 005030** JZSMth ** 005040** ** 005050****************************************************************** 005060* 005070 01 JZSMth. 005080 03 SMth PIC S9(4) COMP VALUE ZERO. 005090****************************************************************** 005100** ** 005110** JZMDays ** 005120** ** 005130****************************************************************** 005140* 005150 01 JZMDays. 005160 03 MDayG. 005170 05 Jan PIC S9(4) COMP VALUE 31. 005180 05 Feb PIC S9(4) COMP VALUE 28. 005190 05 Mar PIC S9(4) COMP VALUE 31. 005200 05 Apr PIC S9(4) COMP VALUE 30. 005210 05 May PIC S9(4) COMP VALUE 31. 005220 05 Jun PIC S9(4) COMP VALUE 30. 005230 05 Jul PIC S9(4) COMP VALUE 31. 005240 05 Aug PIC S9(4) COMP VALUE 31. 005250 05 Sep PIC S9(4) COMP VALUE 30. 005260 05 Oct PIC S9(4) COMP VALUE 31. 005270 05 Nov PIC S9(4) COMP VALUE 30. 005280 05 Dec PIC S9(4) COMP VALUE 31. 005290 03 MDayR REDEFINES MDayG OCCURS 12 INDEXED BY JZIX2 PIC 005300 S9(4) COMP. 005310 03 CDayG. 005320 05 Jan PIC S9(4) COMP VALUE 31. 005330 05 Feb PIC S9(4) COMP VALUE 59. 005340 05 Mar PIC S9(4) COMP VALUE 90. 005350 05 Apr PIC S9(4) COMP VALUE 120. 005360 05 May PIC S9(4) COMP VALUE 151. 005370 05 Jun PIC S9(4) COMP VALUE 181. 005380 05 Jul PIC S9(4) COMP VALUE 212. 005390 05 Aug PIC S9(4) COMP VALUE 243. 005400 05 Sep PIC S9(4) COMP VALUE 273. 005410 05 Oct PIC S9(4) COMP VALUE 304. 005420 05 Nov PIC S9(4) COMP VALUE 334. 005430 05 Dec PIC S9(4) COMP VALUE 365. 005440 03 CDayR REDEFINES CDayG OCCURS 12 INDEXED BY JZIX3 PIC 005450 S9(4) COMP. 005460****************************************************************** 005470** ** 005480** Code Tables ** 005490** ** 005500****************************************************************** 005510* 005520* Types.Month 005530 01 JZCodes-Types-Month. 005540 03 JZValues. 005550 05 FILLER PIC X(9) VALUE 'January '. 005560 05 FILLER PIC X(9) VALUE 'February '. 005570 05 FILLER PIC X(9) VALUE 'March '. 005580 05 FILLER PIC X(9) VALUE 'April '. 005590 05 FILLER PIC X(9) VALUE 'May '. 005600 05 FILLER PIC X(9) VALUE 'June '. 005610 05 FILLER PIC X(9) VALUE 'July '. 005620 05 FILLER PIC X(9) VALUE 'August '. 005630 05 FILLER PIC X(9) VALUE 'September'. 005640 05 FILLER PIC X(9) VALUE 'October '. 005650 05 FILLER PIC X(9) VALUE 'November '. 005660 05 FILLER PIC X(9) VALUE 'December '. 005670 03 JZTABLE REDEFINES JZValues. 005680 05 ITEM-VALUES OCCURS 12 INDEXED BY JZIX-Types-Month. 005690 07 CODE-VALUE PIC X(9). 005700 03 FILLER. 005710 05 SEARCH-FOR PIC S9(4) COMP. 005720 05 FOUND-VALUE PIC X(9) VALUE '*********'. 005730* 005740* CICS2C.Function 005750 01 JZCodes-CICS2C-Function. 005760 03 JZValues. 005770 05 FILLER PIC X(8) VALUE 'EEnquiry'. 005780 05 FILLER PIC X(8) VALUE 'UUpdate '. 005790 05 FILLER PIC X(8) VALUE 'AAdd '. 005800 05 FILLER PIC X(8) VALUE 'DDelete '. 005810 03 JZTABLE REDEFINES JZValues. 005820 05 ITEM-VALUES OCCURS 4 INDEXED BY JZIX-CICS2C-Function. 005830 07 JZCODE PIC X. 005840 07 CODE-VALUE PIC X(7). 005850 03 FILLER. 005860 05 SEARCH-FOR PIC X. 005870 05 FOUND-VALUE PIC X(7) VALUE '*******'. 005880* 005890* JZSMth.SMth 005900 01 JZCodes-JZSMth-SMth. 005910 03 JZValues. 005920 05 FILLER PIC X(3) VALUE 'Jan'. 005930 05 FILLER PIC X(3) VALUE 'Feb'. 005940 05 FILLER PIC X(3) VALUE 'Mar'. 005950 05 FILLER PIC X(3) VALUE 'Apr'. 005960 05 FILLER PIC X(3) VALUE 'May'. 005970 05 FILLER PIC X(3) VALUE 'Jun'. 005980 05 FILLER PIC X(3) VALUE 'Jul'. 005990 05 FILLER PIC X(3) VALUE 'Aug'. 006000 05 FILLER PIC X(3) VALUE 'Sep'. 006010 05 FILLER PIC X(3) VALUE 'Oct'. 006020 05 FILLER PIC X(3) VALUE 'Nov'. 006030 05 FILLER PIC X(3) VALUE 'Dec'. 006040 03 JZTABLE REDEFINES JZValues. 006050 05 ITEM-VALUES OCCURS 12 INDEXED BY JZIX-JZSMth-SMth. 006060 07 CODE-VALUE PIC X(3). 006070 03 FILLER. 006080 05 SEARCH-FOR PIC S9(4) COMP. 006090 05 FOUND-VALUE PIC X(3) VALUE '***'. 006100****************************************************************** 006110** ** 006120** Linkage Section: Commarea ** 006130** ** 006140****************************************************************** 006150* 006160 LINKAGE SECTION. 006170* 006180 01 DFHCOMMAREA. 006190 05 JZ-Function PIC X. 006200 05 SAVE. 006210 07 Account PIC 999999. 006220 07 Region PIC S9(3) COMP-3. 006230 07 District PIC S9(3) COMP-3. 006240 07 JZ-Name PIC X(30). 006250 07 SalesThisMonth PIC S9(5)V9(2) COMP-3. 006260 07 SalesYTD PIC S9(5)V9(2) COMP-3. 006270 07 Billingcycle PIC X. 006280 07 DateCommenced PIC S9(9) COMP. 006290 05 JZ-XCTL PIC X. 006300 05 TS1QName PIC X(16). 006310 05 TS1Current-Record PIC S9(4) COMP. 006320 05 TS1Record-Count PIC S9(4) COMP. 006330 05 TS1Start PIC S9(4) COMP. 006340****************************************************************** 006350** ** 006360** Procedure Division. ** 006370** ** 006380****************************************************************** 006390* 006400 PROCEDURE DIVISION. 006410 EXEC CICS 006420 HANDLE ABEND LABEL(JZ-Abend-Exit) RESP(JZ-RESPONSE) 006430 END-EXEC. 006440 PERFORM CICS-CheckStatus. 006450* No message is returned with CLEAR or PA1-3 006460 IF EIBAID = DFHCLEAR OR DFHPA1 OR DFHPA2 OR DFHPA3 006470 GO TO JZ-Main-Program-Logic 006480 END-IF. 006490* Check that there is a message to read 006500 IF EIBCALEN = 0 006510 MOVE LOW-VALUE TO CICS2S 006520 MOVE 'E' TO OUT OF JZ-Function OF CICS2S 006530 MOVE '006520 SEND MAP(''CICS2S'') FROM(CICS2S) FREEKB ERA 006540- 'SE' TO JZ-CICS-Stmt 006550 EXEC CICS 006560 SEND MAP('CICS2S') FROM(CICS2S) FREEKB ERASE 006570 RESP(JZ-RESPONSE) 006580 END-EXEC 006590 PERFORM CICS-CheckStatus 006600* Read Input Screen 006610 Else 006620 MOVE DFHCOMMAREA TO CICS2C 006630 IF JZ-XCTL OF CICS2C = 'Y' 006640* MOVE 'N' TO JZ-XCTL OF CICS2C in JZ-SEND-INSCREEN 006650 MOVE LOW-VALUES TO CICS2S 006660* Restore SAVE fields 006670 MOVE SAVE OF CICS2C TO JZ-CustF 006680 PERFORM JZ-SEND-INSCREEN 006690 END-IF 006700 MOVE '006690 RECEIVE MAP(''CICS2S'') INTO(CICS2S)' TO 006710 JZ-CICS-Stmt 006720 EXEC CICS 006730 RECEIVE MAP('CICS2S') INTO(CICS2S) RESP(JZ-RESPONSE) 006740 END-EXEC 006750 PERFORM CICS-CheckStatus 006760* Clear error flags (in case prior ACCEPT found errors) 006770 MOVE SPACE TO OUT OF EFLD8 OF CICS2S 006780 MOVE SPACE TO OUT OF EFLD11 OF CICS2S 006790 MOVE SPACE TO OUT OF EFLD17 OF CICS2S 006800 MOVE SPACE TO OUT OF EFLD19 OF CICS2S 006810 MOVE SPACE TO OUT OF EFLD21 OF CICS2S 006820 MOVE SPACE TO OUT OF EFLD23 OF CICS2S 006830 MOVE SPACE TO OUT OF EFLD27 OF CICS2S 006840 MOVE SPACES TO OUT OF JZ-Error OF CICS2S 006850 MOVE ZERO TO LTH OF JZ-Error OF CICS2S 006860 MOVE 'N' TO JZ-Error OF JZ 006870 PERFORM JZ-SET-AidHelp 006880 PERFORM JZ-Main-Program-Logic 006890 END-IF. 006900* 006910 JZ-Normal-Exit. 006920 IF CustF-UpdatePending-Flag = 'Y' 006930* Update not done - probably because of Accept-detected errors 006940 MOVE '006930 UNLOCK FILE(''CUSTF'')' TO JZ-CICS-Stmt 006950 EXEC CICS 006960 UNLOCK FILE('CUSTF') RESP(JZ-RESPONSE) 006970 END-EXEC 006980 PERFORM CICS-CheckStatus 006990 END-IF. 007000 MOVE '006990 RETURN TRANSID(''TRN2'') COMMAREA(CICS2C)' TO 007010 JZ-CICS-Stmt. 007020 EXEC CICS 007030 RETURN TRANSID('TRN2') COMMAREA(CICS2C) RESP(JZ-RESPONSE) 007040 END-EXEC. 007050 GOBACK. 007060* 007070 JZ-Abend-Exit. 007080* BR14 does nothing, but is useful for CEDF/CEDX debugging 007090 EXEC CICS LINK PROGRAM('JZBR14 ') COMMAREA(JZ-Program-Info) 007100 END-EXEC. 007110 CALL 'JZABNDC' USING DFHEIBLK DFHCOMMAREA JZ-Program-Info. 007120* 007130 JZ-Restart. 007140 EXEC CICS 007150 RETURN TRANSID('TRN2') RESP(JZ-RESPONSE) 007160 END-EXEC. 007170 GOBACK. 007180****************************************************************** 007190** ** 007200** Main Program Logic ** 007210** ** 007220****************************************************************** 007230* 007240 JZ-Main-Program-Logic. 007250* 007260* Detect and handle Aid Keys 007270 EVALUATE EIBAID 007280 WHEN DFHENTER 007290 PERFORM JZ-AID-ENTER 007300 WHEN DFHCLEAR 007310 PERFORM JZ-AID-CLEAR 007320 WHEN DFHPF3 007330 PERFORM JZ-AID-PF3 007340 WHEN DFHPF10 007350 PERFORM JZ-AID-PF10 007360 WHEN DFHPF11 007370 PERFORM JZ-AID-PF11 007380 WHEN DFHPF12 007390 PERFORM JZ-AID-PF12 007400 WHEN OTHER 007410 PERFORM JZ-AID-OTHER 007420 END-EVALUATE. 007430 GO TO JZ-NORMAL-EXIT. 007440****************************************************************** 007450** ** 007460** Process Default AID keys ** 007470** ** 007480****************************************************************** 007490* 007500 JZ-AID-CLEAR. 007510 MOVE '007500 SEND TEXT FROM(JZ-BLANK) ERASE FREEKB' TO 007520 JZ-CICS-Stmt. 007530 EXEC CICS 007540 SEND TEXT FROM(JZ-BLANK) ERASE FREEKB RESP(JZ-RESPONSE) 007550 END-EXEC. 007560 PERFORM CICS-CheckStatus. 007570 GOBACK. 007580* 007590 JZ-AID-PF3. 007600 PERFORM JZ-DeleteAllTS. 007610 MOVE '007600 XCTL PROGRAM(''CICS2'')' TO JZ-CICS-Stmt. 007620 EXEC CICS 007630 XCTL PROGRAM('CICS2') RESP(JZ-RESPONSE) 007640 END-EXEC. 007650 PERFORM CICS-CheckStatus. 007660* 007670 JZ-AID-PF10. 007680 IF TS1Current-Record OF CICS2C > 1 007690 SUBTRACT 1 FROM TS1Current-Record OF CICS2C 007700 PERFORM JZ-SET-AIDHELP 007710 PERFORM JZ-READ-TS1 007720 PERFORM JZ-SEND-INSCREEN 007730 Else 007740 MOVE 'PF10 Disabled - outside range of Previous/Next reco 007750- 'rds' TO OUT OF JZ-Error OF CICS2S 007760 MOVE '007750 SEND MAP(''CICS2S'') FROM(CICS2S) ALARM DATA 007770- 'ONLY FREEKB' TO JZ-CICS-Stmt 007780 EXEC CICS 007790 SEND MAP('CICS2S') FROM(CICS2S) ALARM DATAONLY FREEKB 007800 RESP(JZ-RESPONSE) 007810 END-EXEC 007820 PERFORM CICS-CheckStatus 007830 GO TO JZ-NORMAL-EXIT 007840 END-IF. 007850* 007860 JZ-AID-PF11. 007870 IF TS1Current-Record OF CICS2C < TS1Record-Count OF CICS2C 007880 ADD 1 TO TS1Current-Record OF CICS2C 007890 PERFORM JZ-SET-AIDHELP 007900 PERFORM JZ-READ-TS1 007910 PERFORM JZ-SEND-INSCREEN 007920 Else 007930 MOVE 'PF11 Disabled - outside range of Previous/Next reco 007940- 'rds' TO OUT OF JZ-Error OF CICS2S 007950 MOVE '007940 SEND MAP(''CICS2S'') FROM(CICS2S) ALARM DATA 007960- 'ONLY FREEKB' TO JZ-CICS-Stmt 007970 EXEC CICS 007980 SEND MAP('CICS2S') FROM(CICS2S) ALARM DATAONLY FREEKB 007990 RESP(JZ-RESPONSE) 008000 END-EXEC 008010 PERFORM CICS-CheckStatus 008020 GO TO JZ-NORMAL-EXIT 008030 END-IF. 008040* 008050 JZ-AID-PF12. 008060 PERFORM JZ-DeleteAllTS. 008070 MOVE '008060 XCTL PROGRAM(''MENU1'')' TO JZ-CICS-Stmt. 008080 EXEC CICS 008090 XCTL PROGRAM('MENU1') RESP(JZ-RESPONSE) 008100 END-EXEC. 008110 PERFORM CICS-CheckStatus. 008120 GOBACK. 008130* 008140 JZ-AID-OTHER. 008150 MOVE 'INVALID FUNCTION KEY' TO OUT OF JZ-Error OF CICS2S. 008160 MOVE '008150 SEND MAP(''CICS2S'') FROM(CICS2S) ALARM DATAONLY 008170- ' FREEKB' TO JZ-CICS-Stmt. 008180 EXEC CICS 008190 SEND MAP('CICS2S') FROM(CICS2S) ALARM DATAONLY FREEKB 008200 RESP(JZ-RESPONSE) 008210 END-EXEC. 008220 PERFORM CICS-CheckStatus. 008230 GO TO JZ-NORMAL-EXIT. 008240* 008250 JZ-AID-ENTER. 008260****************************************************************** 008270** ** 008280** Normal Processing Logic (ENTER clicked) ** 008290** ** 008300****************************************************************** 008310* ACCEPT (CICS2S.Function); 008320 PERFORM JZ-22-ACCEPT. 008330* CASE (CICS2C.Function); 008340 EVALUATE JZ-Function OF CICS2C 008350* WHEN (Enquiry); 008360 When 'E' 008370 PERFORM JZ-24-WHEN 008380* WHEN (Update); 008390 When 'U' 008400 PERFORM JZ-29-WHEN 008410* WHEN (Add); 008420 When 'A' 008430 PERFORM JZ-39-WHEN 008440* WHEN (Delete); 008450 When 'D' 008460 PERFORM JZ-44-WHEN 008470 END-EVALUATE. 008480* SEND Inscreen; 008490 PERFORM JZ-47-SEND-Inscreen. 008500* 008510 JZ-22-ACCEPT. 008520* ACCEPT (CICS2S.Function); 008530 MOVE 'N' TO JZ-Error OF JZ. 008540* Validate CICS2S.Function, assign to CICS2C.Function 008550 MOVE SPACES TO JZ-CHAR80. 008560 MOVE 'Function' TO JZ-FNAME. 008570 IF LTH OF JZ-Function OF CICS2S > ZERO 008580 MOVE INPT OF JZ-Function OF CICS2S TO JZ-Function OF CICS2C 008590 END-IF. 008600* Check Code Values 008610 MOVE JZ-Function OF CICS2C TO SEARCH-FOR OF 008620 JZCodes-CICS2C-Function. 008630 PERFORM JZCvt-CICS2C-Function. 008640 MOVE FOUND-VALUE OF JZCodes-CICS2C-Function TO OUT OF EFLD13 008650 OF CICS2S. 008660 IF JZ-CHAR80 NOT = SPACE 008670 MOVE 'Y' TO JZ-Error OF JZ 008680 MOVE '*' TO OUT OF EFLD13 OF CICS2S 008690 MOVE -1 TO LTH OF JZ-Function OF CICS2S 008700 MOVE 80 TO JZ-MLTH 008710 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 008720 CICS2S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 008730 END-IF. 008740 IF JZ-Error OF JZ = 'Y' 008750* Respond with error messages and exit program 008760 MOVE '008750 SEND MAP(''CICS2S'') FROM(CICS2S) CURSOR ALA 008770- 'RM FREEKB' TO JZ-CICS-Stmt 008780 EXEC CICS 008790 SEND MAP('CICS2S') FROM(CICS2S) CURSOR ALARM FREEKB 008800 RESP(JZ-RESPONSE) 008810 END-EXEC 008820 PERFORM CICS-CheckStatus 008830 GO TO JZ-Normal-Exit 008840 END-IF. 008850* 008860* WHEN (Enquiry); 008870 JZ-24-WHEN. 008880* ACCEPT (CICS2S.Account OR CICS2S.Name); 008890 PERFORM JZ-25-ACCEPT. 008900* GET Custf KEY(CustF.Account OR CustF.Name) SAVECOPY 008910* CICS2C.SAVE TS(1); 008920 PERFORM JZ-27-GET. 008930* 008940 JZ-25-ACCEPT. 008950* ACCEPT (CICS2S.Account OR CICS2S.Name); 008960 MOVE 'N' TO JZ-Error OF JZ. 008970* Validate CICS2S.Account, assign to CustF.Account 008980 MOVE SPACES TO JZ-CHAR80. 008990 MOVE 'Account' TO JZ-FNAME. 009000 IF LTH OF Account OF CICS2S > ZERO 009010 IF INPT OF Account OF CICS2S IS NUMERIC 009020 COMPUTE Account OF JZ-CustF = FUNCTION NUMVAL(INPT OF 009030 Account OF CICS2S) 009040 ELSE 009050 MOVE 'not numeric' TO JZ-CHAR80 009060 END-IF 009070 ELSE 009080 MOVE ZERO TO Account OF JZ-CustF 009090 END-IF. 009100 IF JZ-CHAR80 NOT = SPACE 009110 MOVE 'Y' TO JZ-Error OF JZ 009120 MOVE '*' TO OUT OF EFLD8 OF CICS2S 009130 MOVE -1 TO LTH OF Account OF CICS2S 009140 MOVE 80 TO JZ-MLTH 009150 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 009160 CICS2S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 009170 END-IF. 009180* Validate CICS2S.Name, assign to CustF.Name 009190 MOVE SPACES TO JZ-CHAR80. 009200 MOVE 'Name' TO JZ-FNAME. 009210 IF LTH OF JZ-Name OF CICS2S > ZERO 009220 MOVE INPT OF JZ-Name OF CICS2S TO JZ-Name OF JZ-CustF 009230* Test that one of the OR-list fields are present 009240 IF Account OF JZ-CustF = ZERO AND JZ-Name OF JZ-CustF = 009250 SPACES 009260 MOVE 'value required' TO JZ-CHAR80 009270 MOVE 'Account,Name' TO JZ-FNAME 009280 END-IF 009290 END-IF. 009300 IF JZ-CHAR80 NOT = SPACE 009310 MOVE 'Y' TO JZ-Error OF JZ 009320 MOVE '*' TO OUT OF EFLD11 OF CICS2S 009330 MOVE -1 TO LTH OF JZ-Name OF CICS2S 009340 MOVE 80 TO JZ-MLTH 009350 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 009360 CICS2S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 009370 END-IF. 009380 IF JZ-Error OF JZ = 'Y' 009390* Respond with error messages and exit program 009400 MOVE '009390 SEND MAP(''CICS2S'') FROM(CICS2S) CURSOR ALA 009410- 'RM FREEKB' TO JZ-CICS-Stmt 009420 EXEC CICS 009430 SEND MAP('CICS2S') FROM(CICS2S) CURSOR ALARM FREEKB 009440 RESP(JZ-RESPONSE) 009450 END-EXEC 009460 PERFORM CICS-CheckStatus 009470 GO TO JZ-Normal-Exit 009480 END-IF. 009490* 009500 JZ-27-GET. 009510* GET Custf KEY(CustF.Account OR CustF.Name) SAVECOPY 009520* CICS2C.SAVE TS(1); 009530 MOVE 'N' TO CUSTF-Get4Update-FLAG. 009540 IF Account OF JZ-CustF NOT = ZERO 009550 PERFORM JZ-CustF-ReadBy1ryKey 009560 PERFORM JZ-27-GETGroup 009570 MOVE ZERO TO TS1Record-Count OF CICS2C 009580 MOVE ZERO TO TS1Current-Record OF CICS2C 009590 PERFORM JZ-SET-AIDHELP 009600 ELSE 009610 IF JZ-Name OF JZ-CustF NOT = SPACES 009620 MOVE LTH OF JZ-Name OF CICS2S TO JZ-KL 009630* Set unique name for TS Queue 009640 MOVE EIBTRMID TO TS1QName OF CICS2C(1:4) 009650 MOVE 'CICS2' TO TS1QName OF CICS2C(5:7) 009660 MOVE 'TS1' TO TS1QName OF CICS2C(12:5) 009670* Read relevant record keys into TS (Temporary Storage) 009680* Initialize TS and its control fields 009690 MOVE ZERO TO TS1Record-Count OF CICS2C 009700 MOVE ZERO TO TS1Current-Record OF CICS2C 009710 MOVE '009700 DELETEQ TS QNAME(TS1QName OF CICS2C)' TO 009720 JZ-CICS-Stmt 009730 EXEC CICS 009740 DELETEQ TS QNAME(TS1QName OF CICS2C) 009750 RESP(JZ-RESPONSE) 009760 END-EXEC 009770 MOVE 'N' TO CUSTF-ENDFILE 009780 MOVE 'N' TO CUSTF-FOUND-FLAG 009790 MOVE JZ-Name OF JZ-CustF(1:JZ-KL) TO CustF-Name OF JZ 009800 IF JZ-KL NOT = 30 009810 MOVE '009800 STARTBR FILE(''CUSTF1'') RIDFLD(JZ-N 009820- 'ame OF JZ-CustF) GENERIC KEYLENGTH(JZ-KL) EQ 009830- 'UA' TO JZ-CICS-Stmt 009840 EXEC CICS 009850 STARTBR FILE('CUSTF1') RIDFLD(JZ-Name OF 009860 JZ-CustF) GENERIC KEYLENGTH(JZ-KL) EQUAL 009870 RESP(JZ-RESPONSE) 009880 END-EXEC 009890 ELSE 009900 MOVE '009890 STARTBR FILE(''CUSTF1'') RIDFLD(JZ-N 009910- 'ame OF JZ-CustF)' TO JZ-CICS-Stmt 009920 EXEC CICS 009930 STARTBR FILE('CUSTF1') RIDFLD(JZ-Name OF 009940 JZ-CustF) RESP(JZ-RESPONSE) 009950 END-EXEC 009960 END-IF 009970 IF JZ-Response = DFHRESP(NORMAL) OR JZ-Response = 009980 DFHRESP(DUPKEY) 009990 PERFORM UNTIL CUSTF-ENDFILE = 'Y' 010000 IF JZ-KL NOT = 30 010010 MOVE '010000 READNEXT FILE(''CUSTF1'') IN 010020- 'TO(JZ-CustF) RIDFLD(JZ-Name OF JZ-Cu 010030- 'stF) KEYLENGTH(JZ-' TO JZ-CICS-Stmt 010040 EXEC CICS 010050 READNEXT FILE('CUSTF1') 010060 INTO(JZ-CustF) RIDFLD(JZ-Name OF 010070 JZ-CustF) KEYLENGTH(JZ-KL) 010080 RESP(JZ-RESPONSE) 010090 END-EXEC 010100 ELSE 010110 MOVE '010100 READNEXT FILE(''CUSTF1'') IN 010120- 'TO(JZ-CustF) RIDFLD(JZ-Name OF JZ-Cu 010130- 'stF)' TO JZ-CICS-Stmt 010140 EXEC CICS 010150 READNEXT FILE('CUSTF1') 010160 INTO(JZ-CustF) RIDFLD(JZ-Name OF 010170 JZ-CustF) RESP(JZ-RESPONSE) 010180 END-EXEC 010190 END-IF 010200* Check that READNEXT hasn't run past end 010210 IF JZ-RESPONSE = DFHRESP(ENDFILE) OR JZ-Name 010220 OF JZ-CustF(1:JZ-KL) NOT = CustF-Name OF 010230 JZ(1:JZ-KL) 010240 MOVE 'Y' TO CUSTF-ENDFILE 010250 END-IF 010260 IF CUSTF-ENDFILE = 'N' 010270 MOVE Account OF JZ-CustF TO Account OF TS1 010280 MOVE '010270 WRITEQ TS QNAME(TS1QName OF 010290- 'CICS2C) FROM(TS1) MAIN NUMITEMS(TS1R 010300- 'ecord-Count OF C' TO JZ-CICS-Stmt 010310 EXEC CICS 010320 WRITEQ TS QNAME(TS1QName OF CICS2C) 010330 FROM(TS1) MAIN 010340 NUMITEMS(TS1Record-Count OF 010350 CICS2C) RESP(JZ-RESPONSE) 010360 END-EXEC 010370 END-IF 010380 END-PERFORM 010390 MOVE '010380 ENDBR FILE(''CUSTF1'')' TO JZ-CICS-Stmt 010400 EXEC CICS 010410 ENDBR FILE('CUSTF1') RESP(JZ-RESPONSE) 010420 END-EXEC 010430 ELSE 010440 MOVE 'Y' TO CUSTF-ENDFILE 010450 END-IF 010460 IF TS1Record-Count OF CICS2C > 0 010470* Read 1st record 010480 MOVE 1 TO TS1Current-Record OF CICS2C 010490 PERFORM JZ-READ-TS1 010500 ELSE 010510 MOVE 'N' TO CUSTF-Found-Flag 010520 PERFORM CUSTF-Initialize 010530 MOVE ZERO TO Account OF JZ-CustF 010540 MOVE CustF-Name OF JZ TO JZ-Name OF JZ-CustF 010550 PERFORM JZ-27-GETGroup 010560 END-IF 010570 PERFORM JZ-SET-AIDHELP 010580 ELSE 010590 MOVE DFHRESP(NOTFND) TO JZ-RESPONSE 010600 END-IF 010610 END-IF. 010620* 010630 JZ-27-GETGroup. 010640* END GET Custf RESETFUNCTION; 010650* Save copy for later UPDATE CHECKCOPY 010660 MOVE JZ-CustF TO SAVE OF CICS2C. 010670 PERFORM JZ-CustF-ResetFunction. 010680* 010690* WHEN (Update); 010700 JZ-29-WHEN. 010710* GET Custf WHERE(CustF.Account=CICS2C.SAVE.Account) REWRITE 010720* CHECKCOPY(CICS2C.SAVE); 010730 PERFORM JZ-30-GET. 010740* 010750 JZ-30-GET. 010760* GET Custf WHERE(CustF.Account=CICS2C.SAVE.Account) REWRITE 010770* CHECKCOPY(CICS2C.SAVE); 010780 MOVE 'Y' TO CUSTF-Get4Update-FLAG. 010790 MOVE Account OF CICS2C TO Account OF JZ-CustF. 010800 PERFORM JZ-CustF-ReadBy1ryKey. 010810 MOVE 'Y' TO CUSTF-UpdatePending-Flag. 010820* Check against saved copy 010830 IF SAVE OF CICS2C IS NOT EQUAL TO JZ-CustF 010840 MOVE JZ-CustF TO SAVE OF CICS2C 010850 MOVE 'Record has been changed. Sorry, you need to re-appl 010860- 'y the updates' TO OUT OF JZ-Error OF CICS2S 010870 MOVE 'E' TO OUT OF JZ-Function OF CICS2S 010880 MOVE '010870 SEND MAP(''CICS2S'') FROM(CICS2S) CURSOR ALA 010890- 'RM FREEKB' TO JZ-CICS-Stmt 010900 EXEC CICS 010910 SEND MAP('CICS2S') FROM(CICS2S) CURSOR ALARM FREEKB 010920 RESP(JZ-RESPONSE) 010930 END-EXEC 010940 PERFORM CICS-CheckStatus 010950 GO TO JZ-Normal-Exit 010960 END-IF. 010970 IF CustF-FOUND-FLAG = 'N' 010980 MOVE 'UPDATE aborted: record does not exist' TO OUT OF 010990 JZ-Error OF CICS2S 011000 MOVE 'E' TO OUT OF JZ-Function OF CICS2S 011010 MOVE '011000 SEND MAP(''CICS2S'') FROM(CICS2S) CURSOR ALA 011020- 'RM FREEKB' TO JZ-CICS-Stmt 011030 EXEC CICS 011040 SEND MAP('CICS2S') FROM(CICS2S) CURSOR ALARM FREEKB 011050 RESP(JZ-RESPONSE) 011060 END-EXEC 011070 PERFORM CICS-CheckStatus 011080 GO TO JZ-Normal-Exit 011090 END-IF. 011100 PERFORM JZ-30-GETGroup. 011110* 011120 JZ-30-GETGroup. 011130* ACCEPT 011140* (CICS2S.Region,CICS2S.District,CICS2S.Name,CICS2S.SalesThisM 011150* onth,CICS2S.SalesYTD,CICS2S.Billingcycle,CICS2S.DateCommence 011160* d); 011170 PERFORM JZ-37-ACCEPT. 011180* END GET Custf REWRITE RESETFUNCTION; 011190 If CustF-FOUND 011200 PERFORM CustF-Update 011210 END-IF. 011220 PERFORM JZ-CustF-ResetFunction. 011230* 011240 JZ-37-ACCEPT. 011250* ACCEPT 011260* (CICS2S.Region,CICS2S.District,CICS2S.Name,CICS2S.SalesThisM 011270* onth,CICS2S.SalesYTD,CICS2S.Billingcycle,CICS2S.DateCommence 011280* d); 011290 MOVE 'N' TO JZ-Error OF JZ. 011300* Validate CICS2S.Region, assign to CustF.Region 011310 MOVE SPACES TO JZ-CHAR80. 011320 MOVE 'Region' TO JZ-FNAME. 011330 IF LTH OF Region OF CICS2S > ZERO 011340 IF INPT OF Region OF CICS2S IS NUMERIC 011350 COMPUTE Region OF JZ-CustF = FUNCTION NUMVAL(INPT OF 011360 Region OF CICS2S) 011370 ELSE 011380 MOVE 'not numeric' TO JZ-CHAR80 011390 END-IF 011400 END-IF. 011410 IF JZ-CHAR80 NOT = SPACE 011420 MOVE 'Y' TO JZ-Error OF JZ 011430 MOVE '*' TO OUT OF EFLD17 OF CICS2S 011440 MOVE -1 TO LTH OF Region OF CICS2S 011450 MOVE 80 TO JZ-MLTH 011460 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 011470 CICS2S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 011480 END-IF. 011490* Validate CICS2S.District, assign to CustF.District 011500 MOVE SPACES TO JZ-CHAR80. 011510 MOVE 'District' TO JZ-FNAME. 011520 IF LTH OF District OF CICS2S > ZERO 011530 IF INPT OF District OF CICS2S IS NUMERIC 011540 COMPUTE District OF JZ-CustF = FUNCTION NUMVAL(INPT 011550 OF District OF CICS2S) 011560 ELSE 011570 MOVE 'not numeric' TO JZ-CHAR80 011580 END-IF 011590 END-IF. 011600* Check Range 011610 IF JZ-CHAR80 = SPACE 011620 IF District OF JZ-CustF < 1 OR District OF JZ-CustF > 10 011630 MOVE 'outside valid range' TO JZ-CHAR80 011640 END-IF 011650 END-IF. 011660 IF JZ-CHAR80 NOT = SPACE 011670 MOVE 'Y' TO JZ-Error OF JZ 011680 MOVE '*' TO OUT OF EFLD19 OF CICS2S 011690 MOVE -1 TO LTH OF District OF CICS2S 011700 MOVE 80 TO JZ-MLTH 011710 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 011720 CICS2S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 011730 END-IF. 011740* Validate CICS2S.Name, assign to CustF.Name 011750 MOVE SPACES TO JZ-CHAR80. 011760 MOVE 'Name' TO JZ-FNAME. 011770 IF LTH OF JZ-Name OF CICS2S > ZERO 011780 MOVE INPT OF JZ-Name OF CICS2S TO JZ-Name OF JZ-CustF 011790 IF JZ-Name OF JZ-CustF = SPACES 011800 MOVE 'value required' TO JZ-CHAR80 011810 END-IF 011820 END-IF. 011830 IF JZ-CHAR80 NOT = SPACE 011840 MOVE 'Y' TO JZ-Error OF JZ 011850 MOVE '*' TO OUT OF EFLD11 OF CICS2S 011860 MOVE -1 TO LTH OF JZ-Name OF CICS2S 011870 MOVE 80 TO JZ-MLTH 011880 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 011890 CICS2S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 011900 END-IF. 011910* Validate CICS2S.SalesThisMonth, assign to 011920* CustF.SalesThisMonth 011930 MOVE SPACES TO JZ-CHAR80. 011940 MOVE 'SalesThisMonth' TO JZ-FNAME. 011950 IF LTH OF SalesThisMonth OF CICS2S > ZERO 011960 IF INPT OF SalesThisMonth OF CICS2S IS NUMERIC 011970 COMPUTE SalesThisMonth OF JZ-CustF = FUNCTION 011980 NUMVAL(INPT OF SalesThisMonth OF CICS2S) / 100 011990 ELSE 012000 MOVE 'not numeric' TO JZ-CHAR80 012010 END-IF 012020 END-IF. 012030 IF JZ-CHAR80 NOT = SPACE 012040 MOVE 'Y' TO JZ-Error OF JZ 012050 MOVE '*' TO OUT OF EFLD21 OF CICS2S 012060 MOVE -1 TO LTH OF SalesThisMonth OF CICS2S 012070 MOVE 80 TO JZ-MLTH 012080 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 012090 CICS2S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 012100 END-IF. 012110* Validate CICS2S.SalesYTD, assign to CustF.SalesYTD 012120 MOVE SPACES TO JZ-CHAR80. 012130 MOVE 'SalesYTD' TO JZ-FNAME. 012140 IF LTH OF SalesYTD OF CICS2S > ZERO 012150 IF INPT OF SalesYTD OF CICS2S IS NUMERIC 012160 COMPUTE SalesYTD OF JZ-CustF = FUNCTION NUMVAL(INPT 012170 OF SalesYTD OF CICS2S) / 100 012180 ELSE 012190 MOVE 'not numeric' TO JZ-CHAR80 012200 END-IF 012210 END-IF. 012220 IF JZ-CHAR80 NOT = SPACE 012230 MOVE 'Y' TO JZ-Error OF JZ 012240 MOVE '*' TO OUT OF EFLD23 OF CICS2S 012250 MOVE -1 TO LTH OF SalesYTD OF CICS2S 012260 MOVE 80 TO JZ-MLTH 012270 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 012280 CICS2S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 012290 END-IF. 012300* Validate CICS2S.Billingcycle, assign to CustF.Billingcycle 012310 MOVE SPACES TO JZ-CHAR80. 012320 MOVE 'Billingcycle' TO JZ-FNAME. 012330 IF LTH OF Billingcycle OF CICS2S > ZERO 012340 IF INPT OF Billingcycle OF CICS2S IS NUMERIC 012350 COMPUTE JZ-TinyNbr = FUNCTION NUMVAL(INPT OF 012360 Billingcycle OF CICS2S) 012370 MOVE JZ-TINY TO Billingcycle OF JZ-CustF 012380 ELSE 012390 MOVE 'not numeric' TO JZ-CHAR80 012400 END-IF 012410 END-IF. 012420* Check Code Values 012430 IF JZ-CHAR80 = SPACE 012440 MOVE Billingcycle OF JZ-CustF TO JZ-TINY 012450 MOVE JZ-TINYNBR TO SEARCH-FOR OF JZCodes-Types-Month 012460 PERFORM JZCvt-Types-Month 012470 MOVE FOUND-VALUE OF JZCodes-Types-Month TO OUT OF EFLD25 012480 OF CICS2S 012490 END-IF. 012500 IF JZ-CHAR80 NOT = SPACE 012510 MOVE 'Y' TO JZ-Error OF JZ 012520 MOVE '*' TO OUT OF EFLD25 OF CICS2S 012530 MOVE -1 TO LTH OF Billingcycle OF CICS2S 012540 MOVE 80 TO JZ-MLTH 012550 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 012560 CICS2S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 012570 END-IF. 012580* Validate CICS2S.DateCommenced, assign to CustF.DateCommenced 012590 MOVE SPACES TO JZ-CHAR80. 012600 MOVE 'DateCommenced' TO JZ-FNAME. 012610 IF LTH OF DateCommenced OF CICS2S > ZERO 012620* Data type Is3270Field cannot be converted to a DATE 012630 MOVE INPT OF DateCommenced OF CICS2S TO DateCommenced OF 012640 JZ-CustF 012650 END-IF. 012660 IF JZ-CHAR80 NOT = SPACE 012670 MOVE 'Y' TO JZ-Error OF JZ 012680 MOVE '*' TO OUT OF EFLD27 OF CICS2S 012690 MOVE -1 TO LTH OF DateCommenced OF CICS2S 012700 MOVE 80 TO JZ-MLTH 012710 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 012720 CICS2S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 012730 END-IF. 012740 IF JZ-Error OF JZ = 'Y' 012750* Respond with error messages and exit program 012760 MOVE '012750 SEND MAP(''CICS2S'') FROM(CICS2S) CURSOR ALA 012770- 'RM FREEKB' TO JZ-CICS-Stmt 012780 EXEC CICS 012790 SEND MAP('CICS2S') FROM(CICS2S) CURSOR ALARM FREEKB 012800 RESP(JZ-RESPONSE) 012810 END-EXEC 012820 PERFORM CICS-CheckStatus 012830 GO TO JZ-Normal-Exit 012840 END-IF. 012850* 012860* WHEN (Add); 012870 JZ-39-WHEN. 012880* CustF.Account = CustF.$LastKey + 1; [Will need to be changed 012890* if key is not a number 012900 PERFORM CustF-LastKey-SET. 012910 COMPUTE Account OF JZ-CustF = CustF-LastKey + 1 . 012920* GET Custf KEY(CustF.Account) CREATE; 012930 PERFORM JZ-41-GET. 012940* 012950 JZ-41-GET. 012960* GET Custf KEY(CustF.Account) CREATE; 012970 MOVE 'Y' TO CUSTF-Get4Update-FLAG. 012980 PERFORM JZ-CustF-ReadBy1ryKey. 012990 MOVE 'Y' TO CUSTF-UpdatePending-Flag. 013000 IF CustF-FOUND-FLAG = 'Y' 013010 MOVE 'UPDATE aborted: record already exists' TO OUT OF 013020 JZ-Error OF CICS2S 013030 MOVE 'E' TO OUT OF JZ-Function OF CICS2S 013040 MOVE '013030 SEND MAP(''CICS2S'') FROM(CICS2S) CURSOR ALA 013050- 'RM FREEKB' TO JZ-CICS-Stmt 013060 EXEC CICS 013070 SEND MAP('CICS2S') FROM(CICS2S) CURSOR ALARM FREEKB 013080 RESP(JZ-RESPONSE) 013090 END-EXEC 013100 PERFORM CICS-CheckStatus 013110 GO TO JZ-Normal-Exit 013120 END-IF. 013130 PERFORM JZ-41-GETGroup. 013140* 013150 JZ-41-GETGroup. 013160* ACCEPT 013170* (CICS2S.Region,CICS2S.District,CICS2S.Name,CICS2S.SalesThisM 013180* onth,CICS2S.SalesYTD,CICS2S.Billingcycle,CICS2S.DateCommence 013190* d) SETMDT; 013200 PERFORM JZ-42-ACCEPT. 013210* END GET Custf CREATE RESETFUNCTION; 013220 If NOT CustF-FOUND 013230 PERFORM CustF-Update 013240 END-IF. 013250 PERFORM JZ-CustF-ResetFunction. 013260* 013270 JZ-42-ACCEPT. 013280* ACCEPT 013290* (CICS2S.Region,CICS2S.District,CICS2S.Name,CICS2S.SalesThisM 013300* onth,CICS2S.SalesYTD,CICS2S.Billingcycle,CICS2S.DateCommence 013310* d) SETMDT; 013320 MOVE 'N' TO JZ-Error OF JZ. 013330* Validate CICS2S.Region, assign to CustF.Region 013340 MOVE SPACES TO JZ-CHAR80. 013350 MOVE 'Region' TO JZ-FNAME. 013360 IF LTH OF Region OF CICS2S > ZERO 013370 IF INPT OF Region OF CICS2S IS NUMERIC 013380 COMPUTE Region OF JZ-CustF = FUNCTION NUMVAL(INPT OF 013390 Region OF CICS2S) 013400 ELSE 013410 MOVE 'not numeric' TO JZ-CHAR80 013420 END-IF 013430 END-IF. 013440 IF JZ-CHAR80 NOT = SPACE 013450 MOVE 'Y' TO JZ-Error OF JZ 013460 MOVE '*' TO OUT OF EFLD17 OF CICS2S 013470 MOVE -1 TO LTH OF Region OF CICS2S 013480 MOVE 80 TO JZ-MLTH 013490 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 013500 CICS2S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 013510 END-IF. 013520* Validate CICS2S.District, assign to CustF.District 013530 MOVE SPACES TO JZ-CHAR80. 013540 MOVE 'District' TO JZ-FNAME. 013550 IF LTH OF District OF CICS2S > ZERO 013560 IF INPT OF District OF CICS2S IS NUMERIC 013570 COMPUTE District OF JZ-CustF = FUNCTION NUMVAL(INPT 013580 OF District OF CICS2S) 013590 ELSE 013600 MOVE 'not numeric' TO JZ-CHAR80 013610 END-IF 013620 END-IF. 013630* Check Range 013640 IF JZ-CHAR80 = SPACE 013650 IF District OF JZ-CustF < 1 OR District OF JZ-CustF > 10 013660 MOVE 'outside valid range' TO JZ-CHAR80 013670 END-IF 013680 END-IF. 013690 IF JZ-CHAR80 NOT = SPACE 013700 MOVE 'Y' TO JZ-Error OF JZ 013710 MOVE '*' TO OUT OF EFLD19 OF CICS2S 013720 MOVE -1 TO LTH OF District OF CICS2S 013730 MOVE 80 TO JZ-MLTH 013740 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 013750 CICS2S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 013760 END-IF. 013770* Validate CICS2S.Name, assign to CustF.Name 013780 MOVE SPACES TO JZ-CHAR80. 013790 MOVE 'Name' TO JZ-FNAME. 013800 IF LTH OF JZ-Name OF CICS2S > ZERO 013810 MOVE INPT OF JZ-Name OF CICS2S TO JZ-Name OF JZ-CustF 013820 IF JZ-Name OF JZ-CustF = SPACES 013830 MOVE 'value required' TO JZ-CHAR80 013840 END-IF 013850 END-IF. 013860 IF JZ-CHAR80 NOT = SPACE 013870 MOVE 'Y' TO JZ-Error OF JZ 013880 MOVE '*' TO OUT OF EFLD11 OF CICS2S 013890 MOVE -1 TO LTH OF JZ-Name OF CICS2S 013900 MOVE 80 TO JZ-MLTH 013910 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 013920 CICS2S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 013930 END-IF. 013940* Validate CICS2S.SalesThisMonth, assign to 013950* CustF.SalesThisMonth 013960 MOVE SPACES TO JZ-CHAR80. 013970 MOVE 'SalesThisMonth' TO JZ-FNAME. 013980 IF LTH OF SalesThisMonth OF CICS2S > ZERO 013990 IF INPT OF SalesThisMonth OF CICS2S IS NUMERIC 014000 COMPUTE SalesThisMonth OF JZ-CustF = FUNCTION 014010 NUMVAL(INPT OF SalesThisMonth OF CICS2S) / 100 014020 ELSE 014030 MOVE 'not numeric' TO JZ-CHAR80 014040 END-IF 014050 END-IF. 014060 IF JZ-CHAR80 NOT = SPACE 014070 MOVE 'Y' TO JZ-Error OF JZ 014080 MOVE '*' TO OUT OF EFLD21 OF CICS2S 014090 MOVE -1 TO LTH OF SalesThisMonth OF CICS2S 014100 MOVE 80 TO JZ-MLTH 014110 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 014120 CICS2S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 014130 END-IF. 014140* Validate CICS2S.SalesYTD, assign to CustF.SalesYTD 014150 MOVE SPACES TO JZ-CHAR80. 014160 MOVE 'SalesYTD' TO JZ-FNAME. 014170 IF LTH OF SalesYTD OF CICS2S > ZERO 014180 IF INPT OF SalesYTD OF CICS2S IS NUMERIC 014190 COMPUTE SalesYTD OF JZ-CustF = FUNCTION NUMVAL(INPT 014200 OF SalesYTD OF CICS2S) / 100 014210 ELSE 014220 MOVE 'not numeric' TO JZ-CHAR80 014230 END-IF 014240 END-IF. 014250 IF JZ-CHAR80 NOT = SPACE 014260 MOVE 'Y' TO JZ-Error OF JZ 014270 MOVE '*' TO OUT OF EFLD23 OF CICS2S 014280 MOVE -1 TO LTH OF SalesYTD OF CICS2S 014290 MOVE 80 TO JZ-MLTH 014300 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 014310 CICS2S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 014320 END-IF. 014330* Validate CICS2S.Billingcycle, assign to CustF.Billingcycle 014340 MOVE SPACES TO JZ-CHAR80. 014350 MOVE 'Billingcycle' TO JZ-FNAME. 014360 IF LTH OF Billingcycle OF CICS2S > ZERO 014370 IF INPT OF Billingcycle OF CICS2S IS NUMERIC 014380 COMPUTE JZ-TinyNbr = FUNCTION NUMVAL(INPT OF 014390 Billingcycle OF CICS2S) 014400 MOVE JZ-TINY TO Billingcycle OF JZ-CustF 014410 ELSE 014420 MOVE 'not numeric' TO JZ-CHAR80 014430 END-IF 014440 END-IF. 014450* Check Code Values 014460 IF JZ-CHAR80 = SPACE 014470 MOVE Billingcycle OF JZ-CustF TO JZ-TINY 014480 MOVE JZ-TINYNBR TO SEARCH-FOR OF JZCodes-Types-Month 014490 PERFORM JZCvt-Types-Month 014500 MOVE FOUND-VALUE OF JZCodes-Types-Month TO OUT OF EFLD25 014510 OF CICS2S 014520 END-IF. 014530 IF JZ-CHAR80 NOT = SPACE 014540 MOVE 'Y' TO JZ-Error OF JZ 014550 MOVE '*' TO OUT OF EFLD25 OF CICS2S 014560 MOVE -1 TO LTH OF Billingcycle OF CICS2S 014570 MOVE 80 TO JZ-MLTH 014580 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 014590 CICS2S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 014600 END-IF. 014610* Validate CICS2S.DateCommenced, assign to CustF.DateCommenced 014620 MOVE SPACES TO JZ-CHAR80. 014630 MOVE 'DateCommenced' TO JZ-FNAME. 014640 IF LTH OF DateCommenced OF CICS2S > ZERO 014650* Data type Is3270Field cannot be converted to a DATE 014660 MOVE INPT OF DateCommenced OF CICS2S TO DateCommenced OF 014670 JZ-CustF 014680 END-IF. 014690 IF JZ-CHAR80 NOT = SPACE 014700 MOVE 'Y' TO JZ-Error OF JZ 014710 MOVE '*' TO OUT OF EFLD27 OF CICS2S 014720 MOVE -1 TO LTH OF DateCommenced OF CICS2S 014730 MOVE 80 TO JZ-MLTH 014740 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 014750 CICS2S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 014760 END-IF. 014770 IF JZ-Error OF JZ = 'Y' 014780* Respond with error messages and exit program 014790 Move MDT OF ATTRIBUTES TO ATTR OF Region OF CICS2S 014800 Move MDT OF ATTRIBUTES TO ATTR OF District OF CICS2S 014810 Move MDT OF ATTRIBUTES TO ATTR OF JZ-Name OF CICS2S 014820 Move MDT OF ATTRIBUTES TO ATTR OF SalesThisMonth OF CICS2S 014830 Move MDT OF ATTRIBUTES TO ATTR OF SalesYTD OF CICS2S 014840 Move MDT OF ATTRIBUTES TO ATTR OF Billingcycle OF CICS2S 014850 Move MDT OF ATTRIBUTES TO ATTR OF DateCommenced OF CICS2S 014860 MOVE '014850 SEND MAP(''CICS2S'') FROM(CICS2S) CURSOR ALA 014870- 'RM FREEKB' TO JZ-CICS-Stmt 014880 EXEC CICS 014890 SEND MAP('CICS2S') FROM(CICS2S) CURSOR ALARM FREEKB 014900 RESP(JZ-RESPONSE) 014910 END-EXEC 014920 PERFORM CICS-CheckStatus 014930 GO TO JZ-Normal-Exit 014940 END-IF. 014950* 014960* WHEN (Delete); 014970 JZ-44-WHEN. 014980* DELETE Custf WHERE(CustF.Account=CICS2C.SAVE.Account) 014990* CHECKCOPY(CICS2C.SAVE) RESETFUNCTION; 015000 PERFORM JZ-45-DELETE. 015010* END CASE; 015020* 015030 JZ-45-DELETE. 015040* DELETE Custf WHERE(CustF.Account=CICS2C.SAVE.Account) 015050* CHECKCOPY(CICS2C.SAVE) RESETFUNCTION; 015060 PERFORM JZ-CustF-ReadBy1ryKey. 015070 MOVE 'Y' TO CUSTF-UpdatePending-Flag. 015080* Check against saved copy 015090 IF SAVE OF CICS2C IS NOT EQUAL TO JZ-CustF 015100 MOVE JZ-CustF TO SAVE OF CICS2C 015110 MOVE 'Record has been changed. Sorry, you need to re-appl 015120- 'y the updates' TO OUT OF JZ-Error OF CICS2S 015130 MOVE 'E' TO OUT OF JZ-Function OF CICS2S 015140 MOVE '015130 SEND MAP(''CICS2S'') FROM(CICS2S) CURSOR ALA 015150- 'RM FREEKB' TO JZ-CICS-Stmt 015160 EXEC CICS 015170 SEND MAP('CICS2S') FROM(CICS2S) CURSOR ALARM FREEKB 015180 RESP(JZ-RESPONSE) 015190 END-EXEC 015200 PERFORM CICS-CheckStatus 015210 GO TO JZ-Normal-Exit 015220 END-IF. 015230 MOVE '015220 DELETE FILE(''CUSTF'') RIDFLD(Account OF JZ-Cust 015240- 'F)' TO JZ-CICS-Stmt. 015250 EXEC CICS 015260 DELETE FILE('CUSTF') RIDFLD(Account OF JZ-CustF) 015270 RESP(JZ-RESPONSE) 015280 END-EXEC. 015290 PERFORM CustF-CheckStatus. 015300 MOVE 'N' TO CUSTF-UpdatePending-Flag. 015310 PERFORM JZ-CustF-ResetFunction. 015320* 015330 JZ-47-SEND-Inscreen. 015340* SEND Inscreen; 015350 PERFORM JZ-SEND-INSCREEN. 015360****************************************************************** 015370** ** 015380** CICS Support Routines ** 015390** ** 015400****************************************************************** 015410* 015420* Assign program data to inscreen and Send it. Normal exit 015430 JZ-SEND-INSCREEN. 015440* Assign program data to screen 015450 MOVE Account OF JZ-CustF TO OUT OF Account OF CICS2S. 015460 MOVE LOW-VALUE TO ATTR OF Account OF CICS2S. 015470 MOVE JZ-Name OF JZ-CustF TO OUT OF JZ-Name OF CICS2S. 015480 MOVE LOW-VALUE TO ATTR OF JZ-Name OF CICS2S. 015490 MOVE JZ-Function OF CICS2C TO OUT OF JZ-Function OF CICS2S. 015500 MOVE JZ-Function OF CICS2C TO SEARCH-FOR OF 015510 JZCodes-CICS2C-Function. 015520 PERFORM JZCvt-CICS2C-Function. 015530 MOVE FOUND-VALUE OF JZCodes-CICS2C-Function TO OUT OF EFLD13 015540 OF CICS2S. 015550 MOVE LOW-VALUE TO ATTR OF JZ-Function OF CICS2S. 015560 MOVE Region OF JZ-CustF TO OUT OF Region OF CICS2S. 015570 MOVE LOW-VALUE TO ATTR OF Region OF CICS2S. 015580 MOVE District OF JZ-CustF TO OUT OF District OF CICS2S. 015590 MOVE LOW-VALUE TO ATTR OF District OF CICS2S. 015600 MOVE SalesThisMonth OF JZ-CustF TO OUT OF SalesThisMonth OF 015610 CICS2S. 015620 MOVE LOW-VALUE TO ATTR OF SalesThisMonth OF CICS2S. 015630 MOVE SalesYTD OF JZ-CustF TO OUT OF SalesYTD OF CICS2S. 015640 MOVE LOW-VALUE TO ATTR OF SalesYTD OF CICS2S. 015650 MOVE ZERO TO JZ-TinyNbr. 015660 MOVE Billingcycle OF JZ-CustF TO JZ-Tiny. 015670 MOVE JZ-TinyNbr TO OUT OF Billingcycle OF CICS2S. 015680 MOVE ZERO TO JZ-TinyNbr. 015690 MOVE Billingcycle OF JZ-CustF TO JZ-Tiny. 015700 MOVE JZ-TinyNbr TO SEARCH-FOR OF JZCodes-Types-Month. 015710 PERFORM JZCvt-Types-Month. 015720 MOVE FOUND-VALUE OF JZCodes-Types-Month TO OUT OF EFLD25 OF 015730 CICS2S. 015740 MOVE LOW-VALUE TO ATTR OF Billingcycle OF CICS2S. 015750 MOVE DateCommenced OF JZ-CustF TO DateFormPic OF JZ. 015760 PERFORM JZDateFormddbMMMbyy. 015770 MOVE DateFormddbMMMbyy TO OUT OF DateCommenced OF CICS2S. 015780 MOVE LOW-VALUE TO ATTR OF DateCommenced OF CICS2S. 015790* Now send screen 015800 IF JZ-XCTL OF CICS2C = 'Y' 015810 MOVE 'N' TO JZ-XCTL OF CICS2C 015820 MOVE '015810 SEND MAP(''CICS2S'') FROM(CICS2S) FREEKB ERA 015830- 'SE' TO JZ-CICS-Stmt 015840 EXEC CICS 015850 SEND MAP('CICS2S') FROM(CICS2S) FREEKB ERASE 015860 RESP(JZ-RESPONSE) 015870 END-EXEC 015880 PERFORM CICS-CheckStatus 015890 ELSE 015900 MOVE '015890 SEND MAP(''CICS2S'') FROM(CICS2S) FREEKB DAT 015910- 'AONLY' TO JZ-CICS-Stmt 015920 EXEC CICS 015930 SEND MAP('CICS2S') FROM(CICS2S) FREEKB DATAONLY 015940 RESP(JZ-RESPONSE) 015950 END-EXEC 015960 PERFORM CICS-CheckStatus 015970 END-IF. 015980 GO TO JZ-Normal-Exit. 015990* 016000 JZ-SET-AidHelp. 016010 MOVE 'F3=Return,' TO OUT OF JZAidHelp OF CICS2S. 016020 MOVE 11 TO JZ-AL. 016030 IF TS1Record-Count OF CICS2C > 1 016040 CALL 'JZNOFM' USING DFHEIBLK DFHCOMMAREA 016050 TS1Current-Record OF CICS2C, TS1Record-Count OF 016060 CICS2C, JZ-CHAR80, JZ-NOFML 016070 IF JZ-NOFML > 0 016080 MOVE JZ-CHAR80 TO OUT OF JZAidHelp OF 016090 CICS2S(JZ-AL:JZ-NOFML) 016100 ADD JZ-NOFML TO JZ-AL 016110 END-IF 016120 END-IF. 016130 IF TS1Current-Record OF CICS2C > 1 016140 MOVE 'F10=Previous,' TO OUT OF JZAidHelp OF CICS2S(JZ-AL:14) 016150 ADD 14 TO JZ-AL 016160 END-IF. 016170 IF TS1Current-Record OF CICS2C < TS1Record-Count OF CICS2C 016180 COMPUTE JZ-MLTH = JZ-AL + 9 016190 IF JZ-MLTH > 77 016200 COMPUTE JZ-ALIM = 77 - JZ-AL 016210 ELSE 016220 MOVE 9 TO JZ-ALIM 016230 END-IF 016240 MOVE 'F11=Next,' TO OUT OF JZAidHelp OF CICS2S(JZ-AL:9) 016250 ADD JZ-ALIM TO JZ-AL 016260 END-IF. 016270 COMPUTE JZ-MLTH = JZ-AL + 8. 016280 IF JZ-MLTH > 77 016290 COMPUTE JZ-ALIM = 77 - JZ-AL 016300 ELSE 016310 MOVE 8 TO JZ-ALIM 016320 END-IF. 016330 IF JZ-ALIM > 0 016340 MOVE 'F12=Exit' TO OUT OF JZAidHelp OF CICS2S(JZ-AL:JZ-ALIM) 016350 ADD JZ-ALIM TO JZ-AL 016360 END-IF. 016370* 016380* Clean up on Exit and Return 016390 JZ-DeleteAllTS. 016400 MOVE '016390 DELETEQ TS QNAME(TS1QName OF CICS2C)' TO 016410 JZ-CICS-Stmt. 016420 EXEC CICS 016430 DELETEQ TS QNAME(TS1QName OF CICS2C) RESP(JZ-RESPONSE) 016440 END-EXEC. 016450****************************************************************** 016460** ** 016470** Code Conversion Routines ** 016480** ** 016490****************************************************************** 016500* 016510* Convert Types-Month code to value 016520 JZCvt-Types-Month. 016530* Input: SEARCH-FOR OF JZCodes-Types-Month 016540* Output: FOUND-VALUE OF JZCodes-Types-Month 016550* If Invalid, FOUND-VALUE will be set to '****', 016560* field JZ-CHAR80 will contain an error message 016570 SET JZIX-Types-Month TO SEARCH-FOR OF JZCodes-Types-Month. 016580 IF JZIX-Types-Month < 1 OR JZIX-Types-Month > 12 016590 MOVE 'Outside Code Range' TO JZ-CHAR80 016600 MOVE '*********' TO FOUND-VALUE OF JZCodes-Types-Month 016610 ELSE 016620 MOVE CODE-Value OF JZCodes-Types-Month(JZIX-Types-Month) 016630 TO FOUND-VALUE OF JZCodes-Types-Month 016640 END-IF. 016650* 016660* Convert CICS2C-Function code to value 016670 JZCvt-CICS2C-Function. 016680* Input: SEARCH-FOR OF JZCodes-CICS2C-Function 016690* Output: FOUND-VALUE OF JZCodes-CICS2C-Function 016700* If Invalid, FOUND-VALUE will be set to '****', 016710* field JZ-CHAR80 will contain an error message 016720 SET JZIX-CICS2C-Function TO 1. 016730 SEARCH ITEM-VALUES OF JZCodes-CICS2C-Function VARYING 016740 JZIX-CICS2C-Function 016750 AT END 016760 MOVE 'Invalid Code' TO JZ-CHAR80 016770 MOVE '*******' TO FOUND-VALUE OF JZCodes-CICS2C-Function 016780 MOVE SPACES TO SEARCH-FOR OF JZCodes-CICS2C-Function 016790 WHEN JZCODE OF 016800 JZCodes-CICS2C-Function(JZIX-CICS2C-Function) = 016810 SEARCH-FOR OF JZCodes-CICS2C-Function 016820 MOVE CODE-VALUE OF 016830 JZCodes-CICS2C-Function(JZIX-CICS2C-Function) 016840 TO FOUND-VALUE OF JZCodes-CICS2C-Function 016850 END-SEARCH. 016860* 016870* Convert JZSMth-SMth code to value 016880 JZCvt-JZSMth-SMth. 016890* Input: SEARCH-FOR OF JZCodes-JZSMth-SMth 016900* Output: FOUND-VALUE OF JZCodes-JZSMth-SMth 016910* If Invalid, FOUND-VALUE will be set to '****', 016920* field JZ-CHAR80 will contain an error message 016930 SET JZIX-JZSMth-SMth TO SEARCH-FOR OF JZCodes-JZSMth-SMth. 016940 IF JZIX-JZSMth-SMth < 1 OR JZIX-JZSMth-SMth > 12 016950 MOVE 'Outside Code Range' TO JZ-CHAR80 016960 MOVE '***' TO FOUND-VALUE OF JZCodes-JZSMth-SMth 016970 ELSE 016980 MOVE CODE-Value OF JZCodes-JZSMth-SMth(JZIX-JZSMth-SMth) 016990 TO FOUND-VALUE OF JZCodes-JZSMth-SMth 017000 END-IF. 017010****************************************************************** 017020** ** 017030** Sundry Routines ** 017040** ** 017050****************************************************************** 017060* 017070 CICS-CheckStatus. 017080 EVALUATE JZ-Response 017090 WHEN DFHRESP(NORMAL) 017100 WHEN DFHRESP(DUPKEY) 017110 CONTINUE 017120 WHEN OTHER 017130 GO TO JZ-Abend-Exit 017140 END-EVALUATE. 017150* 017160* Date Format dd MMM yy 017170 JZDateFormddbMMMbyy. 017180 MOVE DateFormDay OF JZ TO JZ-DAY OF DateFormddbMMMbyyR OF JZ. 017190 MOVE DateFormMth OF JZ TO SMth OF JZSMth. 017200 MOVE SMth OF JZSMth TO SEARCH-FOR OF JZCodes-JZSMth-SMth. 017210 PERFORM JZCvt-JZSMth-SMth. 017220 MOVE FOUND-VALUE OF JZCodes-JZSMth-SMth TO SMth OF 017230 DateFormddbMMMbyyR OF JZ. 017240 MOVE DateFormYear OF JZ TO Year OF DateFormddbMMMbyyR OF JZ. 017250* 017260 CustF-LastKey-SET. 017270* Set CustF.$LastKey 017280 MOVE HIGH-VALUES TO CUSTF-HighKey. 017290 MOVE '017280 STARTBR FILE(''CUSTF'') RIDFLD(CUSTF-HighKey)' 017300 TO JZ-CICS-Stmt. 017310 EXEC CICS 017320 STARTBR FILE('CUSTF') RIDFLD(CUSTF-HighKey) 017330 RESP(JZ-RESPONSE) 017340 END-EXEC. 017350 MOVE '017340 READPREV FILE(''CUSTF'') INTO( JZ-CustF) RIDFLD( 017360- 'CUSTF-HighKey)' TO JZ-CICS-Stmt. 017370 EXEC CICS 017380 READPREV FILE('CUSTF') INTO( JZ-CustF) 017390 RIDFLD(CUSTF-HighKey) RESP(JZ-RESPONSE) 017400 END-EXEC. 017410 MOVE '017400 ENDBR FILE(''CUSTF'')' TO JZ-CICS-Stmt. 017420 EXEC CICS 017430 ENDBR FILE('CUSTF') RESP(JZ-RESPONSE) 017440 END-EXEC. 017450 MOVE Account OF JZ-CustF TO CustF-LastKey. 017460* 017470 JZ-CUSTF-ReadBy1ryKey. 017480 IF CUSTF-Get4Update 017490 MOVE '017480 READ FILE(''CUSTF'') INTO(JZ-CustF) UPDATE R 017500- 'IDFLD(Account OF JZ-CustF)' TO JZ-CICS-Stmt 017510 EXEC CICS 017520 READ FILE('CUSTF') INTO(JZ-CustF) UPDATE 017530 RIDFLD(Account OF JZ-CustF) RESP(JZ-RESPONSE) 017540 END-EXEC 017550 ELSE 017560 MOVE '017550 READ FILE(''CUSTF'') INTO(JZ-CustF) RIDFLD(A 017570- 'ccount OF JZ-CustF)' TO JZ-CICS-Stmt 017580 EXEC CICS 017590 READ FILE('CUSTF') INTO(JZ-CustF) RIDFLD(Account OF 017600 JZ-CustF) RESP(JZ-RESPONSE) 017610 END-EXEC 017620 END-IF. 017630 EVALUATE JZ-Response 017640 WHEN DFHRESP(NORMAL) 017650 WHEN DFHRESP(DUPKEY) 017660 MOVE 'Y' TO CustF-Found-Flag 017670 WHEN DFHRESP(NOTFND) 017680 MOVE 'N' TO CustF-Found-Flag 017690 PERFORM CustF-Initialize 017700 WHEN OTHER 017710 GO TO JZ-Abend-Exit 017720 END-EVALUATE. 017730* 017740 CustF-Initialize. 017750* Initialize non-key fields 017760 Move ZERO TO Region OF JZ-CustF. 017770 Move ZERO TO District OF JZ-CustF. 017780 Move SPACES TO JZ-Name OF JZ-CustF. 017790 Move ZERO TO SalesThisMonth OF JZ-CustF. 017800 Move ZERO TO SalesYTD OF JZ-CustF. 017810 Move LOW-VALUE TO Billingcycle OF JZ-CustF. 017820 Move ZERO TO DateCommenced OF JZ-CustF. 017830* 017840 JZ-CustF-ResetFunction. 017850 MOVE INPT OF JZ-Function OF CICS2S TO JZ-Function OF CICS2C. 017860 EVALUATE JZ-Function OF CICS2C 017870 WHEN 'E' 017880 IF CustF-FOUND-FLAG = 'Y' 017890 MOVE 'Record Found. Use Function U to update it' 017900 TO OUT OF JZ-Error OF CICS2S 017910 ELSE 017920 MOVE 'Record not found. Use Function A to add it' 017930 TO OUT OF JZ-Error OF CICS2S 017940 MOVE 'A' TO JZ-Function OF CICS2C 017950 END-IF 017960 WHEN 'U' 017970 MOVE 'Record Updated' TO OUT OF JZ-Error OF CICS2S 017980 MOVE 'E' TO JZ-Function OF CICS2C 017990 WHEN 'A' 018000 MOVE 'Record Added' TO OUT OF JZ-Error OF CICS2S 018010 MOVE 'E' TO JZ-Function OF CICS2C 018020 WHEN 'D' 018030 MOVE 'Record Deleted' TO OUT OF JZ-Error OF CICS2S 018040 MOVE 'E' TO JZ-Function OF CICS2C 018050 END-EVALUATE. 018060* 018070 CustF-Update. 018080 IF CustF-UpdatePending 018090 MOVE 'N' TO CustF-UpdatePending-Flag 018100 IF CustF-FOUND 018110 MOVE '018100 REWRITE FILE(''CUSTF'') FROM(JZ-CustF)' 018120 TO JZ-CICS-Stmt 018130 EXEC CICS 018140 REWRITE FILE('CUSTF') FROM(JZ-CustF) 018150 RESP(JZ-RESPONSE) 018160 END-EXEC 018170 PERFORM CICS-CheckStatus 018180 ELSE 018190 MOVE '018180 WRITE FILE(''CUSTF'') FROM(JZ-CustF) RID 018200- 'FLD(Account OF JZ-CustF)' TO JZ-CICS-Stmt 018210 EXEC CICS 018220 WRITE FILE('CUSTF') FROM(JZ-CustF) RIDFLD(Account 018230 OF JZ-CustF) RESP(JZ-RESPONSE) 018240 END-EXEC 018250 PERFORM CICS-CheckStatus 018260 END-IF 018270 END-IF. 018280 PERFORM JZ-CustF-ResetFunction. 018290* 018300 CustF-CheckStatus. 018310 EVALUATE JZ-Response 018320 WHEN DFHRESP(NORMAL) 018330 WHEN DFHRESP(DUPKEY) 018340 CONTINUE 018350* GET and DELETE: check that record found 018360 WHEN DFHRESP(NOTFND) 018370 MOVE 'N' TO CustF-Found-Flag 018380* Process (Browse): check for Endfile 018390 WHEN DFHRESP(ENDFILE) 018400 MOVE 'Y' TO CustF-ENDFILE 018410 WHEN OTHER 018420 GO TO JZ-Abend-Exit 018430 END-EVALUATE. 018440* 018450 JZ-READ-TS1. 018460* Read CUSTF with key from nth item in TS 018470* IF condition should always be true 018480 IF TS1Current-Record OF CICS2C >= 1 AND TS1Current-Record OF 018490 CICS2C <= TS1Record-Count OF CICS2C 018500 MOVE '018490 READQ TS QNAME(TS1QName OF CICS2C) INTO(Acco 018510- 'unt OF JZ-CustF) ITEM(TS1Current-Rec' TO JZ-CICS-Stmt 018520 EXEC CICS 018530 READQ TS QNAME(TS1QName OF CICS2C) INTO(Account OF 018540 JZ-CustF) ITEM(TS1Current-Record OF CICS2C) 018550 RESP(JZ-RESPONSE) 018560 END-EXEC 018570 PERFORM CICS-CheckStatus 018580 PERFORM JZ-CustF-ReadBy1ryKey 018590 PERFORM JZ-27-GETGroup 018600 END-IF.