PRS8HD ;HISC/MGD-DECOMPOSITION, DETERMINE HOLIDAYS ;12/17/2008
;;4.0;PAID;**4,33,72,88,94,98,113,118,122,123,139,144**;Sep 21, 1995;Build 12
;;Per VA Directive 6402, 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
;;3071224^Extra Christmas Day^MONDAY^PRS*4*118
;;3081226^Extra Christmas Day^FRIDAY^PRS*4*122
;;3121224^Extra Christmas Day^MONDAY^PRS*4*139
;;3141226^Extra Christmas Day^FRIDAY^PRS*4*144
;
;---------------------------------------------------------------------
;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
;;3090120^Presidential Inauguration Day^TUESDAY^PRS*4*123
;
;PRS8HD
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRS8HD 7347 printed Sep 23, 2025@19:59:11 Page 2
PRS8HD ;HISC/MGD-DECOMPOSITION, DETERMINE HOLIDAYS ;12/17/2008
+1 ;;4.0;PAID;**4,33,72,88,94,98,113,118,122,123,139,144**;Sep 21, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;This routine is used to determine legal holidays. One calls
+5 ;^PRS8HD with nothing defined if one wants all holidays in the
+6 ;next year. Tag EN can be called with PRS8D defined as a VA
+7 ;FileManager format date from which to calculate holidays. See
+8 ;later documentation in this routine regarding further processing
+9 ;instructions.
+10 ;
+11 KILL PRS8D
+12 ;
EN ;--- entry point
+1 ; pass PRS8D as date you want in VA FileMan format
+2 ; - where only year, i.e., 92 is passed, the first day is presumed
+3 ; pass PRS8D(0) containing a holiday code if specific one wanted
+4 ; if neither PRS8D or PRS8D(0) passed DT is assumed and all
+5 ; holidays for next year are returned
+6 ;
+7 ;new variables used
NEW CT,D,DD,DDQ,DN,DX,NY,%Y,PRSDT1
+8 ;remove existing array if there
KILL HD,HO,PRS8D(1)
+9 ;get DT if none
IF '($DATA(DT)#2)
DO DT^DICRW
+10 ;use DT if no X
SET X=$GET(PRS8D)
IF X']""
SET X=DT
+11 ;bad date
KILL %DT
DO ^%DT
SET X=Y
IF Y'>0
SET PRS8D(1)=-1
GOTO END
+12 IF '+$EXTRACT(X,4,5)
SET X=$EXTRACT(X,1,3)_"01"_$SELECT(+$EXTRACT(X,6,7):$EXTRACT(X,6,7),1:"01")
+13 SET PRSDT1=X
+14 ;
+15 ; Build sorted list (by month) of recurring holidays in array H()
+16 ; If specific holiday code passed just get it, else get all.
+17 ; Note that holiday code "E" is not a recurring holiday so it is
+18 ; handled in another section after the recurring holidays are done.
+19 SET (CT,NY)=0
SET X1=$GET(PRS8D(0))
SET X2="^K^P^M^I^L^C^V^T^X^N^"
+20 IF X1]""
IF X2[("^"_X1_"^")
SET X1=$FIND(X2,X1)-1\2+1
SET J=$PIECE($TEXT(H+(X1+6)),";;",2)
SET H($PIECE(J,"^",2),$PIECE(J,"^",1))=$PIECE(J,"^",3,5)
+21 ;get dates by month
IF '$TEST
IF X1'="E"
FOR I=1:1
SET J=$PIECE($TEXT(H+(I+7)),";;",2)
if J=""
QUIT
SET H($PIECE(J,"^",2),$PIECE(J,"^",1))=$PIECE(J,"^",3,5)
+22 ;
+23 ; build output arrays for the recurring holidays
PASS ;--- come back here for a second pass if necessary
+1 SET DN=X
SET D(1)=+$EXTRACT(X,1,3)
SET D(2)=0
FOR
SET D(2)=$ORDER(H(D(2)))
SET D(3)=""
if 'D(2)
QUIT
FOR
SET D(3)=$ORDER(H(D(2),D(3)))
if D(3)=""
QUIT
Begin DoDot:1
+2 SET DD=H(D(2),D(3))
+3 SET D=D(1)+($SELECT(D(2)<(+$EXTRACT(DN,4,5)):1,1:0))_$EXTRACT("00",0,2-$LENGTH(D(2)))_D(2)_$EXTRACT(DN,6,7)
+4 IF '$PIECE(DD,"^",2)
Begin DoDot:2
+5 SET (DX,X)=$EXTRACT(D,1,5)_$EXTRACT("00",0,2-$LENGTH(+$PIECE(DD,"^",1)))_+$PIECE(DD,"^",1)
+6 DO DW^%DTC
SET Y=%Y
SET X=DX
+7 ;I Y,Y'=6 Q
QUIT
+8 SET X2=$SELECT('Y:"",1:"-")_1
SET X1=X
DO C^%DTC
End DoDot:2
+9 IF '$TEST
Begin DoDot:2
+10 SET (DX,X)=$EXTRACT(D,1,5)_"01"
+11 DO DW^%DTC
SET Y=%Y
SET X=DX
+12 IF Y'=+DD
Begin DoDot:3
+13 IF +Y<+DD
SET X2=DD-Y
+14 IF '$TEST
SET X2=7-(+Y)+DD
+15 SET X1=X
DO C^%DTC
End DoDot:3
+16 IF +$PIECE(DD,"^",2)=1
SET DX=X
QUIT
+17 SET DD(1)=X
SET (DD(2),DD(3),DDQ)=0
FOR
if DD(2)&(DDQ)
QUIT
Begin DoDot:3
+18 SET X2=7
SET X1=DD(1)
DO C^%DTC
+19 SET DD(2)=X
SET DDQ=1
+20 IF $EXTRACT(DD(1),1,5)=$EXTRACT(X,1,5)
SET DD(1)=X
SET DDQ=0
+21 SET DD(3)=DD(3)+1
IF DD(3)=2
IF +$PIECE(DD,"^",2)=3
SET DDQ=1
+22 IF DD(3)=1
IF +$PIECE(DD,"^",2)=4
SET DDQ=1
+23 IF DD(3)=3
IF +$PIECE(DD,"^",2)=5
SET DDQ=1
End DoDot:3
+24 SET (DX,X)=DD(1)
End DoDot:2
+25 DO DW^%DTC
SET Y=%Y
SET X=DX
+26 if X<DN
QUIT
+27 DO SET
+28 IF +DD=+D(2)=+$EXTRACT(DN,4,5)
IF $PIECE(DD,"^",3)="N"
Begin DoDot:2
+29 SET NY=NY+1
if NY>1
QUIT
+30 SET X=$EXTRACT(DN,1,3)+1
SET (DX,X)=X_"0101"
+31 DO DW^%DTC
SET Y=%Y
SET X=DX
+32 ;Q:Y'=6
QUIT
+33 SET X2=-1
SET X1=X
DO C^%DTC
SET DX=X
+34 DO DW^%DTC
SET Y=%Y
SET X=DX
+35 DO SET
End DoDot:2
+36 KILL H(D(2),D(3))
End DoDot:1
+37 IF $ORDER(H(0))>0
Begin DoDot:1
+38 SET X=+$EXTRACT(DN,4,5)
+39 SET X=$SELECT(X=12:1,1:(X+1))
+40 SET X1=$EXTRACT(DN,1,3)+$SELECT(X=1:1,1:0)
SET X=X1_$EXTRACT("00",0,2-$LENGTH(X))_X_"01"
+41 DO PASS
End DoDot:1
+42 ;
+43 ;new section to add applicable extra (non-recurring) holidays
+44 IF $GET(PRS8D(0))=""!($GET(PRS8D(0))="E")
Begin DoDot:1
+45 NEW PRSDT2,PRSI,PRSX
+46 SET PRSDT2=$$FMADD^XLFDT(PRSDT1,364)
+47 ;
+48 ; loop thru the extra holiday list
+49 FOR PRSI=1:1
SET PRSX=$PIECE($TEXT(EHOL+PRSI),";;",2)
if PRSX=""
QUIT
Begin DoDot:2
+50 ; skip if before input date
if $PIECE(PRSX,U)<PRSDT1
QUIT
+51 ; skip if not within the next year
if $PIECE(PRSX,U)>PRSDT2
QUIT
+52 ; need to add this extra holiday to list
+53 SET HD($PIECE(PRSX,U))=$PIECE(PRSX,U,2,3)
+54 SET HO("E",$PIECE(PRSX,U))=""
+55 SET CT=CT+1
End DoDot:2
+56 ;
+57 ; quit if site is not in the Washington DC area
+58 if "^101^688^"'[(U_$EXTRACT($$STA^XUAF4(+$$KSP^XUPARAM("INST")),1,3)_U)
QUIT
+59 ;
+60 ; loop thru additional DC location extra holiday list
+61 FOR PRSI=1:1
SET PRSX=$PIECE($TEXT(EHOLDC+PRSI),";;",2)
if PRSX=""
QUIT
Begin DoDot:2
+62 ; skip if before input date
if $PIECE(PRSX,U)<PRSDT1
QUIT
+63 ; skip if not within the next year
if $PIECE(PRSX,U)>PRSDT2
QUIT
+64 ; need to add this extra holiday to list
+65 SET HD($PIECE(PRSX,U))=$PIECE(PRSX,U,2,3)
+66 SET HO("E",$PIECE(PRSX,U))=""
+67 SET CT=CT+1
End DoDot:2
End DoDot:1
+68 ;
+69 SET PRS8D(1)=$SELECT(CT:+CT,1:-1)
+70 ;
END ;--- That's all folks
+1 KILL %DT,H,I,J,X,X1,X2,Y
QUIT
+2 ;
SET ;--- set nodes
+1 SET HD(X)=D(3)_"^"_$PIECE("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR","^",Y+1)_"DAY"
SET HO($PIECE(DD,"^",3),X)=""
SET CT=CT+1
QUIT
+2 ;
H ;--- Actual Holidays
+1 ; PIECE1 PIECE2 PIECE3 PIECE4 PIECE5 PIECE6
+2 ; actual month exact day 0=exact holiday how
+3 ; holiday day-of-week 1=1st wk code deter-
+4 ; 2=last wk mined
+5 ; - pc3 and 4 are used in concert 3=3rd wk
+6 ; 4=2nd wk,5=4th wk
+7 ;
+8 ;;M.L. King's Birthday^1^1^3^K^3rd Monday in January
+9 ;;President's Day^2^1^3^P^3rd Monday in February
+10 ;;Memorial Day^5^1^2^M^Last Monday in May
+11 ;;Independence Day^7^4^0^I^July 4
+12 ;;Labor Day^9^1^1^L^First Monday in September
+13 ;;Columbus Day^10^1^4^C^Second Monday in October
+14 ;;Veterans Day^11^11^0^V^November 11
+15 ;;Thanksgiving Day^11^4^5^T^Fourth Thursday in November
+16 ;;Christmas Day^12^25^0^X^December 25
+17 ;;New Year's Day^1^1^0^N^January 1
+18 ;
+19 ;-Holiday Codes
+20 ; - K = M.L. King P = President's Day M = Memorial Day
+21 ; - I = Independence L = Labor Day C = Columbus Day
+22 ; - V = Veterans Day T = Thanksgiving X = Christmas
+23 ; - E = Extra Holiday (non-recurring) N = New Year's
+24 ;
+25 ;HD(HOLIDAY) is returned by routine equal to "literal^Dow"
+26 ;HO("HOLIDAY CODE",HOLIDAY) is returned equal to null
+27 ;PRS8D* is returned in value passed
+28 ;PRS8D(1) is returned equal to # holidays found or -1 if none
+29 ;
+30 ;---------------------------------------------------------------------
+31 ;New Section Added for Extra Non-Recurring Holidays (holiday code E)
+32 ;
+33 ; format is
+34 ; FM date of the declared holiday^text^day of week^patch number
+35 ;
+36 ; The following list will need to be updated for years that have an
+37 ; extra Christmas Holiday declared or and declared memorial day for
+38 ; past presidents.
+39 ;
EHOL ;
+1 ;;2940427^President Nixon Funeral^WEDNESDAY^PRS*3.1*2
+2 ;;2971226^Extra Christmas Day^FRIDAY^PRS*4*33
+3 ;;3011224^Extra Christmas Day^MONDAY^PRS*4*72
+4 ;;3031226^Extra Christmas Day^FRIDAY^PRS*4*88
+5 ;;3040611^President Reagan Funeral^FRIDAY^PRS*4*94
+6 ;;3070102^President Ford Funeral^TUESDAY^PRS*4*113
+7 ;;3071224^Extra Christmas Day^MONDAY^PRS*4*118
+8 ;;3081226^Extra Christmas Day^FRIDAY^PRS*4*122
+9 ;;3121224^Extra Christmas Day^MONDAY^PRS*4*139
+10 ;;3141226^Extra Christmas Day^FRIDAY^PRS*4*144
+11 ;
+12 ;---------------------------------------------------------------------
+13 ;New Section Added for Extra Non-Recurring Holidays (holiday code E)
+14 ;that are location specifc to the DC area
+15 ;
+16 ; format is
+17 ; FM date of the declared holiday^text^day of week^patch number
+18 ;
+19 ; The following list will need to be updated when additional specific
+20 ; holidays are declared that only apply to the DC area
+21 ;
EHOLDC ;
+1 ;;3050120^Presidential Inauguration Day^THURSDAY^PRS*4*98
+2 ;;3090120^Presidential Inauguration Day^TUESDAY^PRS*4*123
+3 ;
+4 ;PRS8HD
