ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/MAGAZINE/MISC/DBMS9108.ZIP/ZDSAMPLE.PRG

Text File | 1991-03-15 | 22.4 KB | 819 lines

***************************************************************************
* File name: ZDSAMPLE.PRG
* This program is demonstrates the use of Zero-Balanced Distribution Engine
* Copyright (c) 1986-1991  James F. Shaughnessy, Jr.
*     All rights reserved
* Portions of this code were developed using Ashton-Tate, dBase III Plus
* Portions of this code were developed using Fox Software Foxbase + 2.10
* This version, March, 1991, developed using Fox Software FoxPro 1.02
*
***************************************************************************
SET TALK OFF
SET STATUS OFF
vid_bright = "R+/B           "
vid_nrml   = "GR+/B,W+/R,B   "
vid_rvrs   = "W+/R           "
SET COLOR TO &vid_nrml
IF .NOT. FILE ("TRANHDR.DBF")
   CREATE Tranhdr FROM tranhdr.str
ENDIF
IF .NOT. FILE ("TRANDSTR.DBF")
   CREATE Trandstr FROM trandstr.str
ENDIF
SELECT 1
USE Tranhdr
SELECT 2
USE Trandstr
SELECT 3
SET SAFETY OFF
CREATE Dstrwork FROM trandstr.str
SET SAFETY ON
SELECT 1
IF "FOXBASE"$UPPER(VERSION())
   SET PROCEDURE TO zdsample
ENDIF
DO smplmenu
RETURN
*
PROCEDURE smplmenu
 * This a simple menu procedure
   key_press = 0
   paint = .T.
   DO WHILE .T.
      IF paint
         CLEAR
         @  1,26 SAY  "Zero-Balanced Distribution"
         @  2,32 SAY  "Sample System"
         @  1,26 SAY  "Zero-Balanced Distribution"
         @  2,32 SAY  "Sample System"
         @  4,34 SAY  "Main Menu"
         @  5,20 TO 11,58 DOUBLE
         @  6,28 SAY  "1. Add Transaction"
         @  8,28 SAY  "2. Modify Transaction"
         @ 10,28 SAY  "X. Exit to Dot Prompt"
         paint = .F.
      ENDIF
      usr_inp = "  "
      @ 22,27 SAY "Enter selection " GET usr_inp PICTURE "!!"
      READ
      key_press = keypress()
        usr_inp = IIF(key_press=12,"X",usr_inp)
      usr_inp = LTRIM(TRIM(usr_inp))
      IF LEN(usr_inp) = 0
         LOOP
      ENDIF
      DO CASE
      CASE usr_inp = "1"
         paint = .T.
         @  4,0  CLEAR
         @  4,31 SAY  "Add Transaction"
         DO WHILE key_press <> 12    && Esc
            c_new_rec = .T.
            DO gethdr
         ENDDO
      CASE usr_inp = "2"
         paint = .T.
         @  4,0  CLEAR
         @  4,29 SAY  "Modify Transaction"
           SELECT tranhdr
         tran_no = 0
         @ 22,0 SAY "Enter transaction number " GET m->tran_no PICTURE "999"
         READ
         key_press = keypress()
         IF key_press = 12    && Esc
            LOOP
         ENDIF
         LOCATE FOR Tran_No = m->tran_no
         IF .NOT. EOF()
            c_new_rec = .F.
            DO gethdr
         ENDIF
      CASE usr_inp = "/" .OR. usr_inp = "X"
         EXIT
      ENDCASE
   ENDDO
RETURN

