*--------------------------------------------------------------- * * Porgram: ORDENTR * * This program allows a user to enter and confirm an order. It sends * a print request to a batch job via a data queue. The program only * handles District 1 and Warehouse '0001'. * * INDICATOR USAGE: * 03 - F3=Exit * 04 - F4=Prompt bob * 06 - F6=Accept order bob * 12 - F12=Cancel bob * 16 - F16=Spooled files * 40 - SFLDSP * 41 - SFLDSPCTL * 44 - SFLCLR * 79 - OVERLAY on FKEY record format to control clearing display * 80 - Customer record not found * 81 - Part record not found * 82 - Stock record not found * 83 - Invalid quantity * 84 - Both part and quantity must be specified * 99 - General I/O errors * LR - Deactivate program and return to caller * * Compile instructions: * CRTRPGMOD * CRTPGM BIND(QQFENV/QSYS) * * If running as a WebFaced program, library WRKSPLFRPG must be * in the library list to display spooled files. * *--------------------------------------------------------------------- * FORDENTD CF E WORKSTN SFILE(ORDSFL:SflRrn) FITEM IF E K DISK FDSTRCT UF E K DISK FCSTMR UF A E K DISK FSTOCK UF E K DISK FORDERS O A E K DISK FORDLIN O A E K DISK F* Enter this line and save the file * * Mnemonic values D $DqName C CONST('ORDERS ') D $DqLib C CONST('ORDLIB ') D $True C CONST('1') D $False C CONST('0') D $Warehouse C CONST('0001') D $District C CONST(1) D $Panel1 C CONST(1) D $Panel2 C CONST(2) D $Change C CONST(2) * * Miscellaneous variables D SflRrn S 4 0 D Error S 1 D Exit S 1 INZ($False) D Exit2 S 1 INZ($False) D DspPnl S 1 0 INZ($Panel1) D SflCnt S LIKE(SflRrn) D OrdCnt S 5 0 D OrdTot S +2 LIKE(CYTD) bob * * Data queue variables D DqName S 10 D DqLib S 10 D QueDtaLen S 5 0 INZ(%SIZE(QueDta)) D Quedta DS INZ D CustomerID LIKE(CID) D DistrictID LIKE(CDID) D WarehousID LIKE(CWID) D OrderID LIKE(OID) * * Customer info returned by SLTCUSTR D CustInfo DS INZ D CustId 4 D CustFName 16 D CustInitial 2 D CustLName 16 D CustAddr1 20 D CustAddr2 20 D CustCity 20 D CustState 2 D CustPostCode 10 * * Part info returned by SLTPARTR D PartInfo DS INZ D PartId 6 D PartDesc 24 D PartPrice 5 2 D PartQty 5 0 * * Date/Time D DS INZ D DateTime 14 0 D Time 6 0 OVERLAY(DateTime:1) D Date 8 0 OVERLAY(DateTime:7) D Today S D * *--------------------------------------------------------------------- * MAINLINE: * *--------------------------------------------------------------------- * C MoveL 'ORDENTR' PGMQ * Until the user chooses to exit ... C DOU Exit = $True * * Display the panel to user ... C SELECT * ... prompt for a customer C WHEN DspPnl = $Panel1 C Eval *in77 = *off C EXSR RqsCust * ... prompt for an order C WHEN DspPnl = $Panel2 C Eval *in77 = *on C EXSR RqsPart C ENDSL * C* Eval *in89 = *off C ENDDO * C EXSR EndPgm *--------------------------------------------------------------------- * SUBROUTINE: RqsCust * * To prompt for a customer * *--------------------------------------------------------------------- CSR RqsCust BEGSR * ---------- * Display the prompt for a customer C WRITE FKEY C EXFMT PROMPT C SETON 79 * * Clear error indicators C EXSR ClrError * * Process the user's request ... C *IN03 CASEQ *ON EndPgm C *IN04 CASEQ *ON SltCust C *IN12 CASEQ *ON EndPgm C *IN16 CASEQ *ON WrkSplF C CAS VfyCust C ENDCS * CSR ENDSR *--------------------------------------------------------------------- * SUBROUTINE: WrkSplf * * Display spooled files * The WebFace API is called to determine if the job is running * as a Webfaced job to invoke the appropriate spooled file program *--------------------------------------------------------------------- CSR WrkSplf BEGSR * C Call 'QCMDEXC' C Parm 'WRKSPLF' CMD 7 C Parm 7 CMDLEN 15 5 * CSR ENDSR *--------------------------------------------------------------------- * SUBROUTINE: SltCust * * To prompt a selection list of customers * *--------------------------------------------------------------------- CSR SltCust BEGSR * ---------- C CALL 'SLTCUSTR' CustSlt * * Set up the display fields ... C MOVE CustId CID C MOVE CustAddr1 CADDR1 C MOVE CustAddr2 CADDR2 C MOVE CustCity CCITY C MOVE CustState CSTATE C MOVE CustPostCode CZIP * C EXSR VfyCust * CSR ENDSR *--------------------------------------------------------------------- * SUBROUTINE: VfyCust * * To verify a valid customer * *--------------------------------------------------------------------- CSR VfyCust BEGSR * ---------- * Clear customer fields ... C MOVE *BLANKS CUSTOMER C MOVE *BLANKS CADDR1 C MOVE *BLANKS CADDR2 C MOVE *BLANKS CCITY C MOVE *BLANKS CSTATE C MOVE *BLANKS CZIP * * If we have a customer number then verify it ... * *IN80 ==> ERRMSG C IF CID <> *BLANK C MOVE CID CustomerId * ADDED LRS the (N) on the chain C CustKey CHAIN(N) CSRCD 80 * * If the customer number is valid ... C IF *IN80 = *OFF C EVAL DspPnl = $Panel2 * * Format the customer name C EVAL CUSTOMER = %TRIM(CLAST) + ', ' + C %TRIM(CFIRST) + ' ' + %TRIM(CINIT) * * Determine the next order number ... C EXSR GetOrdNbr * C ENDIF * C ENDIF * CSR ENDSR *--------------------------------------------------------------------- * SUBROUTINE: ClrError * * To clear any error indicators * *--------------------------------------------------------------------- CSR ClrError BEGSR * ---------- * Clear error indicators C MOVEA *OFF *IN(80) C EVAL Error = $False * CSR ENDSR *--------------------------------------------------------------------- * SUBROUTINE: RqsPart * * To prompt for a part * *--------------------------------------------------------------------- CSR RqsPart BEGSR * ---------- * C WRITE FKEY C WRITE PROMPT * * Display the order entry panel * -- *IN40 ==> SFLDSP C IF SflCnt > *ZERO C SETON 40 C ENDIF C SETON 41 C EXFMT ORDCTL * * Clear error indicators C EXSR ClrError * * Process the user's request ... C *IN03 CASEQ *ON EndPgm C *IN04 CASEQ *ON SltPart C *IN06 CASEQ *ON CmtOrder C *IN12 CASEQ *ON Cancel C* *IN12 CASEQ *ON EndPgm C *IN16 CASEQ *ON WrkSplf C CAS Process C ENDCS * CSR ENDSR * *--------------------------------------------------------------------- * SUBROUTINE: Main * * *--------------------------------------------------------------------- CSR Cancel BegSr C SETOFF 4041 C SETON 44 C WRITE ORDCTL C SETOFF 44 C Eval sflcnt = 0 C Eval sflrrn = sflcnt C Eval CID = *Blanks C Eval dsppnl = $Panel1 CSR EndSr * *--------------------------------------------------------------------- * SUBROUTINE: SltPart * * To prompt a selection list of parts * *--------------------------------------------------------------------- CSR SltPart BEGSR * ---------- C CALL 'SLTPARTR' PartSlt C IF PartId <> *BLANK C MOVE PartId PARTNBR C MOVE PartDesc PARTDSC C ENDIF * CSR ENDSR *--------------------------------------------------------------------- * SUBROUTINE: Process * * To process the customer action * *--------------------------------------------------------------------- CSR Process BEGSR * ---------- * * Verify part number is valid C EXSR VfyPart * * Verify quantity is valid C IF Error = $False C EXSR VfyQty C ENDIF * * Update order list in subfile C IF Error = $False C EXSR AddOrder C ENDIF * * Need to check for option 2 C IF SflCnt > *ZERO C EXSR ChgOrder C ENDIF * CSR ENDSR *--------------------------------------------------------------------- * SUBROUTINE: VfyPart * * To verify a valid part * *--------------------------------------------------------------------- CSR VfyPart BEGSR * ---------- * Assume part number is not valid C EVAL Error = $True * If we have a part number then verify it ... * *IN81 ==> ERRMSG C IF PARTNBR <> *BLANK C MOVE PARTNBR IID C ItemKey CHAIN ITRCD 81 * C IF *IN81 = *OFF C EVAL Error = $False C MOVE IID PARTNBR C MOVE INAME PARTDSC C ENDIF * C ENDIF * CSR ENDSR *--------------------------------------------------------------------- * SUBROUTINE: VfyQty * * To verify a valid quantity * *--------------------------------------------------------------------- CSR VfyQty BEGSR * ---------- * Assume quantity is not valid C EVAL Error = $True * If we have a quantity then verify it ... * *IN82 ==> ERRMSG C IF PARTQTY > *ZERO C MOVE PARTNBR IID C StockKey CHAIN(N) STRCD 82 * C IF *IN82 = *OFF C EVAL Error = $False C ENDIF * C IF PartQty > STQTY C SETON 83 C EVAL Error = $True C ENDIF * C ENDIF * CSR ENDSR * *--------------------------------------------------------------------- * SUBROUTINE: AddOrder * * To add the new order to the subfile * *--------------------------------------------------------------------- CSR AddOrder BEGSR * ---------- * If we have values to process ... C IF PARTNBR <> *BLANK AND PARTQTY > *ZERO * * Set up the subfile fields ... C MOVE PARTNBR PARTNBR_O C MOVE PARTDSC PARTDSC_O C MOVE PARTQTY PARTQTY_O C MOVE IPRICE ITEMPRICE * * Add the subfile record ... C EVAL SflCnt = SflCnt + 1 C EVAL SflRrn = SflCnt C WRITE ORDSFL * * Clear the display fields ... C MOVE *BLANKS PARTNBR C MOVE *BLANKS PARTDSC C MOVE *ZEROS PARTQTY * * ... otherwise indicate part and quantity are required C ELSE C SETON 84 C ENDIF * CSR ENDSR *--------------------------------------------------------------------- * SUBROUTINE: ChgOrder * * To change an order in the subfile * *--------------------------------------------------------------------- CSR ChgOrder BEGSR * ---------- C EVAL Exit2 = $False * * Check for selected orders ... C READC ORDSFL 9999 C DOW *IN99 <> *ON C IF OPT = $Change * * Set up the change window fields ... C MOVE PARTNBR_O PARTNBR C MOVE PARTDSC_O PARTDSC C MOVE PARTQTY_O PARTQTY * * Display the change window ... C DOU Exit2 = $True C EXFMT ALTORDER * C SELECT * * If the user requested exit ... C WHEN *IN12 = *ON C EVAL Exit2 = $True C MOVE *BLANKS PARTNBR C MOVE *BLANKS PARTDSC C MOVE *ZEROS PARTQTY C EVAL Opt = *ZERO C UPDATE ORDSFL * * If the user requested prompting ... C WHEN *IN04 = *ON C EXSR SltPart * C OTHER * * If we have values to process ... C IF PARTNBR <> *BLANK AND PARTQTY > *ZERO * * Verify the part and quantity ... C EXSR VfyPart C EXSR VfyQty * * Set up the new subfile values ... C EVAL Opt = *ZERO C MOVE PARTNBR PARTNBR_O C MOVE PARTDSC PARTDSC_O C MOVE PARTQTY PARTQTY_O C UPDATE ORDSFL C EVAL Exit2 = $True * * Clear the display fields ... C MOVE *BLANKS PARTNBR C MOVE *BLANKS PARTDSC C MOVE *ZEROS PARTQTY * * ... otherwise indicate part and quantity are required C ELSE C SETON 84 C ENDIF * C ENDSL * C ENDDO * C ENDIF * C READC ORDSFL 99 * C ENDDO * CSR ENDSR *--------------------------------------------------------------------- * SUBROUTINE: CmtOrder * * To update the database with the new order * * WARNING: No checking is done to ensure that values in database * have not changed since the order line was added. *--------------------------------------------------------------------- CSR CmtOrder BEGSR * ---------- * * If we have order lines to process ... C IF SflCnt > *ZERO * Get the order date and time C TIME DateTime C Z-ADD *ZERO OrdTot * * For each order line in the subfile C 1 DO SflCnt OrdCnt C OrdCnt CHAIN ORDSFL * Add an order detail record ... C EXSR AddOrdLin * Update stock record ... C EXSR UpdStock * Accumulate order total ... C EVAL OrdTot = OrdTot + OLAMNT C ENDDO * * Add an order header record ... C EXSR AddOrdHdr * * Update customer record ... C EXSR UpdCust * * Request batch print server to print order C EXSR WrtDtaQ * C ENDIF * * Clear the subfile * *IN40 ==> SFLDSP, *IN41 ==> SFLDSPCTL, *IN44 ==> SFLCLR C SETOFF 4041 C SETON 44 C WRITE ORDCTL C SETOFF 44 * * Reinitialise all fields ... C MOVE *BLANKS CID C MOVE *BLANKS CUSTOMER C MOVE *BLANKS CADDR1 C MOVE *BLANKS CADDR2 C MOVE *BLANKS CCITY C MOVE *BLANKS CSTATE C MOVE *BLANKS CZIP C MOVE *ZEROS ORDNBR C EVAL DspPnl = $Panel1 C EVAL SflCnt = *ZERO C SETOFF 79 C SETON 89 * CSR ENDSR *--------------------------------------------------------------------- * SUBROUTINE: AddOrdLin * * Add a detail line to ORDLIN file * *--------------------------------------------------------------------- CSR AddOrdLin BEGSR * ---------- * Add an order detail record ... C EVAL OLOID = ORDNBR C EVAL OLDID = $District C EVAL OLWID = $Warehouse C EVAL OLNBR = OrdCnt C EVAL OLSPWH = 'JAVA' C EVAL OLIID = PARTNBR_O C EVAL OLQTY = PARTQTY_O * Amount = (ITEMPRICE - Discount) * Quantity C EVAL OLAMNT = ( ITEMPRICE - C (ITEMPRICE * CDCT / 100) ) C * OLQTY C Time Today C Adddur 14:*days Today C MoveL Today oldlvd C* EVAL OLDLVD = Today C* EVAL OLDLVD = 12311999 C EVAL OLDLVT = 235959 C WRITE OLRCD * CSR ENDSR *--------------------------------------------------------------------- * SUBROUTINE: AddOrdHdr * * Add a header recorde to ORDERS file * *--------------------------------------------------------------------- CSR AddOrdHdr BEGSR * ---------- * Add an order header record ... C EVAL OWID = $Warehouse C EVAL ODID = $District C EVAL OCID = CID C EVAL OID = ORDNBR C EVAL OLINES = OrdCnt C EVAL OCARID = 'ZZ' C EVAL OLOCAL = 1 C EVAL OENTDT = Date C EVAL OENTTM = Time C WRITE ORRCD * CSR ENDSR *--------------------------------------------------------------------- * SUBROUTINE: UpdStock * * Update the stock quantity * *--------------------------------------------------------------------- CSR UpdStock BEGSR * ---------- * Update stock record ... C MOVE PARTNBR_O IID C StockKey CHAIN STRCD C EVAL STQTY = STQTY - PARTQTY_O C UPDATE STRCD * CSR ENDSR *--------------------------------------------------------------------- * SUBROUTINE: UpdCust * * Update the customer record * *--------------------------------------------------------------------- CSR UpdCust BEGSR * ---------- * Update customer record ... C EVAL CLDATE = Date C EVAL CLTIME = Time C EVAL CBAL = CBAL + OrdTot C EVAL CYTD = CYTD + OrdTot * ADDED LRS C CustKey Chain CSRCD C UPDATE CSRCD * CSR ENDSR *--------------------------------------------------------------------- * SUBROUTINE: WrtDtaQ * * Write an entry to the data queue * *--------------------------------------------------------------------- CSR WrtDtaQ BEGSR * ---------- * C MOVE CID CustomerID C MOVE $District DistrictID C MOVE $Warehouse WarehousID C MOVE ORDNBR OrderID C CALL 'QSNDDTAQ' SndDtaQ * CSR ENDSR *--------------------------------------------------------------------- * SUBROUTINE: GetOrdNbr * * Determine the next order number * *--------------------------------------------------------------------- CSR GetOrdNbr BEGSR * ---------- * C DstrctKey CHAIN DSRCD C EVAL ORDNBR = DNXTOR C EVAL DNXTOR = DNXTOR + 1 C UPDATE DSRCD * CSR ENDSR *--------------------------------------------------------------------- * SUBROUTINE: EndPgm * * Terminate the program * *--------------------------------------------------------------------- CSR EndPgm BEGSR * ---------- * C Eval Exit = $True C Close *ALL C SETON LR C RETURN * CSR ENDSR *--------------------------------------------------------------------- * SUBROUTINE: *INZSR * * Initialise the program * *--------------------------------------------------------------------- CSR *INZSR BEGSR * ---------- * * Parameter list for QSNDDTAQ API C SndDtaQ PLIST C PARM $DqName DqName C PARM $DqLib DqLib C PARM QueDtaLen C PARM QueDta * * Parameter list for SLTCUSTR program C CustSlt PLIST C PARM CustInfo * * Parameter list for SLTPARTR program C PartSlt PLIST C PARM PartInfo * * Key list for CSTMR file C CustKey KLIST C KFLD CustomerID C KFLD DistrictID C KFLD WarehousID * * Key list for STOCK file C StockKey KLIST C KFLD WarehousID C KFLD IID * * Key list for ITEM file C ItemKey KLIST C KFLD IID * * Key list for DSTRCT file C DstrctKey KLIST C KFLD DistrictID C KFLD WarehousID * * Force composite keyes to use restricted values ... C EVAL DistrictID = $District C EVAL WarehousID = $Warehouse * CSR ENDSR