/* dsDate */

dsDate: procedure expose dsd!.

    switchlist = 'BCDEGIJLMNOPQSTUVWY'
    dsd!.error = 0
    dsd!.switch = Arg(1)
    dsd!.firstparm = Arg(2)
    dsd!.secondparm = Arg(3)
    dsd!.param1_USA_Opts = 'BCDEIJLMNOPQSTUVWY'
    dsd!.P1TJopts = ''
    dsd!.P1FJSwitch = 'G'
    dsd!.P2FJopts = 'I'
    dsd!.P2UsaOpts = 'BP'

    If dsd!.switch = '' Then dsd!.switch = 'N'

    dsd!.Error = InitArgs!(switchlist)

    If \ dsd!.error Then
      Select
        When dsd!.switch = ''  then retval = DefaultFunction!(dsd!.firstparm)
        When pos(dsd!.switch, switchlist) \= 0 then
             retval = GetAnswer!( dsd!.switch, dsd!.firstparm, dsd!.secondparm)
        Otherwise NOP
      End

    /* Reformat year digits, if needed */
    If \ dsd!.error & (pos(dsd!.switch, 'EGIOU') \= 0) Then DO
        parse value retval with v1 '/' v2 '/' v3 .
        Select
            When (Length(v1) > 2) & (substr(v1,1,2) = '19') then v1 = 2Chars!(v1)
            When (Length(v2) > 2) & (substr(v2,1,2) = '19') then v2 = 2Chars!(v2)
            When (Length(v3) > 2) & (substr(v3,1,2) = '19') then v3 = 2Chars!(v3)
            Otherwise NOP
            End /*select*/
        retval = v1 '/' v2 '/' v3
        retval = space(retval,'0')
        END

    If dsd!.error Then Retval = 0

  Return Retval


InitArgs!: procedure expose dsd!.

    Arg switches
    Problem = 0

    /* Examine switch parameter for proper value */
    Select
      When dsd!.switch = '' then nop
      When pos(dsd!.switch, switches) \== 0 then nop
      Otherwise problem = 1
    End /*select*/

    /* Examine Parm1 for value, default to today if null */
    If \problem Then Do
        dsd!.firstparm = space(dsd!.firstparm,'0')
        Select
          When dsd!.firstparm = '' Then Do
                Select
                    When pos(dsd!.switch,dsd!.param1_USA_Opts) \== 0 then dsd!.firstparm = DATE(U)
                    When pos(dsd!.switch, dsd!.P1TJopts) \== 0 then Do
                        parse value DATE(U) with mm '/' dd '/' yy .
                        dsd!.firstparm = CalcJulian!(mm,dd,yy)
                        End
                    When pos(dsd!.switch,dsd!.P1FJSwitch) \== 0 then dsd!.firstparm = DATE(D)
                    When dsd!.switch = '' Then dsd!.firstparm = DATE(U)
                    Otherwise NOP
                    End
                End
          When pos(dsd!.switch, dsd!.param1_USA_Opts) \== 0 &,
               ValidUsa!(dsd!.firstparm) Then NOP
          When pos(dsd!.switch, dsd!.P1TJopts) \= 0 &,
               ValidTJulian!(dsd!.firstparm) Then NOP
          When pos(dsd!.switch,dsd!.P1FJSwitch) \== 0 &,
               ValidFJulian!(dsd!.firstparm) Then NOP
          When (dsd!.switch = '') & ValidUsa!(dsd!.firstparm) Then NOP
          Otherwise problem = 1
          End
        End

        /* Examine the second parameter for value */
        If \problem Then Do
            dsd!.secondparm = space(dsd!.secondparm,'0')
            Select
              When dsd!.secondparm = '' Then Do
                Select
                    When pos(dsd!.switch,dsd!.P2UsaOpts) \== 0 then dsd!.secondparm = DATE(U)
                    When pos(dsd!.switch,dsd!.P2FJopts) \== 0 then dsd!.secondparm = '0'
                    Otherwise NOP
                    End /*select*/
                End /*if parm2 is null*/
              When pos(dsd!.switch,dsd!.P2FJopts) \== 0 & datatype(dsd!.secondparm,'N') then NOP
              When pos(dsd!.switch,dsd!.P2UsaOpts) \== 0 & ValidUsa!(dsd!.secondparm) Then NOP
              Otherwise problem = 1
              End /*select*/
            End /*if not error*/
   Return problem