PROCEDURE gethdr
 * Procedure to get or modify the transaction header
 * The transaction number is assign for new transactions only
 * by incrementing the last transaction.  This technique would
 * not be suitable to a multi-user application.
 * This procedure will also set up and call the engine if the
 * transaction is accepted.
   IF c_new_rec
      GO BOTTOM
      tran_no = tranhdr->Tran_No + 1
      tran_desc = SPACE(LEN(tranhdr->Tran_Desc))
      tran_amt = 0
   ELSE
      tran_no = tranhdr->Tran_No
      tran_desc = tranhdr->Tran_Desc
      tran_amt = tranhdr->Tran_Amt
   ENDIF
   SET COLOR TO &vid_nrml
   @  5,0 CLEAR
   @  5,5 TO 11,74 DOUBLE
   @  6,10 SAY  "Transaction Number"
   @  8,17 SAY  "Description"
   @ 10,22 SAY  "Amount"
   SET COLOR TO &vid_bright
   @ 6,30  SAY  m->tran_no PICTURE "###"
   SET COLOR TO &vid_rvrs
   @ 23,0 SAY "Press Esc to return to menu"
   SET COLOR TO &vid_nrml
   c_amc = 2
   DO WHILE c_amc = 2
      @ 8,30 GET m->tran_desc
      @ 10,30 GET m->tran_amt PICTURE "999999.99 "
      READ
      @ 23,0                  && Clear Esc message
      key_press = keypress()
      IF key_press = 12    && Esc
         RETURN
      ENDIF
      DO qamc WITH IIF(c_new_rec,2,1) && Add record as displayed or
                                      && Save record with changes
   ENDDO
   IF c_amc = 1
      SELECT tranhdr
      IF c_new_rec
         APPEND BLANK
         REPLACE Tran_No WITH m->tran_no
      ENDIF
      REPLACE Tran_Desc WITH m->tran_desc, ;
              Tran_Amt WITH m->tran_amt
      SET SAFETY OFF
      SELECT Dstrwork
      IF c_new_rec
         ZAP
         rmng_2_bal = tranhdr->Tran_Amt
      ELSE
         USE
         SELECT trandstr
         SET DELETED ON
         COPY TO Dstrwork FOR Tran_No = tranhdr->Tran_No
         SELECT 3
         USE Dstrwork
         rmng_2_bal = tranhdr->Tran_Amt - tranhdr->Dstr_Total
      ENDIF
      SET SAFETY ON
    * Scope memory variables for distribution
      STORE SPACE(LEN(trandstr->Dstr_To)) TO dstr_to
      STORE 0 TO dstr_amt
    * Assign procedures for engine
      zd_screen  = "DO dstrscn"
      zd_display = "DO dstrdsp"
      zd_init    = "DO dstrinit"
      zd_get     = "DO dstrget"
      zd_append  = "DO dstrapp"
      zd_modify  = "DO dstrmod"
      zd_insert  = "DO dstrins"
      zd_delete  = "DO dstrdel"
      zd_file    = "DO dstrfile"
      zd_alias   = "dstrwork"
    * Call the engine
      DO zerodstr WITH (rmng_2_bal)
   ENDIF
RETURN

PROCEDURE dstrscn
 * Paint screen for distribution
 * this procedure is assigned to variable zd_screen
   SELECT Dstrwork
   @ 12,0  CLEAR
   @ 12,5 TO 20,74 DOUBLE
   @ 15,6 TO 15,73
   @ 15,5 SAY CHR(199)
   @ 15,74 SAY CHR(182)
   @ 13,11 SAY "Distribution Item"
   @ 13,37 SAY "of"
   @ 14,8  SAY "Remaining to Balance"
   @ 16,15 SAY "Distribute to"
   @ 18,22 SAY "Amount"
   SET COLOR TO &vid_bright
   @ 13,31 SAY cur_item PICTURE "9999"
   @ 13,40 SAY last_item PICTURE "9999"
   @ 14,31 SAY rmng_2_bal PICTURE "999,999.99"
   SET COLOR TO &vid_nrml
RETURN

PROCEDURE dstrdsp
 * Display current distibution item
 * this procedure is assigned to variable zd_dsp
   SET COLOR TO &vid_bright
   @ 13,31 SAY cur_item PICTURE "9999"
   @ 13,40 SAY last_item PICTURE "9999"
   @ 14,31 SAY rmng_2_bal PICTURE "999,999.99"
   @ 16,31 SAY Dstrwork->Dstr_To
   @ 18,31 SAY Dstrwork->Dstr_Amt PICTURE "999,999.99"
   SET COLOR TO &vid_nrml
RETURN

