source: WorldVistAEHR/trunk/r/PAID-PRS/PRS8HD.m@ 975

Last change on this file since 975 was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version

File size: 6.7 KB
RevLine 
[623]1PRS8HD ;HISC/MGD-DECOMPOSITION, DETERMINE HOLIDAYS ;01/3/2007
2 ;;4.0;PAID;**4,33,72,88,94,98,113**;Sep 21, 1995;Build 3
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;This routine is used to determine legal holidays. One calls
6 ;^PRS8HD with nothing defined if one wants all holidays in the
7 ;next year. Tag EN can be called with PRS8D defined as a VA
8 ;FileManager format date from which to calculate holidays. See
9 ;later documentation in this routine regarding further processing
10 ;instructions.
11 ;
12 K PRS8D
13 ;
14EN ;--- entry point
15 ; pass PRS8D as date you want in VA FileMan format
16 ; - where only year, i.e., 92 is passed, the first day is presumed
17 ; pass PRS8D(0) containing a holiday code if specific one wanted
18 ; if neither PRS8D or PRS8D(0) passed DT is assumed and all
19 ; holidays for next year are returned
20 ;
21 N CT,D,DD,DDQ,DN,DX,NY,%Y,PRSDT1 ;new variables used
22 K HD,HO,PRS8D(1) ;remove existing array if there
23 I '($D(DT)#2) D DT^DICRW ;get DT if none
24 S X=$G(PRS8D) I X']"" S X=DT ;use DT if no X
25 K %DT D ^%DT S X=Y I Y'>0 S PRS8D(1)=-1 G END ;bad date
26 I '+$E(X,4,5) S X=$E(X,1,3)_"01"_$S(+$E(X,6,7):$E(X,6,7),1:"01")
27 S PRSDT1=X
28 ;
29 ; Build sorted list (by month) of recurring holidays in array H()
30 ; If specific holiday code passed just get it, else get all.
31 ; Note that holiday code "E" is not a recurring holiday so it is
32 ; handled in another section after the recurring holidays are done.
33 S (CT,NY)=0,X1=$G(PRS8D(0)),X2="^K^P^M^I^L^C^V^T^X^N^"
34 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)
35 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
36 ;
37 ; build output arrays for the recurring holidays
38PASS ;--- come back here for a second pass if necessary
39 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
40 .S DD=H(D(2),D(3))
41 .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)
42 .I '$P(DD,"^",2) D
43 ..S (DX,X)=$E(D,1,5)_$E("00",0,2-$L(+$P(DD,"^",1)))_+$P(DD,"^",1)
44 ..D DW^%DTC S Y=%Y,X=DX
45 ..Q ;I Y,Y'=6 Q
46 ..S X2=$S('Y:"",1:"-")_1,X1=X D C^%DTC
47 .E D
48 ..S (DX,X)=$E(D,1,5)_"01"
49 ..D DW^%DTC S Y=%Y,X=DX
50 ..I Y'=+DD D
51 ...I +Y<+DD S X2=DD-Y
52 ...E S X2=7-(+Y)+DD
53 ...S X1=X D C^%DTC
54 ..I +$P(DD,"^",2)=1 S DX=X Q
55 ..S DD(1)=X,(DD(2),DD(3),DDQ)=0 F Q:DD(2)&(DDQ) D
56 ...S X2=7,X1=DD(1) D C^%DTC
57 ...S DD(2)=X,DDQ=1
58 ...I $E(DD(1),1,5)=$E(X,1,5) S DD(1)=X,DDQ=0
59 ...S DD(3)=DD(3)+1 I DD(3)=2,+$P(DD,"^",2)=3 S DDQ=1
60 ...I DD(3)=1,+$P(DD,"^",2)=4 S DDQ=1
61 ...I DD(3)=3,+$P(DD,"^",2)=5 S DDQ=1
62 ..S (DX,X)=DD(1)
63 .D DW^%DTC S Y=%Y,X=DX
64 .Q:X<DN
65 .D SET
66 .I +DD=+D(2)=+$E(DN,4,5),$P(DD,"^",3)="N" D
67 ..S NY=NY+1 Q:NY>1
68 ..S X=$E(DN,1,3)+1,(DX,X)=X_"0101"
69 ..D DW^%DTC S Y=%Y,X=DX
70 ..Q ;Q:Y'=6
71 ..S X2=-1,X1=X D C^%DTC S DX=X
72 ..D DW^%DTC S Y=%Y,X=DX
73 ..D SET
74 .K H(D(2),D(3))
75 I $O(H(0))>0 D
76 .S X=+$E(DN,4,5)
77 .S X=$S(X=12:1,1:(X+1))
78 .S X1=$E(DN,1,3)+$S(X=1:1,1:0),X=X1_$E("00",0,2-$L(X))_X_"01"
79 .D PASS
80 ;
81 ;new section to add applicable extra (non-recurring) holidays
82 I $G(PRS8D(0))=""!($G(PRS8D(0))="E") D
83 . N PRSDT2,PRSI,PRSX
84 . S PRSDT2=$$FMADD^XLFDT(PRSDT1,364)
85 . ;
86 . ; loop thru the extra holiday list
87 . F PRSI=1:1 S PRSX=$P($T(EHOL+PRSI),";;",2) Q:PRSX="" D
88 . . Q:$P(PRSX,U)<PRSDT1 ; skip if before input date
89 . . Q:$P(PRSX,U)>PRSDT2 ; skip if not within the next year
90 . . ; need to add this extra holiday to list
91 . . S HD($P(PRSX,U))=$P(PRSX,U,2,3)
92 . . S HO("E",$P(PRSX,U))=""
93 . . S CT=CT+1
94 . ;
95 . ; quit if site is not in the Washington DC area
96 . Q:"^101^688^"'[(U_$E($$STA^XUAF4(+$$KSP^XUPARAM("INST")),1,3)_U)
97 . ;
98 . ; loop thru additional DC location extra holiday list
99 . F PRSI=1:1 S PRSX=$P($T(EHOLDC+PRSI),";;",2) Q:PRSX="" D
100 . . Q:$P(PRSX,U)<PRSDT1 ; skip if before input date
101 . . Q:$P(PRSX,U)>PRSDT2 ; skip if not within the next year
102 . . ; need to add this extra holiday to list
103 . . S HD($P(PRSX,U))=$P(PRSX,U,2,3)
104 . . S HO("E",$P(PRSX,U))=""
105 . . S CT=CT+1
106 ;
107 S PRS8D(1)=$S(CT:+CT,1:-1)
108 ;
109END ;--- That's all folks
110 K %DT,H,I,J,X,X1,X2,Y Q
111 ;
112SET ;--- set nodes
113 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
114 ;
115H ;--- Actual Holidays
116 ; PIECE1 PIECE2 PIECE3 PIECE4 PIECE5 PIECE6
117 ; actual month exact day 0=exact holiday how
118 ; holiday day-of-week 1=1st wk code deter-
119 ; 2=last wk mined
120 ; - pc3 and 4 are used in concert 3=3rd wk
121 ; 4=2nd wk,5=4th wk
122 ;
123 ;;M.L. King's Birthday^1^1^3^K^3rd Monday in January
124 ;;President's Day^2^1^3^P^3rd Monday in February
125 ;;Memorial Day^5^1^2^M^Last Monday in May
126 ;;Independence Day^7^4^0^I^July 4
127 ;;Labor Day^9^1^1^L^First Monday in September
128 ;;Columbus Day^10^1^4^C^Second Monday in October
129 ;;Veterans Day^11^11^0^V^November 11
130 ;;Thanksgiving Day^11^4^5^T^Fourth Thursday in November
131 ;;Christmas Day^12^25^0^X^December 25
132 ;;New Year's Day^1^1^0^N^January 1
133 ;
134 ;-Holiday Codes
135 ; - K = M.L. King P = President's Day M = Memorial Day
136 ; - I = Independence L = Labor Day C = Columbus Day
137 ; - V = Veterans Day T = Thanksgiving X = Christmas
138 ; - E = Extra Holiday (non-recurring) N = New Year's
139 ;
140 ;HD(HOLIDAY) is returned by routine equal to "literal^Dow"
141 ;HO("HOLIDAY CODE",HOLIDAY) is returned equal to null
142 ;PRS8D* is returned in value passed
143 ;PRS8D(1) is returned equal to # holidays found or -1 if none
144 ;
145 ;---------------------------------------------------------------------
146 ;New Section Added for Extra Non-Recurring Holidays (holiday code E)
147 ;
148 ; format is
149 ; FM date of the declared holiday^text^day of week^patch number
150 ;
151 ; The following list will need to be updated for years that have an
152 ; extra Christmas Holiday declared or and declared memorial day for
153 ; past presidents.
154 ;
155EHOL ;
156 ;;2940427^President Nixon Funeral^WEDNESDAY^PRS*3.1*2
157 ;;2971226^Extra Christmas Day^FRIDAY^PRS*4*33
158 ;;3011224^Extra Christmas Day^MONDAY^PRS*4*72
159 ;;3031226^Extra Christmas Day^FRIDAY^PRS*4*88
160 ;;3040611^President Reagan Funeral^FRIDAY^PRS*4*94
161 ;;3070102^President Ford Funeral^TUESDAY^PRS*4*113
162 ;
163 ;---------------------------------------------------------------------
164 ;New Section Added for Extra Non-Recurring Holidays (holiday code E)
165 ;that are location specifc to the DC area
166 ;
167 ; format is
168 ; FM date of the declared holiday^text^day of week^patch number
169 ;
170 ; The following list will need to be updated when additional specific
171 ; holidays are declared that only apply to the DC area
172 ;
173EHOLDC ;
174 ;;3050120^Presidential Inauguration Day^THURSDAY^PRS*4*98
175 ;
176 ;PRS8HD
Note: See TracBrowser for help on using the repository browser.