Adding RPGLE example...

This commit is contained in:
wes
2019-07-31 18:25:28 -04:00
parent dd3eb8fa7f
commit 120f9cdbae
+524
View File
@@ -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!'