PROCEDURE dstrinit
 * Initialize memory variables to get an item
 * this procedure is assigned to variable zd_init
   dstr_to = Dstrwork->Dstr_To
   dstr_amt = IIF(c_new_rec,rmng_2_bal,Dstrwork->Dstr_Amt)
RETURN

PROCEDURE dstrget
 * Get and read
 * this procedure is assigned to variable zd_get
   @ 16,31 GET m->dstr_to PICTURE REPLICATE("!",LEN(m->dstr_to))
   @ 18,31 GET m->dstr_amt PICTURE "999999.99 "
   READ
RETURN

PROCEDURE dstrapp
 * Append item to Dstrwork
 * this procedure is assigned to variable zd_append
   SELECT Dstrwork
   APPEND BLANK
   rmng_2_bal = m->rmng_2_bal - m->dstr_amt
   finished = (rmng_2_bal = 0.)
   DO dstrrepl
RETURN

PROCEDURE dstrmod
 * Modify item in Dstrwork
 * this procedure is assigned to variable zd_modify
 * Update rmng_2_bal with difference between old and new values,
 * and do it before the replace !!
   rmng_2_bal = m->rmng_2_bal - m->dstr_amt + Dstrwork->dstr_amt
   DO dstrrepl
RETURN

PROCEDURE dstrins
 * Insert item in front of current item
 * this procedure is assigned to variable zd_insert
   SELECT Dstrwork
   INSERT BLANK BEFORE
   rmng_2_bal = m->rmng_2_bal - m->dstr_amt
   DO dstrrepl
RETURN

PROCEDURE dstrrepl
 * Replace database fields with value of corresponding memory variables
 * This procedure IS NOT assigned to a zd_ variable, but it is
 * called by procedures dstrapp, dstrmod, and dstrins, and keeps the
 * write to database fields in a single procedure
   REPLACE Dstr_To WITH m->dstr_to, Dstr_Amt WITH m->dstr_amt
RETURN

PROCEDURE dstrdel
 * Delete item from Dstrwork
 * this procedure is assigned to variable zd_delete
 * DELETE and PACK statements are in calling procedure
 * only need to adjust rmng_2_bal
   SELECT Dstrwork
   rmng_2_bal = rmng_2_bal + Dstrwork->dstr_amt
RETURN

PROCEDURE dstrfile
 * Distribution has been accepted - write it to permanent files.
 * this procedure is assigned to variable zd_file
 * If we are modifying a previous transaction, we need to delete the
 * the old distribution if the field tranhdr->Dstr_Count is non-zero.
 * After the new distribution is saved, ZAP the workfile.
   SELECT Dstrwork
   PACK
   REPLACE tran_no WITH tranhdr->Tran_No FOR .T.
   USE
   SET DELETED ON
   SELECT trandstr
   IF tranhdr->dstr_count <> 0
      LOCATE FOR Tran_No = tranhdr->Tran_No      && not using an index in this sample
      DELETE WHILE trandstr->Tran_No = tranhdr->Tran_No
   ENDIF
   APPEND FROM Dstrwork
   SELECT tranhdr
   REPLACE dstr_count WITH last_item, dstr_total WITH tran_amt - rmng_2_bal
   SELECT 3
   SET SAFETY OFF
   USE Dstrwork
   ZAP
   SET SAFETY ON
RETURN

