!
! Date manipulation functions
!
! Function     Description/modifications
!--------------------------------------------------
! date'val     Takes a date string and converts it to a date value using
!              century calculation.  Default is 1900
!
! date'str$    Takes a date value and converts it to a date string
!              First parameter is date value, second is flag for string size
!              A second parm of 2 returns date as 'mm/dd/yr'
!              default is 'mm/dd/ccyy'
!
! dow          Takes a date value and returns the numeric day of week ( 1 - 7 )
!
! cdow$        Takes a date value and return the day of week as string.
!              The second parm determines string size.
!
! in_date      Generic mask input routine for date entries
!              ( see notes at routine for details on implementation 's !!!' )
!


     float dsv'yr, dsv'mn, dsv'da, dsv'ly, valid'date
     string 12 dsv'dt$

function date'val( G1$ ) 

     when G1$ <> ""
          dsv'ly = int((val(G1$[5,8])-1)*365.25)+((val(G1$[1,2])-1)*30)
          dsv'ly += abs(val(G1$[1,2])=2)-abs(val(G1$[1,2])=3)+abs(val(G1$[1,2])>5)+abs(val(G1$[1,2])>7)+abs(val(G1$[1,2])>8)+abs(val(G1$[1,2])>10)
          dsv'ly += abs((val(G1$[5,8])/4=int(val(G1$[5,8])/4))and val(G1$[1,2])>2)+val(G1$[3,4])

          if dsv'ly < 500000 then dsv'ly += 693975  ! for 1900 default
!         if dsv'ly < 500000 then dsv'ly += 730500  ! for 2000 default

     else

          dsv'ly = 0

     wend

     return dsv'ly

endfunc

function date'str$( G1, nmdgt)

     when G1 > 0

          dsv'yr = int((G1)/365.25)+1             ! value of current year
          dsv'ly = abs((dsv'yr/4)=int(dsv'yr/4))  ! is it a leap year
          dsv'da = int((G1-(int((dsv'yr-1)*365.25))))  ! number of days into current year

          when dsv'da = 0         ! only happens on 12/31/xx of leap years
               dsv'yr -= 1        ! it is prior year  ( ly->366->01/00/yy->12/31/yy )
               dsv'da += 365      ! 12/31
          wend

     ! calculate month
          dsv'mn = int(dsv'da/30)+1          
          dsv'mn += (dsv'da=30 or dsv'da=31) - abs((dsv'da=60) and (dsv'ly)) + (dsv'da=90 or dsv'da=90+dsv'ly)
          dsv'mn += (dsv'da=120 or dsv'da=120+dsv'ly) + (dsv'da=150 or dsv'da=150+dsv'ly or dsv'da=151+dsv'ly)
          dsv'mn += (dsv'da=180 or dsv'da=180+dsv'ly or dsv'da=181+dsv'ly) + (dsv'da>209 and dsv'da<213+dsv'ly)
          dsv'mn += (dsv'da>239 and dsv'da<244+dsv'ly) + (dsv'da>269 and dsv'da<274+dsv'ly)
          dsv'mn += (dsv'da>299 and dsv'da<305+dsv'ly) + (dsv'da>329 and dsv'da<335+dsv'ly) + (dsv'da>359)

     ! subtract #days up to current month
          dsv'da -= ((dsv'mn-1)*30)+abs(dsv'mn=2)-abs(dsv'mn=3)+abs(dsv'mn>5)+abs(dsv'mn>7)+abs(dsv'mn>8)+abs(dsv'mn>10)+(dsv'mn>2 and dsv'ly)

     ! format the date as a string
          switch nmdgt
               case 2              ! format with 2 digit year
                    dsv'ly = (dsv'mn * 100) + dsv'da
                    dsv'dt$ = str(dsv'ly) using "#ZZZ"
                    dsv'ly = dsv'yr
                    repeat
                         dsv'ly -= 100
                    until dsv'ly < 100
                    dsv'dt$ += str(dsv'ly) using "#Z"
                    dsv'dt$ = merge("##/##/##", dsv'dt$)
               endcase
               default case        ! default to 4 digit year
                    dsv'ly = (dsv'mn * 1000000) + (dsv'da * 10000) + (dsv'yr)
                    dsv'dt$ = str(dsv'ly) using "#ZZZZZZZ"
                    dsv'dt$ = merge("##/##/####", dsv'dt$)
               endcase
          endswitch

     else

          dsv'dt$ = ""

     wend

     return dsv'dt$

