H COPYRIGHT('Discount Tobacco, Inc. 2015') H/copy $header //******************************************************************************* // Written By :?Jerry C. Adams ? ** // Date Written :?28 February 2012 ? ** // Project No :?0135 ? ** // Program Name :?DTU020 ? ** // Program Desc : Cigarette Inventory Master Maintenance ** //******************************************************************************* // Revised By :?Jerry C. Adams ?Revised Date : 18 September 2012 ** // Project No :?0194 ? ** // Reason : Provide the means by which a master record can be deleted. ** //******************************************************************************* // Revised By :?Jerry C. Adams ?Revised Date : 9 January 2015 ** // Project No :?0254 ? ** // Reason : Provide the means by which multiple price sets can be ** // maintained. ** //******************************************************************************* //******************** // FILE DEFINITIONS ** //******************** FDTU020D CF E WORKSTN SFile(DTU020A:rrna) F SFile(DTU020E:rrne) FSTRCIG UF A E K DISK 0254 FSTRSETID IF E K DISK //******************* // DATA STRUCTURES ** //******************* // Named Indicators D P_Indicators S * INZ(%Addr(*IN)) D Indicators DS Based(P_Indicators) D SF_Display LIKE(*IN) Overlay(Indicators:33) D SF_Clear LIKE(*IN) Overlay(Indicators:31) D TypeError LIKE(*IN) Overlay(Indicators:51) D CatError LIKE(*IN) Overlay(Indicators:52) D CtnError LIKE(*IN) Overlay(Indicators:53) D PckError LIKE(*IN) Overlay(Indicators:54) D SF_End LIKE(*IN) Overlay(Indicators:90) D Help LIKE(*IN) Overlay(Indicators:130) F1 D EOJ LIKE(*IN) Overlay(Indicators:132) F3 D AddRecord LIKE(*IN) Overlay(Indicators:135) F6 D Cancel LIKE(*IN) Overlay(Indicators:141) F12 D DeleteIt LIKE(*IN) Overlay(Indicators:152) F23 D/Define MsgD D/Copy $Msg //******************* // FIELD NAMES ** //******************* D #Error S N D @Member S 10a D #Limit S Like(rrna) D #LimitE S Like(rrne) D pType S Like(sctype) D pCategory S Like(sccategory) 0254 D pSet S Like(scset) D X S Like(rrna) D ErrorTest S N D #First S N D rrna_error S Like(rrna) D SetFound S N //************* // ProtoTypes * //************* D $BuildList PR 0254 D $BuildSet PR 0254 D $Select PR 0254 D DTU024 PR EXTPGM('DTU024') D/copy qproto,bwchelp *In-line help //***************** // ---CONTROL--- ** //***************** C FileKey KLIST 0254 C KFLD pSet C KFLD pType C KFLD pCategory /FREE EXSR $INIT; EXSR $MAIN; EXSR $EOJ; //**************************************************************** // SUBROUTINE - $INIT ** // PURPOSE - Program Initialization ** //**************************************************************** BEGSR $INIT; EXSR $MINIT; ENDSR; //**************************************************************** // SUBROUTINE - $MAIN ** // PURPOSE - Main Program Logic ** //**************************************************************** BEGSR $MAIN; DOW not eoj; $BuildSet(); WRITE DTU020EFK; EXFMT DTU020ECTL; IF AddRecord; DTU024(); ITER; ENDIF; $Select(); IF SetFound; EXSR $MainB; ENDIF; ENDDO; ENDSR; //**************************************************************** // SUBROUTINE - $MAINB ** // PURPOSE - Process Price List. ** //**************************************************************** BEGSR $MAINB; DOW not eoj AND not cancel; WRITE MSGSFLB; IF not #error; $BuildList(); ELSE; rrna = rrna_error; ENDIF; WRITE DTU020AFK; EXFMT DTU020ACTL; EXSR $CMsg; IF eoj; LEAVE; ENDIF; IF AddRecord; EXSR sub002; IF eoj; LEAVE; ENDIF; ITER; ENDIF; IF Help; @member = 'DTU020A'; bwchelp(@member); ITER; ENDIF; EXSR $EditA; IF #error; ITER; ENDIF; EXSR $PostList; ENDDO; ENDSR; //**************************************************************** // SUBROUTINE - SUB002 ** // PURPOSE - Edit and process new categories. ** //**************************************************************** BEGSR sub002; cattype = *Blanks; category = *Blanks; carton = *Zeros; pack = *Zeros; DOW not eoj AND not cancel; WRITE MSGSFLB; EXFMT DTU020B; EXSR $CMsg; IF Help; @member = 'DTU020B'; bwchelp(@member); ITER; ENDIF; IF eoj OR cancel; LEAVE; ENDIF; EXSR $EditB; IF #error; ITER; ENDIF; 0254 scset = @set; sctype = cattype; sccategory = category; scctnretl = carton; scpackretl = pack; WRITE STRCIGR; cattype = *Blanks; category = *Blanks; carton = *Zeros; pack = *Zeros; ENDDO; ENDSR; //**************************************************************** // SUBROUTINE - $EditA ** // PURPOSE - Validate the lines on Panel 'A'. ** //**************************************************************** BEGSR $EditA; #error = *Off; #First = *On; rrna_error = *Zeros; IF #limit > *Zeros; FOR x = 1 to #limit; CHAIN x DTU020A; IF %found(); errorTest = *Off; catError = *Off; TypeError = *Off; ctnError = *Off; pckError = *Off; IF cattype <> *Blanks AND cattype <> 'S' AND cattype <> '*'; typeError = *On; #error = *On; errorTest = *On; @MsgId = 'DTO0017'; EXSR $SMsg; ENDIF; IF category <= *Blanks; caterror = *On; #Error = *On; errorTest = *On; @MsgId = 'DTO0016'; EXSR $SMsg; ENDIF; IF carton < *Zeros; ctnError = *On; #error = *On; errorTest = *On; @MsgId = 'DTO0015'; EXSR $SMsg; ENDIF; IF pack < *Zeros OR pack > carton; pckError = *On; #error = *On; errorTest = *On; @MsgId = 'DTO0015'; EXSR $SMsg; ENDIF; IF errorTest; UPDATE DTU020A; IF #First; #first = *Off; rrna_error = x; ENDIF; ENDIF; ENDIF; ENDFOR; ENDIF; ENDSR; //**************************************************************** // SUBROUTINE - $EditB ** // PURPOSE - Validate new category panel fields. ** //**************************************************************** BEGSR $EditB; #Error = *Off; 0254 pSet = @set; pType = cattype; pCategory = category; CHAIN(n) FileKey STRCIG; IF %found(STRCIG); #Error = *On; @MsgId = 'DTO0018'; EXSR $SMsg; ENDIF; IF cattype <> *Blanks AND cattype <> 'S'; #Error = *On; @MsgId = 'DTO0017'; EXSR $SMsg; ENDIF; IF category <= *Blanks; #Error = *On; @MsgId = 'DTO0016'; EXSR $SMsg; ENDIF; IF carton < *Zeros; #Error = *On; @MsgId = 'DTO0015'; EXSR $SMsg; ELSE; IF pack < *Zeros OR pack > carton; #Error = *On; @MsgId = 'DTO0015'; EXSR $SMsg; ENDIF; ENDIF; ENDSR; //****************************************************************** // Subroutine - $PostList * // Purpose - Post the prices to STRCIG. * //****************************************************************** BEGSR $postlist; IF #Limit > *Zeros; FOR x = 1 to #Limit; CHAIN x DTU020A; IF %found(); SELECT; WHEN cattype = '*'; // Delete master record. EXSR $Delete; WHEN category <> categoryH OR cattype <> cattypeH; 0254 pSet = @set; pCategory = categoryH; // Either the type or category were pType = cattypeH; // changed. Delete the old one. CHAIN FileKey STRCIG; IF %found(STRCIG); DELETE STRCIGR; ENDIF; 0254 pSet = @set; pCategory = category; pType = cattype; CHAIN(n) FileKey STRCIG; IF not %found(STRCIG); // Add the changed back as a new sctype = cattype; // only if it doesn't already exist. scset = @set; sccategory = category; scctnretl = carton; scpackretl = pack; WRITE STRCIGR; ENDIF; OTHER; // Simply update existing record. pSet = @set; pCategory = category; pType = cattype; CHAIN FileKey STRCIG; IF %found(STRCIG); scctnretl = carton; scpackretl = pack; UPDATE STRCIGR; ENDIF; ENDSL; ENDIF; ENDFOR; ENDIF; ENDSR; //**************************************************************** // Subroutine - $Delete * // Purpose - Vaslidate requested deletion. * //**************************************************************** 0194 BEGSR $Delete; 0254 pSet = @set; pCategory = categoryH; pType = cattypeH; CHAIN(n) FileKey STRCIG; IF %found(STRCIG); catDelete = sccategory; EXFMT DTU020C; IF DeleteIt; CHAIN FileKey STRCIG; DELETE STRCIGR; ENDIF; ENDIF; ENDSR; //**************************************************************** // SUBROUTINE - $EOJ ** // PURPOSE - End of Program ** //**************************************************************** BEGSR $EOJ; *INLR = *On; RETURN; ENDSR; /END-FREE C/Define MsgC C/Copy $Msg //****************************************************************** // Subprocedure - $BuildList * // Purpose - Build the list of current cigarette categories. * //****************************************************************** P $BuildList B D PI /free SF_Clear = *On; WRITE DTU020ACTL; SF_Clear = *Off; rrna = *Zeros; SETLL *Loval STRCIG; READ(n) STRCIG; DOW not %eof(STRCIG); 0254 IF scset = @set; rrna = rrna + 1; cattype = sctype; category = sccategory; carton = scctnretl; pack = scpackretl; cattypeH = sctype; categoryH = sccategory; WRITE DTU020A; 0254 ENDIF; READ(n) STRCIG; ENDDO; #Limit = rrna; IF rrna > *Zeros; SF_Display = *On; SF_End = *On; rrna = 1; ELSE; SF_Display = *Off; SF_End = *Off; ENDIF; RETURN; /end-free P E //****************************************************************** 0254 // Subprocedure - $BuildSet * // Purpose - Build the list of price sets. * //****************************************************************** P $BuildSet B D PI /free SF_Clear = *on; WRITE DTU020ECTL; SF_Clear = *Off; rrne = *Zeros; SETLL *Loval STRSETID; READ STRSETID; DOW not %eof(STRSETID); rrne = rrne + 1; @select = *Blanks; @set = ssset; @sdesc = ssdesc; WRITE DTU020E; READ STRSETID; ENDDO; #LimitE = rrne; IF rrne > *Zeros; SF_Display = *On; SF_End = *On; rrne = 1; ELSE; SF_Display = *Off; SF_End = *Off; ENDIF; RETURN; /end-free P E //****************************************************************** 0254 // Subprocedure - $Select * // Purpose - Select the price set to maintain. * //****************************************************************** P $Select B D PI /free setFound = *Off; IF #LimitE > *Zeros; FOR x = 1 to #LimitE; CHAIN x DTU020E; IF %found(); IF @select > *Blanks; SetFound = *On; LEAVE; ENDIF; ENDIF; ENDFOR; ENDIF; RETURN; /end-free P E ********************************************************************* * Name :?DTU020D ?* * Date :?27 February 2012 ?* * Programmer :?Jerry C. Adams ?* * Project No. :?0135 ?* * Description : Cigarette Inventory Master Maintenance. * * Define cigarette categories and retail prices of * * each category for store inventory. * ********************************************************************* DSPSIZ(24 80 *DS3) CF03 CF01 R DTU020A SFL CATTYPE 1 B 5 3DSPATR(CS) 51 DSPATR(RI) CATEGORY 50 B 5 7DSPATR(CS) 52 DSPATR(RI) CHECK(LC) CARTON 5 2B 5 58EDTWRD(' . ') DSPATR(CS) 53 DSPATR(RI) PACK 5 2B 5 65EDTWRD(' . ') DSPATR(CS) 54 DSPATR(RI) CATTYPEH 1 H CATEGORYH 50 H R DTU020ACTL SFLCTL(DTU020A) SFLSIZ(9999) SFLPAG(0017) OVERLAY CF06 CF12 33 SFLDSP N31 SFLDSPCTL 31 SFLCLR 90 SFLEND(*MORE) RRNA 4S 0H SFLRCDNBR 1 2'DTU020A' 1 28'Cigarette Inventory Master' DSPATR(UL) 1 66DATE EDTCDE(Y) 2 66TIME 3 58'Carton' 3 66'Pack' 4 2'Type' DSPATR(UL) 4 7'Category - ' DSPATR(UL) 4 58'Retail' DSPATR(UL) 4 65'Retail' DSPATR(UL) R DTU020AFK 23 2'F1=Help' DSPATR(UL) COLOR(BLU) 23 10'F3=End' DSPATR(UL) COLOR(BLU) 23 17'F6=Add Category' DSPATR(UL) COLOR(BLU) 23 33'F12=Cancel' DSPATR(UL) COLOR(BLU) R DTU020B CF12 OVERLAY 1 2'DTU020B' 1 28'Cigarette Inventory Master' DSPATR(UL) 1 66TIME 2 66DATE EDTCDE(Y) 4 2'Mode: Add Category' 6 3'Category..............' CATEGORY 50 B 6 26DSPATR(CS) CHECK(LC) 7 3'Carton Retail Price...' CARTON 5 2B 7 26EDTWRD(' . ') DSPATR(CS) 7 33'(2 dec.)' 8 3'Pack Retail Price.....' PACK 5 2B 8 26EDTWRD(' . ') DSPATR(CS) 8 33'(2 dec.)' 9 3'Type..................' CATTYPE 1 B 9 26DSPATR(CS) 9 28'(S=Specialty Cigarette)' 23 2'F1=Help' DSPATR(UL) COLOR(BLU) 23 10'F3=End' DSPATR(UL) COLOR(BLU) 23 17'F12=Cancel' DSPATR(UL) COLOR(BLU) R DTU020C CF23 CF12 1 2'DTU020C' 1 28'Cigarette Inventory Master' DSPATR(UL) 1 66DATE EDTCDE(Y) 2 66TIME 6 13'You have elected to delete categor- y:' CATDELETE 50 O 7 13 23 2'F3=End' DSPATR(UL) COLOR(BLU) 23 9'F12=Cancel' DSPATR(UL) COLOR(BLU) 23 20'F23=Confirm Deletion' DSPATR(UL) COLOR(YLW) R DTU020E SFL @SELECT 1 B 5 21 @SET 1 O 5 28 @SDESC 30 O 5 31 R DTU020ECTL SFLCTL(DTU020E) 33 SFLDSP SFLSIZ(9999) SFLPAG(17) OVERLAY CF06 N31 SFLDSPCTL 31 SFLCLR 90 SFLEND(*MORE) RRNE 4S 0H SFLRCDNBR 1 2'DTU020E' 1 30'Cigarette Price Tiers' 1 65DATE EDTCDE(Y) 2 65TIME 4 18'Select' DSPATR(UL) 4 27'Set' DSPATR(UL) 4 31'Description ' DSPATR(UL) R DTU020EFK 24 3'F3=End' DSPATR(UL) COLOR(BLU) 24 10'F6=Maintain Set' DSPATR(UL) COLOR(BLU) R MSGSFLA SFL SFLMSGRCD(24) TEXT('Error message subfile') @KEY SFLMSGKEY @PGMQ SFLPGMQ R MSGSFLB SFLCTL(MSGSFLA) TEXT('Error message control file') OVERLAY SFLDSP SFLDSPCTL SFLINZ N03 SFLEND SFLSIZ(0002) SFLPAG(0001) @PGMQ SFLPGMQ