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!'