Question : Fox9 - Having a problem getting color to work using @ ... Gets and @ ... Say

This was written 20 year ago in FoxPro for DOS. I am in the process of upgrading to Fox9. Can you please help me with getting VFP to change the colors on a menu? I woulf like the menu selection items to have a different color depending what is selected by the up/down arrows. Another problem I am having is when I rest the cursor on any menu item, the entire menu goes away. I know I included a lot of code here, but the actual code in use is very small and easy to isolate.

Thank you for being there and helping me with my problem.

* Start of Main Menu
* Enviroment

* Added for VFP
  CLEAR ALL

* Commented for VFP9
* PARAMETER

* Added for VFP9
  parm1_= .T.
  parm2_= .T.

  SET DEFAULT TO c:\crit\CODE
  SET TALK OFF
  SET ECHO OFF

  PUBLIC akl_test
  IF TYPE('parm1_') = 'L'
   akl_test = "Y"
  ELSE
     IF parm1_ = "test"
      akl_test = "Y"
     ELSE
      akl_test = "N"
     ENDIF
  ENDIF

  PUBLIC akl_system
  akl_system = "Y"

* if type('parm2_') = 'L'
*    akl_system = "N"
* else
*    if parm2_ = "akl"
*       akl_system = "Y"
*    else
*       akl_system = "N"
*    endif
* endif

* DEVELOPMENT FLAGS
  IF akl_test $ 'Y'
     SET DISPLAY TO VGA50
     SET ESCAPE ON
     SET STATUS ON
*    SET VIEW Off
*    SET CLOCK TO 48,69
  ELSE
*    SET CLOCK TO 24,69 Turn clock off for VFP
    ENDIF

* ENVIRONMENT
  modi_memo = .T.
  ON KEY LABEL f12 DO _popcal
  ON KEY LABEL ctrl+f12  DO rundos WITH "COMMAND.COM"

  IF EMPTY(ON('key','ctrl+o'))
     DO fs_setup
  ENDIF

  SET PROCEDURE TO genlbr
  = envrnmnt()
  CLEAR WINDOWS

  OPTION   = ' '
  goodpass = .F.

  DO COLORS

* All FUNCTION Key code will be removed. FUNCTION KEY SETTINGS
  s_zoom_no = 0
  s_lastkey = 0         && Save the last key entered
  s_prgname = ''        && Save the program name using a function
  s_FkeyRec = 0         && Save Function Key Record Number
  s_FkeyPag = 0         && Save Function Key Page Number
  s_FkyMRec = 0         && Save FKey MASTER Record Number.  1/10/97 12:28 am (akl)
  && ---- First needed in PAYABLE when F1 from the Detail.
  listmenu  = .F.       && Did we come from List Menu?
  utilmenu  = .F.       && Did we come from Util Menu?
 
  KeyF1     = .F.       && Flag - from anything to Animals
  KeyF2     = .F.       && Flag - from anything to Bids
  KeyF3     = .F.       && Flag - from anything to Calendar
  KeyF4     = .F.       && Flag - from anything to Contracts
  KeyF5     = .F.       && Flag - from anything to Critters
  KeyF6     = .F.       && Flag - from anything to Invoices
  KeyF8     = .F.       && Flag - from anything to Payables
  KeyF9     = .F.       && Flag - from anything to Prices
  KeyF10    = .F.       && Flag - from anything to Production Companies
  KeyF11    = .F.       && Flag - from anything to Receivables

* Commented for VFP
* VARIABLES
  choice   = 0
  prompt1  = ' 1. Animals '
  prompt2  = ' 2. Bids '
  prompt3  = ' 3. Calendar '
  prompt4  = ' 4. Contracts '
  prompt5  = ' 5. Critters '
  prompt6  = ' 6. Invoices '
  prompt7  = ' 7. Labels '
  prompt8  = ' 8. Lists '
  prompt9  = ' 9. Prices '
* prompt10 = ' P. Print '
  prompt10 = ' S. Stats '
  prompt11 = ' U. Utilities '
  prompt12 = ' Help '
  prompt13 = ' Quit '
* Commented for VFP

* WINDOWS
* Commented for VFP
* define window crit from 2,2 to 22,75 ;
    title ' Critters Main Menu ' ;
    double float shadow color scheme 2 ;
    FONT 'Arial Bold', 25

*Added for VFP.
  DEFINE WINDOW crit FROM 2,2 TO 90,170 ;
     TITLE ' Critters Main Menu ' ;
     DOUBLE FLOAT SHADOW COLOR scheme 2 ;
     FONT 'Arial Bold', 25

* SCREEN
   CLEAR
   = explode (2,2,22,75,50,1)

ACTIVATE SCREEN
  IF akl_test $ 'Yy'
     @ 0,34 SAY 'Testing On' COLOR w+/N
* else
*    @ 0,70 say space(9)
  ENDIF
*L
* PROCESSING LOOP
  DO WHILE .T.

     ACTIVATE WINDOW crit
     DO disscr
     s_choice = mchoice
     choice = mchoice

****************************************************************************
*                                                                          *
* This is a tempoary program to look for duplicates in a specific .DBF.    *
  IF .NOT. akl_test $ 'Yy'
*    do dup1chk
*    do dup2chk
  ENDIF
*                                                                          *
****************************************************************************

  ON KEY LABEL f7 DO genhlp WITH PROGRAM()                && USER HELP

  DO CASE
     CASE choice = 0                      && <ESC>
        RELEASE WINDOW crit
        IF akl_test $ "Yy"
           RETURN
        ELSE
           QUIT
        ENDIF
     CASE choice = 1 .AND. (FILE('ANIMALS.PRG').OR.FILE('ANIMALS.FXP'))
        DO animals WITH PROGRAM()
     CASE choice = 2 .AND. (FILE('BIDS.PRG').OR.FILE('BIDS.FXP'))
        DO bids WITH PROGRAM()
     CASE choice = 3 .AND. (FILE('CALENDAR.PRG').OR.FILE('CALENDAR.FXP'))
        DO calendar WITH PROGRAM()
     CASE choice = 4 .AND. (FILE('CONTRACT.PRG').OR.FILE('CONTRACT.FXP'))
        DO contract WITH PROGRAM()
     CASE choice = 5 .AND. (FILE('CRITTERS.PRG').OR.FILE('CRITTERS.FXP'))
        DO critters WITH PROGRAM()
     CASE choice = 6 .AND. (FILE('INVOICE.PRG').OR.FILE('INVOICE.FXP'))
        DO invoice WITH PROGRAM()
     CASE choice = 7 .AND. (FILE('P_LABELS.PRG').OR.FILE('P_LABELS.FXP'))
        DO p_labels WITH PROGRAM()
     CASE choice = 8 .AND. (FILE('LISTS.PRG').OR.FILE('LISTS.FXP'))
        DO lists
     CASE choice = 9 .AND. (FILE('PRICES.PRG').OR.FILE('PRICES.FXP'))
        DO prices WITH PROGRAM()
*    CASE choice = 10 .and. (file('PRINT.PRG').or.file('PRINT.FXP'))
*       DO print
     CASE choice = 10 .AND. (FILE('STATS.PRG').OR.FILE('STATS.FXP'))
        DO stats
     CASE choice = 11 .AND. (FILE('UTILS.PRG').OR.FILE('UTILS.FXP'))
        DO utils
     CASE choice = 12 .AND. (FILE('CRITHELP.PRG').OR.FILE('CRITHELP.FXP'))
        DO crithelp
     CASE choice = 13
        IF akl_test $ "Yy"
           SUSPEND
        ELSE
           QUIT
        ENDIF
********** akl: Added choice=14 for F8 from Bids to Payable 2/25/96  2:08 am
     CASE choice = 14 .AND. (FILE('PAYABLE.PRG').OR.FILE('PAYABLE.FXP'))
        DO payable WITH PROGRAM()
**********
********** akl: Added choice=15 for F11 from Bids to Receivables 2/28/96 10:53 am
     CASE choice = 15 .AND. (FILE('RECEIVE.PRG').OR.FILE('RECEIVE.FXP'))
        DO receive WITH PROGRAM()
         **********
   ENDCASE
  ENDDO
RETURN
*L
PROCEDURE disscr

  PUBLIC mchoice, mget, cchoice, cchoices
  STORE 0 TO mchoice, mget
  STORE "" TO cchoice, cchoices
* nCOL = ROUND(WCOLS()/2,0) - 19

  @  1,34 SAY '2010'

* Left Column
  ncol = 20

  nrow =  3
  DO GET WITH nrow,ncol, "[\<1] - Animals"
  nrow =  4
  DO GET WITH nrow,ncol, "[\<2] - Bids"
  nrow =  5
  DO GET WITH nrow,ncol, "[\<3] - Calendar"
  nrow =  6
  DO GET WITH nrow,ncol, "[\<4] - Contracts"
  nrow =  7
  DO GET WITH nrow,ncol, "[\<5] - Critters"
  nrow =  8
  DO GET WITH nrow,ncol, "[\<6] - Invoices"

* Right column
  ncol = 40

  nrow =  3
  DO GET WITH nrow,ncol, "[\<7] - Labels"
  nrow =  4
  DO GET WITH nrow,ncol, "[\<8] - Lists"
  nrow =  5
  DO GET WITH nrow,ncol, "[\<9] - Prices"
  nrow =  6
  DO GET WITH nrow,ncol, "[\<S] - Stats"
  nrow =  7
  DO GET WITH nrow,ncol, "[\<U] - Utilities"
  nrow =  8
  DO GET WITH nrow,ncol, "[\<H] - Help"

* Middle column
  ncol = 30
  nrow = 10
  DO GET WITH nrow,ncol, "[\<Q] - Quit"
     cchoices = cchoices + "12Q"
     cchoice = fnchoice(cchoices, "Q")
  RETURN

FUNCTION fncurobj
  PARAMETERS mchoice
  mchoice = _CUROBJ
  RETURN .T.
ENDFUNC

PROCEDURE GET
  PARAMETERS nrow, ncol, cfunc, bskip
  nsize2 = LEN(STRTRAN(cfunc,"\<")) + 2
  @ nrow,ncol GET mget FUNCTION "* "+IIF(bskip,"\\","")+cfunc ;
    VALID fnCUROBJ(@mCHOICE) ;
    color scheme 1
  RETURN
ENDPROC

FUNCTION fnchoice
  PARAMETERS cchoices, cdef
  READ CYCLE OBJECT mchoice
  mchoice = IIF(LASTKEY()=27,AT(cdef,cchoices),mchoice)
  RETURN IIF(mchoice > 0,SUBSTR(cchoices,mchoice,1),"")
ENDFUNC

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

* COLORS
origschem1 = "W+/B,W+/BG,GR+/B,GR+/B,R+/B,W+/GR,GR+/RB,N+/N,GR+/B,R+/B,+"
origschem2 = "BG/W,N/W,N/W,B/W,W/N,N/BG,W+/W,N+/N,B/W,W/N,+"

*       1    2   3    4   5    6      7     8     9    10 11
SET COLOR OF SCHEME 1 TO ;
     "W+/B,W+/r,w/B,W+/B,W+/B,r/w,GR+/RB,N+/N,GR+/B,R+/B,+"
*     Letters of DeskTop (1)
*        DeskTop Background (1)
*          User GET Field Letters (2)
*             User GET Field Background (2)
*               User Border Character (3)
*                 User Border Background (3)
*                   User Title Active Letters (4)
*                      User Title Active Background (4)
*                        User Title Inactive Letters (5)
*                          User Title Inactive Background (5)
*                                 Field Select (^A) Letters (6)
*                                     Field Select (^A) Letters Background (6)

*      1   2   3    4   5    6    7    8   9   10 11
SET COLOR OF SCHEME 2 TO ;
     "w/b,w/b,w/b,w+/b,W/N,w+/r,W+/W,N+/N,B/W,W/N,+"
*     Menu Letters (1)
*        Menu Letters Background (1)
*          Menu Selection Inactive Letters (2)
*            Menu Selection Inactive Background (2)
*              Menu Border Characters (3)
*                Menu Border Background (3)
*                  Menu Title Inactive Letters (4)
*                    Menu Title Background (4)
*                           Menu Slection Active Letters (6)
*                              Menu Selection Active Background (6)

*

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

* GENLBR.Prg (General Library)

* GENERAL LIBRARY PROCEDURE(S): GENLBR.PRG

function _add
  if zoom_no = 1
    go bottom
  endif
  do str_empty
  do default
  = add_rec()
return ''
*L
function _begin
  if top_mark = 0
    go top
  else
    go top_mark
    skip
  endif
return ''
*L
function _beginr
  go top
return ''
*L
function _canflt
  set filter to
  = fltrsta()
return ''
*L
function _canfltr
  set filter to
  = _disstat()
return ''
*L
function _canscop
  ndx_exp  = sys(14,1)
  go bottom
  last_rec = recno()
  last_val = &ndx_exp
  go top
  first_rec = recno()
  first_val = &ndx_exp
  = _disstat()
return ''
*L
function _copy
  = add_rec()
return ''
*L
function _delete
  if zoom_no < no_zooms
    * Are there any children records?
    child_num = str(zoom_no + 1, 1)
    select &child_num
    lnk_var = lnk_var&child_num
    seek &lnk_var
    if .not. &at_eof
      = dismsg(chr(7) + "Subordinate records exist")
      select &zoom_num
      return ''
    endif
    select &zoom_num
  endif

  if confirm('Delete Record')

     if right(sys(16,3),9) = 'ADOPT.FXP'
        rec_del = .T.
     endif

     if right(sys(16,3),12) = 'CONTRACT.FXP'
        select 3
        delete

        select 2
        delete

        select 1
     endif

     if right(sys(16,3),7) = 'DHR.FXP'          && No Show Flag
        dhr_delete = .t.
        repl dhr_delete with m->dhr_delete
        reindex
     else
        delete
     endif

     skip                && reposition to the next record

     if &at_eof()        && if last record deleted, go to beginning of database
        = _begin()
     endif

     if &at_eof .and. .not. empty(filter())
        * no records left in filter, remove the filter
        set filter to
        = _begin()
     endif

     if &at_eof
        * Last record deleted, database now empty
        = _quit()
     endif

  endif

return ''
*L
function _disstat
  exp_N = max(len(first_val),len(filter()))
  define window stat_wndw from 0,1 to 4,17+exp_N ;
         shadow color scheme 7
  activate window stat_wndw
  if .not. empty(filter())
    @ 0,0 say ' Filter is  : ' + filter()
  else
    @ 0,0 say ' Filter is  : Off'
  endif
  @ 1,0 say ' From Record: ' + first_val
  @ 2,0 say ' To Record  : ' + last_val
  wait ''
  release window stat_wndw
