84 lines
2.8 KiB
Plaintext
84 lines
2.8 KiB
Plaintext
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; ;
|
|
; Copyright 1987, 2003 Sanchez Computer Associates, Inc. ;
|
|
; ;
|
|
; This source code contains the intellectual property ;
|
|
; of its copyright holder(s), and is made available ;
|
|
; under a license. If you do not know the terms of ;
|
|
; the license, please stop and do not read further. ;
|
|
; ;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
%DATE ;GT.M %DATE utility - returns $H format date in %DN
|
|
;invoke at INT with %DS to by pass interactive prompt
|
|
;formats accepted include:
|
|
; days as 1 or 2 digits
|
|
; months as 1 or 2 digits or as unique alpha prefixes
|
|
; years as 2 or 4 digits
|
|
; "T" or "t" for today with an optional +/- offset
|
|
; except for the +/- offset any non alphameric character(s)
|
|
; are accepted as delimiters
|
|
; numeric months must precede days
|
|
; alpha months may precede or follow days
|
|
; a missing year is defaulted to this year
|
|
; null input is defaulted to today
|
|
;
|
|
n %DS
|
|
f r !,"Date: ",%DS s %DN=$$FUNC(%DS) q:%DN'="" w " - invalid date"
|
|
q
|
|
INT s %DN=$$FUNC($g(%DS))
|
|
q
|
|
FUNC(dt)
|
|
n cp,dd,dir,ilen,mm,tok,tp,yy,dh,zd
|
|
i $g(dt)="" q +$H
|
|
s ilen=$l(dt)+1,cp=1 d advance
|
|
i $e("TODAY",1,$l(tok))=$tr(tok,"today","TODAY") q $$incr(+$H)
|
|
i $e("TOMORROW",1,$l(tok))=$tr(tok,"tomrw","TOMRW") q $$incr($H+1)
|
|
i $e("YESTERDAY",1,$l(tok))=$tr(tok,"yestrday","YESTRDAY") q $$incr($H-1)
|
|
i dir?1A s mm=$$amon(tok) q:mm=0 "" d advance s dd=tok q $$date
|
|
i tok<1 q ""
|
|
s mm=tok d advance
|
|
i dir?1A s dd=mm,mm=$$amon(tok) q:mm=0 "" q $$date
|
|
i mm<13 s dd=tok q $$date
|
|
q ""
|
|
;
|
|
advance f cp=cp:1:ilen q:$e(dt,cp)?1AN
|
|
s dir=$e(dt,cp)
|
|
i dir?1A f tp=cp+1:1:ilen q:$e(dt,tp)'?1A
|
|
e i dir?1N f tp=cp+1:1:ilen q:$e(dt,tp)'?1N
|
|
e s tok="" q
|
|
s tok=$e(dt,cp,tp-1)
|
|
s cp=tp
|
|
q
|
|
incr(h)
|
|
f cp=cp:1:ilen q:"+-"[$e(dt,cp)
|
|
i cp'=ilen s dd=$e(dt,cp) d advance i dir?.1N,cp=ilen q h+(dd_tok)
|
|
q h
|
|
;
|
|
amon(mm)
|
|
s mm=$tr(mm,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
|
i $l(mm)<3,"AJM"[tok,"JAPAU"'[mm q 0
|
|
n mon
|
|
s mon="\JANUARY \FEBRUARY \MARCH \APRIL \MAY \JUNE \JULY \AUGUST \SEPTEMBER\OCTOBER \NOVEMBER \DECEMBER"
|
|
q $f(mon,("\"_mm))+8\10
|
|
;
|
|
date()
|
|
i dd<1 q ""
|
|
d advance
|
|
i dir'?.1N q ""
|
|
s zd=$ZDATEFORM
|
|
s yy=tok
|
|
i yy="" s yy=$zd($h,"YEAR")
|
|
i cp'=ilen q ""
|
|
i $l(yy)<3 d
|
|
. s dh=$H
|
|
. s yy=yy+(100*$S('zd:19,(zd>1840)&($L(zd)=4):($E(zd,1,2)+$S($E(zd,3,4)'>yy:0,1:1)),1:$E($ZDATE(dh,"YEAR"),1,2)))
|
|
; 20th rolling current century
|
|
i dd>$s(+mm'=2:$e(303232332323,mm)+28,yy#4:28,yy#100:29,yy#400:28,1:29) q ""
|
|
n cc,dat
|
|
s dat=yy-1841,mm=mm-1,cc=1
|
|
i dat<0 s dd=dd-1,cc=-1
|
|
s dat=dat\4*1461+(dat#4-$s(dat'<0:0,1:4)*365)+(mm*30)+$e(10112234455,mm)+dd-(yy-1800\100-(yy-1600\400))
|
|
i yy#4,mm>1 s dat=dat-cc
|
|
i yy#100=0,mm<2,yy#400 s dat=dat+cc
|
|
q dat
|