2009-12-04 00:11:15 -05:00
|
|
|
PRS8HD ;HISC/MGD-DECOMPOSITION, DETERMINE HOLIDAYS ;01/3/2007
|
|
|
|
|
;;4.0;PAID;**4,33,72,88,94,98,113**;Sep 21, 1995;Build 3
|
|
|
|
|
;;Per VHA Directive 2004-038, this routine should not be modified.
|
|
|
|
|
;
|
|
|
|
|
;This routine is used to determine legal holidays. One calls
|
|
|
|
|
;^PRS8HD with nothing defined if one wants all holidays in the
|
|
|
|
|
;next year. Tag EN can be called with PRS8D defined as a VA
|
|
|
|
|
;FileManager format date from which to calculate holidays. See
|
|
|
|
|
;later documentation in this routine regarding further processing
|
|
|
|
|
;instructions.
|
|
|
|
|
;
|
|
|
|
|
K PRS8D
|
|
|
|
|
;
|
|
|
|
|
EN ;--- entry point
|
|
|
|
|
; pass PRS8D as date you want in VA FileMan format
|
|
|
|
|
; - where only year, i.e., 92 is passed, the first day is presumed
|
|
|
|
|
; pass PRS8D(0) containing a holiday code if specific one wanted
|
|
|
|
|
; if neither PRS8D or PRS8D(0) passed DT is assumed and all
|
|
|
|
|
; holidays for next year are returned
|
|
|
|
|
;
|
|
|
|
|
N CT,D,DD,DDQ,DN,DX,NY,%Y,PRSDT1 ;new variables used
|
|
|
|
|
K HD,HO,PRS8D(1) ;remove existing array if there
|
|
|
|
|
I '($D(DT)#2) D DT^DICRW ;get DT if none
|
|
|
|
|
S X=$G(PRS8D) I X']"" S X=DT ;use DT if no X
|
|
|
|
|
K %DT D ^%DT S X=Y I Y'>0 S PRS8D(1)=-1 G END ;bad date
|
|
|
|
|
I '+$E(X,4,5) S X=$E(X,1,3)_"01"_$S(+$E(X,6,7):$E(X,6,7),1:"01")
|
|
|
|
|
S PRSDT1=X
|
|
|
|
|
;
|
|
|
|
|
; Build sorted list (by month) of recurring holidays in array H()
|
|
|
|
|
; If specific holiday code passed just get it, else get all.
|
|
|
|
|
; Note that holiday code "E" is not a recurring holiday so it is
|
|
|
|
|
; handled in another section after the recurring holidays are done.
|
|
|
|
|
S (CT,NY)=0,X1=$G(PRS8D(0)),X2="^K^P^M^I^L^C^V^T^X^N^"
|
|
|
|
|
I X1]"",X2[("^"_X1_"^") S X1=$F(X2,X1)-1\2+1,J=$P($T(H+(X1+6)),";;",2),H($P(J,"^",2),$P(J,"^",1))=$P(J,"^",3,5)
|
|
|
|
|
E I X1'="E" F I=1:1 S J=$P($T(H+(I+7)),";;",2) Q:J="" S H($P(J,"^",2),$P(J,"^",1))=$P(J,"^",3,5) ;get dates by month
|
|
|
|
|
;
|
|
|
|
|
; build output arrays for the recurring holidays
|
|
|
|
|
PASS ;--- come back here for a second pass if necessary
|
|
|
|
|
S DN=X,D(1)=+$E(X,1,3),D(2)=0 F S D(2)=$O(H(D(2))),D(3)="" Q:'D(2) F S D(3)=$O(H(D(2),D(3))) Q:D(3)="" D
|
|
|
|
|
.S DD=H(D(2),D(3))
|
|
|
|
|
.S D=D(1)+($S(D(2)<(+$E(DN,4,5)):1,1:0))_$E("00",0,2-$L(D(2)))_D(2)_$E(DN,6,7)
|
|
|
|
|
.I '$P(DD,"^",2) D
|
|
|
|
|
..S (DX,X)=$E(D,1,5)_$E("00",0,2-$L(+$P(DD,"^",1)))_+$P(DD,"^",1)
|
|
|
|
|
..D DW^%DTC S Y=%Y,X=DX
|
|
|
|
|
..Q ;I Y,Y'=6 Q
|
|
|
|
|
..S X2=$S('Y:"",1:"-")_1,X1=X D C^%DTC
|
|
|
|
|
.E D
|
|
|
|
|
..S (DX,X)=$E(D,1,5)_"01"
|
|
|
|
|
..D DW^%DTC S Y=%Y,X=DX
|
|
|
|
|
..I Y'=+DD D
|
|
|
|
|
...I +Y<+DD S X2=DD-Y
|
|
|
|
|
...E S X2=7-(+Y)+DD
|
|
|
|
|
...S X1=X D C^%DTC
|
|
|
|
|
..I +$P(DD,"^",2)=1 S DX=X Q
|
|
|
|
|
..S DD(1)=X,(DD(2),DD(3),DDQ)=0 F Q:DD(2)&(DDQ) D
|
|
|
|
|
...S X2=7,X1=DD(1) D C^%DTC
|
|
|
|
|
...S DD(2)=X,DDQ=1
|
|
|
|
|
...I $E(DD(1),1,5)=$E(X,1,5) S DD(1)=X,DDQ=0
|
|
|
|
|
...S DD(3)=DD(3)+1 I DD(3)=2,+$P(DD,"^",2)=3 S DDQ=1
|
|
|
|
|
...I DD(3)=1,+$P(DD,"^",2)=4 S DDQ=1
|
|
|
|
|
...I DD(3)=3,+$P(DD,"^",2)=5 S DDQ=1
|
|
|
|
|
..S (DX,X)=DD(1)
|
|
|
|
|
.D DW^%DTC S Y=%Y,X=DX
|
|
|
|
|
.Q:X<DN
|
|
|
|
|
.D SET
|
|
|
|
|
.I +DD=+D(2)=+$E(DN,4,5),$P(DD,"^",3)="N" D
|
|
|
|
|
..S NY=NY+1 Q:NY>1
|
|
|
|
|
..S X=$E(DN,1,3)+1,(DX,X)=X_"0101"
|
|
|
|
|
..D DW^%DTC S Y=%Y,X=DX
|
|
|
|
|
..Q ;Q:Y'=6
|
|
|
|
|
..S X2=-1,X1=X D C^%DTC S DX=X
|
|
|
|
|
..D DW^%DTC S Y=%Y,X=DX
|
|
|
|
|
..D SET
|
|
|
|
|
.K H(D(2),D(3))
|
|
|
|
|
I $O(H(0))>0 D
|
|
|
|
|
.S X=+$E(DN,4,5)
|
|
|
|
|
.S X=$S(X=12:1,1:(X+1))
|
|
|
|
|
.S X1=$E(DN,1,3)+$S(X=1:1,1:0),X=X1_$E("00",0,2-$L(X))_X_"01"
|
|
|
|
|
.D PASS
|
|
|
|
|
;
|
|
|
|
|
;new section to add applicable extra (non-recurring) holidays
|
|
|
|
|
I $G(PRS8D(0))=""!($G(PRS8D(0))="E") D
|
|
|
|
|
. N PRSDT2,PRSI,PRSX
|
|
|
|
|
. S PRSDT2=$$FMADD^XLFDT(PRSDT1,364)
|
|
|
|
|
. ;
|
|
|
|
|
. ; loop thru the extra holiday list
|
|
|
|
|
. F PRSI=1:1 S PRSX=$P($T(EHOL+PRSI),";;",2) Q:PRSX="" D
|
|
|
|
|
. . Q:$P(PRSX,U)<PRSDT1 ; skip if before input date
|
|
|
|
|
. . Q:$P(PRSX,U)>PRSDT2 ; skip if not within the next year
|
|
|
|
|
. . ; need to add this extra holiday to list
|
|
|
|
|
. . S HD($P(PRSX,U))=$P(PRSX,U,2,3)
|
|
|
|
|
. . S HO("E",$P(PRSX,U))=""
|
|
|
|
|
. . S CT=CT+1
|
|
|
|
|
. ;
|
|
|
|
|
. ; quit if site is not in the Washington DC area
|
|
|
|
|
. Q:"^101^688^"'[(U_$E($$STA^XUAF4(+$$KSP^XUPARAM("INST")),1,3)_U)
|
|
|
|
|
. ;
|
|
|
|
|
. ; loop thru additional DC location extra holiday list
|
|
|
|
|
. F PRSI=1:1 S PRSX=$P($T(EHOLDC+PRSI),";;",2) Q:PRSX="" D
|
|
|
|
|
. . Q:$P(PRSX,U)<PRSDT1 ; skip if before input date
|
|
|
|
|
. . Q:$P(PRSX,U)>PRSDT2 ; skip if not within the next year
|
|
|
|
|
. . ; need to add this extra holiday to list
|
|
|
|
|
. . S HD($P(PRSX,U))=$P(PRSX,U,2,3)
|
|
|
|
|
. . S HO("E",$P(PRSX,U))=""
|
|
|
|
|
. . S CT=CT+1
|
|
|
|
|
;
|
|
|
|
|
S PRS8D(1)=$S(CT:+CT,1:-1)
|
|
|
|
|
;
|
|
|
|
|
END ;--- That's all folks
|
|
|
|
|
K %DT,H,I,J,X,X1,X2,Y Q
|
|
|
|
|
;
|
|
|
|
|
SET ;--- set nodes
|
|
|
|
|
S HD(X)=D(3)_"^"_$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR","^",Y+1)_"DAY",HO($P(DD,"^",3),X)="",CT=CT+1 Q
|
|
|
|
|
;
|
|
|
|
|
H ;--- Actual Holidays
|
|
|
|
|
; PIECE1 PIECE2 PIECE3 PIECE4 PIECE5 PIECE6
|
|
|
|
|
; actual month exact day 0=exact holiday how
|
|
|
|
|
; holiday day-of-week 1=1st wk code deter-
|
|
|
|
|
; 2=last wk mined
|
|
|
|
|
; - pc3 and 4 are used in concert 3=3rd wk
|
|
|
|
|
; 4=2nd wk,5=4th wk
|
|
|
|
|
;
|
|
|
|
|
;;M.L. King's Birthday^1^1^3^K^3rd Monday in January
|
|
|
|
|
;;President's Day^2^1^3^P^3rd Monday in February
|
|
|
|
|
;;Memorial Day^5^1^2^M^Last Monday in May
|
|
|
|
|
;;Independence Day^7^4^0^I^July 4
|
|
|
|
|
;;Labor Day^9^1^1^L^First Monday in September
|
|
|
|
|
;;Columbus Day^10^1^4^C^Second Monday in October
|
|
|
|
|
;;Veterans Day^11^11^0^V^November 11
|
|
|
|
|
;;Thanksgiving Day^11^4^5^T^Fourth Thursday in November
|
|
|
|
|
;;Christmas Day^12^25^0^X^December 25
|
|
|
|
|
;;New Year's Day^1^1^0^N^January 1
|
|
|
|
|
;
|
|
|
|
|
;-Holiday Codes
|
|
|
|
|
; - K = M.L. King P = President's Day M = Memorial Day
|
|
|
|
|
; - I = Independence L = Labor Day C = Columbus Day
|
|
|
|
|
; - V = Veterans Day T = Thanksgiving X = Christmas
|
|
|
|
|
; - E = Extra Holiday (non-recurring) N = New Year's
|
|
|
|
|
;
|
|
|
|
|
;HD(HOLIDAY) is returned by routine equal to "literal^Dow"
|
|
|
|
|
;HO("HOLIDAY CODE",HOLIDAY) is returned equal to null
|
|
|
|
|
;PRS8D* is returned in value passed
|
|
|
|
|
;PRS8D(1) is returned equal to # holidays found or -1 if none
|
|
|
|
|
;
|
|
|
|
|
;---------------------------------------------------------------------
|
|
|
|
|
;New Section Added for Extra Non-Recurring Holidays (holiday code E)
|
|
|
|
|
;
|
|
|
|
|
; format is
|
|
|
|
|
; FM date of the declared holiday^text^day of week^patch number
|
|
|
|
|
;
|
|
|
|
|
; The following list will need to be updated for years that have an
|
|
|
|
|
; extra Christmas Holiday declared or and declared memorial day for
|
|
|
|
|
; past presidents.
|
|
|
|
|
;
|
|
|
|
|
EHOL ;
|
|
|
|
|
;;2940427^President Nixon Funeral^WEDNESDAY^PRS*3.1*2
|
|
|
|
|
;;2971226^Extra Christmas Day^FRIDAY^PRS*4*33
|
|
|
|
|
;;3011224^Extra Christmas Day^MONDAY^PRS*4*72
|
|
|
|
|
;;3031226^Extra Christmas Day^FRIDAY^PRS*4*88
|
|
|
|
|
;;3040611^President Reagan Funeral^FRIDAY^PRS*4*94
|
|
|
|
|
;;3070102^President Ford Funeral^TUESDAY^PRS*4*113
|
|
|
|
|
;
|
|
|
|
|
;---------------------------------------------------------------------
|
|
|
|
|
;New Section Added for Extra Non-Recurring Holidays (holiday code E)
|
|
|
|
|
;that are location specifc to the DC area
|
|
|
|
|
;
|
|
|
|
|
; format is
|
|
|
|
|
; FM date of the declared holiday^text^day of week^patch number
|
|
|
|
|
;
|
|
|
|
|
; The following list will need to be updated when additional specific
|
|
|
|
|
; holidays are declared that only apply to the DC area
|
|
|
|
|
;
|
|
|
|
|
EHOLDC ;
|
|
|
|
|
;;3050120^Presidential Inauguration Day^THURSDAY^PRS*4*98
|
|
|
|
|
;
|
|
|
|
|
;PRS8HD
|