return ''
*L
function _editmemo
  parameters is_edit

  private memo_field
  memo_field = memo_fld&zoom_num

  if empty(memo_field)
    = dismsg('Has no memo field')
    return ''
  endif
  define window memo_wndw from 12,30 to 18,73  ;
         title 'MEMO (ESC to Exit or Ctrl-W to Save)' ;
         system float grow zoom close shadow color scheme 11
  if is_edit
    modify memo &memo_field window memo_wndw
  else
    modify memo &memo_field noedit window memo_wndw
  endif
  release window memo_wndw
return ''
*L
function _end
* Go to last record (last child record if Zoomed)
  if bot_mark >= 0
    go bot_mark
    skip -1
  else
    if bot_mark = -1
      go bottom
    else
      * Find first record outside range
      locate while .t. for &at_eof
      if eof()
        * It is last record in database
        bot_mark = -1
      else
        bot_mark = recno()
      endif
      skip -1
    endif
  endif
return ''
*L
function _endr
  go bottom
return ''
*L
function _fromrcd
  ndx_exp  = sys(14,1)
  if &ndx_exp <= last_val
    first_rec = recno()
    first_val = &ndx_exp
  else
    = dismsg("First record must precede the last record" )
  endif
  = _disstat()
return ''
*L
function _list
  parameters dbf_desc
                                       && This command is needed because
  on key label F7 && do _nohelp        && of the SYS(18) problem found.
  set help off                         && (_nohelp is on this page)
                                       && Notice -->> No func can be called!
                                       &&             Nor can a .PRG

  if right(sys(16,2),12) = 'CRITTERS.FXP'          && No 'GROW' !! (11 hours !)
     define window brws_wndw from 9,4 to 19,54  ;
                   title dbf_desc ;
                   system zoom float      close shadow color scheme 10
  else
     define window brws_wndw from 9,4 to 19,65  ;
                   title dbf_desc ;
                   system zoom float grow close shadow color scheme 10
  endif

  do list&zoom_num

  record_no = recno()
  release window brws_wndw

  set help on                                   && <<<--- REMEMBER! Remove these statements.
  on key label F7 do genhlp with sys(18)

return ''
*L
function _modify
  abort = .f.

********** akl: Bids - Multi Edit Window 10/16/95  2:07 am
   on key label PGUP do PageUp
   on key label PGDN do PageDn
**********

  if modify_key
    getcond = " 'G' $ fld_usg"
  else
    getcond = " 'G' $ fld_usg .and. .not. 'K' $ fld_usg"
  endif

*--------- akl: Removed - Did not like the way it worked 3/13/96  9:17 pm
********** akl: Added for automatic balance computation 2/11/96  8:42 pm
* if ((prog_name = "PAYABLE" .and. alias() = "PAYDETL")  .or.  ;
*     (prog_name = "RECEIVE" .and. alias() = "RECDETL")) .and. ;
*    (option = 'copy' .or. option = 'modify')
*       p_amount = 0
* endif
**********
*---------

  getcond = "'G'$fld_usg"

  if right(sys(16,3),8)  =  "USDA.FXP" .and. ;
     right(sys(16,8),10) <> "G_USDA.FXP"
        do getfldA with getcond
        read

        if m->u_code_2 = "D" .or. m->u_code_2 = "C"
           do getfldB with getcond
           read
        endif

  else

     do getfld with getcond

     ********** akl: Allows cursor to UpArrow to Date field 11/16/95  4:17 pm
     if right(sys(16,3),9) = "CALLS.FXP"
        read cycle
     else
        read
     endif
     **********

  endif

  s_lastkey = lastkey()

  * CLEANUP
********** akl: Bids - Multi Edit Window 10/16/95  2:07 am
  on key label PgUp
  on key label PgDn
**********

********** akl: CRITTERS.PRG - Multi Window Dogs Tricks Screen  7/28/98 10:06 pm
  if option    = "modify"   .and. ;
     prog_name = "CRITTERS" .and. ;
     (alias()  = "CRITDOGS" .or. alias()  = "CRITCATS")
        s_lastkey = s_lastky2   && Just in case the user pressed Ctrl-W from the first screen
        do DogUpDn
  endif
