From 120f9cdbae1772381142d8a936a4b3ab90067220 Mon Sep 17 00:00:00 2001 From: Wesley Ray Date: Wed, 31 Jul 2019 18:25:28 -0400 Subject: [PATCH] Adding RPGLE example... --- rpgle_example.rpg | 524 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 524 insertions(+) create mode 100644 rpgle_example.rpg diff --git a/rpgle_example.rpg b/rpgle_example.rpg new file mode 100644 index 0000000..ccbd0a4 --- /dev/null +++ b/rpgle_example.rpg @@ -0,0 +1,524 @@ + F********************************************************************************************** + F* AUTHOR: Wes Ray + F* + F* This program is called by __________ when the user presses F10 to run the report. The input + F* file BATCH is a physical file in QTEMP that is created/cleared each time __________ is run. + F* BATCH will contain two kinds of records: + F* + F* 'PATTERN_NAME ' 'COL#' 'YARDS' + F* OR + F* 'USER_MESSAGE ' '50 character message to be printed at top of report' + F* + F* In the interactive program there is a screen that allows the user to enter notes (up 50 char + F* each) that will appear at the top of the report. Using a special string in the pattern field + F* allows us to identify that the rest of the record is a user message. This allows the user to + F* enter as many as they would like. The program first reads though the entire BATCH file and + F* prints all USER_MESSAGEs to the top of the report, SETLL is called to reposition the file + F* back to the begining and the file is then processed again for the SKUs entered. + F* + F* 12/23/13 - I'm an idiot. All I needed to do to sort by more than one field was overlay a + F* larger field overtop of the type and color and sort by that. Of course this only + F* works if the composite key you want to sort by resides in contiguous space. + F* At any rate, the warp and fill lists on this report are now sorted by type AND + F* then color which makes them much easier to use when the lists get long. + F* 01-15-14 nw-01 call program to check delivery & collection (#1299) + F* 01/21/14 WR-01 Add finish description to SKU detail page. (#1310) + F********************************************************************************************** + FQPRINT O F 132 PRINTER OFLIND(*INOF) INFDS(PRTFBK) + FFILE1 IF E K DISK WR-01 + FFILE2 IF E K DISK WR-01 + FBATCH IF F 65 DISK + F********************************************************************************************** + D* Named Constants + D********************************************************************************************** + D Title C '**REDACTED**' + D Title1 C 'Yarn Projection Report' + D PGM C 'PGM: REDACTED' + D*linesPerPg C CONST(64) + D********************************************************************************************** + D* Variables + D********************************************************************************************** + D sysDate S D DATFMT(*USA) INZ(*sys) + D sysTime S T TIMFMT(*USA) INZ(*sys) + D yardsInt S 5 0 INZ(0) + D count S 3 0 INZ(0) + D linesNeeded S 2 0 INZ(0) + D goToNewPage S 1 INZ('N') + D i S 4 0 INZ(1) index for lists + D j S 3 0 INZ(1) index for fills + D wrpInLst S 1A INZ('N') + D fllInLst S LIKE(wrpInLst) + D grandTotPicks S +2 LIKE(totalPicks) + D grandTotDays S LIKE(daysToWeave) + D lastFillPrnt S 6A + D finishPrint S 27A WR-01 + D delv1 S 3A INZ('8wk') nw-01 + D delv2 S 6A INZ('8-10wk') nw-01 + D delv3 S 7A INZ('10-12wk') nw-01 + D delvPrnt S 7A nw-01 + D********************************************************************************************** + D projection DS + D errorMsg 1 14 + D style1 15 18 + D style2 19 23 0 + D patternNum 24 28 0 + D totalPicks 29 38 0 + D piecePicks 39 44 0 + D daysToWeave 45 50 2 + D warpYarn 51 56 + D warpColor 55 76 + D WARP 51 76 + D fillType 77 148 + D fillTypes 6A OVERLAY(fillType) DIM(12) + D fillColor 149 388 + D fillColors 20A OVERLAY(fillColor) DIM(12) + D fillNeed 389 448 + D fillNeeded 5 0 OVERLAY(fillNeed) DIM(12) + D fillOnHnd 449 508 + D fillOnHand 5 0 OVERLAY(fillOnHnd) DIM(12) + D fillReq 509 568 + D fillReqd 5 0 OVERLAY(fillReq) DIM(12) + D fillBalan 569 628 + D fillBalanc 5 0 OVERLAY(fillBalan) DIM(12) + D fillDelCd 629 640 + D fillDelCod 1 OVERLAY(fillDelCd) DIM(12) + D DERP1 641 644 + D DERP2 646 649 + D warpStyle 641 649 + D********************************************************************************************** + D delv_coll DS nw-01 + D #8week 1 1 nw-01 + D #8to10 2 2 nw-01 + D #10to12 3 3 nw-01 + D #collection 4 7 nw-01 + D********************************************************************************************** + D* Printer file information data structure + D********************************************************************************************** + D PRTFBK DS + D CUR_LINE 367 368I 0 * Current line num + D********************************************************************************************** + D* Data structure for printing warp information because wrpLstDS(i).wrpTypeDS is a little long + D* for the O-specs ;) + D********************************************************************************************** + D pWARP DS + D pWrpType 1 9A + D pWrpCol 10 29A + D pWrpYds 30 34 0 + D********************************************************************************************** + D* Data structure for printing fill information because fllLstDS(i).fllTypeDS is a little long + D* for the O-specs ;) + D********************************************************************************************** + D pFILL DS + D pFllType 1 6A + D pFllCol 7 26A + D pFllLbs 27 32 0 + D pllOHnDS 33 37 0 + D pllReqDS 38 42 0 + D pllBalDS 43 47 0 + D********************************************************************************************** + D* Basically an ILE equivalent to a multiple occurence data structure. This is serves as a list + D* of unnique warps required by all of the SKUs entered. So, if 7 of the SKUs require A-1600 + D* BLACK warps it will only occur in this list once but with the total yardage of the 7 SKUs + D* + D* QUALIFIED is required for data structures with the DIM keyword. QUALIFIED allows you to + D* access the subfields like this: wrpLstDS(i).wrpTypeDS where i is the "occurence" and the + D* name after the dot is the sub field you wish to access. + D********************************************************************************************** + D wrpLstDS DS DIM(100) QUALIFIED + D wrpTypeDS 1 9A + D wrpColDS 10 29A + D wrpTyClDS 1 29A * Used to sort array + D wrpYdsDS 30 34 0 + D********************************************************************************************** + D fllLstDs DS DIM(1200) QUALIFIED + D fllTypeDS 1 6A + D fllColDS 7 26A + D fllTyClDS 1 26A * Used to sort array + D fllLbsDS 27 32 0 + D fllOHnDS 33 37 0 + D fllReqDS 38 42 0 + D fllBalDS 43 47 0 + D********************************************************************************************** + D getProjection PR ExtPgm('______') + D Parm1 LIKE(PATT) + D Parm2 LIKE(COLO) + D Parm3 LIKE(YARD) + D Parm4 LIKE(projection) + D********************************************************************************************** + D getDelv_Coll PR ExtPgm('________') nw-01 + D Parm1 LIKE(PATT) nw-01 + D Parm2 LIKE(delv_coll) nw-01 + D********************************************************************************************** + IBATCH NS + I 1 15 PATT + I 16 19 COLO + I 20 24 YARD + I 16 65 userMsg + C********************************************************************************************** + C* M A I N L I N E P R O C E S S I N G + C********************************************************************************************** + /free + EXCEPT HEADER; //Write report heading + EXSR writeUsrMsg; + EXCEPT detailHead; //Write detail column headers + READ BATCH; //Priming read + + DOW NOT (%EOF(BATCH)); + IF NOT (PATT = 'USER_MESSAGE '); + count += 1; //Count number of SKUs processed + + CALLP getProjection(PATT:COLO:YARD:projection); //Get projection info + + yardsInt = %DEC(YARD:5:0); //Cast YARDS to an int for formatting on report + grandTotPicks += totalPicks; //accumulate picks + grandTotDays += daysToWeave; //accumulate days + + CALLP getDelv_Coll(PATT:delv_coll); //Get delivery & collection info + EXSR CHKDELVCOLL; + + CHAIN PATT PATMAST; //Look up pattern to get finish key WR-01 + IF %FOUND(PATMAST); | + CHAIN PFNHKY FINISHP; //Look up finish description w/ finish key | + IF %FOUND(FINISHP); | + finishPrint = FNHDES; //Print finish description on first page | + ENDIF; | + ENDIF; WR-01 + + EXSR CHKOVERFLOW; + EXCEPT detail; //Write sku detail line + + EXSR processWarp; //Add this SKUs warp to the warp list + EXSR processFill; //Add this SKUs fill to the fill list + + projection = *BLANKS; //Explicitly clear these variables just in case + delv_coll = *BLANKS; + finishPrint = *BLANKS; + ENDIF; + READ BATCH; //grab next sku from batch input file + ENDDO; + + EXCEPT detailFoot; //write sku detail footer. total days to weave etc.. + + EXCEPT NEWPAGE; + EXCEPT HEADER; //go to new page + + EXSR writeWarps; //write warp information + + EXCEPT NEWPAGE; + EXCEPT HEADER; //go to new page + + EXSR writeFill; //write fill information + + //Tidy up any open resources and exit. + *INLR = *ON; + RETURN; + /end-free + C********************************************************************************************** + C* E N D M A I N L I N E P R O C E S S I N G + C********************************************************************************************** + C* CHKDELVCOLL - Sub-routine to check delivery codes + C********************************************************************************************** + C CHKDELVCOLL BEGSR nw-01 + /free + IF #8week = '*'; + delvPrnt = delv1; + ENDIF; + IF #8to10 = '*'; + delvPrnt = delv2; + ENDIF; + IF #10to12 = '*'; + delvPrnt = delv3; + ENDIF; + /end-free + C ENDSR nw-01 + C********************************************************************************************** + C* CHKOVERFLOW - Sub-routine to print report header during page overflow + C********************************************************************************************** + C CHKOVERFLOW BEGSR + /free + IF *INOF = *ON; + EXCEPT Header; + *INOF = *OFF; + ENDIF; + /end-free + C ENDSR + C********************************************************************************************** + C* warpInList - Sub-routine that loops throught the wrpLstDS data structure array to see if + C* the warp from the last processed SKU is already on the list. If it is the + C* yardage from the the last processed SKU is added to what is already in the list + C* Otherwise wrpInLst remains 'N' causing addWarp to be executed. + C********************************************************************************************** + C warpInList BEGSR + /free + i = 1; + //DSPLY warpStyle; + DOW NOT (i > 100); + + IF warpStyle = wrpLstDS(i).wrpTypeDS; + IF warpColor = wrpLstDS(i).wrpColDS; + wrpInLst = 'Y'; //Warp already in list + wrpLstDS(i).wrpYdsDS += %DEC(yard:5:0); //Add current yardage to yards for this warp + LEAVE; //Exit do-while loop + ENDIF; + ENDIF; + + i += 1; + ENDDO; + + /end-free + C ENDSR + C********************************************************************************************** + C* fillInList - Sub-routine that checks for every fill required by the last SKU processed if it + C* is already in the fllLstDS data structure array. If it is; the lbs required and + C* lbs needed are added to what is already in the list and the balance is then + C* recalculated. Otherwise fllInLst remains 'N' causing addFill to be executed. + C********************************************************************************************** + C fillInList BEGSR + /free + i = 1; + DOW NOT (i > 1200); + + IF (fillTypes(j) = fllLstDS(i).fllTypeDS) AND + NOT (fillTypes(j) = *BLANKS); + IF fillColors(j) = fllLstDS(i).fllColDS; + fllInLst = 'Y'; //Fill already in list + fllLstDS(i).fllLbsDS += fillNeeded(j); //Add current LBS to LBS for this fill + fllLstDS(i).fllBalDS = fllLstDS(i).fllOHnDS; + fllLstDS(i).fllBalDS -= fllLstDS(i).fllReqDS; + fllLstDS(i).fllBalDS -= fllLstDS(i).fllLbsDS; + LEAVE; //Exit do-while loop + ENDIF; + ENDIF; + + i += 1; + ENDDO; + + /end-free + C ENDSR + C********************************************************************************************** + C* addWarp - Sub-routine to add a warp to the wrpLstDS data structure array. This is called if + C* wrpInLst = 'N' after calling warpInList. + C********************************************************************************************** + C addWarp BEGSR + /free + i = 1; + + DOW NOT (i > 100); + IF wrpLstDS(i).wrpTypeDS = *BLANKS; + wrpLstDS(i).wrpTypeDS = warpStyle; + wrpLstDS(i).wrpColDS = warpColor; + wrpLstDS(i).wrpYdsDS = %DEC(yard:5:0); + LEAVE; + ENDIF; + + i += 1; + ENDDO; + + /end-free + C ENDSR + C********************************************************************************************** + C* addFill - Sub-routine to add a fill yarn to the fllLstDS data structure array. This is + C* called if fllInLst = 'N' after fillInList is called. + C********************************************************************************************** + C addFill BEGSR + /free + i = 1; + + DOW NOT (i > 1200); + IF fllLstDS(i).fllTypeDS = *BLANKS; + fllLstDS(i).fllTypeDS = fillTypes(j); + fllLstDS(i).fllColDS = fillColors(j); + fllLstDS(i).fllLbsDS = fillNeeded(j); + fllLstDS(i).fllOHnDS = fillOnHand(j); + fllLstDS(i).fllReqDS = fillReqd(j); + fllLstDS(i).fllBalDS = fillBalanc(j); + LEAVE; + ENDIF; + + i += 1; + ENDDO; + + /end-free + C ENDSR + C********************************************************************************************** + C* processWarp - Sub-routine that calls warpInList and addWarp if needed for each SKU processed + C********************************************************************************************** + C processWarp BEGSR + /free + wrpInLst = 'N'; + EXSR warpInList; + IF wrpInLst = 'N'; + EXSR addWarp; + ENDIF; + /end-free + C ENDSR + C********************************************************************************************** + C* processFill - Sub-routine that calls fillInList and addFill if needed for each fill yarn + C* required by the last read SKU. + C********************************************************************************************** + C processFill BEGSR + /free + j = 1; + + DOW NOT (j > 12); + fllInLst = 'N'; + EXSR fillInList; + IF fllInLst = 'N'; + EXSR addFill; + ENDIF; + j += 1; + ENDDO; + /end-free + C ENDSR + C********************************************************************************************** + C* writeWarps - Sub-routine that sorts the wrpLstDs data structure array by wrpTypeDS and then + C* writes the list of required warps to the report. + C********************************************************************************************** + C writeWarps BEGSR + /free + SORTA %subarr(wrpLstDS(*).wrpTyClDS : 1 : %elem(wrpLstDs)); //Sort array by type then color + EXCEPT warpDetHed; + i = 1; + + DOW NOT (i > 100); + EXSR CHKOVERFLOW; + IF NOT (wrpLstDS(i).wrpTypeDS = *BLANKS); + pWARP = wrpLstDS(i); + EXCEPT warpDetail; + ENDIF; + i += 1; + ENDDO; + /end-free + C ENDSR + C********************************************************************************************** + C* writeFill - Sub-routine that sorts the fllLstDS data structure array by fllTypeDS and then + C* writes the required fill yarn information to the report. + C********************************************************************************************** + C writeFill BEGSR + /free + SORTA %subarr(fllLstDS(*).fllTyClDS : 1 : %elem(fllLstDs)); //Sort array by type then color + EXCEPT fillDetHed; + i = 1; + + DOW NOT (i > 1200); + IF *INOF = *ON; + EXCEPT Header; + EXCEPT fillDetHed; + *INOF = *OFF; + ENDIF; + IF NOT (fllLstDS(i).fllTypeDS = *BLANKS); + pFILL = fllLstDS(i); + + IF (pllBalDS < 0); + *IN88 = *ON; //*IN88 Conditions a negative balance note on the report + ENDIF; + + IF NOT (pFllType = lastFillPrnt); + EXCEPT BLANK; //Inserts a blank line between different types of fill on the report + ENDIF; + + EXCEPT fillDetail; + lastFillPrnt = pFllType; + ENDIF; + i += 1; + *IN88 = *OFF; + ENDDO; + /end-free + C ENDSR + C********************************************************************************************** + C* writeUsrMsg - Sub-Routine that loops through every record in BATCH at the start of the + C* program. For any record encountered where the pattern name is 'USER_MESSAGE ' + C* the rest of the record is written to the top of the report. These are the + C* notes the user entered in the interactive program. + C********************************************************************************************** + C writeUsrMsg BEGSR + /free + READ BATCH;//Priming read + DOW NOT (%EOF(BATCH)); + IF (PATT = 'USER_MESSAGE '); + EXSR CHKOVERFLOW; + EXCEPT usrMSG; + ENDIF; + READ BATCH; + ENDDO; + SETLL *START BATCH; //Reposition BATCH for SKU processing + /end-free + C********************************************************************************************** + C ENDSR + OQPRINT E Header 1 2 + O Title 23 + O Title1 51 + O 96 'Page' WR-01 + O PAGE 101 WR-01 + O E Header 2 + O PGM 16 + O sysDate 40 + O sysTime 50 + O E newPage 1 + O 1 ' ' + O E blank 1 + O 1 ' ' + O E usrMSG + O userMsg 52 + O********************************************************************************************** + O E detailHead 1 nw-01 + O 54 'Days to' nw-01 + O 65 'Extended' nw-01 + O E detailHead 1 2 + O 8 'Pattern' nw-01 + O 23 'Color' | + O 30 'Yards' | + O 44 'Picks' | + O 53 'Weave' | + O 65 'Delivery' | + O 73 'Coll.' nw-01 + O 81 'Finish' WR-01 + O E detail 1 + O PATT 16 nw-01 + O COLO 22 | + O yardsInt Z 30 | + O totalPicks O 44 | + O daysToWeave O 53 | + O delvPrnt b 64 | + O #collection 72 nw-01 + O finishPrint 102 WR-01 + O********************************************************************************************** + O E detailFoot 1 1 + O count z 18 + O 23 'SKUs' + O E detailFoot 1 + O grandTotPicks O 18 + O 24 'Picks' + O E detailFoot 1 + O grandTotDays O 18 + O 32 'Days to weave' + O********************************************************************************************** + O E warpDetHed 2 + O 19 'Warp Yards Needed' + O E warpDetHed 2 + O 11 'Type' + O 18 'Color' + O E warpDetail 1 + O pWrpType 11 + O pWrpCol 33 + O pWrpYds O 40 + O 46 'Yards' + O********************************************************************************************** + O E fillDetHed 2 + O 18 'Fill Information' + O E fillDetHed 1 + O 6 'Type' + O 15 'Color' + O 37 'Needed' + O 51 'On-Hand' + O 61 'Required' + O 71 'Balance' + O E fillDetail 1 + O pFllType 8 + O pFllCol 30 + O pFllLbs O 37 + O pllOHnDS O 51 + O pllReqDS O 61 + O pllBalDS O 71 + O 88 93 '<== Negative Balance!' + \ No newline at end of file