home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 18 REXX / 18-REXX.zip / dsdate.zip / DSDATE next >
Text File  |  1995-09-01  |  12KB  |  419 lines
  1. /* dsDate */
  2.  
  3. dsDate: procedure expose dsd!.
  4.  
  5.     switchlist = 'BCDEGIJLMNOPQSTUVWY'
  6.     dsd!.error = 0
  7.     dsd!.switch = Arg(1)
  8.     dsd!.firstparm = Arg(2)
  9.     dsd!.secondparm = Arg(3)
  10.     dsd!.param1_USA_Opts = 'BCDEIJLMNOPQSTUVWY'
  11.     dsd!.P1TJopts = ''
  12.     dsd!.P1FJSwitch = 'G'
  13.     dsd!.P2FJopts = 'I'
  14.     dsd!.P2UsaOpts = 'BP'
  15.  
  16.     If dsd!.switch = '' Then dsd!.switch = 'N'
  17.  
  18.     dsd!.Error = InitArgs!(switchlist)
  19.  
  20.     If \ dsd!.error Then
  21.       Select
  22.         When dsd!.switch = ''  then retval = DefaultFunction!(dsd!.firstparm)
  23.         When pos(dsd!.switch, switchlist) \= 0 then
  24.              retval = GetAnswer!( dsd!.switch, dsd!.firstparm, dsd!.secondparm)
  25.         Otherwise NOP
  26.       End
  27.  
  28.     /* Reformat year digits, if needed */
  29.     If \ dsd!.error & (pos(dsd!.switch, 'EGIOU') \= 0) Then DO
  30.         parse value retval with v1 '/' v2 '/' v3 .
  31.         Select
  32.             When (Length(v1) > 2) & (substr(v1,1,2) = '19') then v1 = 2Chars!(v1)
  33.             When (Length(v2) > 2) & (substr(v2,1,2) = '19') then v2 = 2Chars!(v2)
  34.             When (Length(v3) > 2) & (substr(v3,1,2) = '19') then v3 = 2Chars!(v3)
  35.             Otherwise NOP
  36.             End /*select*/
  37.         retval = v1 '/' v2 '/' v3
  38.         retval = space(retval,'0')
  39.         END
  40.  
  41.     If dsd!.error Then Retval = 0
  42.  
  43.   Return Retval
  44.  
  45.  
  46. InitArgs!: procedure expose dsd!.
  47.  
  48.     Arg switches
  49.     Problem = 0
  50.  
  51.     /* Examine switch parameter for proper value */
  52.     Select
  53.       When dsd!.switch = '' then nop
  54.       When pos(dsd!.switch, switches) \== 0 then nop
  55.       Otherwise problem = 1
  56.     End /*select*/
  57.  
  58.     /* Examine Parm1 for value, default to today if null */
  59.     If \problem Then Do
  60.         dsd!.firstparm = space(dsd!.firstparm,'0')
  61.         Select
  62.           When dsd!.firstparm = '' Then Do
  63.                 Select
  64.                     When pos(dsd!.switch,dsd!.param1_USA_Opts) \== 0 then dsd!.firstparm = DATE(U)
  65.                     When pos(dsd!.switch, dsd!.P1TJopts) \== 0 then Do
  66.                         parse value DATE(U) with mm '/' dd '/' yy .
  67.                         dsd!.firstparm = CalcJulian!(mm,dd,yy)
  68.                         End
  69.                     When pos(dsd!.switch,dsd!.P1FJSwitch) \== 0 then dsd!.firstparm = DATE(D)
  70.                     When dsd!.switch = '' Then dsd!.firstparm = DATE(U)
  71.                     Otherwise NOP
  72.                     End
  73.                 End
  74.           When pos(dsd!.switch, dsd!.param1_USA_Opts) \== 0 &,
  75.                ValidUsa!(dsd!.firstparm) Then NOP
  76.           When pos(dsd!.switch, dsd!.P1TJopts) \= 0 &,
  77.                ValidTJulian!(dsd!.firstparm) Then NOP
  78.           When pos(dsd!.switch,dsd!.P1FJSwitch) \== 0 &,
  79.                ValidFJulian!(dsd!.firstparm) Then NOP
  80.           When (dsd!.switch = '') & ValidUsa!(dsd!.firstparm) Then NOP
  81.           Otherwise problem = 1
  82.           End
  83.         End
  84.  
  85.         /* Examine the second parameter for value */
  86.         If \problem Then Do
  87.             dsd!.secondparm = space(dsd!.secondparm,'0')
  88.             Select
  89.               When dsd!.secondparm = '' Then Do
  90.                 Select
  91.                     When pos(dsd!.switch,dsd!.P2UsaOpts) \== 0 then dsd!.secondparm = DATE(U)
  92.                     When pos(dsd!.switch,dsd!.P2FJopts) \== 0 then dsd!.secondparm = '0'
  93.                     Otherwise NOP
  94.                     End /*select*/
  95.                 End /*if parm2 is null*/
  96.               When pos(dsd!.switch,dsd!.P2FJopts) \== 0 & datatype(dsd!.secondparm,'N') then NOP
  97.               When pos(dsd!.switch,dsd!.P2UsaOpts) \== 0 & ValidUsa!(dsd!.secondparm) Then NOP
  98.               Otherwise problem = 1
  99.               End /*select*/
  100.             End /*if not error*/
  101.    Return problem
  102.  
  103.  
  104. GetAnswer!: PROCEDURE EXPOSE dsd!.
  105.  
  106.     Arg SwitchCode, P1, P2
  107.  
  108.     Select
  109.       When switchcode = 'B' then retval = BaseDate!(P1,'01/01/0001')
  110.       When switchcode = 'C' then retval = CenturyDays!(P1)
  111.       When switchcode = 'D' then retval = YearDays!(P1)
  112.       When switchcode = 'E' then retval = European!(P1)
  113.       When switchcode = 'G' then retval = FJ2Gregorian!(dsd!.firstparm)
  114.       When switchcode = 'I' then retval = IncrementDays!(dsd!.firstparm,dsd!.secondparm)
  115.       When switchcode = 'J' then retval = JulianDate!(P1)
  116.       When (switchcode = 'L') | (switchcode = 'N') Then retval = DefaultFunction!(P1)
  117.       When switchcode = 'M' then retval = MonthName!(P1)
  118.       When switchcode = 'O' then retval = OrderedDate!(P1)
  119.       When switchcode = 'P' then retval = BaseDate!(dsd!.firstparm,dsd!.secondparm)
  120.       When switchcode = 'Q' then retval = QuarterNbr!(dsd!.firstparm)
  121.       When switchcode = 'S' then retval = SortedDate!(P1)
  122.       When switchcode = 'T' Then retval = TextDate!(dsd!.firstparm)
  123.       When switchcode = 'U' then retval = P1
  124.       When switchcode = 'V' then retval = 1
  125.       When switchcode = 'W' then retval = DayName!(P1)
  126.       When switchcode = 'Y' then retval = DayNumber!(dsd!.firstparm)
  127.       Otherwise NOP
  128.     End
  129.   Return retval
  130.  
  131. TextDate!: procedure
  132.  
  133.     arg parm1
  134.     parse value parm1 with mm '/' dd '/' yy .
  135.  
  136.     If Left(dd,1) = '0' Then dd = Right(dd,1)
  137.     retval = FindMonthName!(mm) dd || ',' 4Chars!(yy)
  138.     retval = space(retval,'1')
  139.  
  140.    Return retval
  141.  
  142. DefaultFunction!: procedure
  143.  
  144.     arg parm1
  145.     parse value parm1 with mm '/' dd '/' yy .
  146.     retval = Right(dd,2,'0') substr(FindMonthName!(mm),1,3) 4Chars!(yy)
  147.     retval = space(retval,'1')
  148.  
  149.    Return retval
  150.  
  151. CenturyDays!: procedure
  152.  
  153.     arg parm1
  154.     parse value parm1 with mm '/' dd '/' yy .
  155.     yy = 4Chars!(yy)
  156.     century_yr = Century!(yy)
  157.     retval = CalcJulian!(mm,dd,yy) - CalcJulian!(1,1,century_yr) + 1
  158.  
  159.    Return retval
  160.  
  161. YearDays!: procedure
  162.  
  163.     arg parm1
  164.     parse value parm1 with mm '/' dd '/' yy .
  165.     yy = 4Chars!(yy)
  166.     retval = CalcJulian!(mm,dd,yy) - CalcJulian!(01,01,yy) + 1
  167.  
  168.    Return retval
  169.  
  170. QuarterNbr!: procedure
  171.  
  172.     Arg parm
  173.     parse value parm with mm '/' dd '/' yy .
  174.     junk = Abs(mm)
  175.     Select
  176.         When (junk < 4) Then retval = 1
  177.         When (junk > 3) & (junk < 7) Then retval = 2
  178.         When (junk > 6) & (junk < 10) Then retval = 3
  179.         Otherwise retval = 4
  180.         End
  181.   Return retval
  182.  
  183.  
  184. European!: procedure
  185.  
  186.     arg parm1
  187.     parse value parm1 with mm '/' dd '/' yy .
  188.     retval = Space(dd '/' mm '/' yy,'0')
  189.  
  190.    Return retval
  191.  
  192. JulianDate!: procedure
  193.  
  194.     arg parm1
  195.     parse value parm1 with mm '/' dd '/' yy .
  196.     v1 = 2Chars!(yy)
  197.     v2 = YearDays!(parm1)
  198.     retval = v1||right(v2,3,'0')
  199.  
  200.    Return retval
  201.  
  202. MonthName!: procedure
  203.  
  204.     arg parm1
  205.     parse value parm1 with mm '/' .
  206.     retval = FindMonthName!(mm)
  207.    Return retval
  208.  
  209. FindMonthName!: procedure
  210.  
  211.     Arg parm
  212.     retval = Word('January February March April May June',
  213.             ' July August September October',
  214.             ' November December',parm)
  215.   Return retval
  216.  
  217. OrderedDate!: procedure
  218.  
  219.     arg parm1
  220.     parse value parm1 with mm '/' dd '/' yy .
  221.     retval = yy '/' mm '/' dd
  222.     retval = space(retval,'0')
  223.  
  224.    Return retval
  225.  
  226. SortedDate!: procedure
  227.     arg parm1
  228.     parse value parm1 with mm '/' dd '/' yy .
  229.     retval = 4Chars!(yy) 2Chars!(mm) 2Chars!(dd)
  230.     retval = space(retval,'0')
  231.    Return retval
  232.  
  233. DayNumber!: procedure
  234.     arg parm1
  235.     parse value parm1 with mm '/' dd '/' yy .
  236.     yy = 4Chars!(yy)
  237.     retval = WeekDay!(mm,dd,yy)
  238.  
  239.    Return retval
  240.  
  241. DayName!: procedure
  242.     arg parm1
  243.     parse value parm1 with mm '/' dd '/' yy .
  244.     retval = Word('Sunday Monday Tuesday Wednesday',
  245.             ' Thursday Friday Saturday Sunday',WeekDay!(mm,dd,yy))
  246.   Return retval
  247.  
  248. WeekDay!: procedure
  249.     mm = arg(1)
  250.     dd = arg(2)
  251.     yy = arg(3)
  252.     w_var  =     (CalcJulian!(mm,dd,yy) - CalcJulian!(1,1,1984)) // 7
  253.     if w_var >= 0 then retval = w_var + 1
  254.       else retval = w_var + 8
  255.    Return retval
  256.  
  257. FJ2Gregorian!: procedure
  258.  
  259.     arg parm1
  260.     retval =  CalcGreg!(FJul2TJul!(parm1))
  261.  
  262.    Return retval
  263.  
  264. IncrementDays!: PROCEDURE EXPOSE dsd!.
  265.  
  266.     parm1 = arg(1)
  267.     parm2 = arg(2)
  268.     parse value parm1 with mm '/' dd '/' yy .
  269.     Select
  270.       When (parm2 < 0) & (abs(parm2) > (CalcJulian!(mm,dd,yy) - 1721426)) then dsd!.error = 1
  271.       When (parm2 >= 0) & (parm2 > (5373484 - CalcJulian!(mm,dd,yy))) then dsd!.error = 1
  272.       otherwise retval = CalcGreg!(CalcJulian!(mm,dd,yy) + parm2)
  273.       end
  274.  
  275.     Return retval
  276.  
  277. BaseDate!: procedure
  278.  
  279.     parm1 = arg(1)
  280.     parm2 = arg(2)
  281.     parse value parm1 with mm1 '/' dd1 '/' yy1 .
  282.     parse value parm2 with mm2 '/' dd2 '/' yy2 .
  283.     retval = abs(CalcJulian!(mm1,dd1,yy1) - CalcJulian!(mm2,dd2,yy2))
  284.  
  285.    Return retval
  286.  
  287. CalcJulian!: procedure
  288.  
  289.     month = arg(1)
  290.     day   = arg(2)
  291.     year  = arg(3)
  292.     year  = 4Chars!(year)
  293.     numeric digits 15
  294.     If month > 2 then month = month - 3
  295.     else do
  296.         month = month + 9
  297.         year = year - 1
  298.         end
  299.     c = year % 100
  300.     ya = year - 100 * c
  301.     julian_number = (146097 * c  % 4) +    ((1461 * ya) % 4) +,
  302.                        ((153 * month + 2) % 5) + day + 1721119
  303.  
  304.     Return julian_number
  305.  
  306. CalcGreg!: procedure
  307.  
  308.     jn = arg(1)
  309.     numeric digits 15
  310.     jn = jn - 1721119
  311.     year =    ((4 * jn - 1) % 146097)
  312.     jn =    (4 * jn - 1 - 146097 * year)
  313.     day =     jn % 4
  314.     jn =    ((4 * day + 3) % 1461)
  315.     day =    (4 * day + 3 - 1461 * jn)
  316.     day =    ((day + 4) % 4)
  317.     month =    ((5 * day - 3) % 153)
  318.     day   =    (5 * day - 3 - 153 * month)
  319.     day =    ((day + 5) % 5)
  320.     year =    (100 * year + jn)
  321.     If (month < 10) Then month = month + 3
  322.       Else Do
  323.           month = month - 9
  324.           year  = year + 1
  325.           End
  326.   Return Usa4Year!(month,day,year)
  327.  
  328. Usa2Year!: procedure
  329.  
  330.     mm = arg(1)
  331.     dd = arg(2)
  332.     yy = arg(3)
  333.     retval = right(month,2,'0') '/' right(day,2,'0') '/',
  334.              right(year,2,'0')
  335.     retval = space(retval,0)
  336.   Return retval
  337.  
  338. TJul2FJul!: procedure
  339.     true_julian_number = arg(1)
  340.     greg_date = CalcGreg!(true_julian_number)
  341.     greg_year = substr(greg_date,7,4)
  342.     false_julian_day = true_julian_number - CalcJulian!(1,1,greg_year) + 1
  343.     retval = substr(greg_year,3,2)||right(false_julian_day,3,'0')
  344.  
  345.   Return retval
  346.  
  347. FJul2TJul!: procedure
  348.  
  349.     false_julian_number = arg(1)
  350.     false_julian_year   = substr(false_julian_number,1,2)
  351.     false_julian_day    = substr(false_julian_number,3,3)
  352.     retval = CalcJulian!(1,1,false_julian_year) + false_julian_day - 1
  353.   Return retval
  354.  
  355. Usa4Year!: procedure
  356.  
  357.     mm   = arg(1)
  358.     dd   = arg(2)
  359.     yyyy = arg(3)
  360.     retval = right(mm,2,'0') '/' right(dd,2,'0') '/',
  361.              right(yyyy,4,'0')
  362.     retval = space(retval,'0')
  363.  
  364.   Return retval
  365.  
  366. ValidUsa!: procedure
  367.  
  368.     arg mmddyy
  369.  
  370.     parse value mmddyy with mm '/' dd '/' yy .
  371.     retval = 0
  372.  
  373.     If datatype(mm,'N') & datatype(dd,'N') & datatype(yy,'N') Then
  374.         do
  375.           yy = 4Chars!(yy)
  376.           If CalcGreg!(CalcJulian!(mm,dd,yy)) = Usa4Year!(mm,dd,yy) Then retval = 1
  377.         end
  378.  
  379.   Return retval
  380.  
  381. ValidFJulian!: procedure
  382.  
  383.     arg Parm
  384.     Select
  385.       When \datatype(parm,'N') Then retval = 0
  386.       When Length(parm) \== 5 Then retval = 0
  387.       When TJul2FJul!( FJul2TJul!( parm )) \= parm then retval = 0
  388.       Otherwise retval = 1
  389.     End
  390.   Return retval
  391.  
  392. ValidTJulian!: procedure
  393.  
  394.     Arg Parm
  395.  
  396.     Select
  397.       When \ datatype(parm,'N') then retval = 0
  398.       When (parm << 1721426) | (parm >> 5373484) then retval = 0
  399.       otherwise retval = 1
  400.     End
  401.   Return retval
  402.  
  403. Century!: procedure
  404.     Arg yyyy
  405.     retval = 100 * (yyyy % 100)
  406.     If retval < 100 Then retval = 1900
  407.   Return retval
  408.  
  409. 2Chars!: procedure
  410.     Arg retval
  411.     retval = Right(retval,2,'0')
  412.   Return retval
  413.  
  414. 4Chars!: procedure
  415.     Arg retval
  416.     If (Length(retval) < 3) Then retval = retval + 1900
  417.   Return retval
  418.  
  419.