Index: WorldVistAEHR/trunk/r/PAID-PRS/PRS8ST.m
===================================================================
--- WorldVistAEHR/trunk/r/PAID-PRS/PRS8ST.m	(revision 613)
+++ WorldVistAEHR/trunk/r/PAID-PRS/PRS8ST.m	(revision 623)
@@ -1,178 +1,123 @@
-PRS8ST	;HISC/MGD-DECOMPOSITION, START-UP ;05/09/07
-	;;4.0;PAID;**45,92,102,112**;Sep 21, 1995;Build 54
-	;;Per VHA Directive 2004-038, this routine should not be modified.
-	;
-	;This routine is the one which actually gets everything moving.
-	;It moves the information from the ^TMP global into a local array
-	;[DAY(DAY)] for the three day period it's working with.  It then
-	;processes that information internally and, where necessary, by
-	;calling certain external processes.
-	;
-	;Called by Routines:  PRS8SU
-	;
-	K SBY F DAY=1:1:14 D
-	.K DAY(DAY-2)
-	.S LP=$S(DAY=1:"0,1,2",1:(DAY+1)),JURY=0
-	.F II=1:1 S DY=$P(LP,",",II) Q:DY=""  D
-	..F J=0,1,2,4,10,"CP","DH1","DH2","HOL","ML","MT1","MT2","OFF","P","TOUR","TWO","W","r" D
-	...S DAY(DY,J)=$G(^TMP($J,"PRS8",DY,J))
-	...;
-	...;P 45 INITIALIZE THE "F" NODE HERE BY SIMPLY COPYING THE 
-	...;THE "W" NODE FROM TEMP--FOR TESTING PURPOSES.
-	...;THE NODE SHOULD BE INITIALIZED BY COPYING THE "F" NODE
-	...;FROM THE TEMP GLOBAL.
-	...S DAY(DY,"F")=$G(^TMP($J,"PRS8",DY,"W"))
-	.F II=1:1 S DY=$P(LP,",",II) Q:DY=""  D
-	..S WK=$S(DY<8:1,1:2)
-	..S TOUR=$S(TYP'["W":1,+DAY(DY,"TOUR"):+DAY(DY,"TOUR"),1:+TOUR(WK))
-	..D MOVE^PRS8AC
-	..S N=DAY(DY,2),WK=$S(DY<8:1,1:2) ;exception node/week
-	..I N["UN" S X1="UN" D 2 ;unavailable
-	..I N["HX" S X1="HX" D 2 ;holiday excused
-	..I N["ON" S X1="ON" D 2 ;on-call
-	..I N["SB" S X1="SB" D 2 ;standby
-	..; Process the scheduled tours
-	..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
-	...S QT=0 F PRS8=1:3 S V=$P(N,"^",PRS8,PRS8+2) Q:QT  D
-	....N PRS8AFFH S PRS8AFFH=0 ;fire fighter additional hours flag
-	....S X=$P(DAY(DY,NN),"^",PRS8,999)
-	....I X="" S QT=1 Q  ;nothing left to check
-	....I X?1"^"."^" S QT=1 Q  ;only ^ left
-	....;
-	....; X = 9 is special tour CODE FOR FF ADDTL HRS.
-	....; It gets converted to 'f'
-	....S X=$P(V,"^",3),VAR=1 I X S VAR=$E("se1BC235f",+X) I '+VAR D ENT Q:Q
-	....;if this segment is addt ff hrs then save a variable to signify
-	....;that, but convert the time back to a 1 to use in the W node.
-	....I "Ff"[TYP,VAR="f" S (PRS8AFFH,VAR)=1
-	....;
-	....I VAR,TYP'["W" S VAR=$S(VAR=5:5,1:1) ;only wg need shifts
-	....S JURY=$G(^TMP($J,"PRS8",DY,2)) I JURY'="" D
-	.....F J=4,8,12,16,20,24,28 S:$P(JURY,"^",J)=6 JURY=1 Q
-	....D ^PRS8AC ;build "W" node
-	..; Process the exceptions
-	..S N=DAY(DY,2),WK=$S(DY<8:1,1:2) ;exception node/week
-	..S QT=0
-	..; If there are Recess exceptions, process them first
-	..I N["RS" D
-	...; Since Recess will reduce hours worked in the week add P to TYP
-	...I TYP'["P" S TYP=TYP_"P"
-	...F PRS8=1:4:25 S V=$P(N,"^",PRS8,PRS8+3) Q:QT  D
-	....Q:$P(V,"^",3)='"RS"
-	....I TYP["D",$P(V,"^",3)="" S QT=1 Q  ;doctor
-	....I TYP'["D",'+V,$P(V,"^",3)="" S QT=1 Q  ;all others
-	....S X=$P(V,"^",3)
-	....I "^UN^ON^SB^HX^"'[("^"_X_"^") D ^PRS8EX
-	...;
-	...; Process all other types of exceptions
-	..S QT=0
-	..F PRS8=1:4:25 S V=$P(N,"^",PRS8,PRS8+3) Q:QT  D
-	...Q:$P(V,"^",3)="RS"
-	...I TYP["D",$P(V,"^",3)="" S QT=1 Q  ;doctor
-	...I TYP'["D",'+V,$P(V,"^",3)="" S QT=1 Q  ;all others
-	...S X=$P(V,"^",3)
-	...I "^UN^ON^SB^HX^"'[("^"_X_"^") D ^PRS8EX
-	..;
-	..S ^TMP($J,"PRS8",DY,"W")=DAY(DY,"W") ;save in ^TMP
-	..S ^TMP($J,"PRS8",DY,"P")=DAY(DY,"P") ;save non-prem ot in ^TMP
-	..S ^TMP($J,"PRS8",DY,"HOL")=DAY(DY,"HOL") ;holiday
-	..S ^TMP($J,"PRS8",DY,"r")=DAY(DY,"r") ; Recess for 9mo AWS nurse
-	.S WK=$S(DAY<8:1,1:2),OFF=+DAY(DAY,"OFF") ;week/day off
-	.S TOUR=$S(TYP'["W":1,+DAY(DAY,"TOUR"):+DAY(DAY,"TOUR"),1:+TOUR(WK))
-	.I TYP["I",DAY>0,DAY<15,$G(DAY(DAY,"DWK")) D  ;days worked
-	..S DWK=DWK+1 ;count days worked
-	..I CYA,DAY'<CYA S CAMISC=CAMISC+1 ;calendar year adjustment (CA)
-	.S MDY=+DAY D ^PRS8MT I +DAY=1 S MDY=0 D ^PRS8MT
-	.Q
-	;
-	;make DAY array available for prior, current, and next day
-	F DAY=1:1:14 D
-	.; I AWS Nurse check to see if hour counts need to be adjusted
-	.S WK=$S(DAY<8:1,1:2)
-	.; For each week, TYP should not contain "P" unless:
-	.; 36/40 AWS has NP or WP
-	.;   9mo AWS has Recess
-	.I +NAWS,(DAY=1!(DAY=8)) S TYP=$TR(TYP,"P","") D NAWS
-	.;
-	.K DAY(DAY-2)
-	.S LP=$S(DAY=1:"0,1,2",1:(DAY+1))
-	.F II=1:1 S DY=$P(LP,",",II) Q:DY=""  D
-	..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))
-	.;
-	.S WK=$S(DAY<8:1,1:2),OFF=+DAY(DAY,"OFF") ;week/day off
-	.S TOUR=$S(TYP'["W":1,+DAY(DAY,"TOUR"):+DAY(DAY,"TOUR"),1:+TOUR(WK))
-	.;
-	.I ((TYP["I")!(TYP["P")),DAY>0,DAY<15 D  ;FOR CY
-	..I $S('CYA:1,DAY<CYA:1,1:0) Q  ;quit if no calendar year adjustment
-	..S IIX=0 I $E(ENT,2)'="D" F II=1:1:$L(DAY(DAY,"W")) D
-	...I "4E"[$E(DAY(DAY,"W"),II) S IIX=IIX+1
-	...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))
-	...;SF2806 adjustment (CY) (163 & 323 because mt subtracted)
-	.;
-	.I CYA,DAY'<CYA,DAY(DAY,"W")["W" D  ;count wop in hours for CA
-	..F II=1:1:$L(DAY(DAY,"W")) S WPCYA=WPCYA+("W"=$E(DAY(DAY,"W"),II))
-	.;
-	.I TYP'["D",DAY(DAY,"W")'?1"0"."0" D ^PRS8PP ;nightdiff/shift premiums
-	.;
-	.F T=1:1:96 S VAR1=$E(DAY(DAY,"W"),T) S OK=0 D
-	..I "BbCct"[VAR1 D  ; process on-call/standby
-	...I T=96!("BbCct"'[$E(DAY(DAY,"W"),T+1)) S OK=T
-	...I DOUB D ^PRS8OC,^PRS8SB Q  ;Prem. Pay of "W" or "V"
-	...I VAR1'=""&("Cct"[VAR1) D ^PRS8OC Q  ;compute on-call/2hr minimum
-	...I "Bb"[VAR1 D ^PRS8SB ;standby
-	.I $G(SBY) D UP^PRS8SB
-	.;
-	.Q
-	;
-	;P 45 CODE O firefighters use PRS8MISC to calculated overtime
-	;but code R and C firefighters use routine PRS8OTFF.
-	;
-	I "Ff"[TYP&("RC"[PMP) D
-	.  D ^PRS8OTFF
-	E  D
-	.  D ^PRS8MISC
-	K DH,DY,I,J,JURY,K,K1,LP,N,NN,OFF,PRS8L,TOUR,V,VAR,WG,X,Y,Y1
-	D ^PRS8WE ;Weekend premiums
-	D ^PRS8UP ;finish up Misc and non-time related activities
-	Q
-	;
-ENT	; --- check entitlement to activity for 1 node non-norm hrs
-	S Q=0
-	I '$E(ENT,$P("12^28^^29^26^^^29","^",+X)) S Q=1 ;entitlement string
-	;PATCH 45: ADD CHECK FOR FIRE FIGHTER ADDITIONAL HOURS
-	;SINCE THIS TYPE OF TIME IS NOT IN THE ENTITLEMENT TABLE
-	;IT IS SET UP WITH TOUR IND. WITH CODE 9
-	I "Ff"[TYP,X=9 S Q=0
-	Q:X'=12  I TYP["W",TOUR>1,$E(ENT,11+TOUR) S Q=0
-	Q
-	;
-2	; --- get 2 node unavailable/oncall and standby
-	F PRS8=1:4:25 S V=$P(N,"^",PRS8,PRS8+2) Q:$P(V,"^",1)=""  D
-	.S X=$P(V,"^",3) I X=X1 D ^PRS8EX
-	K PRS8,X,V
-	Q
-	;
-NAWS	; NAWS Nurse Alternate Work Schedules
-	; If any NP or WP has been incurred for a nurse on the 36/40 AWS,
-	; adjust their hours worked counts.  40 hrs/wk will now be used to 
-	; determine their qualification for OT and CT.  Check piece 16 of
-	; 0 node as NH will have been updated to 320 in PRS8SU.
-	;
-	I +NAWS=36 D
-	.Q:$P(WK(WK),U,3)=""&($P(WK(WK),U,4)="")
-	.S TH(WK)=144-($P(WK(WK),U,3)+$P(WK(WK),U,4)) ; Adjust Total Hours per week
-	.S TH=TH(1)+TH(2) ; Adjust Total Hours per pay period
-	.S NH(WK)=144,NH=288 ; Adjust Normal Hours
-	.I TYP'["P" S TYP=TYP_"P" ; Make them into a PT employee
-	.S $E(ENT,2)=1 ; Make employee eligible for UN/US
-	;
-	; If any Recess has occurred for a nurse on the 9month AWS, adjust 
-	; their hours worked counts.  These employees will be treated as PT
-	; in determining the eligibility for OT/CT.
-	;
-	I +NAWS=9 D
-	.Q:$P(WK(WK),U,48)=""
-	.S TH(WK)=TH(WK)-$P(WK(WK),U,48) ; Adjust total hours per week
-	.S TH=TH(1)+TH(2) ; Adjust Total Hours
-	.I TYP'["P" S TYP=TYP_"P" ; Adjust TYP to represent a PT employee
-	Q
+PRS8ST ;HISC/MGD-DECOMPOSITION, START-UP ;12/12/05
+ ;;4.0;PAID;**45,92,102**;Sep 21, 1995
+ ;
+ ;This routine is the one which actually gets everything moving.
+ ;It moves the information from the ^TMP global into a local array
+ ;[DAY(DAY)] for the three day period it's working with.  It then
+ ;processes that information internally and, where necessary, by
+ ;calling certain external processes.
+ ;
+ ;Called by Routines:  PRS8SU
+ ;
+ K SBY F DAY=1:1:14 D
+ .K DAY(DAY-2)
+ .S LP=$S(DAY=1:"0,1,2",1:(DAY+1)),JURY=0
+ .F II=1:1 S DY=$P(LP,",",II) Q:DY=""  D
+ ..F J=0,1,2,4,10,"CP","DH1","DH2","HOL","ML","MT1","MT2","OFF","P","TOUR","TWO","W" D
+ ...S DAY(DY,J)=$G(^TMP($J,"PRS8",DY,J))
+ ...;
+ ...;P 45 INITIALIZE THE "F" NODE HERE BY SIMPLY COPYING THE 
+ ...;THE "W" NODE FROM TEMP--FOR TESTING PURPOSES.
+ ...;THE NODE SHOULD BE INITIALIZED BY COPYING THE "F" NODE
+ ...;FROM THE TEMP GLOBAL.
+ ...S DAY(DY,"F")=$G(^TMP($J,"PRS8",DY,"W"))
+ .F II=1:1 S DY=$P(LP,",",II) Q:DY=""  D
+ ..S WK=$S(DY<8:1,1:2)
+ ..S TOUR=$S(TYP'["W":1,+DAY(DY,"TOUR"):+DAY(DY,"TOUR"),1:+TOUR(WK))
+ ..D MOVE^PRS8AC S N=DAY(DY,2),WK=$S(DY<8:1,1:2) ;exception node/week
+ ..I N["UN" S X1="UN" D 2 ;unavailable
+ ..I N["HX" S X1="HX" D 2 ;holiday excused
+ ..I N["ON" S X1="ON" D 2 ;on-call
+ ..I N["SB" S X1="SB" D 2 ;standby
+ ..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
+ ...S QT=0 F PRS8=1:3 S V=$P(N,"^",PRS8,PRS8+2) Q:QT  D
+ ....N PRS8AFFH S PRS8AFFH=0 ;fire fighter additional hours flag
+ ....S X=$P(DAY(DY,NN),"^",PRS8,999)
+ ....I X="" S QT=1 Q  ;nothing left to check
+ ....I X?1"^"."^" S QT=1 Q  ;only ^ left
+ ....;
+ ....; X = 9 is special tour CODE FOR FF ADDTL HRS.
+ ....; It gets converted to 'f'
+ ....S X=$P(V,"^",3),VAR=1 I X S VAR=$E("se1BC235f",+X) I '+VAR D ENT Q:Q
+ ....;if this segment is addt ff hrs then save a variable to signify
+ ....;that, but convert the time back to a 1 to use in the W node.
+ ....I "Ff"[TYP,VAR="f" S (PRS8AFFH,VAR)=1
+ ....;
+ ....I VAR,TYP'["W" S VAR=$S(VAR=5:5,1:1) ;only wg need shifts
+ ....S JURY=$G(^TMP($J,"PRS8",DY,2)) I JURY'="" D
+ .....F J=4,8,12,16,20,24,28 S:$P(JURY,"^",J)=6 JURY=1 Q
+ ....D ^PRS8AC ;build "W" node
+ ..S N=DAY(DY,2),WK=$S(DY<8:1,1:2) ;exception node/week
+ ..S QT=0 F PRS8=1:4:25 S V=$P(N,"^",PRS8,PRS8+3) Q:QT  D
+ ...I TYP["D",$P(V,"^",3)="" S QT=1 Q  ;doctor
+ ...I TYP'["D",'+V,$P(V,"^",3)="" S QT=1 Q  ;all others
+ ...S X=$P(V,"^",3) I "^UN^ON^SB^HX^"'[("^"_X_"^") D ^PRS8EX
+ ..S ^TMP($J,"PRS8",DY,"W")=DAY(DY,"W") ;save in ^TMP
+ ..S ^TMP($J,"PRS8",DY,"P")=DAY(DY,"P") ;save non-prem ot in ^TMP
+ ..S ^TMP($J,"PRS8",DY,"HOL")=DAY(DY,"HOL") ;holiday
+ .S WK=$S(DAY<8:1,1:2),OFF=+DAY(DAY,"OFF") ;week/day off
+ .S TOUR=$S(TYP'["W":1,+DAY(DAY,"TOUR"):+DAY(DAY,"TOUR"),1:+TOUR(WK))
+ .I TYP["I",DAY>0,DAY<15,$G(DAY(DAY,"DWK")) D  ;days worked
+ ..S DWK=DWK+1 ;count days worked
+ ..I CYA,DAY'<CYA S CAMISC=CAMISC+1 ;calendar year adjustment (CA)
+ .S MDY=+DAY D ^PRS8MT I +DAY=1 S MDY=0 D ^PRS8MT
+ .Q
+ ;
+ F DAY=1:1:14 D
+ .;make DAY array available for prior, current, and next day
+ .K DAY(DAY-2)
+ .S LP=$S(DAY=1:"0,1,2",1:(DAY+1))
+ .F II=1:1 S DY=$P(LP,",",II) Q:DY=""  D
+ ..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))
+ .;
+ .S WK=$S(DAY<8:1,1:2),OFF=+DAY(DAY,"OFF") ;week/day off
+ .S TOUR=$S(TYP'["W":1,+DAY(DAY,"TOUR"):+DAY(DAY,"TOUR"),1:+TOUR(WK))
+ .;
+ .I ((TYP["I")!(TYP["P")),DAY>0,DAY<15 D  ;FOR CY
+ ..I $S('CYA:1,DAY<CYA:1,1:0) Q  ;quit if no calander year adjustment
+ ..S IIX=0 I $E(ENT,2)'="D" F II=1:1:$L(DAY(DAY,"W")) D
+ ...I "4E"[$E(DAY(DAY,"W"),II) S IIX=IIX+1
+ ...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))
+ ...;SF2806 adjustment (CY) (163 & 323 because mt subtracted)
+ .;
+ .I CYA,DAY'<CYA,DAY(DAY,"W")["W" D  ;count wop in hours for CA
+ ..F II=1:1:$L(DAY(DAY,"W")) S WPCYA=WPCYA+("W"=$E(DAY(DAY,"W"),II))
+ .;
+ .I TYP'["D",DAY(DAY,"W")'?1"0"."0" D ^PRS8PP ;nightdiff/shift premiums
+ .;
+ .F T=1:1:96 S VAR1=$E(DAY(DAY,"W"),T) S OK=0 D
+ ..I "BbCct"[VAR1 D  ; process on-call/standby
+ ...I T=96!("BbCct"'[$E(DAY(DAY,"W"),T+1)) S OK=T
+ ...I DOUB D ^PRS8OC,^PRS8SB Q  ;Prem. Pay of "W" or "V"
+ ...I VAR1'=""&("Cct"[VAR1) D ^PRS8OC Q  ;compte on-call/2hr minimum
+ ...I "Bb"[VAR1 D ^PRS8SB ;standby
+ .I $G(SBY) D UP^PRS8SB
+ .;
+ .Q
+ ;
+ ;P 45 CODE O firefighters use PRS8MISC to calculated overtime
+ ;but code R and C firefighters use routine PRS8OTFF.
+ ;
+ I "Ff"[TYP&("RC"[PMP) D
+ .  D ^PRS8OTFF
+ E  D
+ .  D ^PRS8MISC
+ K DH,DY,I,J,JURY,K,K1,LP,N,NN,OFF,PRS8L,TOUR,V,VAR,WG,X,Y,Y1
+ D ^PRS8WE ;Weekend premiums
+ D ^PRS8UP ;finish up Misc and non-time related activities
+ Q
+ ;
+ENT ; --- check entitlement to activity for 1 node non-norm hrs
+ S Q=0
+ I '$E(ENT,$P("12^28^^29^26^^^29","^",+X)) S Q=1 ;entitlement string
+ ;PATCH 45: ADD CHECK FOR FIRE FIGHTER ADDITIONAL HOURS
+ ;SINCE THIS TYPE OF TIME IS NOT IN THE ENTITLMENT TABLE
+ ;IT IS SET UP WITH TOUR IND. WITH CODE 9
+ I "Ff"[TYP,X=9 S Q=0
+ Q:X'=12  I TYP["W",TOUR>1,$E(ENT,11+TOUR) S Q=0
+ Q
+ ;
+2 ; --- get 2 node unavailable/oncall and standby
+ F PRS8=1:4:25 S V=$P(N,"^",PRS8,PRS8+2) Q:$P(V,"^",1)=""  D
+ .S X=$P(V,"^",3) I X=X1 D ^PRS8EX
+ K PRS8,X,V Q