GetAnswer!: PROCEDURE EXPOSE dsd!.

    Arg SwitchCode, P1, P2

    Select
      When switchcode = 'B' then retval = BaseDate!(P1,'01/01/0001')
      When switchcode = 'C' then retval = CenturyDays!(P1)
      When switchcode = 'D' then retval = YearDays!(P1)
      When switchcode = 'E' then retval = European!(P1)
      When switchcode = 'G' then retval = FJ2Gregorian!(dsd!.firstparm)
      When switchcode = 'I' then retval = IncrementDays!(dsd!.firstparm,dsd!.secondparm)
      When switchcode = 'J' then retval = JulianDate!(P1)
      When (switchcode = 'L') | (switchcode = 'N') Then retval = DefaultFunction!(P1)
      When switchcode = 'M' then retval = MonthName!(P1)
      When switchcode = 'O' then retval = OrderedDate!(P1)
      When switchcode = 'P' then retval = BaseDate!(dsd!.firstparm,dsd!.secondparm)
      When switchcode = 'Q' then retval = QuarterNbr!(dsd!.firstparm)
      When switchcode = 'S' then retval = SortedDate!(P1)
      When switchcode = 'T' Then retval = TextDate!(dsd!.firstparm)
      When switchcode = 'U' then retval = P1
      When switchcode = 'V' then retval = 1
      When switchcode = 'W' then retval = DayName!(P1)
      When switchcode = 'Y' then retval = DayNumber!(dsd!.firstparm)
      Otherwise NOP
    End
  Return retval

TextDate!: procedure

    arg parm1
    parse value parm1 with mm '/' dd '/' yy .

    If Left(dd,1) = '0' Then dd = Right(dd,1)
    retval = FindMonthName!(mm) dd || ',' 4Chars!(yy)
    retval = space(retval,'1')

   Return retval

DefaultFunction!: procedure

    arg parm1
    parse value parm1 with mm '/' dd '/' yy .
    retval = Right(dd,2,'0') substr(FindMonthName!(mm),1,3) 4Chars!(yy)
    retval = space(retval,'1')

   Return retval

CenturyDays!: procedure

    arg parm1
    parse value parm1 with mm '/' dd '/' yy .
    yy = 4Chars!(yy)
    century_yr = Century!(yy)
    retval = CalcJulian!(mm,dd,yy) - CalcJulian!(1,1,century_yr) + 1

   Return retval

YearDays!: procedure

    arg parm1
    parse value parm1 with mm '/' dd '/' yy .
    yy = 4Chars!(yy)
    retval = CalcJulian!(mm,dd,yy) - CalcJulian!(01,01,yy) + 1

   Return retval

QuarterNbr!: procedure

    Arg parm
    parse value parm with mm '/' dd '/' yy .
    junk = Abs(mm)
    Select
        When (junk < 4) Then retval = 1
        When (junk > 3) & (junk < 7) Then retval = 2
        When (junk > 6) & (junk < 10) Then retval = 3
        Otherwise retval = 4
        End
  Return retval


European!: procedure

    arg parm1
    parse value parm1 with mm '/' dd '/' yy .
    retval = Space(dd '/' mm '/' yy,'0')

   Return retval

JulianDate!: procedure

    arg parm1
    parse value parm1 with mm '/' dd '/' yy .
    v1 = 2Chars!(yy)
    v2 = YearDays!(parm1)
    retval = v1||right(v2,3,'0')

   Return retval

MonthName!: procedure

    arg parm1
    parse value parm1 with mm '/' .
    retval = FindMonthName!(mm)
   Return retval

FindMonthName!: procedure

    Arg parm
    retval = Word('January February March April May June',
            ' July August September October',
            ' November December',parm)
  Return retval

OrderedDate!: procedure

    arg parm1
    parse value parm1 with mm '/' dd '/' yy .
    retval = yy '/' mm '/' dd
    retval = space(retval,'0')

   Return retval

SortedDate!: procedure
    arg parm1
    parse value parm1 with mm '/' dd '/' yy .
    retval = 4Chars!(yy) 2Chars!(mm) 2Chars!(dd)
    retval = space(retval,'0')
   Return retval

DayNumber!: procedure
    arg parm1
    parse value parm1 with mm '/' dd '/' yy .
    yy = 4Chars!(yy)
    retval = WeekDay!(mm,dd,yy)

   Return retval

DayName!: procedure
    arg parm1
    parse value parm1 with mm '/' dd '/' yy .
    retval = Word('Sunday Monday Tuesday Wednesday',
            ' Thursday Friday Saturday Sunday',WeekDay!(mm,dd,yy))
  Return retval

WeekDay!: procedure
    mm = arg(1)
    dd = arg(2)
    yy = arg(3)
    w_var  =     (CalcJulian!(mm,dd,yy) - CalcJulian!(1,1,1984)) // 7
    if w_var >= 0 then retval = w_var + 1
      else retval = w_var + 8
   Return retval

FJ2Gregorian!: procedure

    arg parm1
    retval =  CalcGreg!(FJul2TJul!(parm1))

   Return retval