**********

  set message to

  if .not. ((right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF') .or. ;
            (right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF'))

      * (akl) 4/10/99 11:43 pm
      * added if statement for the following condition: 2/M/F5/N/Z
      * The data screen is erased and a user screen is activated.
      * Problem occurs ONLY when Hot-Keying from Bids to Critters Dog's Zoom.
      * No user screen is activated because the amount of data won't fit on a
      * user screen. So the Desk Top is used. (activate screen).

      if .not. (sys(16,5) = "ON... "            .and. ;
                right(sys(16,6),8) = "BIDS.FXP" .and. ;
                right(dbf(),12) = "CRITDOGS.DBF")

         set stat off                   && This had to be put in because the SET

      endif

  endif
                                    && STAT OFF alone did not erase the message
  if akl_test $ 'Yy'
     if .not. ((right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF') .or. ;
               (right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF'))

        if .not. (sys(16,5) = "ON... "            .and. ;
                  right(sys(16,6),8) = "BIDS.FXP" .and. ;
                  right(dbf(),12) = "CRITDOGS.DBF")

           set stat on

        endif

     endif
  endif

  if s_lastkey = 27                             && Esc
     abort = .t.
     return ''
  endif

  if modify_key
     if chk_dupl()
        return ''
     endif
  endif

  do lookup
  do calcul with .t.

  if right(sys(16,3),8)  =  "USDA.FXP" .and. ;
     right(sys(16,8),10) <> "G_USDA.FXP"
        do getfldA with ".t."
        do getfldB with ".t."
  else
     do getfld with ".t."
  endif

  clear gets

  if page_no < last_page                        && Display next screen page
     page_no = page_no + 1
     do disscr

     do while page_no <= last_page
        getcond = "'G'$fld_usg"

********** akl: Bids - Multi Edit Window 10/16/95  2:07 am
*       s_lastkey = ''          && Commented for F11 key 2/28/96  0:08 pm
        PgUpKey = .F.
        PgDnKey = .F.
        BTabKey = .F.
        on key label PGUP do PageUp
        on key label PGDN do PageDn
        on key label BACKTAB do TabBack
**********

        if right(sys(16,3),8) = "USDA.FXP"
           do getfldA with getcond
           do getfldB with getcond
        else
           do getfld with getcond
        endif

        read

        if .not. (PgUpKey .or. PgDnKey .or. BTabKey)
           s_lastkey = lastkey()
        endif

        * CLEANUP
********** akl: Bids - Multi Edit Window 10/16/95  2:07 am
        on key label PGUP
        on key label PGDN
        on key label BACKTAB
**********
        set message to
        set stat off                && This had to be put in because the SET
                                    && STAT OFF alone did not erase the message
                                    && It should work. Find out why?
        if akl_test $ 'Yy'
           set stat on
           set esca on
        endif

        if s_lastkey = 27                               && Esc
           abort = .t.
           exit
        endif

        if s_lastkey = 18                               && Page Up Key
           if page_no > 1
              page_no = page_no - 1
              do disscr
              loop
           endif
        endif

        if s_lastkey = 3                                && Page Down Key
           if page_no < last_page
              page_no = page_no + 1
              do disscr
              loop
           endif
        endif

        if s_lastkey = 15                               && Back Tab
           if page_no > 1
              page_no = page_no - 1
              do disscr
              if page_no = 1
                 for i = 1 to 18
                    keyboard chr(9)
                 next
              loop
              endif
           endif
        endif

        if type('LArrow') = 'L'         && See Contracts (akl) 10/05/99 10:43 am
           if page_no = 2
              page_no = 1
              do disscr
              loop
           endif
        endif

        if page_no = first_page
           * Check for duplicate (key entered only on first page)
           seek &ndx_var

*******************************************************************************
*                                                                             *
*  This IF statement was changed and duplicated because when you ZOOM to an   *
*  empty database, the system always displays the 'Duplicate Record' error    *
*  message when the first record is entered. Separate IF statements seems     *
*  to fix this problem. The difference is the IF statement just before the    *
*  '= dismsg...' statement. They are different for each condition of ZOOM_NO. *
*                                                                       (akl)   *
*******************************************************************************

           * Use this IF statement if zoom_no = 1
           if zoom_no = 1

              if prog_name = "CONTRACT"
                 exit       && Added because always getting error message when
                            && in Contract and ^W used to exit. I did it this
                            && way because I know that I will witing a WINDOWS
                            && windows version of the program. It is not worth
                            && fighting at this time  3/08/2000  2:09 pm (akl)
              else

                 if .not. &at_eof .and. .not. allow_dup&zoom_num
                    = dismsg(chr(7) + 'Duplicate record not allowed')
                    abort = .t.
                    exit
                 endif

              endif

           endif

           * Use this IF statement if zoom_no > 1
           if zoom_no > 1
              if .not. (&at_eof .and. allow_dup&zoom_num)
                 = dismsg(chr(7) + 'Duplicate record not allowed - 2 (akl)')
                 abort = .t.
                 exit
              endif
           endif
        endif

        * Display lookup fields and computed variables
        do lookup
        do calcul with .t.

        if right(sys(16,3),8) = "USDA.FXP"
           do getfldA with ".t."
           do getfldB with ".t."
        else
           do getfld with ".t."
        endif

        clear gets

        if page_no < last_page
           * Display next screen page
           page_no = page_no + 1
           do disscr
        else
           exit
        endif
     enddo while page_no <= last_page
  endif

  if .not. ((alias() = 'PAYDETL' .or. alias() = 'RECDETL' ) .and. option = 'modify')
     do calcul with .t.
  endif

  * Restore page number
  if page_no > first_page
     deact wind all
     page_no = first_page
     do disscr

     if right(sys(16,3),8) = "USDA.FXP"
        do getfldA with ".f."
        do getfldB with ".f."
     else
        do getfld with ".f."
     endif


     redisp_fld = .t.
     clear gets
  endif

  if .not. abort
********** akl: Check the spelling of the record 3/19/96  1:55 am
     if prog_name = "BIDS"    .or. prog_name = "CONTRACT" .or. ;
        prog_name = "INVOICE" .or. prog_name = "SUBRENT"  .or. ;
        prog_name = "MAPS"    .or. prog_name = "HELTHCRT"

          do SpellChk with "Rec"     && Record (Rec) or Field (Fld)

          if right(sys(16,3),8) = "USDA.FXP"
             do getfldA with ".f."
             do getfldB with ".f."
          else
             do getfld with ".f."
          endif

     endif
**********
     if confirm('Save Record')
        save_rec = .T.
        if alias()  = "CRITDOGS" .or. alias()  = "CRITCATS"
           LastTKUpd = Date()
           if alias()  = "CRITDOGS"
              select critters
              replace LastTKupd with m->LastTKupd
              select critdogs
              @ 0,67 say dtoc(m.lasttkupd)
           else
              select critters
              replace LastTKupd with m->LastTKupd
              select critcats
              @ 2,60 say dtoc(lasttkupd)
           endif
        endif
        gather memvar memo
        if right(sys(16,3),12) = "CONTRACT.FXP"
           sele 2
           gather memvar
           sele 3
           gather memvar
           sele 1
        endif
     endif
  endif
return ''
*L
PROCEDURE RunDOS
* Execute a DOS program or batch file, or invoke the DOS command
* interpreter (COMMAND.COM must be in the PATH)

  PARAMETERS command_
  IF _DOS
    ACTIVATE SCREEN
    SAVE SCREEN TO DOSscreen
    @ 0,0 CLEAR
    SET CURSOR ON

*   RUN /0 &command_.                       Commented out: 8/15/95  3:08 am

    NewCommand_ = GETENV('COMSPEC')     && Added this code to read the true
    RUN /0 &NewCommand_                 && "COMMAND.COM". Can't always be sure
                                        && COMMAND.COM will be running.
    SET CURSOR ON                       && Added 11/29/94
*   SET CURSOR OFF                         Commented 11/29/94-(akl)
    RESTORE SCREEN FROM DOSscreen
    RELEASE SCREEN DOSscreen
  ENDIF

RETURN
*L
function PageDn
  s_lastkey = lastkey()

  if s_lastkey = 3
     PgDnKey = .T.
     keyboard chr(23)

     if option    = "modify"   .and. ;
        prog_name = "CRITTERS" .and. ;
        (alias()  = "CRITDOGS" .or. alias()  = "CRITCATS")
           s_lastky2 = s_lastkey  && Just in case the user pressed Ctrl-W from the first screen
     endif
  endif

return
*L
function PageUp
  s_lastkey = lastkey()

  if s_lastkey = 18
*    if .not. (prog_name = "CRITTERS" .and. ;
*              option    = "modify"   .and. ;
*             (alias()   = "CRITDOGS" .or alias()   = "CRITCATS"))

     PgUpKey = .T.
     keyboard chr(23)

*    endif
  endif

return
*L
function _next
  skip
  if &at_eof
     = _end()
     = dismsg(chr(7) + 'Last record')
  endif
return ''
*L
function _nextr
  skip
  if eof()
    = _endr()
    = dismsg(chr(7) + 'Last record')
  endif
return ''
*L
function _nextpage
  last_page = val(substr(page_seq&zoom_num,len(page_seq&zoom_num),1))
  if page_no < last_page
    page_no = page_no + 1
    do disscr
  else
    = dismsg('No other page')
  endif
return ''
*L
function _nohelp

  define window help_not from 0,30 to 2,78 shadow color scheme 7
  activate window help_not

  mess_err = 'Sorry, no HELP is available at this time.'
  wait mess_err

  release window help_not
return ''
*L
function _prev
  skip -1
  if &at_bof
     = _begin()
     = dismsg(chr(7) + 'First record')
  endif
return ''
*L
function _prevr
  skip -1
  if bof()
    = _beginr()
    = dismsg(chr(7) + 'First record')
  endif
return ''
*L
function _prepage
  first_page = val(substr(page_seq&zoom_num,1,1))
  if page_no > first_page
    page_no = page_no - 1
    do disscr
    redisp_fld = .t.
  else
    = dismsg('No other page')
  endif
return ''
*L
function _print

********** Print Selected Entries 9/07/98  9:27 pm (akl)
  if right(sys(16,2),12) = 'CRITTERS.FXP' .or. ;
     right(sys(16,2),12) = 'P_LABELS.FXP'
       do prn_sele
  endif
**********

  set escape on

  define window prnt_wndw from 0,43 to 2,78 ;
         shadow color scheme 7
  activate window prnt_wndw

  s_readkey = 0
  @ 0,0 say ' Printing - ESC To Stop '
  = init_rpt()

  if s_readkey = 268 .or. s_readkey = 12                && Escape was pressed
     release window prnt_wndw
     return
  endif

  && Added Current or All USDA records (02/05/02 akl)

  if right(sys(16,6),10) = "P_USDA.FXP" .and. g_all = "A"
     if .not. sys(13) = 'OFFLINE' .or. outp_dev <> 'laser' .or. outp_dev <> 'dot'

        s_recno = recno()
        go top

        brk_no = 1

        do pgehdr

        do while .not. eof()

           r_count = 0

           do while r_count <> 9
              do brkhdr

              skip
              if eof()
                 exit
              endif

              r_count = r_count + 1

           enddo

           if eof()
              exit
           endif

        enddo

        goto s_recno

     endif

  else

     if .not. sys(13) = 'OFFLINE' .or. outp_dev <> 'laser' .or. outp_dev <> 'dot'
        do rpthdr
        do pgehdr
        do rptbdy
        do rptftr
        line_no = lns_per_pg
        do pgeftr
     endif
  endif

  if right(sys(16,2),12) = 'P_LABELS.FXP' .and. group = 1
     if akl_system $ 'Y'
        set print to LPT1
     else
        set print to LPT1
     endif
     set print on
     eject
     set print off
     set printer to
  else
     = end_rpt()
  endif

  release window prnt_wndw

  if outp_dev = 'screen'
    = edit_txt()
  endif

  set escape off
  go record_no
return ''
*L
function _popcal
  s_curobj = _curobj
* activate screen

  on key label esc keyboard "{CTRL+W}" + "{ENTER}"

* @ 24,0 say padc("Press ESC to return to the data entry screen",80)
  activate window calculator
  read valid .T.
* @ 24,0

  on key label esc

  _curobj = s_curobj

  set esca on
return
*L
function _quit

  if right(sys(16,2),9) <> 'PRINT.FXP' .and. ;
     right(sys(16,3),8) <> 'JOBS.FXP'
        set filter to
  endif

* Hide the window when user Quits to previous window
  do case
     case right(sys(16,2),12) = 'CRITTERS.FXP'
        do case
           case zoom_no = 1
              wind_hide = 'usr_wndw1'
           case zoom_no = 2
              clear
              wind_hide = 'usr_wndw5'
           case zoom_no = 3
              clear
              wind_hide = 'usr_wndw4'
           case zoom_no = 4
              wind_hide = 'usr_wndw6'
           case zoom_no = 5
              wind_hide = 'usr_wndw3'
        endcase

        s_zoom_no = zoom_no
        if zoom_no = 1 .or. KeyF2
           zoom_no = 0
        else
           zoom_no = 1
        endif

     otherwise
        wind_hide = 'usr_wndw'+alltrim(str(zoom_no))
        zoom_no = zoom_no - 1

        * Added if statement for the following condition: 2/M/F5/N/Z
        * The data screen is erased and a user screen is activated.
        * Problem occurs ONLY when Hot-Keying from Bids to Critters Dog's Zoom.
        * No user screen is activated because the amount of data won't fit on a
        * user screen. So the Desk Top is used. (activate screen).

        if (sys(16,5) = "ON... "            .and. ;
            right(sys(16,6),8) = "BIDS.FXP" .and. ;
            right(dbf(),12) = "CRITDOGS.DBF")

              clear
      endif

  endcase

  if wexist('&wind_hide')
     hide window &wind_hide
  endif

  if zoom_no > 0
    = x_zoom()
    go record_no
    do disscr
    redisp_fld = .t.
  endif
return ''
*L
function _retrieve
* Accept key and seek record; if not found reposition to record_no
  d_function = dispage1()
  if '' <> trim(ndx_var)
     scatter memvar blank memo
     do clrfld
     do getkey

     read

     * CLEANUP
     set message to
     set stat off                    && This had to be put in because the SET
                                     && STAT OFF alone did not erase the message
     if akl_test $ 'Yy'
        set stat on
     endif
     if lastkey() <> 27                                  && Esc

                if program(3) = "JOBS" .and. alias() = "JOBS"
                        seek trim(&ndx_var1a)
                else
                        seek trim(&ndx_var)
        endif

        if &at_eof
           = dismsg('Not found')
           go record_no
        endif

     endif
  endif
return ''
*L
********** akl: New Select Command 10/23/95  2:25 am
function _select
  parameters dbf_desc
                                       && This command is needed because
  on key label F7 && do _nohelp        && of the SYS(18) problem found.
  set help off                         && (_nohelp is on this page)
                                       && Notice -->> No func can be called!
                                       &&             Nor can a .PRG

  if right(sys(16,2),12) = 'CRITTERS.FXP'         && No 'GROW' !! (11 hours !)
     define window brws_wndw from 9,4 to 19,54 ;
                   title dbf_desc ;
                   system zoom float      close shadow color scheme 10
  else
     define window brws_wndw from 9,4 to 19,65  ;
                   title dbf_desc ;
                   system zoom float grow close shadow color scheme 10
  endif

  do sel&zoom_num

  record_no = recno()
  release window brws_wndw

  set help on                                   && <<<--- REMEMBER! Remove these statements.
  on key label F1 do genhlp with sys(18)

return ''
**********
*L
function _skip
  * Move forward/backward several records
  rec_count = 0
  define window skip_wndw from 11,29 to 13,52 ;
         shadow color scheme 7
  activate window skip_wndw
  @ 00,00 say ' Skip Records:' get rec_count picture '@Z 999999'
  read
  skip rec_count
  if &at_eof
    = _end()
    = dismsg(chr(7) + 'Last Record')
  endif
  if &at_bof
   = _begin()
   = dismsg(chr(7) + 'First record')
  endif
  release window skip_wndw
return ''
*L
function _skipr
  * Move forward/backward several records
  rec_count = 0
  define window skip_wndw from 11,29 to 13,52 ;
         shadow color scheme 7
  activate window skip_wndw
  @ 00,00 say ' Skip Records:' get rec_count picture '@Z 999999'
  read
  skip rec_count
  if eof()
    = _endr()
    = dismsg(chr(7) + 'Last Record')
  endif
  if bof()
   = _beginr()
   = dismsg(chr(7) + 'First record')
  endif
  release window skip_wndw
return ''
*L
function TabBack
  s_lastkey = lastkey()
  if s_lastkey = 15
     BTabKey = .T.
     keyboard chr(23)
  endif

return
*L
function _tally
  define window count_wndw from 0,35 to 2,78 ;
         shadow color scheme 7
  activate window count_wndw
  @ 0,0 say ' Counting...'
  rec_count = 0
  = _begin()
  count while .not. &at_eof to rec_count

  mess_str =  str(rec_count,6) + ' record'

  if rec_count > 1
     mess_str =  mess_str + 's'
  endif

  wait mess_str
  go record_no
  release window count_wndw
return ''
*L
function _tallyr
  define window count_wndw from 0,35 to 2,78 ;
         shadow color scheme 7
  activate window count_wndw
  @ 0,0 say ' Counting...'
  rec_count = 0
  = _beginr()
  count while .not. eof() to rec_count
  mess_str =  str(rec_count,6) + ' records'
  wait mess_str
  go record_no
  release window count_wndw
return ''
*L
function _tofile
  rep_file = space(8)
  define window file_wndw from 7,20 to 16,59 ;
         title ' Enter Fax Filename ' ;
         shadow color scheme 7

  activate window usr_wndw1
  activate window file_wndw

  @ 3, 1 say "Maximum of 8 characters is allowed."
  @ 4, 1 say 'The filename, you enter, will have'
  @ 5, 1 say '".TXT" added to the end of the name.'
  @ 6, 1 say 'Do not use any special characters.'

  @ 1,15 get rep_file
  read

  rep_file = "c:\crit\fax\"+alltrim(rep_file)+".txt"

  deactivate window file_wndw
  release    window file_wndw

  define window file_wndw from 7,18 to 19, 60 ;
         title ' Your Fax is Ready ' ;
         shadow color scheme 7
  activate window file_wndw

  @  1, 1  say "After the fax has been printed, go to"
  @  2, 1  say "the Systray, on the desktop, and start"
  @  3, 1  say "WinFax, by Right-Clicking on the fax"
  @  4, 1  say "icon. Next, left-click on send a Fax..."

  @  6, 1  say "File location: "+rep_file

  @  8, 1  say "When the fax has been sent, return here"
  @  9, 1  say "to continue to work as before."
  read

  release  window file_wndw

  if .not. empty(rep_file)
     outp_dev = 'file'
  endif
return ''
*L
function _torcd
  ndx_exp  = sys(14,1)
  if &ndx_exp >= first_val
    last_rec = record_no
    last_val = &ndx_exp
  else
    = dismsg("Last record must follow the first record")
  endif
  = _disstat()
return ''
*L
function _zoom

* susp

  if no_zooms = zoom_no
     = dismsg('No Zoom File')
  else
     if right(sys(16,2),12) = 'CRITTERS.FXP'
        do case
           case anml_type = 'C'
              zoom_no = 3
           case anml_type = 'D'
              zoom_no = 2
           case anml_type = 'E'
              zoom_no = 4
           case anml_type = 'F'
              zoom_no = 5
           otherwise

*             = dismsg('The Animal Type field is NOT C, D, E, or F.')

              A_Type =  space(1)
              define window file_wndw from 8,20 to 16,57 ;
              title ' Missing: Animal Type ' ;
              shadow color scheme 7

              activate window usr_wndw1
              activate window file_wndw

              @ 1, 1 say "Every animal must have a TYPE that"
              @ 2, 1 say "describes a general catagory. The "
              @ 3, 1 say "allowed entries are: D, C, F, or E"
              @ 4, 1 say "   (Dog, Cat, Farm, or Exotic.)   "

              GoodType = .F.

              Do while .not. GoodType

                 @ 4,34 get A_Type
                 read

                 A_Type = Upper(A_Type)

                 If A_Type $ "DCFE"
                    GoodType = .T.
                 else
                    @ 6, 1 say "     Please enter: D, C, F, or E  "
                 EndIf

              enddo

              deactivate window file_wndw
              release  window file_wndw

              anml_type = A_Type

              replace anml_type with m->anml_type

              @ 2, 65 say m->anml_type
        endcase
     else
        zoom_no = zoom_no + 1
     endif

     = x_zoom()
     = _begin()
     * If a new page, display new screen
     if first_page <> page_no
        page_no = first_page
     endif
     if &at_eof
        set esca off
        = dismsg('Database empty')
        set esca on
        = _add()
     endif
  endif

return ''
*L
function add_rec
* Add a record
  abort = .f.
  no_rcds = &at_eof

  * reset to first page
  d_function = dispage1()

  on key label PGUP do PageUp
  on key label PGDN do PageDn

  do while page_no <= last_page

********** akl: Bids - Multi Edit Window 10/16/95  2:07 am
*+++++++++ akl: Bids - Allow <BackTab> on Multi Edit Window
    if right(sys(16,3),8) = "BIDS.FXP"
       on key label PGUP do newPageUp
       on key label PGDN do newPageDn
    endif
**********

*--------- akl: Removed - Did not like the way it worked 3/13/96  9:17 pm
********** akl: Added for automatic balance computation 2/11/96  8:42 pm
  if ((prog_name = "PAYABLE" .and. alias() = "PAYDETL")  .or.  ;
      (prog_name = "RECEIVE" .and. alias() = "RECDETL")) .and. ;
     (option = 'copy' .or. option = 'modify'))
        p_amount = 0
  endif
**********
*---------
    getcond = "'G'$fld_usg"

    if right(sys(16,3),8) = "USDA.FXP"
       do clrfld
        @ 14, 1 say space(57)
        @ 15, 1 say space(57)
        @ 16, 1 say space(57)
        @ 17, 1 say space(57)

       do getfldA with getcond
       read

       if m->u_code_2 = "D" .or. m->u_code_2 = "C"
          do getfldB with getcond
          read
       endif

    else

       do getfld with getcond

       ********** akl: Allows cursor to UpArrow to Date field. 12/15/95  6:59 pm
       if right(sys(16,3),9) = "CALLS.FXP"
          read cycle
       else
          read
       endif
       **********
    endif

********** akl: Bids - Multi Edit Window 10/16/95  2:07 am
*+++++++++ akl: Bids - Allow <BackTab> on Multi Edit Window
    if right(sys(16,3),8) = "BIDS.FXP"
       on key label PGUP
       on key label PGDN
    endif
**********

    set message to
    set stat off                    && This had to be put in because the SET
                                    && MESSAGE to does not seem to work !!
    if akl_test $ 'Yy'
       set stat on
    endif

    s_lastkey = lastkey()

    if s_lastkey = 27                                   && Esc
      abort = .t.
      exit
    endif

    if s_lastkey = 18                               && Page Up Key
       if page_no > 1
          page_no = page_no - 1
          do disscr
          loop
       endif
    endif

    if s_lastkey = 3                                && Page Down Key
       if page_no < last_page
          page_no = page_no + 1
          do disscr
          loop
       endif
    endif

    if page_no = first_page
*      Check for duplicate (key entered only on first page)
       if .not. allow_dup&zoom_num
          if right(sys(16,3),8) <> "USDA.FXP"
             seek &ndx_var
             if .not. (&at_eof)
                = dismsg(chr(7) + 'Duplicate record not allowed')
                abort = .t.
                exit
             endif
********** akl: Added individual checking of each key field in USDA 5/31/96  0:26 pm
          else
             if m.usda = 0
                exit
             endif
             s_recno = recno()
             go top
             locate for m.name = name
             if found()
                = dismsg(chr(7) + "Animal's name already in use. Choose another name")
                abort = .t.
                exit
             endif
             go top
             locate for m.usda = usda
             if found()
                = dismsg(chr(7) + "USDA number already in use. Choose another number")
                abort = .t.
                exit
             endif
             if .not. eof()
                goto s_recno
             endif
          endif
**********
       endif
    endif

    * Display lookup fields and computed variables
    do lookup
    do calcul with .t.

    if right(sys(16,3),8) = "USDA.FXP"
       do getfldA with ".t."
       do getfldB with ".t."
    else
       do getfld with ".t."
    endif

    clear gets

    if page_no < last_page
      * Display next screen page
      page_no = page_no + 1
      do disscr
    else
      exit
    endif
  enddo while page_no <= last_page

  * Restore page number
  if page_no > first_page
     deact wind all
     page_no = first_page

     do disscr

     if right(sys(16,3),8) = "USDA.FXP"
        do getfldA with ".t."
        do getfldB with ".t."
     else
        do getfld with ".t."
     endif

     redisp_fld = .t.
  endif

  abort = iif(abort,.t.,.not. save_rec())

  if .not. abort
    if no_rcds
      = set_bndry()
    endif
  else
    if no_rcds
      = _quit()
    else
      go record_no
    endif
  endif abort
return ''
*L
function adv_line
* Advance a report/screen line
  line_no = line_no + 1
  if line_no = lns_per_pg
    do pgeftr
    = adv_page()
  endif
  at_top = .f.
return line_no
*L
function adv_page
* Advance report/screen page

  page_no = page_no + 1

  if right(sys(16,2),12) = 'CRITTERS.FXP' && 9/09/98  9:11 pm (akl)
     if page_no = sel_yes + 1
        return
     endif
  endif

  if outp_dev = 'laser' .or. outp_dev = 'dot'
     eject
  else
     @ line_no+1,0 say replicate(chr(219),76)
  endif

  line_no = top_margin

  do pgehdr
return ''
*L
function chk_dupl

* Set duplicate to .f. if the key is a duplicate, or to .t. otherwise
  private dupl_rec

   if ((&at_bof) = (&at_eof)) .or. '' = trim(ndx_var) .or. allow_dup&zoom_num
    dupl_rec = .f.
  else
    seek &ndx_var
    if option = 'M'
      dupl_rec = record_no <> recno() .and. .not. &at_eof
    else
      dupl_rec = .not. &at_eof
    endif
    if dupl_rec
      = dismsg(chr(7) + 'Duplicate record not allowed')
    else
      go record_no
    endif
  endif
return dupl_rec
*L
function chng_brk
Parameters up
* Increment break level if "up" = .t., decrement otherwise
  if up
    * Set new report termination condition
    brk_field = brk_field&brk_num
    new_cond = '&brk_field<>m->&brk_field' + '.or.'
    cond_size&brk_num = len(new_cond)
    done_cond = new_cond + done_cond
    * Store break field to memory variable
    &brk_field = &brk_field
    * Zoom up if it is a "zoom" break

    if brk_zoom&brk_num
      zoom_no = zoom_no + 1
      zoom_num = str(zoom_no,1)
      frst_child = lnk_var&zoom_num
      select &zoom_num
      seek &frst_child
    endif
    * Increment break number
    brk_no = brk_no + 1
    brk_num = str(brk_no,1)
    done = &done_cond
  else
    brk_no = brk_no - 1
    brk_num = str(brk_no,1)
    * Reduce the report termination condition
    done_cond = substr(done_cond, 1+cond_size&brk_num)
    * Zoom down if it is a "zoom" break
    if brk_zoom&brk_num
      zoom_no = zoom_no - 1
      zoom_num = str(zoom_no,1)
      select &zoom_num
    endif
  endif
return ''
*L
function confirm
  parameters header
  define window con_wndw from 1,50 to 20,100 ;
         double color scheme 12 ;
         FONT 'Arial Bold', 20            && 1,2,5?,6?,8?,10?,11?,'13'

  activate window con_wndw
 
  if (13-len(header)/2) < 0
     = dismsg('Error: Header too long. 13 Chars max')
  endif
  @ 1,00 say space(13-len(header)/2) + header
  @ 3,00 say '    <   >        <  >  '
  @ 3,05 prompt 'Yes'
  @ 3,18 prompt 'No'
  menu to con_opt
  release window con_wndw
return iif(con_opt=1,.t.,.f.)
*L
function con_year
* CONTRACY YEAR returns the year of the contract as specified by Rob
*               for his business.

  SET CENTURY ON
  num_yr = val(right(dtoc(date()),4))-1981
  SET CENTURY OFF

  if val(left(dtoc(date()),4)) > 5
     num_yr = num_yr + 1
  endif
return num_yr
*L
function dismsg
  parameters message
  define window mess_wndw from 10,78-6-len(message) to 24,100 ;
         TITLE "Critters Message" ;
         CLOSE FLOAT GROW ZOOM ;
         shadow color scheme 7;
         FONT 'Arial Bold', 20
  activate window mess_wndw
  if empty(message)
    wait ' Press any key to continue...'
  else
    wait ' ' + message + '...'
  endif
  release window mess_wndw
return ''
*L
function dismsgt
  parameters message
  define window mess_wndw from 0,78-6-len(message) to 2,78 ;
         shadow color scheme 7
  activate window mess_wndw
  if empty(message)
    wait ' Press any key to continue...' ;
         timeout 2
  else
    wait ' ' + message + '...' ;
         timeout 2
  endif
  release window mess_wndw
return ''
*L
function DmsgQwQr
* Display Message, Wait ?(yes or no) Release ?(yes or no)

  parameters Message, WaitReply, CloseWin

  define window mess_wndw from 0,78-6-len(message) to 2,78 ;
         shadow color scheme 7
  activate window mess_wndw

  if WaitReply
     if empty(message)
        @ 0,1 say 'Press any key to continue...'
        read
     else
        @ 0,1 say message + '...'
        read
     endif
  else
     if empty(message)
        @ 0,1 say ''
     else
        @ 0,1 say message + '...'
     endif
  endif

  if CloseWin
     release window mess_wndw
  endif
return ''
*L
function dispage1
  if page_no <> first_page
    redisp_fld = .t.
    page_no = first_page
    do disscr

    if right(sys(16,3),8) = "USDA.FXP"
       do getfldA with ".t."
       do getfldB with ".t."
    else
       do getfld with ".t."
    endif

    clear gets
  endif
return ''
*L
function edit_txt
  define window txt_wndw from 1,0 to 24,79  ;
         title 'PRINT TO SCREEN (ESC To Exit)' ;
         system zoom float grow close color scheme 11

  if akl_test $ 'Yy'
     modify file gentemp.gtx        window txt_wndw  && .gtx = GeneralTeXt
  else
     modify file gentemp.gtx noedit window txt_wndw  && .gtx = GeneralTeXt
  endif
  release window txt_wndw
return ''
*L
function end_rpt
  if outp_dev = 'laser' .or. outp_dev = 'dot'
     if right(sys(16,3),11) <> 'P_CONTR.FXP'  .and. ;
        right(sys(16,3),10) <> 'P_INVO.FXP'   .and. ;
        right(sys(16,5),12) <> 'P_SUBRNT.FXP' .and. ;
        right(sys(16,5),10) <> 'P_BIDS.FXP'
        if .not. ((right(sys(16,3),12) = 'P_LABELS.FXP' .or. ;
                   right(sys(16,3),12) = 'P_LABLS1.FXP' .or. ;
                   right(sys(16,3),12) = 'P_LABLS2.FXP') .and. ;
                 (m.group = 2 .or. m.group = 3 .or. m.group = 4 .or. m.group = 5))
           eject
        endif
     endif
  endif

  if outp_dev = 'file'
     set printer to
  endif

  set device to screen
  set console on

return ''

*       right(sys(16,4),10) <> 'P_BIDS.FXP'           && (akl) 6/02/99  0:33 pm
*   .and. ;                                     && 2/20/94 (akl)
*        right(sys(16,3),12) <> 'P_LABELS.FXP'

*L
function envrnmnt
  on error do errfix with error(),message(),message(1),program(),lineno()
  set bell off
  set console on
  set decimals to 10
  set deleted on
  set exact off
  set exclusive off
  set device to screen
  set multilocks off
  set refresh to 0
  set reprocess to 1
  set safety off
  set talk off
  close databases
return ''
*L
function errfix
  parameters errnum,errormsg,errormsg1,prgname,lineno
* release window err_wndw
  do case
    case errnum = 108                   && file in use by another
      if confirm('File In Use, Retry?')
        retry
      else
        if wexist('chkf_wndw')
          release window chkf_wndw
        endif
        = restenv()
        return to &callmenu
      endif
    case errnum = 109                   && record locked by another
      if confirm('Record In Use, Retry?')
        retry
      else
        return to mainproc
      endif
      *  return to &
    case errnum = 110                   && file in use by another
      = dismsg('File has to be opended exclusively')
      return to &callmenu
    otherwise
*set esca on
      define window err_wndw from 15,3 to 50,170 ;
         FONT 'Arial Bold', 16 ;
         double float shadow color scheme 2
             
      activate window err_wndw
      @ 0,0 say 'Error Number:  ' + ltrim(str(errnum))
      @ 1,0 say 'Error Message: ' + errormsg
      @ 2,0 say 'Line of Text:  ' + errormsg1
      @ 3,0 say 'Program Name:  ' + prgname
      @ 4,0 say 'Line Number:   ' + ltrim(str(lineno))
      @ 5,0 say 'Object:        ' + sys(2018)
      = dismsg('Error')
      release window err_wndw
*set esca off
  endcase
return ''
*L
function explode
parameters m_row1,m_col1,m_row2,m_col2,m_cnt,m_type

* m_row1 = upper left hand corner of box.
* m_col1 = upper right hand corner of box.
* m_row2 = lower left hand corner of box.
* m_col2 = lower right had corner of box.
* m_cnt  = number of steps for explosion determines the speed that box explodes.
* m_type = type of explosion.
*          1 = all sides explode at once.
*          2 = only sides explode.
*          3 = only top and bottom explode.
*          4 = explodes from top to bottom.
*          5 = explodes from bottom to top.
*          6 = explodes from left to right.
*          7 = explodes from right to left.

public explode
save screen to explode

r_pos1 = m_row1
r_pos2 = m_row2
c_pos1 = m_col1
c_pos2 = m_col2

do case
   case m_type = 1 && all sides.
      store ((m_row2-m_row1)/2)+m_row1 to r_pos1,r_pos2  && row center
      store ((m_col2-m_col1)/2)+m_col1 to c_pos1,c_pos2  && col center
      r_cnt = (r_pos1-m_row1)/m_cnt  && row increment
      c_cnt = (c_pos1-m_col1)/m_cnt  && col increment
   case m_type = 2 && sides only.
      store ((m_col2-m_col1)/2)+m_col1 to c_pos1,c_pos2  && col center
      c_cnt = (c_pos1-m_col1)/m_cnt  && col increment
   case m_type = 3 && top and bottom
      store ((m_row2-m_row1)/2)+m_row1 to r_pos1,r_pos2  && row center
      r_cnt = (r_pos1-m_row1)/m_cnt  && row increment
   case m_type = 4 && top to bottom
      r_pos2 = m_row1
      r_cnt = (m_row2-m_row1)/m_cnt  && row increment
   case m_type = 5 && bottom to top
      r_pos1 = m_row2
      r_cnt = (m_row2-m_row1)/m_cnt  && row increment
   case m_type = 6 && left to right
      c_pos2 = m_col1
      c_cnt = (m_col2-m_col1)/m_cnt  && row increment
   case m_type = 7 && right to left
      c_pos1 = m_col2
      c_cnt = (m_col2-m_col1)/m_cnt  && row increment
endcase

do while r_pos1 >= m_row1 .and. r_pos2 <= m_row2 .and. ;
         c_pos1 >= m_col1 .and. c_pos2 <= m_col2
   @ r_pos1,c_pos1,r_pos2,c_pos2 box 'im;:<mh: '
   do case
      case m_type = 1
         r_pos1 = r_pos1 - r_cnt
         r_pos2 = r_pos2 + r_cnt
         c_pos1 = c_pos1 - c_cnt
         c_pos2 = c_pos2 + c_cnt
      case m_type = 2
         c_pos1 = c_pos1 - c_cnt
         c_pos2 = c_pos2 + c_cnt
      case m_type = 3
         r_pos1 = r_pos1 - r_cnt
         r_pos2 = r_pos2 + r_cnt
      case m_type = 4
         r_pos2 = r_pos2 + r_cnt
      case m_type = 5
         r_pos1 = r_pos1 - r_cnt
      case m_type = 6
         c_pos2 = c_pos2 + c_cnt
      case m_type = 7
         c_pos1 = c_pos1 - c_cnt
   endcase
enddo
clear

*@ m_row1,m_col1,m_row2,m_col2 box 'im;:<mh: '

return ''
*L
function fltrsta

* (akl)  5/11/99  3:27 pm
* The next IF statement was removed to allow Filter message to be displayed.
* if .not. ((right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF') .or. ;
            (right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF'))
     activate screen
* endif
  if .not. empty(filter())
     @ 0,70 say 'Filter On' color w+/n
  else
* (akl)  5/11/99  3:27 pm
* The next IF statement was changed to display the Right-Top corner of the box..
     do case
        case right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF'
             if PrimDisp
                @ 0,70 say "ÍÍÍÍÍÍÍÍÍ"
             else
                @ 0,70 say "ÍÍÍÍÍÍÍÍÍ»"
             endif

        case right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF'
             if PrimDisp
                @ 0,70 say space(09)
             else
                @ 0,70 say "ÍÍ»"+space(06)
             endif

        otherwise
             @ 0,70 say space(09)
     endcase
  endif

  if alias() = 'BIDS'
     if type('s_recon_date') = 'D'
        if empty(s_recon_date)
           @ 0, 1 say space(25)
        else
           @ 0, 1 say "Recon Date: "+dtoc(s_recon_date) color w+/n
        endif
     endif
  endif

  if .not. ((right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF') .or. ;
            (right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF'))

     * (akl) 4/10/99 11:43 pm
     * added if statement for the following condition: 2/M/F5/N/Z
     * The data screen is erased and a user screen is activated.
     * Problem occurs ONLY when Hot-Keying from Bids to Critters Dog's Zoom.
     * No user screen is activated because the amount of data won't fit on a
     * user screen. So the Desk Top is used. (activate screen).

     if .not. (sys(16,5) = "ON... "            .and. ;
               right(sys(16,6),8) = "BIDS.FXP" .and. ;
               right(dbf(),12) = "CRITDOGS.DBF")
        activate window usr_wndw&page_num
     endif

  endif
return ''
*L
function fltrstar
  activate screen
  if .not. empty(filter())
    @ 0,70 say 'Filter On' color w+/n
  else
    @ 0,70 say space(09)
  endif
  activate window usr_wndw
return ''
*L
function genhlp
  parameters prm1
  private org_alias, hlp_topic

  org_alias = alias()
  if "GENHLP.DBF" $ dbf()
    return ''
  endif

  EditFld = .F.         && Rob wants ALL Edit (Memo) fields to point the same
                        && help message  1/10/97  1:53 am (akl)
  if empty(prm1)
    hlp_topic = prog_name
  else
    if empty(sys(18))
       hlp_topic = prm1
    else
       hlp_topic = sys(18)
       if type('&hlp_topic') = 'M'
          EditFld = .T.
       endif
    endif
  endif

  if .not. file('genhlp.DBF')
    if .not. file('genhlp.STR')
      = dismsg('genhlp.STR not found')
      return ''
    else
      select 0
      create genhlp from genhlp.str
      use
    endif
  endif

  select 0
  use genhlp

  set exact on
  if EditFld
     locate for trim(topic) = 'BID'
  else
     locate for trim(topic) = hlp_topic
  endif
  set exact off

  if eof()
    if modi_memo
      append blank
      = rlock()

*     replace topic with prm1          && Is this a bug??
      replace topic with hlp_topic     && If yes, this may be the fix !!
                                       && The screen where a field has not yet
                                       && chosen (A or M), replaces a blank.

      replace brow with  7, bcol with 10 ;
              erow with 16, ecol with 70
      unlock
    else
      && no help available - ignore or alert msg???
      return ''
    endif
  endif
  if modi_memo
    define window help_wndw from brow,bcol to erow,ecol ;
           title 'HELP (ESC to Exit or F10 to Save)' ;
           system zoom float grow close color scheme 11
  else
    define window help_wndw from brow,bcol to erow,ecol ;
           title 'HELP (ESC to Exit)' ;
           system zoom close color scheme 11
  endif
  if modi_memo
    if rlock()
      on key label F10 do sav_wind with 'HELP (ESC to Exit or F10 to Save)'
      modify memo details window help_wndw
      unlock
      on key label F10
    else
      = dismsg('Help Record In Use, Retry')
    endif
  else
    modify memo details noedit window help_wndw
  endif
  use
  if ! empty(org_alias)
    select &org_alias
  endif
  release window help_wndw
return ''
*L
function getgrid
* VARIABLES
  private choice
  private all like prompt*
  choice  = 0
  prompt1 = ' Go '
  prompt2 = ' Modi '
  prompt3 = ' Quit '

* WINDOWS
  define window MAINTMNU from 22,0 to 24,79 ;
         title ' Grid Commands Menu ' ;
         double float shadow color scheme 2

* SCREEN
  activate window MAINTMNU noshow
*              1   2    3
  @  0, 1 say 'Go Modi Quit'
*L
  on key label F7 do genhlp with program()               && USER HELP

  activate window MAINTMNU
  @ 0, 1-1 prompt prompt1
  @ 0, 4-1 prompt prompt2
  @ 0, 9-1 prompt prompt3
  menu to choice

  do case
     case choice = 0
        release window MAINTMNU
        option = 'quit'
     case choice = 1
        option = 'go'
     case choice = 2
        option = 'modify'
     case choice = 3
        release window MAINTMNU
        option = 'quit'
  endcase

  deactivate window MAINTMNU

return option
*L
function getgrid2
* GetGrid2 has the Select (Sel) command added to the list 3/21/96  6:03 pm
* VARIABLES
  private choice
  private all like prompt*
  choice  = 0
  prompt1 = ' Go '
  prompt2 = ' Modi '
  prompt3 = ' Sel '
  prompt4 = ' Quit '

* WINDOWS
  define window MAINTMNU from 22,0 to 24,79 ;
         title ' Grid Commands Menu ' ;
         double float shadow color scheme 2

* SCREEN
  activate window MAINTMNU noshow
*              1   2    3   4
  @  0, 1 say 'Go Modi Sel Quit'
*L
  on key label F7 do genhlp with program()               && USER HELP

  activate window MAINTMNU
  @ 0, 1-1 prompt prompt1
  @ 0, 4-1 prompt prompt2
  @ 0, 9-1 prompt prompt3
  @ 0,13-1 prompt prompt4
  menu to choice

  do case
     case choice = 0
        release window MAINTMNU
        option = 'quit'
     case choice = 1
        option = 'go'
     case choice = 2
        option = 'modify'
     case choice = 3
        option = 'select'
     case choice = 4
        release window MAINTMNU
        option = 'quit'
  endcase

  deactivate window MAINTMNU

return option
*L
function getsel
   on key label F7 do genhlp with sys(18)

   do case
      case right(sys(16,2),12) = 'CRITTERS.FXP' .and. zoom_num <> '1'
         do maintmnu2

      case right(sys(16,2),12)='CONTRACT.FXP' .or. right(sys(16,2),11)='INVOICE.FXP'  .or. ;
           right(sys(16,2),11)='ANIMALS.FXP'  .or. right(sys(16,2),08)='BIDS.FXP'     .or. ;
           right(sys(16,3),08)='CREW.FXP'     .or. right(sys(16,2),12)='CRITTERS.FXP' .or. ;
           right(sys(16,3),07)='DHR.FXP'      .or. right(sys(16,3),08)='ACTS.FXP'     .or. ;
           right(sys(16,3),10)='AGENCY.FXP'   .or. right(sys(16,3),08)='JOBS.FXP'     .or. ;
           right(sys(16,3),08)='MAPS.FXP'     .or. right(sys(16,3),11)='MEASURE.FXP'  .or. ;
           right(sys(16,3),11)='PAYABLE.FXP'  .or. right(sys(16,3),10)='PRICES.FXP'   .or. ;
           right(sys(16,3),12)='PRODUCTN.FXP' .or. right(sys(16,3),10)='PETSHP.FXP'   .or. ;
           right(sys(16,3),11)='RECEIVE.FXP'  .or. right(sys(16,3),11)='SUBRENT.FXP'  .or. ;
           right(sys(16,3),08)='USDA.FXP'     .or. right(sys(16,3),12)='HELTHCRT.FXP' .or. ;
           right(sys(16,3),09)='ADOPT.FXP'

         do maintmnu4              && Added menu for 'Go'

      case right(sys(16,3),9) = 'SETUP.FXP'
         do maintmnu5

      otherwise
         do maintmnu

   endcase
return option
*L
************************************************************************
*                                                                      *
*  For CRITTERS the standard maintenance menu is replaced with:        *
*                                                                      *
*       MAINTMNU.prg                                                   *
*                                                                      *
= dismsg('Crit error # 1 - Code not activated. (getsel)')
************************************************************************

  activate screen
  set message to 0
  dimension actn_pad(8,2)
  dimension data_bar(3)
  dimension recd_bar(3)
  dimension recs_bar(3)
  dimension edit_bar(2)
  dimension addr_bar(3)
  dimension scrn_bar(2)
  dimension filt_bar(2)
  dimension quit_bar(1)

  * define pad in each popup
  actn_pad(1,1) = 'DATABASE '
  actn_pad(2,1) = 'RECORD '
  actn_pad(3,1) = 'RECORDS '
  actn_pad(4,1) = 'EDIT '
  actn_pad(5,1) = 'ADD'
  actn_pad(6,1) = 'SCREEN '
  actn_pad(7,1) = 'FILTER '
  actn_pad(8,1) = 'QUIT '
  actn_pad(1,2) = 'DATABASE '
  actn_pad(2,2) = 'RECORD '
  actn_pad(3,2) = 'RECORDS '
  actn_pad(4,2) = 'EDIT '
  actn_pad(5,2) = 'ADD'
  actn_pad(6,2) = 'SCREEN '
  actn_pad(7,2) = 'FILTER '
  actn_pad(8,2) = 'QUIT '

  data_bar(1) = 'List    '
  data_bar(2) = 'Zoom    '
  data_bar(3) = 'Tally   '
* data_bar(4) = 'Quit    '
  recd_bar(1) = 'Retrieve'
  recd_bar(2) = 'Next    '
  recd_bar(3) = 'Previous'
  recs_bar(1) = 'Begin   '
  recs_bar(2) = 'End     '
  recs_bar(3) = 'Skip    '
  edit_bar(1) = 'Modify   '
  edit_bar(2) = 'Edit Memo'
  addr_bar(2) = 'Delete   '
  addr_bar(3) = 'Copy     '
  scrn_bar(1) = 'Next Page'
  scrn_bar(2) = 'Prev Page'
  filt_bar(1) = 'Set Filter   '
  filt_bar(2) = 'Cancel Filter '
  quit_bar(1) = 'Quit '

  menu bar actn_pad,8
  menu 1,data_bar,3
  menu 2,recd_bar,3
  menu 3,recs_bar,3
  menu 4,edit_bar,2
  menu 5,addr_bar,3
  menu 6,scrn_bar,2
  menu 7,filt_bar,2
  menu 8,quit_bar,1
  @ 24,0 say space(80)
  read menu bar to sele_row,sele_col save
  clear
  do case
    case sele_row = 1
      opt_sel = data_bar(sele_col)
    case sele_row = 2
      opt_sel = recd_bar(sele_col)
    case sele_row = 3
      opt_sel = recs_bar(sele_col)
    case sele_row = 4
      opt_sel = edit_bar(sele_col)
    case sele_row = 5
      opt_sel = addr_bar(sele_col)
    case sele_row = 6
      opt_sel = scrn_bar(sele_col)
    case sele_row = 7
      opt_sel = filt_bar(sele_col)
    otherwise
      opt_sel = 'Quit'
  endcase
  if opt_sel <> 'Quit'
    @ 0,1 say upper(trim(opt_sel)) color w+/n
  endif
  activate window usr_wndw&page_num
return lower(trim(opt_sel))
*L
function getseli
  activate screen
  set message to 0
  dimension actn_pad(5,2)
  dimension data_bar(4)
  dimension recd_bar(7)
  dimension scrn_bar(2)
  dimension filt_bar(2)
  dimension quit_bar(1)

  * define pad in each popup
  actn_pad(1,1) = 'DATABASE '
  actn_pad(2,1) = 'RECORD '
  actn_pad(3,1) = 'SCREEN '
  actn_pad(4,1) = 'FILTER '
  actn_pad(5,1) = 'QUIT '
  actn_pad(1,2) = 'DATABASE '
  actn_pad(2,2) = 'RECORD '
  actn_pad(3,2) = 'SCREEN '
  actn_pad(4,2) = 'FILTER '
  actn_pad(5,2) = 'QUIT '

  * data_bar(1) = iif(no_zooms = zoom_no,'\-','Zoom ')
  data_bar(1) = 'List    '
  data_bar(2) = 'Tally   '
  data_bar(3) = 'Zoom    '
  data_bar(4) = 'Quit    '
  recd_bar(1) = 'Retrieve'
  recd_bar(2) = 'Next    '
  recd_bar(3) = 'Previous'
  recd_bar(4) = 'Begin   '
  recd_bar(5) = 'End     '
  recd_bar(6) = 'Skip    '
  recd_bar(7) = 'Memo    '
  scrn_bar(1) = 'Next Page'
  scrn_bar(2) = 'Prev Page'
  filt_bar(1) = 'Set Filter'
  filt_bar(2) = 'Cancel Filter'
  quit_bar(1) = 'Quit '

  menu bar actn_pad,5
  menu 1,data_bar,4
  menu 2,recd_bar,7
  menu 3,scrn_bar,2
  menu 4,filt_bar,2
  menu 5,quit_bar,1
  @ 24,0 say space(80)
  read menu bar to sele_row,sele_col save
  clear
  do case
    case sele_row = 1
      opt_sel = data_bar(sele_col)
    case sele_row = 2
      opt_sel = recd_bar(sele_col)
    case sele_row = 3
      opt_sel = scrn_bar(sele_col)
    case sele_row = 4
      opt_sel = filt_bar(sele_col)
    otherwise
      opt_sel = 'Quit'
  endcase
  if opt_sel <> 'Quit'
    @ 0,1 say upper(trim(opt_sel)) color w+/n
  endif
  activate window usr_wndw&page_num
return lower(trim(opt_sel))
*L
function getselr
  on key label F7 do genhlp with sys(18)
  do maintmnu3
return

************************************************************************
*                                                                      *
*  For CRITTERS the standard maintenance menu is replaced with:        *
*                                                                      *
*       MAINTMNU.prg                                                   *
*                                                                      *
= dismsg('Crit error # 1 - Code not activated. (getselr)')
************************************************************************

  activate screen
  set message to 0
  dimension actn_pad(7,2)
  dimension prnt_bar(3)
  dimension data_bar(3)
  dimension recd_bar(2)
  dimension recs_bar(3)
  dimension scop_bar(3)
  dimension filt_bar(2)
  dimension quit_bar(1)

  * define pad in each popup
  actn_pad(1,1) = 'PRINT '
  actn_pad(2,1) = 'DATABASE '
  actn_pad(3,1) = 'RECORD '
  actn_pad(4,1) = 'RECORDS '
  actn_pad(5,1) = 'SCOPE '
  actn_pad(6,1) = 'FILTER '
  actn_pad(7,1) = 'QUIT '

  actn_pad(1,2) = 'PRINT '
  actn_pad(2,2) = 'DATABASE '
  actn_pad(3,2) = 'RECORD '
  actn_pad(4,2) = 'RECORDS '
  actn_pad(5,2) = 'SCOPE '
  actn_pad(6,2) = 'FILTER '
  actn_pad(7,2) = 'QUIT '

  prnt_bar(1) = 'To Printer  '
  prnt_bar(2) = 'To File     '
  prnt_bar(3) = 'To Screen   '
* prnt_bar(4) = 'Print Report'
* prnt_bar(5) = 'Status      '
* prnt_bar(6) = 'Quit        '

  data_bar(1) = 'List  '
  data_bar(2) = 'Tally '
  data_bar(3) = 'Status'

  recd_bar(1) = 'Next    '
  recd_bar(2) = 'Previous'

  recs_bar(1) = 'Begin '
  recs_bar(2) = 'End   '
  recs_bar(3) = 'Skip  '

  scop_bar(1) = 'From Record  '
  scop_bar(2) = 'To Record    '
  scop_bar(3) = 'Cancel Scope '

  filt_bar(1) = 'Set Filter    '
  filt_bar(2) = 'Cancel Filter '

  quit_bar(1) = 'Quit '

  menu bar actn_pad,7
  menu 1,prnt_bar,3
  menu 2,data_bar,3
  menu 3,recd_bar,2
  menu 4,recs_bar,3
  menu 5,scop_bar,3
  menu 6,filt_bar,2
  menu 7,quit_bar,1
  read menu bar to sele_row,sele_col save
  clear
  do case
    case sele_row = 1
      opt_sel = prnt_bar(sele_col)
    case sele_row = 2
      opt_sel = data_bar(sele_col)
    case sele_row = 3
      opt_sel = recd_bar(sele_col)
    case sele_row = 4
      opt_sel = recs_bar(sele_col)
    case sele_row = 5
      opt_sel = scop_bar(sele_col)
    case sele_row = 6
      opt_sel = filt_bar(sele_col)
    otherwise
      opt_sel = 'Quit'
  endcase
  if opt_sel <> 'Quit'
    @ 0,1 say upper(trim(opt_sel)) color w+/n
  endif
  activate window usr_wndw
return lower(trim(opt_sel))
*L
function init_rpt

  do case
    case outp_dev = 'laser' .or. outp_dev = 'dot'
      if outp_dev = 'dot'
         set print to LPT1
      endif

      if outp_dev = 'laser'
         if right(sys(16,3),12) <> 'P_LABELS.FXP' && Move to 95. Change this when possible.
            if akl_system $ 'Y'
               set print to LPT1
            else
               set print to LPT1
            endif
         endif
      endif

      if right(sys(16,3),12) = 'P_LABELS.FXP'
*        if group = 1 .or. group = 2 .or. group = 3 Commented because there
*               is not more Dot Printer.  4/11/2000  9:57 pm (akl)

* (akl - 12/31/98  4:31 pm)
* I am removing this if statement. I don't really know why I put it in.
* I contradicted myself. See previous IF statement, just below 'laser'.
* After a long time, remove this IF and END statements.
*           if right(sys(16,3),12) <> 'P_LABELS.FXP' && Move to 95. Change this when possible.

               if akl_system $ 'Y'
                  set print to LPT1
               else
                  set print to LPT1
               endif
*            endif

*        endif
      endif

      if right(sys(16,3),11) = 'P_CONTR.FXP'  .or. ;
         right(sys(16,3),10) = 'P_INVO.FXP'   .or. ;
         right(sys(16,3),12) = 'P_SUBRNT.FXP'
            if akl_system $ 'Y'
               set print to LPT1
            else
               set print to LPT1
            endif
      endif

      do while sys(13) = 'OFFLINE'
         @ 0,0 say ' Please set printer on line ...'
         read
         s_readkey = readkey()

         if s_readkey = 268 .or. s_readkey = 12 && Escape was pressed
            set device to screen
            set console on
            set print off
            return
         endif
      enddo

      @ 0,0
      @ 0,0 say ' Printing - ESC To Stop '
      set device to printer
      if outp_dev = 'laser'
         * Move to 95. Change this when possible. <- Why ? 11/14/01
         if right(sys(16,3),12) <> 'P_LABELS.FXP' .and. ;
            right(sys(16,5),10) <> 'P_BIDS.FXP'
            set console off
            set print on
*           @ 0,0 say chr(27)+"E"            && Initialize the printer
            ?? chr(27)+"E"
            set print off
            set console on
         endif
      endif

    case outp_dev = 'file'
      @ 0,0
      @ 0,0 say ' Printing - ESC To Stop '
      set printer to file &rep_file
      set device to file &rep_file

    case outp_dev = 'screen'
      @ 0,0
      @ 0,0 say ' Printing - ESC To Stop '
      set printer to file gentemp.gtx
      set device to file gentemp.gtx
********** akl: Lines added to stop TOF character going into
      eject     && file as first character.  8/01/98  1:18 am
      set printer to
      set device to screen

      set printer to file gentemp.gtx
      set device to file gentemp.gtx
**********
  endcase

  page_no = 1
  line_no = top_margin
  set console off

  lnk_var = ''
  go first_rec

  if .not. empty(filter())
    filter_str = filter()
    if .not. &filter_str
      skip
    endif
  endif

  brk_no = 1
  brk_num = '1'
  done = &done_cond
  at_top = .t.
return ''
*L
function maintmnu
* VARIABLES
  private choice
  private all like prompt*
  choice   = 0
  prompt1  = ' Add '
  prompt2  = ' Beg '
  prompt3  = ' Copy '
  prompt4  = ' Del '
  prompt5  = ' End '
  prompt6  = ' Filt '
  prompt7  = ' List '
  prompt8  = ' Modi '
  prompt9  = ' Next '
  prompt10 = ' Prev '
  prompt11 = ' Quit '
  prompt12 = ' Ret '
  prompt13 = ' Skip '
  prompt14 = ' Tally '
  prompt15 = ' Zoom '

* WINDOWS
  define window MAINTMNU from 22,0 to 24,79 ;
         title ' Maintenance Commands Menu ' ;
         double float shadow color scheme 2

* SCREEN
* Commented for VFP
  IF .F.
  activate window MAINTMNU noshow
*               1   2    3   4   5   6    7    8    9    10   11  12   13   14    15
  @  0, 1 say 'Add Beg Copy Del End Filt List Modi Next Prev Quit Ret Skip Tally Zoom'
  ENDIF
* Commented for VFP
*L
* FUNCTION KEY ASSIGNMENT
  on key label F7  do genhlp with program()               && USER HELP

  do case
     case prog_name = "CALENDAR"
        on key label F2  do mntmnuf with 2
        on key label F10 do mntmnuf with 10

     otherwise
        on key label F2  do mntmnuf with 2
        on key label F8  do mntmnuf with 8
        on key label F9  do mntmnuf with 9
        on key label F10 do mntmnuf with 10
        on key label F11 do mntmnuf with 11

  endcase

* Added for VFP  
  do DispMenu
  s_choice = mChoice
  choice = mChoice

* Commented for VFP
  IF .F.
    activate window MAINTMNU
    @ 0, 1-1 prompt prompt1
    @ 0, 5-1 prompt prompt2
    @ 0, 9-1 prompt prompt3
    @ 0,14-1 prompt prompt4
    @ 0,18-1 prompt prompt5
    @ 0,22-1 prompt prompt6
    @ 0,27-1 prompt prompt7
    @ 0,32-1 prompt prompt8
    @ 0,37-1 prompt prompt9
    @ 0,42-1 prompt prompt10
    @ 0,47-1 prompt prompt11
    @ 0,52-1 prompt prompt12
    @ 0,56-1 prompt prompt13
    @ 0,61-1 prompt prompt14
    @ 0,67-1 prompt prompt15
    menu to choice
  ENDIF
* Commented for VFP

  do case
     case choice = 0
        release window MAINTMNU
        option = 'quit'
     case choice = 1
        option = 'add'
     case choice = 2
        option = 'begin'
     case choice = 3
        option = 'copy'
     case choice = 4
        option = 'delete'
     case choice = 5
        option = 'end'
     case choice = 6
        define window fil_wndw from 1,50 to 6,77 double color scheme 12
        activate window fil_wndw
        header = 'Filter'
        @ 1,00 say space(13-len(header)/2) + header
        @ 3,04 say '<Set>      <Cancel>'
        @ 3,05 prompt 'Set'
        @ 3,16 prompt 'Cancel'
        menu to fil_opt

        if fil_opt = 1
           option = 'set filter'
        endif

        if fil_opt = 2
           option = 'cancel filter'
        endif

        release window fil_wndw

     case choice = 7
        option = 'list'
     case choice = 8
        option = 'modify'
     case choice = 9
        option = 'next'
     case choice = 10
        option = 'previous'
     case choice = 11
        release window MAINTMNU
        option = 'quit'
     case choice = 12
        option = 'retrieve'
     case choice = 13
        option = 'skip'
     case choice = 14
        option = 'tally'
     case choice = 15
        option = 'zoom'
  endcase

  deactivate window MAINTMNU
return option

* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

function mntmnuf
parameter KeyF_no

  do case
     case KeyF_no = 2
        KeyF2 = .T.

     case KeyF_no = 5
        KeyF5 = .T.

     case KeyF_no = 8
        KeyF8 = .T.

     case KeyF_no = 9
        KeyF9 = .T.

     case KeyF_no = 10
        KeyF10 = .T.

     case KeyF_no = 11
        KeyF11 = .T.

  endcase

  s_FkeyRec = recno()
  s_prgname = prog_name
  keyboard chr(113) plain

return
*L
function maintmnu2
* VARIABLES
  private choice
  private all like prompt*
  choice  = 0
  prompt1 = ' Modi '
  prompt2 = ' Quit '
  prompt3 = ' Del '
  prompt4 = ' Filt '

* if ((right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF') .or. ;
*     (right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF'))
    prompt5 = ' Primary '
    prompt6 = ' Secondary '
* endif

* WINDOWS
  define window MAINTMNU from 22,0 to 24,79 ;
         title ' Maintenance Commands Menu (Zoom) ' ;
         double float shadow color scheme 2

* SCREEN
  ON KEY LABEL Alt+F12 SUSPEND
  activate window MAINTMNU noshow
*               1    2    3   4      5        6
  @  0, 1 say 'Modi Quit Del Filt Primary Secondary'

  if ((right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF') .or. ;
      (right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF'))
   *                       1         2         3
   *              123456789012345678901234567890123456
     @  0, 1 say 'Modi Quit Del Filt Primary Secondary'
   *     Prompt:   1    2    3   4      5        6
  endif
*L
  on key label F2 do mntmnuf22
  on key label F7 do genhlp with program()               && USER HELP

  if ((right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF') .or. ;
      (right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF'))                 on key label PgDn do DispSecn
        on key label PgUp do DispPrim
  endif

  activate window MAINTMNU
  @ 0, 1-1 prompt prompt1
  @ 0, 6-1 prompt prompt2
  @ 0,11-1 prompt prompt3
  @ 0,15-1 prompt prompt4

  if (right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF') .or. ;
      right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF'))
        @ 0,20-1 prompt prompt5
        @ 0,28-1 prompt prompt6
  endif

  menu to choice

  do case
     case choice = 0
        release window MAINTMNU
        option = 'quit'
     case choice = 1
        option = 'modify'
     case choice = 2
        release window MAINTMNU
        option = 'quit'
     case choice = 3
        option = 'delete'
     case choice = 4
        define window fil_wndw from 1,50 to 6,77 double color scheme 12
        activate window fil_wndw
        header = 'Filter'
        @ 1,00 say space(13-len(header)/2) + header
        @ 3,04 say '<Set>      <Cancel>'
        @ 3,05 prompt 'Set'
        @ 3,16 prompt 'Cancel'
        menu to fil_opt

        if fil_opt = 1
           option = 'set filter'
        endif

        if fil_opt = 2
           option = 'cancel filter'
        endif

        release window fil_wndw
     case choice = 5
        option = 'primary'
        do DispPrim

     case choice = 6
        option = 'secondary'
        do DispSecn
  endcase

  deactivate window MAINTMNU

  if (right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITDOGS.DBF') .or. ;
     (right(sys(16,2),12) = 'CRITTERS.FXP' .and. right(dbf(),12) = 'CRITCATS.DBF')
     on key label PgDn
     on key label PgUp
  endif

return option

* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

function mntmnuf22

  KeyF2 = .T.
  s_prgname = prog_name
  keyboard chr(113) plain

return
*L
function maintmnu3
* VARIABLES
  private choice
  private all like prompt*
  choice   = 4
  prompt1  = ' Beg '
  prompt2  = ' End '
  prompt3  = ' Filt '
  Prompt4  = ' Go '
  prompt5  = ' List '
  prompt6  = ' Next '
  prompt7  = ' Prev '
  prompt8  = ' Quit '
  prompt9  = ' Ret '
  prompt10 = ' Skip '
  prompt11 = ' Tally '
  prompt12 = ' < '
  prompt13 = ' > '

* WINDOWS
  define window MAINTMNU from 22,0 to 24,79 ;
         title ' Report Commands Menu ' ;
         double float shadow color scheme 2

* SCREEN
  activate window MAINTMNU noshow
*              1   2   3   4   5    6    7    8    9   10   11  12 13
  @ 0, 1 say 'Beg End Filt Go List Next Prev Quit Ret Skip Tally < >'
*L
  on key label F7 do genhlp with program()               && USER HELP

  activate window MAINTMNU
  @ 0, 1-1 prompt prompt1
  @ 0, 5-1 prompt prompt2
  @ 0, 9-1 prompt prompt3
  @ 0,14-1 prompt prompt4
  @ 0,17-1 prompt prompt5
  @ 0,22-1 prompt prompt6
  @ 0,27-1 prompt prompt7
  @ 0,32-1 prompt prompt8
  @ 0,37-1 prompt prompt9
  @ 0,41-1 prompt prompt10
  @ 0,46-1 prompt prompt11
  @ 0,52-1 prompt prompt12
  @ 0,54-1 prompt prompt13
  menu to choice

  do case
     case choice = 0
        release window MAINTMNU
        option = 'quit'
     case choice = 1
        option = 'begin'
     case choice = 2
        option = 'end'
     case choice = 3
        define window fil_wndw from 1,50 to 6,77 double color scheme 12
        activate window fil_wndw
        header = 'Filter'
        @ 1,00 say space(13-len(header)/2) + header
        @ 3,04 say '<Set>      <Cancel>'
        @ 3,05 prompt 'Set'
        @ 3,16 prompt 'Cancel'
        menu to fil_opt

        if fil_opt = 1
           option = 'set filter'
        endif

        if fil_opt = 2
           option = 'cancel filter'
        endif

        release window fil_wndw

     case choice = 4
        if right(sys(16,3),11) = 'P_CONTR.FXP'
           option = 'to printer'
        else
*          do out_dev                                           && 11/27/93
        endif

     case choice = 5
        option = 'list'
     case choice = 6
        option = 'next'
     case choice = 7
        option = 'previous'
     case choice = 8
        release window MAINTMNU
        option = 'quit'
     case choice = 9
        option = 'retrieve'
     case choice = 10
        option = 'skip'
     case choice = 11
        option = 'tally'
     case choice = 12
        option = 'from record'
     case choice = 13
        option = 'to record'
  endcase

  deactivate window MAINTMNU
return option
*L
function maintmnu4
* 10/19 - Added 'menu4' to allow the 'Go' (print) from a maintnenace window.
*         This works the same as the Print Menu 'Go' command. (AKL)

* VARIABLES
  private choice
  private all like prompt*
  choice   = 0
  prompt1  = ' Add '
  prompt2  = ' Beg '
  prompt3  = ' Copy '
  prompt4  = ' Del '
  prompt5  = ' End '
  prompt6  = ' Filt '
  prompt7  = ' Go '
  prompt8  = ' List '
  prompt9  = ' Modi '
  prompt10 = ' Next '
  prompt11 = ' Prev '
  prompt12 = ' Quit '
  prompt13 = ' Ret '
* New Select Command
  if right(sys(16,2),12) = 'CRITTERS.FXP' .or. right(sys(16,3),8) = 'USDA.FXP'
        prompt14 = ' Sele '
  else
        prompt14 = ' Skip '
  endif
  prompt15 = ' Tally '
  prompt16 = ' Zoom '

* WINDOWS
  define window MAINTMNU from 95,0 to 105,190 ;
         title ' Maintenance Commands Menu ' ;
         double float shadow color scheme 2 ;
         FONT 'Arial Bold', 19

* SCREEN
  ON KEY LABEL Alt+F12 SUSPEND
  activate window MAINTMNU

* Commented for VFP
  IF .F.
  if right(sys(16,2),12) = 'CRITTERS.FXP'
*                  1   2    3   4   5   6   7    8   9    10   11   12  13   14   15    16
     @  0, 1 say 'Add Beg Copy Del End Filt Go List Modi Next Prev Quit Ret Sele Tally Zoom'
  else
     @  0, 1 say 'Add Beg Copy Del End Filt Go List Modi Next Prev Quit Ret Skip Tally Zoom'
  ENDIF
  ENDIF
* Commented for VFP
*L
  if .not. right(sys(16,3),11) = "ANIMALS.FXP"
     on key label F1  do mntmnuf4 with 1
  endif
  if .not. right(sys(16,3),8) = "BIDS.FXP"
     on key label F2  do mntmnuf4 with 2
  endif
  if .not. right(sys(16,3),12) = "CALENDAR.FXP"
     on key label F3  do mntmnuf4 with 3
  endif
  if .not. right(sys(16,3),12) = "CONTRACT.FXP"
     on key label F4  do mntmnuf4 with 4
  endif
  if .not. right(sys(16,3),12) = "CRITTERS.FXP"
     on key label F5  do mntmnuf4 with 5
  endif
  if .not. right(sys(16,3),11) = "INVOICE.FXP"
     on key label F6  do mntmnuf4 with 6
  endif
  on key label F7  do genhlp with program()               && USER HELP
  on key label F8  do mntmnuf4 with 8
  if .not. right(sys(16,3),10) = "PRICES.FXP"
     on key label F9  do mntmnuf4 with 9
  endif
  on key label F10 do mntmnuf4 with 10
  on key label F11 do mntmnuf4 with 11

  activate window MAINTMNU

  do DispMenu
  s_choice = mChoice
  choice = mChoice

* Commented for VFP
  IF .F.
    @ 0, 1-1 prompt prompt1
    @ 0, 5-1 prompt prompt2
    @ 0, 9-1 prompt prompt3
    @ 0,14-1 prompt prompt4
    @ 0,18-1 prompt prompt5
    @ 0,22-1 prompt prompt6
    @ 0,27-1 prompt prompt7
    @ 0,30-1 prompt prompt8
    @ 0,35-1 prompt prompt9
    @ 0,40-1 prompt prompt10
    @ 0,45-1 prompt prompt11
    @ 0,50-1 prompt prompt12
    @ 0,55-1 prompt prompt13
    @ 0,59-1 prompt prompt14
    @ 0,64-1 prompt prompt15
    @ 0,70-1 prompt prompt16
    menu to choice
  ENDIF
* Commented for VFP

  do case
     case choice = 0
        release window MAINTMNU
        option = 'quit'
     case choice = 1
        option = 'add'
     case choice = 2
        option = 'begin'
     case choice = 3
        option = 'copy'
     case choice = 4
        option = 'delete'
     case choice = 5
        option = 'end'
     case choice = 6
        define window fil_wndw from 1,50 to 6,77 double color scheme 12
        activate window fil_wndw
        header = 'Filter'
        @ 1,00 say space(13-len(header)/2) + header
        @ 3,04 say '<Set>      <Cancel>'
        @ 3,05 prompt 'Set'
        @ 3,16 prompt 'Cancel'
        menu to fil_opt

        if fil_opt = 1
           option = 'set filter'
        endif

        if fil_opt = 2
           option = 'cancel filter'
        endif

        release window fil_wndw

     case choice = 7
        option = 'go'
     case choice = 8
        option = 'list'
     case choice = 9
        option = 'modify'
     case choice = 10
        option = 'next'
     case choice = 11
        option = 'previous'
     case choice = 12
        release window MAINTMNU
        option = 'quit'
     case choice = 13
        option = 'retrieve'
     case choice = 14
        option = 'skip'
     case choice = 15
        option = 'tally'
     case choice = 16
        option = 'zoom'
  endcase

  deac wind MAINTMNU
  rele wind MAINTMNU

  deac wind MAINTMNU4
  rele wind MAINTMNU4

  rele memo like prompt*
return option
*L
* Added for VFP  
procedure DispMenu
  PUBLIC mCHOICE, mGET, cCHOICE, cCHOICES
  STORE 0 TO mCHOICE, mGET
  STORE "" TO cCHOICE, cCHOICES
* nCOL = ROUND(WCOLS()/2,0) - 19

* Add Beg Copy Del End Filt Go List Modi Next Prev Quit Ret Skip Tally Zoom'

  nPad = 3
  nROW = 0
* 1
  nCOL = 0  
  DO GET WITH nROW,nCOL, "\<Add"
  nCOL = nCol + 3 + nPad
  DO GET WITH nROW,nCOL, "\<Beg"
  nCOL = nCol + 3 + nPad
  DO GET WITH nROW,nCOL, "\<Copy"
  nCOL = nCol + 4 + nPad
  DO GET WITH nROW,nCOL, "\<Del"
* 5
  nCOL = nCol + 3 + nPad
  DO GET WITH nROW,nCOL, "\<End"
  nCOL = nCol + 3 + nPad
  DO GET WITH nROW,nCOL, "\<Filt"
  nCOL = nCol + 4 + nPad
  DO GET WITH nROW,nCOL, "\<Go"
  nCOL = nCol + 2 + nPad
  DO GET WITH nROW,nCOL, "\<List"
  nCOL = nCol + 4 + nPad
  DO GET WITH nROW,nCOL, "\<Modi"
* 10
  nCOL = nCol + 4 + nPad
  DO GET WITH nROW,nCOL, "\<Next"
  nCOL = nCol + 4 + nPad
  DO GET WITH nROW,nCOL, "\<Prev"
  nCOL = nCol + 4 + nPad
  DO GET WITH nROW,nCOL, "\<Quit"
  nCOL = nCol + 4 + nPad
  DO GET WITH nROW,nCOL, "\<Ret"
  nCOL = nCol + 3 + nPad
  DO GET WITH nROW,nCOL, "\<Skip"
* 15
  nCOL = nCol + 4 + nPad
  DO GET WITH nROW,nCOL, "\<Tally"
  nCOL = nCol + 5 + nPad
  DO GET WITH nROW,nCOL, "\<Zoom"

* Add Beg Copy Del End Filt Go List Modi Next Prev Quit Ret Skip Tally Zoom'

  cCHOICES = cCHOICES + "12Q"
  cCHOICE = fnCHOICE(cCHOICES, "Q")

FUNCTION fnCUROBJ
PARAMETERS mCHOICE
  mCHOICE = _CUROBJ
RETURN .T.

PROCEDURE GET
PARAMETERS nROW, nCOL, cFUNC, bSKIP
  nSIZE2 = LEN(STRTRAN(cFUNC,"\<")) + 2
 
  @ nROW,nCOL GET mGET FUNCTION "* "+IIF(bSKIP,"\\","")+cFUNC ;
                              VALID fnCUROBJ(@mCHOICE)

* @ nROW,nCOL GET mGET FUNCTION "* "+IIF(bSKIP,"\\","")+cFUNC ;
                              VALID fnCUROBJ(@mCHOICE)
*     DEFAULT 1 SIZE 1,nSIZE2 VALID fnCUROBJ(@mCHOICE)
* Note: nSIZE2 is not used any other place.
RETURN

FUNCTION fnCHOICE
PARAMETERS cCHOICES, cDEF
  READ CYCLE OBJECT mCHOICE
  mCHOICE = IIF(LASTKEY()=27,AT(cDEF,cCHOICES),mCHOICE)
RETURN IIF(mCHOICE > 0,SUBSTR(cCHOICES,mCHOICE,1),"")

* End - Added for VFP

* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

function mntmnuf4
parameter KeyF_no

* suspend

  do case
     case KeyF_no = 1
        KeyF1  = .T.

     case KeyF_no = 2
        KeyF2  = .T.

     case KeyF_no = 3
        KeyF3  = .T.

     case KeyF_no = 4
        KeyF4  = .T.

     case KeyF_no = 5
        KeyF5  = .T.

     case KeyF_no = 6
        KeyF6  = .T.

     case KeyF_no = 8
        KeyF8  = .T.

     case KeyF_no = 9
        KeyF9  = .T.

     case KeyF_no = 10
        KeyF10 = .T.

     case KeyF_no = 11
        KeyF11 = .T.

  endcase

  s_FkeyRec = recno()
  s_prgname = prog_name

  if prog_name = "PAYABLE" and alias() = "PAYDETL"
     s_FkeyPag = 2
     select payable
     s_FkyMRec = recno()
  endif

  keyboard chr(113) plain

return
*L
function maintmnu5
* VARIABLES
  private choice
  private all like prompt*
  choice  = 0
  prompt1 = ' Quit '
  prompt2 = ' Modi '

* WINDOWS
  define window MAINTMNU from 22,0 to 24,79 ;
         title ' Maintenance Commands Menu ' ;
         double float shadow color scheme 2

* SCREEN
  ON KEY LABEL Alt+F12 SUSPEND
  activate window MAINTMNU noshow
*               1    2
  @  0, 1 say 'Quit Modi'
*L
  on key label F7 do genhlp with program()               && USER HELP

  activate window MAINTMNU
  @ 0, 1-1 prompt prompt1
  @ 0, 6-1 prompt prompt2
  menu to choice

  do case
     case choice = 0
        release window MAINTMNU
        option = 'quit'

     case choice = 1
        release window MAINTMNU
        option = 'quit'

     case choice = 2
        option = 'modify'

  endcase

  deactivate window MAINTMNU

return option
*L
function out_dev
   define window fil_wndw from 1,40 to 6,77 double color scheme 12
   activate window fil_wndw
   header = 'Print'
   @ 1,00 say space(19-len(header)/2) + header
   @ 3,04 say '<Screen>   <Laser>   <File>'
   @ 3,05 prompt 'Screen'
   @ 3,16 prompt 'Laser'
   @ 3,26 prompt 'File'

   menu to fil_opt

   if fil_opt = 1
      option = 'to screen'
   endif

   if fil_opt = 2
      option = 'to laser'
   endif

   if fil_opt = 3
      option = 'to file'
   endif

   release window fil_wndw
return ''
*L
function restenv
  for i=1 to no_pages
    i_str = str(i,1)

    if wexist('usr_wndw'+i_str)
      release window usr_wndw&i_str
    endif
  endfor

  if wexist('maintmnu')
     release window maintmnu
  endif

  acti screen
  @ 0,62 say space(7)
  @ 0,70 say space(9)

  show window all
  close databases
return ''
*L
function restenvr
  release window usr_wndw
  show window all
  close databases
return ''
*L
function save_rec

********** akl: First, check the spelling of the record 3/19/96  1:55 am
  if prog_name = "BIDS"    .or. prog_name = "CONTRACT" .or. ;
     prog_name = "INVOICE" .or. prog_name = "SUBRENT"  .or. ;
     prog_name = "MAPS"    .or. prog_name = "HELTHCRT"
        do SpellChk with "Rec"     && Record (Rec) or Field (Fld)

        if right(sys(16,3),8) = "USDA.FXP"
           do getfldA with ".t."
           do getfldB with ".t."
        else
           do getfld with ".t."
        endif

  endif
**********

  if confirm('Save Record')
    append blank
    if right(sys(16,3),12) = "CONTRACT.FXP"
       sele 2
       append blank
       sele 3
       append blank
       sele 1
    endif
    = rlock()
********** akl: DHR - Field USDA.NAME 7/23/96 12:37 am
    if prog_name = "DHR"
       usda = usda.usda
    endif
**********
    gather memvar memo
    if right(sys(16,3),12) = "CONTRACT.FXP"
       sele 2
       gather memvar
       sele 3
       gather memvar
       sele 1
    endif
    unlock
    * reset the filter
    if .not. empty(filter())
      * Check if record matches filter
      record_no = recno()
      skip
      skip -1
      if recno() <> record_no  && No match
        = _begin()
        if &at_eof  &&  Remove filter
          set filter to
          go record_no
        endif
      endif
    endif
    return .t.
  endif
return .f.
*L
procedure sav_wind                && linked to F10 by gen_hlp
  parameter w_name
  replace brow with wlrow(w_name), bcol with wlcol(w_name), ;
          erow with wlrow(w_name) + wrows(w_name) + 1, ;
          ecol with wlcol(w_name) + wcols(w_name) + 1
  keyboard chr(23)                && Ctrl-W to Exit window with save
return
*L
function set_bndry
  * Set boundaries
  skip -1
  if bof()
    top_mark = 0
  else
    top_mark = recno()
    skip 1
  endif
  skip 1
  if eof()
    bot_mark = -1
  else
    bot_mark = recno()
  endif
  skip -1
return ''
*L
function stp_prnt
  on escape
  zoom_no = 1
  zoom_num = '1'
  brk_no = 1
  brk_num = '1'
  select 1
  done_cond  = '&ndx_exp>last_val.or.eof()'
return to _print
*L
function val_fil
parameters n_vald_fld, ref_fld, vald_alias, getpos, fld_size


   vald_fld = &n_vald_fld

if .f.
   set view off
   acti screen
   clear
   for i = 1 to 25
      ?
   next

   ?
   ? "Parameters:"
   ? "n_vald_fld >"+n_vald_fld+"<"
   ? "vald_fld >"+vald_fld+"<"
   ? "ref_fld = "+ref_fld
   ? "vald_alias = "+vald_alias
   ? "getpos = "
   ?? getpos
   ? "fld_size = "
   ?? fld_size
endif

  private at_eof,at_bof,record_no
  set notify off

  is_valid    = .f.
  at_eof      = 'eof()'
  at_bof      = 'bof()'

  save_alias  = alias()
  empty_field = .F.

  select &vald_alias

  do case
    case type("vald_fld") = 'D'
      srch_str = str(year(m->vald_fld),4) + str(month(vald_fld),2)+str(day(vald_fld),2)

    case type("vald_fld") = 'N'
      srch_str = str(vald_fld,fld_size)
      if vald_fld = 0
         empty_field = .T.
      endif

    otherwise
      srch_str = vald_fld
      if len(trim(vald_fld)) = 0
         empty_field = .T.
      endif
  endcase

  if type("vald_fld") = 'N'
    locate for &ref_fld = val(srch_str)
  else
    seek srch_str

if .f.
   ?
   ? "Seeking to >"+srch_str+"<"
   if found()
      ? "Found"
   else
      ? "NOT found"
   endif
endif

  endif

if .f.
   ?
   ? "eof() = "
   ?? eof()
endif

  if .not. eof()                                && found
     is_valid = .t.
  else
     if empty_field
        if right(sys(16,3),12) = "CRITTERS.FXP"
           is_valid = .f.
        else
           is_valid = .t.
        endif
     else
        set near on
        seek srch_str
        set near off
        leftpos = iif(getpos > 40,4,43)

        define window brws_wndw from 6,leftpos to 15,leftpos+30 ;
               system zoom float grow close shadow color scheme 10

        on key label ENTER keyboard chr(23)

        activate window brws_wndw noshow
        browse last noappend nomodify nodelete window brws_wndw
        release window brws_wndw

if .f.
   set view off
   acti screen
   clear
   for i = 1 to 25
      ?
   next

   ? ">"+type(ref_fld)+"<"
   ? ">"+ref_fld+"<"
   ? ">"+&ref_fld+"<"
endif

        do case
           case type("ref_fld") = 'C'
if .f.
   ?
   ? "Field is CHARACTER"
   ? "type(ref_fld) = >"+type(ref_fld)+"<"
   ? "ref_fld = >"+ref_fld+"<"
   ? "&ref_fld = >"+&ref_fld+"<"

   on key label ENTER
*  suspend
endif

*             keyboard &ref_fld

              do case
                 case n_vald_fld = "m->name"
                    name = &ref_fld
                    show gets
                    is_valid = .t.
                 case n_vald_fld = "m->anml_name"
                    anml_name = &ref_fld
                    show gets
                    is_valid = .t.
                 case n_vald_fld = "m->crit_name"
                    crit_name = &ref_fld
                    show gets
                    is_valid = .t.
                 case n_vald_fld = "m->job_no"
                    job_no = &ref_fld
                    show gets
                    is_valid = .t.
                 case n_vald_fld = "m->map_no"
                    map_no = &ref_fld
                    show gets
                    is_valid = .t.
             endcase

           case type(ref_fld) = 'D'
              keyboard dtoc(&ref_fld)

           case type(ref_fld) = 'N'
              keyboard ltrim(str(&ref_fld))
        endcase

        on key label ENTER                  && Re-assigns orginal value
     endif
  endif

if .f.
   ?
   ? ">"+type(ref_fld)+"<"
   ? ">"+ref_fld+"<"
   ? ">"+&ref_fld+"<"
   ? "is_valid="
   ?? is_valid
endif

  select &save_alias
  set notify off

return is_valid
*L
function orig_val_fil
parameters vald_fld, ref_fld, vald_alias, getpos, fld_size

set view off
acti screen
clear
for i = 1 to 25
   ?
next

?
? "Parameters:"
? "vald_fld >"+vald_fld+"<"
? "ref_fld = "+ref_fld
? "vald_alias = "+vald_alias
? "getpos = "
?? getpos
? "fld_size = "
?? fld_size

  private at_eof,at_bof,record_no
  set notify off

  is_valid    = .f.
  at_eof      = 'eof()'
  at_bof      = 'bof()'

  save_alias  = alias()
  empty_field = .F.

  select &vald_alias

  do case
    case type("vald_fld") = 'D'
      srch_str = str(year(m->vald_fld),4) + str(month(vald_fld),2)+str(day(vald_fld),2)

    case type("vald_fld") = 'N'
      srch_str = str(vald_fld,fld_size)
      if vald_fld = 0
         empty_field = .T.
      endif

    otherwise
      srch_str = vald_fld
      if len(trim(vald_fld)) = 0
         empty_field = .T.
      endif
  endcase

  if type("vald_fld") = 'N'
    locate for &ref_fld = val(srch_str)
  else
    seek srch_str

?
? "Seeking to >"+srch_str+"<"
if found()
   ? "Found"
else
   ? "NOT found"
endif

  endif

?
? "eof() = "
?? eof()

  if .not. eof()                                && found
     is_valid = .t.
  else
     if empty_field
        if right(sys(16,3),12) = "CRITTERS.FXP"
           is_valid = .f.
        else
           is_valid = .t.
        endif
     else
        set near on
        seek srch_str
        set near off
        leftpos = iif(getpos > 40,4,43)

        define window brws_wndw from 6,leftpos to 15,leftpos+30 ;
               system zoom float grow close shadow color scheme 10

        on key label ENTER keyboard chr(23)

        activate window brws_wndw noshow
        browse last noappend nomodify nodelete window brws_wndw
        release window brws_wndw

*if .f.
   set view off
   acti screen
   clear
   for i = 1 to 25
      ?
   next

   ? ">"+type(ref_fld)+"<"
   ? ">"+ref_fld+"<"
   ? ">"+&ref_fld+"<"

   ?
   if chrsaw()
      ? "Keyboard buffer is NOT empty"
   else
      ? "Keyboard buffer is empty"
   endif

*endif

        do case
           case type(ref_fld) = 'C'
?
? "Field is CHARACTER"
? "type(ref_fld) = >"+type(ref_fld)+"<"
? "ref_fld = >"+ref_fld+"<"
? "&ref_fld = >"+&ref_fld+"<"

              keyboard &ref_fld && plain

           case type(ref_fld) = 'D'
              keyboard dtoc(&ref_fld)

           case type(ref_fld) = 'N'
              keyboard ltrim(str(&ref_fld))
        endcase

*is_valid = .t.

        on key label ENTER                  && Re-assigns orginal value
     endif
  endif

if .f.
   ?
   if chrsaw()
      ? "Keyboard buffer is NOT empty."
      ? "             Buffer contains: >"
      ?? chr(inkey())
      ?? chr(inkey())
      ?? chr(inkey())
      ?? chr(inkey())
      ?? chr(inkey())
      ?? chr(inkey())
      ?? chr(inkey())
      ?? chr(inkey())
      ?? chr(inkey())
      ?? chr(inkey())
      ?? chr(inkey())
      ?? chr(inkey())
      ?? chr(inkey())
      ?? chr(inkey())
      ?? chr(inkey())
      ?? chr(inkey())
      ?? "<"
   else
      ? "Keyboard buffer is empty"
   endif
endif

   ?
   ? ">"+type(ref_fld)+"<"
   ? ">"+ref_fld+"<"
   ? ">"+&ref_fld+"<"
   ? "is_valid="
   ?? is_valid
*  suspend
*endif

  select &save_alias
  set notify off

return is_valid
*L
function var_get
  parameters getcond,fld_usg

  * Left Arrow Check
  * This function was created because Donna wanted to hit the Left Arrow Key
  * and have the cursor go to the last field of the previous screen. At this
  * it is set up for Contracts. 10/05/99 10:19 am

  if right(sys(16,2),12) = "CONTRACT.FXP"
     if page_no = 1
        if LArrow = .T.
           LArrow = .F.
           NewOnum = 28
           _curobj = NewOnum
        endif
     endif
  endif

  akl=.F.

  if right(sys(16,2),11) = "INVOICE.FXP" .and. right(sys(16,7),12) = "FS_SPELL.FXP"
    akl=.T.
     activate window spell_win
  endif

return &getcond
*L
function x_zoom
  zoom_num = str(zoom_no,1)
  at_bof = at_bof&zoom_num
  at_eof = at_eof&zoom_num
  ndx_var = ndx_var&zoom_num
  first_page = val(substr(page_seq&zoom_num,1,1))
  last_page = val(substr(page_seq&zoom_num,len(page_seq&zoom_num),1))

  * If a new page, display new screen
  if first_page <> page_no
    page_no = first_page
    do disscr
    redisp_fld = .t.
  endif

  * Select new Zoom area, set new top and bottom marks
  select &zoom_num
  record_no = recno()

  if zoom_no = 1 .or. reccount() = 0
    top_mark = 0
    bot_mark = -1
  else
    lnk_var = lnk_var&zoom_num
    seek &lnk_var
    if .not. bof()
      skip -1
    endif
    if bof()
      top_mark = 0
    else
      top_mark = recno()
    endif
    if .not. eof()
      skip
    endif
    bot_mark = -2    && to be determined in funcion _end
  endif zoom_no = 1
return ''

function y2kfix1
parameter FieldName

* Calling Syntax: valid y2kfix1(sys(18))

   MoValu = str(month(m.&FieldName),2,0)
   DyValu = str(day(m.&FieldName),2,0)
   YrValu = str(year(m.&FieldName),4,0)

   YrRHT  = right(YrValu,2)

   if val(YrRHT) >= 80 .and. val(YrRHT) <= 99
      YrLFT = "19"
   else
      YrLFT = "20"
   endif

   YrValu = YrLFT+YrRHT

   &FieldName = ctod(MoValu+"/"+DyValu+"/"+YrValu)

return .T.
*L
*******************************************************************************
*                                                                             *
* The rest of this library will be for the new scrolling field screens with   *
* the ability to <BackTab> from the first field of the current screen to the  *
* last field of the previous screen, given that the current screen is not the *
* first screen. In which the <BackTab> key is ignored. The <Tab> key has not  *
* been changed in any way. Scrolling - Multi Edit Window 10/16/95  2:07 am    *
*                          Added <BackTab> - 10/29/95  2:10 am                *
*                                                                             *
*******************************************************************************

function _newadd
  if zoom_no = 1
    go bottom
  endif
  do str_empty
  do default
  = newadd_rec()
return ''

*=============================================================================

function _newcopy
  = newadd_rec()
return ''
*L
function _newmodify
  abort = .f.

  on key label PGUP do NewPageUp
  on key label PGDN do NewPageDn

  if modify_key
    getcond = " 'G' $ fld_usg"
  else
    getcond = " 'G' $ fld_usg .and. .not. 'K' $ fld_usg"
  endif

  getcond = "'G'$fld_usg"

  if right(sys(16,3),8) = "USDA.FXP"
     do getfldA with ".t."
     do getfldB with ".t."
  else
     do getfld with ".t."
  endif

  read

  s_lastkey = lastkey()

  * CLEANUP
  on key label PGUP
  on key label PGDN

  set message to
  set stat off                      && This had to be put in because the SET
                                    && STAT OFF alone did not erase the message
  if akl_test $ 'Yy'
     set stat on
     set esca on
  endif

  if s_lastkey = 27                             && Esc
     abort = .t.
     return ''
  endif

  * Check for duplicate
  s_recno = recno()
  seek &ndx_var

  if .not. &at_eof .and. .not. allow_dup&zoom_num
     = dismsg(chr(7) + 'Duplicate record not allowed')
     abort = .t.
     return
  endif

  goto s_recno

  * Display lookup fields and computed variables
  do lookup

  do calcul with .t.
  if right(sys(16,3),8) = "USDA.FXP"
     do getfldA with ".t."
     do getfldB with ".t."
  else
     do getfld with ".t."
  endif

  clear gets

********** akl: First, check the spelling of the record 3/19/96  1:55 am
  if prog_name = "BIDS"    .or. prog_name = "CONTRACT" .or. ;
     prog_name = "INVOICE" .or. prog_name = "SUBRENT"  .or. ;
     prog_name = "MAPS"    .or. prog_name = "HELTHCRT"

        do SpellChk with "Rec"     && Record (Rec) or Field (Fld)

        if right(sys(16,3),8) = "USDA.FXP"
           do getfldA with ".f."
           do getfldB with ".f."
        else
           do getfld with ".f."
        endif
  endif
**********

  do calcul with .t.
  if .not. abort
     if confirm('Save Record')
        save_rec = .T.
        gather memvar memo
        if right(sys(16,3),12) = "CONTRACT.FXP"
           sele 2
           gather memvar
           sele 3
           gather memvar
           sele 1
        endif
     endif
  endif
return ''
*L
function NewPageDn
  s_lastkey = lastkey()

  do case
     case _curobj < 20
        _curobj = 20

     case _curobj = 20
        _curobj = 21

     case _curobj = 21
        _curobj = 22

  endcase
return

*==========================================================================

function NewPageUp
  s_lastkey = lastkey()

  do case
     case _curobj = 20
        _curobj = 1

     case _curobj = 21
        _curobj = 20

     case _curobj = 22
        _curobj = 21

  endcase
return

*L
function SpellChk
parameters CheckType
* Check spelling

* To check spelling, one field at a time, put "VALID SPELLCHK('Fld')"
*    into the "@ ... GET" statement.

  set clock off

  if CheckType = "Fld"          && This will check a field as it is exited.
     FieldToCheck = VarRead()
     FieldText    = m.&FieldToCheck

     if .not. empty(trim(FieldText))
        do fs_modal with .T., .F.
     endif
  endif

  if CheckType = "Rec"      && This will check ALL fields in a screen.
     bu_cancel = 0             && If user cancles, FS_SPELL() will set it to 1.
     field_max = FCOUNT()      && Number of fields in the current record.

     FOR field_num = 1 TO field_max        && Loop through all screen fields.
        IF TYPE(FIELD(field_num)) $ "MC"      && If memo or character field.
           fld_name = FIELD(field_num)           && Determine field's name.
           fld_2check = m.&fld_name              && Extract field's contents.

           IF len(trim(fld_2check)) > 1          && Need 2 letters to work with.
              *          ÚÄÄÄÄLeave blank since only used to pass in file names.
              *          ³       ÚÄÄÄÄPass in copy of memo to be checked.
              *          ³       ³         ÚÄÄÄÄDon't stop after each memo.
              *          v       v         v
              = FS_SPELL("", @fld_2check, .F.) && Call Foxspell Checker.
              m.&fld_name = fld_2check
           ENDIF

        ENDIF

        IF bu_cancel = 1        && If user canceled, then exit.
           WAIT WINDOW "Quit spell checking!"
           EXIT
        ENDIF
     NEXT

  endif

  s_sel = select(0)

  select WORDS1
  use
  select WORDS2
  use
  select WORDS3
  use

  select (s_sel)

  set clock on
return .T.

* EOF GENLBR.PRG

Answer : Fox9 - Having a problem getting color to work using @ ... Gets and @ ... Say

procedure sp_FinalDefCountList

requires a

SET NOCOUNT ON at the start

if @finalstring needs to sometimes be returned , then you need to set it up as an output parameter instead.

the initial trigger is very poorly written in that it doesn't cater for multiple updates...

>>SET @CaseID = (Select tblLinkDefendantCounts.CaseID from tblLinkDefendantCounts, INSERTED WHERE tblLinkDefendantCounts.DefendantCountsID = INSERTED.DefendantCountsID)
>>EXEC sp_UpdateDefCaseCounts @CaseID

needs to be processed in a loop.
Random Solutions  
 
programming4us programming4us