PROCEDURE zerodstr
* This is the top level procedure of the Zero-Balanced Distribution Engine
* Parameter passed - rmng_2_balance
* The calling procedure is expected to assign values in the illustrated
*  manner to to the following  variables :
*                                && supply mnemonic or acronym for *
*     zd_screen  = "DO *scn"     && Procedure to paint screen
*     zd_display = "DO *dsp"     && Display current distibution item
*     zd_init    = "DO *init"    && Intialize memory varibles
*     zd_get     = "DO *get"     && GET and READ
*     zd_append  = "DO *app"     && Append to end of workfile
*     zd_modify  = "DO *mod"     && Modify item
*     zd_insert  = "DO *ins"     && Insert in front current item
*     zd_delete  = "DO *del"     && Delete current item
*     zd_file    = "DO *file"    && File distribution
*     zd_alias   = "alias"       && Alias of workfile
*
*  Macro substitution command is executed as needed to call the above
*  defined procedures and to reference the workfile. The procedures
*  in the engine, from the top:
*     zerodstr    - initilizes and controls the prompt
*                   "File, Review, Append, Cancel".
*     zdreview    - controls the "Enter item number (9999); Prev ..." prompt
*     zdloop      - controls the "Skip, Modify, Insert, Delele" prompt
*     zdappend    - set up for appending items
*     zdinput     - macro  &zd_get and control "Accept, Modify, Cancel"
*     qfrac       - query  "File, Review, Append, Cancel"
*     qsmid       - query  "Skip, Modify, Insert, Delele"
*  The following procedure are general purpose and used, as well, outside
*  the engine:
*     qamc        - query  "Accept, Modify, Cancel"
*     qyesno      - query  "Yes No" to parameter question
*     pause       - suspend for up to 60 seconds
*     hlpcr       - press Enter to continue
*     keypress    - returns low value of READKEY()
*
PARAMETER rmng_2_bal
PRIVATE dstr_mode,NO_INPUT,APPEND_ITM,MODIFY_ITM,INSERT_ITM
PRIVATE c_amc,c_smid,c_frac,c_new_rec
PRIVATE c_item,last_item
STORE 0 TO c_amc,c_smid,c_frac
STORE .F. TO c_new_rec
NO_INPUT = 0
APPEND_ITM = 1
MODIFY_ITM = 2
INSERT_ITM = 3
IF TYPE("zd_rvwonly") <> "L"
   PRIVATE zd_rvwonly
   zd_rvwonly = .F.
ENDIF
IF TYPE("rvwmsg_row") <> "N"
   PRIVATE rvwmsg_row
   rvwmsg_row = 23
ELSE
   IF rvwmsg_row < 0 .OR. rvwmsg_row > 24
      PRIVATE rvwmsg_row
      rvwmsg_row = 23
   ENDIF
ENDIF
IF TYPE("rvwmsg_col") <> "N"
   PRIVATE rvwmsg_col
   rvwmsg_col = 0
ELSE
   IF rvwmsg_col < 0 .OR. rvwmsg_col > 64
      PRIVATE rvwmsg_col
      rvwmsg_col = 0
   ENDIF
ENDIF
SELECT &zd_alias
last_item = RECCOUNT()
cur_item = IIF(last_item=0,0,1)
GO TOP
IF zd_rvwonly
   &zd_screen
   IF cur_item <> 0
      &zd_display
   ENDIF
   DO zdreview
   SELECT &zd_alias
   SET SAFETY OFF
   ZAP
   SET SAFETY ON
   RETURN
ENDIF
dstr_mode = IIF(last_item=0, APPEND_ITM,NO_INPUT)
c_frac = 0
DO WHILE c_frac = 0
   IF dstr_mode = APPEND_ITM
      DO zdappend
   ELSE
      &zd_screen
      IF cur_item <> 0
         &zd_display
      ENDIF
   ENDIF
   DO qfrac
   DO CASE
   CASE  c_frac = 1                                    && File distribution
      IF last_item = 0
         IF qyesno("File with zero items ? ","N") <> 1
            c_frac = 0
            LOOP
         ENDIF
      ENDIF
      &zd_file
   CASE  c_frac = 2                                    && Review items
      DO zdreview
      dstr_mode = NO_INPUT
      c_frac = 0
   CASE  c_frac = 3                                    && Append items
      c_new_rec = .T.
      cur_item = last_item
      dstr_mode = APPEND_ITM
      c_frac = 0
   CASE  c_frac = 4  .OR. c_frac = -1                  && Cancel distribution
      SELECT &zd_alias
      SET SAFETY OFF
      ZAP
      SET SAFETY ON
      @ 23,0
      ?? "No Action!"
      DO pause WITH 2
      @ 23,0
      ** will exit
   ENDCASE
ENDDO
*
RETURN

