*-- PROGRAM.....: PROC.PRG 
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth J. Mayer, (KENMAYER on ATBBS)
*-- Date........: 07/07/1991
*-- Notes.......: This is a procedure file I have been using for awhile,
*--               modified for the dUFLP and dHUNG standards on the Ashton-
*--               Tate Bulletin Board System (ATBBS). dUFLP is the dBASE Users
*--               Function Library Project. dHUNG is the dBASE HUNGarian 
*--               notation (a modified version of the HUNGARIAN programming
*--               notation which can be found elsewhere on the ATBBS).
*--
*--               To use this procedure file in toto, the program must contain 
*--               the line in it stating:
*--                SET PROCEDURE TO PROC
*--               To use any of the individual functions and/or procedures see 
*--               the documentation for each function or procedure.
*-- Rev. History: This has gone through so many revisions, some of it being
*--               suggestions from users on ATBBS, and some in trying to set
*--               it up for dUFLP, that it's too much to go into here ... <g>
*--               Any procedures/functions here that were modified just for
*--               the dHUNG/dUFLP notations show "None" for Rev. History ...
*===============================================================================

PROCEDURE SetPrint
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Kenmayer)
*-- Date........: 05/24/1991
*-- Notes.......: Used to set the the appropriate default settings. 
*--               (Can be modified easily for other printers ...)
*--               If you want "letter quality" print on some printers,
*--               you can take the * out from the one line below. Note
*--               that some printer drivers don't have a "letter quality" mode,
*--               and dBASE will spit out an error message if you try to
*--               force it (by using _pquality). I use this routine for
*--               various systems, and only use _pquality for my dot matrix
*--               at home. Change the printer driver below to the one you
*--               are using.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do setprint
*-- Example.....: do setprint
*-- Returns.....: None
*-- Parameters..: None
*--------------------------------------------------------------------------
	_pdriver  = "HPLAS2I"  && printer driver
	_ppitch   = "PICA"     && printer pitch (10 CPI)	
	_box      = .t.		  && make sure we can print boxes/line draw
	_ploffset = 0          && page offset (left side) to 0
	_lmargin  = 0          && left margin (also set to 0)
	_rmargin  = 80         && right margin set to 80
	_plength  = 66         && page length 
	_peject   = "NONE"     && don't send extra blank pages . . .
	* _pquality = .t.        && set print quality to high -- not available
	                         && for some printers
	
RETURN   
*-- EoP: SetPrint

PROCEDURE PrintErr
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Kenmayer)
*-- Date........: 05/24/1991
*-- Notes.......: Used to display a printer error for STAND-ALONE
*--               systems. (The dBASE function PRINTSTATUS() doesn't work
*--               on a Network with Print Spoolers ...)
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: SHADOW               (procedure in proc.prg)
*-- Called by...: Any
*-- Usage.......: do printerr
*-- Example.....: do setprint  && if it hasn't been done
*--               if .not. printstatus()
*--                  DO PRINTERR
*--               endif
*--               *    or
*--               do while .not. printstatus() && my preference ... loop!
*--                  DO PRINTERR
*--               enddo
*-- Returns.....: None
*-- Parameters..: None
*--------------------------------------------------------------------------

	if iscolor()    && if we're using a color monitor, use yellow on red
		cColor = "RG+/R,RG+/R,RG+/R"
	else            && otherwise, use black on white
		cColor = "N/W,N/W,N/W"
	endif
	
	define window wPErr from  7,15 to 16,57 double color &cColor
	save screen to sPErr       && store current screen
	do shadow with 7,15,16,57	&& shadow box!
	activate window wPErr      && here we go ..
	
	cCursor=set("CURSOR")      && save cursor setting
	set cursor off             && turn cursor off
	                           && display message
	do center with 0,40,"",chr(7) + "*** PRINTER ERROR ***"
	do center with 2,40,""," The printer is not ready. Please check:"
	do center with 3,40,"","1) that the printer is ON,        "
	do center with 4,40,"","2) that the printer is ONLINE, and"
	do center with 5,40,"","3) that the printer has paper.    "
	do center with 7,40,"","Press any key to continue . . ."
	
	x=inkey(0)                 && wait for user to press a key ...
	set cursor &cCursor        && set cursor to original setting ...
	
	deactivate window wPErr    && cleanup
	release window wPErr
	restore screen from sPErr
	release screen sPErr
	
RETURN  
*-- EoP: PrintErr

PROCEDURE SetColor
*--------------------------------------------------------------------------
*-- Programmer..: Phil Steele
*-- Date........: 05/23/91
*-- Notes.......: Used to set the screen colors for a system. It
*--               checks to see if a color monitor is attached (ISCOLOR()),
*--               and sets system variables, that can be used in SET COLOR OF
*--               commands. You must define the memvars as PUBLIC, see Example
*--               below -- otherwise nothing will work.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: Borrowed from Phil Steele's PCSDEMO (a public domain
*--               program) and commented a bit more, minor modifications by
*--               Ken Mayer (Kenmayer).
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do setcolor
*-- Example.....: in a menu or setup program:
*--               PUBLIC cl_blank,cl_func,cl_help,cl_data,cl_error,;
*--                      cl_entry,cl_stand,cl_menu,cl_warn 
*--               DO setcolor
*--                  by declaring the variables PUBLIC before calling SETCOLOR
*--                  they should be globally available throughout, unless you
*--                  use a CLEAR ALL or CLOSE ALL command ...
*-- Returns.....: None
*-- Parameters..: None
*--------------------------------------------------------------------------
	
	if file("COLOR.MEM")
		restore from Color.mem additive	&& if color.mem exists, restore from it
	else                                && otherwise, create it
		lC		   = iscolor()             && remember -- foreground/background
		cl_Blank = "n/n,n/n,n"           && black on black on black ...
		cl_Func  = "n/w"                 && function keys (used in CLRSHOW)
			* if iscolor() = true, define color, otherwise black/white
		cl_Help  = iif(lC,"n/g,g/n,n"      , "w+/n,n/w,n")   && help
		cl_Data  = iif(lC,"rg+/gb,gb/rg,n" , "w+/n,n/w,n")   && data entry fields
		cl_Error = iif(lC,"rg+/r,w/n,n"    , "w/n,n/w,n")    && error messages
		cl_Entry = iif(lC,"n/w,w/n,n"      , "n/w,w/n,n")    && data entry??
		cl_Stand = iif(lC,"w+/b,b/w,n"     , "w+/n,n/w,n")   && standard screen
		cl_Menu  = iif(lC,"rg+/b,b/w,n"    , "w+/n,n/w,n")   && menus
		cl_Warn  = iif(lC,"rg+/r,w/n,n"    , "w/n,n/w,n")    && warning messages
		save to color all like cl_*		&& create COLOR.MEM
	endif
	
	*-- change current color settings to these ...
	set color to &cl_stand	&& default
	set color of fields   to rg+/gb                && yellow/cyan
	set color of messages to rg+/gb                && yellow/cyan
	set color of box      to rg+/n                 && yellow/black
	
RETURN
*-- EoP: SetColor

FUNCTION ExtrClr
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Kenmayer)
*-- Date........: 05/24/1991
*-- Notes.......: Used to extract the first parameter of the MEMVARS
*--               created from SETCOLOR above. The SET COLOR OF commands can
*--               only use the first parameter.
*--               It is recommended that you run SetColor (above) first, 
*--               although if you define your own color memvars, this will work
*--               just as well.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: extrclr(<cMemVar>)
*-- Example.....: set color of highlight to &extrclr(cl_stand)
*-- Returns.....: "W+/B"
*-- Parameters..: cMemVar = color memory variable to have colors extracted from
*--------------------------------------------------------------------------
	
	parameters cMemVar
	
RETURN substr(cMemVar,1,(at(",",cMemVar)-1)) 
*-- EoF: ExtrClr