IncrementDays!: PROCEDURE EXPOSE dsd!.

    parm1 = arg(1)
    parm2 = arg(2)
    parse value parm1 with mm '/' dd '/' yy .
    Select
      When (parm2 < 0) & (abs(parm2) > (CalcJulian!(mm,dd,yy) - 1721426)) then dsd!.error = 1
      When (parm2 >= 0) & (parm2 > (5373484 - CalcJulian!(mm,dd,yy))) then dsd!.error = 1
      otherwise retval = CalcGreg!(CalcJulian!(mm,dd,yy) + parm2)
      end

    Return retval

BaseDate!: procedure

    parm1 = arg(1)
    parm2 = arg(2)
    parse value parm1 with mm1 '/' dd1 '/' yy1 .
    parse value parm2 with mm2 '/' dd2 '/' yy2 .
    retval = abs(CalcJulian!(mm1,dd1,yy1) - CalcJulian!(mm2,dd2,yy2))

   Return retval

CalcJulian!: procedure

    month = arg(1)
    day   = arg(2)
    year  = arg(3)
    year  = 4Chars!(year)
    numeric digits 15
    If month > 2 then month = month - 3
    else do
        month = month + 9
        year = year - 1
        end
    c = year % 100
    ya = year - 100 * c
    julian_number = (146097 * c  % 4) +    ((1461 * ya) % 4) +,
                       ((153 * month + 2) % 5) + day + 1721119

    Return julian_number

CalcGreg!: procedure

    jn = arg(1)
    numeric digits 15
    jn = jn - 1721119
    year =    ((4 * jn - 1) % 146097)
    jn =    (4 * jn - 1 - 146097 * year)
    day =     jn % 4
    jn =    ((4 * day + 3) % 1461)
    day =    (4 * day + 3 - 1461 * jn)
    day =    ((day + 4) % 4)
    month =    ((5 * day - 3) % 153)
    day   =    (5 * day - 3 - 153 * month)
    day =    ((day + 5) % 5)
    year =    (100 * year + jn)
    If (month < 10) Then month = month + 3
      Else Do
          month = month - 9
          year  = year + 1
          End
  Return Usa4Year!(month,day,year)

Usa2Year!: procedure

    mm = arg(1)
    dd = arg(2)
    yy = arg(3)
    retval = right(month,2,'0') '/' right(day,2,'0') '/',
             right(year,2,'0')
    retval = space(retval,0)
  Return retval

TJul2FJul!: procedure
    true_julian_number = arg(1)
    greg_date = CalcGreg!(true_julian_number)
    greg_year = substr(greg_date,7,4)
    false_julian_day = true_julian_number - CalcJulian!(1,1,greg_year) + 1
    retval = substr(greg_year,3,2)||right(false_julian_day,3,'0')

  Return retval

FJul2TJul!: procedure

    false_julian_number = arg(1)
    false_julian_year   = substr(false_julian_number,1,2)
    false_julian_day    = substr(false_julian_number,3,3)
    retval = CalcJulian!(1,1,false_julian_year) + false_julian_day - 1
  Return retval

Usa4Year!: procedure

    mm   = arg(1)
    dd   = arg(2)
    yyyy = arg(3)
    retval = right(mm,2,'0') '/' right(dd,2,'0') '/',
             right(yyyy,4,'0')
    retval = space(retval,'0')

  Return retval

ValidUsa!: procedure

    arg mmddyy

    parse value mmddyy with mm '/' dd '/' yy .
    retval = 0

    If datatype(mm,'N') & datatype(dd,'N') & datatype(yy,'N') Then
        do
          yy = 4Chars!(yy)
          If CalcGreg!(CalcJulian!(mm,dd,yy)) = Usa4Year!(mm,dd,yy) Then retval = 1
        end

  Return retval

ValidFJulian!: procedure

    arg Parm
    Select
      When \datatype(parm,'N') Then retval = 0
      When Length(parm) \== 5 Then retval = 0
      When TJul2FJul!( FJul2TJul!( parm )) \= parm then retval = 0
      Otherwise retval = 1
    End
  Return retval

ValidTJulian!: procedure

    Arg Parm

    Select
      When \ datatype(parm,'N') then retval = 0
      When (parm << 1721426) | (parm >> 5373484) then retval = 0
      otherwise retval = 1
    End
  Return retval

Century!: procedure
    Arg yyyy
    retval = 100 * (yyyy % 100)
    If retval < 100 Then retval = 1900
  Return retval

2Chars!: procedure
    Arg retval
    retval = Right(retval,2,'0')
  Return retval

4Chars!: procedure
    Arg retval
    If (Length(retval) < 3) Then retval = retval + 1900
  Return retval

