home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / xbase / library / dbase / duflp / dates.prg < prev    next >
Text File  |  1992-06-25  |  36KB  |  924 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: DATES.PRG
  3. *-- Programmer: Ken Mayer (KENMAYER)
  4. *-- Date......: 06/25/1992
  5. *-- Notes.....: These are the date functions/procedures I felt were not as
  6. *--             commonly used as those left behind in PROC.PRG. See README.TXT
  7. *--             for details on the use of this library file.
  8. *-------------------------------------------------------------------------------
  9.  
  10. FUNCTION DateText3
  11. *-------------------------------------------------------------------------------
  12. *-- Programmer..: Miriam Liskin
  13. *-- Date........: 03/02/1992
  14. *-- Notes.......: Display date in format  Month, year
  15. *-- Written for.: dBASE IV, 1.1
  16. *-- Rev. History: 05/21/1991 - original function.
  17. *--               03/02/1992 - This one's Douglas P. Saine's (XRED) invention.
  18. *--               In his words: "I just removed the middle part looking for
  19. *--               the day. For the things I do, I only need the month and
  20. *--               year. (I work for a defense contracter, accuracy of dates
  21. *--               has never been of great concern. <G>)"
  22. *-- Calls.......: None
  23. *-- Called by...: Any
  24. *-- Usage.......: DateText3(<dDate>)
  25. *-- Example.....: ? DateText3(date())
  26. *-- Returns.....: July, 1991
  27. *-- Parameters..: dDate = date to be converted
  28. *-------------------------------------------------------------------------------
  29.  
  30.     parameters dDate
  31.     
  32. RETURN cmonth(dDate)+", "+str(year(dDate),4)
  33. *-- EoF: DateText3()
  34.  
  35. FUNCTION Age2
  36. *-------------------------------------------------------------------------------
  37. *-- Programmer..: Martin Leon (HMAN)
  38. *-- Date........: 04/22/1992
  39. *-- Notes.......: Returns number of full years between two dates, which is
  40. *--               age of a person born on the first date as of the second.
  41. *-- Written for.: dBASE IV, 1.1
  42. *-- Rev. History: 10/23/1991 - original function.
  43. *--               04/22/1992 -- Description modified, parameters changed by
  44. *--               Jay Parsons (JPARSONS).
  45. *-- Calls.......: None
  46. *-- Called by...: Any
  47. *-- Usage.......: Age2(<d1>,<d2>)
  48. *-- Example.....: ? "Joe was "+ltrim(str(age2(dBDay,{10/16/85})))+;
  49. *--                        " on the day of ..."
  50. *-- Returns.....: Numeric value in years
  51. *-- Parameters..: d1 = first date, such as date of birth
  52. *--               d2 = second date, when age is wanted
  53. *-------------------------------------------------------------------------------
  54.  
  55.     parameters d1, d2
  56.     private nYears
  57.     
  58.     nYears = year(d2) - year(d1)
  59.     do case
  60.         case month(d1) > month(d2)
  61.             nYears = nYears - 1
  62.         case month(d1) = month(d2)
  63.             if day(d1) > day(d2)
  64.                 nYears = nYears - 1
  65.             endif
  66.     endcase
  67.  
  68. RETURN nYears
  69. *-- EoF: Age2()
  70.  
  71. FUNCTION IsLeap
  72. *-------------------------------------------------------------------------------
  73. *-- Programmer..: Jay Parsons (JPARSONS)
  74. *-- Date........: 01/13/1992
  75. *-- Notes.......: Is the year given a Leap Year? Year given must be after 1500
  76. *-- Written for.: dBASE IV, 1.1
  77. *-- Rev. History: 11/08/1991 - original function.
  78. *--               01/13/1992 -- updated to handle two digit OR four digit year.
  79. *-- Calls.......: None
  80. *-- Called by...: Any
  81. *-- Usage.......: IsLeap(<nYear>)
  82. *-- Example.....: IsLeap(91)
  83. *-- Returns.....: Logical (.t./.f.) 
  84. *-- Parameters..: nYear  = Numeric form of year -- last two digits (i.e., 91),
  85. *--                        or all four digits (i.e., 1991)
  86. *-------------------------------------------------------------------------------
  87.     
  88.     parameter nYear
  89.     private lReturn
  90.     
  91.     *-- deal with two digit year ...
  92.     if nYear < 100
  93.         nYear = nYear + 100 * int(year(date())/100)
  94.     endif
  95.     
  96.     lReturn = mod(iif(mod(nYear,100)=0,nYear/100,nYear),4)=0
  97.     
  98. RETURN lReturn
  99. *-- EoF: IsLeap()
  100.  
  101. FUNCTION Annivrsry
  102. *-------------------------------------------------------------------------------
  103. *-- Programmer..: David Love (DAVIDLOVE) and Jay Parsons (JPARSONS)
  104. *-- Date........: 11/10/1991
  105. *-- Notes.......: Checks to see if an anniversary date falls within a range of
  106. *--               dates (handy for mailings for organizations, checking to see
  107. *--               if someone's birthday falls within certain dates, etc.
  108. *-- Written for.: dBASE IV, 1.1
  109. *-- Rev. History: None
  110. *-- Calls.......: AGE2()               Function in DATES.PRG
  111. *-- Called by...: Any
  112. *-- Usage.......: Annivrsry(<dTest>,<dBegin>,<dEnd>)
  113. *-- Example.....: if Annivrsry(dBDay,{03/01/91},{03/31/91})
  114. *--                  *-- do something
  115. *--               endif
  116. *-- Returns.....: .t. if a date (dTest) falls within the period beginning at
  117. *--               dBegin or ending at dEnd, inclusive. .F. for any other
  118. *--               occurance, including invalid ranges or blank dates.
  119. *-- Parameters..: dTest  = Date being tested for ...
  120. *--               dBegin = Beginning of range
  121. *--               dEnd   = End of range
  122. *-------------------------------------------------------------------------------
  123.  
  124.     parameters dTest, dBegin, dEnd
  125.     private nYears
  126.     
  127.     nYears = 0
  128.     if dBegin <= dEnd .AND. dTest <= dEnd        && will be false if blank
  129.       nYears = age2(dTest,dEnd) - iif(dTest < dBegin,age2(dTest,dBegin-1),0)
  130.     endif
  131.  
  132. RETURN nYears > 0
  133. *-- EoF: Annivrsry()
  134.  
  135. FUNCTION AddMonths
  136. *-------------------------------------------------------------------------------
  137. *-- Programmer..: Jay Parsons (JPARSONS)
  138. *-- Date........: 11/10/1991
  139. *-- Notes.......: Finds same day as given date N months ahead. 
  140. *--               This function will return the first day of the following
  141. *--               month if there is no date in the month otherwise returned 
  142. *--               and nMonths is positive, or the last day of the month if 
  143. *--               nMonths is negative.  That is, a call with {01/31/91} 
  144. *--               (January 31, 1991) and 1 would yield March 1, there being 
  145. *--               no February 31.
  146. *--                 Do not use this function successively to find first the
  147. *--               date one month ahead, then the date one month beyond that.  
  148. *--               Instead, to find the date two months ahead from the original 
  149. *--               date, call this function with the original date and 
  150. *--               nMonths = 2.  Otherwise, in the example, you'll get April 1 
  151. *--               the second time rather than the correct March 31.
  152. *-- Written for.: dBASE IV, 1.1
  153. *-- Rev. History: None
  154. *-- Calls.......: None
  155. *-- Called by...: Any
  156. *-- Usage.......: AddMonths(<dDate>,<nMonths>)
  157. *-- Example.....: ?AddMonths({01/01/91},1)
  158. *-- Returns.....: Date
  159. *-- Parameters..: dDate   = Date being tested for ...
  160. *--               dMonths = Number of months "ahead"
  161. *-------------------------------------------------------------------------------
  162.     
  163.     parameters dDate, nMonths
  164.     private dNew, dTest,dReturn
  165.     
  166.     dNew = dDate - day(dDate)+ 15 + 30.436875 * nMonths  && middle of month
  167.     dTest = dNew - day(dNew) + day(dDate)
  168.     dReturn = iif(month(dTest) = month(dNew),dTest, ;
  169.            dTest - day(dTest) + iif(nMonths > 0, 1, 0))
  170.  
  171. RETURN dReturn
  172. *-- EoF: AddMonths()
  173.  
  174. FUNCTION AddYears
  175. *-------------------------------------------------------------------------------
  176. *-- Programmer..: Jay Parsons (JPARSONS)
  177. *-- Date........: 11/14/1991
  178. *-- Notes.......: Finds same day as given date N years ahead. 
  179. *--               Using this function dBASE IV will take care of converting 
  180. *--               February 29 to March 1 if moving from a leap to a non-leap
  181. *--               year.  However, neither may be used backwards (negative 
  182. *--               value of nYears) since the date a year before February 29,
  183. *--               1992 will be returned as March 1, 1991, not February 28, 1991.
  184. *--               If you must move back, either check explicitly for February 29
  185. *--               as the original date or add code as in the addmonths()
  186. *--               function to test for the date returned being of a different
  187. *--               month than the original and, if it is, to subtract its day().
  188. *-- Written for.: dBASE IV, 1.1
  189. *-- Rev. History: 11/10/1991 - original function.
  190. *--               11/14/1991 - Ken Mayer - expanded out to make it easier
  191. *--                          to read, and see what's happening.
  192. *-- Calls.......: None
  193. *-- Called by...: Any
  194. *-- Usage.......: AddYears(<dDate>,<nYears>)
  195. *-- Example.....: ?AddYears({01/01/91},1)
  196. *-- Returns.....: Date
  197. *-- Parameters..: dDate  = Date being tested for ...
  198. *--               dYears = Number of Years "ahead"
  199. *-------------------------------------------------------------------------------
  200.     
  201.     parameters dDate, nYears
  202.     private cYear,cMonth,cDay,dReturn
  203.     
  204.     cYear = str(year(dDate) + nYears)
  205.     cMonth = right(str(month(dDate) + 100),2)
  206.     cDay = right(str(day(dDate) + 100),2)
  207.     dReturn = ctod(cMonth+"/"+cDay+"/"+cYear)
  208.         
  209. RETURN dReturn
  210. *-- EoF: AddYears()
  211.  
  212. FUNCTION DoY
  213. *-------------------------------------------------------------------------------
  214. *-- Programmer..: Jay Parsons (JPARSONS)
  215. *-- Date........: 11/14/1991
  216. *-- Notes.......: Returns the day of the year of a date (from beginning of the
  217. *--               year).
  218. *-- Written for.: dBASE IV, 1.1
  219. *-- Rev. History: 11/10/1991 - original function.
  220. *--               11/14/1991 - Ken Mayer - expanded for readability ...
  221. *-- Calls.......: None
  222. *-- Called by...: Any
  223. *-- Usage.......: DoY(<dDate>)
  224. *-- Example.....: ?DoY({01/01/91})
  225. *-- Returns.....: Numeric value of day of year
  226. *-- Parameters..: dDate  = Date being tested for ...
  227. *-------------------------------------------------------------------------------
  228.  
  229.     parameters dDate
  230.     private cYear,dStart,nReturn
  231.     
  232.     cYear = right(str(year(dDate)),2)
  233.     dStart = ctod("01/01/"+cYear)
  234.     nReturn = dDate+1 - dStart
  235.     
  236. RETURN nReturn
  237. *-- EoF: DoY()
  238.  
  239. FUNCTION WeekNo
  240. *-------------------------------------------------------------------------------
  241. *-- Programmer..: Jay Parsons (JPARSONS)
  242. *-- Date........: 11/14/1991
  243. *-- Notes.......: Returns the week number of the year of a date (from beginning 
  244. *--               of the year).
  245. *--               To use this function but start the week on a different day,
  246. *--               change the 1 in the second-to-last line, the dow() of Sunday, 
  247. *--               to the dow() of the day that should start each week, 2 for 
  248. *--               Monday through 7 for Saturday.
  249. *-- Written for.: dBASE IV, 1.1
  250. *-- Rev. History: 11/10/1991 - original function.
  251. *--               11/14/91 - Ken Mayer - expanded for readability ...
  252. *-- Calls.......: None
  253. *-- Called by...: Any
  254. *-- Usage.......: WeekNo(<dDate>)
  255. *-- Example.....: ?WeekNo({01/01/91})
  256. *-- Returns.....: Numeric value of week number
  257. *-- Parameters..: dDate  = Date being tested for ...
  258. *-------------------------------------------------------------------------------
  259.     
  260.     parameters dDate
  261.     private dBaseDate,nReturn
  262.     
  263.     dBaseDate = dDate - doy(dDate)
  264.     dBaseDate = dBaseDate - mod(dow(dBaseDate - 1), 7)
  265.     nReturn = int((dDate - dBaseDate) / 7)
  266.  
  267. RETURN nReturn
  268. *-- EoF: WeekNo()
  269.  
  270. FUNCTION Holiday
  271. *-------------------------------------------------------------------------------
  272. *-- Programmer..: Jay Parsons (JPARSONS)
  273. *-- Date........: 04/22/1992
  274. *-- Notes.......: Returns the date of a specific "floating" holiday (using 
  275. *--               chart below) for current year. 
  276. *--               Name                 Code
  277. *--               President's Day      P
  278. *--               Daylight saving time D
  279. *--               Memorial Day         M
  280. *--               Labor Day            L
  281. *--               Columbus Day         C
  282. *--               Resume Standard time S
  283. *--               Election Day         E
  284. *--               Thanksgiving         T
  285. *--               Advent (1st Sunday)  A
  286. *-- Written for.: dBASE IV, 1.1
  287. *-- Rev. History: 11/01/1991 - original function.
  288. *--               11/15/1991 - Ken Mayer - takes a code and year -- I basically
  289. *--               simplified the use of the function.
  290. *--               04/22/1992 - Jay Parsons - added 'D' and 'S' options
  291. *--               (daylight saving time and return to standard)
  292. *-- Calls.......: None
  293. *-- Called by...: Any
  294. *-- Usage.......: Holiday(<nYear>,"<cCode>")
  295. *-- Example.....: ? Holiday(92,"P")   && date of President's day, 1992
  296. *-- Returns.....: Date of specified holiday ...
  297. *-- Parameters..: nYear = Year you need the holiday date for ...
  298. *--               cCode = one of the codes above for specific holiday
  299. *-------------------------------------------------------------------------------
  300.  
  301.     parameters nYear,cCode
  302.     private dBaseDate,cCode,cYear,nDoW,cFirst,dReturn
  303.     
  304.     cCode = upper(cCode)
  305.     cYear = ltrim(str(nYear))
  306.     do case
  307.                 case cCode = "P"    && President's day (3rd Mon of Feb)
  308.             cFirst = "02/15/"
  309.             nDoW   = 2
  310.         case cCode = "D"    && Daylight time U.S. (1st Sun of April)
  311.             cFirst = "04/01/"
  312.             nDoW   = 1
  313.                 case cCode = "M"    && Memorial day  (last Mon of May)
  314.                         cFirst = "05/25/"
  315.             nDoW   = 2
  316.         case cCode = "L"    && Labor day  (1st Mon of Sep)
  317.                         cFirst = "09/01/"
  318.             nDoW   = 2
  319.         case cCode = "C"    && Columbus Day  (2nd Mon of Oct)
  320.                         cFirst = "10/08/"
  321.             nDoW   = 2
  322.                 case cCode = "S"    && Standard Time U.S. (Last Sun of Oct)
  323.             cFirst = "10/25/"
  324.             nDoW = 1
  325.         case cCode = "E"    && Election Day  (1st Tues of Nov not Nov 1)
  326.                         cFirst = "11/02/"
  327.             nDoW   = 3
  328.         case cCode = "T"    && Thanksgiving (fourth Thursday of Nov)
  329.                         cFirst = "11/22/"
  330.             nDoW   = 5
  331.         case cCode = "A"    && 1st Sun of Advent (Sunday closest Nov 30)
  332.                         cFirst = "11/27/"
  333.             nDoW   = 1
  334.         otherwise
  335.             return {}        && if not one of above, return blank date ...
  336.     endcase
  337.     dFirst = ctod(cFirst + cYear)
  338.         dBaseDate = dFirst + 7 - nDow
  339.         dReturn = dBaseDate - dow( dBaseDate ) + nDow    && dow( dBaseDate )
  340.     
  341. RETURN dReturn
  342. *-- EoF: Holiday()
  343.  
  344. FUNCTION EasterDay
  345. *-------------------------------------------------------------------------------
  346. *-- Programmer..: Jay Parsons (JPARSONS)
  347. *-- Date........: 04/22/1992
  348. *-- Notes.......: Returns date of Easter for given year after 1582.
  349. *--               This gives the date of Easter as celebrated by Western
  350. *--               churches. The algorithm is from Example 1.3.2.14 of 
  351. *--               Volume I of "The Art of Computer Programming", 2nd
  352. *--               Edition, Addison-Wesley, Reading, MA, 1973, by Donald
  353. *--               Knuth, who attributes it to Aloysius Lilius of Naples
  354. *--               and Christopher Clavius of Germany, both floruit 1582.
  355. *-- Written for.: dBASE IV, 1.1
  356. *-- Rev. History: 11/18/1991 - original function.
  357. *--               04/22/1992 - Jay Parsons - Notes expanded.
  358. *-- Calls.......: None
  359. *-- Called by...: Any
  360. *-- Usage.......: EasterDay(<Year>)
  361. *-- Example.....: EasterDay(91)
  362. *-- Returns.....: Date (in dBASE date format) of Easter
  363. *-- Parameters..: nYear  =  Numeric form of year - YYYY or YY format
  364. *-------------------------------------------------------------------------------
  365.     
  366.     parameters nYear
  367.     private nGolden,nCentury,nNoLeap,nMoonOrbit,nEPact,nPascalMoon,dReturn
  368.     
  369.     *-- deal with two digit year ...
  370.     if nYear < 100
  371.         nYear = nYear + 100 * int(year(date())/100)
  372.     endif
  373.     
  374.     nGolden     = 1+mod(nYear,19)
  375.     nCentury    = floor(nYear/100)+1
  376.     nNoLeap     = floor(3*nCentury/4)-12
  377.     nMoonOrbit  = floor((8*nCentury+5)/25)-5
  378.     nEPact      = mod(11*nGolden+nMoonOrbit-nNoLeap+20,30)
  379.     nEPact      = nEPact+iif(nEPact=24.or.(nEPact=25.and.nGolden>11),1,0)
  380.     nPascalMoon = ctod("03/21/"+str(nYear))+mod(53-nEPact,30)
  381.     dReturn     = nPascalMoon+8-dow(nPascalMoon)
  382.  
  383. RETURN dReturn
  384. *-- EoF: EasterDay()
  385.  
  386. FUNCTION nDoW
  387. *-------------------------------------------------------------------------------
  388. *-- Programmer..: Jay Parsons (JPARSONS) 
  389. *-- Date........: 04/22/1992
  390. *-- Notes.......: Numeric Day of Week -- returns the numeric value of the
  391. *--               day of week for use by some of the other date functions
  392. *--               below.
  393. *-- Written for.: dBASE IV, 1.1
  394. *-- Rev. History: 02/25/1992 - original function.
  395. *--               04/22/1992 - Jay Parsons - modified example/descriptions,
  396. *--               added ltrim() of argument.
  397. *-- Calls.......: None
  398. *-- Called by...: None
  399. *-- Usage.......: nDoW(<cDay>)
  400. *-- Example.....: nDay = nDoW("Tues")
  401. *-- Returns.....: Numeric dow value of day of week given
  402. *-- Parameters..: cDay  -- Character memvar containing "day" of week ('MONDAY',
  403. *--                        etc ...)
  404. *-------------------------------------------------------------------------------
  405.  
  406.     parameter cDay
  407.     
  408. RETURN at(upper(left(ltrim(cDay),3)),"   SUN MON TUE WED THU FRI SAT")/4
  409. *-- nDoW()
  410.  
  411. FUNCTION FWDoM
  412. *-------------------------------------------------------------------------------
  413. *-- Programmer..: Jay Parsons (JPARSONS) 
  414. *-- Date........: 02/25/1992
  415. *-- Notes.......: First Working Day of the Month -- originally I used Dan
  416. *--               Madoni's stuff from Technotes, but Jay came along and pointed
  417. *--               out an easier way to do this. SO, here we have a shorter,
  418. *--               faster, FWDoM function. This returns the first WORKING
  419. *--               day of the month.
  420. *-- Written for.: dBASE IV, 1.1
  421. *-- Rev. History: None
  422. *-- Calls.......: None
  423. *-- Called by...: Any
  424. *-- Usage.......: FWDoM(<dDate>)
  425. *-- Example.....: ? CDoW( FWDoM(DATE()) ) (character day of week ...)
  426. *-- Returns.....: dBASE Date
  427. *-- Parameters..: dDate  -- date to work from ...
  428. *-------------------------------------------------------------------------------
  429.  
  430.     parameters dDate
  431.     private dReturn, nDay
  432.     
  433.     dReturn = dDate - day(dDate) + 1
  434.     nDay = DoW(dReturn)
  435.     
  436. RETURN dReturn + iif(nDay=7,2,iif(nDow=1,1,0))
  437. *-- EoF: FWDoM()
  438.  
  439. FUNCTION LWDoM
  440. *-------------------------------------------------------------------------------
  441. *-- Programmer..: Jay Parsons (JPARSONS)
  442. *-- Date........: 02/25/1992
  443. *-- Notes.......: Last Working Day of the Month -- function from Jay (new
  444. *--               version like FWDoM) to return the last working day of the
  445. *--               month. Give a date, the function returns the last WORKING day 
  446. *--               of the month. This has a companion function, giving the 
  447. *--               FIRST working day (see above).
  448. *-- Written for.: dBASE IV, 1.1
  449. *-- Rev. History: None
  450. *-- Calls.......: LDOM()               Function in DATES.PRG
  451. *-- Called by...: Any
  452. *-- Usage.......: LWDoM(<dDate>)
  453. *-- Example.....: ? LWDoM(DATE())
  454. *-- Returns.....: dBASE Date
  455. *-- Parameters..: dDate  -- date to work from ...
  456. *-------------------------------------------------------------------------------
  457.  
  458.     parameters dDate
  459.     private dReturn, nDay
  460.     
  461.     dReturn = ldom(dDate)
  462.     nDay = DoW(dReturn)
  463.  
  464. RETURN dReturn - iif(nDay=7,1,iif(nDay=1,2,0))
  465. *-- EoF: LWDoM()
  466.  
  467. FUNCTION FDoD
  468. *-------------------------------------------------------------------------------
  469. *-- Programmer..: Jay Parsons (JPARSONS)
  470. *-- Date........: 02/25/1992
  471. *-- Notes.......: First Day of Date. This function works to give the first
  472. *--               date in a given month (using a date) that a specific day
  473. *--               of the week occurs (i.e., first Monday of the month).
  474. *--               It returns a blank date if the day of week doesn't match, 
  475. *--               but is not case sensitive. New, slimmer, sleeker version
  476. *--               by Jay ...
  477. *-- Written for.: dBASE IV, 1.1
  478. *-- Rev. History: None
  479. *-- Calls.......: NDOW()               Function in DATES.PRG
  480. *-- Called by...: Any
  481. *-- Usage.......: FDoD(<dDate>,"<cDay>")
  482. *-- Example.....: ? FDoD(DATE(),"Tuesday")
  483. *-- Returns.....: dBASE Date
  484. *-- Parameters..: dDate  -- date to work from ...
  485. *--               cDay   -- Day of week to look for ...
  486. *-------------------------------------------------------------------------------
  487.  
  488.     parameters dDate, cDay
  489.     private dReturn, nDay
  490.     
  491.     nDay = nDoW(cDay)
  492.     dReturn = dDate - day(dDate) + 1
  493.     
  494. RETURN dReturn + mod(nDay+7 - DoW(dReturn),7)
  495. *-- EoF: FDoD()
  496.  
  497. FUNCTION LDoD
  498. *-------------------------------------------------------------------------------
  499. *-- Programmer..: Jay Parsons (JPARSONS)
  500. *-- Date........: 02/25/1992
  501. *-- Notes.......: Last Day of Date. This function works to give the last
  502. *--               date in a given month (using a date) that a specific day
  503. *--               of the week occurs (i.e., last Monday of the month).
  504. *--               It returns a blank date if the day of week doesn't match, 
  505. *--               but is not case sensitive. New version as FDoD() ...
  506. *-- Written for.: dBASE IV, 1.1
  507. *-- Rev. History: None
  508. *-- Calls.......: LDOM()               Function in DATES.PRG
  509. *--               NDOW()               Function in DATES.PRG
  510. *-- Called by...: Any
  511. *-- Usage.......: LDoD(<dDate>,"<cDay>")
  512. *-- Example.....: ? LDoD(DATE(),"Tuesday")
  513. *-- Returns.....: dBASE Date
  514. *-- Parameters..: dDate  -- date to work from ...
  515. *--               cDay   -- Day of week to look for ...
  516. *-------------------------------------------------------------------------------
  517.  
  518.     parameters dDate, cDay
  519.     private dReturn
  520.     
  521.     nDay = nDoW(cDay)
  522.     dReturn = ldom(dDate)
  523.     
  524. RETURN dReturn - mod(dow(dReturn) + 7 - nDay,7)
  525. *-- EoF: LDoD()
  526.  
  527. FUNCTION LDoM
  528. *-------------------------------------------------------------------------------
  529. *-- Programmer..: Ken Chan (HazMatZak)
  530. *-- Date........: 02/26/1992
  531. *-- Notes.......: Last Day of Month -- Zak wrote this one up as a MUCH shorter
  532. *--               and more straightforward version of the one I did. >sigh<.
  533. *--               This function returns the date of the last day of the month.
  534. *-- Written for.: dBASE IV, 1.1
  535. *-- Rev. History: None
  536. *-- Calls.......: None
  537. *-- Called by...: Any
  538. *-- Usage.......: LDoM(<dDate>)
  539. *-- Example.....: ? LDoM(DATE())
  540. *-- Returns.....: dBASE Date
  541. *-- Parameters..: dDate  -- date to work from ...
  542. *-------------------------------------------------------------------------------
  543.  
  544.     parameter dDate
  545.     private dNxtMonth
  546.     
  547.     dNxtMonth = dDate - day(dDate) + 45 && middle of next month
  548.     
  549. RETURN dNxtMonth - day(dNxtMonth)
  550. *-- EoF: LDoM()
  551.  
  552. FUNCTION NumDoD
  553. *-------------------------------------------------------------------------------
  554. *-- Programmer..: Ken Mayer
  555. *-- Date........: 02/24/1992
  556. *-- Notes.......: This function will return the x daytype of a month.
  557. *--               Example: what if you need the third Monday of the month?
  558. *-                Send to this function a date (any date) of the month,
  559. *--               the number you need (first, second...) and the day you
  560. *--               need. The function is not case specific.
  561. *-- Written for.: dBASE IV, 1.1
  562. *-- Rev. History: None
  563. *-- Calls.......: FDOD()               Function in DATES.PRG
  564. *--               NDOW()               Function in DATES.PRG
  565. *-- Called by...: Any
  566. *-- Usage.......: NumDoD(<dDate>,<nDay>,<cDay>)
  567. *-- Example.....: ?NumDoD({02/03/92},3,"Monday")
  568. *-- Returns.....: Date
  569. *-- Parameters..: dDate  =  Any date of the month (and year) needed
  570. *--               nDay   =  Number of day you need (i.e., third cDay of month)
  571. *--               cDay   =  Character value of day (Monday, Tuesday, etc.)
  572. *-------------------------------------------------------------------------------
  573.  
  574.     parameter dDate, nDay, cDay
  575.     private dReturn
  576.     
  577.     dReturn = FDoD(dDate,cDay)  && get the first day of this type of the month
  578.     if nDay > 1                 && if it's greater than one, add 7 (1 week) for
  579.                                 && required # ...
  580.         dReturn = dReturn + ((nDay-1)*7)
  581.     endif
  582.     
  583. RETURN dReturn
  584. *-- EoF: NumDoD()
  585.  
  586. FUNCTION WDiF
  587. *-------------------------------------------------------------------------------
  588. *-- Programmer..: Martin Leon (HMAN)
  589. *-- Date........: 12/12/1991
  590. *-- Notes.......: This UDF is designed to return the first Working Day In the
  591. *--               Future of a specific date, based on a # of days. For example,
  592. *--               to return the first working day, 10 days from the current
  593. *--               date, you can pass the parameters of DATE() and 10. If the
  594. *--               date 10 days from today is a working day, that date is
  595. *--               returned, otherwise, the function returns the next closest
  596. *--               working day. You may, if you wish, use a database to
  597. *--               store holidays. If you do, the database must be laid out
  598. *--               with the following structure:
  599. *--                 HOLIDAYS.DBF
  600. *--                 Field name  Field type  MDX?
  601. *--                 HOLIDATE      Date       Y
  602. *--               Once the UDF has been run, the database is left open in 
  603. *--               whatever work area it was opened.  If another database was 
  604. *--               in use at the time of calling the UDF, it becomes the active
  605. *--               database after the UDF is done. The reason for leaving the 
  606. *--               database open is that this speeds up the process when you 
  607. *--               call on the UDF several times in a row.
  608. *--               To ensure that holidays are working properly, there are
  609. *--               3 assumptions made by this function, and all must be true.
  610. *--               These are: 1) WDIF() assumes that your holidays database
  611. *--               has an index tag on the HOLIDATE field, 2) there are no
  612. *--               duplicate entries, and 3) none of the holidays in the data-
  613. *--               base fall on a weekend date. A simple method for insuring
  614. *--               the last is:
  615. *--                 USE Holidays
  616. *--                 DELETE FOR DOW( Holidate ) = 7 .or. DOW( Holidate ) = 1
  617. *--                 PACK
  618. *--               If you do not have a Holidays database, this function will 
  619. *--               work fine ...
  620. *-- Written for.: dBASE IV, 1.1
  621. *-- Rev. History: None
  622. *-- Calls.......: None
  623. *-- Called by...: Any
  624. *-- Usage.......: WDIF(<dStart>,<nDays>)
  625. *-- Example.....: ?WDiF(date(),10)
  626. *-- Returns.....: dBASE date
  627. *-- Parameters..: dStart  =  Date to start counting from
  628. *--               nDays   =  Number of working days in the future ...
  629. *-------------------------------------------------------------------------------
  630.  
  631.     parameter dStart, nWDays
  632.     private nweeks, n, nXtraDays, nHDays, dReturn, cNear, cAlias, dTemp
  633.     
  634.     store 0 to nweeks, n, nHDays, nXtraDays
  635.     store {} to dReturn, dTemp
  636.     store "" to cNear, cAlias
  637.     cNear = set("NEAR")
  638.     
  639.     if nWDays = 0
  640.        RETURN 0
  641.     endif
  642.     
  643.     if type("dStart") + type("nWDays") # "DN"
  644.        RETURN -1
  645.     endif
  646.     
  647.     *-- Rough guestimate of future date within a week
  648.     nweeks = int( nWDays / 5 )
  649.     dReturn = dStart + (nweeks * 7)
  650.     
  651.     *-- Left over number of days from integer division above
  652.     nXtraDays = mod( nWDays, 5 )
  653.     
  654.     *-- Check to see if Holidays database is already in use.  This is
  655.     *-- done so that we don't have to close and open the database for
  656.     *-- every call to this UDF. The first call opens it and subsequent
  657.     *-- calls select it as needed.
  658.     
  659.     *-- Check all work areas for holidays database, starting with work
  660.     *-- area 10 since this is most likely where it was opened the
  661.     *-- first time.
  662.     n = 10
  663.     do while .not. "HOLIDAYS" $ alias( n )
  664.        n = n - 1
  665.        if n = 0
  666.           exit
  667.        endif
  668.     enddo
  669.     *-- If it is open, store current alias name and select holidays
  670.     *-- database.
  671.     if n # 0
  672.        cAlias = alias()
  673.        select (alias(n))
  674.     else
  675.        *-- If it isn't the currently selected database,
  676.        *-- make sure it exists and use it and select it.
  677.        if file( "HOLIDAYS.DBF" )
  678.           cAlias = alias()
  679.           use Holidays order Holidate in select()
  680.           select Holidays
  681.        endif
  682.     endif
  683.     *-- If it's active now ...
  684.     if alias() = "HOLIDAYS"
  685.        *-- make sure it's in Holidate order, and ...
  686.        if order() # "HOLIDATE"
  687.           set order to Holidate
  688.        endif
  689.        set near on
  690.        *-- count all records in holiday database that fall within the
  691.        *-- range of the starting date and the rough guestimate date.
  692.        seek dStart
  693.        *-- don't count starting day if it's in Holidays database.
  694.        if dStart = Holidate
  695.           skip
  696.        endif
  697.        scan while dReturn >= Holidate 
  698.           nHDays = nHDays + 1
  699.        endscan
  700.        set near off
  701.     endif
  702.     
  703.     *-- Add holidays to "left over" days from original guestimate
  704.     nXtraDays = nXtraDays + nHDays
  705.     
  706.     *-- Add extra days one day at a time to the original guestimate,
  707.     *-- skipping over holidays and weekends.
  708.     
  709.     do while nXtraDays > 0
  710.        dReturn = dReturn + 1
  711.        if alias() = "HOLIDAYS"
  712.           if seek(dReturn)
  713.              loop
  714.           endif
  715.        endif
  716.        if dow( dReturn ) = 7 .or. dow( dReturn ) = 1
  717.           loop
  718.        endif
  719.        nXtraDays = nXtraDays - 1
  720.     enddo
  721.     
  722.     *-- If return date falls on Saturday or Sunday, "re-wind" to Friday.
  723.     dReturn = dReturn - ;
  724.        iif( dow( dReturn ) = 7, 1, iif( dow(dReturn) = 1, 2, 0 ))
  725.     
  726.     *-- If another database was origally in use, make it the active
  727.     *-- database again.
  728.     if "" # cAlias
  729.        select (cAlias)
  730.     endif
  731.     *-- set NEAR back to what it was orginally.
  732.     set near &cNear
  733.  
  734. RETURN dReturn
  735. *-- EoF: WDiF()
  736.  
  737. FUNCTION StoD
  738. *-------------------------------------------------------------------------------
  739. *-- Programmer..: Jay Parsons (JPARSONS)
  740. *-- Date........: 11/10/91
  741. *-- Notes.......: Convert string YYYYMMDD or YYMMDD to a date regardless of
  742. *--               SET DATE. 
  743. *-- Written for.: dBASE IV, 1.1
  744. *-- Rev. History: None
  745. *-- Calls.......: None
  746. *-- Called by...: Any
  747. *-- Usage.......: StoD("<cString>")
  748. *-- Example.....: ?StoD("19910101")
  749. *-- Returns.....: Date
  750. *-- Parameters..: <cString> = Date string you wish converted to "normal" dBASE
  751. *--                           date. Must be in either YYYYMMDD or YYMMDD format.
  752. *-------------------------------------------------------------------------------
  753.  
  754.     parameters cString
  755.     private dTest, cMonth, cDay, cYear, dReturn
  756.     
  757.     dTest = ctod("01/02/03")
  758.     if len(cString) < 8
  759.         cString = left(str(year(date()),4),2) + cString
  760.     endif
  761.     cYear  = left(cString, 4)
  762.     cMonth = substr(cString, 5, 2)
  763.     cDay   = right(cString, 2)
  764.     do case
  765.         case month(dTest) = 1
  766.             dReturn = ctod(cMonth + "/" + cDay + "/" + cYear)
  767.         case day(dTest) = 1
  768.             dReturn = ctod(cDay + "/" + cMonth + "/" + cYear)
  769.         otherwise
  770.             dReturn = ctod(cYear + "/" + cMonth + "/" + cDay)
  771.     endcase
  772.  
  773. RETURN dReturn
  774. *-- EoF: StoD()
  775.  
  776. FUNCTION Quarter
  777. *-------------------------------------------------------------------------------
  778. *-- Programmer..: Bowen Moursund (BOWEN)
  779. *-- Date........: 02/03/1992
  780. *-- Notes.......: Returns the quarter of the year of a specific date ...
  781. *-- Written for.: dBASE IV, 1.1
  782. *-- Rev. History: None
  783. *-- Calls.......: None
  784. *-- Called by...: Any
  785. *-- Usage.......: Quarter(<dDate>)
  786. *-- Example.....: ?Quarter({05/25/1992})
  787. *-- Returns.....: Numeric (integer) value from 1 to 4 (or 0 on error ...)
  788. *-- Parameters..: dDate = date to be checked
  789. *-------------------------------------------------------------------------------
  790.  
  791.     Parameter dDate
  792.  
  793. RETURN iif(type("dDate")="D",ceiling(month(dDate)/3),0)
  794. *-- EoF: Quarter()
  795.  
  796. FUNCTION Dat2Jul
  797. *-------------------------------------------------------------------------------
  798. *-- Programmer..: Jay Parsons (JPARSONS)
  799. *-- Date........: 03/01/92
  800. *-- Notes.......: Converts dBASE date to Julian # of days (from January 1,
  801. *--               3713 B.C.)
  802. *-- Rev. History: None
  803. *-- Written for.: dBASE IV
  804. *-- Rev. History: None
  805. *-- Calls.......: None
  806. *-- Called by...: Any
  807. *-- Usage.......: Dat2Jul("<dDate>")
  808. *-- Example.....: ?Dat2Jul(date())
  809. *-- Returns.....: Numeric
  810. *-- Parameters..: dDate = Date to convert to Julian ...
  811. *-------------------------------------------------------------------------------
  812.  
  813.     PARAMETERS dDate
  814.     
  815. RETURN 2415386 + dDate - ctod( "01/01/01" )
  816. *-- EoF: Dat2Jul()
  817.  
  818. FUNCTION Jul2Dat
  819. *-------------------------------------------------------------------------------
  820. *-- Programmer..: Jay Parsons (JPARSONS)
  821. *-- Date........: 03/01/92
  822. *-- Notes.......: Converts Julian # of days to dBASE Date
  823. *-- Rev. History: None
  824. *-- Written for.: dBASE IV
  825. *-- Rev. History: None
  826. *-- Calls.......: None
  827. *-- Called by...: Any
  828. *-- Usage.......: Jul2Dat(nJulian)
  829. *-- Example.....: ?Jul2Dat(2448691)
  830. *-- Returns.....: Date
  831. *-- Parameters..: nJulian = Julian date to convert to dBase Date
  832. *-------------------------------------------------------------------------------
  833.  
  834.     parameters nJulian
  835.     
  836. RETURN ctod( "01/01/01" ) + (nJulian - 2415386)
  837. *-- EoF: Jul2Dat()
  838.  
  839. FUNCTION DateSet
  840. *-------------------------------------------------------------------------------
  841. *-- Programmer..: Jay Parsons (JPARSONS)
  842. *-- Date........: 03/01/92
  843. *-- Notes.......: Returns string giving name of current DATE format
  844. *--               This is not needed in Version 1.5, in which set("DATE")
  845. *--               returns the format.  Unlike that function in 1.5, this
  846. *--               one cannot distinguish between date formats set with
  847. *--               different terms that amount to the same thing:
  848. *--                     DMY = BRITISH = FRENCH
  849. *--                     MDY = AMERICAN
  850. *--                     YMD = JAPAN
  851. *--               If your users will be using one of these formats and
  852. *--               are sensitive about the name, substitute the one they
  853. *--               want for the equivalent in this function.
  854. *-- Rev. History: None
  855. *-- Written for.: dBASE IV, versions below 1.5
  856. *-- Rev. History: None
  857. *-- Calls.......: None
  858. *-- Called by...: Any
  859. *-- Usage.......: DateSet()
  860. *-- Example.....: ?DateSet()
  861. *-- Returns.....: Character
  862. *-- Parameters..: None
  863. *-------------------------------------------------------------------------------
  864.  
  865.     private cCent, cTestdate, cDelimiter
  866.     cCent = set( "CENTURY" )
  867.     set century off
  868.     cTestdate = ctod( "01/02/03" )
  869.     cDelimiter = substr( dtoc( cTestdate ), 3, 1 )
  870.     set century &cCent
  871.     do case
  872.       case month( cTestdate ) = 1
  873.         RETURN iif( cDelimiter = "-", "USA", "MDY" )
  874.       case day( cTestdate ) = 1
  875.         RETURN iif( cDelimiter = "/", "DMY", ;
  876.           iif( cDelimiter = ".", "GERMAN", "ITALIAN" ) )
  877.       otherwise
  878.         RETURN iif( cDelimiter = ".", "ANSI", "YMD" )
  879.     endcase
  880.     
  881. *-- EoF: DateSet()
  882.  
  883. FUNCTION FrstNxtMth
  884. *-------------------------------------------------------------------------------
  885. *-- Programmer..: Todd Barry (TODDBARRY)
  886. *-- Date........: 04/04/1992
  887. *-- Notes.......: Returns first day of next month
  888. *-- Written for.: dBASE IV, 1.1
  889. *-- Rev. History: None
  890. *-- Calls.......: None
  891. *-- Called by...: Any
  892. *-- Usage.......: FrstNxtMth(<dDate>)
  893. *-- Example.....: FrstNxtMth( dDate )
  894. *-- Returns.....: dBASE Date
  895. *-- Parameters..: dDate  -- date to work from ...
  896. *-------------------------------------------------------------------------------
  897.     
  898.     parameters dDate
  899.     private nYear, nMonth
  900.     
  901.     nYear  = year( dDate )
  902.     nMonth = month( dDate )
  903.  
  904.     * return same if blank
  905.     if nYear = 0
  906.         RETURN dDate
  907.     endif
  908.  
  909.     if nMonth < 12
  910.         * all months except December
  911.         nMonth = nMonth + 1
  912.     else
  913.         * December
  914.         nMonth = 1
  915.         nYear  = nYear + 1
  916.     endif
  917.  
  918. RETURN ctod( str( nMonth ) + "/" + "01" + "/" + str( nYear ) )
  919. *-- EoF: FrstNxtMth()
  920.  
  921. *-------------------------------------------------------------------------------
  922. *-- EoP: DATES.PRG
  923. *-------------------------------------------------------------------------------
  924.