Changeset 623 for WorldVistAEHR/trunk/r/PAID-PRS/PRS8HD.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/PAID-PRS/PRS8HD.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PAID-PRS/PRS8HD.m
r613 r623 1 PRS8HD ;HISC/MGD-DECOMPOSITION, DETERMINE HOLIDAYS ;12/07/2007 2 ;;4.0;PAID;**4,33,72,88,94,98,113,118**;Sep 21, 1995;Build 1 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 ; 14 EN ;--- 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 38 PASS ;--- 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 ; 109 END ;--- That's all folks 110 K %DT,H,I,J,X,X1,X2,Y Q 111 ; 112 SET ;--- 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 ; 115 H ;--- 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 ; 155 EHOL ; 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 ;;3071224^Extra Christmas Day^MONDAY^PRS*4*118 163 ; 164 ;--------------------------------------------------------------------- 165 ;New Section Added for Extra Non-Recurring Holidays (holiday code E) 166 ;that are location specifc to the DC area 167 ; 168 ; format is 169 ; FM date of the declared holiday^text^day of week^patch number 170 ; 171 ; The following list will need to be updated when additional specific 172 ; holidays are declared that only apply to the DC area 173 ; 174 EHOLDC ; 175 ;;3050120^Presidential Inauguration Day^THURSDAY^PRS*4*98 176 ; 177 ;PRS8HD 1 PRS8HD ;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 ; 14 EN ;--- 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 38 PASS ;--- 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 ; 109 END ;--- That's all folks 110 K %DT,H,I,J,X,X1,X2,Y Q 111 ; 112 SET ;--- 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 ; 115 H ;--- 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 ; 155 EHOL ; 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 ; 173 EHOLDC ; 174 ;;3050120^Presidential Inauguration Day^THURSDAY^PRS*4*98 175 ; 176 ;PRS8HD
Note:
See TracChangeset
for help on using the changeset viewer.
