H COPYRIGHT('A&K Wholesale, Inc. 2012') 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 :‚__________ €Revised Date : ___-__-__ ** // Project No :‚____ € ** // Reason : ** //******************************************************************************* //******************** // FILE DEFINITIONS ** //******************** FDTU020D CF E WORKSTN SFile(DTU020A:rrna) FSTRCIG UF A 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 CatError LIKE(*IN) Overlay(Indicators:51) D TypeError 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/Define MsgD D/Copy $Msg //******************* // FIELD NAMES ** //******************* D #Error S N D @Member S 10a D #Limit S Like(rrna) D pType S Like(sctype) D pCategory S Like(sccategory) D X S Like(rrna) D ErrorTest S N //************* // ProtoTypes * //************* D $BuildList PR D $PostList PR D/copy qproto,bwchelp *In-line help //***************** // ---CONTROL--- ** //***************** C FileKey KLIST 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; WRITE MSGSFLB; $BuildList(); 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; $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; 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; 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'; 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; ENDIF; ENDIF; ENDFOR; ENDIF; ENDSR; //**************************************************************** // SUBROUTINE - $EditB ** // PURPOSE - Validate new category panel fields. ** //**************************************************************** BEGSR $EditB; #Error = *Off; 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 - $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); rrna = rrna + 1; cattype = sctype; category = sccategory; carton = scctnretl; pack = scpackretl; cattypeH = sctype; categoryH = sccategory; WRITE DTU020A; 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 //****************************************************************** // Subprocedure - $PostList * // Purpose - Update the master file with the new retail * // prices. * //****************************************************************** P $PostList B D PI /free IF #Limit > *Zeros; FOR x = 1 to #Limit; CHAIN x DTU020A; IF %found(); IF category <> categoryH OR cattype <> cattypeH; pCategory = categoryH; // Either the type or category were pType = cattypeH; // changed. Delete the old one. CHAIN FileKey STRCIG; IF %found(STRCIG); DELETE STRCIGR; ENDIF; 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. sccategory = category; scctnretl = carton; scpackretl = pack; WRITE STRCIGR; ENDIF; ELSE; // Simply update existing record. pCategory = category; pType = cattype; CHAIN FileKey STRCIG; IF %found(STRCIG); scctnretl = carton; scpackretl = pack; UPDATE STRCIGR; ENDIF; ENDIF; ENDIF; ENDFOR; ENDIF; RETURN; /end-free P E Display File: DTU020D ********************************************************************* * 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. * ********************************************************************* * Revised By:‚ €Revision Date:‚dd mmmmmmmmm ccyy €* * Project No:‚ €* * Reason : * ********************************************************************* 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(17) 33 SFLDSP N31 SFLDSPCTL 31 SFLCLR 90 SFLEND(*MORE) CF06 OVERLAY 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) 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 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 PF: STRCIG ********************************************************************* * Name :‚STRCIG €* * Date :‚27 February 2012 €* * Programmer :‚Jerry C. Adams €* * Project No. :‚0135 €* * Description : Cigarette categories for store inventory. * ********************************************************************* * Revised By:‚ €Revision Date:‚dd mmmmmmmmm ccyy €* * Project No:‚ €* * Reason : * ********************************************************************* UNIQUE R STRCIGR TEXT('Cigarette Categories') SCTYPE 1A TEXT('Type: S=Specialty') COLHDG('Type') SCCATEGORY 50A TEXT('Cigarette category') COLHDG('Category') SCCTNRETL 9P 2 TEXT('Retail price per carton') COLHDG('Carton' 'Retail' 'Price') EDTCDE(J) SCPACKRETL 9P 2 TEXT('Retail price per pack') COLHDG('Pack' 'Retail' 'Price') EDTCDE(J) K SCTYPE K SCCATEGORY