PROCEDURE zdreview
*
PRIVATE ok, all_left
IF last_item = 0
   @ 22,0 CLEAR
   ?? "There are no items to review."
   DO hlpcr WITH "Press ─┘ to continue "
ENDIF
all_left = .F.
key_press = 0
DO WHILE .T.
   IF last_item = 0       && All items can be deleted
      RETURN
   ENDIF
   key_press = IIF(key_press=15 .OR. key_press=271,0,key_press)
   IF .NOT. all_left  .AND. key_press = 0
      usr_inp = "    "
      @ 22,0 CLEAR
?? "Enter item number (9999); Previous, Next, or All remaining; End review"
?  "[Press ─┘ for item (last) displayed. Also:   PgUp PgDn]"
      SET COLOR TO &vid_bright
      @ 22,26 SAY "P"
      @ 22,36 SAY "N"
      @ 22,45 SAY "A"
      @ 22,60 SAY "E"
      SET COLOR TO &vid_nrml
      @ 22,72 GET usr_inp  PICTURE "!!!!"
      READ
      key_press = keypress()
   ENDIF
   key_press = IIF(key_press=15,0,key_press)
   usr_inp = TRIM(usr_inp)
   DO CASE
   CASE usr_inp $ "E/" .OR. key_press = 12 .OR. usr_inp = "0000"
      @ 22,0 CLEAR
      RETURN
   CASE  .NOT. all_left .AND. LEN(usr_inp) = 0 .AND. key_press = 0
      DO zdloop
   CASE usr_inp = "A" .OR. all_left
      try_item = IIF(all_left,cur_item+1,cur_item)
      all_left = .T.
      IF try_item > last_item
         all_left = .F.
         cur_item = IIF(last_item > 0, 1, 0)
         GO TOP
         &zd_screen
         IF cur_item <> 0
            &zd_display
         ENDIF
      ELSE
         SELECT &zd_alias
         GOTO try_item
         cur_item = try_item
         DO zdloop
      ENDIF
   CASE usr_inp = "N" .OR. key_press = 5   && DownArrow - next item
      try_item = cur_item + 1
      IF try_item <= last_item
         SELECT &zd_alias
         GOTO try_item
         cur_item = try_item
         DO zdloop
      ENDIF
   CASE usr_inp = "P" .OR. key_press = 4   && UpArrow - previous item
      try_item = cur_item - 1
      IF try_item > 0
         SELECT &zd_alias
         GOTO try_item
         cur_item = try_item
         DO zdloop
      ENDIF
   CASE key_press = 6                      && PgUp - first item
      SELECT &zd_alias
      GO TOP
      cur_item = 1
      DO zdloop
   CASE key_press = 7                      && PgDn - last item
      SELECT &zd_alias
      GO BOTTOM
      cur_item = last_item
      DO zdloop
   OTHERWISE
      try_item = VAL(usr_inp)
      IF try_item > 0 .AND. try_item <= last_item
         SELECT &zd_alias
         GOTO try_item
         cur_item = try_item
         DO zdloop
      ENDIF
      key_press = 0
   ENDCASE
ENDDO
*
RETURN

PROCEDURE zdloop
*
key_press = 0
SELECT &zd_alias
c_bright = .F.
&zd_screen
&zd_display
IF zd_rvwonly
   @ 22,0 CLEAR
   SET COLOR TO &vid_bright
   @ rvwmsg_row,rvwmsg_col SAY 'Review Only'
   SET COLOR TO &vid_nrml
   DO hlpcr WITH "Press ─┘ to continue "
   RETURN
