Changeset 623 for WorldVistAEHR/trunk/r/PAID-PRS/PRS8ST.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/PAID-PRS/PRS8ST.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PAID-PRS/PRS8ST.m
r613 r623 1 PRS8ST ;HISC/MGD-DECOMPOSITION, START-UP ;05/09/07 2 ;;4.0;PAID;**45,92,102,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;This routine is the one which actually gets everything moving. 6 ;It moves the information from the ^TMP global into a local array 7 ;[DAY(DAY)] for the three day period it's working with. It then 8 ;processes that information internally and, where necessary, by 9 ;calling certain external processes. 10 ; 11 ;Called by Routines: PRS8SU 12 ; 13 K SBY F DAY=1:1:14 D 14 .K DAY(DAY-2) 15 .S LP=$S(DAY=1:"0,1,2",1:(DAY+1)),JURY=0 16 .F II=1:1 S DY=$P(LP,",",II) Q:DY="" D 17 ..F J=0,1,2,4,10,"CP","DH1","DH2","HOL","ML","MT1","MT2","OFF","P","TOUR","TWO","W","r" D 18 ...S DAY(DY,J)=$G(^TMP($J,"PRS8",DY,J)) 19 ...; 20 ...;P 45 INITIALIZE THE "F" NODE HERE BY SIMPLY COPYING THE 21 ...;THE "W" NODE FROM TEMP--FOR TESTING PURPOSES. 22 ...;THE NODE SHOULD BE INITIALIZED BY COPYING THE "F" NODE 23 ...;FROM THE TEMP GLOBAL. 24 ...S DAY(DY,"F")=$G(^TMP($J,"PRS8",DY,"W")) 25 .F II=1:1 S DY=$P(LP,",",II) Q:DY="" D 26 ..S WK=$S(DY<8:1,1:2) 27 ..S TOUR=$S(TYP'["W":1,+DAY(DY,"TOUR"):+DAY(DY,"TOUR"),1:+TOUR(WK)) 28 ..D MOVE^PRS8AC 29 ..S N=DAY(DY,2),WK=$S(DY<8:1,1:2) ;exception node/week 30 ..I N["UN" S X1="UN" D 2 ;unavailable 31 ..I N["HX" S X1="HX" D 2 ;holiday excused 32 ..I N["ON" S X1="ON" D 2 ;on-call 33 ..I N["SB" S X1="SB" D 2 ;standby 34 ..; Process the scheduled tours 35 ..S N=DAY(DY,1),DH=DAY(DY,"DH1"),NN=1 D I DAY(DY,"TWO") S N=DAY(DY,4),DH=DAY(DY,"DH2"),NN=4 D 36 ...S QT=0 F PRS8=1:3 S V=$P(N,"^",PRS8,PRS8+2) Q:QT D 37 ....N PRS8AFFH S PRS8AFFH=0 ;fire fighter additional hours flag 38 ....S X=$P(DAY(DY,NN),"^",PRS8,999) 39 ....I X="" S QT=1 Q ;nothing left to check 40 ....I X?1"^"."^" S QT=1 Q ;only ^ left 41 ....; 42 ....; X = 9 is special tour CODE FOR FF ADDTL HRS. 43 ....; It gets converted to 'f' 44 ....S X=$P(V,"^",3),VAR=1 I X S VAR=$E("se1BC235f",+X) I '+VAR D ENT Q:Q 45 ....;if this segment is addt ff hrs then save a variable to signify 46 ....;that, but convert the time back to a 1 to use in the W node. 47 ....I "Ff"[TYP,VAR="f" S (PRS8AFFH,VAR)=1 48 ....; 49 ....I VAR,TYP'["W" S VAR=$S(VAR=5:5,1:1) ;only wg need shifts 50 ....S JURY=$G(^TMP($J,"PRS8",DY,2)) I JURY'="" D 51 .....F J=4,8,12,16,20,24,28 S:$P(JURY,"^",J)=6 JURY=1 Q 52 ....D ^PRS8AC ;build "W" node 53 ..; Process the exceptions 54 ..S N=DAY(DY,2),WK=$S(DY<8:1,1:2) ;exception node/week 55 ..S QT=0 56 ..; If there are Recess exceptions, process them first 57 ..I N["RS" D 58 ...; Since Recess will reduce hours worked in the week add P to TYP 59 ...I TYP'["P" S TYP=TYP_"P" 60 ...F PRS8=1:4:25 S V=$P(N,"^",PRS8,PRS8+3) Q:QT D 61 ....Q:$P(V,"^",3)='"RS" 62 ....I TYP["D",$P(V,"^",3)="" S QT=1 Q ;doctor 63 ....I TYP'["D",'+V,$P(V,"^",3)="" S QT=1 Q ;all others 64 ....S X=$P(V,"^",3) 65 ....I "^UN^ON^SB^HX^"'[("^"_X_"^") D ^PRS8EX 66 ...; 67 ...; Process all other types of exceptions 68 ..S QT=0 69 ..F PRS8=1:4:25 S V=$P(N,"^",PRS8,PRS8+3) Q:QT D 70 ...Q:$P(V,"^",3)="RS" 71 ...I TYP["D",$P(V,"^",3)="" S QT=1 Q ;doctor 72 ...I TYP'["D",'+V,$P(V,"^",3)="" S QT=1 Q ;all others 73 ...S X=$P(V,"^",3) 74 ...I "^UN^ON^SB^HX^"'[("^"_X_"^") D ^PRS8EX 75 ..; 76 ..S ^TMP($J,"PRS8",DY,"W")=DAY(DY,"W") ;save in ^TMP 77 ..S ^TMP($J,"PRS8",DY,"P")=DAY(DY,"P") ;save non-prem ot in ^TMP 78 ..S ^TMP($J,"PRS8",DY,"HOL")=DAY(DY,"HOL") ;holiday 79 ..S ^TMP($J,"PRS8",DY,"r")=DAY(DY,"r") ; Recess for 9mo AWS nurse 80 .S WK=$S(DAY<8:1,1:2),OFF=+DAY(DAY,"OFF") ;week/day off 81 .S TOUR=$S(TYP'["W":1,+DAY(DAY,"TOUR"):+DAY(DAY,"TOUR"),1:+TOUR(WK)) 82 .I TYP["I",DAY>0,DAY<15,$G(DAY(DAY,"DWK")) D ;days worked 83 ..S DWK=DWK+1 ;count days worked 84 ..I CYA,DAY'<CYA S CAMISC=CAMISC+1 ;calendar year adjustment (CA) 85 .S MDY=+DAY D ^PRS8MT I +DAY=1 S MDY=0 D ^PRS8MT 86 .Q 87 ; 88 ;make DAY array available for prior, current, and next day 89 F DAY=1:1:14 D 90 .; I AWS Nurse check to see if hour counts need to be adjusted 91 .S WK=$S(DAY<8:1,1:2) 92 .; For each week, TYP should not contain "P" unless: 93 .; 36/40 AWS has NP or WP 94 .; 9mo AWS has Recess 95 .I +NAWS,(DAY=1!(DAY=8)) S TYP=$TR(TYP,"P","") D NAWS 96 .; 97 .K DAY(DAY-2) 98 .S LP=$S(DAY=1:"0,1,2",1:(DAY+1)) 99 .F II=1:1 S DY=$P(LP,",",II) Q:DY="" D 100 ..F J=0,1,2,4,10,"CP","DH1","DH2","HOL","ML","MT1","MT2","OFF","P","TOUR","TWO","W","F","r" S DAY(DY,J)=$G(^TMP($J,"PRS8",DY,J)) 101 .; 102 .S WK=$S(DAY<8:1,1:2),OFF=+DAY(DAY,"OFF") ;week/day off 103 .S TOUR=$S(TYP'["W":1,+DAY(DAY,"TOUR"):+DAY(DAY,"TOUR"),1:+TOUR(WK)) 104 .; 105 .I ((TYP["I")!(TYP["P")),DAY>0,DAY<15 D ;FOR CY 106 ..I $S('CYA:1,DAY<CYA:1,1:0) Q ;quit if no calendar year adjustment 107 ..S IIX=0 I $E(ENT,2)'="D" F II=1:1:$L(DAY(DAY,"W")) D 108 ...I "4E"[$E(DAY(DAY,"W"),II) S IIX=IIX+1 109 ...S CYA2806=CYA2806+("ALSUMRVW1235OscXYFGD"[$E(DAY(DAY,"W"),II)) S:(IIX<33)&(FLX'="C"&(TH(WK)+IIX<163))!(FLX="C"&(TH+IIX<323)) CYA2806=CYA2806+("4E"[$E(DAY(DAY,"W"),II)) 110 ...;SF2806 adjustment (CY) (163 & 323 because mt subtracted) 111 .; 112 .I CYA,DAY'<CYA,DAY(DAY,"W")["W" D ;count wop in hours for CA 113 ..F II=1:1:$L(DAY(DAY,"W")) S WPCYA=WPCYA+("W"=$E(DAY(DAY,"W"),II)) 114 .; 115 .I TYP'["D",DAY(DAY,"W")'?1"0"."0" D ^PRS8PP ;nightdiff/shift premiums 116 .; 117 .F T=1:1:96 S VAR1=$E(DAY(DAY,"W"),T) S OK=0 D 118 ..I "BbCct"[VAR1 D ; process on-call/standby 119 ...I T=96!("BbCct"'[$E(DAY(DAY,"W"),T+1)) S OK=T 120 ...I DOUB D ^PRS8OC,^PRS8SB Q ;Prem. Pay of "W" or "V" 121 ...I VAR1'=""&("Cct"[VAR1) D ^PRS8OC Q ;compute on-call/2hr minimum 122 ...I "Bb"[VAR1 D ^PRS8SB ;standby 123 .I $G(SBY) D UP^PRS8SB 124 .; 125 .Q 126 ; 127 ;P 45 CODE O firefighters use PRS8MISC to calculated overtime 128 ;but code R and C firefighters use routine PRS8OTFF. 129 ; 130 I "Ff"[TYP&("RC"[PMP) D 131 . D ^PRS8OTFF 132 E D 133 . D ^PRS8MISC 134 K DH,DY,I,J,JURY,K,K1,LP,N,NN,OFF,PRS8L,TOUR,V,VAR,WG,X,Y,Y1 135 D ^PRS8WE ;Weekend premiums 136 D ^PRS8UP ;finish up Misc and non-time related activities 137 Q 138 ; 139 ENT ; --- check entitlement to activity for 1 node non-norm hrs 140 S Q=0 141 I '$E(ENT,$P("12^28^^29^26^^^29","^",+X)) S Q=1 ;entitlement string 142 ;PATCH 45: ADD CHECK FOR FIRE FIGHTER ADDITIONAL HOURS 143 ;SINCE THIS TYPE OF TIME IS NOT IN THE ENTITLEMENT TABLE 144 ;IT IS SET UP WITH TOUR IND. WITH CODE 9 145 I "Ff"[TYP,X=9 S Q=0 146 Q:X'=12 I TYP["W",TOUR>1,$E(ENT,11+TOUR) S Q=0 147 Q 148 ; 149 2 ; --- get 2 node unavailable/oncall and standby 150 F PRS8=1:4:25 S V=$P(N,"^",PRS8,PRS8+2) Q:$P(V,"^",1)="" D 151 .S X=$P(V,"^",3) I X=X1 D ^PRS8EX 152 K PRS8,X,V 153 Q 154 ; 155 NAWS ; NAWS Nurse Alternate Work Schedules 156 ; If any NP or WP has been incurred for a nurse on the 36/40 AWS, 157 ; adjust their hours worked counts. 40 hrs/wk will now be used to 158 ; determine their qualification for OT and CT. Check piece 16 of 159 ; 0 node as NH will have been updated to 320 in PRS8SU. 160 ; 161 I +NAWS=36 D 162 .Q:$P(WK(WK),U,3)=""&($P(WK(WK),U,4)="") 163 .S TH(WK)=144-($P(WK(WK),U,3)+$P(WK(WK),U,4)) ; Adjust Total Hours per week 164 .S TH=TH(1)+TH(2) ; Adjust Total Hours per pay period 165 .S NH(WK)=144,NH=288 ; Adjust Normal Hours 166 .I TYP'["P" S TYP=TYP_"P" ; Make them into a PT employee 167 .S $E(ENT,2)=1 ; Make employee eligible for UN/US 168 ; 169 ; If any Recess has occurred for a nurse on the 9month AWS, adjust 170 ; their hours worked counts. These employees will be treated as PT 171 ; in determining the eligibility for OT/CT. 172 ; 173 I +NAWS=9 D 174 .Q:$P(WK(WK),U,48)="" 175 .S TH(WK)=TH(WK)-$P(WK(WK),U,48) ; Adjust total hours per week 176 .S TH=TH(1)+TH(2) ; Adjust Total Hours 177 .I TYP'["P" S TYP=TYP_"P" ; Adjust TYP to represent a PT employee 178 Q 1 PRS8ST ;HISC/MGD-DECOMPOSITION, START-UP ;12/12/05 2 ;;4.0;PAID;**45,92,102**;Sep 21, 1995 3 ; 4 ;This routine is the one which actually gets everything moving. 5 ;It moves the information from the ^TMP global into a local array 6 ;[DAY(DAY)] for the three day period it's working with. It then 7 ;processes that information internally and, where necessary, by 8 ;calling certain external processes. 9 ; 10 ;Called by Routines: PRS8SU 11 ; 12 K SBY F DAY=1:1:14 D 13 .K DAY(DAY-2) 14 .S LP=$S(DAY=1:"0,1,2",1:(DAY+1)),JURY=0 15 .F II=1:1 S DY=$P(LP,",",II) Q:DY="" D 16 ..F J=0,1,2,4,10,"CP","DH1","DH2","HOL","ML","MT1","MT2","OFF","P","TOUR","TWO","W" D 17 ...S DAY(DY,J)=$G(^TMP($J,"PRS8",DY,J)) 18 ...; 19 ...;P 45 INITIALIZE THE "F" NODE HERE BY SIMPLY COPYING THE 20 ...;THE "W" NODE FROM TEMP--FOR TESTING PURPOSES. 21 ...;THE NODE SHOULD BE INITIALIZED BY COPYING THE "F" NODE 22 ...;FROM THE TEMP GLOBAL. 23 ...S DAY(DY,"F")=$G(^TMP($J,"PRS8",DY,"W")) 24 .F II=1:1 S DY=$P(LP,",",II) Q:DY="" D 25 ..S WK=$S(DY<8:1,1:2) 26 ..S TOUR=$S(TYP'["W":1,+DAY(DY,"TOUR"):+DAY(DY,"TOUR"),1:+TOUR(WK)) 27 ..D MOVE^PRS8AC S N=DAY(DY,2),WK=$S(DY<8:1,1:2) ;exception node/week 28 ..I N["UN" S X1="UN" D 2 ;unavailable 29 ..I N["HX" S X1="HX" D 2 ;holiday excused 30 ..I N["ON" S X1="ON" D 2 ;on-call 31 ..I N["SB" S X1="SB" D 2 ;standby 32 ..S N=DAY(DY,1),DH=DAY(DY,"DH1"),NN=1 D I DAY(DY,"TWO") S N=DAY(DY,4),DH=DAY(DY,"DH2"),NN=4 D 33 ...S QT=0 F PRS8=1:3 S V=$P(N,"^",PRS8,PRS8+2) Q:QT D 34 ....N PRS8AFFH S PRS8AFFH=0 ;fire fighter additional hours flag 35 ....S X=$P(DAY(DY,NN),"^",PRS8,999) 36 ....I X="" S QT=1 Q ;nothing left to check 37 ....I X?1"^"."^" S QT=1 Q ;only ^ left 38 ....; 39 ....; X = 9 is special tour CODE FOR FF ADDTL HRS. 40 ....; It gets converted to 'f' 41 ....S X=$P(V,"^",3),VAR=1 I X S VAR=$E("se1BC235f",+X) I '+VAR D ENT Q:Q 42 ....;if this segment is addt ff hrs then save a variable to signify 43 ....;that, but convert the time back to a 1 to use in the W node. 44 ....I "Ff"[TYP,VAR="f" S (PRS8AFFH,VAR)=1 45 ....; 46 ....I VAR,TYP'["W" S VAR=$S(VAR=5:5,1:1) ;only wg need shifts 47 ....S JURY=$G(^TMP($J,"PRS8",DY,2)) I JURY'="" D 48 .....F J=4,8,12,16,20,24,28 S:$P(JURY,"^",J)=6 JURY=1 Q 49 ....D ^PRS8AC ;build "W" node 50 ..S N=DAY(DY,2),WK=$S(DY<8:1,1:2) ;exception node/week 51 ..S QT=0 F PRS8=1:4:25 S V=$P(N,"^",PRS8,PRS8+3) Q:QT D 52 ...I TYP["D",$P(V,"^",3)="" S QT=1 Q ;doctor 53 ...I TYP'["D",'+V,$P(V,"^",3)="" S QT=1 Q ;all others 54 ...S X=$P(V,"^",3) I "^UN^ON^SB^HX^"'[("^"_X_"^") D ^PRS8EX 55 ..S ^TMP($J,"PRS8",DY,"W")=DAY(DY,"W") ;save in ^TMP 56 ..S ^TMP($J,"PRS8",DY,"P")=DAY(DY,"P") ;save non-prem ot in ^TMP 57 ..S ^TMP($J,"PRS8",DY,"HOL")=DAY(DY,"HOL") ;holiday 58 .S WK=$S(DAY<8:1,1:2),OFF=+DAY(DAY,"OFF") ;week/day off 59 .S TOUR=$S(TYP'["W":1,+DAY(DAY,"TOUR"):+DAY(DAY,"TOUR"),1:+TOUR(WK)) 60 .I TYP["I",DAY>0,DAY<15,$G(DAY(DAY,"DWK")) D ;days worked 61 ..S DWK=DWK+1 ;count days worked 62 ..I CYA,DAY'<CYA S CAMISC=CAMISC+1 ;calendar year adjustment (CA) 63 .S MDY=+DAY D ^PRS8MT I +DAY=1 S MDY=0 D ^PRS8MT 64 .Q 65 ; 66 F DAY=1:1:14 D 67 .;make DAY array available for prior, current, and next day 68 .K DAY(DAY-2) 69 .S LP=$S(DAY=1:"0,1,2",1:(DAY+1)) 70 .F II=1:1 S DY=$P(LP,",",II) Q:DY="" D 71 ..F J=0,1,2,4,10,"CP","DH1","DH2","HOL","ML","MT1","MT2","OFF","P","TOUR","TWO","W","F" S DAY(DY,J)=$G(^TMP($J,"PRS8",DY,J)) 72 .; 73 .S WK=$S(DAY<8:1,1:2),OFF=+DAY(DAY,"OFF") ;week/day off 74 .S TOUR=$S(TYP'["W":1,+DAY(DAY,"TOUR"):+DAY(DAY,"TOUR"),1:+TOUR(WK)) 75 .; 76 .I ((TYP["I")!(TYP["P")),DAY>0,DAY<15 D ;FOR CY 77 ..I $S('CYA:1,DAY<CYA:1,1:0) Q ;quit if no calander year adjustment 78 ..S IIX=0 I $E(ENT,2)'="D" F II=1:1:$L(DAY(DAY,"W")) D 79 ...I "4E"[$E(DAY(DAY,"W"),II) S IIX=IIX+1 80 ...S CYA2806=CYA2806+("ALSUMRVW1235OscXYFGD"[$E(DAY(DAY,"W"),II)) S:(IIX<33)&(FLX'="C"&(TH(WK)+IIX<163))!(FLX="C"&(TH+IIX<323)) CYA2806=CYA2806+("4E"[$E(DAY(DAY,"W"),II)) 81 ...;SF2806 adjustment (CY) (163 & 323 because mt subtracted) 82 .; 83 .I CYA,DAY'<CYA,DAY(DAY,"W")["W" D ;count wop in hours for CA 84 ..F II=1:1:$L(DAY(DAY,"W")) S WPCYA=WPCYA+("W"=$E(DAY(DAY,"W"),II)) 85 .; 86 .I TYP'["D",DAY(DAY,"W")'?1"0"."0" D ^PRS8PP ;nightdiff/shift premiums 87 .; 88 .F T=1:1:96 S VAR1=$E(DAY(DAY,"W"),T) S OK=0 D 89 ..I "BbCct"[VAR1 D ; process on-call/standby 90 ...I T=96!("BbCct"'[$E(DAY(DAY,"W"),T+1)) S OK=T 91 ...I DOUB D ^PRS8OC,^PRS8SB Q ;Prem. Pay of "W" or "V" 92 ...I VAR1'=""&("Cct"[VAR1) D ^PRS8OC Q ;compte on-call/2hr minimum 93 ...I "Bb"[VAR1 D ^PRS8SB ;standby 94 .I $G(SBY) D UP^PRS8SB 95 .; 96 .Q 97 ; 98 ;P 45 CODE O firefighters use PRS8MISC to calculated overtime 99 ;but code R and C firefighters use routine PRS8OTFF. 100 ; 101 I "Ff"[TYP&("RC"[PMP) D 102 . D ^PRS8OTFF 103 E D 104 . D ^PRS8MISC 105 K DH,DY,I,J,JURY,K,K1,LP,N,NN,OFF,PRS8L,TOUR,V,VAR,WG,X,Y,Y1 106 D ^PRS8WE ;Weekend premiums 107 D ^PRS8UP ;finish up Misc and non-time related activities 108 Q 109 ; 110 ENT ; --- check entitlement to activity for 1 node non-norm hrs 111 S Q=0 112 I '$E(ENT,$P("12^28^^29^26^^^29","^",+X)) S Q=1 ;entitlement string 113 ;PATCH 45: ADD CHECK FOR FIRE FIGHTER ADDITIONAL HOURS 114 ;SINCE THIS TYPE OF TIME IS NOT IN THE ENTITLMENT TABLE 115 ;IT IS SET UP WITH TOUR IND. WITH CODE 9 116 I "Ff"[TYP,X=9 S Q=0 117 Q:X'=12 I TYP["W",TOUR>1,$E(ENT,11+TOUR) S Q=0 118 Q 119 ; 120 2 ; --- get 2 node unavailable/oncall and standby 121 F PRS8=1:4:25 S V=$P(N,"^",PRS8,PRS8+2) Q:$P(V,"^",1)="" D 122 .S X=$P(V,"^",3) I X=X1 D ^PRS8EX 123 K PRS8,X,V Q
Note:
See TracChangeset
for help on using the changeset viewer.
