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

I recieved an email from someone: how can i see from server who sent it?

Digital signature control not visible

Offline address book cannot be downloaded after moving mailbox to exchange 2010

Create folder / Start Menu Programs Shortcut / Set permissions

File Upload in AJAX enabled TabContainer

cd business card

OCS 2007 R2 and Cisco call manager

Coldfusion -SQL and LIKE question

setup basic ipsec vpn for windows on cisco sa520

Microsoft System Center Ops Manager 2007 - Reporting