ENDIF
c_smid = 0
DO WHILE c_smid = 0
   DO qsmid             && Skip, Modify, Insert, or Delete ?
   DO CASE
   CASE  c_smid = 1 .OR. c_smid = -1                        &&    S k i p
      RETURN
   CASE  c_smid = 2                                         &&    M o d i f y
      SET COLOR TO &vid_bright
      @ rvwmsg_row,rvwmsg_col SAY "Modifying Item"
      SET COLOR TO &vid_nrml
      dstr_mode = MODIFY_ITM
      c_new_rec = .F.
      &zd_init
      DO zdinput
      IF c_amc = 1
         &zd_modify
      ELSE
         &zd_display
         STORE 0 TO c_amc,c_smid
         ** reexecute WHILE c_smid = 0 loop
      ENDIF
   CASE  c_smid = 3                                         &&    I n s e r t
      SET COLOR TO &vid_bright
      @ rvwmsg_row,rvwmsg_col SAY "Inserting Item"
      SET COLOR TO &vid_nrml
      dstr_mode = INSERT_ITM
      c_new_rec = .T.
      &zd_init
      DO zdinput
      IF c_amc = 1
         &zd_insert
         last_item = last_item + 1
      ELSE
         &zd_display
         STORE 0 TO c_amc,c_smid
         ** reexecute WHILE c_smid = 0 loop
      ENDIF
   CASE  c_smid = 4                                         &&    D e l e t e
      IF qyesno("Really delete this item ?","N") = 1
         &zd_delete
         DELETE
         PACK
         last_item = last_item - 1
         cur_item = IIF(cur_item > last_item, last_item, cur_item)
         cur_item = IIF(all_left .AND. (cur_item > 0) , cur_item - 1, cur_item)
         IF cur_item <> 0
            GOTO cur_item
         ENDIF
      ENDIF
   ENDCASE
ENDDO
IF .NOT. all_left
   &zd_screen
   IF cur_item <> 0
      &zd_display
   ENDIF
ENDIF
*
RETURN

PROCEDURE zdappend
*
PRIVATE finished
c_new_rec = .T.
finished = .F.
DO WHILE .NOT. finished
   cur_item = cur_item + 1
   &zd_screen
   &zd_init
   DO zdinput
   IF c_amc = 1
      &zd_append
      last_item = last_item + 1
   ELSE
      cur_item = cur_item - 1
   ENDIF
   finished = finished .OR. (keypress() = 12)    && Esc
   IF finished
      GO cur_item
      &zd_display
   ENDIF
ENDDO
*
RETURN

PROCEDURE zdinput
   c_amc = 2
   DO WHILE c_amc = 2
      &zd_get
      @ rvwmsg_row,rvwmsg_col SAY "              "
      key_press = keypress()
      IF key_press = 12    && Esc
         RETURN
      ENDIF
      DO qamc WITH IIF(dstr_mode = MODIFY_ITM,1,2)
   ENDDO
RETURN

PROCEDURE qfrac
*
PRIVATE usr_inp
@ 23,0
IF TYPE("no_bal_msg")<> "L"
   PRIVATE no_bal_msg
   STORE .F. TO no_bal_msg
ENDIF
IF no_bal_msg
   usr_inp = "F "
ELSE
   SET COLOR TO &vid_rvrs
   IF rmng_2_bal = 0
      ?? "Distribution is in balance"
      usr_inp = "F "
   ELSE
      ?? "Distribution is not in balance",CHR(7)
      usr_inp = IIF(last_item = 0,"A ","R ")
   ENDIF
   SET COLOR TO &vid_nrml
ENDIF
c_frac = 0
DO WHILE c_frac = 0
   @ 22,0
   @ 22,0 SAY "File, Review, Append, Cancel (F/R/A/C) " ;
      GET usr_inp PICTURE "!!"
   READ
   key_press = keypress()
   DO CASE
   CASE  usr_inp = "/" .OR. key_press = 12    && Esc
      c_frac = -1
   CASE  usr_inp = "F" .OR. usr_inp = "1"
      c_frac = 1
   CASE  usr_inp = "R" .OR. usr_inp = "2"
      c_frac = 2
   CASE  usr_inp = "A" .OR. usr_inp = "3"
      c_frac = 3
   CASE  usr_inp = "C" .OR. usr_inp = "4"
      c_frac = 4
   ENDCASE
   usr_inp = "  "
ENDDO
@ 22,0 CLEAR
*
RETURN