FUNCTION InvClr
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Kenmayer)
*-- Date........: 05/23/1991
*-- Notes.......: Used to set an inverse color, using value(s) returned
*--               from extrclr above, or from a single color memvar.
*--               Inverted colors may give odd results -- RG+ (yellow) is
*--               not a background color, for example, and will appear as
*--               RG (brown) -- this may not be what you wanted ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: invclr(<cMemVar>)
*-- Example.....: set color of highlight to &invclr(extrclr(cl_stand))
*--                    or
*--               x = extrclr(cl_stand)
*--               set color of highlight to &invclr(x)
*-- Returns.....: "B/W+"
*-- Parameters..: cMemVar = color variable containing colors to be inverted
*--------------------------------------------------------------------------

	parameters cMemVar
	
		cTemp1 = substr(cMemVar,1,(at("/",cMemVar)-1))
		cTemp2 = substr(cMemVar,(at("/",cMemVar)+1),len(cMemVar))

RETURN cTemp2+"/"+cTemp1
*-- EoF: InvClr

PROCEDURE Open_Screen
*--------------------------------------------------------------------------
*-- Programmer..: Rick Price (Hammett)
*-- Date........: 05/24/1991
*-- Notes.......: Used to give a texture to the background of the screen
*--               I got this from Rick when he uploaded it as part of his 
*--               original entry to a Color Contest on the ATBBS. It is
*--               kinda nice to have that texture on the screen, keeps it
*--               from being monotonous.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do open_screen
*-- Example.....: do open_screen
*-- Returns.....: None
*-- Parameters..: None
*--------------------------------------------------------------------------

	clear
	nRow=0
	cBackdrp = chr(176)  && chr(176) = "°", chr(177) = "±", chr(178) = "²"
	do while nRow < 3
	   @nRow,0 to nRow+3,79 cBackdrp  && fill this section of the screen
	   nHoldRow = nRow
	   nRow = nRow + 6
	   @nRow,0 to nRow+3,79 cBackdrp
	   nRow = nRow + 6
	   @nRow,0 to nRow+3,79 cBackdrp
	   nRow = nRow + 6
	   @nRow,0 to nRow+3,79 cBackdrp
	   nRow = nHoldRow + 1
	enddo
	@24,0 to 24,79 cBackdrp

RETURN
*-- EoP: OpenScreen

FUNCTION Do_Wait
*--------------------------------------------------------------------------
*-- Programmer..: Rick Price (Hammett)
*-- Date........: 05/24/91
*-- Notes.......: This function can replace the WAIT command with a message
*--               in the usual Message line. This is useful for situations
*--               where the user is used to messages at row 24 on the screen,
*--               and this will handle it. It uses the default message of
*--               "Press any key to continue ...", unless you pass your own
*--               message to it. If you want the default, use nul (""), other-
*--               wise dBASE will get annoyed.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Do_Wait("<cMessage>")
*-- Example.....: lc_wait = do_wait("message")
*-- Returns.....: numeric value of key pressed by user to exit Wait (inkey())
*-- Parameters..: cMessage = Message to display at bottom of screen
*--------------------------------------------------------------------------

	parameters cMessage

	cWaitCur = set("CURSOR")	&& save status of cursor
	set cursor off
	
	** If the passed parameter (message_to_display) is null, use a generic
	** message.
	cMessage = ;
	iif(""=cMessage," Press any key to continue . . . ",cMessage)
	* center/truncate message
	nMesLen = len(cMessage)   && get length of message
	* if message length is greater than 80, truncate it to 80
	cMessage = iif(nMesLen>80,LEFT(cMessage,80),cMessage)
	nMesLen = len(cMessage)  && reset if message was longer than 80
	* center message on row 24 of screen
	@24,int((80-nMesLen)/2) say cMessage 
	* return whatever key was pressed by user, in case you need it ...
	cRetStr=chr(Inkey(0))
	set cursor &cWaitCur  && reset cursor state to what it was before ...

RETURN cRetStr 
*-- EoF: Do_Wait

