'FUNCTION DEFINITIONS  Last change 7/19/96

' ********************************************************************************
' Project file: APPLIBHU.PF3
' ********************************************************************************

' Contents
'	1) Graphics Browser Class (Used in Sales Graphical Database
'	2) Font Chooser (User in Sales Graphical Database & Employee Pictures)
'	3) Database loading routine used in example batch update
'	4) Popup Calander [Chr version, graphical version in Low Use Lib]


' ********************************************************************************


EXTERNAL $$fct  '<---- RAD variable
GLOBAL WEEKDAY(1), CALKEYS() ' Calander functions


public mcal() 'Calander Function
public automenu() 'Automaticly pops up data file menu
public working() 'Function that returns "WORKING" screen with Message
public flag()  'Function that returns "FLAG" with message from $$FCT

' Public Functions
  public GrBrInit() '(AP_gbr,#x1,#y1,#x2,#y2,#fg,#bg,#item_height,$draw_fct)
	            ' Initialize the graphic browse routines
  public GrBrEvent() '(AP_gbr,#key)
		     ' Handle events relevant to graphic display.

' ********************************************************************************
' Private functions & data for Graphic Browser
' AP_browser[10]	' 1 = item height
'			' 2 = x1
'			' 3 = y1
'			' 4 = x2
'			' 5 = y2
'			' 6 = fg
'			' 7 = bg
'			' 8 = item_draw fucntion name

global blank_area()
global calcxy()
global draw_screen()

' Constants (Array index values for code readability)
global	GBR_HEIGHT 	' Height of one unit
global	GBR_X1		' Coordinates
global	GBR_Y1
global	GBR_X2
global	GBR_Y2
global	GBR_FG		' Colors
global	GBR_BG
global	GBR_FCT		' Draw item function
global	GBR_CURREC	' Current record
global	GBR_CURPOS	' Current position on screen
global	GBR_MAXPOS	' Number of positions on screen
global	GBR_SORECS	' Start of Record Numbers (held at end of array)



' Graphic Browser Class

' ********************************************************************************
' Private functions & data for Graphic Browser
' AP_browser[10]	' 1 = item height
'			' 2 = x1
'			' 3 = y1
'			' 4 = x2
'			' 5 = y2
'			' 6 = fg
'			' 7 = bg
'			' 8 = item_draw fucntion name


main
	"@(#)applibhu.pf3	3.3 - 95/01/23" '	SID
end main

