- 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 Feb 18, 2025@23:49:13 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