PROCEDURE JazClear
*--------------------------------------------------------------------------
*-- Programmer..: Rick Price (Hammett)
*-- Date........: 05/24/1991
*-- Notes.......: Used to clear the screen from the middle out --
*--               could be used with OpenScreen, above. I got this
*--               from Rick at the same time I got the other two routines
*--               above ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do jazclear
*-- Examples....: do jazclear
*-- Returns.....: None
*-- Parameters..: None
*--------------------------------------------------------------------------

	nWinR1 = 0	 && row 1
	nWinR2 = 24  && row 2
	nWinC1 = 0   && column 1
	nWinC2 = 79  && column 2
	nStep = 1    && amount to increment by
	  * set starting point
	mnWinC1 = int((nWinC2-nWinC1)/2)+nWinC1
	mnWinC2 = mnWinC1+1
	mnWinR1 = int((nWinR2-nWinR1)/2)+nWinR1
	mnWinR2 = mnWinR1+1
	
	** Adjust step offset values: nColOff & nRowOff
	** Vertical steps: nWinR1-nWinR1
	nTmpAdjR = int((nWinR2 - nWinR1)/2)
	nTmpAdjC = int((nWinC2 - nWinC1)/2)
	
	nAdjRow = ;
	iif(nTmpAdjC > nTmpAdjR, nTmpAdjR/nTmpAdjC,1) * nStep
	
	nAdjCol = ;
	iif(nTmpAdjR > nTmpAdjC, nTmpAdjC/nTmpAdjR,1) * nStep
	
	ncolleft = nWinC1
	ncolrite = nWinC2
	nRowTop = nWinR1
	nRowBot = nWinR2
	nWinC1 = mnWinC1
	nWinC2 = mnWinC2
	nWinR1 = mnWinR1
	nWinR2 = mnWinR2
	do while (nWinC1#nColLeft .or. nWinC2#nColRite .or. ;
		nWinR1 # nRowTop .or. nWinR2 # nRowBot)
		
		* Adjust coordinates for the clear (moving out from the middle)
		nWinR1 = ;
		nWinR1-iif(nRowTop<nWinR1-nAdjRow,nAdjRow,nWinR1-nRowTop)
		nWinR2 = ;
		nWinR2+iif(nRowBot>nWinR2+nAdjRow,nAdjRow,nRowBot-nWinR2)
		nWinC1 = ;
		nWinC1-iif(nColLeft<nWinC1-nAdjCol,nAdjCol,nWinC1-nColLeft)
		nWinC2 = ;
		nWinC2+iif(nColRite>nWinC2+nAdjCol,nAdjCol,nColRite-nWinC2)
		
		* Perform the clear
		@nWinR1,nWinC1 clear to nWinR2,nWinC2
		@nWinR1,nWinC1 to nWinR2,nWinC2
	enddo
	clear
	
RETURN   
*-- EoP: JazClear

PROCEDURE Center
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/24/1991
*-- Notes.......: Centers text on the screen with @says
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: This and all other procedures/functions listed in this
*--               file attributed to Miriam Liskin came from "Liskin's
*--               Programming dBASE IV Book". Very good, worth the money.
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do center with <nLine>,<nWidth>,"<cColor>","<cText>"
*-- Example.....: do center with 5,65,"RG+/GB","WARNING! This will blow up!"
*--                  Note that the color field may be blank: ""
*-- Returns.....: None
*-- Parameters..: nLine  = Line or Row for @/Say
*--               nWidth = Width of screen
*--               cColor = Colors to be used ("Forg/Back") (may be nul "", in
*--                           order to use the default colors of window/screen)
*--               cText  = Message to center on screen
*--------------------------------------------------------------------------
	
	parameters nLine,nWidth,cColor,cText
	
	nCol = (nWidth - len(cText)) /2
	@nLine,nCol say cText color &cColor.
	
RETURN
*-- EoP: Center

FUNCTION Center2
*--------------------------------------------------------------------------
*-- Programmer..: Jeff Riedl (Student)
*-- Date........: 05/24/1991
*-- Notes.......: centers text, only two parameters and is a function.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: center2(<nWidth>,"<cText>")
*-- Example.....: @row,center2(80,"Center this text") say "Center this text"
*--                  or
*--               @row,center2(80,"&MemVar") say MemVar
*-- Returns.....: centered text
*-- Parameters..: nWidth = Width of screen
*--               cText  = Text to be centered
*--------------------------------------------------------------------------

	parameters nWidth,cText
	
RETURN (nWidth - len(cText)) / 2
*-- EoF: Center2

FUNCTION Surround
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/24/1991
*-- Notes.......: Displays a message surrounded by a box anywhere on 
*--               the screen
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/19/1991 - Modified by Ken Mayer (Kenmayer) to a function
*--                from original procedure
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: surround(<nLine>,<nColumn>,"<cColor>","<cText>")
*-- Example.....: lc_Dummy = surround(5,12,"RG+/GB",;
*--                          "Processing ... Do not Touch!")
*-- Returns.....: Nul/""
*-- Parameters..: nLine   = Line to display "surrounded" message at
*--               nColumn = Column for same (X,Y coordinates for @SAY)
*--               cColor  = Color variable/colors
*--               cText   = Text to be displayed inside box
*--------------------------------------------------------------------------
	
	parameters nLine,nColumn,cColor,cText
	
	cText = " " + trim(cText) + " "	         && add spaces around text
	@nLine-1,nColumn-1 to nLine+1,nColumn+len(cText) double;
		color &cColor.                           && draw box
	@nLine,nColumn say cText color &cColor.  && disp. text
	
RETURN "" 
*-- EoF: Surround

FUNCTION Message1
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/24/1991
*-- Notes.......: Displays a message, centered at whatever line you give,
*--               pauses until user presses a key.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/19/1991 Modified by Ken Mayer (Kenmayer) from Miriam's 
*--                procedure to function
*-- Calls.......: CENTER               (procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: message1(<nLine>,<nWidth>,"<cColor>","<cText>")
*-- Example.....: lc_Dummy = Message1(5,12,"RG+/GB","All Done.")
*-- Returns.....: numeric value of key pressed by user (cUser)
*-- Parameters..: nLine  = Line to display message
*--               nWidth = Width of screen
*--               cColor = Colors for display
*--               cText  = Text to be displayed.
*--------------------------------------------------------------------------

	parameters nLine,nWidth,cColor,cText
	
	@nLine,0
	cCursor = set("CURSOR")  && store current state of CURSOR
	set cursor off           && turn it off
	do center with nLine,nWidth,cColor,cText
	wait "" to cUser
	set cursor &cCursor      && set cursor to original state
	@nLine,0                 && erase line ...

RETURN cUser
*-- EoF: Message1

FUNCTION Message2
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/23/1991
*-- Notes.......: Displays a message in a window, pauses for user to 
*--               press key
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/19/1991 - Modified by Ken Mayer (Kenmayer) to a function
*--               04/29/1991 - Modified by Ken Mayer (Kenmayer) to add shadow
*-- Calls.......: SHADOW               (procedure in PROC.PRG)
*--               CENTER               (procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: message2("<cText>","<cColor>")
*-- Example.....: lc_Dummy = message2("Finished Processing!",;
*--                   "RG+/GB,,RG+/GB")
*-- Returns.....: numeric value of key pressed by user (cUser)
*-- Parameters..: cText  = Text to be displayed in window
*--               cColor = Colors for window
*--------------------------------------------------------------------------

	parameters cText,cColor
	
	cCursor = set("CURSOR")
	set cursor off
	save screen to sMessage
	define window wMessage from 10,10 to 14,70 double color &cColor.
	do shadow with 10,10,14,70
	activate window wMessage
	
	do center with 1,60,"",cText
	wait "" to cUser
	
	set cursor &cCursor
	deactivate window wMessage
	release window wMessage
	restore screen from sMessage
	release screen sMessage

RETURN cUser
*-- EoF: Message2

FUNCTION Message3
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/23/1991
*-- Notes.......: Displays a message in a window, pauses for user, 
*--               will wrap a long message inside the window.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/19/1991 - Modified by Ken Mayer (Kenmayer) to a function
*--               04/29/1991 - Modified to Ken Mayer (Kenmayer) add shadow
*-- Calls.......: SHADOW               (procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: Message3("<cText>","<cColor>")
*-- Example.....: lc_Dummy = Message3("This is a long message that will be"+;
*--                 "wrapped around inside the window.","rg+/gb,,rg+/gb")
*-- Returns.....: numeric value of key used to exit window (cUser)
*-- Parameters..: cText  = Text to be displayed
*--               cColor = Colors for window
*--------------------------------------------------------------------------

	parameters cText,cColor
	
	nLines = int(len(cText) / 38) + 5	&& set # of lines for window
	
	cCursor = set("CURSOR")
	set cursor off
	save screen to sMessage
	define window wMessage from 8,20 to 8+nLines,60 double color &cColor.
	do shadow with 8,20,8+nLines,60
	activate window wMessage
	
	nLmargin   = _lmargin
	nRmargin   = _rmargin
	cAlignment = _alignment
	lWrap      = _wrap
	
	_lmargin   = 1 
	_rmargin   = 38
	_alignment = "CENTER"
	_wrap      = .t.
	
	?cText
	?
	wait "    Press any key to continue . . ." to cUser
	
	_lmargin   = nLmargin
	_rmargin   = nRmargin
	_alignment = cAlignment
	_wrap      = lWrap
	
	set cursor &cCursor
	deactivate window wMessage
	release window wMessage
	restore screen from sMessage
	release screen sMessage

RETURN cUser
*-- EoF: Message3

FUNCTION Message4
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/23/1991
*-- Notes.......: Displays a 2-line message in a predefined window 
*--                 and pauses
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/19/1991 - Modified by Ken Mayer (Kenmayer) to a function
*--               04/29/1991 - Modified to Ken Mayer (Kenmayer) add shadow
*-- Calls.......: SHADOW               (procedure in PROC.PRG)
*--               CENTER               (procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: message4("<cText1>","<cText2>","<cColor>")
*-- Example.....: lc_Dummy = message4("Finished processing.","There are ";
*--                 +ltrim(str(reccount()))+" Records in this file.",;
*--                 "rg+/rg,rg+/rg,rg+/rg")
*-- Returns.....: numeric value of key pressed by user to exit window (cUser)
*-- Parameters..: cText1 = First line of message
*--               cText2 = Second line of message
*--               cColor = Colors for window
*--------------------------------------------------------------------------

	parameters cText1,cText2,cColor
	
	cCursor = set("CURSOR")
	set cursor off
	save screen to sMessage
	define window wMonitor from 10,10 to 17,70 double color &cColor.
	do shadow with 10,10,17,70
	activate window wMonitor
	
	nLmargin = _lmargin
	nRmargin = _rmargin
	lWrap =    _wrap

	_lmargin = 1 
	_rmargin = 58
	_wrap    = .t.
	
	do center with 1,58,"",cText1
	do center with 2,58,"",cText2
	do center with 4,58,"","Press any key to continue . . ."
	wait "" to cUser

	_lmargin = nLmargin
	_rmargin = nRmargin
	_wrap    = lWrap
	
	set cursor &cCursor
	deactivate window wMonitor
	release window wMonitor
	restore screen from sMessage
	release screen sMessage
	
RETURN cUser
*-- EoF: Message4

PROCEDURE Monitor
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/23/1991
*-- Notes.......: Displays a status message to monitor a long-running 
*--                 operation that operates on multiple records . . . 
*--                 Should be used with MONITOROFF (below) to cleanup.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/29/1991 - Modified by Ken Mayer (Kenmayer) to add shadow
*-- Calls.......: SHADOW               (procedure in PROC.PRG)
*--               CENTER               (procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: do monitor with "<cText>","<cColor>"
*-- Example.....: do monitor with "Processing REPORT.DBF","rg+/gb,rg+/gb,rg+/gb"
*--               ln_recnum = 0
*--               do while  && (or SCAN)
*--                  stuff -- process records
*--                  ln_recnum = ln_recnum + 1
*--                  @4,30 display ltrim(str(ln_recnum)) && current record
*--                                                      && in window MONITOR
*--               enddo  && (or endscan)
*--               do monitoroff  && procedure to clean-up after this one
*-- Returns.....: None
*-- Parameters..: cText  = Text to display
*--               cColor = Colors for window
*--------------------------------------------------------------------------

	parameters cText,cColor
	
	save screen to sMonitor
	define window wMonitor From 10,10 to 18,70 double color &cColor.
	do shadow with 10,10,18,70
	activate window wMonitor
	
	do center with 1,60,"",cText
	do center with 2,60,"","Please do not interrupt"
	@4,10 say "Working on record          of " + ltrim(str(reccount(),5))
	
RETURN
*-- EoP: Monitor

PROCEDURE MonitorOff
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Kenmayer)
*-- Date........: 05/23/1991
*-- Notes.......: Used to deal with ending routines for MONITOR
*--                 procedure above.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Routine using MONITOR  (procedure in PROC.PRG)
*-- Usage.......: do monitoroff
*-- Example.....: do monitoroff
*-- Returns.....: None
*-- Parameters..: None
*--------------------------------------------------------------------------

	deactivate window wMonitor
	release window wMonitor
	restore screen from sMonitor
	release screen sMonitor
	
RETURN
*-- EoP: MonitorOff

FUNCTION ScrnHead
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/23/1991
*-- Notes.......: Displays a heading on the screen in a box 2 
*--               spaces wider than the text, with a custom border (double 
*--               line top, single the rest)
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 4/29/1991 - Modified by Ken Mayer (Kenmayer) to add shadow
*-- Calls.......: SHADOW               (procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: scrnhead("<cColor>","<cText>")
*-- Examples....: lc_Dummy = ScrnHead("rg+/gb","Print Financial Report")
*-- Returns.....: nul/""
*-- Parameters..: cColor = Colors to display box/text in
*--               cText  = text to be displayed.
*--------------------------------------------------------------------------

	parameters cColor,cText
	
	cText = " "+trim(cText)+" "              && ad spaces to left and right
	cTextstart = (80-len(trim(cText)))/2
	do shadow with 1,cTextstart-1,3,81-cTextstart
	@1,cTextstart-1 to 3,81-cTextstart 205,196,179,179,213,184,192,217;
		color &cColor.	                      && display box
	@2, cTextstart say cText color &cColor. && display text

RETURN ""
*-- EoF: ScrnHead

FUNCTION YesNo
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/23/1991
*-- Notes.......: Asks a yes/no question in a dialog window/box
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function
*--               04/29/1991 - Modified to Ken Mayer add shadow
*--               05/13/1991 - Modified to Ken Mayer remove need for extra 
*--                            procedures (YES/NO) that were used for returning
*--                            values from Menu
*--                            (suggested by Clinton L. Warren (VBCES on ATBBS))
*-- Calls.......: SHADOW               (procedure in PROC.PRG)
*--               CENTER               (procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: yesno(<lAnswer>,"<cMess1>","<cMess2>","<cMess3>","<cColor>")
*-- Example.....: if YesNo(.t.,"Do You Really Wish To Delete?",;
*--                            "This will destroy the data";
*--                             "in this record.";
*--                             "rg+/gb,n/w,rg+/gb")
*--                  delete
*--               else
*--                  skip
*--               endif
*--
*--                 The middle set of colors should be different, as they
*--                 will be the colors of the YES/NO selections ...
*--                 Options may be blank by using nul values ("")
*-- Returns.....: .t./.f. depending on user's choice from menu
*-- Parameters..: lAnswer = default value (Yes or No) for menu
*--               cMess1  =  First line of Message
*--               cMess2  =  Second line of message
*--               cMess3  =  Third line of message
*--               cColor  =  Colors for window/menu/box
*--------------------------------------------------------------------------

	parameter lAnswer,cMess1,cMess2,cMess3,cColor
	
	save screen to sYesno
	define window wYesno from 8,20 to 15,60 double color &cColor.
	
	define menu mYesno
	define pad pYes of mYesno Prompt "[Yes]" at 5,10
	define pad pNo  of mYesno Prompt "[No]"  at 5,25
	on selection pad pYes of mYesno deactivate menu
	on selection pad pNo  of mYesno deactivate menu
	
	do shadow with 8,20,15,60
	activate window wYesno
	nLmargin = _lmargin	&& store system values
	nRmargin = _rmargin
	lWrap    = _wrap
	_lmargin   = 2			&& set local values
	_rmargin   = 38
	_wrap      = .t.
	
	do center with 0,38,"",cMess1		&& center the text
	do center with 2,38,"",cMess2
	do center with 3,38,"",cMess3
	if lAnswer
		activate menu mYesno pad pYes
	else
		activate menu mYesno pad pNo
	endif
	
	_lmargin = nLmargin	&& reset system values
	_rmargin = nRmargin
	_wrap    = lWrap
	
	deactivate window wYesno
	release window wYesno
	restore screen from sYesno
	release screen sYesno
	release menu mYesno

RETURN iif(pad()="PYES",.t.,.f.)
*-- EoF: YesNo

FUNCTION ErrorMsg
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Kenmayer)
*-- Date........: 05/23/1991
*-- Notes.......: Display an error message in a Window: 
*--                           ** ERROR [#] **
*--
*--                              Message 1
*--                              Message 2
*--                       Press any key to continue ...
*--
*--                 colors should be VIVID, since it's an error message.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: SHADOW               (procedure in PROC.PRG)
*--               CENTER               (procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: ErrorMsg("<cErr>","<cMess1>","<cMess2>","<cColor>")
*-- Example.....: lc_Dummy = errormsg("3","This record","already exists!",;
*--                   "rg+/r,rg+/r,rg+/r")
*--               where "errornum" is an error number or nul,
*--               message2 and 3 should be 36 characters or less ...
*--               Colors should include foreground/background,;
*--                 foreground/background,foreground/background
*-- Returns.....: numeric value of keystroke user presses (cUser)
*-- Parameters..: cErr   = Error # (can be blank, but use "" for blank)
*--               cMess1 = Error message line 1
*--               cMess2 = Error message line 2
*--               cColor = Colors for text/window/border
*--------------------------------------------------------------------------
	
	parameters cErr,cMess1,cMess2,cColor
	
	save screen to sErr
	define window wErr from 8,20 to 15,60 double color &cColor.
	do shadow with 8,20,15,60
	activate window wErr
	
	cCursor = set("CURSOR")
	set cursor off
	if len(trim(cErr)) > 0  && if there's an error number ...
		do center with 0,38,"","** ERROR "+alltrim(cErr)+" **"
	else                      && otherwise, don't display errornumber
		do center with 0,38,"","** ERROR **"
	endif
	do center with 2,38,"",cMess1
	do center with 3,38,"",cMess2
	do center with 5,38,"","Press any key to continue ..."
	cUser=inkey(0)
	set cursor &cCursor
	
	deactivate window wErr
	release window wErr
	restore screen from sErr
	release screen sErr
	
RETURN cUser
*-- EoF: ErrorMsg

FUNCTION DateText
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/23/1991
*-- Notes.......: Display date in format Month, day year (e.g., July 1,1991)
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: DateText(<dDate>) 
*-- Example.....: ? datetext(date())
*-- Returns.....: July 1, 1991
*-- Parameters..: dDate = date to be converted
*--------------------------------------------------------------------------

	parameters dDate
	
RETURN CMONTH(dDate)+" "+ltrim(str(day(dDate),2))+", "+;
       str(year(dDate),4)
*-- EoF: DateText

FUNCTION DateText2
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/23/1991
*-- Notes.......: Display date in format day-of-week, Month day, year
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: DateText2(<dDate>)
*-- Example.....: ? DateText2(date())
*-- Returns.....: Thursday, July 1, 1991
*-- Parameters..: dDate = date to be converted
*--------------------------------------------------------------------------

	parameters dDate
	
RETURN CDOW(dDate)+", "+cmonth(dDate)+" "+;
       ltrim(str(day(dDate),2))+", "+str(year(dDate),4)
*-- EoF: DateText2

FUNCTION IsUnique
*--------------------------------------------------------------------------
*-- Programmer..: Clinton L. Warren (VBCES)
*-- Date........: 07/23/1991
*-- Notes.......: Checks to see if an index key already exists in the current
*--               selected database. This function was inspired by Tom
*--               Woodward's Chk4Dup UDF.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: May 15, 1991 Version 1.1  Added check for zero record database
*--               May  7, 1991 Version 1.0  Initial 'release'.
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: IsUnique(<xValue>,<cOrder>)
*-- Example.....: @x,y SAY "SSN: " GET SSN PICTURE "999-99-9999";
*--                  valid required IsUnique(SSN, SSN);
*--                  message "Enter a new SSN";
*--                  error chr(7)+"SSN must be unique!"
*-- Returns.....: .T./.F.
*-- Parameters..: xValue = Value (any non-memo type) to check for uniqueness
*--               cOrder = MDX Tag used to order the database. Must be set for
*--                        field being checked.
*--------------------------------------------------------------------------
	
	parameters xValue, cOrder
	
	nRecNo = recno()           && store current record number
	nRecCnt = reccount()       && count records in database
	
	if nRecCnt = 0             && empty database, cValue MUST be unique
	   return .t.
	endif
	
	cSetNear = set('NEAR')     && store status of NEAR flag
	set near off               && set it off
	c_SetDel = set('DELETE')   && store status of DELETE
	set delete on              && Delete must be ON for this to work
	lIsDeleted = deleted()     && is current record deleted?
	delete                     && set delete flag for current record
	cSetOrder = order()        && store current MDX tag
	set order to (cOrder)      && set tag to that sent to function
	
	if seek(xValue)            && does it exist already?
	   lIsUnique = .f.         &&   if so, it's not unique
	else                       && otherwise,
	   lIsUnique = .t.         &&   it is.
	endif
   
   set order to (cSetOrder)   && restore changed settings to original settings
   set delete &cSetDel
   set near &cSetNear
   
   if nRecNo > nRecCnt        && if called during an append
      go bottom               && goto the bottom of the database,
      skip 1                  &&   plus one record (the new one)
   else
      go nRecNo               && otherwise, goto the current record number
   endif

   if .not. lIsDeleted        && was record 'deleted' before?
      recall                  && if not, undelete it ... (turn flag off)
   endif 

RETURN (lIsUnique)
*-- EoF: IsUnique

FUNCTION Proper
*------------------------------------------------------------------------------
*-- Programmer..: Clinton L. Warren (VBCES/CLW)
*-- Date........: 07/10/1991
*-- Notes.......: Returns cBaseStr converted to proper case.  Converts
*--             : "Mc", "Mac", and "'s" as special cases.  Inspired by
*--             : A-T's CCB Proper function.  cBaseStr isn't modified.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 07/10/1991 1.0 - Original version (VBCES/CLW)
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Proper(<cArg>)
*-- Example.....: Proper("mcdonald's") returns "McDonald's"
*-- Returns.....: Propertized string (e.g. "Test String")
*-- Parameters..: cArg = String to be propertized
*------------------------------------------------------------------------------

	PARAMETERS cBaseStr

	private nPos, cDeli, cWrkStr

	cWrkStr = lower(cBaseStr) + ' '             && space necessary for 's process

	nPos = at('mc', cWrkStr)                    && "Mc" handling
	do while nPos # 0
   	cWrkStr = stuff(cWrkStr, nPos, 3, upper(substr(cWrkStr, nPos, 1)) ;
                        + lower(substr(cWrkStr, nPos + 1, 1)) ;
                                    + upper(substr(cWrkStr, nPos + 2, 1)))
    	nPos = at('mc', cWrkStr)
  	enddo

	nPos = at('mac', cWrkStr)                    && "Mac" handling
	do while nPos # 0
   	cWrkStr = stuff(cWrkStr, nPos, 4, upper(substr(cWrkStr, nPos, 1)) ;
                                + lower(substr(cWrkStr, nPos + 1, 2)) ;
                                + upper(substr(cWrkStr, nPos + 3, 1)))
		nPos = at('mac', cWrkStr)
	enddo

	cWrkStr = stuff(cWrkStr, 1, 1, upper(substr(cWrkStr, 1, 1)))
	nPos = 2
	cDeli = [ -.'"\/`]                           && standard delimiters

	do while nPos <= len(cWrkStr)                && 'routine' processing
		if substr(cWrkStr,nPos-1,1) $ cDeli
      	cWrkStr = stuff(cWrkStr, nPos, 1, upper(substr(cWrkStr,nPos,1)))
		endif
		nPos = nPos + 1
	enddo

	nPos = at("'S ", cWrkStr)                    && 's processing
	do while nPos # 0
		cWrkStr = stuff(cWrkStr, nPos, 2, lower(substr(cWrkStr, nPos, 2)))
		nPos = at('mac', cWrkStr)
	enddo

RETURN (cWrkStr)
*-- EoF: Proper()

FUNCTION AllTrim
*--------------------------------------------------------------------------
*-- Programmer..: Phil Steele (from PCSDEMO.PRG -- Public Domain)
*-- Date........: 5/23/1991
*-- Notes.......: Complete trims edges of field (left and right)
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: alltrim(<cString>)
*-- Example.....: ? alltrim("  Test String  ") 
*-- Returns.....: Trimmed string, i.e.:"Test String"
*-- Parameters..: cString = string to be trimmed
*--------------------------------------------------------------------------
	
	parameters cString
	
RETURN ltrim(rtrim(cString))
*-- EoF: AllTrim

PROCEDURE Shadow
*--------------------------------------------------------------------------
*-- Programmer..: Ashton-Tate
*-- Date........: 5/23/1991
*-- Notes.......: Creates a shadow for a window (taken from the dBASE IV
*--               picklist functions)
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do shadow with <nULRow>,<nULCol>,<nBRRow>,<nBRCol>
*-- Example.....: save screen to sc_Main
*--               define window w_Error from 5,15 to 15,65 double color;
*--                    rg+/r,rg+/r,rg+/r
*--               do shadow with 5,15,15,65
*--               activate window W_Error
*--                && perform actions in window
*--               deactivate window W_Error
*--               release window W_Error
*--               restore screen from sc_Main
*--               release screen sc_Main
*-- Returns.....: None
*-- Parameters..: nULRow = Upper Left Row position
*--               nULCol = Upper Left Column position (x,y)
*--               nBRRow = Bottom Right Row position
*--               nBRCol = Bottom Right Column position (x2,y2)
*--------------------------------------------------------------------------

	parameters nULRow,nULCol,nBRRow,nBRCOL

	nTempRow = nBRRow+1
	nTempCol = nBRCol+2
	nIncRow = 1
	nIncCol = (nBRCol-nULCol) / (nBRRow-nULRow)
	do while nTempRow <> nULRow .or. nTempCol <> nULCol+2
		@ nTempRow,nTempCol fill to nBRRow+1,nBRCol+2 color n+/n
		nTempRow = iif(nTempRow<>nULRow,nTempRow - nIncRow,nTempRow)
		nTempCol = iif(nTempCol<>nULCol+2,nTempCol - nIncCol,nTempCol)
		nTempCol = iif(nTempCol<nULCol+2,nULCol+2,nTempCol)
	enddo
	
RETURN
*-- EoP: Shadow

PROCEDURE FullWin
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Kenmayer)
*-- Date........: 05/23/91
*-- Notes.......: Overlays menus or another screen with a full window,
*--               so that processing is done in the window, and one can return
*--               directly to the menus, without redrawing screen and such.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do fullwin with <cColor>,<cWinName>,<cScreen>
*-- Example.....: do fullwin with "w+/b","w_Edit","sc_Main"
*--                * perform whatever actions are needed in the window
*--               deactivate window w_Edit
*--               release window w_Edit
*--               restore screen from sc_Main
*--               release screen sc_Main
*-- Returns.....: None
*-- Parameters..: cColor   = Colors for window
*--               cWinName = Name of window
*--               cScreen  = Name of screen
*--------------------------------------------------------------------------
	
	parameters cColor,cWinName,sScreen
	
	define window &cWinName from 0,0 to 23,79 none color &cColor.
	save screen to &sScreen.
	activate window &cWinName.
	
RETURN  
*-- EoP: FullWin

FUNCTION DosRun
*--------------------------------------------------------------------------
*-- Programmer..: Michael P. Dean (Ashton-Tate)
*-- Date........: 05/23/1991
*-- Notes.......: A routine to run a DOS program, checks to see if a
*--               window is active -- if so, it avoids the inevitable
*--               "Press any key to continue" and the subsequent messing
*--               up of the screen display.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: Pulled from A-T BBS 
*--               05/13/1991 - modified by Ken Mayer (Kenmayer) to use the DBASE
*--                 RUN() function, rather than the ! or RUN commands,
*--                 which allows the return of DOS exit codes ... (suggested
*--                 by Clinton L. Warren (VBCES).)
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: DosRun(<cCmd>)
*-- Example.....: lc_dummy = dosrun("DIR /W /P")
*--                 * or
*--               lc_dummy = dosrun(memvar)  && where memvar contains dos
*--                                          && command and parameters ...
*-- Returns.....: NUMERIC value of the DOS exit code (nRun)
*-- Parameters..: cCmd = Command (and parameters) to be executed
*--------------------------------------------------------------------------

	parameter cCmd
	
	wWindow = window()              && grab window name of current window
	if len(trim(wWindow)) > 0       && if there's a window,
		deactivate window &wWindow   && deactivate it
	endif
	set console off                  && don't display to screen
	nRun = run("&cCmd")              && place DOS exit code in NRUN
	set console on                   && ok, display to screen
	if len(trim(wWindow)) > 0        && if there's a window,
		activate window &wWindow      && reactivate it
	endif
	
RETURN nRun
*-- EoF: DosRun

*-------------------------------------------------------------------------------
*-- The next four functions are used for FRPGs (Fantasy Role-Playing Games)
*-------------------------------------------------------------------------------

FUNCTION Dice
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Kenmayer)
*-- Date........: 05/23/1991
*-- Notes.......: A small function used to determine a random number from
*--               1 to x. Used for gaming purposes.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any/MultDice()       (Function in PROC.PRG)
*-- Usage.......: Dice(<nSides>)
*-- Example.....: ln_val = Dice(4)
*-- Returns.....: Random # between 1 and <nSides>
*-- Parameters..: nSides = # of sides of die to be cast ... (RPG dice
*--                        include 4, 6 (standard), 8, 10, 12, 20, 100 ...
*--------------------------------------------------------------------------

	parameters nSides
	nSeed = (val(substr(time(),1,2))+val(substr(time(),4,2))+;
	         val(substr(time(),7,2))) * val(substr(time(),7,2))

RETURN int(rand(nSeed) * nSides) + 1
*-- EoF: Dice

FUNCTION MultDice
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Kenmayer)
*-- Date........: 06/12/1991
*-- Notes.......: Function like above, used to determine a random #,
*--               but for multiple dice, of x# of sides.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: Originally this called DICE for each iteration, but it
*--                turned out that calling that routine more than once
*--                was resetting the randomizer seed to a similar or same
*--                value, and we got (quite often) the exact same number
*--                for each iteration. SO, now this routine calls DICE once,
*--                which sets the seed, and if we want more than one die,
*--                we loop and call RAND without a new seed. It works.
*-- Calls.......: DICE()               (Function in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: MultDice(<nNum>,<nSides>)
*-- Example.....: ln_val = MultDice(3,6)
*-- Returns.....: Random value of 1 to x (x being number of sides), 
*--                for each iteration (nNum), totalled. For example,
*--                value returned would be the total of 3 six-sided die
*--                rolled, the number would be anywhere from 3 to 18.
*-- Parameters..: nNum   = Number of dice to be "rolled"
*--               nSides = # of sides to the dice (see Dice() above)
*--------------------------------------------------------------------------

	parameters nNum,nSides
	
	nTotal = dice(nSides)                  && call DICE and set RAND seed
	nCount = 1                             && set counter
	do while nCount < nNum                 && loop for number of dice 
		nNewval = int(rand() * nSides) + 1  && get new random value
		nTotal = nTotal + nNewval           && add to total
		nCount = nCount + 1                 && increment counter
	enddo
	
RETURN nTotal
*-- EoF: MultDice

FUNCTION ValiDice
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (KenMayer)
*-- Date........: 07/09/1991
*-- Notes.......: Used to ask user for input of a number within a range
*--               based on gaming dice. Programmer supplies # of dice,
*--               and number of sides to function, it returns the input
*--               from the user (and only allows valid input).
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: SHADOW               (procedure in PROC.PRG)
*--               CENTER               (procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: ValiDice(<nNum>,<nDice>,"<cMessage>","<cColor>")
*-- Example.....: replace STRENGTH with ValiDice(3,6,"Strength",;
*--                                       "rg+/gb,w/n,rg+/gb")  && 3 6-sided
*-- Returns.....: Valid user input
*-- Parameters..: nNum     = Number of dice
*--               nSides   = Number of sides
*--               cMessage = Message for line 0
*--               cColor   = Colors for window
*--------------------------------------------------------------------------

	PARAMETERS nNum, nDice, cMessage, cColor
	
	save screen to sDice
	define window wDice from 8,20 to 14,60 double color &cColor
	do shadow with 8,20,14,60
	activate window wDice
	
	nUpper = nNum * nDice    && upper limit
	do center with 0,40,"","&cMessage"
	do center with 1,40,"","Enter a value from "+ltrim(str(nNum))+" to "+;
	                        ltrim(str(nUpper))
	do center with 2,40,"","("+ltrim(str(nNum))+"d"+ltrim(str(nDice))+")"
	nUser = 0
	@4,18 get nUser picture "999" valid required nUser => nNum .and.;
	                                             nUser =< nUpper;
	                         error chr(7)+"Enter a valid number!"
	read 

	deactivate window wDice
	release window wDice
	restore screen from sDice
	release screen sDice
	
RETURN nUser
*-- EoF: ValiDice

FUNCTION DiceChoose
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer
*-- Date........: 07/09/1991
*-- Notes.......: This is another FRPG routine -- It is used to give the
*--               user a choice of three die roles. The computer will
*--               randomly generate a die roll three times so the user
*--               has a choice. It uses DICE (above) to do so.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: MULTDICE()           (Function in PROC.PRG)
*--               DICE()               (Function in PROC.PRG)
*--               SHADOW               (Procedure in PROC.PRG)
*--               CENTER               (Procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: DiceChoose(<nNum>,<nSides>,"<nMessage>","<cColor>")
*-- Example.....: replace STRENGTH with DiceChoose(3,6,;
*--                                 "To determine your character's Strength",;
*--                                 "rg+/gb,w/n,rg+/gb")
*-- Returns.....: The value of one of the choices displayed for the user,
*--               which will be a value from nNum to nNum*nSides + nNum+nPlus.
*-- Parameters..: nNum     = number of dice to be rolled
*--               nSides   = number of sides for each dice
*--               cMessage = Message to be displayed at line 0 (max 40 Char)
*--               cColor   = Colors for the window
*--------------------------------------------------------------------------

	PARAMETERS nNum, nSides, cMessage, cColor
	
	*-- here we determine the three values for the user (roll the dice) --
	*-- The problem with using MULTDICE function above for all three values, is
	*-- that it calls DICE each time, which resets the random number table, 
	*-- and will give the exact same value for each of the three below. 
	*-- By copying the logic from MultDice() for the second two values, 
	*-- we only call DICE once, the values should all be random, instead of 
	*-- the same values (from the same random # table).
	
	*-- value 1 -- use MultDice above for this one
	nVal1 = MultDice(nNum,nSides)          && call MULTDICE and set RAND # Table
	
	*-- value 2 -- DON'T use MultDice, but use the same logic ...
	nVal2 = 0                              && init nVal2
	nCount = 0                             && set counter
	do while nCount < nNum                 && loop for number of dice 
		nNewVal = int(rand() * nSides) + 1  && get new random value
		nVal2 = nVal2 + nNewval             && add to total
		nCount = nCount + 1                 && increment counter
	enddo
	
	*-- value 3 -- same as value 2
	nVal3 = 0                              && init nVal3
	nCount = 0                             && set counter
	do while nCount < nNum                 && loop for number of dice 
		nNewVal = int(rand() * nSides) + 1  && get new random value
		nVal3 = nVal3 + nNewval             && add to total
		nCount = nCount + 1                 && increment counter
	enddo
	
	*-- now we have the three values we need, define windows/menu ...
	define window wDice from 8,20 to 17,60 double color &cColor
	save screen to sDice
	define menu mDice                      && as it says, define the menu
	define pad  pChoice1 of mDice prompt ltrim(str(nVal1)) at 3,18
	define pad  pChoice2 of mDice prompt ltrim(str(nVal2)) at 4,18
	define pad  pChoice3 of mDice prompt ltrim(str(nVal3)) at 5,18
	on selection pad pChoice1 of mDice deactivate menu
	on selection pad pChoice2 of mDice deactivate menu
	on selection pad pChoice3 of mDice deactivate menu
	
	*-- activate it all for user ...
	do shadow with 8,20,17,60              && display shadow
	activate window wDice                  && startup the window
	*-- display info in Window
	do center with 0,40,"","&cMessage"
	do center with 1,40,"","Choose a value from below:"
	@3,15 say "1)"
	@4,15 say "2)"
	@5,15 say "3)"
	do center with 7,40,"","Use Arrow keys, <Enter> to choose"
	activate menu mDice                    && startup menu
	
	do case                                && determine value to be returned
		case pad() = "PCHOICE1"
			nUser = nVal1
		case pad() = "PCHOICE2"
			nUser = nVal2
		case pad() = "PCHOICE3"
			nUser = nVal3
	endcase
	
	*-- cleanup
	release menu mDice
	deactivate window wDice
	release window wDice
	restore screen from sDice
	release screen sDice
	
RETURN nUser
*-- EoF: DiceChoose

*--------------------------------------------------------------------------
*-- These next two are ones I created for the SCA (Society for Creative
*-- Anachronism) -- they deal with SCA dates, which start at May 1, 1966.
*-- One goes from SCA dates to Real dates (i.e., 05/01/66 versus May 1, AS I)
*-- and the other goes back to SCA dates from real dates ...
*--------------------------------------------------------------------------

PROCEDURE SCA_Real
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Hirsch von Henford)
*-- Date........: 07/23/1991
*-- Notes.......: This procedure was designed to handle data entered into
*--               the Order of Precedence of the Principality of the Mists.
*--               The problem is, my usual sources of data give only SCA
*--               dates, and in order to sort properly, I need real dates.
*--               This procedure will handle it, and goes hand-in-hand with
*--               the function Real_SCA, to translate real dates to SCA
*--               dates ... This procedure assumes that you have set the
*--               F1 Key (see Example below). If you use a different F key,
*--               you will want to modify the ON KEY LABEL commands ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 07/29/1991  -- modified it to stuff a character directly into
*--                    a date field (was having to do a CTOD in the program),
*--                    and added use of ESC to escape out, instead of killing
*--                    the procedure and the program calling it ...
*-- Calls.......: Center               (Procedure in PROC.PRG)
*--               Shadow               (Procedure in PROC.PRG)
*--               Arabic()             (Function in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: do SCA_Real
*-- Example.....: on key label f1 do sca_real
*--               store {} to t_date   && initialize as a date
*--                                    && or you could STORE datefield to t_date
*--                                    && if you have a date field ...
*--               clear
*--               @5,10 say "Enter a date:" get t_date;
*--                  message "Press <F1> to convert from SCA date to real date"
*--               read
*--               on key label f1  && clear out that command ...
*-- Returns.....: real date, forced into field ...
*-- Parameters..: None
*--------------------------------------------------------------------------
	cEscape = set("ESCAPE")
	set escape off            && so we can handle the Escape Key
	cExact = set("EXACT")
	set exact on              && VERY important ...
	on key label F1 ?? chr(7) && make it beep, rather than call this procedure 
	                          && again, which causes wierdnesses ...
	*-- first let's popup a window to ask for the information ...
	
	save screen to sDate
	define window wDate from 8,20 to 15,60 color rg+/gb,n/g,rg+/gb
	do shadow with 8,20,15,60
	activate window wDate
	
	*-- set the memvars ...
	cYear  = space(8)
	cMonth = space(3)
	cDay   = space(2)
	
	do center with 0,40,"","Enter SCA Date below:"
	do while .t.
		
		@2,14 say "Month: " get cMonth ;
			picture "@M JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC";
			message "Enter first letter of month, <Space> to scroll through, "+;
				"<Enter> to choose" color rg+/gb,n/g
		@3,14 say "  Day: " get cDay picture "99";
			message "Enter 2 digits for day of the month, if blank will assume 15";
				color rg+/gb,n/g
		@4,14 say " Year: " get cYear picture "!!!!!!!!" ;
			message "Enter year in AS roman numeral format";
			valid required len(trim(cYear)) > 0;
			error chr(7)+"This is no good without a year ..." color rg+/gb,n/g
	
		read
	
		if lastkey() = 27                && if user wants out by pressing <Esc>
			deactivate window wDate
			release window wDate
			restore screen from sDate
			release screen sDate
			set escape &cEscape
			set exact &cExact
			on key label F1 do SCA_Real   && reset it ...
			return
		endif
		
		if lastkey() < 0   && function key F1 through Shift F9 was pressed
			?? chr(7)       && beep at user
			loop            && don't let 'em get away with that -- try again
		endif
		
		*-- check for valid roman numerals
		cYear = trim(cYear)    && trim it
		nYearLen = len(cYear)  && get length
		nCount = 0            
		do while nCount < nYearLen  && loop through length of year
			nCount = nCount + 1      && increment
			if .not. substr(cYear,nCount,1) $ "IVXLC" && if it's not here
				do center with 5,40,"rg+/r","** ERROR -- Invalid Year **"
				lError = .t.          && set error flag
				exit                  && exit internal loop
			else
				lError = .f.          && make sure this is false
			endif
		enddo     && end of internal loop
		if lError && if error,
			loop   && go back ...
		endif
		
		@5,0 clear   && clear out any error message ...
		do center with 5,40,"rg+/r","Converting Date ..."
		
		*-- First (and most important) is conversion of the year
		nYear = Arabic(cYear)
		
		*-- AS Years start at May ... if the month for a specific year is
		*-- Jan through April it's part of the next "real" year ...
		if cMonth = "JAN" .or. cMonth = "FEB" .or. cMonth = "MAR" .or.;
									   cMonth = "APR"
			nYear = nYear + 1
		endif
		
		nYear = nYear + 65  && SCA dates start at 66 ...
		if nYear > 99       && this thing doesn't handle turn of the century
			@5,0 clear
			do center with 5,40,"rg+/r","No dates past XXXIV, please"
			loop
		endif
		
		*-- set numeric value of month ...
		do case
			case cMonth = "JAN"
				nMonth = 1
			case cMonth = "FEB"
				nMonth = 2
			case cMonth = "MAR"
				nMonth = 3
			case cMonth = "APR"
				nMonth = 4
			case cMonth = "MAY"
				nMonth = 5
			case cMonth = "JUN"
				nMonth = 6
			case cMonth = "JUL"
				nMonth = 7
			case cMonth = "AUG"
				nMonth = 8
			case cMonth = "SEP"
				nMonth = 9
			case cMonth = "OCT"
				nMonth = 10
			case cMonth = "NOV"
				nMonth = 11
			case cMonth = "DEC"
				nMonth = 12
		endcase
		
		*-- if the day field is empty, assume the middle of the month, so we
		*-- have SOMETHING to go by ...
		if len(alltrim(cDay)) = 0
			nDay = 15
		else
			nDay = val(cDay)
		endif
		
		*-- Check for valid day of the month ...
		if nDay > 29 .and. nMonth = 2 .or. (nDay = 31 .and. (nMonth = 4 .or.;
								 nMonth = 6 .or. nMonth = 9 .or. nMonth = 11))
			do center with 5,40,"rg+/r",chr(7)+"INVALID DATE -- Try again ..."
			loop
		endif
		
		exit                        && out of loop -- if here, we're done
		
	enddo                          && end of loop

	*-- Convert it
	cDate = transform(nMonth,"@L 99")+transform(nDay,"@L 99")+;
			  transform(nYear,"@L 99")
	
	*-- force this 'character' date into the date field on the screen ...
	keyboard cDate clear           && put it into the field, and clear out
	                               && keyboard buffer first ...

	*-- deal with cleanup ...
	deac wind wDate
	release wind wDate
	restore screen from sDate
	release screen sDate
	set escape &cEscape
	set exact &cExact
	on key label F1 do SCA_Real  && reset for user
	
RETURN
*-- EoP: SCA_Real

FUNCTION Real_SCA
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Hirsch von Henford)
*-- Date........: 07/23/1991
*-- Notes.......: This procedure was designed to handle data entered into
*--               the Order of Precedence of the Principality of the Mists.
*--               For the purpose of printing the Order of Precedence, it 
*--               is necessary to convert real dates to SCA dates. I needed
*--               to store the data as real dates, but I want it to print with
*--               SCA dates ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: Roman()              (Function in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: Real_SCA(<dDate>)
*-- Example.....: @nLine,25 say Real_SCA(CA)  && print SCA date for Corolla 
*--                                           &&   Aulica
*-- Returns.....: SCA Date based on dDate
*-- Parameters..: dDate = date to be converted
*--------------------------------------------------------------------------

	PARAMETERS dDate   && a real date, to be converted to an SCA date ...
	
	nYear  = year(dDate) - 1900        && remove the century
	nMonth = month(dDate)
	cMonth = substr(cmonth(dDate),1,3) && grab only first three characters
	cDay   = ltrim(str(day(dDate)))    && convert day to character
	
	*-- First (and most important) is conversion of the year
	*-- this is set to the turn of the century ... (AS XXXV)
	*-- AS Years start at May ... if the month for a specific year is
	*-- Jan through April it's part of the previous SCA year 
	*-- (April '67 = April AS I, not II)
	 
	if nMonth < 5
		nYear = nYear - 1
	endif
	
	nYear = nYear - 65   && SCA dates start at 66
	cYear = Roman(nYear)

RETURN cMonth+" "+cDay+", "+"AS "+cYear
*-- EoF: Real_SCA

FUNCTION Roman
*-------------------------------------------------------------------------------
*-- Programmer..: Nick Carlin
*-- Date........: 04/13/1988
*-- Notes.......: A function designed to return a Roman Numeral based on
*--               an Arabic Numeral input ...
*-- Written for.: dBASE III+
*-- Rev. History: 07/25/1991 -- Modified by Ken Mayer for 1) dBASE IV, 1.1,
*--                             2) updated to a function, and 3) the procedure
*--                             GetRoman was done away with (combined into the
*--                             function).
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Roman(<nArabic>)
*-- Example.....: ? Roman(32)
*-- Returns.....: Roman Numeral (character string) equivalent of Arabic numeral
*--               passed to it. In example:  XXXII
*-- Parameters..: nArabic = Arabic number to be converted to Roman
*-------------------------------------------------------------------------------

	parameters nArabic
	private nCounter,nValue
	
	cRoman = ""                 && this is the returned value
	nCounter = 0                && init counter
	do while nCounter < 4       && loop four times, once for thousands, once
	                            && four hundreds, tens and singles ...
		nCounter = nCounter + 1  && increment counter
		do case                  && determine roman numerals to use
			case nCounter = 1     && first time through the loop
				nDiv   = 1000      && divide by 1000
				cSmall = "M"       && smallest value 
				cMid   = "W"       && next up ...
				cBig   = "Y"       && largest passed with this ... 10,000s
			case nCounter = 2
				nDiv   = 100
				cSmall = "C"
				cMid   = "D"
				cBig   = "M"
			case nCounter = 3
				nDiv   = 10
				cSmall = "X"
				cMid   = "L"
				cBig   = "C"
			case nCounter = 4
				nDiv   = 1
				cSmall = "I"
				cMid   = "V"
				cBig   = "X"
		endcase
		nValue = mod(int(nArabic/nDiv),10)
		do case
			case nValue = 0
				                && do nothing
			case nValue = 1
				cRoman = cRoman + cSmall                           && 1 = I
			case nValue = 2
				cRoman = cRoman + cSmall + cSmall                  && 2 = II
			case nValue = 3
				cRoman = cRoman + cSmall + cSmall + cSmall         && 3 = III
			case nValue = 4
				cRoman = cRoman + cSmall + cMid                    && 4 = IV
			case nValue = 5
				cRoman = cRoman + cMid                             && 5 = V
			case nValue = 6
				cRoman = cRoman + cMid + cSmall                    && 6 = VI
			case nValue = 7
				cRoman = cRoman + cMid + cSmall + cSmall           && 7 = VII
			case nValue = 8
				cRoman = cRoman + cMid + cSmall + cSmall + cSmall  && 8 = VIII
			case nValue = 9
				cRoman = cRoman + cSmall + cBig                    && 9 = IX
		endcase
		
	enddo  && while nCounter < 4
	
RETURN cRoman
*-- EoF: Roman()

FUNCTION Arabic
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer
*-- Date........: 07/25/1991
*-- Notes.......: This function converts a Roman Numeral to an arabic one.
*--               It parses the roman numeral into an array, and checks each 
*--               character ... if the previous character causes the value to 
*--               subtract (for example, IX = 9, not 10) we subtract that value, 
*--               and then set the previous value to 0, otherwise we would get 
*--               some odd values in return.
*--               So far, it works fine.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: ver. 1 07/25/1991
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Arabic(<cRoman>)
*-- Example.....: ?Arabic("XXIV")
*-- Returns.....: Arabic number (from example, 24)
*-- Parameters..: cRoman = character string containing roman numeral to be
*--               converted.
*-------------------------------------------------------------------------------

	parameters cRoman
	private nCounter
	
	cRoman = upper(cRoman)   && convert to all caps in case ...
	
	declare cChar[15],nNum[15] && hopefully no string will be sent that large ...
	
	nMax = 0                && counter for later on ..
	nCounter = 0            && parse cRoman into the array, one character per
	do while nCounter < 15  &&  array element ...
		nCounter = nCounter + 1
		if len(trim(substr(cRoman,nCounter,1))) > 0  && if something's there
			cChar[nCounter] = substr(cRoman,nCounter,1)
			nMax = nMax + 1   && set max times through NEXT loop
		else
			exit
		endif
	enddo
	
	*-- Now that it's in an array ... we need to look at it ... and convert
	*-- each character to an arabic number 
	nCounter = 0
	do while nCounter < nMax
		nCounter = nCounter + 1
		do case
			case cChar[nCounter] = "I"    && 1
				nNum[nCounter] = 1
			case cChar[nCounter] = "V"    && 5
				if nCounter > 1 .and. cChar[nCounter - 1] = "I"
					nNum[nCounter] = 4      && IV = 4
					nNum[nCounter - 1] = 0  && don't add anything later ...
				else
					nNum[nCounter] = 5      && otherwise we have 5
				endif
			case cChar[nCounter] = "X"    && 10
				if nCounter > 1 .and. cChar[nCounter - 1] = "I"
					nNum[nCounter] = 9      && IX = 9
					nNum[nCounter - 1] = 0  && same ... don't add this ...
				else
					nNum[nCounter] = 10     && X = 10
				endif
			case cChar[nCounter] = "L"    && 50
				if nCounter > 1 .and. cChar[nCounter - 1] = "X"
					nNum[nCounter] = 40     && XL = 40
					nNum[nCounter - 1] = 0
				else
					nNum[nCounter] = 50     && L = 50
				endif
			case cChar[nCounter] = "C"    && 100
				if nCounter > 1 .and. cChar[nCounter -1] = "X"
					nNum[nCounter] = 90     && XC = 90
					nNum[nCounter - 1] = 0
				else
					nNum[nCounter] = 100
				endif
			case cChar[nCounter] = "D"    && 500
				if nCounter > 1 .and. cChar[nCounter - 1] = "C"
					nNum[nCounter] = 400    && CD = 400
					nNum[nCounter - 1] = 0
				else
					nNum[nCounter] = 500
				endif
			case cChar[nCounter] = "M"    && 1,000
				if nCounter > 1 .and. cChar[nCounter - 1] = "C"
					nNum[nCounter] = 900    && CM = 900
					nNum[nCounter - 1] = 0
				else
					nNum[nCounter] = 1000
				endif
			case cChar[nCounter] = "W"    && 5,000
				if nCounter > 1 .and. cChar[nCounter - 1] = "M"
					nNum[nCounter] = 4000   && MW = 4000
					nNum[nCounter - 1] = 0
				else
					nNum[nCounter] = 5000
				endif
			case cChar[nCounter] = "Y"    && 10,000
				if nCounter > 1 .and. cChar[nCounter - 1] = "M"
					nNum[nCounter] = 9000   && MY = 9000
					nNum[nCounter - 1] = 0
				else
					nNum[nCounter] = 10000
				endif
			&& that's plenty big ...
		endcase
	enddo

	*-- Add it all together ... it SHOULD give us the proper arabic value
	nArabic = 0
	nCounter = 0
	do while nCounter < nMax
		nCounter = nCounter + 1
		nArabic = nArabic + nNum[nCounter]
	enddo
	
RETURN nArabic
*-- EoF: Arabic()

*-------------------------------------------------------------------------------
*-- End of Procedure File -- PROC.PRG
*-------------------------------------------------------------------------------