' GrBrInit - GRaphical BRowser INIT
'
' Initializes the graphics browser
'
' Parameters:
'	AP_gbr - A pointer to an single dimensional array
'	#x1,#y1,#x2,#y2 - Area to be used
'	#fg,#bg - Colors
'	#item_height - Height in Pixels of one item
'	$draw_fct - Name of public function (at client) to draw one item with params:
'				(current, #x1, #y1, #x2, #y2)
'				(if current=true must draw as current record (highlight)
'				(#x/#y - area to draw item in)
' **********************************************************************
function GrBrInit(AP_gbr,#x1,#y1,#x2,#y2,#fg,#bg,#item_height,$draw_fct)
' **********************************************************************
local #ct #slots #start #currec

	#slots = int((#y2-#y1)/#item_height)	' # of items that fit on screen
'	arrayresize(AP_gbr,20+#slots)		' Resize array
	GBR_HEIGHT = 1				' Set constants
	GBR_X1 = 2
	GBR_Y1 = 3
	GBR_X2 = 4
	GBR_Y2 = 5
	GBR_FG = 6
	GBR_BG = 7
	GBR_FCT = 8
	GBR_CURREC = 9
	GBR_CURPOS = 10
	GBR_MAXPOS = 11
	GBR_SORECS = 12 			' Start of records
						' Fill Array
	writeptr(AP_gbr,GBR_HEIGHT,#item_height)
	writeptr(AP_gbr,GBR_X1,#x1)
	writeptr(AP_gbr,GBR_Y1,#y1)
	writeptr(AP_gbr,GBR_X2,#x2)
	writeptr(AP_gbr,GBR_Y2,#y2)
	writeptr(AP_gbr,GBR_FG,#fg)
	writeptr(AP_gbr,GBR_BG,#bg)
	writeptr(AP_gbr,GBR_FCT,$draw_fct)
	writeptr(AP_gbr,GBR_CURREC,record)
	writeptr(AP_gbr,GBR_CURPOS,1)
	writeptr(AP_gbr,GBR_MAXPOS,#slots)
	for #ct = 1 to #slots
		writeptr(AP_gbr,GBR_SORECS+#ct,0)
	end for
	#currec = record			' Initial paint
	if records<=#slots
		data goto record first
		#start = record
	else
		#start = #currec
	end if
	draw_screen(AP_gbr,#start,#currec)
end function

' GrBrEvent - GRaphical BRowser Event
'
' Handles events that affect the display
'
' Parameters
'	AP_gbr - Array pointer to GrBr data
'	#key - Event Id (keystroke) to process
'
' Returns
'	0 - have not processed event
'	1 - processed event
'
' **********************************************************************
function GrBrEvent(AP_gbr,#key)
' **********************************************************************
local #currec #curpos $fct #maxpos
local #x1 #y1 #x2 #y2
local #check #ct #match

	$fct = readptr(AP_gbr,GBR_FCT)		' Read info from AP
	#currec = readptr(AP_gbr,GBR_CURREC)
	#curpos = readptr(AP_gbr,GBR_CURPOS)
	#maxpos = readptr(AP_gbr,GBR_MAXPOS)
	if #currec<>record
		data goto record record-number #currec
	end if
	calcxy(AP_gbr,#curpos,varptr(#x1),varptr(#y1),varptr(#x2),varptr(#y2))
			' Calc XY position of current item

	' Branch on events
	if #key={F6} or #key = {Down} ' NEXT RECORD
		call($fct,0,#x1, #y1, #x2, #y2) ' Blank current
		data goto record next
		if record>records ' END OF FILE
			data goto record record-number #currec
			call($fct,1,#x1, #y1, #x2, #y2) ' Rehighlight
		else
			if #curpos<#maxpos ' No scroll
				#curpos = #curpos + 1
				calcxy(AP_gbr,#curpos,varptr(#x1),varptr(#y1),varptr(#x2),varptr(#y2))
				call($fct,1,#x1, #y1, #x2, #y2) ' Highlight
			else ' Scroll (Redraw all - Lazy!)
				draw_screen(AP_gbr,readptr(AP_gbr,GBR_SORECS+2),record)
			end if
		end if
	elseif #key = {F5} or #key = {Up} ' PREVIOUS RECORD
		call($fct,0,#x1, #y1, #x2, #y2) ' Blank current
		#check = record
		data goto record previous
		if record=#check ' START OF FILE
			call($fct,1,#x1, #y1, #x2, #y2) 'Rehighlight
		else
			if #curpos>1
				#curpos = #curpos - 1
				calcxy(AP_gbr,#curpos,varptr(#x1),varptr(#y1),varptr(#x2),varptr(#y2))
				call($fct,1,#x1, #y1, #x2, #y2) ' Blank current
			else
				draw_screen(AP_gbr,record,record)
			end if
		end if
	elseif #key = {Home} ' TOP OF SCREEN
		call($fct,0,#x1, #y1, #x2, #y2) ' Blank current
		#curpos = 1
		calcxy(AP_gbr,#curpos,varptr(#x1),varptr(#y1),varptr(#x2),varptr(#y2))
		call($fct,1,#x1, #y1, #x2, #y2) ' Draw new pos
	elseif #key = {End} ' END OF SCREEN
		call($fct,0,#x1, #y1, #x2, #y2) ' Blank current
		for #ct = #maxpos to 1 step -1 ' Last spot with a record
			if readptr(AP_gbr,GBR_SORECS+#ct)>1
				#curpos=#ct
				calcxy(AP_gbr,#curpos,varptr(#x1),varptr(#y1),varptr(#x2),varptr(#y2))
				call($fct,1,#x1, #y1, #x2, #y2) ' Draw new pos
				exit for
			end if
		end for
	elseif #key={PgUp}
		for #ct = 1 to #maxpos
			data goto record previous
		end for
		draw_screen(AP_gbr,record,record)
		#curpos = 1
	elseif #key = {PgDn}
		for #ct = 1 to #maxpos
			data goto record next
		end for
		if record>records
			data goto record last
		end if
		draw_screen(AP_gbr,readptr(AP_gbr,GBR_SORECS+1),record)
		#curpos = min(#maxpos,records)
	elseif #key = {^Home} ' START OF FILE
		#curpos = 1
		data goto record first
		draw_screen(AP_gbr,record,record)
	elseif #key = {^End} ' END OF FILE
		#curpos = #maxpos
		data goto record last
		#check = record
		for #ct = 1 to #maxpos - 1
			data goto record previous
		end for
		draw_screen(AP_gbr,record,#check)
	elseif #key = {LeftUp} ' MOUSE
		call($fct,0,#x1, #y1, #x2, #y2) ' Blank current
		#match = 0
		for #ct = 1 to #maxpos ' CHECK EACH POSITION
			calcxy(AP_gbr,#ct,varptr(#x1),varptr(#y1),varptr(#x2),varptr(#y2))
			if eventinfo(m_x)>=#x1 and \
			   eventinfo(m_x)<=#x2 and \
			   eventinfo(m_y)>=#y1 and \
			   eventinfo(m_y)<#y2
				#check = readptr(AP_gbr,GBR_SORECS+#ct)
				if #check
					data goto record record-number #check
					#curpos = #ct
					call($fct,1,#x1, #y1, #x2, #y2) ' Blank current
					#match = 1
				end if
				exit for
			end if
		end for
		if not(#match)
			return 0
		end if
	else
		return 0 ' AN IRRELEVANT EVENT
	end if
	writeptr(AP_gbr,GBR_CURREC,record)	' UPDATE AP
	writeptr(AP_gbr,GBR_CURPOS,#curpos)
	return 1 ' Return status that indicates event handled
end function

' CALCXY
'
' Calculates XY positions of passed position.  Fills variables passed as pointers
'
' **********************************************************************
function calcxy(AP_gbr,#pos,VP_x1,VP_y1,VP_x2,VP_Y2)
' **********************************************************************
local #y1
	if #pos = -1
		return
	end if
	writeptr(VP_x1,readptr(AP_gbr,GBR_X1) + 4)
	writeptr(VP_x2,readptr(AP_gbr,GBR_X2) - 4)
	#y1 = readptr(AP_gbr,GBR_Y1) + 4 + (readptr(AP_gbr,GBR_HEIGHT)-1)*(#pos-1)
	writeptr(VP_y1,#y1)
	writeptr(VP_y2,#y1+readptr(AP_gbr,GBR_HEIGHT)-1)
end function

' Draw whole graphics browse area
' **********************************************************************
function draw_screen(AP_gbr,#top_rec,#cur_rec)
' **********************************************************************
local #x1 #y1 #x2 #y2
local #ct #end

	data goto record record-number #top_rec
	blank_area(AP_gbr)
	for #ct = 1 to readptr(AP_gbr,GBR_MAXPOS) ' LOOP FOR EACH POSITION
		calcxy(AP_gbr,#ct,varptr(#x1),varptr(#y1),varptr(#x2),varptr(#y2))
		if #end
			writeptr(AP_gbr,GBR_SORECS+#ct,0)
		else
			call(	readptr(AP_gbr,GBR_FCT),\
				record=#cur_rec, #x1, #y1, #x2, #y2)
			if record = #cur_rec
				writeptr(AP_gbr,GBR_CURPOS,#ct)
			end if
			writeptr(AP_gbr,GBR_SORECS+#ct,record)
			data goto record next
			if record>records
				#end = 1
			end if
		end if
	end for
	data goto record record-number #cur_rec
end function

' B;ank
' **********************************************************************
function blank_area(AP_gbr)
' **********************************************************************
	graphics set foreground readptr(AP_gbr,GBR_FG)
	graphics set fill-type fill_solid
	graphics fill rectangle \
		readptr(AP_gbr,GBR_X1) \
		readptr(AP_gbr,GBR_Y1) \
		readptr(AP_gbr,GBR_X2) \
		readptr(AP_gbr,GBR_Y2)
end function

' ********************************************************************************
' END OF GRAPHIC BROWSER CLASS
' ********************************************************************************



' ********************************************************************************
' Font Chooser
'
' Picks a font of a specified size, takes into account cross platform
' considerations
' ********************************************************************************

public choose_font()

' Select a Font (works on X11/WIndows/DOS)
' ************************************************************
function choose_font(#points)
' ************************************************************
local #ct $typeface #font

	if #points<10 ' Try use "Small Fonts"
		if sysvar($_os)<=2 or sysvar($_os)=5 ' Windows
			$typeface = "Small Fonts"
		else ' X11
			$typeface = "fixed"
		end if
		error off
		clearerror
		#font = gr_fontopen($typeface,#points,0)
		graphics set text-font #font
		error on
		if #font>0 and lerror=0
			return gr_textheight
		end if
	end if
	#ct = 0
	while true
		#ct = #ct + 1
		if sysvar($_os)<=2 or sysvar($_os)=5 ' Windows
			$typeface = case #ct \
					(1,"Arial") \
					(2,"MS Serif") \
					(3,"Courier") \
					(4,"Roman") \
					(5,"SFF-Standard") \
					else ""
		else
			$typeface = case #ct \
					(1,"times") \
					(2,"helvetica") \
					(3,"courier") \
					(4,"fixed") \
					else ""
		end if
		if $typeface = ""
			exit while
		end if
		error off
		clearerror
		#font = gr_fontopen($typeface,#points,0)
		graphics set text-font #font
		error on
		if #font>0 and lerror=0
			exit while
		else
			#font = 0
		end if
	end while
	if #font<=0
		graphics set text-font font_serif_medium
		graphics set text-height #points*72 / gr_ydpi
			' 1 point = 1/72 of an inch
	end if
	return gr_textheight
end function

' ********************************************************************************
' End of Font Chooser
' ********************************************************************************


' ********************************************************************************
' File loading routines
'	-Great for loading files in processing routines
'	-Makes it easy to write programs that don't care if a view is loaded
'	 or not
' ********************************************************************************

public load_file_using()

global mess()

external XS()			' For build time translation
external check_path()		' Fixes \ or / on dir name
external display_message()
external error_push()		' Sets error on/off
external error_pop()		' Restores error on/off
external file_load()		' Central File loading function
external get_path()		' Looks up a path
external get_choice()		' Asks user to select an item
external substr1()		' Substitute string (translation)
external substr2()		' Substitute two strings (translation)

'****************************************************************************
' This function will load a file according to a variety of options.
' Requires: View to Load
'           Type - 'vw' or 'vws'
'           Path to get file from
'           Load in Current Window? If not, then activate
'           Exclusive? - Must load in current window
'           Retries allowed - Time interval increases with each retry
'               - A retry of 0 will become interactive to load the file or
'                   ask if the user wants to abort the load.
'           File handle of Error Report - 0 = Screen
'           Indent factor for Message
' Uses:
' Returns:  "error"           - Unable to load
'           "loaded"          - Loaded by this function
'           "already loaded"  - File previously loaded
'****************************************************************************
function load_file_using($path,$view,$type,#cur_win,#exclusive,#retries,#handle,#indent)
 local #loop
 local $key
 local $return

	if $type<>"vw" and $type<>"vws"
		mess(#indent,"System Error.  Invalid view type indicator."&"{"|$type|"}",#handle)
		return "error"
	end if

	if " "|lower(currfiles(1))|" "!" "|lower($view|"."|$type)|" "
		if #cur_win
			data goto view $view|"."|$type
		end if
		return "already loaded"
	end if

	if $path=""
		clearerror
		error_push(0)
		$path=get_path($view)
		error_pop()
		if lerror>0
			clearerror
			mess(#indent,substr1("Path is blank. Could not locate %s in dv_info.",$view),#handle)
			return "error"
		end if
	elseif left($path,1)="?"
		clearerror
		error_push(0)
		$path=get_path(mid($path,2))
		error_pop()
		if lerror>0
			clearerror
			mess(#indent,substr2("Path is %s1. Could not locate %s1 in dv_info.",$path,mid($path,2)),#handle)
			return "error"
		end if
	end if

	$path   = check_path($path)
	$return = "error"

	while true

		clearerror

		if not(#cur_win) and #exclusive
			mess(#indent,"System Error. Exlcusive files Must Be placed in the current window.",#handle)
			return "error"
		end if
		file_load($type,$path|$view,#exclusive,#cur_win)
		if lerror
			mess(#indent,substr2("Error (%s1) occured loading %s2.",errortext(lerror),$view),#handle)
		else
			$return = "loaded"
		end if

		if $return = "loaded"
			exit while
		end if

		if #handle > 0
			mess(#indent,substr2("AutoRetry Load on %s1 at %s2",$path|$view,adate(now)|" - "|time),#handle)
		end if

		#loop = #loop + 1

		if #retries = 0                          'User Decides
			while true
				$key = get_choice(\
					substr2("%s1 occured during load of %s2.",errortext(lerror),$path|$view|"."|$type),\
						"Retry or Abort load?","","",\
						"Retry"&"Abort",4)
				if $key = 2
					return "error"
				elseif $key = 1
					exit while
				end if
			end while
		elseif #loop <= #retries
			display_message(substr2("Load of %s1, Attempt # %s2",$view|"."|$type,str(#loop)),"Press a key to end wait.",14)
			wait 60 * #loop
			display_message("","",14)
		else
			exit while
		end if

	end while

	clearerror
	return $return

end function


' ************************************************************
function mess(#indent,$mess,#hnd)
' ************************************************************
	if #hnd = 0
		display_message($mess,"Press a key...",4)
	else
		fwrite #hnd from repeat(" ",#indent)|$mess
	end if
end function

' ************************************************************
' End of loading functions
' ************************************************************




'JD BUSINESS SOLUTIONS INC.
'DALE WEBER
'935 PLUM STREET
'LINCOLN, NE 68502
'402 475 2262
'the field calling this function from the database should have the calculation
'"if dbinfo(db_recalc) <> true then mcal([<field name>]) else nochange"
'this will return the date selected by mcal() and place it in the field
'the db_recalc prevents the function from being called again when you exit
'the entry/update mode.
'==========================================================================
'ELECTRONIC CALENDAR - A POP UP CALENDAR FOR USE WITH CUSTOME VIEWS AND PROJECTS
'
' ARGUMENTS:        R2,C1 = THE UPPER LEFT CORNER OF THE CALENDAR
'                   FG,BG = FORGROUND AND BACKGROUND COLORS
'
'OPERATION:  INEVENT IS USED TO PROCESSKEYS, THE CURENTLY SELECTED DAY
'            IS HIGHLIGHTED. LEFT MOUSE TO CHANGE DAYS

' VALID KEYS:
'    LEFT ARROW     PREVIOUS DAY
'    RIGHT ARROW    NEXT DAY
'    UP ARROW       PREVIOUS WEEK
'    DOWN ARROW     NEXT WEEK
'    PGUP           PREVIOUS MONTH
'    PGDN           NEXT MONTH
'    HOME           1ST DAY OF MONTH
'    END            LAST DAY OF MONTH
'    ^PGUP          PREVIOUS YEAR
'    ^PGDN          NEXT YEAR
'    ^LEFT ARROW    1ST DAY OF THE WEEK
'    ^RIGHT ARROW   LAST DAY OF THE WEEK
'    ESC            RETURNS NULL
'    F1             DISPLAY KEYS (HELP)
'
'CREDIT TO LAWRENCE SOBILO
'3L DEVELOPMENT CORP
'628 SOUTH STREET
'MUNSTER, IN 46321
'SMART TIMES AUGUST 1991
'==========================================================================
'calendar working variables
public electronicalendar()
public R1, C1, FG, BG $PP
public R2, C2 CALSCR, KEYPRESS, CURROW, OLDDAY, DISPDAY, DISPMONTH, DISPYEAR, CURRMONTH
public CURRYEAR, N, DISPDATE, NEXTMONTH, NUMDAYS, DAYOFWEEK, DISPMNAME
public DAYSMON[31,2] movecal() makebutton() displaycal()
public rvalue 'return value passed to mcal()
function mcal()
QUIET ON
f1help off
'LET R1 = scrheight-20
LET R1 = scrheight-22 'Moved Cal up 2 lines due to scroll bar on contacts view
LET C1 = scrwidth/2-12

rvalue = " "
electronicalendar()
button finished
repaint
f1help  on
case rvalue
   when "nochange"
	return nochange
   when "blank"
        return blank
   when "date"
        RETURN date(STR(DISPMONTH)|"/"|STR(DISPDAY)|"/"|STR(DISPYEAR))
  otherwise
        beep 4
        message "An internal error has occured in the mcal() function - press Any Key "
end case

end function


'==========================================================================
function electronicalendar()

'SET CALENDAR CORRDINATES, THEY MUST FIT ON SCREEN.
'R1 = @IF(R1+10<=SCRHEIGHT,R1,SCRHEIGHT-10)
R1 = @IF(R1+8<=SCRHEIGHT,R1,SCRHEIGHT-10)  'Moved to avoid scroll bar
C1 = @IF(C1+23<=SCRWIDTH,C1,SCRWIDTH-23)
R2 = R1 + 9
C2 = C1 + 23
FG = 15
BG = 1
'BG = 9
SCREEN SAVE R1 C1 R2 C2 CALSCR

DISPMONTH = MONTH(TODAY)
DISPYEAR = YEAR(TODAY)
DISPDAY = DAY(TODAY)
KEYPRESS = BLANK


'SET UP DAYS IN THE MONTH, START WITH CURRENT MONTH.

WHILE TRUE
label redraw
    DISPDATE = STR(DISPMONTH)|"/01/"|STR(DISPYEAR)
    NEXTMONTH = STR(@IF(DISPMONTH<12,DISPMONTH+1,1))|"/01/"|STR(@IF(DISPMONTH=12,DISPYEAR+1,DISPYEAR))

    NUMDAYS =  DATE(NEXTMONTH) - DATE(DISPDATE)
    DAYOFWEEK = WEEKDAY(DISPDATE)
    DISPMNAME = "  "|MONTHNAME(DISPDATE)|"  "

'WHEN SWITCHING TO PRIOR MONTH, CALCULATE DISPLAY DAY.

    CASE KEYPRESS
       WHEN {LEFT}
        DISPDAY = NUMDAYS
	  WHEN {1}
        DISPDAY = NUMDAYS
       WHEN {UP}
        DISPDAY = NUMDAYS + DISPDAY
	  WHEN {3}
        DISPDAY = NUMDAYS + DISPDAY
       OTHERWISE
    END CASE

'SET UP AN ARRAY FOR EACH DAY OF THE MONTH. ARRAY HAS 2 VALUES
'THE DAY OF THE WEEK (1 THRU 7), AND THE ROW IT IS TO BE DISPLAYED
'ON.  WHEN THE DAY OF THE WEEK IS 7, START A NEW ROW.
    CURROW = R1+3
    FOR N = 1 to NUMDAYS
      DAYSMON[N,1] = DAYOFWEEK
      DAYSMON[N,2] = CURROW
      IF DAYOFWEEK = 7
       DAYOFWEEK = 1
       CURROW = (CURROW + 1)
      ELSE
       DAYOFWEEK = (DAYOFWEEK + 1)
      END IF
    END FOR


'DISPLAY THE DAYS OF THE MONTH IN THE CALENDAR. CLEAR A BOX FIRST
'TO ERASE A PRIOR MONTH DISPLAYED
	button finished
	button init FG BG
    FOR N = 1 to NUMDAYS

	CASE N
		WHEN 1
			button create auto-size DAYSMON[N,2] (C1+3)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 2
			button create auto-size DAYSMON[N,2] (C1+3)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 3
			button create auto-size DAYSMON[N,2] (C1+3)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 4
			button create auto-size DAYSMON[N,2] (C1+3)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 5
			button create auto-size DAYSMON[N,2] (C1+3)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 6
			button create auto-size DAYSMON[N,2] (C1+3)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 7
			button create auto-size DAYSMON[N,2] (C1+3)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 8
			button create auto-size DAYSMON[N,2] (C1+3)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 9
			button create auto-size DAYSMON[N,2] (C1+3)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 10
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 11
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 12
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 13
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 14
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 15
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 16
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 17
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 18
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 19
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 20
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 21
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 22
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 23
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 24
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 25
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 26
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 27
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 28
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 29
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 30
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
		WHEN 31
			button create auto-size DAYSMON[N,2] (C1+2)+((DAYSMON[N,1]-1)*3) {�} str(N)
	END CASE
     END FOR
repaint off
makebutton()
displaycal()
button draw all
repaint on
'DISPLAY THE MONTH AND YEAR ON THE FIRST/LAST LINES.
    screen print R1 C1+((24-LEN(DISPMNAME))/2) FG BG DISPMNAME
    screen print R2+1 C1+((23-LEN(STR(DISPYEAR)))/2) FG BG "�"|STR(DISPYEAR)|"�"

'PROCESS KEYS, HIGHLIGHTING APPROPRIATE DAY.

    CURRMONTH = DISPMONTH
    CURRYEAR = DISPYEAR
    WHILE CURRMONTH = DISPMONTH AND CURRYEAR = DISPYEAR
      OLDDAY = DISPDAY
	IF LEN(STR(DISPDAY)) = 1
      screen print DAYSMON[DISPDAY,2] (C1+2)+((DAYSMON[DISPDAY,1]-1)*3) BG FG FORMAT "0R3" DISPDAY
	ELSE
      screen print DAYSMON[DISPDAY,2] (C1+2)+((DAYSMON[DISPDAY,1]-1)*3) BG FG FORMAT "0M2" DISPDAY
	END IF
'paints date & day at bottem of screen -->          screen print scrheight 1 15 2 format("M"|str(scrwidth)) adate(STR(DISPMONTH)|"/"|STR(DISPDAY)|"/"|STR(DISPYEAR)) & dayname(adate(STR(DISPMONTH)|"/"|STR(DISPDAY)|"/"|STR(DISPYEAR)))

      KEYPRESS = inevent
  CASE KEYPRESS
       when {b}
          rvalue = "blank"
'          SCREEN SHORTRESTORE CALSCR
          return
       WHEN {ESC}
          rvalue = "nochange"
'          SCREEN SHORTRESTORE CALSCR
          RETURN
       WHEN {ENTER}
          rvalue = "date"
'          SCREEN SHORTRESTORE CALSCR
          RETURN
       WHEN {Left}
          DISPDAY = (DISPDAY - 1)
	  WHEN {1}
          DISPDAY = (DISPDAY - 1)
       WHEN {Right}
          DISPDAY = (DISPDAY + 1)
	  WHEN {2}
          DISPDAY = (DISPDAY + 1)
       WHEN {Up}
          DISPDAY = (DISPDAY - 7)
	  WHEN {3}
          DISPDAY = (DISPDAY - 7)
       WHEN {Down}
          DISPDAY = (DISPDAY + 7)
	  WHEN {4}
          DISPDAY = (DISPDAY + 7)
       WHEN {PgUp}
          DISPMONTH = (DISPMONTH - 1)
	  WHEN {5}
          DISPMONTH = (DISPMONTH - 1)
       WHEN {PgDn}
          DISPMONTH = (DISPMONTH + 1)
	  WHEN {6}
          DISPMONTH = (DISPMONTH + 1)
       WHEN {Home}
          DISPDAY = 1
       WHEN {End}
          DISPDAY = NUMDAYS
       WHEN {^Home}
          DISPMONTH = 1
       WHEN {^End}
          DISPMONTH = 12
       WHEN {^PgUp}
          DISPYEAR = (DISPYEAR - 1)
	  WHEN {7}
          DISPYEAR = (DISPYEAR - 1)
       WHEN {^PgDn}
          DISPYEAR = (DISPYEAR + 1)
	  WHEN {8}
          DISPYEAR = (DISPYEAR + 1)
       WHEN {^Left}
          DISPDAY = DISPDAY - (DAYSMON[DISPDAY,1]-1)
          IF DISPDAY < 1
             DISPDAY = 1
          END IF
       WHEN {^Right}
          DISPDAY = DISPDAY + (7-DAYSMON[DISPDAY,1])
          IF DISPDAY > NUMDAYS
             DISPDAY = NUMDAYS
          END IF
       WHEN {�}
		 movecal()
		jump redraw
       WHEN {F1}
          CALKEYS()
     END CASE
KEY NAME KEYPRESS $PP
DISPDAY = CASE $PP("�",1)("�",2)("�",3)("�",4)("�",5)("�",6)("�",7)("�",8)("�",9)("�",10)("�",11)("�",12)("�",13)("�",14)("�",15)("�",16)("�",17)("�",18)("�",19)("�",20)("�",21)("�",22)("�",23)("�",24)("�",25)("�",26)("�",27)\
("�",28)("�",29)("�",30)("�",31) else DISPDAY

'  displays last keystroke -->  screen print 1 1 15 4 FORMAT("m"|STR(SCRWIDTH)) $PP & STR(DISPDAY)

'SWITCH TO PREVIOUS MONTH OR YEAR.

     IF DISPDAY < 1
        IF DISPMONTH > 1
           DISPMONTH = (DISPMONTH - 1)
        ELSE
           DISPMONTH = 12
           DISPYEAR = (DISPYEAR - 1)
        END IF
     END IF
     IF DISPDAY > NUMDAYS
        IF DISPMONTH < 12
           DISPMONTH = (DISPMONTH + 1)
        ELSE
           DISPMONTH = 1
           DISPYEAR = (DISPYEAR + 1)
        END IF
        DISPDAY = 1
     END IF
     IF DISPMONTH < 1
        DISPMONTH = 12
        DISPYEAR = (DISPYEAR - 1)
     END IF
     IF DISPMONTH > 12
        DISPMONTH = 1
        DISPYEAR = (DISPYEAR + 1)
     END IF

' REMOVE HIGHLIGHT OF DISPLAY DAY. NEXT PASS THROUGH THE LOOP WILL
' HIGHLIGHT A NEW ( OR SAME) DAY.
     screen print DAYSMON[OLDDAY,2] (C1+2)+((DAYSMON[OLDDAY,1]-1)*3) FG BG FORMAT "0R3" OLDDAY
   END WHILE
 END WHILE
end function 'electrinicalendar()
'----------------------------------------------------------------------


'----------------------------------------------------------------------
function WEEKDAY(DAYSTR)
CASE DAYNAME(DAYSTR)
    WHEN "Sunday"
     RETURN 1
    WHEN "Monday"
     RETURN 2
    WHEN "Tuesday"
     RETURN 3
    WHEN "Wednesday"
     RETURN 4
    WHEN "Thursday"
     RETURN 5
    WHEN "Friday"
     RETURN 6
    WHEN "Saturday"
     RETURN 7
END CASE
END function
'----------------------------------------------------------------------

'----------------------------------------------------------------------
function CALKEYS()
LOCAL KEYSCR, FG, BG
FG = FGEDITING
BG = BGEDITING
SCREEN SAVE 02 20 20 65 KEYSCR
screen clear box 02 20 20 65 FG BG
screen print 02 37 BG FG " Calendar Keys "
screen print 03 22 FG BG "Left Arrow       = Previous Day"
screen print 04 22 FG BG "Right Arrow      = Next Day"
screen print 05 22 FG BG "Up Arrow         = Previous Week"
screen print 06 22 FG BG "Dn Arrow         = Next Week"
screen print 07 22 FG BG "PgUp             = Previous Month"
screen print 08 22 FG BG "PgDn             = Next Month"
screen print 09 22 FG BG "Home             = 1st Day of the Month"
screen print 10 22 FG BG "End              = Last Day of the Month"
screen print 11 22 FG BG "^Home            = 1st Day of the Year"
screen print 12 22 FG BG "^End             = Last Day of the Year"
screen print 13 22 FG BG "^PgUp            = Previous Year"
screen print 14 22 FG BG "^PgDn            = Next Year"
screen print 15 22 FG BG "^Left Arrow      = 1st Day of the Week"
screen print 16 22 FG BG "^Right Arrow     = Last Day of the Week"
screen print 17 22 FG BG "Esc              = Finished"
screen print 18 22 FG BG "Enter            = Returns Displayed Date"
screen print 19 22 FG BG "F1               = Displays Help Screen"
screen print 20 25 FG BG "Press Any Key to Return to Calendar"
INCHAR
SCREEN SHORTRESTORE KEYSCR
RETURN
END function 'calkeys()
'----------------------------------------------------------------------

'----------------------------------------------------------------------
function movecal()
'----------------------------------------------------------------------
local $control $cal
$control = inevent
clearerror
error off
screen save R1 C1 R1+10 C1+23 $cal
button finished
SCREEN RESTORE R1 C1 $cal
repaint
while true
  while mouseinfo(m_leftdown)
	REPAINT
	let R1 = mouseinfo(m_row)
	let C1 = mouseinfo(m_col)
	SCREEN RESTORE R1 C1 $cal
  end while
  if mouseinfo(m_leftup)
	let R1 = mouseinfo(m_row)
	let C1 = mouseinfo(m_col)
	R1 = @IF(R1+10<=SCRHEIGHT,R1,SCRHEIGHT-10)
	C1 = @IF(C1+23<=SCRWIDTH,C1,SCRWIDTH-23)
	R2 = R1 + 9
	C2 = C1 + 23
     exit while
  end if
end while
'SCREEN RESTORE R1 C1 $cal
clearerror
screen clear box scrheight-3 1 scrheight-1 scrwidth 15 0 no-border
button draw all
end function 'movecal()
'----------------------------------------------------------------------

'----------------------------------------------------------------------
function makebutton()
button default-color 15 0
	button create auto-size scrheight-3 1 {1} " 1. Previous Day"
	button create auto-size scrheight-3 19 {3} " 3. Previous Week"
	button create auto-size scrheight-3 37 {5} " 5. Previous Month"
	button create auto-size scrheight-3 55 {7} " 7. Previous Year"
	button create auto-size scrheight-2 1 {2} " 2. Next Day"
	button create auto-size scrheight-2 19 {4} " 4. Next Week"
	button create auto-size scrheight-2 37 {6} " 6. Next Month"
	button create auto-size scrheight-2 55 {8} " 8. Next Year"
	button create auto-size scrheight-1 1 {ENTER} " Enter - Returns Date"
	button create auto-size scrheight-1 30 {ESC} " ESC - No Change"
	button create auto-size scrheight-1 55 {b} " b. BLANK Field"


	button default-color 7 15
	button create auto-size R1 C1 {�} "Move"

	button default-color 7 15
	button create auto-size R1+9 C1+5 {F1} " F1 for Help "
	button default-color 0 15

end function 'makebutton()
'----------------------------------------------------------------------

'----------------------------------------------------------------------
function displaycal()
'DISPLAY THE CALENDAR
screen clear box R1 C1 R2 C2 FG BG no-border
screen print R1+1 C1 FG BG "  Su Mo Tu We Th Fr Sa  "
screen print R1+2 C1+1 FG BG repeat(chr(205),22)
screen draw box R1 C1 R1+2 C2 FG BG
screen draw box R1 C1 R1+10 C2 FG BG
screen clear box scrheight-3 1 scrheight-1 scrwidth 0 15 no-border
end function 'displaycal()
'----------------------------------------------------------------------






'**********************************************************************
'OTHER FUNCTIONS
'**********************************************************************

function automenu()
'**********************************************************************
'MAKES DB MENU POP UP DURING ENTER OR UPDATE, ENTER AS DEFALT EQUATION
'SET automenu() AS THE DEFAULT CALCULATION ON A FIELD WITH A DB MENU ATTACHED
smartpoke $_KEY {ALT-F5}
return blank
end function



'*************************************************************************
' displays working screen with message passed from $$fct
'*************************************************************************
function working()
local lmsg
$$fct = "  "|$$fct|"  "
lmsg = int(len($$fct))
REPAINT OFF
SCREEN CLEAR BOX 1 1 scrheight -4  scrwidth -1 fgpleasing bgpleasing
SCREEN DRAW BOX int(scrheight*.5)-1 (int(int(scrwidth*.5)-(int(lmsg * .5)))-2)\
int(scrheight*.5)+1 int(scrwidth*.5)+(int(lmsg*.5)+1) fgpleasing bgpleasing
SCREEN PRINT  int(scrheight*.5)  int(scrwidth*.5)-int(lmsg *.5) fgpleasing \
bgpleasing $$fct
$$fct = " "
end function


'*************************************************************************
' displays flag in center of the screen screen with message passed from $$fct
'*************************************************************************
function flag()
local lmsg
$$fct = "  "|$$fct|"  "
lmsg = int(len($$fct))
REPAINT OFF
SCREEN CLEAR BOX int(scrheight*.5)-1 (int(int(scrwidth*.5)-(int(lmsg * .5)))-2)\
int(scrheight*.5)+1 int(scrwidth*.5)+(int(lmsg*.5)+1) fgpleasing bgpleasing
SCREEN DRAW BOX int(scrheight*.5)-1 (int(int(scrwidth*.5)-(int(lmsg * .5)))-2)\
int(scrheight*.5)+1 int(scrwidth*.5)+(int(lmsg*.5)+1) fgpleasing bgpleasing
SCREEN PRINT  int(scrheight*.5)  int(scrwidth*.5)-int(lmsg *.5) fgpleasing \
bgpleasing $$fct
$$fct = " "
end function