endfunc


function dow( G1 )

     dsv'da = 4              ! set base day of week to Fri Sept 17/93
     dsv'yr = date'val("091793")

     dsv'ly = ( dsv'yr max G1 ) - ( G1 min dsv'yr )
     when dsv'yr <= G1
          dsv'da += int( dsv'ly - ( int( dsv'ly/7 ) * 7 ) )
     else
          dsv'da -= int( dsv'ly - ( int( dsv'ly/7 ) * 7 ) )
     wend
 
     if dsv'da < 0 then dsv'da += 7
     if dsv'da > 6 then dsv'da -= 7

     return dsv'da + 1        ! return 1 - 7  not 0 - 6 

endfunc


function cdow$( G1, ln )

     dsv'da =  dow( G1 )
     switch dsv'da
          case 1
               dsv'dt$ = "Monday"
          endcase
          case 2
               dsv'dt$ = "Tuesday"
          endcase
          case 3
               dsv'dt$ = "Wednesday"
          endcase
          case 4
               dsv'dt$ = "Thursday"
          endcase
          case 5
               dsv'dt$ = "Friday"
          endcase
          case 6
               dsv'dt$ = "Saturday"
          endcase
          case 7
               dsv'dt$ = "Sunday"
          endcase
     endswitch

     when ln > 0
          return dsv'dt[1,ln]
     else
          return dsv'dt$
     wend

endfunc



!!!! NOTES
!
!  To properly use this function your input mask must have an extra
!  field defined using digits, and len 8.
!  This function will move that field onto the date field space defined
!  by row, col.  You must set row, col prior to calling this function.
!
!  replace the XX characters with the field number of this dummy field.
!  replace MASK  with the mask name.
!
!  This function returns a dummy value.  You must have the variables
!  STR1NG and EXIT'COD pre-defined as well as row & col.
!  You also msut predefine the ESC and CTRL'C  to 27 and 3 respectively
!
!  This function will not terminate until a valid date is entered or
!  a NULL entry is encountered.
!
!  This function will only process 6 or 8 length strings.  Any other
!  length other than 0 will be considered invalid.
!
function in_date( row, col )

     move.field #XX of "MASK" to row, col

     repeat

          valid'date = .false
          accept.field #XX of "MASK" into STR1NG,EXIT'COD

          when STR1NG <> "" and EXIT'COD <> ESC and EXIT'COD <> CTRL'C

               when len( STR1NG ) = 6

                    when STR1NG[5,6] <> "00"
                         dsv'dt$ = STR1NG
                    else ! use 2001 to validate 2000 dates
                         dsv'dt$ = STR1NG[1,4] + "01"
                    wend

                    valid'date = ( vdate(STR1NG) <> 0 )

               else

                    when len( STR1NG ) = 8

                         when STR1NG[7,8] <> "00"
                              dsv'dt$ = STR1NG[1,4] + STR1NG[7,8]
                         else ! use 2001 to validate 2000 dates
                              dsv'dt$ = STR1NG[1,4] + "01"
                         wend

                         valid'date = ( vdate(dsv'dt$) <> 0 )

                    wend

               wend

          else      ! blank entry or abort code

               valid'date = .true       ! to allow exit

          wend

          if valid'date = .false then print chr(7)

     until valid'date

     when len(STR1NG) = 6
          STR1NG = STR1NG[1,4] + "19" + STR1NG[5,6]
     wend

     return 0

endfunc



.