000010* C:\tutorials\TstSQL\cbl\PRCustF.CBL 000010 IDENTIFICATION DIVISION. PRCustF 000020 PROGRAM-ID. PRCustF. PRCustF 000030 AUTHOR. JazzUser (Using Jazz from Visual Studio) PRCustF 000040 DATE-WRITTEN. 2/10/2018 4:33:14 p.m. PRCustF 000050 ENVIRONMENT DIVISION. PRCustF 000060*# Last Updated by JazzUser at 2/10/2018 4:33:14 p.m. PRCustF 000070*PROGRAM PrCustF BATCH DATABASE sample DB2; PRCustF 000080*COPY Custf; PRCustF 000090*COPY JZSMth; PRCustF 000100*PROCESS Custf WHERE CustF.Region <> 5 ORDER(CustF.Account); PRCustF 000110* PRINT(CustF.Account,CustF.Region,CustF.District,CustF.Name,C PRCustF 000120* ustF.SalesThisMonth, PRCustF 000130* CustF.Billingcycle); PRCustF 000140*END PROCESS custf; PRCustF 000150******************************************************************PRCustF 000160** **PRCustF 000170** INPUT-OUTPUT Section/File-Control **PRCustF 000180** **PRCustF 000190******************************************************************PRCustF 000200 INPUT-OUTPUT Section. PRCustF 000210 FILE-CONTROL. PRCustF 000220 SELECT RepNbr1 ASSIGN TO RepNbr1 PRCustF 000230 FILE STATUS IS RepNbr1-STATUS. PRCustF 000240******************************************************************PRCustF 000250** **PRCustF 000260** Data Division **PRCustF 000270** **PRCustF 000280******************************************************************PRCustF 000290 DATA DIVISION. PRCustF 000300******************************************************************PRCustF 000310** **PRCustF 000320** File Section. **PRCustF 000330** **PRCustF 000340******************************************************************PRCustF 000350 File SECTION. PRCustF 000360******************************************************************PRCustF 000370** **PRCustF 000380** RepNbr1 **PRCustF 000390** **PRCustF 000400******************************************************************PRCustF 000410 FD RepNbr1 PRCustF 000420 RECORDING MODE F. PRCustF 000430* PRCustF 000440 01 JZ-RepNbr1 PIC X(132). PRCustF 000450******************************************************************PRCustF 000460** **PRCustF 000470** Working Storage Section: General Program Data **PRCustF 000480** **PRCustF 000490******************************************************************PRCustF 000500* PRCustF 000510 WORKING-STORAGE SECTION. PRCustF 000520******************************************************************PRCustF 000530** **PRCustF 000540** General Program Information **PRCustF 000550** **PRCustF 000560******************************************************************PRCustF 000570* PRCustF 000580* Status Flags and control data PRCustF 000590 01 JZ-FileControl. PRCustF 000600 03 SORTWORK-ENDFILE PIC X VALUE 'N'. PRCustF 000610 03 JZDB2Co-ENDFILE PIC X VALUE 'N'. PRCustF 000620 03 JZDB2Co-STATUS PIC XX VALUE '00'. PRCustF 000630 03 JZDB2Co-FOUND-FLAG PIC X VALUE 'Y'. PRCustF 000640 88 JZDB2Co-FOUND VALUE 'Y'. PRCustF 000650 03 JZDB2Co-UPDATEPENDING-FLAG PIC X VALUE 'N'. PRCustF 000660 88 JZDB2Co-UPDATEPENDING VALUE 'Y'. PRCustF 000670 03 JZDB2Co-Get4Update-FLAG PIC X VALUE 'N'. PRCustF 000680 88 JZDB2Co-Get4Update VALUE 'Y'. PRCustF 000690 03 JZDB2Co-LastKey PIC X(16) VALUE SPACES. PRCustF 000700 03 JZDB2Co-HighKey PIC XXXXXXXXXXXXXXXX VALUE HIGH-VALUES. PRCustF 000710 03 CustF-ENDFILE PIC X VALUE 'N'. PRCustF 000720 03 CustF-STATUS PIC XX VALUE '00'. PRCustF 000730 03 CustF-FOUND-FLAG PIC X VALUE 'Y'. PRCustF 000740 88 CustF-FOUND VALUE 'Y'. PRCustF 000750 03 CustF-UPDATEPENDING-FLAG PIC X VALUE 'N'. PRCustF 000760 88 CustF-UPDATEPENDING VALUE 'Y'. PRCustF 000770 03 CustF-Get4Update-FLAG PIC X VALUE 'N'. PRCustF 000780 88 CustF-Get4Update VALUE 'Y'. PRCustF 000790 03 CustF-LastKey PIC X(6) VALUE SPACES. PRCustF 000800 03 CustF-HighKey PIC XXXXXX VALUE HIGH-VALUES. PRCustF 000810 03 RepNbr1-STATUS PIC XX VALUE '00'. PRCustF 000820 03 RepNbr1-PageNbr PIC 99999 COMP-3 VALUE 0. PRCustF 000830 03 RepNbr1-LineCount PIC 9999 COMP VALUE 1000. PRCustF 000840 03 RepNbr1-Space PIC 9999 COMP VALUE 1. PRCustF 000850* PRCustF 000860 01 JZ-TODAY. PRCustF 000870 05 JZ-DATETIMEGMT. PRCustF 000880 10 JZ-DATETIME PIC 9(16). PRCustF 000890 10 JZ-GMTDIFF PIC S9(4). PRCustF 000900 05 JZ-DATETIME-1 REDEFINES JZ-DATETIMEGMT. PRCustF 000910 10 JZ-DATE PIC 9(8). PRCustF 000920 10 JZ-TIME PIC 9(8). PRCustF 000930 10 FILLER PIC S9(4). PRCustF 000940 05 JZ-DATETIME-2 REDEFINES JZ-DATETIMEGMT. PRCustF 000950 10 JZ-YEAR PIC 9(4). PRCustF 000960 10 JZ-MONTH PIC 9(2). PRCustF 000970 10 JZ-DAY PIC 9(2). PRCustF 000980 10 JZ-HOUR PIC 9(2). PRCustF 000990 10 JZ-MINUTE PIC 9(2). PRCustF 001000 10 JZ-SECOND PIC 9(2). PRCustF 001010 10 JZ-MS PIC 9(2). PRCustF 001020 10 FILLER PIC S9(4). PRCustF 001030 05 JZ-DATETIME-3 REDEFINES JZ-DATETIMEGMT. PRCustF 001040 10 FILLER PIC 9(12). PRCustF 001050 10 JZ-SECONDS PIC 99V99. PRCustF 001060 10 FILLER PIC S9(4). PRCustF 001070* Report Time Stamp PRCustF 001080* PRCustF 001090 01 JZ-ReportTS. PRCustF 001100 10 JZ-DAY PIC 9(2). PRCustF 001110 10 FILLER PIC X VALUE SPACE. PRCustF 001120 10 JZ-MONTH-NAME PIC X(3). PRCustF 001130 10 FILLER PIC X VALUE SPACE. PRCustF 001140 10 JZ-YEAR PIC 9(4). PRCustF 001150 10 JZ-COMMA PIC XX VALUE ', '. PRCustF 001160 10 JZ-HOUR PIC 9(2). PRCustF 001170 10 JZ-SEPCHAR1 PIC X VALUE ':'. PRCustF 001180 10 JZ-MINUTE PIC 9(2). PRCustF 001190 10 JZ-SEPCHAR2 PIC X VALUE ':'. PRCustF 001200 10 JZ-SECOND PIC 9(2). PRCustF 001210* PRCustF 001220 01 JZ-ReportTimeStamp REDEFINES JZ-ReportTS PIC X(21). PRCustF 001230* PRCustF 001240 LOCAL-STORAGE SECTION. PRCustF 001250******************************************************************PRCustF 001260** **PRCustF 001270** SQL Data **PRCustF 001280** **PRCustF 001290******************************************************************PRCustF 001300 EXEC SQL PRCustF 001310 INCLUDE SQLCA PRCustF 001320 END-EXEC. PRCustF 001330 EXEC SQL PRCustF 001340 INCLUDE JZDB2Co PRCustF 001350 END-EXEC. PRCustF 001360 EXEC SQL PRCustF 001370 INCLUDE CustF PRCustF 001380 END-EXEC. PRCustF 001390******************************************************************PRCustF 001400** **PRCustF 001410** RepNbr1 Print Lines **PRCustF 001420** **PRCustF 001430******************************************************************PRCustF 001440* PRCustF 001450* Save line while headings are printed PRCustF 001460 01 JZ-RepNbr1-Save PIC X(132). PRCustF 001470* PRCustF 001480* Page Header and footer PRCustF 001490 01 JZ-RepNbr1-Heading. PRCustF 001500 03 Filler PIC X(11) Value 'Printed at '. PRCustF 001510 03 DateTime PIC X(21). PRCustF 001520 03 Filler PIC X(22) VALUE SPACES. PRCustF 001530 03 Filler PIC X(7) VALUE 'RepNbr1'. PRCustF 001540 03 Filler PIC X(23) VALUE SPACES. PRCustF 001550 03 Filler PIC XXXX VALUE 'Page'. PRCustF 001560 03 PageNbr PIC ZZZ9. PRCustF 001570* PRCustF 001580* Column Headings PRCustF 001590 01 RepNbr1-L1-H. PRCustF 001600 03 FILLER PIC X(132) VALUE 'Account Number Region District *PRCustF 001610- '------------Name------------* SalesThisMonth BillingcyclPRCustF 001620- 'e '. PRCustF 001630* PRCustF 001640* Data line PRCustF 001650 01 RepNbr1-L1-D. PRCustF 001660 03 Account PIC X(6). PRCustF 001670 03 FILLER PIC X(8) VALUE SPACE. PRCustF 001680 03 FILLER PIC X(1) VALUE SPACES. PRCustF 001690 03 FILLER PIC X(2) VALUE SPACE. PRCustF 001700 03 Region PIC ---9. PRCustF 001710 03 FILLER PIC X(1) VALUE SPACES. PRCustF 001720 03 FILLER PIC X(4) VALUE SPACE. PRCustF 001730 03 District PIC ---9. PRCustF 001740 03 FILLER PIC X(1) VALUE SPACES. PRCustF 001750 03 JZ-Name PIC X(30). PRCustF 001760 03 FILLER PIC X(1) VALUE SPACES. PRCustF 001770 03 FILLER PIC X(2) VALUE SPACE. PRCustF 001780 03 SalesThisMonth PIC $$$,$$9.99CR. PRCustF 001790 03 FILLER PIC X(1) VALUE SPACES. PRCustF 001800 03 FILLER PIC X(3) VALUE SPACE. PRCustF 001810 03 Billingcycle PIC X(9). PRCustF 001820 03 FILLER PIC X(42) VALUE SPACES. PRCustF 001830******************************************************************PRCustF 001840** **PRCustF 001850** JZ - Jazz Sundry fields **PRCustF 001860** **PRCustF 001870******************************************************************PRCustF 001880* PRCustF 001890 01 JZ. PRCustF 001900 03 JZ-AL PIC S9(4) COMP VALUE ZERO. PRCustF 001910 03 JZ-ALIM PIC S9(4) COMP VALUE ZERO. PRCustF 001920 03 JZ-NOFML PIC S9(4) COMP VALUE ZERO. PRCustF 001930 03 JZ-INDEX PIC S9(4) COMP VALUE ZERO. PRCustF 001940 03 JZ-INDEX2 PIC S9(4) COMP VALUE ZERO. PRCustF 001950 03 JZ-IXMth PIC S9(4) COMP VALUE ZERO. PRCustF 001960 03 IX1 PIC S9(4) COMP VALUE ZERO. PRCustF 001970 03 IX2 PIC S9(4) COMP VALUE ZERO. PRCustF 001980 03 IX3 PIC S9(4) COMP VALUE ZERO. PRCustF 001990 03 IX4 PIC S9(4) COMP VALUE ZERO. PRCustF 002000 03 IX5 PIC S9(4) COMP VALUE ZERO. PRCustF 002010 03 IX6 PIC S9(4) COMP VALUE ZERO. PRCustF 002020 03 IX7 PIC S9(4) COMP VALUE ZERO. PRCustF 002030 03 JZ-ST PIC S9(4) COMP VALUE ZERO. PRCustF 002040 03 JZ-SL PIC S9(4) COMP VALUE ZERO. PRCustF 002050 03 JZ-BLANK PIC XXXX VALUE SPACES. PRCustF 002060 03 JZ-CHAR80 PIC X(80) VALUE SPACES. PRCustF 002070 03 JZ-FNAME PIC X(30) VALUE SPACES. PRCustF 002080 03 JZ-KL PIC S9(4) COMP VALUE ZERO. PRCustF 002090 03 JZ-MLTH PIC S9(4) COMP VALUE ZERO. PRCustF 002100 03 JZ-INT PIC S9(9) COMP VALUE ZERO. PRCustF 002110 03 JZ-TRUEFALSE PIC XXXXX VALUE SPACES. PRCustF 002120 03 JZ-TinyNbr PIC S9(9) COMP VALUE ZERO. PRCustF 002130 03 JZ-TinyGr REDEFINES JZ-TinyNbr. PRCustF 002140 05 FILLER PIC XXX. PRCustF 002150 05 JZ-Tiny PIC X. PRCustF 002160 03 JZ-Error PIC X VALUE 'N'. PRCustF 002170 03 JZ-NBR1 PIC 9999 VALUE ZERO. PRCustF 002180 03 JZ-NBR1X REDEFINES JZ-NBR1 PIC XXXX. PRCustF 002190 03 JZ-NBR2 PIC 9999 VALUE ZERO. PRCustF 002200 03 JZ-NBR2X REDEFINES JZ-NBR2 PIC XXXX. PRCustF 002210 03 JZ-SUBVAL PIC ZZZZZ9 VALUE ZERO. PRCustF 002220 03 JZ-SUBVALR REDEFINES JZ-SUBVAL PIC X(6). PRCustF 002230 03 JZ-SUBDIGIT PIC S9(4) COMP VALUE ZERO. PRCustF 002240 03 JZ-INDEXES OCCURS 7 INDEXED BY JZIX1 PIC X(6) VALUE PRCustF 002250 SPACES. PRCustF 002260 03 JZ-INDEXPR PIC X(6) VALUE SPACES. PRCustF 002270******************************************************************PRCustF 002280** **PRCustF 002290** JZSMth **PRCustF 002300** **PRCustF 002310******************************************************************PRCustF 002320* PRCustF 002330 01 JZSMth. PRCustF 002340 03 SMth PIC S9(4) COMP VALUE ZERO. PRCustF 002350******************************************************************PRCustF 002360** **PRCustF 002370** Break **PRCustF 002380** **PRCustF 002390******************************************************************PRCustF 002400* PRCustF 002410 01 Break. PRCustF 002420 03 Level PIC S9(4) COMP VALUE ZERO. PRCustF 002430 03 Sub PIC S9(4) COMP VALUE ZERO. PRCustF 002440 03 Rec-Count PIC S9(4) COMP VALUE ZERO. PRCustF 002450******************************************************************PRCustF 002460** **PRCustF 002470** RepNbr1-CBD **PRCustF 002480** **PRCustF 002490******************************************************************PRCustF 002500* PRCustF 002510 01 RepNbr1-CBD. PRCustF 002520 03 Description1. PRCustF 002530 05 JZGrandTotal PIC X(12) VALUE ' Grand Total'. PRCustF 002540 03 Description2 REDEFINES Description1 OCCURS 1 INDEXED BY PRCustF 002550 JZIX2. PRCustF 002560 05 Descriptions PIC X(12). PRCustF 002570******************************************************************PRCustF 002580** **PRCustF 002590** Code Tables **PRCustF 002600** **PRCustF 002610******************************************************************PRCustF 002620* PRCustF 002630* Types.Month PRCustF 002640 01 JZCodes-Types-Month. PRCustF 002650 03 JZValues. PRCustF 002660 05 FILLER PIC X(9) VALUE 'January '. PRCustF 002670 05 FILLER PIC X(9) VALUE 'February '. PRCustF 002680 05 FILLER PIC X(9) VALUE 'March '. PRCustF 002690 05 FILLER PIC X(9) VALUE 'April '. PRCustF 002700 05 FILLER PIC X(9) VALUE 'May '. PRCustF 002710 05 FILLER PIC X(9) VALUE 'June '. PRCustF 002720 05 FILLER PIC X(9) VALUE 'July '. PRCustF 002730 05 FILLER PIC X(9) VALUE 'August '. PRCustF 002740 05 FILLER PIC X(9) VALUE 'September'. PRCustF 002750 05 FILLER PIC X(9) VALUE 'October '. PRCustF 002760 05 FILLER PIC X(9) VALUE 'November '. PRCustF 002770 05 FILLER PIC X(9) VALUE 'December '. PRCustF 002780 03 JZTABLE REDEFINES JZValues. PRCustF 002790 05 ITEM-VALUES OCCURS 12 INDEXED BY JZIX-Types-Month. PRCustF 002800 07 CODE-VALUE PIC X(9). PRCustF 002810 03 FILLER. PRCustF 002820 05 SEARCH-FOR PIC S9(4) COMP. PRCustF 002830 05 FOUND-VALUE PIC X(9) VALUE '*********'. PRCustF 002840* PRCustF 002850* JZSMth.SMth PRCustF 002860 01 JZCodes-JZSMth-SMth. PRCustF 002870 03 JZValues. PRCustF 002880 05 FILLER PIC X(3) VALUE 'Jan'. PRCustF 002890 05 FILLER PIC X(3) VALUE 'Feb'. PRCustF 002900 05 FILLER PIC X(3) VALUE 'Mar'. PRCustF 002910 05 FILLER PIC X(3) VALUE 'Apr'. PRCustF 002920 05 FILLER PIC X(3) VALUE 'May'. PRCustF 002930 05 FILLER PIC X(3) VALUE 'Jun'. PRCustF 002940 05 FILLER PIC X(3) VALUE 'Jul'. PRCustF 002950 05 FILLER PIC X(3) VALUE 'Aug'. PRCustF 002960 05 FILLER PIC X(3) VALUE 'Sep'. PRCustF 002970 05 FILLER PIC X(3) VALUE 'Oct'. PRCustF 002980 05 FILLER PIC X(3) VALUE 'Nov'. PRCustF 002990 05 FILLER PIC X(3) VALUE 'Dec'. PRCustF 003000 03 JZTABLE REDEFINES JZValues. PRCustF 003010 05 ITEM-VALUES OCCURS 12 INDEXED BY JZIX-JZSMth-SMth. PRCustF 003020 07 CODE-VALUE PIC X(3). PRCustF 003030 03 FILLER. PRCustF 003040 05 SEARCH-FOR PIC S9(4) COMP. PRCustF 003050 05 FOUND-VALUE PIC X(3) VALUE '***'. PRCustF 003060******************************************************************PRCustF 003070** **PRCustF 003080** Procedure Division. **PRCustF 003090** **PRCustF 003100******************************************************************PRCustF 003110* PRCustF 003120 PROCEDURE DIVISION. PRCustF 003130 MOVE 'SAMPLE' TO JZC-DATABASE. PRCustF 003140 EXEC SQL PRCustF 003150 CONNECT TO :JZC-DATABASE PRCustF 003160 END-EXEC. PRCustF 003170 IF SQLCODE NOT = 0 PRCustF 003180 DISPLAY 'PROGRAM TERMINATED. CONNECT TO SAMPLE failed, SPRCustF 003190- 'QLCode=' SQLCODE PRCustF 003200 GOBACK PRCustF 003210 END-IF. PRCustF 003220 MOVE FUNCTION CURRENT-DATE TO JZ-TODAY. PRCustF 003230 PERFORM JZDT01. PRCustF 003240 MOVE JZ-ReportTimeStamp TO DateTime OF JZ-RepNbr1-Heading. PRCustF 003250 OPEN OUTPUT RepNbr1. PRCustF 003260 IF RepNbr1-Status IS NOT = '00' AND RepNbr1-Status IS NOT = 'PRCustF 003270- '41' AND RepNbr1-Status IS NOT = '97' PRCustF 003280 DISPLAY 'PROGRAM TERMINATED. Invalid Status Code on OPEN PRCustF 003290- 'RepNbr1. CODE=' RepNbr1-Status PRCustF 003300 GOBACK PRCustF 003310 END-IF . PRCustF 003320* Main Program Logic PRCustF 003330 PERFORM JZ-Main-Program-Logic. PRCustF 003340* PRCustF 003350 JZ-Normal-Exit. PRCustF 003360 Move '* * * END OF RepNbr1 * * *' TO JZ-RepNbr1. PRCustF 003370 WRITE JZ-RepNbr1. PRCustF 003380* Logical end-of-program PRCustF 003390 GOBACK. PRCustF 003400******************************************************************PRCustF 003410** **PRCustF 003420** Main Program Logic **PRCustF 003430** **PRCustF 003440******************************************************************PRCustF 003450* PRCustF 003460 JZ-Main-Program-Logic. PRCustF 003470* PROCESS Custf WHERE CustF.Region <> 5 ORDER(CustF.Account); PRCustF 003480 EXEC SQL PRCustF 003490 DECLARE JZ-18-CURSOR CURSOR FOR SELECT Account, Region, PRCustF 003500 District, Name, SalesThisMonth, Billingcycle FROM PRCustF 003510 CustF WHERE Region <> 5 ORDER BY Account PRCustF 003520 END-EXEC. PRCustF 003530 EXEC SQL PRCustF 003540 OPEN JZ-18-CURSOR PRCustF 003550 END-EXEC. PRCustF 003560 MOVE 'N' TO CustF-ENDFILE. PRCustF 003570 PERFORM JZ-18-PROCESSGroup UNTIL CustF-ENDFILE = 'Y'. PRCustF 003580* PRCustF 003590 JZ-18-PROCESSGroup. PRCustF 003600 EXEC SQL PRCustF 003610 FETCH JZ-18-CURSOR INTO :Cus-Account, PRCustF 003620 :Cus-Region:JZB-Cus-Region, PRCustF 003630 :Cus-District:JZB-Cus-District, PRCustF 003640 :Cus-JZ-Name:JZB-Cus-JZ-Name, PRCustF 003650 :Cus-SalesThisMonth:JZB-Cus-SalesThisMonth, PRCustF 003660 :Cus-Billingcycle:JZB-Cus-Billingcycle PRCustF 003670 END-EXEC. PRCustF 003680 IF SQLCODE NOT = 0 PRCustF 003690 MOVE 'Y' TO CustF-ENDFILE PRCustF 003700 END-IF. PRCustF 003710 IF CustF-ENDFILE = 'N' PRCustF 003720* PRINT(CustF.Account,CustF.Region,CustF.District,CustF.Na PRCustF 003730* me,CustF.SalesThisMonth,PRCustF 003740* CustF.Billingcycle); PRCustF 003750 PERFORM JZ-19-Print PRCustF 003760* END PROCESS custf; PRCustF 003770 CONTINUE PRCustF 003780 ELSE PRCustF 003790 EXEC SQL PRCustF 003800 CLOSE JZ-18-CURSOR PRCustF 003810 END-EXEC PRCustF 003820 END-IF. PRCustF 003830* PRCustF 003840 JZ-19-Print. PRCustF 003850* PRINT(CustF.Account,CustF.Region,CustF.District,CustF.Name,C PRCustF 003860* ustF.SalesThisMonth,PRCustF 003870* CustF.Billingcycle); PRCustF 003880 MOVE Cus-Account OF CustF TO Account OF RepNbr1-L1-D. PRCustF 003890 MOVE Cus-Region OF CustF TO Region OF RepNbr1-L1-D. PRCustF 003900 MOVE Cus-District OF CustF TO District OF RepNbr1-L1-D. PRCustF 003910 MOVE Cus-JZ-Name OF CustF TO JZ-Name OF RepNbr1-L1-D. PRCustF 003920 MOVE Cus-SalesThisMonth OF CustF TO SalesThisMonth OF PRCustF 003930 RepNbr1-L1-D. PRCustF 003940 MOVE ZERO TO JZ-TinyNbr. PRCustF 003950 MOVE Cus-Billingcycle OF CustF TO JZ-Tiny. PRCustF 003960 MOVE JZ-TinyNbr TO SEARCH-FOR OF JZCodes-Types-Month. PRCustF 003970 PERFORM JZCvt-Types-Month. PRCustF 003980 MOVE FOUND-VALUE OF JZCodes-Types-Month TO Billingcycle OF PRCustF 003990 RepNbr1-L1-D. PRCustF 004000 MOVE RepNbr1-L1-D TO JZ-RepNbr1. PRCustF 004010 PERFORM RepNbr1-Print. PRCustF 004020******************************************************************PRCustF 004030** **PRCustF 004040** Code Conversion Routines **PRCustF 004050** **PRCustF 004060******************************************************************PRCustF 004070* PRCustF 004080* Convert Types-Month code to value PRCustF 004090 JZCvt-Types-Month. PRCustF 004100* Input: SEARCH-FOR OF JZCodes-Types-Month PRCustF 004110* Output: FOUND-VALUE OF JZCodes-Types-Month PRCustF 004120* If Invalid, FOUND-VALUE will be set to '****', PRCustF 004130* field JZ-CHAR80 will contain an error message PRCustF 004140 SET JZIX-Types-Month TO SEARCH-FOR OF JZCodes-Types-Month. PRCustF 004150 IF JZIX-Types-Month < 1 OR JZIX-Types-Month > 12 PRCustF 004160 MOVE 'Outside Code Range' TO JZ-CHAR80 PRCustF 004170 MOVE '*********' TO FOUND-VALUE OF JZCodes-Types-Month PRCustF 004180 ELSE PRCustF 004190 MOVE CODE-Value OF JZCodes-Types-Month(JZIX-Types-Month) PRCustF 004200 TO FOUND-VALUE OF JZCodes-Types-Month PRCustF 004210 END-IF. PRCustF 004220* PRCustF 004230* Convert JZSMth-SMth code to value PRCustF 004240 JZCvt-JZSMth-SMth. PRCustF 004250* Input: SEARCH-FOR OF JZCodes-JZSMth-SMth PRCustF 004260* Output: FOUND-VALUE OF JZCodes-JZSMth-SMth PRCustF 004270* If Invalid, FOUND-VALUE will be set to '****', PRCustF 004280* field JZ-CHAR80 will contain an error message PRCustF 004290 SET JZIX-JZSMth-SMth TO SEARCH-FOR OF JZCodes-JZSMth-SMth. PRCustF 004300 IF JZIX-JZSMth-SMth < 1 OR JZIX-JZSMth-SMth > 12 PRCustF 004310 MOVE 'Outside Code Range' TO JZ-CHAR80 PRCustF 004320 MOVE '***' TO FOUND-VALUE OF JZCodes-JZSMth-SMth PRCustF 004330 ELSE PRCustF 004340 MOVE CODE-Value OF JZCodes-JZSMth-SMth(JZIX-JZSMth-SMth) PRCustF 004350 TO FOUND-VALUE OF JZCodes-JZSMth-SMth PRCustF 004360 END-IF. PRCustF 004370******************************************************************PRCustF 004380** **PRCustF 004390** Print Routine **PRCustF 004400** **PRCustF 004410******************************************************************PRCustF 004420* PRCustF 004430 RepNbr1-PRINT. PRCustF 004440 IF RepNbr1-LineCount >= 54 PRCustF 004450 MOVE JZ-RepNbr1 TO JZ-RepNbr1-Save PRCustF 004460 IF RepNbr1-PageNbr > ZERO PRCustF 004470 Write JZ-RepNbr1 FROM JZ-RepNbr1-HEADING AFTER PRCustF 004480 ADVANCING 2 LINES PRCustF 004490 END-IF PRCustF 004500 Move 0 TO RepNbr1-LineCount PRCustF 004510 Add 1 TO RepNbr1-PageNbr PRCustF 004520 MOVE RepNbr1-PageNbr TO PageNbr OF JZ-RepNbr1-HEADING PRCustF 004530 Write JZ-RepNbr1 FROM JZ-RepNbr1-HEADING AFTER ADVANCING PRCustF 004540 PAGE PRCustF 004550 WRITE JZ-RepNbr1 FROM RepNbr1-L1-H AFTER ADVANCING 2 LINESPRCustF 004560 WRITE JZ-RepNbr1 FROM JZ-RepNbr1-SAVE AFTER ADVANCING 2 PRCustF 004570 LINES PRCustF 004580 ELSE PRCustF 004590 WRITE JZ-RepNbr1 AFTER ADVANCING RepNbr1-SPACE LINES PRCustF 004600 END-IF. PRCustF 004610 ADD RepNbr1-SPACE TO RepNbr1-LineCount. PRCustF 004620 MOVE 1 TO RepNbr1-SPACE. PRCustF 004630******************************************************************PRCustF 004640** **PRCustF 004650** Sundry Routines **PRCustF 004660** **PRCustF 004670******************************************************************PRCustF 004680* PRCustF 004690* Format Date for reports PRCustF 004700 JZDT01. PRCustF 004710* Move Corresponding JZ-DATETIME-2 TO JZ-ReportTS PRCustF 004720 MOVE JZ-DAY OF JZ-DateTIME-2 TO JZ-DAY OF JZ-ReportTS. PRCustF 004730 MOVE JZ-YEAR OF JZ-DateTIME-2 TO JZ-YEAR OF JZ-ReportTS. PRCustF 004740 MOVE JZ-HOUR OF JZ-DateTIME-2 TO JZ-HOUR OF JZ-ReportTS. PRCustF 004750 MOVE JZ-MINUTE OF JZ-DateTIME-2 TO JZ-MINUTE OF JZ-ReportTS. PRCustF 004760 MOVE JZ-SECOND OF JZ-DateTIME-2 TO JZ-SECOND OF JZ-ReportTS. PRCustF 004770* Format Month PRCustF 004780 MOVE JZ-MONTH TO SMth OF JZSMth. PRCustF 004790 MOVE SMth OF JZSMth TO SEARCH-FOR OF JZCodes-JZSMth-SMth. PRCustF 004800 PERFORM JZCvt-JZSMth-SMth. PRCustF 004810 MOVE FOUND-VALUE OF JZCodes-JZSMth-SMth TO JZ-MONTH-NAME. PRCustF