000010 IDENTIFICATION DIVISION. 000020 PROGRAM-ID. CICS3. 000030 AUTHOR. IBMUSER (Using Jazz from Visual Studio) 000040 DATE-WRITTEN. 18/04/2018 11:47:08 a.m. 000050 ENVIRONMENT DIVISION. 000060*# Last Updated by IBMUSER at 18/04/2018 11:47:08 a.m. 000070* PROGRAM CICS3 CICS INSCREEN(CICS3S) TRANSID(TRN3) 000080* COMMAREA(CICS3C) EXIT(Menu1); 000090*COPY JZSMth; 000100*COPY JZMDays; 000110*COPY orders; 000120*COPY CICS4C; 000130* #036 W More than one TYPE(COMMAREA) definition. CICS4C treated 000140* as Working Data 000150*COPY CICS4S; 000160*ACCEPT (CICS3S.Function); 000170*#562 I CICS3S.Error used as message field 000180*CASE (CICS3C.Function); 000190* WHEN (Enquiry); 000200* ACCEPT (CICS3S.Account OR CICS3S.Name); 000210* #562 I CICS3S.Error used as message field 000220* DEFINE TS1 TS DATA( 000230* Account LIKE CustF.Account); 000240* GET Custf KEY(CustF.Account OR CustF.Name) SAVECOPY 000250* CICS3C.SAVE TS(1); 000260* #373 I GET statement returns one record at a time 000270* for Name 000280* DEFINE TS2 TS DATA( 000290* OrdNbr LIKE Orders.OrdNbr); 000300* PROCESS Orders WHERE (Orders.OrdCustId = 000310* CustF.Account) INDEX JZ-N1 TS(2); 000320* IF CICS3S.JZREPEAT.JZ-LF(JZ.JZ-N1) = 'S' THEN; 000330* CICS4C.Function = Update; 000340* CICS4C.SAVE = Orders; 000350* EXIT TO CICS4 COMMAREA(CICS4C); 000360* END IF; 000370* END PROCESS Orders; 000380* END GET Custf RESETFUNCTION; 000390* WHEN (Update); 000400* GET Custf WHERE(CustF.Account=CICS3C.SAVE.Account) 000410* REWRITE CHECKCOPY(CICS3C.SAVE); 000420* ACCEPT 000430* (CICS3S.Region,CICS3S.District,CICS3S.Name,CICS3 000440* S.SalesThisMonth,CICS3S.SalesYTD,CICS3S.Billingc 000450* ycle,CICS3S.DateCommenced); 000460* #562 I CICS3S.Error used as message field 000470* END GET Custf REWRITE RESETFUNCTION; 000480* WHEN (Add); 000490* CustF.Account = CustF.$LastKey + 1; [Will need to be 000500* changed if key is not a number 000510* #361 E Assignment to a key field 000520* GET Custf KEY(CustF.Account) CREATE; 000530* ACCEPT 000540* (CICS3S.Region,CICS3S.District,CICS3S.Name,CICS3 000550* S.SalesThisMonth,CICS3S.SalesYTD,CICS3S.Billingc 000560* ycle,CICS3S.DateCommenced) SETMDT; 000570* #562 I CICS3S.Error used as message field 000580* END GET Custf CREATE RESETFUNCTION; 000590* WHEN (Delete); 000600* DELETE Custf WHERE(CustF.Account=CICS3C.SAVE.Account) 000610* CHECKCOPY(CICS3C.SAVE) 000620* NOCHILDREN(Orders) RESETFUNCTION; 000630* WHEN (Order); 000640* Orders = JAZZ.$Init; 000650* Orders.OrdCustId = CICS3C.SAVE.Account; 000660* Orders.ordDate = JAZZ.$Today; 000670* CICS4C.SAVE = Orders; 000680* CICS4C.Function = Add; 000690* EXIT TO CICS4 COMMAREA CICS4C; 000700*END CASE; 000710*SEND Inscreen; 000720****************************************************************** 000730** ** 000740** Data Division ** 000750** ** 000760****************************************************************** 000770 DATA DIVISION. 000780****************************************************************** 000790** ** 000800** Working Storage Section: General Program Data ** 000810** ** 000820****************************************************************** 000830* 000840 WORKING-STORAGE SECTION. 000850****************************************************************** 000860** ** 000870** Screen Areas ** 000880** ** 000890****************************************************************** 000900* 000910 COPY DFHAID. 000920* 000930 01 CICS3S. 000940 03 FILLER PIC X(12). 000950* SpecialConstant VALUE 'CICS3S' 000960 03 SCNST1. 000970 05 LTH PIC S9(4) COMP. 000980 05 ATTR PIC X. 000990 05 COLR PIC X. 001000 05 HLIT PIC X. 001010 05 FILLER PIC X(6). 001020* Constant VALUE 'UPDATE CustF' 001030 03 CNST5. 001040 05 LTH PIC S9(4) COMP. 001050 05 ATTR PIC X. 001060 05 COLR PIC X. 001070 05 HLIT PIC X. 001080 05 FILLER PIC X(12). 001090* SpecialConstant VALUE 'TRN3' 001100 03 SCNST4. 001110 05 LTH PIC S9(4) COMP. 001120 05 ATTR PIC X. 001130 05 COLR PIC X. 001140 05 HLIT PIC X. 001150 05 FILLER PIC X(4). 001160* Constant VALUE 'Enter =>' 001170 03 CNST6. 001180 05 LTH PIC S9(4) COMP. 001190 05 ATTR PIC X. 001200 05 COLR PIC X. 001210 05 HLIT PIC X. 001220 05 FILLER PIC X(8). 001230* Constant VALUE 'Account Number.' 001240 03 CNST7. 001250 05 LTH PIC S9(4) COMP. 001260 05 ATTR PIC X. 001270 05 COLR PIC X. 001280 05 HLIT PIC X. 001290 05 FILLER PIC X(15). 001300* Field ='CustF.Account' VALUE '999999' 001310 03 Account. 001320 05 LTH PIC S9(4) COMP. 001330 05 ATTR PIC X. 001340 05 COLR PIC X. 001350 05 HLIT PIC X. 001360 05 INPT PIC X(6). 001370 05 OUT REDEFINES INPT PIC 999999. 001380* ErrorFlag VALUE '*' 001390 03 EFLD8. 001400 05 LTH PIC S9(4) COMP. 001410 05 ATTR PIC X. 001420 05 COLR PIC X. 001430 05 HLIT PIC X. 001440 05 OUT PIC X(1). 001450* Constant VALUE 'OR =>' 001460 03 CNST9. 001470 05 LTH PIC S9(4) COMP. 001480 05 ATTR PIC X. 001490 05 COLR PIC X. 001500 05 HLIT PIC X. 001510 05 FILLER PIC X(5). 001520* Constant VALUE 'Name.' 001530 03 CNST10. 001540 05 LTH PIC S9(4) COMP. 001550 05 ATTR PIC X. 001560 05 COLR PIC X. 001570 05 HLIT PIC X. 001580 05 FILLER PIC X(5). 001590* Field ='CustF.Name' VALUE 'X(30)_________________________' 001600 03 JZ-Name. 001610 05 LTH PIC S9(4) COMP. 001620 05 ATTR PIC X. 001630 05 COLR PIC X. 001640 05 HLIT PIC X. 001650 05 INPT PIC X(30). 001660 05 OUT REDEFINES INPT PIC X(30). 001670* ErrorFlag VALUE '*' 001680 03 EFLD11. 001690 05 LTH PIC S9(4) COMP. 001700 05 ATTR PIC X. 001710 05 COLR PIC X. 001720 05 HLIT PIC X. 001730 05 OUT PIC X(1). 001740* Constant VALUE 'and' 001750 03 CNST12. 001760 05 LTH PIC S9(4) COMP. 001770 05 ATTR PIC X. 001780 05 COLR PIC X. 001790 05 HLIT PIC X. 001800 05 FILLER PIC X(3). 001810* Field ='CICS3C.Function' VALUE 'X' 001820 03 JZ-Function. 001830 05 LTH PIC S9(4) COMP. 001840 05 ATTR PIC X. 001850 05 COLR PIC X. 001860 05 HLIT PIC X. 001870 05 INPT PIC X(1). 001880 05 OUT REDEFINES INPT PIC X. 001890* ErrorFlag VALUE '*******' 001900 03 EFLD13. 001910 05 LTH PIC S9(4) COMP. 001920 05 ATTR PIC X. 001930 05 COLR PIC X. 001940 05 HLIT PIC X. 001950 05 OUT PIC X(7). 001960* Constant VALUE 'E, U, A, D or R and click Enter' 001970 03 CNST14. 001980 05 LTH PIC S9(4) COMP. 001990 05 ATTR PIC X. 002000 05 COLR PIC X. 002010 05 HLIT PIC X. 002020 05 FILLER PIC X(31). 002030* Constant VALUE 'Region.' 002040 03 CNST28. 002050 05 LTH PIC S9(4) COMP. 002060 05 ATTR PIC X. 002070 05 COLR PIC X. 002080 05 HLIT PIC X. 002090 05 FILLER PIC X(7). 002100* Field ='CustF.Region' VALUE '---9' 002110 03 Region. 002120 05 LTH PIC S9(4) COMP. 002130 05 ATTR PIC X. 002140 05 COLR PIC X. 002150 05 HLIT PIC X. 002160 05 INPT PIC X(4). 002170 05 OUT REDEFINES INPT PIC ---9. 002180* ErrorFlag VALUE '*' 002190 03 EFLD29. 002200 05 LTH PIC S9(4) COMP. 002210 05 ATTR PIC X. 002220 05 COLR PIC X. 002230 05 HLIT PIC X. 002240 05 OUT PIC X(1). 002250* Constant VALUE 'District.' 002260 03 CNST30. 002270 05 LTH PIC S9(4) COMP. 002280 05 ATTR PIC X. 002290 05 COLR PIC X. 002300 05 HLIT PIC X. 002310 05 FILLER PIC X(9). 002320* Field ='CustF.District' VALUE '---9' 002330 03 District. 002340 05 LTH PIC S9(4) COMP. 002350 05 ATTR PIC X. 002360 05 COLR PIC X. 002370 05 HLIT PIC X. 002380 05 INPT PIC X(4). 002390 05 OUT REDEFINES INPT PIC ---9. 002400* ErrorFlag VALUE '*' 002410 03 EFLD31. 002420 05 LTH PIC S9(4) COMP. 002430 05 ATTR PIC X. 002440 05 COLR PIC X. 002450 05 HLIT PIC X. 002460 05 OUT PIC X(1). 002470* Constant VALUE 'SalesThisMonth.' 002480 03 CNST32. 002490 05 LTH PIC S9(4) COMP. 002500 05 ATTR PIC X. 002510 05 COLR PIC X. 002520 05 HLIT PIC X. 002530 05 FILLER PIC X(15). 002540* Field ='CustF.SalesThisMonth' VALUE '$$$,$$9.99CR' 002550 03 SalesThisMonth. 002560 05 LTH PIC S9(4) COMP. 002570 05 ATTR PIC X. 002580 05 COLR PIC X. 002590 05 HLIT PIC X. 002600 05 INPT PIC X(12). 002610 05 OUT REDEFINES INPT PIC $$$,$$9.99CR. 002620* ErrorFlag VALUE '*' 002630 03 EFLD33. 002640 05 LTH PIC S9(4) COMP. 002650 05 ATTR PIC X. 002660 05 COLR PIC X. 002670 05 HLIT PIC X. 002680 05 OUT PIC X(1). 002690* Constant VALUE 'SalesYTD.' 002700 03 CNST34. 002710 05 LTH PIC S9(4) COMP. 002720 05 ATTR PIC X. 002730 05 COLR PIC X. 002740 05 HLIT PIC X. 002750 05 FILLER PIC X(9). 002760* Field ='CustF.SalesYTD' VALUE '$$$,$$9.99CR' 002770 03 SalesYTD. 002780 05 LTH PIC S9(4) COMP. 002790 05 ATTR PIC X. 002800 05 COLR PIC X. 002810 05 HLIT PIC X. 002820 05 INPT PIC X(12). 002830 05 OUT REDEFINES INPT PIC $$$,$$9.99CR. 002840* ErrorFlag VALUE '*' 002850 03 EFLD35. 002860 05 LTH PIC S9(4) COMP. 002870 05 ATTR PIC X. 002880 05 COLR PIC X. 002890 05 HLIT PIC X. 002900 05 OUT PIC X(1). 002910* Constant VALUE 'Billingcycle.' 002920 03 CNST36. 002930 05 LTH PIC S9(4) COMP. 002940 05 ATTR PIC X. 002950 05 COLR PIC X. 002960 05 HLIT PIC X. 002970 05 FILLER PIC X(13). 002980* Field ='CustF.Billingcycle' VALUE '99' 002990 03 Billingcycle. 003000 05 LTH PIC S9(4) COMP. 003010 05 ATTR PIC X. 003020 05 COLR PIC X. 003030 05 HLIT PIC X. 003040 05 INPT PIC X(2). 003050 05 OUT REDEFINES INPT PIC 99. 003060* ErrorFlag VALUE '*********' 003070 03 EFLD37. 003080 05 LTH PIC S9(4) COMP. 003090 05 ATTR PIC X. 003100 05 COLR PIC X. 003110 05 HLIT PIC X. 003120 05 OUT PIC X(9). 003130* Constant VALUE 'DateCommenced.' 003140 03 CNST38. 003150 05 LTH PIC S9(4) COMP. 003160 05 ATTR PIC X. 003170 05 COLR PIC X. 003180 05 HLIT PIC X. 003190 05 FILLER PIC X(14). 003200* Field ='CustF.DateCommenced' VALUE 'dd MMM yy' 003210 03 DateCommenced. 003220 05 LTH PIC S9(4) COMP. 003230 05 ATTR PIC X. 003240 05 COLR PIC X. 003250 05 HLIT PIC X. 003260 05 INPT PIC X(9). 003270 05 OUT REDEFINES INPT PIC X(9). 003280* ErrorFlag VALUE '*' 003290 03 EFLD39. 003300 05 LTH PIC S9(4) COMP. 003310 05 ATTR PIC X. 003320 05 COLR PIC X. 003330 05 HLIT PIC X. 003340 05 OUT PIC X(1). 003350* Constant VALUE 'F OrdNbr **ordDate OrdPart *OrdQty Discount 003360* OrdStatus***' 003370 03 CNST40. 003380 05 LTH PIC S9(4) COMP. 003390 05 ATTR PIC X. 003400 05 COLR PIC X. 003410 05 HLIT PIC X. 003420 05 FILLER PIC X(56). 003430* Group 003440 03 JZREPEAT OCCURS 13. 003450* Field ='JZ.JZ-LF' VALUE 'X' 003460 05 JZ-LF. 003470 07 LTH PIC S9(4) COMP. 003480 07 ATTR PIC X. 003490 07 COLR PIC X. 003500 07 HLIT PIC X. 003510 07 INPT PIC X(1). 003520 07 OUT REDEFINES INPT PIC X. 003530* OutputField ='Orders.OrdNbr' VALUE '99999' 003540 05 OrdNbr. 003550 07 LTH PIC S9(4) COMP. 003560 07 ATTR PIC X. 003570 07 COLR PIC X. 003580 07 HLIT PIC X. 003590 07 OUT PIC 99999. 003600 07 BLK REDEFINES OUT PIC X(5). 003610* OutputField ='Orders.ordDate' VALUE 'dd MMM yy' 003620 05 ordDate. 003630 07 LTH PIC S9(4) COMP. 003640 07 ATTR PIC X. 003650 07 COLR PIC X. 003660 07 HLIT PIC X. 003670 07 OUT PIC X(9). 003680 07 BLK REDEFINES OUT PIC X(9). 003690* OutputField ='Orders.OrdPart' VALUE '---,--9' 003700 05 OrdPart. 003710 07 LTH PIC S9(4) COMP. 003720 07 ATTR PIC X. 003730 07 COLR PIC X. 003740 07 HLIT PIC X. 003750 07 OUT PIC ---,--9. 003760 07 BLK REDEFINES OUT PIC X(7). 003770* OutputField ='Orders.OrdQty' VALUE '---,--9' 003780 05 OrdQty. 003790 07 LTH PIC S9(4) COMP. 003800 07 ATTR PIC X. 003810 07 COLR PIC X. 003820 07 HLIT PIC X. 003830 07 OUT PIC ---,--9. 003840 07 BLK REDEFINES OUT PIC X(7). 003850* OutputField ='Orders.OrdDiscount' VALUE '--9.9' 003860 05 OrdDiscount. 003870 07 LTH PIC S9(4) COMP. 003880 07 ATTR PIC X. 003890 07 COLR PIC X. 003900 07 HLIT PIC X. 003910 07 OUT PIC --9.9. 003920 07 BLK REDEFINES OUT PIC X(5). 003930* OutputField ='Orders.OrdStatus' VALUE 'XXXXXXXXXXXX' 003940 05 OrdStatus. 003950 07 LTH PIC S9(4) COMP. 003960 07 ATTR PIC X. 003970 07 COLR PIC X. 003980 07 HLIT PIC X. 003990 07 OUT PIC X(12). 004000 07 BLK REDEFINES OUT PIC X(12). 004010* ErrorFlag VALUE 004020* '#xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx 004030* xxxxxxxxxxxxxxxxxxxxx' 004040 03 JZ-Error. 004050 05 LTH PIC S9(4) COMP. 004060 05 ATTR PIC X. 004070 05 COLR PIC X. 004080 05 HLIT PIC X. 004090 05 OUT PIC X(80). 004100* OutputField ='' VALUE 'PF Keys. PF3=Return, PF12 = Exit 004110* .' 004120 03 JZAidHelp. 004130 05 LTH PIC S9(4) COMP. 004140 05 ATTR PIC X. 004150 05 COLR PIC X. 004160 05 HLIT PIC X. 004170 05 OUT PIC X(77). 004180 05 BLK REDEFINES OUT PIC X(77). 004190****************************************************************** 004200** ** 004210** Screen CICS4S ** 004220** ** 004230****************************************************************** 004240* 004250 01 CICS4S. 004260 03 FILLER PIC X(12). 004270* SpecialConstant VALUE 'CICS4S' 004280 03 SCNST1. 004290 05 LTH PIC S9(4) COMP. 004300 05 ATTR PIC X. 004310 05 COLR PIC X. 004320 05 HLIT PIC X. 004330 05 FILLER PIC X(6). 004340* Constant VALUE 'UPDATE Orders' 004350 03 CNST5. 004360 05 LTH PIC S9(4) COMP. 004370 05 ATTR PIC X. 004380 05 COLR PIC X. 004390 05 HLIT PIC X. 004400 05 FILLER PIC X(13). 004410* SpecialConstant VALUE 'TRN4' 004420 03 SCNST4. 004430 05 LTH PIC S9(4) COMP. 004440 05 ATTR PIC X. 004450 05 COLR PIC X. 004460 05 HLIT PIC X. 004470 05 FILLER PIC X(4). 004480* Constant VALUE 'Enter =>' 004490 03 CNST6. 004500 05 LTH PIC S9(4) COMP. 004510 05 ATTR PIC X. 004520 05 COLR PIC X. 004530 05 HLIT PIC X. 004540 05 FILLER PIC X(8). 004550* Constant VALUE 'OrdNbr.' 004560 03 CNST7. 004570 05 LTH PIC S9(4) COMP. 004580 05 ATTR PIC X. 004590 05 COLR PIC X. 004600 05 HLIT PIC X. 004610 05 FILLER PIC X(7). 004620* Field ='Orders.OrdNbr' VALUE '99999' 004630 03 OrdNbr. 004640 05 LTH PIC S9(4) COMP. 004650 05 ATTR PIC X. 004660 05 COLR PIC X. 004670 05 HLIT PIC X. 004680 05 INPT PIC X(5). 004690 05 OUT REDEFINES INPT PIC 99999. 004700* ErrorFlag VALUE '*' 004710 03 EFLD8. 004720 05 LTH PIC S9(4) COMP. 004730 05 ATTR PIC X. 004740 05 COLR PIC X. 004750 05 HLIT PIC X. 004760 05 OUT PIC X(1). 004770* Constant VALUE 'OR =>' 004780 03 CNST9. 004790 05 LTH PIC S9(4) COMP. 004800 05 ATTR PIC X. 004810 05 COLR PIC X. 004820 05 HLIT PIC X. 004830 05 FILLER PIC X(5). 004840* Constant VALUE 'Account Number.' 004850 03 CNST10. 004860 05 LTH PIC S9(4) COMP. 004870 05 ATTR PIC X. 004880 05 COLR PIC X. 004890 05 HLIT PIC X. 004900 05 FILLER PIC X(15). 004910* Field ='Orders.OrdCustId' VALUE '999999' 004920 03 OrdCustId. 004930 05 LTH PIC S9(4) COMP. 004940 05 ATTR PIC X. 004950 05 COLR PIC X. 004960 05 HLIT PIC X. 004970 05 INPT PIC X(6). 004980 05 OUT REDEFINES INPT PIC 999999. 004990* ErrorFlag VALUE '*' 005000 03 EFLD11. 005010 05 LTH PIC S9(4) COMP. 005020 05 ATTR PIC X. 005030 05 COLR PIC X. 005040 05 HLIT PIC X. 005050 05 OUT PIC X(1). 005060* Constant VALUE 'OR =>' 005070 03 CNST12. 005080 05 LTH PIC S9(4) COMP. 005090 05 ATTR PIC X. 005100 05 COLR PIC X. 005110 05 HLIT PIC X. 005120 05 FILLER PIC X(5). 005130* Constant VALUE 'OrdPart.' 005140 03 CNST13. 005150 05 LTH PIC S9(4) COMP. 005160 05 ATTR PIC X. 005170 05 COLR PIC X. 005180 05 HLIT PIC X. 005190 05 FILLER PIC X(8). 005200* Field ='Orders.OrdPart' VALUE '---,--9' 005210 03 OrdPart. 005220 05 LTH PIC S9(4) COMP. 005230 05 ATTR PIC X. 005240 05 COLR PIC X. 005250 05 HLIT PIC X. 005260 05 INPT PIC X(7). 005270 05 OUT REDEFINES INPT PIC ---,--9. 005280* ErrorFlag VALUE '*' 005290 03 EFLD14. 005300 05 LTH PIC S9(4) COMP. 005310 05 ATTR PIC X. 005320 05 COLR PIC X. 005330 05 HLIT PIC X. 005340 05 OUT PIC X(1). 005350* Constant VALUE 'Function.' 005360 03 CNST15. 005370 05 LTH PIC S9(4) COMP. 005380 05 ATTR PIC X. 005390 05 COLR PIC X. 005400 05 HLIT PIC X. 005410 05 FILLER PIC X(9). 005420* Field ='CICS4C.Function' VALUE 'X' 005430 03 JZ-Function. 005440 05 LTH PIC S9(4) COMP. 005450 05 ATTR PIC X. 005460 05 COLR PIC X. 005470 05 HLIT PIC X. 005480 05 INPT PIC X(1). 005490 05 OUT REDEFINES INPT PIC X. 005500* ErrorFlag VALUE '*******' 005510 03 EFLD16. 005520 05 LTH PIC S9(4) COMP. 005530 05 ATTR PIC X. 005540 05 COLR PIC X. 005550 05 HLIT PIC X. 005560 05 OUT PIC X(7). 005570* Constant VALUE 'E, U, A, or D and press Enter' 005580 03 CNST17. 005590 05 LTH PIC S9(4) COMP. 005600 05 ATTR PIC X. 005610 05 COLR PIC X. 005620 05 HLIT PIC X. 005630 05 FILLER PIC X(29). 005640* Constant VALUE 'ordDate.' 005650 03 CNST19. 005660 05 LTH PIC S9(4) COMP. 005670 05 ATTR PIC X. 005680 05 COLR PIC X. 005690 05 HLIT PIC X. 005700 05 FILLER PIC X(8). 005710* Field ='Orders.ordDate' VALUE 'dd MMM yy' 005720 03 ordDate. 005730 05 LTH PIC S9(4) COMP. 005740 05 ATTR PIC X. 005750 05 COLR PIC X. 005760 05 HLIT PIC X. 005770 05 INPT PIC X(9). 005780 05 OUT REDEFINES INPT PIC X(9). 005790* ErrorFlag VALUE '*' 005800 03 EFLD20. 005810 05 LTH PIC S9(4) COMP. 005820 05 ATTR PIC X. 005830 05 COLR PIC X. 005840 05 HLIT PIC X. 005850 05 OUT PIC X(1). 005860* Constant VALUE 'OrdQty.' 005870 03 CNST21. 005880 05 LTH PIC S9(4) COMP. 005890 05 ATTR PIC X. 005900 05 COLR PIC X. 005910 05 HLIT PIC X. 005920 05 FILLER PIC X(7). 005930* Field ='Orders.OrdQty' VALUE '---,--9' 005940 03 OrdQty. 005950 05 LTH PIC S9(4) COMP. 005960 05 ATTR PIC X. 005970 05 COLR PIC X. 005980 05 HLIT PIC X. 005990 05 INPT PIC X(7). 006000 05 OUT REDEFINES INPT PIC ---,--9. 006010* ErrorFlag VALUE '*' 006020 03 EFLD22. 006030 05 LTH PIC S9(4) COMP. 006040 05 ATTR PIC X. 006050 05 COLR PIC X. 006060 05 HLIT PIC X. 006070 05 OUT PIC X(1). 006080* Constant VALUE 'Order Discount.' 006090 03 CNST23. 006100 05 LTH PIC S9(4) COMP. 006110 05 ATTR PIC X. 006120 05 COLR PIC X. 006130 05 HLIT PIC X. 006140 05 FILLER PIC X(15). 006150* Field ='Orders.OrdDiscount' VALUE '--9.9' 006160 03 OrdDiscount. 006170 05 LTH PIC S9(4) COMP. 006180 05 ATTR PIC X. 006190 05 COLR PIC X. 006200 05 HLIT PIC X. 006210 05 INPT PIC X(5). 006220 05 OUT REDEFINES INPT PIC --9.9. 006230* ErrorFlag VALUE '*' 006240 03 EFLD24. 006250 05 LTH PIC S9(4) COMP. 006260 05 ATTR PIC X. 006270 05 COLR PIC X. 006280 05 HLIT PIC X. 006290 05 OUT PIC X(1). 006300* Constant VALUE 'OrdStatus.' 006310 03 CNST25. 006320 05 LTH PIC S9(4) COMP. 006330 05 ATTR PIC X. 006340 05 COLR PIC X. 006350 05 HLIT PIC X. 006360 05 FILLER PIC X(10). 006370* Field ='Orders.OrdStatus' VALUE 'X' 006380 03 OrdStatus. 006390 05 LTH PIC S9(4) COMP. 006400 05 ATTR PIC X. 006410 05 COLR PIC X. 006420 05 HLIT PIC X. 006430 05 INPT PIC X(1). 006440 05 OUT REDEFINES INPT PIC X. 006450* ErrorFlag VALUE '************' 006460 03 EFLD26. 006470 05 LTH PIC S9(4) COMP. 006480 05 ATTR PIC X. 006490 05 COLR PIC X. 006500 05 HLIT PIC X. 006510 05 OUT PIC X(12). 006520* ErrorFlag VALUE 006530* '#xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx 006540* xxxxxxxxxxxxxxxxxxxxx' 006550 03 JZ-Error. 006560 05 LTH PIC S9(4) COMP. 006570 05 ATTR PIC X. 006580 05 COLR PIC X. 006590 05 HLIT PIC X. 006600 05 OUT PIC X(80). 006610* OutputField ='' VALUE 'PF Keys. PF3=Return, PF12 = Exit 006620* .' 006630 03 JZAidHelp. 006640 05 LTH PIC S9(4) COMP. 006650 05 ATTR PIC X. 006660 05 COLR PIC X. 006670 05 HLIT PIC X. 006680 05 OUT PIC X(77). 006690 05 BLK REDEFINES OUT PIC X(77). 006700****************************************************************** 006710** ** 006720** VSAM Files ** 006730** ** 006740****************************************************************** 006750* 006760 01 JZ-CustF. 006770 03 Account PIC 999999 VALUE ZERO. 006780 03 Region PIC S9(3) COMP-3 VALUE ZERO. 006790 03 District PIC S9(3) COMP-3 VALUE ZERO. 006800 03 JZ-Name PIC X(30) VALUE SPACES. 006810 03 SalesThisMonth PIC S9(5)V9(2) COMP-3 VALUE ZERO. 006820 03 SalesYTD PIC S9(5)V9(2) COMP-3 VALUE ZERO. 006830 03 Billingcycle PIC X VALUE LOW-VALUE. 006840 03 DateCommenced PIC S9(9) COMP VALUE ZERO. 006850* 006860 01 JZ-Parts. 006870 03 Partnbr PIC S9(4) COMP VALUE ZERO. 006880 03 PartName PIC X(30) VALUE 'Part Name Absent'. 006890 03 StandardPrice PIC S9(5)V9(2) COMP-3 VALUE ZERO. 006900* 006910 01 JZ-Orders. 006920 03 OrdNbr PIC S9(5) COMP-3 VALUE ZERO. 006930 03 OrdCustId PIC 999999 VALUE ZERO. 006940 03 ordDate PIC S9(9) COMP VALUE ZERO. 006950 03 OrdPart PIC S9(4) COMP VALUE ZERO. 006960 03 OrdQty PIC S9(4) COMP VALUE ZERO. 006970 03 OrdDiscount PIC S9(2)V9(1) COMP-3 VALUE ZERO. 006980 03 OrdStatus PIC X VALUE SPACES. 006990****************************************************************** 007000** ** 007010** General Program Information ** 007020** ** 007030****************************************************************** 007040* 007050* Program ID etc - in case of errors 007060 01 JZ-Program-Info. 007070 03 PROG-ID PIC X(20) VALUE 'PROGRAM CICS3'. 007080 03 AUTH PIC X(40) VALUE 'IBMUSER (Using Jazz, 1.14.2.177)'. 007090 03 DTE-WRITTEN PIC X(24) VALUE '18/04/2018 11:47:08 a.m.'. 007100 03 JZ-Jazz-Stmt PIC X(80) VALUE SPACES. 007110 03 JZ-CICS-Stmt PIC X(80) VALUE SPACES. 007120 03 JZ-Response PIC S9(8) BINARY VALUE 0. 007130 03 JZ-Response2 PIC S9(8) BINARY VALUE 0. 007140 03 JZ-SQLIsUsed PIC X VALUE 'N'. 007150* SQL diagnostics ignored unless JZ-SQLIsUsed = 'Y' 007160 03 JZ-SQL-Stmt PIC X(80) VALUE SPACES. 007170 03 JZ-SQLCA PIC X(80) VALUE SPACES. 007180* 007190* Status Flags and control data 007200 01 JZ-FileControl. 007210 03 SORTWORK-ENDFILE PIC X VALUE 'N'. 007220 03 CustF-ENDFILE PIC X VALUE 'N'. 007230 03 CustF-STATUS PIC S9(8) VALUE 0. 007240 03 CustF-FOUND-FLAG PIC X VALUE 'Y'. 007250 88 CustF-FOUND VALUE 'Y'. 007260 03 CustF-UPDATEPENDING-FLAG PIC X VALUE 'N'. 007270 88 CustF-UPDATEPENDING VALUE 'Y'. 007280 03 CustF-Get4Update-FLAG PIC X VALUE 'N'. 007290 88 CustF-Get4Update VALUE 'Y'. 007300 03 CustF-LastKey PIC 999999 VALUE ZERO. 007310 03 CustF-HighKey PIC XXXXXX VALUE HIGH-VALUES. 007320 03 Parts-ENDFILE PIC X VALUE 'N'. 007330 03 Parts-STATUS PIC S9(8) VALUE 0. 007340 03 Parts-FOUND-FLAG PIC X VALUE 'Y'. 007350 88 Parts-FOUND VALUE 'Y'. 007360 03 Parts-UPDATEPENDING-FLAG PIC X VALUE 'N'. 007370 88 Parts-UPDATEPENDING VALUE 'Y'. 007380 03 Parts-Get4Update-FLAG PIC X VALUE 'N'. 007390 88 Parts-Get4Update VALUE 'Y'. 007400 03 Parts-LastKey PIC S9(4) COMP VALUE ZERO. 007410 03 Parts-HighKey PIC XX VALUE HIGH-VALUES. 007420 03 Orders-ENDFILE PIC X VALUE 'N'. 007430 03 Orders-STATUS PIC S9(8) VALUE 0. 007440 03 Orders-FOUND-FLAG PIC X VALUE 'Y'. 007450 88 Orders-FOUND VALUE 'Y'. 007460 03 Orders-UPDATEPENDING-FLAG PIC X VALUE 'N'. 007470 88 Orders-UPDATEPENDING VALUE 'Y'. 007480 03 Orders-Get4Update-FLAG PIC X VALUE 'N'. 007490 88 Orders-Get4Update VALUE 'Y'. 007500 03 Orders-LastKey PIC S9(5) COMP-3 VALUE ZERO. 007510 03 Orders-HighKey PIC XXX VALUE HIGH-VALUES. 007520 03 TS1-ENDFILE PIC X VALUE 'N'. 007530 03 TS1-STATUS PIC S9(8) VALUE 0. 007540 03 TS1-FOUND-FLAG PIC X VALUE 'Y'. 007550 88 TS1-FOUND VALUE 'Y'. 007560 03 TS1-UPDATEPENDING-FLAG PIC X VALUE 'N'. 007570 88 TS1-UPDATEPENDING VALUE 'Y'. 007580 03 TS1-Get4Update-FLAG PIC X VALUE 'N'. 007590 88 TS1-Get4Update VALUE 'Y'. 007600 03 TS2-ENDFILE PIC X VALUE 'N'. 007610 03 TS2-STATUS PIC S9(8) VALUE 0. 007620 03 TS2-FOUND-FLAG PIC X VALUE 'Y'. 007630 88 TS2-FOUND VALUE 'Y'. 007640 03 TS2-UPDATEPENDING-FLAG PIC X VALUE 'N'. 007650 88 TS2-UPDATEPENDING VALUE 'Y'. 007660 03 TS2-Get4Update-FLAG PIC X VALUE 'N'. 007670 88 TS2-Get4Update VALUE 'Y'. 007680* 007690 01 JZ-TODAY. 007700 05 JZ-DATETIMEGMT. 007710 10 JZ-DATETIME PIC 9(16). 007720 10 JZ-GMTDIFF PIC S9(4). 007730 05 JZ-DATETIME-1 REDEFINES JZ-DATETIMEGMT. 007740 10 JZ-DATE PIC 9(8). 007750 10 JZ-TIME PIC 9(8). 007760 10 FILLER PIC S9(4). 007770 05 JZ-DATETIME-2 REDEFINES JZ-DATETIMEGMT. 007780 10 JZ-YEAR PIC 9(4). 007790 10 JZ-MONTH PIC 9(2). 007800 10 JZ-DAY PIC 9(2). 007810 10 JZ-HOUR PIC 9(2). 007820 10 JZ-MINUTE PIC 9(2). 007830 10 JZ-SECOND PIC 9(2). 007840 10 JZ-MS PIC 9(2). 007850 10 FILLER PIC S9(4). 007860 05 JZ-DATETIME-3 REDEFINES JZ-DATETIMEGMT. 007870 10 FILLER PIC 9(12). 007880 10 JZ-SECONDS PIC 99V99. 007890 10 FILLER PIC S9(4). 007900* Report Time Stamp 007910* 007920 01 JZ-ReportTS. 007930 10 JZ-DAY PIC 9(2). 007940 10 FILLER PIC X VALUE SPACE. 007950 10 JZ-MONTH-NAME PIC X(3). 007960 10 FILLER PIC X VALUE SPACE. 007970 10 JZ-YEAR PIC 9(4). 007980 10 JZ-COMMA PIC XX VALUE ', '. 007990 10 JZ-HOUR PIC 9(2). 008000 10 JZ-SEPCHAR1 PIC X VALUE ':'. 008010 10 JZ-MINUTE PIC 9(2). 008020 10 JZ-SEPCHAR2 PIC X VALUE ':'. 008030 10 JZ-SECOND PIC 9(2). 008040* 008050 01 JZ-ReportTimeStamp REDEFINES JZ-ReportTS PIC X(21). 008060 01 CustF-CheckCopy PIC X(53). 008070* 008080 LOCAL-STORAGE SECTION. 008090****************************************************************** 008100** ** 008110** JZ - Jazz Sundry fields ** 008120** ** 008130****************************************************************** 008140* 008150 01 JZ. 008160 03 JZ-AL PIC S9(4) COMP VALUE ZERO. 008170 03 JZ-ALIM PIC S9(4) COMP VALUE ZERO. 008180 03 JZ-NOFML PIC S9(4) COMP VALUE ZERO. 008190 03 JZ-INDEX PIC S9(4) COMP VALUE ZERO. 008200 03 JZ-INDEX2 PIC S9(4) COMP VALUE ZERO. 008210 03 JZ-IXMth PIC S9(4) COMP VALUE ZERO. 008220 03 IX1 PIC S9(4) COMP VALUE ZERO. 008230 03 IX2 PIC S9(4) COMP VALUE ZERO. 008240 03 IX3 PIC S9(4) COMP VALUE ZERO. 008250 03 IX4 PIC S9(4) COMP VALUE ZERO. 008260 03 IX5 PIC S9(4) COMP VALUE ZERO. 008270 03 IX6 PIC S9(4) COMP VALUE ZERO. 008280 03 IX7 PIC S9(4) COMP VALUE ZERO. 008290 03 JZ-BLANK PIC XXXX VALUE SPACES. 008300 03 JZ-CHAR80 PIC X(80) VALUE SPACES. 008310 03 JZ-FNAME PIC X(30) VALUE SPACES. 008320 03 JZ-KL PIC S9(4) COMP VALUE ZERO. 008330 03 JZ-MLTH PIC S9(4) COMP VALUE ZERO. 008340 03 JZ-INT PIC S9(9) COMP VALUE ZERO. 008350 03 JZ-TRUEFALSE PIC XXXXX VALUE SPACES. 008360 03 JZ-TinyNbr PIC S9(9) COMP VALUE ZERO. 008370 03 JZ-TinyGr REDEFINES JZ-TinyNbr. 008380 05 FILLER PIC XXX. 008390 05 JZ-Tiny PIC X. 008400 03 JZ-Error PIC X VALUE 'N'. 008410 03 JZ-NBR1 PIC 9999 VALUE ZERO. 008420 03 JZ-NBR1X REDEFINES JZ-NBR1 PIC XXXX. 008430 03 JZ-NBR2 PIC 9999 VALUE ZERO. 008440 03 JZ-NBR2X REDEFINES JZ-NBR2 PIC XXXX. 008450 03 JZ-SUBVAL PIC ZZZZZ9 VALUE ZERO. 008460 03 JZ-SUBVALR REDEFINES JZ-SUBVAL PIC X(6). 008470 03 JZ-SUBDIGIT PIC S9(4) COMP VALUE ZERO. 008480 03 JZ-INDEXES OCCURS 7 INDEXED BY JZIX1 PIC X(6) VALUE 008490 SPACES. 008500 03 JZ-INDEXPR PIC X(6) VALUE SPACES. 008510 03 JZFromSub PIC S9(4) COMP VALUE ZERO. 008520 03 JZToSub PIC S9(4) COMP VALUE ZERO. 008530 03 CustF-Name PIC X(30) VALUE SPACES. 008540 03 JZ-N1 PIC S9(4) COMP VALUE ZERO. 008550 03 Orders-OrdCustId PIC 999999 VALUE ZERO. 008560 03 CustF-Account PIC 999999 VALUE ZERO. 008570 03 IsDateArith PIC X VALUE 'N'. 008580 03 DateFormPic PIC 99999999 VALUE ZERO. 008590 03 DateFormPicR REDEFINES DateFormPic. 008600 05 DateFormCYear PIC 9999. 008610 05 DateFormCYearR REDEFINES DateFormCYear. 008620 07 FILLER PIC 99. 008630 07 DateFormYear PIC 99. 008640 05 DateFormMth PIC 99. 008650 05 DateFormDay PIC 99. 008660 03 JZ-DateDiff. 008670 05 DFYears PIC S9(4) COMP VALUE ZERO. 008680 05 DFMonths PIC S9(4) COMP VALUE ZERO. 008690 05 DFDays PIC S9(4) COMP VALUE ZERO. 008700 03 DateFormddbMMMbyy PIC X(9) VALUE SPACES. 008710 03 DateFormddbMMMbyyR REDEFINES DateFormddbMMMbyy. 008720 05 JZ-Day PIC 99. 008730 05 FILLER PIC X. 008740 05 SMth PIC XXX. 008750 05 FILLER PIC X. 008760 05 Year PIC 99. 008770 03 LeapYear PIC X VALUE 'N'. 008780 03 JulianDay PIC S9(3) COMP-3 VALUE ZERO. 008790 03 WJulianDay PIC XXX VALUE SPACES. 008800 03 JZ-CustF-HasChildren PIC X VALUE SPACES. 008810****************************************************************** 008820** ** 008830** ATTRIBUTES ** 008840** ** 008850****************************************************************** 008860* 008870 01 ATTRIBUTES. 008880 03 MDT PIC X VALUE X'41'. 008890****************************************************************** 008900** ** 008910** CICS3C (COMMAREA) ** 008920** ** 008930****************************************************************** 008940* 008950 01 CICS3C. 008960 03 JZ-Function PIC X VALUE 'E'. 008970 03 SAVE. 008980 05 Account PIC 999999 VALUE ZERO. 008990 05 Region PIC S9(3) COMP-3 VALUE ZERO. 009000 05 District PIC S9(3) COMP-3 VALUE ZERO. 009010 05 JZ-Name PIC X(30) VALUE SPACES. 009020 05 SalesThisMonth PIC S9(5)V9(2) COMP-3 VALUE ZERO. 009030 05 SalesYTD PIC S9(5)V9(2) COMP-3 VALUE ZERO. 009040 05 Billingcycle PIC X VALUE LOW-VALUE. 009050 05 DateCommenced PIC S9(9) COMP VALUE ZERO. 009060 03 JZ-XCTL PIC X VALUE 'N'. 009070 03 TS1QName PIC X(16) VALUE SPACES. 009080 03 TS1Current-Record PIC S9(4) COMP VALUE ZERO. 009090 03 TS1Record-Count PIC S9(4) COMP VALUE ZERO. 009100 03 TS1Start PIC S9(4) COMP VALUE ZERO. 009110 03 TS2QName PIC X(16) VALUE SPACES. 009120 03 TS2Current-Record PIC S9(4) COMP VALUE ZERO. 009130 03 TS2Record-Count PIC S9(4) COMP VALUE ZERO. 009140 03 TS2Start PIC S9(4) COMP VALUE ZERO. 009150****************************************************************** 009160** ** 009170** JZSMth ** 009180** ** 009190****************************************************************** 009200* 009210 01 JZSMth. 009220 03 SMth PIC S9(4) COMP VALUE ZERO. 009230****************************************************************** 009240** ** 009250** JZMDays ** 009260** ** 009270****************************************************************** 009280* 009290 01 JZMDays. 009300 03 MDayG. 009310 05 Jan PIC S9(4) COMP VALUE 31. 009320 05 Feb PIC S9(4) COMP VALUE 28. 009330 05 Mar PIC S9(4) COMP VALUE 31. 009340 05 Apr PIC S9(4) COMP VALUE 30. 009350 05 May PIC S9(4) COMP VALUE 31. 009360 05 Jun PIC S9(4) COMP VALUE 30. 009370 05 Jul PIC S9(4) COMP VALUE 31. 009380 05 Aug PIC S9(4) COMP VALUE 31. 009390 05 Sep PIC S9(4) COMP VALUE 30. 009400 05 Oct PIC S9(4) COMP VALUE 31. 009410 05 Nov PIC S9(4) COMP VALUE 30. 009420 05 Dec PIC S9(4) COMP VALUE 31. 009430 03 MDayR REDEFINES MDayG OCCURS 12 INDEXED BY JZIX3 PIC 009440 S9(4) COMP. 009450 03 CDayG. 009460 05 Jan PIC S9(4) COMP VALUE 31. 009470 05 Feb PIC S9(4) COMP VALUE 59. 009480 05 Mar PIC S9(4) COMP VALUE 90. 009490 05 Apr PIC S9(4) COMP VALUE 120. 009500 05 May PIC S9(4) COMP VALUE 151. 009510 05 Jun PIC S9(4) COMP VALUE 181. 009520 05 Jul PIC S9(4) COMP VALUE 212. 009530 05 Aug PIC S9(4) COMP VALUE 243. 009540 05 Sep PIC S9(4) COMP VALUE 273. 009550 05 Oct PIC S9(4) COMP VALUE 304. 009560 05 Nov PIC S9(4) COMP VALUE 334. 009570 05 Dec PIC S9(4) COMP VALUE 365. 009580 03 CDayR REDEFINES CDayG OCCURS 12 INDEXED BY JZIX4 PIC 009590 S9(4) COMP. 009600****************************************************************** 009610** ** 009620** CICS4C ** 009630** ** 009640****************************************************************** 009650* 009660 01 CICS4C. 009670 03 JZ-Function PIC X VALUE 'E'. 009680 03 SAVE. 009690 05 OrdNbr PIC S9(5) COMP-3 VALUE ZERO. 009700 05 OrdCustId PIC 999999 VALUE ZERO. 009710 05 ordDate PIC S9(9) COMP VALUE ZERO. 009720 05 OrdPart PIC S9(4) COMP VALUE ZERO. 009730 05 OrdQty PIC S9(4) COMP VALUE ZERO. 009740 05 OrdDiscount PIC S9(2)V9(1) COMP-3 VALUE ZERO. 009750 05 OrdStatus PIC X VALUE SPACES. 009760 03 JZ-XCTL PIC X VALUE 'N'. 009770****************************************************************** 009780** ** 009790** TS1 ** 009800** ** 009810****************************************************************** 009820* 009830 01 TS1. 009840 03 Account PIC 999999 VALUE ZERO. 009850****************************************************************** 009860** ** 009870** TS2 ** 009880** ** 009890****************************************************************** 009900* 009910 01 TS2. 009920 03 OrdNbr PIC S9(5) COMP-3 VALUE ZERO. 009930****************************************************************** 009940** ** 009950** Code Tables ** 009960** ** 009970****************************************************************** 009980* 009990* Types.Month 010000 01 JZCodes-Types-Month. 010010 03 JZValues. 010020 05 FILLER PIC X(9) VALUE 'January '. 010030 05 FILLER PIC X(9) VALUE 'February '. 010040 05 FILLER PIC X(9) VALUE 'March '. 010050 05 FILLER PIC X(9) VALUE 'April '. 010060 05 FILLER PIC X(9) VALUE 'May '. 010070 05 FILLER PIC X(9) VALUE 'June '. 010080 05 FILLER PIC X(9) VALUE 'July '. 010090 05 FILLER PIC X(9) VALUE 'August '. 010100 05 FILLER PIC X(9) VALUE 'September'. 010110 05 FILLER PIC X(9) VALUE 'October '. 010120 05 FILLER PIC X(9) VALUE 'November '. 010130 05 FILLER PIC X(9) VALUE 'December '. 010140 03 JZTABLE REDEFINES JZValues. 010150 05 ITEM-VALUES OCCURS 12 INDEXED BY JZIX-Types-Month. 010160 07 CODE-VALUE PIC X(9). 010170 03 FILLER. 010180 05 SEARCH-FOR PIC S9(4) COMP. 010190 05 FOUND-VALUE PIC X(9) VALUE '*********'. 010200* 010210* Orders.OrdStatus 010220 01 JZCodes-Orders-OrdStatus. 010230 03 JZValues. 010240 05 FILLER PIC X(13) VALUE 'IInitial '. 010250 05 FILLER PIC X(13) VALUE 'CConfirmed '. 010260 05 FILLER PIC X(13) VALUE 'QPart Shipped'. 010270 05 FILLER PIC X(13) VALUE 'SShipped '. 010280 05 FILLER PIC X(13) VALUE 'BBilled '. 010290 05 FILLER PIC X(13) VALUE 'PPaid '. 010300 03 JZTABLE REDEFINES JZValues. 010310 05 ITEM-VALUES OCCURS 6 INDEXED BY 010320 JZIX-Orders-OrdStatus. 010330 07 JZCODE PIC X. 010340 07 CODE-VALUE PIC X(12). 010350 03 FILLER. 010360 05 SEARCH-FOR PIC X. 010370 05 FOUND-VALUE PIC X(12) VALUE '************'. 010380* 010390* CICS3C.Function 010400 01 JZCodes-CICS3C-Function. 010410 03 JZValues. 010420 05 FILLER PIC X(8) VALUE 'EEnquiry'. 010430 05 FILLER PIC X(8) VALUE 'UUpdate '. 010440 05 FILLER PIC X(8) VALUE 'AAdd '. 010450 05 FILLER PIC X(8) VALUE 'DDelete '. 010460 05 FILLER PIC X(8) VALUE 'ROrder '. 010470 03 JZTABLE REDEFINES JZValues. 010480 05 ITEM-VALUES OCCURS 5 INDEXED BY JZIX-CICS3C-Function. 010490 07 JZCODE PIC X. 010500 07 CODE-VALUE PIC X(7). 010510 03 FILLER. 010520 05 SEARCH-FOR PIC X. 010530 05 FOUND-VALUE PIC X(7) VALUE '*******'. 010540* 010550* JZSMth.SMth 010560 01 JZCodes-JZSMth-SMth. 010570 03 JZValues. 010580 05 FILLER PIC X(3) VALUE 'Jan'. 010590 05 FILLER PIC X(3) VALUE 'Feb'. 010600 05 FILLER PIC X(3) VALUE 'Mar'. 010610 05 FILLER PIC X(3) VALUE 'Apr'. 010620 05 FILLER PIC X(3) VALUE 'May'. 010630 05 FILLER PIC X(3) VALUE 'Jun'. 010640 05 FILLER PIC X(3) VALUE 'Jul'. 010650 05 FILLER PIC X(3) VALUE 'Aug'. 010660 05 FILLER PIC X(3) VALUE 'Sep'. 010670 05 FILLER PIC X(3) VALUE 'Oct'. 010680 05 FILLER PIC X(3) VALUE 'Nov'. 010690 05 FILLER PIC X(3) VALUE 'Dec'. 010700 03 JZTABLE REDEFINES JZValues. 010710 05 ITEM-VALUES OCCURS 12 INDEXED BY JZIX-JZSMth-SMth. 010720 07 CODE-VALUE PIC X(3). 010730 03 FILLER. 010740 05 SEARCH-FOR PIC S9(4) COMP. 010750 05 FOUND-VALUE PIC X(3) VALUE '***'. 010760****************************************************************** 010770** ** 010780** Linkage Section: Commarea ** 010790** ** 010800****************************************************************** 010810* 010820 LINKAGE SECTION. 010830* 010840 01 DFHCOMMAREA. 010850 05 JZ-Function PIC X. 010860 05 SAVE. 010870 07 Account PIC 999999. 010880 07 Region PIC S9(3) COMP-3. 010890 07 District PIC S9(3) COMP-3. 010900 07 JZ-Name PIC X(30). 010910 07 SalesThisMonth PIC S9(5)V9(2) COMP-3. 010920 07 SalesYTD PIC S9(5)V9(2) COMP-3. 010930 07 Billingcycle PIC X. 010940 07 DateCommenced PIC S9(9) COMP. 010950 05 JZ-XCTL PIC X. 010960 05 TS1QName PIC X(16). 010970 05 TS1Current-Record PIC S9(4) COMP. 010980 05 TS1Record-Count PIC S9(4) COMP. 010990 05 TS1Start PIC S9(4) COMP. 011000 05 TS2QName PIC X(16). 011010 05 TS2Current-Record PIC S9(4) COMP. 011020 05 TS2Record-Count PIC S9(4) COMP. 011030 05 TS2Start PIC S9(4) COMP. 011040****************************************************************** 011050** ** 011060** Procedure Division. ** 011070** ** 011080****************************************************************** 011090* 011100 PROCEDURE DIVISION. 011110 EXEC CICS 011120 HANDLE ABEND LABEL(JZ-Abend-Exit) RESP(JZ-RESPONSE) 011130 END-EXEC. 011140 PERFORM CICS-CheckStatus. 011150 MOVE FUNCTION CURRENT-DATE TO JZ-TODAY. 011160 PERFORM JZDT01. 011170* No message is returned with CLEAR or PA1-3 011180 IF EIBAID = DFHCLEAR OR DFHPA1 OR DFHPA2 OR DFHPA3 011190 GO TO JZ-Main-Program-Logic 011200 END-IF. 011210* Check that there is a message to read 011220 IF EIBCALEN = 0 011230 MOVE LOW-VALUE TO CICS3S 011240 MOVE 'E' TO OUT OF JZ-Function OF CICS3S 011250 MOVE '011240 SEND MAP(''CICS3S'') FROM(CICS3S) ERASE' TO 011260 JZ-CICS-Stmt 011270 EXEC CICS 011280 SEND MAP('CICS3S') FROM(CICS3S) ERASE RESP(JZ-RESPONSE) 011290 END-EXEC 011300 PERFORM CICS-CheckStatus 011310* Read Input Screen 011320 Else 011330 MOVE DFHCOMMAREA TO CICS3C 011340 IF JZ-XCTL OF CICS3C = 'Y' 011350* MOVE 'N' TO JZ-XCTL OF CICS3C in JZ-SEND-INSCREEN 011360 MOVE LOW-VALUES TO CICS3S 011370* Restore SAVE fields 011380 MOVE SAVE OF CICS3C TO JZ-CustF 011390 PERFORM JZ-SEND-INSCREEN 011400 END-IF 011410 MOVE '011400 RECEIVE MAP(''CICS3S'') INTO(CICS3S)' TO 011420 JZ-CICS-Stmt 011430 EXEC CICS 011440 RECEIVE MAP('CICS3S') INTO(CICS3S) RESP(JZ-RESPONSE) 011450 END-EXEC 011460 PERFORM CICS-CheckStatus 011470* Clear error flags (in case prior ACCEPT found errors) 011480 MOVE SPACE TO OUT OF EFLD8 OF CICS3S 011490 MOVE SPACE TO OUT OF EFLD11 OF CICS3S 011500 MOVE SPACE TO OUT OF EFLD29 OF CICS3S 011510 MOVE SPACE TO OUT OF EFLD31 OF CICS3S 011520 MOVE SPACE TO OUT OF EFLD33 OF CICS3S 011530 MOVE SPACE TO OUT OF EFLD35 OF CICS3S 011540 MOVE SPACE TO OUT OF EFLD39 OF CICS3S 011550 MOVE SPACES TO OUT OF JZ-Error OF CICS3S 011560 MOVE ZERO TO LTH OF JZ-Error OF CICS3S 011570 MOVE 'N' TO JZ-Error OF JZ 011580 PERFORM JZ-SET-AidHelp 011590 PERFORM JZ-Main-Program-Logic 011600 END-IF. 011610* 011620 JZ-Normal-Exit. 011630 IF CustF-UpdatePending-Flag = 'Y' 011640* Update not done - probably because of Accept-detected errors 011650 MOVE '011640 UNLOCK FILE(''CUSTF'')' TO JZ-CICS-Stmt 011660 EXEC CICS 011670 UNLOCK FILE('CUSTF') RESP(JZ-RESPONSE) 011680 END-EXEC 011690 PERFORM CICS-CheckStatus 011700 END-IF. 011710 MOVE '011700 RETURN TRANSID(''TRN3'') COMMAREA(CICS3C)' TO 011720 JZ-CICS-Stmt. 011730 EXEC CICS 011740 RETURN TRANSID('TRN3') COMMAREA(CICS3C) RESP(JZ-RESPONSE) 011750 END-EXEC. 011760 GOBACK. 011770* 011780 JZ-Abend-Exit. 011790* BR14 does nothing, but is useful for CEDF/CEDX debugging 011800 EXEC CICS LINK PROGRAM('JZBR14 ') COMMAREA(JZ-Program-Info) 011810 END-EXEC. 011820 CALL 'JZABNDC' USING DFHEIBLK DFHCOMMAREA JZ-Program-Info. 011830* 011840 JZ-Restart. 011850 EXEC CICS 011860 RETURN TRANSID('TRN3') RESP(JZ-RESPONSE) 011870 END-EXEC. 011880 GOBACK. 011890****************************************************************** 011900** ** 011910** Main Program Logic ** 011920** ** 011930****************************************************************** 011940* 011950 JZ-Main-Program-Logic. 011960* 011970* Detect and handle Aid Keys 011980 EVALUATE EIBAID 011990 WHEN DFHENTER 012000 PERFORM JZ-AID-ENTER 012010 WHEN DFHCLEAR 012020 PERFORM JZ-AID-CLEAR 012030 WHEN DFHPF3 012040 PERFORM JZ-AID-PF3 012050 WHEN DFHPF7 012060 PERFORM JZ-AID-PF7 012070 WHEN DFHPF8 012080 PERFORM JZ-AID-PF8 012090 WHEN DFHPF10 012100 PERFORM JZ-AID-PF10 012110 WHEN DFHPF11 012120 PERFORM JZ-AID-PF11 012130 WHEN DFHPF12 012140 PERFORM JZ-AID-PF12 012150 WHEN OTHER 012160 PERFORM JZ-AID-OTHER 012170 END-EVALUATE. 012180 GO TO JZ-NORMAL-EXIT. 012190****************************************************************** 012200** ** 012210** Process Default AID keys ** 012220** ** 012230****************************************************************** 012240* 012250 JZ-AID-CLEAR. 012260 MOVE '012250 SEND TEXT FROM(JZ-BLANK) ERASE FREEKB' TO 012270 JZ-CICS-Stmt. 012280 EXEC CICS 012290 SEND TEXT FROM(JZ-BLANK) ERASE FREEKB RESP(JZ-RESPONSE) 012300 END-EXEC. 012310 PERFORM CICS-CheckStatus. 012320 GOBACK. 012330* 012340 JZ-AID-PF3. 012350 PERFORM JZ-DeleteAllTS. 012360 MOVE '012350 XCTL PROGRAM(''CICS3'')' TO JZ-CICS-Stmt. 012370 EXEC CICS 012380 XCTL PROGRAM('CICS3') RESP(JZ-RESPONSE) 012390 END-EXEC. 012400 PERFORM CICS-CheckStatus. 012410* 012420 JZ-AID-PF7. 012430 IF TS2Current-Record OF CICS3C > 1 012440 SUBTRACT 25 FROM TS2Current-Record OF CICS3C 012450 IF TS2Current-Record OF CICS3C < 1 012460 MOVE 1 TO TS2Current-Record OF CICS3C 012470 END-IF 012480 MOVE TS2Current-Record OF CICS3C TO TS2Start OF CICS3C 012490 PERFORM JZ-SET-AIDHELP 012500 MOVE CORRESPONDING SAVE OF DFHCOMMAREA TO JZ-CustF 012510 PERFORM JZ-SEND-INSCREEN 012520 Else 012530 MOVE 'PF7 Disabled - outside range of records' TO OUT OF 012540 JZ-Error OF CICS3S 012550 MOVE '012540 SEND MAP(''CICS3S'') FROM(CICS3S) ALARM DATA 012560- 'ONLY FREEKB' TO JZ-CICS-Stmt 012570 EXEC CICS 012580 SEND MAP('CICS3S') FROM(CICS3S) ALARM DATAONLY FREEKB 012590 RESP(JZ-RESPONSE) 012600 END-EXEC 012610 PERFORM CICS-CheckStatus 012620 GO TO JZ-NORMAL-EXIT 012630 END-IF. 012640* 012650 JZ-AID-PF8. 012660 IF TS2Current-Record OF CICS3C < TS2Record-Count OF CICS3C 012670 ADD 1 TO TS2Current-Record OF CICS3C 012680 MOVE TS2Current-Record OF CICS3C TO TS2Start OF CICS3C 012690 PERFORM JZ-SET-AIDHELP 012700 MOVE CORRESPONDING SAVE OF DFHCOMMAREA TO JZ-CustF 012710 PERFORM JZ-SEND-INSCREEN 012720 Else 012730 MOVE 'PF8 Disabled - outside range of records' TO OUT OF 012740 JZ-Error OF CICS3S 012750 MOVE '012740 SEND MAP(''CICS3S'') FROM(CICS3S) ALARM DATA 012760- 'ONLY FREEKB' TO JZ-CICS-Stmt 012770 EXEC CICS 012780 SEND MAP('CICS3S') FROM(CICS3S) ALARM DATAONLY FREEKB 012790 RESP(JZ-RESPONSE) 012800 END-EXEC 012810 PERFORM CICS-CheckStatus 012820 GO TO JZ-NORMAL-EXIT 012830 END-IF. 012840* 012850 JZ-AID-PF10. 012860 IF TS1Current-Record OF CICS3C > 1 012870 SUBTRACT 1 FROM TS1Current-Record OF CICS3C 012880 PERFORM JZ-SET-AIDHELP 012890 PERFORM JZ-READ-TS1 012900 PERFORM JZ-SEND-INSCREEN 012910 Else 012920 MOVE 'PF10 Disabled - outside range of Previous/Next reco 012930- 'rds' TO OUT OF JZ-Error OF CICS3S 012940 MOVE '012930 SEND MAP(''CICS3S'') FROM(CICS3S) ALARM DATA 012950- 'ONLY FREEKB' TO JZ-CICS-Stmt 012960 EXEC CICS 012970 SEND MAP('CICS3S') FROM(CICS3S) ALARM DATAONLY FREEKB 012980 RESP(JZ-RESPONSE) 012990 END-EXEC 013000 PERFORM CICS-CheckStatus 013010 GO TO JZ-NORMAL-EXIT 013020 END-IF. 013030* 013040 JZ-AID-PF11. 013050 IF TS1Current-Record OF CICS3C < TS1Record-Count OF CICS3C 013060 ADD 1 TO TS1Current-Record OF CICS3C 013070 PERFORM JZ-SET-AIDHELP 013080 PERFORM JZ-READ-TS1 013090 PERFORM JZ-SEND-INSCREEN 013100 Else 013110 MOVE 'PF11 Disabled - outside range of Previous/Next reco 013120- 'rds' TO OUT OF JZ-Error OF CICS3S 013130 MOVE '013120 SEND MAP(''CICS3S'') FROM(CICS3S) ALARM DATA 013140- 'ONLY FREEKB' TO JZ-CICS-Stmt 013150 EXEC CICS 013160 SEND MAP('CICS3S') FROM(CICS3S) ALARM DATAONLY FREEKB 013170 RESP(JZ-RESPONSE) 013180 END-EXEC 013190 PERFORM CICS-CheckStatus 013200 GO TO JZ-NORMAL-EXIT 013210 END-IF. 013220* 013230 JZ-AID-PF12. 013240 PERFORM JZ-DeleteAllTS. 013250 MOVE '013240 XCTL PROGRAM(''MENU1'')' TO JZ-CICS-Stmt. 013260 EXEC CICS 013270 XCTL PROGRAM('MENU1') RESP(JZ-RESPONSE) 013280 END-EXEC. 013290 PERFORM CICS-CheckStatus. 013300 GOBACK. 013310* 013320 JZ-AID-OTHER. 013330 MOVE 'INVALID FUNCTION KEY' TO OUT OF JZ-Error OF CICS3S. 013340 MOVE '013330 SEND MAP(''CICS3S'') FROM(CICS3S) ALARM DATAONLY 013350- ' FREEKB' TO JZ-CICS-Stmt. 013360 EXEC CICS 013370 SEND MAP('CICS3S') FROM(CICS3S) ALARM DATAONLY FREEKB 013380 RESP(JZ-RESPONSE) 013390 END-EXEC. 013400 PERFORM CICS-CheckStatus. 013410 GO TO JZ-NORMAL-EXIT. 013420* 013430 JZ-AID-ENTER. 013440****************************************************************** 013450** ** 013460** Normal Processing Logic (ENTER clicked) ** 013470** ** 013480****************************************************************** 013490* ACCEPT (CICS3S.Function); 013500 PERFORM JZ-42-ACCEPT. 013510* CASE (CICS3C.Function); 013520 EVALUATE JZ-Function OF CICS3C 013530* WHEN (Enquiry); 013540 When 'E' 013550 PERFORM JZ-44-WHEN 013560* WHEN (Update); 013570 When 'U' 013580 PERFORM JZ-57-WHEN 013590* WHEN (Add); 013600 When 'A' 013610 PERFORM JZ-61-WHEN 013620* WHEN (Delete); 013630 When 'D' 013640 PERFORM JZ-66-WHEN 013650* WHEN (Order); 013660 When 'R' 013670 PERFORM JZ-68-WHEN 013680 END-EVALUATE. 013690* SEND Inscreen; 013700 PERFORM JZ-76-SEND-Inscreen. 013710* 013720 JZ-42-ACCEPT. 013730* ACCEPT (CICS3S.Function); 013740 MOVE 'N' TO JZ-Error OF JZ. 013750* Validate CICS3S.Function, assign to CICS3C.Function 013760 MOVE SPACES TO JZ-CHAR80. 013770 MOVE 'Function' TO JZ-FNAME. 013780 IF LTH OF JZ-Function OF CICS3S > ZERO 013790 MOVE INPT OF JZ-Function OF CICS3S TO JZ-Function OF CICS3C 013800 END-IF. 013810* Check Code Values 013820 MOVE JZ-Function OF CICS3C TO SEARCH-FOR OF 013830 JZCodes-CICS3C-Function. 013840 PERFORM JZCvt-CICS3C-Function. 013850 MOVE FOUND-VALUE OF JZCodes-CICS3C-Function TO OUT OF EFLD13 013860 OF CICS3S. 013870 IF JZ-CHAR80 NOT = SPACE 013880 MOVE 'Y' TO JZ-Error OF JZ 013890 MOVE '*' TO OUT OF EFLD13 OF CICS3S 013900 MOVE -1 TO LTH OF JZ-Function OF CICS3S 013910 MOVE 80 TO JZ-MLTH 013920 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 013930 CICS3S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 013940 END-IF. 013950 IF JZ-Error OF JZ = 'Y' 013960* Respond with error messages and exit program 013970 MOVE '013960 SEND MAP(''CICS3S'') FROM(CICS3S) CURSOR ALA 013980- 'RM' TO JZ-CICS-Stmt 013990 EXEC CICS 014000 SEND MAP('CICS3S') FROM(CICS3S) CURSOR ALARM 014010 RESP(JZ-RESPONSE) 014020 END-EXEC 014030 PERFORM CICS-CheckStatus 014040 GO TO JZ-Normal-Exit 014050 END-IF. 014060* 014070* WHEN (Enquiry); 014080 JZ-44-WHEN. 014090* ACCEPT (CICS3S.Account OR CICS3S.Name); 014100 PERFORM JZ-45-ACCEPT. 014110* GET Custf KEY(CustF.Account OR CustF.Name) SAVECOPY 014120* CICS3C.SAVE TS(1); 014130 PERFORM JZ-47-GET. 014140* 014150 JZ-45-ACCEPT. 014160* ACCEPT (CICS3S.Account OR CICS3S.Name); 014170 MOVE 'N' TO JZ-Error OF JZ. 014180* Validate CICS3S.Account, assign to CustF.Account 014190 MOVE SPACES TO JZ-CHAR80. 014200 MOVE 'Account' TO JZ-FNAME. 014210 IF LTH OF Account OF CICS3S > ZERO 014220 IF INPT OF Account OF CICS3S IS NUMERIC 014230 COMPUTE Account OF JZ-CustF = FUNCTION NUMVAL(INPT OF 014240 Account OF CICS3S) 014250 ELSE 014260 MOVE 'not numeric' TO JZ-CHAR80 014270 END-IF 014280 ELSE 014290 MOVE ZERO TO Account OF JZ-CustF 014300 END-IF. 014310 IF JZ-CHAR80 NOT = SPACE 014320 MOVE 'Y' TO JZ-Error OF JZ 014330 MOVE '*' TO OUT OF EFLD8 OF CICS3S 014340 MOVE -1 TO LTH OF Account OF CICS3S 014350 MOVE 80 TO JZ-MLTH 014360 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 014370 CICS3S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 014380 END-IF. 014390* Validate CICS3S.Name, assign to CustF.Name 014400 MOVE SPACES TO JZ-CHAR80. 014410 MOVE 'Name' TO JZ-FNAME. 014420 IF LTH OF JZ-Name OF CICS3S > ZERO 014430 MOVE INPT OF JZ-Name OF CICS3S TO JZ-Name OF JZ-CustF 014440* Test that one of the OR-list fields are present 014450 IF Account OF JZ-CustF = ZERO AND JZ-Name OF JZ-CustF = 014460 SPACES 014470 MOVE 'value required' TO JZ-CHAR80 014480 MOVE 'Account,Name' TO JZ-FNAME 014490 END-IF 014500 END-IF. 014510 IF JZ-CHAR80 NOT = SPACE 014520 MOVE 'Y' TO JZ-Error OF JZ 014530 MOVE '*' TO OUT OF EFLD11 OF CICS3S 014540 MOVE -1 TO LTH OF JZ-Name OF CICS3S 014550 MOVE 80 TO JZ-MLTH 014560 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 014570 CICS3S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 014580 END-IF. 014590 IF JZ-Error OF JZ = 'Y' 014600* Respond with error messages and exit program 014610 MOVE '014600 SEND MAP(''CICS3S'') FROM(CICS3S) CURSOR ALA 014620- 'RM' TO JZ-CICS-Stmt 014630 EXEC CICS 014640 SEND MAP('CICS3S') FROM(CICS3S) CURSOR ALARM 014650 RESP(JZ-RESPONSE) 014660 END-EXEC 014670 PERFORM CICS-CheckStatus 014680 GO TO JZ-Normal-Exit 014690 END-IF. 014700* 014710 JZ-47-GET. 014720* GET Custf KEY(CustF.Account OR CustF.Name) SAVECOPY 014730* CICS3C.SAVE TS(1); 014740 MOVE 'N' TO CUSTF-Get4Update-FLAG. 014750 IF Account OF JZ-CustF NOT = ZERO 014760 PERFORM JZ-CustF-ReadBy1ryKey 014770 PERFORM JZ-47-GETGroup 014780 MOVE ZERO TO TS1Record-Count OF CICS3C 014790 MOVE ZERO TO TS1Current-Record OF CICS3C 014800 PERFORM JZ-SET-AIDHELP 014810 ELSE 014820 IF JZ-Name OF JZ-CustF NOT = SPACES 014830 MOVE LTH OF JZ-Name OF CICS3S TO JZ-KL 014840* Set unique name for TS Queue 014850 MOVE EIBTRMID TO TS1QName OF CICS3C(1:4) 014860 MOVE 'CICS3' TO TS1QName OF CICS3C(5:7) 014870 MOVE 'TS1' TO TS1QName OF CICS3C(12:5) 014880* Read relevant record keys into TS (Temporary Storage) 014890* Initialize TS and its control fields 014900 MOVE ZERO TO TS1Record-Count OF CICS3C 014910 MOVE ZERO TO TS1Current-Record OF CICS3C 014920 MOVE '014910 DELETEQ TS QNAME(TS1QName OF CICS3C)' TO 014930 JZ-CICS-Stmt 014940 EXEC CICS 014950 DELETEQ TS QNAME(TS1QName OF CICS3C) 014960 RESP(JZ-RESPONSE) 014970 END-EXEC 014980 MOVE 'N' TO CUSTF-ENDFILE 014990 MOVE 'N' TO CUSTF-FOUND-FLAG 015000 MOVE JZ-Name OF JZ-CustF(1:JZ-KL) TO CustF-Name OF JZ 015010 IF JZ-KL NOT = 30 015020 MOVE '015010 STARTBR FILE(''CUSTF1'') RIDFLD(JZ-N 015030- 'ame OF JZ-CustF) GENERIC KEYLENGTH(JZ-KL) EQ 015040- 'UA' TO JZ-CICS-Stmt 015050 EXEC CICS 015060 STARTBR FILE('CUSTF1') RIDFLD(JZ-Name OF 015070 JZ-CustF) GENERIC KEYLENGTH(JZ-KL) EQUAL 015080 RESP(JZ-RESPONSE) 015090 END-EXEC 015100 ELSE 015110 MOVE '015100 STARTBR FILE(''CUSTF1'') RIDFLD(JZ-N 015120- 'ame OF JZ-CustF)' TO JZ-CICS-Stmt 015130 EXEC CICS 015140 STARTBR FILE('CUSTF1') RIDFLD(JZ-Name OF 015150 JZ-CustF) RESP(JZ-RESPONSE) 015160 END-EXEC 015170 END-IF 015180 IF JZ-Response = DFHRESP(NORMAL) OR JZ-Response = 015190 DFHRESP(DUPKEY) 015200 PERFORM UNTIL CUSTF-ENDFILE = 'Y' 015210 IF JZ-KL NOT = 30 015220 MOVE '015210 READNEXT FILE(''CUSTF1'') IN 015230- 'TO(JZ-CustF) RIDFLD(JZ-Name OF JZ-Cu 015240- 'stF) KEYLENGTH(JZ-' TO JZ-CICS-Stmt 015250 EXEC CICS 015260 READNEXT FILE('CUSTF1') 015270 INTO(JZ-CustF) RIDFLD(JZ-Name OF 015280 JZ-CustF) KEYLENGTH(JZ-KL) 015290 RESP(JZ-RESPONSE) 015300 END-EXEC 015310 ELSE 015320 MOVE '015310 READNEXT FILE(''CUSTF1'') IN 015330- 'TO(JZ-CustF) RIDFLD(JZ-Name OF JZ-Cu 015340- 'stF)' TO JZ-CICS-Stmt 015350 EXEC CICS 015360 READNEXT FILE('CUSTF1') 015370 INTO(JZ-CustF) RIDFLD(JZ-Name OF 015380 JZ-CustF) RESP(JZ-RESPONSE) 015390 END-EXEC 015400 END-IF 015410* Check that READNEXT hasn't run past end 015420 IF JZ-RESPONSE = DFHRESP(ENDFILE) OR JZ-Name 015430 OF JZ-CustF(1:JZ-KL) NOT = CustF-Name OF 015440 JZ(1:JZ-KL) 015450 MOVE 'Y' TO CUSTF-ENDFILE 015460 END-IF 015470 IF CUSTF-ENDFILE = 'N' 015480 MOVE Account OF JZ-CustF TO Account OF TS1 015490 MOVE '015480 WRITEQ TS QNAME(TS1QName OF 015500- 'CICS3C) FROM(TS1) MAIN NUMITEMS(TS1R 015510- 'ecord-Count OF C' TO JZ-CICS-Stmt 015520 EXEC CICS 015530 WRITEQ TS QNAME(TS1QName OF CICS3C) 015540 FROM(TS1) MAIN 015550 NUMITEMS(TS1Record-Count OF 015560 CICS3C) RESP(JZ-RESPONSE) 015570 END-EXEC 015580 END-IF 015590 END-PERFORM 015600 MOVE '015590 ENDBR FILE(''CUSTF1'')' TO JZ-CICS-Stmt 015610 EXEC CICS 015620 ENDBR FILE('CUSTF1') RESP(JZ-RESPONSE) 015630 END-EXEC 015640 ELSE 015650 MOVE 'Y' TO CUSTF-ENDFILE 015660 END-IF 015670 IF TS1Record-Count OF CICS3C > 0 015680* Read 1st record 015690 MOVE 1 TO TS1Current-Record OF CICS3C 015700 PERFORM JZ-READ-TS1 015710 ELSE 015720 MOVE 'N' TO CUSTF-Found-Flag 015730 PERFORM CUSTF-Initialize 015740 MOVE ZERO TO Account OF JZ-CustF 015750 MOVE CustF-Name OF JZ TO JZ-Name OF JZ-CustF 015760 PERFORM JZ-47-GETGroup 015770 END-IF 015780 PERFORM JZ-SET-AIDHELP 015790 ELSE 015800 MOVE DFHRESP(NOTFND) TO JZ-RESPONSE 015810 END-IF 015820 END-IF. 015830* 015840 JZ-47-GETGroup. 015850* PROCESS Orders WHERE (Orders.OrdCustId = CustF.Account) 015860* INDEX JZ-N1 TS(2); 015870 PERFORM JZ-49-PROCESS. 015880* END GET Custf RESETFUNCTION; 015890* Save copy for later UPDATE CHECKCOPY 015900 MOVE JZ-CustF TO SAVE OF CICS3C. 015910 PERFORM JZ-CustF-ResetFunction. 015920* 015930 JZ-49-PROCESS. 015940* PROCESS Orders WHERE (Orders.OrdCustId = CustF.Account) 015950* INDEX JZ-N1 TS(2); 015960 MOVE Account OF JZ-CustF TO OrdCustId OF JZ-Orders. 015970* Reset Start if parent record has changed 015980 IF Account OF JZ-CustF NOT = Account OF SAVE OF CICS3C 015990 MOVE 1 TO TS2Start OF CICS3C 016000 END-IF. 016010* Set unique name for TS Queue 016020 MOVE EIBTRMID TO TS2QName OF CICS3C(1:4). 016030 MOVE 'CICS3' TO TS2QName OF CICS3C(5:7). 016040 MOVE 'TS2' TO TS2QName OF CICS3C(12:5). 016050* Read relevant record keys into TS (Temporary Storage) 016060* Initialize TS and its control fields 016070 MOVE ZERO TO TS2Record-Count OF CICS3C. 016080 MOVE ZERO TO TS2Current-Record OF CICS3C. 016090 MOVE '016080 DELETEQ TS QNAME(TS2QName OF CICS3C)' TO 016100 JZ-CICS-Stmt. 016110 EXEC CICS 016120 DELETEQ TS QNAME(TS2QName OF CICS3C) RESP(JZ-RESPONSE) 016130 END-EXEC. 016140 MOVE 'N' TO ORDERS-ENDFILE. 016150 MOVE 'N' TO ORDERS-FOUND-FLAG. 016160 MOVE OrdCustId OF JZ-Orders TO Orders-OrdCustId OF JZ. 016170 MOVE ZERO TO JZ-N1 OF JZ. 016180 MOVE '016170 STARTBR FILE(''ORDERS1'') RIDFLD(OrdCustId OF JZ 016190- '-Orders)' TO JZ-CICS-Stmt. 016200 EXEC CICS 016210 STARTBR FILE('ORDERS1') RIDFLD(OrdCustId OF JZ-Orders) 016220 RESP(JZ-RESPONSE) 016230 END-EXEC. 016240 IF JZ-Response = DFHRESP(NORMAL) OR JZ-Response = 016250 DFHRESP(DUPKEY) 016260 PERFORM UNTIL ORDERS-ENDFILE = 'Y' 016270 MOVE '016260 READNEXT FILE(''ORDERS1'') INTO(JZ-Order 016280- 's) RIDFLD(OrdCustId OF JZ-Orders)' TO JZ-CICS-Stmt 016290 EXEC CICS 016300 READNEXT FILE('ORDERS1') INTO(JZ-Orders) 016310 RIDFLD(OrdCustId OF JZ-Orders) RESP(JZ-RESPONSE) 016320 END-EXEC 016330* Check that READNEXT hasn't run past end 016340 IF JZ-RESPONSE = DFHRESP(ENDFILE) OR OrdCustId OF 016350 JZ-Orders NOT = Orders-OrdCustId OF JZ 016360 MOVE 'Y' TO ORDERS-ENDFILE 016370 END-IF 016380 ADD 1 TO JZ-N1 OF JZ 016390 IF ORDERS-ENDFILE = 'N' 016400 MOVE OrdNbr OF JZ-Orders TO OrdNbr OF TS2 016410 MOVE '016400 WRITEQ TS QNAME(TS2QName OF CICS3C) 016420- 'FROM(TS2) MAIN NUMITEMS(TS2Record-Count OF C 016430- '' TO JZ-CICS-Stmt 016440 EXEC CICS 016450 WRITEQ TS QNAME(TS2QName OF CICS3C) FROM(TS2) 016460 MAIN NUMITEMS(TS2Record-Count OF CICS3C) 016470 RESP(JZ-RESPONSE) 016480 END-EXEC 016490 END-IF 016500 END-PERFORM 016510 MOVE '016500 ENDBR FILE(''ORDERS1'')' TO JZ-CICS-Stmt 016520 EXEC CICS 016530 ENDBR FILE('ORDERS1') RESP(JZ-RESPONSE) 016540 END-EXEC 016550 ELSE 016560 MOVE 'Y' TO ORDERS-ENDFILE 016570 END-IF. 016580 IF TS2Record-Count OF CICS3C > 0 016590* Read 1st record 016600 MOVE 1 TO TS2Current-Record OF CICS3C 016610 PERFORM JZ-READ-TS2 016620 ELSE 016630 MOVE 'N' TO ORDERS-Found-Flag 016640 PERFORM ORDERS-Initialize 016650 MOVE ZERO TO OrdNbr OF JZ-Orders 016660 MOVE Orders-OrdCustId OF JZ TO OrdCustId OF JZ-Orders 016670 PERFORM JZ-49-PROCESSGroup 016680 END-IF. 016690 PERFORM JZ-SET-AIDHELP. 016700* 016710 JZ-49-PROCESSGroup. 016720 IF ( OrdCustId OF JZ-Orders = Account OF JZ-CustF ) AND 016730 JZ-N1 OF JZ > 0 AND JZ-N1 OF JZ <= 13 016740* IF CICS3S.JZREPEAT.JZ-LF(JZ.JZ-N1) = 'S' THEN; 016750 IF INPT OF JZ-LF OF CICS3S(JZ-N1 OF JZ) = 'S' 016760* CICS4C.Function = Update; 016770 MOVE 'U' TO JZ-Function OF CICS4C 016780* CICS4C.SAVE = Orders; 016790 MOVE JZ-Orders TO SAVE OF CICS4C 016800* EXIT TO CICS4 COMMAREA(CICS4C); 016810 MOVE 'Y' TO JZ-XCTL OF CICS4C 016820 MOVE '016810 XCTL PROGRAM(''CICS4'') COMMAREA(CICS4C) 016830- '' TO JZ-CICS-Stmt 016840 EXEC CICS 016850 XCTL PROGRAM('CICS4') COMMAREA(CICS4C) 016860 RESP(JZ-RESPONSE) 016870 END-EXEC 016880 PERFORM CICS-CheckStatus 016890* END IF; 016900 END-IF 016910* END PROCESS Orders; 016920 CONTINUE 016930 END-IF. 016940* 016950* WHEN (Update); 016960 JZ-57-WHEN. 016970* GET Custf WHERE(CustF.Account=CICS3C.SAVE.Account) REWRITE 016980* CHECKCOPY(CICS3C.SAVE); 016990 PERFORM JZ-58-GET. 017000* 017010 JZ-58-GET. 017020* GET Custf WHERE(CustF.Account=CICS3C.SAVE.Account) REWRITE 017030* CHECKCOPY(CICS3C.SAVE); 017040 MOVE 'Y' TO CUSTF-Get4Update-FLAG. 017050 MOVE Account OF CICS3C TO Account OF JZ-CustF. 017060 PERFORM JZ-CustF-ReadBy1ryKey. 017070 MOVE 'Y' TO CUSTF-UpdatePending-Flag. 017080* Check against saved copy 017090 IF SAVE OF CICS3C IS NOT EQUAL TO JZ-CustF 017100 MOVE JZ-CustF TO SAVE OF CICS3C 017110 MOVE 'Record has been changed. Sorry, you need to re-appl 017120- 'y the updates' TO OUT OF JZ-Error OF CICS3S 017130 MOVE 'E' TO OUT OF JZ-Function OF CICS3S 017140 MOVE '017130 SEND MAP(''CICS3S'') FROM(CICS3S) CURSOR ALA 017150- 'RM' TO JZ-CICS-Stmt 017160 EXEC CICS 017170 SEND MAP('CICS3S') FROM(CICS3S) CURSOR ALARM 017180 RESP(JZ-RESPONSE) 017190 END-EXEC 017200 PERFORM CICS-CheckStatus 017210 GO TO JZ-Normal-Exit 017220 END-IF. 017230 IF CustF-FOUND-FLAG = 'N' 017240 MOVE 'UPDATE aborted: record does not exist' TO OUT OF 017250 JZ-Error OF CICS3S 017260 MOVE 'E' TO OUT OF JZ-Function OF CICS3S 017270 MOVE '017260 SEND MAP(''CICS3S'') FROM(CICS3S) CURSOR ALA 017280- 'RM' TO JZ-CICS-Stmt 017290 EXEC CICS 017300 SEND MAP('CICS3S') FROM(CICS3S) CURSOR ALARM 017310 RESP(JZ-RESPONSE) 017320 END-EXEC 017330 PERFORM CICS-CheckStatus 017340 GO TO JZ-Normal-Exit 017350 END-IF. 017360 PERFORM JZ-58-GETGroup. 017370* 017380 JZ-58-GETGroup. 017390* ACCEPT 017400* (CICS3S.Region,CICS3S.District,CICS3S.Name,CICS3S.SalesThisM 017410* onth,CICS3S.SalesYTD,CICS3S.Billingcycle,CICS3S.DateCommence 017420* d); 017430 PERFORM JZ-59-ACCEPT. 017440* END GET Custf REWRITE RESETFUNCTION; 017450 If CustF-FOUND 017460 PERFORM CustF-Update 017470 END-IF. 017480 PERFORM JZ-CustF-ResetFunction. 017490* 017500 JZ-59-ACCEPT. 017510* ACCEPT 017520* (CICS3S.Region,CICS3S.District,CICS3S.Name,CICS3S.SalesThisM 017530* onth,CICS3S.SalesYTD,CICS3S.Billingcycle,CICS3S.DateCommence 017540* d); 017550 MOVE 'N' TO JZ-Error OF JZ. 017560* Validate CICS3S.Region, assign to CustF.Region 017570 MOVE SPACES TO JZ-CHAR80. 017580 MOVE 'Region' TO JZ-FNAME. 017590 IF LTH OF Region OF CICS3S > ZERO 017600 IF INPT OF Region OF CICS3S IS NUMERIC 017610 COMPUTE Region OF JZ-CustF = FUNCTION NUMVAL(INPT OF 017620 Region OF CICS3S) 017630 ELSE 017640 MOVE 'not numeric' TO JZ-CHAR80 017650 END-IF 017660 END-IF. 017670 IF JZ-CHAR80 NOT = SPACE 017680 MOVE 'Y' TO JZ-Error OF JZ 017690 MOVE '*' TO OUT OF EFLD29 OF CICS3S 017700 MOVE -1 TO LTH OF Region OF CICS3S 017710 MOVE 80 TO JZ-MLTH 017720 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 017730 CICS3S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 017740 END-IF. 017750* Validate CICS3S.District, assign to CustF.District 017760 MOVE SPACES TO JZ-CHAR80. 017770 MOVE 'District' TO JZ-FNAME. 017780 IF LTH OF District OF CICS3S > ZERO 017790 IF INPT OF District OF CICS3S IS NUMERIC 017800 COMPUTE District OF JZ-CustF = FUNCTION NUMVAL(INPT 017810 OF District OF CICS3S) 017820 ELSE 017830 MOVE 'not numeric' TO JZ-CHAR80 017840 END-IF 017850 END-IF. 017860* Check Range 017870 IF JZ-CHAR80 = SPACE 017880 IF District OF JZ-CustF < 1 OR District OF JZ-CustF > 10 017890 MOVE 'outside valid range' TO JZ-CHAR80 017900 END-IF 017910 END-IF. 017920 IF JZ-CHAR80 NOT = SPACE 017930 MOVE 'Y' TO JZ-Error OF JZ 017940 MOVE '*' TO OUT OF EFLD31 OF CICS3S 017950 MOVE -1 TO LTH OF District OF CICS3S 017960 MOVE 80 TO JZ-MLTH 017970 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 017980 CICS3S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 017990 END-IF. 018000* Validate CICS3S.Name, assign to CustF.Name 018010 MOVE SPACES TO JZ-CHAR80. 018020 MOVE 'Name' TO JZ-FNAME. 018030 IF LTH OF JZ-Name OF CICS3S > ZERO 018040 MOVE INPT OF JZ-Name OF CICS3S TO JZ-Name OF JZ-CustF 018050 IF JZ-Name OF JZ-CustF = SPACES 018060 MOVE 'value required' TO JZ-CHAR80 018070 END-IF 018080 END-IF. 018090 IF JZ-CHAR80 NOT = SPACE 018100 MOVE 'Y' TO JZ-Error OF JZ 018110 MOVE '*' TO OUT OF EFLD11 OF CICS3S 018120 MOVE -1 TO LTH OF JZ-Name OF CICS3S 018130 MOVE 80 TO JZ-MLTH 018140 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 018150 CICS3S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 018160 END-IF. 018170* Validate CICS3S.SalesThisMonth, assign to 018180* CustF.SalesThisMonth 018190 MOVE SPACES TO JZ-CHAR80. 018200 MOVE 'SalesThisMonth' TO JZ-FNAME. 018210 IF LTH OF SalesThisMonth OF CICS3S > ZERO 018220 IF INPT OF SalesThisMonth OF CICS3S IS NUMERIC 018230 COMPUTE SalesThisMonth OF JZ-CustF = FUNCTION 018240 NUMVAL(INPT OF SalesThisMonth OF CICS3S) / 100 018250 ELSE 018260 MOVE 'not numeric' TO JZ-CHAR80 018270 END-IF 018280 END-IF. 018290 IF JZ-CHAR80 NOT = SPACE 018300 MOVE 'Y' TO JZ-Error OF JZ 018310 MOVE '*' TO OUT OF EFLD33 OF CICS3S 018320 MOVE -1 TO LTH OF SalesThisMonth OF CICS3S 018330 MOVE 80 TO JZ-MLTH 018340 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 018350 CICS3S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 018360 END-IF. 018370* Validate CICS3S.SalesYTD, assign to CustF.SalesYTD 018380 MOVE SPACES TO JZ-CHAR80. 018390 MOVE 'SalesYTD' TO JZ-FNAME. 018400 IF LTH OF SalesYTD OF CICS3S > ZERO 018410 IF INPT OF SalesYTD OF CICS3S IS NUMERIC 018420 COMPUTE SalesYTD OF JZ-CustF = FUNCTION NUMVAL(INPT 018430 OF SalesYTD OF CICS3S) / 100 018440 ELSE 018450 MOVE 'not numeric' TO JZ-CHAR80 018460 END-IF 018470 END-IF. 018480 IF JZ-CHAR80 NOT = SPACE 018490 MOVE 'Y' TO JZ-Error OF JZ 018500 MOVE '*' TO OUT OF EFLD35 OF CICS3S 018510 MOVE -1 TO LTH OF SalesYTD OF CICS3S 018520 MOVE 80 TO JZ-MLTH 018530 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 018540 CICS3S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 018550 END-IF. 018560* Validate CICS3S.Billingcycle, assign to CustF.Billingcycle 018570 MOVE SPACES TO JZ-CHAR80. 018580 MOVE 'Billingcycle' TO JZ-FNAME. 018590 IF LTH OF Billingcycle OF CICS3S > ZERO 018600 IF INPT OF Billingcycle OF CICS3S IS NUMERIC 018610 COMPUTE JZ-TinyNbr = FUNCTION NUMVAL(INPT OF 018620 Billingcycle OF CICS3S) 018630 MOVE JZ-TINY TO Billingcycle OF JZ-CustF 018640 ELSE 018650 MOVE 'not numeric' TO JZ-CHAR80 018660 END-IF 018670 END-IF. 018680* Check Code Values 018690 IF JZ-CHAR80 = SPACE 018700 MOVE Billingcycle OF JZ-CustF TO JZ-TINY 018710 MOVE JZ-TINYNBR TO SEARCH-FOR OF JZCodes-Types-Month 018720 PERFORM JZCvt-Types-Month 018730 MOVE FOUND-VALUE OF JZCodes-Types-Month TO OUT OF EFLD37 018740 OF CICS3S 018750 END-IF. 018760 IF JZ-CHAR80 NOT = SPACE 018770 MOVE 'Y' TO JZ-Error OF JZ 018780 MOVE '*' TO OUT OF EFLD37 OF CICS3S 018790 MOVE -1 TO LTH OF Billingcycle OF CICS3S 018800 MOVE 80 TO JZ-MLTH 018810 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 018820 CICS3S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 018830 END-IF. 018840* Validate CICS3S.DateCommenced, assign to CustF.DateCommenced 018850 MOVE SPACES TO JZ-CHAR80. 018860 MOVE 'DateCommenced' TO JZ-FNAME. 018870 IF LTH OF DateCommenced OF CICS3S > ZERO 018880* Data type Is3270Field cannot be converted to a DATE 018890 MOVE INPT OF DateCommenced OF CICS3S TO DateCommenced OF 018900 JZ-CustF 018910 END-IF. 018920 IF JZ-CHAR80 NOT = SPACE 018930 MOVE 'Y' TO JZ-Error OF JZ 018940 MOVE '*' TO OUT OF EFLD39 OF CICS3S 018950 MOVE -1 TO LTH OF DateCommenced OF CICS3S 018960 MOVE 80 TO JZ-MLTH 018970 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 018980 CICS3S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 018990 END-IF. 019000 IF JZ-Error OF JZ = 'Y' 019010* Respond with error messages and exit program 019020 MOVE '019010 SEND MAP(''CICS3S'') FROM(CICS3S) CURSOR ALA 019030- 'RM' TO JZ-CICS-Stmt 019040 EXEC CICS 019050 SEND MAP('CICS3S') FROM(CICS3S) CURSOR ALARM 019060 RESP(JZ-RESPONSE) 019070 END-EXEC 019080 PERFORM CICS-CheckStatus 019090 GO TO JZ-Normal-Exit 019100 END-IF. 019110* 019120* WHEN (Add); 019130 JZ-61-WHEN. 019140* CustF.Account = CustF.$LastKey + 1; [Will need to be changed 019150* if key is not a number 019160 PERFORM CustF-LastKey-SET. 019170 COMPUTE Account OF JZ-CustF = CustF-LastKey + 1 . 019180* GET Custf KEY(CustF.Account) CREATE; 019190 PERFORM JZ-63-GET. 019200* 019210 JZ-63-GET. 019220* GET Custf KEY(CustF.Account) CREATE; 019230 MOVE 'Y' TO CUSTF-Get4Update-FLAG. 019240 PERFORM JZ-CustF-ReadBy1ryKey. 019250 MOVE 'Y' TO CUSTF-UpdatePending-Flag. 019260 IF CustF-FOUND-FLAG = 'Y' 019270 MOVE 'UPDATE aborted: record already exists' TO OUT OF 019280 JZ-Error OF CICS3S 019290 MOVE 'E' TO OUT OF JZ-Function OF CICS3S 019300 MOVE '019290 SEND MAP(''CICS3S'') FROM(CICS3S) CURSOR ALA 019310- 'RM' TO JZ-CICS-Stmt 019320 EXEC CICS 019330 SEND MAP('CICS3S') FROM(CICS3S) CURSOR ALARM 019340 RESP(JZ-RESPONSE) 019350 END-EXEC 019360 PERFORM CICS-CheckStatus 019370 GO TO JZ-Normal-Exit 019380 END-IF. 019390 PERFORM JZ-63-GETGroup. 019400* 019410 JZ-63-GETGroup. 019420* ACCEPT 019430* (CICS3S.Region,CICS3S.District,CICS3S.Name,CICS3S.SalesThisM 019440* onth,CICS3S.SalesYTD,CICS3S.Billingcycle,CICS3S.DateCommence 019450* d) SETMDT; 019460 PERFORM JZ-64-ACCEPT. 019470* END GET Custf CREATE RESETFUNCTION; 019480 If NOT CustF-FOUND 019490 PERFORM CustF-Update 019500 END-IF. 019510 PERFORM JZ-CustF-ResetFunction. 019520* 019530 JZ-64-ACCEPT. 019540* ACCEPT 019550* (CICS3S.Region,CICS3S.District,CICS3S.Name,CICS3S.SalesThisM 019560* onth,CICS3S.SalesYTD,CICS3S.Billingcycle,CICS3S.DateCommence 019570* d) SETMDT; 019580 MOVE 'N' TO JZ-Error OF JZ. 019590* Validate CICS3S.Region, assign to CustF.Region 019600 MOVE SPACES TO JZ-CHAR80. 019610 MOVE 'Region' TO JZ-FNAME. 019620 IF LTH OF Region OF CICS3S > ZERO 019630 IF INPT OF Region OF CICS3S IS NUMERIC 019640 COMPUTE Region OF JZ-CustF = FUNCTION NUMVAL(INPT OF 019650 Region OF CICS3S) 019660 ELSE 019670 MOVE 'not numeric' TO JZ-CHAR80 019680 END-IF 019690 END-IF. 019700 IF JZ-CHAR80 NOT = SPACE 019710 MOVE 'Y' TO JZ-Error OF JZ 019720 MOVE '*' TO OUT OF EFLD29 OF CICS3S 019730 MOVE -1 TO LTH OF Region OF CICS3S 019740 MOVE 80 TO JZ-MLTH 019750 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 019760 CICS3S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 019770 END-IF. 019780* Validate CICS3S.District, assign to CustF.District 019790 MOVE SPACES TO JZ-CHAR80. 019800 MOVE 'District' TO JZ-FNAME. 019810 IF LTH OF District OF CICS3S > ZERO 019820 IF INPT OF District OF CICS3S IS NUMERIC 019830 COMPUTE District OF JZ-CustF = FUNCTION NUMVAL(INPT 019840 OF District OF CICS3S) 019850 ELSE 019860 MOVE 'not numeric' TO JZ-CHAR80 019870 END-IF 019880 END-IF. 019890* Check Range 019900 IF JZ-CHAR80 = SPACE 019910 IF District OF JZ-CustF < 1 OR District OF JZ-CustF > 10 019920 MOVE 'outside valid range' TO JZ-CHAR80 019930 END-IF 019940 END-IF. 019950 IF JZ-CHAR80 NOT = SPACE 019960 MOVE 'Y' TO JZ-Error OF JZ 019970 MOVE '*' TO OUT OF EFLD31 OF CICS3S 019980 MOVE -1 TO LTH OF District OF CICS3S 019990 MOVE 80 TO JZ-MLTH 020000 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 020010 CICS3S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 020020 END-IF. 020030* Validate CICS3S.Name, assign to CustF.Name 020040 MOVE SPACES TO JZ-CHAR80. 020050 MOVE 'Name' TO JZ-FNAME. 020060 IF LTH OF JZ-Name OF CICS3S > ZERO 020070 MOVE INPT OF JZ-Name OF CICS3S TO JZ-Name OF JZ-CustF 020080 IF JZ-Name OF JZ-CustF = SPACES 020090 MOVE 'value required' TO JZ-CHAR80 020100 END-IF 020110 END-IF. 020120 IF JZ-CHAR80 NOT = SPACE 020130 MOVE 'Y' TO JZ-Error OF JZ 020140 MOVE '*' TO OUT OF EFLD11 OF CICS3S 020150 MOVE -1 TO LTH OF JZ-Name OF CICS3S 020160 MOVE 80 TO JZ-MLTH 020170 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 020180 CICS3S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 020190 END-IF. 020200* Validate CICS3S.SalesThisMonth, assign to 020210* CustF.SalesThisMonth 020220 MOVE SPACES TO JZ-CHAR80. 020230 MOVE 'SalesThisMonth' TO JZ-FNAME. 020240 IF LTH OF SalesThisMonth OF CICS3S > ZERO 020250 IF INPT OF SalesThisMonth OF CICS3S IS NUMERIC 020260 COMPUTE SalesThisMonth OF JZ-CustF = FUNCTION 020270 NUMVAL(INPT OF SalesThisMonth OF CICS3S) / 100 020280 ELSE 020290 MOVE 'not numeric' TO JZ-CHAR80 020300 END-IF 020310 END-IF. 020320 IF JZ-CHAR80 NOT = SPACE 020330 MOVE 'Y' TO JZ-Error OF JZ 020340 MOVE '*' TO OUT OF EFLD33 OF CICS3S 020350 MOVE -1 TO LTH OF SalesThisMonth OF CICS3S 020360 MOVE 80 TO JZ-MLTH 020370 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 020380 CICS3S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 020390 END-IF. 020400* Validate CICS3S.SalesYTD, assign to CustF.SalesYTD 020410 MOVE SPACES TO JZ-CHAR80. 020420 MOVE 'SalesYTD' TO JZ-FNAME. 020430 IF LTH OF SalesYTD OF CICS3S > ZERO 020440 IF INPT OF SalesYTD OF CICS3S IS NUMERIC 020450 COMPUTE SalesYTD OF JZ-CustF = FUNCTION NUMVAL(INPT 020460 OF SalesYTD OF CICS3S) / 100 020470 ELSE 020480 MOVE 'not numeric' TO JZ-CHAR80 020490 END-IF 020500 END-IF. 020510 IF JZ-CHAR80 NOT = SPACE 020520 MOVE 'Y' TO JZ-Error OF JZ 020530 MOVE '*' TO OUT OF EFLD35 OF CICS3S 020540 MOVE -1 TO LTH OF SalesYTD OF CICS3S 020550 MOVE 80 TO JZ-MLTH 020560 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 020570 CICS3S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 020580 END-IF. 020590* Validate CICS3S.Billingcycle, assign to CustF.Billingcycle 020600 MOVE SPACES TO JZ-CHAR80. 020610 MOVE 'Billingcycle' TO JZ-FNAME. 020620 IF LTH OF Billingcycle OF CICS3S > ZERO 020630 IF INPT OF Billingcycle OF CICS3S IS NUMERIC 020640 COMPUTE JZ-TinyNbr = FUNCTION NUMVAL(INPT OF 020650 Billingcycle OF CICS3S) 020660 MOVE JZ-TINY TO Billingcycle OF JZ-CustF 020670 ELSE 020680 MOVE 'not numeric' TO JZ-CHAR80 020690 END-IF 020700 END-IF. 020710* Check Code Values 020720 IF JZ-CHAR80 = SPACE 020730 MOVE Billingcycle OF JZ-CustF TO JZ-TINY 020740 MOVE JZ-TINYNBR TO SEARCH-FOR OF JZCodes-Types-Month 020750 PERFORM JZCvt-Types-Month 020760 MOVE FOUND-VALUE OF JZCodes-Types-Month TO OUT OF EFLD37 020770 OF CICS3S 020780 END-IF. 020790 IF JZ-CHAR80 NOT = SPACE 020800 MOVE 'Y' TO JZ-Error OF JZ 020810 MOVE '*' TO OUT OF EFLD37 OF CICS3S 020820 MOVE -1 TO LTH OF Billingcycle OF CICS3S 020830 MOVE 80 TO JZ-MLTH 020840 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 020850 CICS3S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 020860 END-IF. 020870* Validate CICS3S.DateCommenced, assign to CustF.DateCommenced 020880 MOVE SPACES TO JZ-CHAR80. 020890 MOVE 'DateCommenced' TO JZ-FNAME. 020900 IF LTH OF DateCommenced OF CICS3S > ZERO 020910* Data type Is3270Field cannot be converted to a DATE 020920 MOVE INPT OF DateCommenced OF CICS3S TO DateCommenced OF 020930 JZ-CustF 020940 END-IF. 020950 IF JZ-CHAR80 NOT = SPACE 020960 MOVE 'Y' TO JZ-Error OF JZ 020970 MOVE '*' TO OUT OF EFLD39 OF CICS3S 020980 MOVE -1 TO LTH OF DateCommenced OF CICS3S 020990 MOVE 80 TO JZ-MLTH 021000 CALL 'JZMSAD' USING DFHEIBLK, DFHCOMMAREA, JZ-Error OF 021010 CICS3S, JZ-FNAME, JZ-CHAR80, JZ-MLTH 021020 END-IF. 021030 IF JZ-Error OF JZ = 'Y' 021040* Respond with error messages and exit program 021050 Move MDT OF ATTRIBUTES TO ATTR OF Region OF CICS3S 021060 Move MDT OF ATTRIBUTES TO ATTR OF District OF CICS3S 021070 Move MDT OF ATTRIBUTES TO ATTR OF JZ-Name OF CICS3S 021080 Move MDT OF ATTRIBUTES TO ATTR OF SalesThisMonth OF CICS3S 021090 Move MDT OF ATTRIBUTES TO ATTR OF SalesYTD OF CICS3S 021100 Move MDT OF ATTRIBUTES TO ATTR OF Billingcycle OF CICS3S 021110 Move MDT OF ATTRIBUTES TO ATTR OF DateCommenced OF CICS3S 021120 MOVE '021110 SEND MAP(''CICS3S'') FROM(CICS3S) CURSOR ALA 021130- 'RM' TO JZ-CICS-Stmt 021140 EXEC CICS 021150 SEND MAP('CICS3S') FROM(CICS3S) CURSOR ALARM 021160 RESP(JZ-RESPONSE) 021170 END-EXEC 021180 PERFORM CICS-CheckStatus 021190 GO TO JZ-Normal-Exit 021200 END-IF. 021210* 021220* WHEN (Delete); 021230 JZ-66-WHEN. 021240* DELETE Custf WHERE(CustF.Account=CICS3C.SAVE.Account) 021250* CHECKCOPY(CICS3C.SAVE) 021260* NOCHILDREN(Orders) RESETFUNCTION; 021270 PERFORM JZ-67-DELETE. 021280* 021290 JZ-67-DELETE. 021300* DELETE Custf WHERE(CustF.Account=CICS3C.SAVE.Account) 021310* CHECKCOPY(CICS3C.SAVE) 021320* NOCHILDREN(Orders) RESETFUNCTION; 021330 PERFORM JZ-CustF-ReadBy1ryKey. 021340 MOVE 'Y' TO CUSTF-UpdatePending-Flag. 021350* Check against saved copy 021360 IF SAVE OF CICS3C IS NOT EQUAL TO JZ-CustF 021370 MOVE JZ-CustF TO SAVE OF CICS3C 021380 MOVE 'Record has been changed. Sorry, you need to re-appl 021390- 'y the updates' TO OUT OF JZ-Error OF CICS3S 021400 MOVE 'E' TO OUT OF JZ-Function OF CICS3S 021410 MOVE '021400 SEND MAP(''CICS3S'') FROM(CICS3S) CURSOR ALA 021420- 'RM' TO JZ-CICS-Stmt 021430 EXEC CICS 021440 SEND MAP('CICS3S') FROM(CICS3S) CURSOR ALARM 021450 RESP(JZ-RESPONSE) 021460 END-EXEC 021470 PERFORM CICS-CheckStatus 021480 GO TO JZ-Normal-Exit 021490 END-IF. 021500 MOVE 'N' TO JZ-CustF-HasChildren OF JZ. 021510* Check for child records: NOCHILDREN(Orders). 021520 MOVE 'N' TO ORDERS-ENDFILE. 021530 MOVE 'N' TO ORDERS-FOUND-FLAG. 021540 MOVE OrdCustId OF JZ-Orders TO Orders-OrdCustId OF JZ. 021550 MOVE '021540 STARTBR FILE(''ORDERS1'') RIDFLD(OrdCustId OF JZ 021560- '-Orders)' TO JZ-CICS-Stmt. 021570 EXEC CICS 021580 STARTBR FILE('ORDERS1') RIDFLD(OrdCustId OF JZ-Orders) 021590 RESP(JZ-RESPONSE) 021600 END-EXEC. 021610 IF JZ-Response = DFHRESP(NORMAL) OR JZ-Response = 021620 DFHRESP(DUPKEY) 021630 PERFORM UNTIL ORDERS-ENDFILE = 'Y' 021640 MOVE '021630 READNEXT FILE(''ORDERS1'') INTO(JZ-CustF 021650- ') RIDFLD(OrdCustId OF JZ-Orders)' TO JZ-CICS-Stmt 021660 EXEC CICS 021670 READNEXT FILE('ORDERS1') INTO(JZ-CustF) 021680 RIDFLD(OrdCustId OF JZ-Orders) RESP(JZ-RESPONSE) 021690 END-EXEC 021700* GET ... FIRST. Terminate browse after 1st record 021710 MOVE 'Y' TO ORDERS-ENDFILE 021720 IF JZ-RESPONSE = DFHRESP(ENDFILE) OR JZ-RESPONSE = 021730 DFHRESP(NOTFND) 021740 MOVE 'N' TO ORDERS-Found-Flag 021750 ELSE 021760 MOVE 'Y' TO ORDERS-FOUND-FLAG 021770 END-IF 021780 END-PERFORM 021790 MOVE '021780 ENDBR FILE(''ORDERS1'')' TO JZ-CICS-Stmt 021800 EXEC CICS 021810 ENDBR FILE('ORDERS1') RESP(JZ-RESPONSE) 021820 END-EXEC 021830 ELSE 021840 MOVE 'Y' TO ORDERS-ENDFILE 021850 MOVE 'N' TO ORDERS-Found-Flag 021860 END-IF. 021870 IF ORDERS-Found-Flag = 'Y' 021880 MOVE 'Y' TO JZ-CustF-HasChildren OF JZ 021890 END-IF. 021900 IF JZ-CustF-HasChildren OF JZ = 'Y' 021910 MOVE 'DELETE prevented: child ORDERS record(s) present' 021920 TO OUT OF JZ-Error OF CICS3S 021930 MOVE 'E' TO OUT OF JZ-Function OF CICS3S 021940 MOVE '021930 SEND MAP(''CICS3S'') FROM(CICS3S) CURSOR ALA 021950- 'RM' TO JZ-CICS-Stmt 021960 EXEC CICS 021970 SEND MAP('CICS3S') FROM(CICS3S) CURSOR ALARM 021980 RESP(JZ-RESPONSE) 021990 END-EXEC 022000 PERFORM CICS-CheckStatus 022010 GO TO JZ-Normal-Exit 022020 ELSE 022030 MOVE '022020 DELETE FILE(''CUSTF'') RIDFLD(Account OF JZ- 022040- 'CustF)' TO JZ-CICS-Stmt 022050 EXEC CICS 022060 DELETE FILE('CUSTF') RIDFLD(Account OF JZ-CustF) 022070 RESP(JZ-RESPONSE) 022080 END-EXEC 022090 PERFORM CustF-CheckStatus 022100 END-IF. 022110 MOVE 'N' TO CUSTF-UpdatePending-Flag. 022120 PERFORM JZ-CustF-ResetFunction. 022130* 022140* WHEN (Order); 022150 JZ-68-WHEN. 022160* Orders = JAZZ.$Init; 022170 Move ZERO TO OrdNbr OF JZ-Orders. 022180 Move ZERO TO OrdCustId OF JZ-Orders. 022190 Move ZERO TO ordDate OF JZ-Orders. 022200 Move ZERO TO OrdPart OF JZ-Orders. 022210 Move ZERO TO OrdQty OF JZ-Orders. 022220 Move ZERO TO OrdDiscount OF JZ-Orders. 022230 Move SPACES TO OrdStatus OF JZ-Orders. 022240* Orders.OrdCustId = CICS3C.SAVE.Account; 022250 MOVE Account OF CICS3C TO OrdCustId OF JZ-Orders. 022260* Orders.ordDate = JAZZ.$Today; 022270 MOVE JZ-DATE OF JZ-TODAY TO ordDate OF JZ-Orders. 022280* CICS4C.SAVE = Orders; 022290 MOVE JZ-Orders TO SAVE OF CICS4C. 022300* CICS4C.Function = Add; 022310 MOVE 'A' TO JZ-Function OF CICS4C. 022320* EXIT TO CICS4 COMMAREA CICS4C; 022330 MOVE 'Y' TO JZ-XCTL OF CICS4C. 022340 MOVE '022330 XCTL PROGRAM(''CICS4'') COMMAREA(CICS4C)' TO 022350 JZ-CICS-Stmt. 022360 EXEC CICS 022370 XCTL PROGRAM('CICS4') COMMAREA(CICS4C) RESP(JZ-RESPONSE) 022380 END-EXEC. 022390 PERFORM CICS-CheckStatus. 022400* END CASE; 022410* 022420 JZ-76-SEND-Inscreen. 022430* SEND Inscreen; 022440 PERFORM JZ-SEND-INSCREEN. 022450****************************************************************** 022460** ** 022470** CICS Support Routines ** 022480** ** 022490****************************************************************** 022500* 022510* Assign program data to inscreen and Send it. Normal exit 022520 JZ-SEND-INSCREEN. 022530* Assign program data to screen 022540 MOVE Account OF JZ-CustF TO OUT OF Account OF CICS3S. 022550 MOVE LOW-VALUE TO ATTR OF Account OF CICS3S. 022560 MOVE JZ-Name OF JZ-CustF TO OUT OF JZ-Name OF CICS3S. 022570 MOVE LOW-VALUE TO ATTR OF JZ-Name OF CICS3S. 022580 MOVE JZ-Function OF CICS3C TO OUT OF JZ-Function OF CICS3S. 022590 MOVE JZ-Function OF CICS3C TO SEARCH-FOR OF 022600 JZCodes-CICS3C-Function. 022610 PERFORM JZCvt-CICS3C-Function. 022620 MOVE FOUND-VALUE OF JZCodes-CICS3C-Function TO OUT OF EFLD13 022630 OF CICS3S. 022640 MOVE LOW-VALUE TO ATTR OF JZ-Function OF CICS3S. 022650 MOVE Region OF JZ-CustF TO OUT OF Region OF CICS3S. 022660 MOVE LOW-VALUE TO ATTR OF Region OF CICS3S. 022670 MOVE District OF JZ-CustF TO OUT OF District OF CICS3S. 022680 MOVE LOW-VALUE TO ATTR OF District OF CICS3S. 022690 MOVE SalesThisMonth OF JZ-CustF TO OUT OF SalesThisMonth OF 022700 CICS3S. 022710 MOVE LOW-VALUE TO ATTR OF SalesThisMonth OF CICS3S. 022720 MOVE SalesYTD OF JZ-CustF TO OUT OF SalesYTD OF CICS3S. 022730 MOVE LOW-VALUE TO ATTR OF SalesYTD OF CICS3S. 022740 MOVE ZERO TO JZ-TinyNbr. 022750 MOVE Billingcycle OF JZ-CustF TO JZ-Tiny. 022760 MOVE JZ-TinyNbr TO OUT OF Billingcycle OF CICS3S. 022770 MOVE ZERO TO JZ-TinyNbr. 022780 MOVE Billingcycle OF JZ-CustF TO JZ-Tiny. 022790 MOVE JZ-TinyNbr TO SEARCH-FOR OF JZCodes-Types-Month. 022800 PERFORM JZCvt-Types-Month. 022810 MOVE FOUND-VALUE OF JZCodes-Types-Month TO OUT OF EFLD37 OF 022820 CICS3S. 022830 MOVE LOW-VALUE TO ATTR OF Billingcycle OF CICS3S. 022840 MOVE DateCommenced OF JZ-CustF TO DateFormPic OF JZ. 022850 PERFORM JZDateFormddbMMMbyy. 022860 MOVE DateFormddbMMMbyy TO OUT OF DateCommenced OF CICS3S. 022870 MOVE LOW-VALUE TO ATTR OF DateCommenced OF CICS3S. 022880* Begin repeating section JZREPEAT 022890 Move TS2Start OF CICS3C TO JZ-Index2. 022900 PERFORM VARYING JZ-N1 OF JZ FROM 1 BY 1 UNTIL JZ-N1 OF JZ > 022910 13 022920 COMPUTE TS2Current-Record OF CICS3C = JZ-N1 OF JZ + 022930 JZ-Index2 - 1 022940 IF TS2Current-Record OF CICS3C <= TS2Record-Count OF 022950 CICS3C AND TS2Record-Count OF CICS3C > ZERO 022960* Get Child record and assign to current repeating line 022970 PERFORM JZ-READ-TS2 022980 MOVE OrdNbr OF JZ-Orders TO OUT OF OrdNbr OF 022990 CICS3S(JZ-N1 OF JZ) 023000 MOVE LOW-VALUE TO ATTR OF OrdNbr OF CICS3S(JZ-N1 OF JZ) 023010 MOVE ordDate OF JZ-Orders TO DateFormPic OF JZ 023020 PERFORM JZDateFormddbMMMbyy 023030 MOVE DateFormddbMMMbyy TO OUT OF ordDate OF 023040 CICS3S(JZ-N1 OF JZ) 023050 MOVE LOW-VALUE TO ATTR OF ordDate OF CICS3S(JZ-N1 OF JZ) 023060 MOVE OrdPart OF JZ-Orders TO OUT OF OrdPart OF 023070 CICS3S(JZ-N1 OF JZ) 023080 MOVE LOW-VALUE TO ATTR OF OrdPart OF CICS3S(JZ-N1 OF JZ) 023090 MOVE OrdQty OF JZ-Orders TO OUT OF OrdQty OF 023100 CICS3S(JZ-N1 OF JZ) 023110 MOVE LOW-VALUE TO ATTR OF OrdQty OF CICS3S(JZ-N1 OF JZ) 023120 MOVE OrdDiscount OF JZ-Orders TO OUT OF OrdDiscount 023130 OF CICS3S(JZ-N1 OF JZ) 023140 MOVE LOW-VALUE TO ATTR OF OrdDiscount OF CICS3S(JZ-N1 023150 OF JZ) 023160 MOVE OrdStatus OF JZ-Orders TO SEARCH-FOR OF 023170 JZCodes-Orders-OrdStatus 023180 PERFORM JZCvt-Orders-OrdStatus 023190 MOVE FOUND-VALUE OF JZCodes-Orders-OrdStatus TO OUT 023200 OF OrdStatus OF CICS3S(JZ-N1 OF JZ) 023210 MOVE LOW-VALUE TO ATTR OF OrdStatus OF CICS3S(JZ-N1 023220 OF JZ) 023230 ELSE 023240* Clear unused lines 023250 MOVE SPACES TO BLK OF OrdNbr OF CICS3S(JZ-N1 OF JZ) 023260 MOVE SPACES TO BLK OF ordDate OF CICS3S(JZ-N1 OF JZ) 023270 MOVE SPACES TO BLK OF OrdPart OF CICS3S(JZ-N1 OF JZ) 023280 MOVE SPACES TO BLK OF OrdQty OF CICS3S(JZ-N1 OF JZ) 023290 MOVE SPACES TO BLK OF OrdDiscount OF CICS3S(JZ-N1 OF JZ) 023300 MOVE SPACES TO BLK OF OrdStatus OF CICS3S(JZ-N1 OF JZ) 023310 END-IF 023320 END-PERFORM. 023330* Now send screen 023340 IF JZ-XCTL OF CICS3C = 'Y' 023350 MOVE 'N' TO JZ-XCTL OF CICS3C 023360 MOVE '023350 SEND MAP(''CICS3S'') FROM(CICS3S) ERASE' TO 023370 JZ-CICS-Stmt 023380 EXEC CICS 023390 SEND MAP('CICS3S') FROM(CICS3S) ERASE RESP(JZ-RESPONSE) 023400 END-EXEC 023410 PERFORM CICS-CheckStatus 023420 ELSE 023430 MOVE '023420 SEND MAP(''CICS3S'') FROM(CICS3S) DATAONLY' 023440 TO JZ-CICS-Stmt 023450 EXEC CICS 023460 SEND MAP('CICS3S') FROM(CICS3S) DATAONLY 023470 RESP(JZ-RESPONSE) 023480 END-EXEC 023490 PERFORM CICS-CheckStatus 023500 END-IF. 023510 GO TO JZ-Normal-Exit. 023520* 023530 JZ-SET-AidHelp. 023540 MOVE 'F3=Return,' TO OUT OF JZAidHelp OF CICS3S. 023550 MOVE 11 TO JZ-AL. 023560 IF TS2Record-Count OF CICS3C > 13 023570 CALL 'JZNOFM' USING DFHEIBLK DFHCOMMAREA 023580 TS2Current-Record OF CICS3C, TS2Record-Count OF 023590 CICS3C, JZ-CHAR80, JZ-NOFML 023600 IF JZ-NOFML > 0 023610 MOVE JZ-CHAR80 TO OUT OF JZAidHelp OF 023620 CICS3S(JZ-AL:JZ-NOFML) 023630 ADD JZ-NOFML TO JZ-AL 023640 END-IF 023650 END-IF. 023660 IF TS2Current-Record OF CICS3C > 1 023670 MOVE 'F7=Up,' TO OUT OF JZAidHelp OF CICS3S(JZ-AL:7) 023680 ADD 7 TO JZ-AL 023690 END-IF. 023700 IF TS2Current-Record OF CICS3C + 13 < TS2Record-Count OF 023710 CICS3C 023720 MOVE 'F8=Down,' TO OUT OF JZAidHelp OF CICS3S(JZ-AL:9) 023730 ADD 9 TO JZ-AL 023740 END-IF. 023750 IF TS1Record-Count OF CICS3C > 1 023760 CALL 'JZNOFM' USING DFHEIBLK DFHCOMMAREA 023770 TS1Current-Record OF CICS3C, TS1Record-Count OF 023780 CICS3C, JZ-CHAR80, JZ-NOFML 023790 IF JZ-NOFML > 0 023800 MOVE JZ-CHAR80 TO OUT OF JZAidHelp OF 023810 CICS3S(JZ-AL:JZ-NOFML) 023820 ADD JZ-NOFML TO JZ-AL 023830 END-IF 023840 END-IF. 023850 IF TS1Current-Record OF CICS3C > 1 023860 MOVE 'F10=Previous,' TO OUT OF JZAidHelp OF CICS3S(JZ-AL:14) 023870 ADD 14 TO JZ-AL 023880 END-IF. 023890 IF TS1Current-Record OF CICS3C < TS1Record-Count OF CICS3C 023900 COMPUTE JZ-MLTH = JZ-AL + 9 023910 IF JZ-MLTH > 77 023920 COMPUTE JZ-ALIM = 77 - JZ-AL 023930 ELSE 023940 MOVE 9 TO JZ-ALIM 023950 END-IF 023960 MOVE 'F11=Next,' TO OUT OF JZAidHelp OF CICS3S(JZ-AL:9) 023970 ADD JZ-ALIM TO JZ-AL 023980 END-IF. 023990 COMPUTE JZ-MLTH = JZ-AL + 8. 024000 IF JZ-MLTH > 77 024010 COMPUTE JZ-ALIM = 77 - JZ-AL 024020 ELSE 024030 MOVE 8 TO JZ-ALIM 024040 END-IF. 024050 IF JZ-ALIM > 0 024060 MOVE 'F12=Exit' TO OUT OF JZAidHelp OF CICS3S(JZ-AL:JZ-ALIM) 024070 ADD JZ-ALIM TO JZ-AL 024080 END-IF. 024090* 024100* Clean up on Exit and Return 024110 JZ-DeleteAllTS. 024120 MOVE '024110 DELETEQ TS QNAME(TS1QName OF CICS3C)' TO 024130 JZ-CICS-Stmt. 024140 EXEC CICS 024150 DELETEQ TS QNAME(TS1QName OF CICS3C) RESP(JZ-RESPONSE) 024160 END-EXEC. 024170 MOVE '024160 DELETEQ TS QNAME(TS2QName OF CICS3C)' TO 024180 JZ-CICS-Stmt. 024190 EXEC CICS 024200 DELETEQ TS QNAME(TS2QName OF CICS3C) RESP(JZ-RESPONSE) 024210 END-EXEC. 024220****************************************************************** 024230** ** 024240** Code Conversion Routines ** 024250** ** 024260****************************************************************** 024270* 024280* Convert Types-Month code to value 024290 JZCvt-Types-Month. 024300* Input: SEARCH-FOR OF JZCodes-Types-Month 024310* Output: FOUND-VALUE OF JZCodes-Types-Month 024320* If Invalid, FOUND-VALUE will be set to '****', 024330* field JZ-CHAR80 will contain an error message 024340 SET JZIX-Types-Month TO SEARCH-FOR OF JZCodes-Types-Month. 024350 IF JZIX-Types-Month < 1 OR JZIX-Types-Month > 12 024360 MOVE 'Outside Code Range' TO JZ-CHAR80 024370 MOVE '*********' TO FOUND-VALUE OF JZCodes-Types-Month 024380 ELSE 024390 MOVE CODE-Value OF JZCodes-Types-Month(JZIX-Types-Month) 024400 TO FOUND-VALUE OF JZCodes-Types-Month 024410 END-IF. 024420* 024430* Convert Orders-OrdStatus code to value 024440 JZCvt-Orders-OrdStatus. 024450* Input: SEARCH-FOR OF JZCodes-Orders-OrdStatus 024460* Output: FOUND-VALUE OF JZCodes-Orders-OrdStatus 024470* If Invalid, FOUND-VALUE will be set to '****', 024480* field JZ-CHAR80 will contain an error message 024490 SET JZIX-Orders-OrdStatus TO 1. 024500 SEARCH ITEM-VALUES OF JZCodes-Orders-OrdStatus VARYING 024510 JZIX-Orders-OrdStatus 024520 AT END 024530 MOVE 'Invalid Code' TO JZ-CHAR80 024540 MOVE '************' TO FOUND-VALUE OF 024550 JZCodes-Orders-OrdStatus 024560 MOVE SPACES TO SEARCH-FOR OF JZCodes-Orders-OrdStatus 024570 WHEN JZCODE OF 024580 JZCodes-Orders-OrdStatus(JZIX-Orders-OrdStatus) = 024590 SEARCH-FOR OF JZCodes-Orders-OrdStatus 024600 MOVE CODE-VALUE OF 024610 JZCodes-Orders-OrdStatus(JZIX-Orders-OrdStatus) 024620 TO FOUND-VALUE OF JZCodes-Orders-OrdStatus 024630 END-SEARCH. 024640* 024650* Convert CICS3C-Function code to value 024660 JZCvt-CICS3C-Function. 024670* Input: SEARCH-FOR OF JZCodes-CICS3C-Function 024680* Output: FOUND-VALUE OF JZCodes-CICS3C-Function 024690* If Invalid, FOUND-VALUE will be set to '****', 024700* field JZ-CHAR80 will contain an error message 024710 SET JZIX-CICS3C-Function TO 1. 024720 SEARCH ITEM-VALUES OF JZCodes-CICS3C-Function VARYING 024730 JZIX-CICS3C-Function 024740 AT END 024750 MOVE 'Invalid Code' TO JZ-CHAR80 024760 MOVE '*******' TO FOUND-VALUE OF JZCodes-CICS3C-Function 024770 MOVE SPACES TO SEARCH-FOR OF JZCodes-CICS3C-Function 024780 WHEN JZCODE OF 024790 JZCodes-CICS3C-Function(JZIX-CICS3C-Function) = 024800 SEARCH-FOR OF JZCodes-CICS3C-Function 024810 MOVE CODE-VALUE OF 024820 JZCodes-CICS3C-Function(JZIX-CICS3C-Function) 024830 TO FOUND-VALUE OF JZCodes-CICS3C-Function 024840 END-SEARCH. 024850* 024860* Convert JZSMth-SMth code to value 024870 JZCvt-JZSMth-SMth. 024880* Input: SEARCH-FOR OF JZCodes-JZSMth-SMth 024890* Output: FOUND-VALUE OF JZCodes-JZSMth-SMth 024900* If Invalid, FOUND-VALUE will be set to '****', 024910* field JZ-CHAR80 will contain an error message 024920 SET JZIX-JZSMth-SMth TO SEARCH-FOR OF JZCodes-JZSMth-SMth. 024930 IF JZIX-JZSMth-SMth < 1 OR JZIX-JZSMth-SMth > 12 024940 MOVE 'Outside Code Range' TO JZ-CHAR80 024950 MOVE '***' TO FOUND-VALUE OF JZCodes-JZSMth-SMth 024960 ELSE 024970 MOVE CODE-Value OF JZCodes-JZSMth-SMth(JZIX-JZSMth-SMth) 024980 TO FOUND-VALUE OF JZCodes-JZSMth-SMth 024990 END-IF. 025000****************************************************************** 025010** ** 025020** Sundry Routines ** 025030** ** 025040****************************************************************** 025050* 025060 CICS-CheckStatus. 025070 EVALUATE JZ-Response 025080 WHEN DFHRESP(NORMAL) 025090 WHEN DFHRESP(DUPKEY) 025100 CONTINUE 025110 WHEN OTHER 025120 GO TO JZ-Abend-Exit 025130 END-EVALUATE. 025140* 025150* Format Date for reports 025160 JZDT01. 025170* Move Corresponding JZ-DATETIME-2 TO JZ-ReportTS 025180 MOVE JZ-DAY OF JZ-DateTIME-2 TO JZ-DAY OF JZ-ReportTS. 025190 MOVE JZ-YEAR OF JZ-DateTIME-2 TO JZ-YEAR OF JZ-ReportTS. 025200 MOVE JZ-HOUR OF JZ-DateTIME-2 TO JZ-HOUR OF JZ-ReportTS. 025210 MOVE JZ-MINUTE OF JZ-DateTIME-2 TO JZ-MINUTE OF JZ-ReportTS. 025220 MOVE JZ-SECOND OF JZ-DateTIME-2 TO JZ-SECOND OF JZ-ReportTS. 025230* Format Month 025240 MOVE JZ-MONTH TO SMth OF JZSMth. 025250 MOVE SMth OF JZSMth TO SEARCH-FOR OF JZCodes-JZSMth-SMth. 025260 PERFORM JZCvt-JZSMth-SMth. 025270 MOVE FOUND-VALUE OF JZCodes-JZSMth-SMth TO JZ-MONTH-NAME. 025280* 025290* Date Format dd MMM yy 025300 JZDateFormddbMMMbyy. 025310 MOVE DateFormDay OF JZ TO JZ-DAY OF DateFormddbMMMbyyR OF JZ. 025320 MOVE DateFormMth OF JZ TO SMth OF JZSMth. 025330 MOVE SMth OF JZSMth TO SEARCH-FOR OF JZCodes-JZSMth-SMth. 025340 PERFORM JZCvt-JZSMth-SMth. 025350 MOVE FOUND-VALUE OF JZCodes-JZSMth-SMth TO SMth OF 025360 DateFormddbMMMbyyR OF JZ. 025370 MOVE DateFormYear OF JZ TO Year OF DateFormddbMMMbyyR OF JZ. 025380* 025390 CustF-LastKey-SET. 025400* Set CustF.$LastKey 025410 MOVE HIGH-VALUES TO CUSTF-HighKey. 025420 MOVE '025410 STARTBR FILE(''CUSTF'') RIDFLD(CUSTF-HighKey) EQ 025430- 'UAL' TO JZ-CICS-Stmt. 025440 EXEC CICS 025450 STARTBR FILE('CUSTF') RIDFLD(CUSTF-HighKey) EQUAL 025460 RESP(JZ-RESPONSE) 025470 END-EXEC. 025480 MOVE '025470 READPREV FILE(''CUSTF'') INTO( JZ-CustF) RIDFLD( 025490- 'CUSTF-HighKey)' TO JZ-CICS-Stmt. 025500 EXEC CICS 025510 READPREV FILE('CUSTF') INTO( JZ-CustF) 025520 RIDFLD(CUSTF-HighKey) RESP(JZ-RESPONSE) 025530 END-EXEC. 025540 PERFORM CICS-CheckStatus. 025550 MOVE '025540 ENDBR FILE(''CUSTF'')' TO JZ-CICS-Stmt. 025560 EXEC CICS 025570 ENDBR FILE('CUSTF') RESP(JZ-RESPONSE) 025580 END-EXEC. 025590 PERFORM CICS-CheckStatus. 025600 MOVE Account OF JZ-CustF TO CustF-LastKey. 025610* 025620 JZ-CUSTF-ReadBy1ryKey. 025630 IF CUSTF-Get4Update 025640 MOVE '025630 READ FILE(''CUSTF'') INTO(JZ-CustF) UPDATE R 025650- 'IDFLD(Account OF JZ-CustF)' TO JZ-CICS-Stmt 025660 EXEC CICS 025670 READ FILE('CUSTF') INTO(JZ-CustF) UPDATE 025680 RIDFLD(Account OF JZ-CustF) RESP(JZ-RESPONSE) 025690 END-EXEC 025700 ELSE 025710 MOVE '025700 READ FILE(''CUSTF'') INTO(JZ-CustF) RIDFLD(A 025720- 'ccount OF JZ-CustF)' TO JZ-CICS-Stmt 025730 EXEC CICS 025740 READ FILE('CUSTF') INTO(JZ-CustF) RIDFLD(Account OF 025750 JZ-CustF) RESP(JZ-RESPONSE) 025760 END-EXEC 025770 END-IF. 025780 EVALUATE JZ-Response 025790 WHEN DFHRESP(NORMAL) 025800 WHEN DFHRESP(DUPKEY) 025810 MOVE 'Y' TO CustF-Found-Flag 025820 WHEN DFHRESP(NOTFND) 025830 MOVE 'N' TO CustF-Found-Flag 025840 PERFORM CustF-Initialize 025850 WHEN OTHER 025860 GO TO JZ-Abend-Exit 025870 END-EVALUATE. 025880* 025890 CustF-Initialize. 025900* Initialize non-key fields 025910 Move ZERO TO Region OF JZ-CustF. 025920 Move ZERO TO District OF JZ-CustF. 025930 Move SPACES TO JZ-Name OF JZ-CustF. 025940 Move ZERO TO SalesThisMonth OF JZ-CustF. 025950 Move ZERO TO SalesYTD OF JZ-CustF. 025960 Move LOW-VALUE TO Billingcycle OF JZ-CustF. 025970 Move ZERO TO DateCommenced OF JZ-CustF. 025980* 025990 JZ-CustF-ResetFunction. 026000 MOVE INPT OF JZ-Function OF CICS3S TO JZ-Function OF CICS3C. 026010 EVALUATE JZ-Function OF CICS3C 026020 WHEN 'E' 026030 IF CustF-FOUND-FLAG = 'Y' 026040 MOVE 'Record Found. Use Function U to update it' 026050 TO OUT OF JZ-Error OF CICS3S 026060 ELSE 026070 MOVE 'Record not found. Use Function A to add it' 026080 TO OUT OF JZ-Error OF CICS3S 026090 MOVE 'A' TO JZ-Function OF CICS3C 026100 END-IF 026110 WHEN 'U' 026120 MOVE 'Record Updated' TO OUT OF JZ-Error OF CICS3S 026130 MOVE 'E' TO JZ-Function OF CICS3C 026140 WHEN 'A' 026150 MOVE 'Record Added' TO OUT OF JZ-Error OF CICS3S 026160 MOVE 'E' TO JZ-Function OF CICS3C 026170 WHEN 'D' 026180 MOVE 'Record Deleted' TO OUT OF JZ-Error OF CICS3S 026190 MOVE 'E' TO JZ-Function OF CICS3C 026200 END-EVALUATE. 026210* 026220 CustF-Update. 026230 IF CustF-UpdatePending 026240 MOVE 'N' TO CustF-UpdatePending-Flag 026250 IF CustF-FOUND 026260 MOVE '026250 REWRITE FILE(''CUSTF'') FROM(JZ-CustF)' 026270 TO JZ-CICS-Stmt 026280 EXEC CICS 026290 REWRITE FILE('CUSTF') FROM(JZ-CustF) 026300 RESP(JZ-RESPONSE) 026310 END-EXEC 026320 PERFORM CICS-CheckStatus 026330 ELSE 026340 MOVE '026330 WRITE FILE(''CUSTF'') FROM(JZ-CustF) RID 026350- 'FLD(Account OF JZ-CustF)' TO JZ-CICS-Stmt 026360 EXEC CICS 026370 WRITE FILE('CUSTF') FROM(JZ-CustF) RIDFLD(Account 026380 OF JZ-CustF) RESP(JZ-RESPONSE) 026390 END-EXEC 026400 PERFORM CICS-CheckStatus 026410 END-IF 026420 END-IF. 026430 PERFORM JZ-CustF-ResetFunction. 026440* 026450 CustF-CheckStatus. 026460 EVALUATE JZ-Response 026470 WHEN DFHRESP(NORMAL) 026480 WHEN DFHRESP(DUPKEY) 026490 CONTINUE 026500* GET and DELETE: check that record found 026510 WHEN DFHRESP(NOTFND) 026520 MOVE 'N' TO CustF-Found-Flag 026530* Process (Browse): check for Endfile 026540 WHEN DFHRESP(ENDFILE) 026550 MOVE 'Y' TO CustF-ENDFILE 026560 WHEN OTHER 026570 GO TO JZ-Abend-Exit 026580 END-EVALUATE. 026590* 026600 JZ-ORDERS-ReadBy1ryKey. 026610 IF ORDERS-Get4Update 026620 MOVE '026610 READ FILE(''ORDERS'') INTO(JZ-Orders) UPDATE 026630- ' RIDFLD(OrdNbr OF JZ-Orders)' TO JZ-CICS-Stmt 026640 EXEC CICS 026650 READ FILE('ORDERS') INTO(JZ-Orders) UPDATE 026660 RIDFLD(OrdNbr OF JZ-Orders) RESP(JZ-RESPONSE) 026670 END-EXEC 026680 ELSE 026690 MOVE '026680 READ FILE(''ORDERS'') INTO(JZ-Orders) RIDFLD 026700- '(OrdNbr OF JZ-Orders)' TO JZ-CICS-Stmt 026710 EXEC CICS 026720 READ FILE('ORDERS') INTO(JZ-Orders) RIDFLD(OrdNbr OF 026730 JZ-Orders) RESP(JZ-RESPONSE) 026740 END-EXEC 026750 END-IF. 026760 EVALUATE JZ-Response 026770 WHEN DFHRESP(NORMAL) 026780 WHEN DFHRESP(DUPKEY) 026790 MOVE 'Y' TO Orders-Found-Flag 026800 WHEN DFHRESP(NOTFND) 026810 MOVE 'N' TO Orders-Found-Flag 026820 PERFORM Orders-Initialize 026830 WHEN OTHER 026840 GO TO JZ-Abend-Exit 026850 END-EVALUATE. 026860* 026870 Orders-Initialize. 026880* Initialize non-key fields 026890 Move ZERO TO OrdCustId OF JZ-Orders. 026900 Move ZERO TO ordDate OF JZ-Orders. 026910 Move ZERO TO OrdPart OF JZ-Orders. 026920 Move ZERO TO OrdQty OF JZ-Orders. 026930 Move ZERO TO OrdDiscount OF JZ-Orders. 026940 Move SPACES TO OrdStatus OF JZ-Orders. 026950* 026960 JZ-READ-TS1. 026970* Read CUSTF with key from nth item in TS 026980* IF condition should always be true 026990 IF TS1Current-Record OF CICS3C >= 1 AND TS1Current-Record OF 027000 CICS3C <= TS1Record-Count OF CICS3C 027010 MOVE '027000 READQ TS QNAME(TS1QName OF CICS3C) INTO(Acco 027020- 'unt OF JZ-CustF) ITEM(TS1Current-Rec' TO JZ-CICS-Stmt 027030 EXEC CICS 027040 READQ TS QNAME(TS1QName OF CICS3C) INTO(Account OF 027050 JZ-CustF) ITEM(TS1Current-Record OF CICS3C) 027060 RESP(JZ-RESPONSE) 027070 END-EXEC 027080 PERFORM CICS-CheckStatus 027090 PERFORM JZ-CustF-ReadBy1ryKey 027100 PERFORM JZ-47-GETGroup 027110 END-IF. 027120* 027130 JZ-READ-TS2. 027140* Read ORDERS with key from nth item in TS 027150* IF condition should always be true 027160 IF TS2Current-Record OF CICS3C >= 1 AND TS2Current-Record OF 027170 CICS3C <= TS2Record-Count OF CICS3C 027180 MOVE '027170 READQ TS QNAME(TS2QName OF CICS3C) INTO(OrdN 027190- 'br OF JZ-Orders) ITEM(TS2Current-Rec' TO JZ-CICS-Stmt 027200 EXEC CICS 027210 READQ TS QNAME(TS2QName OF CICS3C) INTO(OrdNbr OF 027220 JZ-Orders) ITEM(TS2Current-Record OF CICS3C) 027230 RESP(JZ-RESPONSE) 027240 END-EXEC 027250 PERFORM CICS-CheckStatus 027260 PERFORM JZ-Orders-ReadBy1ryKey 027270 PERFORM JZ-49-PROCESSGroup 027280 END-IF.