PROCEDURE qsmid
*
   PRIVATE usr_inp, col
   usr_inp = 1
   @ 22,0 CLEAR
   IF TYPE("all_left") <> "L"
      PRIVATE all_left
      all_left = .F.
   ENDIF
   col = IIF(all_left,10,25)
   @ 23,col      PROMPT "Skip"   MESSAGE "No change to item displayed."
   @ 23,col+6    PROMPT "Modify" MESSAGE "Change item displayed."
   @ 23,col+14   PROMPT "Insert" MESSAGE "Insert new item before item displayed."
   @ 23,col+22   PROMPT "Delete" MESSAGE "Delete item displayed."
   IF all_left
     @ 23,col+30 PROMPT 'Cancel "All Remaining" Option' MESSAGE "Also skip item displayed."
   ENDIF
   SET MESSAGE TO 24
   MENU TO usr_inp
   key_press = keypress()
   @ 23,0 CLEAR
   DO CASE
   CASE  usr_inp = 1
      c_smid = 1
   CASE  usr_inp = 2
      c_smid = 2
   CASE  usr_inp = 3
      c_smid = 3
   CASE  usr_inp = 4
      c_smid = 4
   CASE  usr_inp = 0 .OR. usr_inp = 5
      press = "/"
      c_smid = -1
      all_left = .F.
   ENDCASE
*
RETURN

PROCEDURE qamc
*
PARAMETER qamc_type
* 1  Modify existing record
* 2  Add new record
* 3  Proceed as displayed
press = " "
PRIVATE usr_inp
usr_inp = 1
@ 23,29 PROMPT "Accept" MESSAGE IIF(qamc_type = 3,"Proceed as specified.", ;
   IIF(qamc_type=2,"Add record as displayed.","Save record with changes."))
@ 23,37 PROMPT "Modify" MESSAGE IIF(qamc_type = 3,"Change specifications.", ;
   "Make changes to record.")
@ 23,45 PROMPT "Cancel" MESSAGE IIF(qamc_type = 3,"Return to menu.", ;
   IIF(qamc_type=2,"Do not add record.","Disregard any changes made."))
SET MESSAGE TO 24
MENU TO usr_inp
key_press = keypress()
@ 23,0 CLEAR
DO CASE
CASE  usr_inp = 1
   c_amc = 1
CASE  usr_inp = 2
   c_amc = 2
CASE  usr_inp = 3
   c_amc = 3
CASE  usr_inp = 0
   press = "/"
   c_amc = -1
ENDCASE
*
RETURN

PROCEDURE qyesno
*
PARAMETERS prompt,initial
PRIVATE col,test,usr_inp
initial = UPPER(LEFT(initial+"  ",2))
usr_inp = IIF(initial = "Y",2,1)
@ 23,0 CLEAR
test = LEN(TRIM(prompt))
col = (80-LEN(prompt)-9)/2
@ 23,col SAY prompt
@ 23,col+test+7 PROMPT "No"
@ 23,col+test+2 PROMPT "Yes"
MENU TO usr_inp
key_press = keypress()
@ 23,0 CLEAR
* Return Value is 1 if Y
*                 0 if N
*                -1 if Esc
RETURN usr_inp - 1

PROCEDURE pause
*
* use to pause between 0 & 60 seconds
* if outside range, prompt
PARAMETER kount
PRIVATE start,now
IF kount < 0 .OR. kount > 60
   DO hlpcr WITH 'Press ─┘ to continue '
   RETURN
ENDIF
start = VAL(RIGHT(TIME(),2))
now = start
DO WHILE start+kount > now
   now = VAL(RIGHT(TIME(),2))
   IF now < start
      now = now + 60
   ENDIF
ENDDO
*
RETURN

PROCEDURE hlpcr
*
PARAMETER message
IF TYPE("bell_off") <> "L"
   PRIVATE bell_off
   bell_off = .F.
ENDIF
@ 23,0 CLEAR
?? IIF(bell_off,"",CHR(7))
press = " "
@ 23,0 SAY message GET press
READ
key_press = keypress()
press = IIF(key_press=12,"/",press)    && compatible with older versions
@ 23,0 CLEAR
*
RETURN

PROCEDURE keypress
*
key_press = READKEY()
key_press = IIF(key_press>36,key_press-256,key_press)
*
RETURN key_press