Adding RPGLE example...
This commit is contained in:
@@ -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!'
|
||||
|
||||
Reference in New Issue
Block a user