Changeset 623 for WorldVistAEHR/trunk/r/PAID-PRS
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (15 years ago)
- Location:
- WorldVistAEHR/trunk/r/PAID-PRS
- Files:
-
- 38 edited
-
PRS8AC.m (modified) (1 diff)
-
PRS8CR.m (modified) (1 diff)
-
PRS8DR.m (modified) (1 diff)
-
PRS8EX.m (modified) (1 diff)
-
PRS8HD.m (modified) (1 diff)
-
PRS8HR.m (modified) (1 diff)
-
PRS8HRSV.m (modified) (1 diff)
-
PRS8MSC0.m (modified) (1 diff)
-
PRS8MT.m (modified) (1 diff)
-
PRS8OC.m (modified) (1 diff)
-
PRS8PP.m (modified) (1 diff)
-
PRS8ST.m (modified) (1 diff)
-
PRS8SU.m (modified) (1 diff)
-
PRS8VW.m (modified) (1 diff)
-
PRS8VW1.m (modified) (1 diff)
-
PRS8VW2.m (modified) (1 diff)
-
PRS8WE2.m (modified) (1 diff)
-
PRSACED2.m (modified) (1 diff)
-
PRSACED5.m (modified) (1 diff)
-
PRSACED6.m (modified) (1 diff)
-
PRSAENT.m (modified) (1 diff)
-
PRSAENX.m (modified) (1 diff)
-
PRSALVS.m (modified) (1 diff)
-
PRSAOTT.m (modified) (1 diff)
-
PRSAPPH.m (modified) (1 diff)
-
PRSAPPO.m (modified) (1 diff)
-
PRSASR.m (modified) (1 diff)
-
PRSASR1.m (modified) (1 diff)
-
PRSATE.m (modified) (1 diff)
-
PRSATE0.m (modified) (1 diff)
-
PRSATP.m (modified) (1 diff)
-
PRSATP1.m (modified) (1 diff)
-
PRSATPE.m (modified) (1 diff)
-
PRSAUDP.m (modified) (1 diff)
-
PRSDEU03.m (modified) (1 diff)
-
PRSDSERV.m (modified) (1 diff)
-
PRSDW450.m (modified) (1 diff)
-
PRSPUT3.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PAID-PRS/PRS8AC.m
r613 r623 1 PRS8AC ;HISC/MRL-DECOMPOSITION, ACTIVITY STRING ;05/18/07 2 ;;4.0;PAID;**40,45,54,52,69,75,90,96,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;The primary purpose of this routine is to create the activity 6 ;string [the "W" node] for each day of activity. While creating 7 ;this string certain counts will also be tallied. These include 8 ;Standby, On-Call and the various absence categories. Actual 9 ;Call Back hrs are also counted in this routine for the purpose 10 ;of reducing the OC later on in the process. 11 ; 12 ;Called by Routines: PRS8EX, PRS8ST. 13 ; 14 Q:VAR="" 15 I $S($P(V,"^",1)="":1,$P(V,"^",2)="":1,1:0) Q ;no times 16 S Q=0 17 I DY>0,DY<15 D G END:Q 18 .I DAY(DY,"OFF"),"LSWARUHFGDr"[VAR S Q=1 ;exc invalid day off VAR 19 K OC,FLAG 20 ; 21 S DAYZ=DAY(DY,"W")_$G(DAY(DY,"N")),MTM=0 22 S DAYH=$G(DAY(DY,"HOL"))_$G(DAY(DY+1,"HOL")) ;holiday node 23 N DAYR 24 S DAYR=DAY(DY,"r")_$G(DAY(DY,"rN")) ; Recess 25 ; 26 ;P 45 FIREFIGHTERS F NODE TO TRACK ADDITIONAL FF HRS 27 S DAYF=$G(DAY(DY,"F")) 28 ; 29 F T=+V:1:+$P(V,"^",2) D 30 .I +VAR,$E(DAYH,T),$E(DAYZ,T)?1A Q ;no override holiday 31 .; Don't override Recess but allow Unscheduled Regular (VAR=4) 32 .I +VAR,VAR'=4,$E(DAYR,T)="r" Q ; don't override Recess 33 .I VAR="A"&(JURY=1) S VAR="J" 34 .S VAR1=VAR Q:VAR1="" S DAYZ(1)=$E(DAYZ,T) 35 .I "HhJLSARWMNUnVXYTFGD"[VAR1,$E(DAYZ,T)="m" Q 36 .I T=+V,"12345E"[VAR1 S DAY(DY,"DWK")=1 ;count days worked 37 .I T=+V,"Vh"[VAR1,TYP["I" S DAY(DY,"DWK")=1 ;count days worked for cop 38 .I "JLSWNnARUXYFGD"[VAR1,T'>96,'$E(DAYZ,T) Q ;invalid outside tour 39 .; Regular employees can't earn ct/use ot during work 40 .I +NAWS'=9,"EOPQT4"[VAR1,T'>96,$E(DAYZ,T) Q 41 .; 9mo AWS checks 42 .I +NAWS=9,"PQT"[VAR1,T'>96,$E(DAYZ,T) Q ;can't earn ct/use ot during work 43 .; Allow CT/OT/UN/ON if posted over Recess otherwise don't allow 44 .I +NAWS=9,"4OEC"[VAR1,T'>96,$E(DAYZ,T),$E(DAYR,T)'="r" S $E(DAYR,T)=VAR1 Q 45 .I "OE"[VAR1,"BC"[DAYZ(1),$L(DAYZ(1)) D ; Change OT or CT to CB/SB OT 46 ..S VAR1=$C($A($E(DAYZ,T))+32) 47 ..I $E(DAYZ,T)="C",VAR="E" S VAR1="t" ; Comp time on on-call = "t" 48 .I "BC"[VAR1,DAYZ(1)="O",$L(DAYZ(1)) D ; Change CB/SB to CB/SB OT 49 ..S VAR1=$C($A($E(VAR1))+32) 50 .I "Hh"[VAR1 D Q:VAR1="H" 51 ..S DAYH=$E(DAYH,0,T-1)_$S(VAR1="H":1,$E(DAYZ,T)&($E(DAYZ,T)'=4)!(TYP["I")!(TYP["P"&(TYP["N"!(TYP["H")))!(VAR1="h"):2,1:0)_$E(DAYH,T+1,999) ;holiday node 52 ..I VAR1="h" S VAR1="O" ;convert HW to OT 53 ..I VAR="h",$E(DAYZ,T)=5 S FLAG=5 54 .I $E(DAYZ,T)=5,"ALSRUFGD"[VAR1 S VAR1=$E(DAYZ,T) 55 .I $E(DAYZ,T)="-","BbCctes"[VAR1 Q ;unavail for oc/sb or sch ot/ct 56 .; 57 .I VAR'="r" D 58 ..S DAYZ=$E(DAYZ,0,T-1)_VAR1_$E(DAYZ,T+1,999) 59 ..I $E($G(DAY(DY-1,"N")),T)'="",VAR1'=$E($G(DAY(DY-1,"N")),T) D 60 ...S DAY(DY-1,"N")=$E(DAY(DY-1,"N"),0,T-1)_VAR1_$E(DAY(DY-1,"N"),T+1,999) ;save VAR 61 ..; When processing tour time also copy tour into DAYR 62 ..I "1235"[VAR1 D 63 ...S DAYR=$E(DAYZ,0,T-1)_VAR1_$E(DAYZ,T+1,999) 64 ...I $E($G(DAY(DY-1,"N")),T)'="",VAR1'=$E($G(DAY(DY-1,"N")),T) D 65 ....S DAY(DY-1,"rN")=$E(DAY(DY-1,"rN"),0,T-1)_VAR1_$E(DAY(DY-1,"rN"),T+1,999) 66 .; 67 .; The following check will record Recess and will then update VAR1 to 0 which 68 .; will result in the normally scheduled tour being marked as being no tour. 69 .; This will allow Unscheduled Regular, OT and CT to be posted over the tour. 70 .I VAR="r" D 71 ..S DAYR=$E(DAYR,0,T-1)_VAR1_$E(DAYR,T+1,999) 72 ..S DAYZ=$E(DAYZ,0,T-1)_0_$E(DAYZ,T+1,999) ; Overwrite tour 73 ..I $E($G(DAY(DY-1,"rN")),T)'="",VAR1'=$E($G(DAY(DY-1,"rN")),T) D 74 ...S DAY(DY-1,"rN")=$E(DAY(DY-1,"rN"),0,T-1)_VAR1_$E(DAY(DY-1,"rN"),T+1,999) 75 ...S DAY(DY-1,"N")=$E(DAY(DY-1,"N"),0,T-1)_0_$E(DAY(DY-1,"N"),T+1,999) 76 ..S Y=48 D SET ; Count Recess 77 .; 78 .I VAR1="J" S Y=5 D SET ;set authorized absence for jury duty 79 .I VAR1="M" S Y=5 D SET ; authorized absence for ML 80 .;ot on non-premium T&L 81 .I ("Eocb"[VAR1!(VAR1="O"&'$E(DAYH,T)))&("^^10^11^12^13^15^16^17^"[("^"_$P(V,"^",4)_"^"))!(VAR1=5&("ALSRUFGD"[VAR))!(VAR1=4&(TYP["P"!(TYP["I"&(TYP["N"!(TYP["H"!($$HYBRID^PRSAENT1($G(DFN)))))))&("^7^9^11^12^14^17^"[("^"_$P(V,"^",4)_"^"))) D 82 ..Q:$E(DAY(DY,"P"),T)=5&("ALSRUFGD"'[VAR) 83 ..I $D(FLAG) S FLAG=VAR1,VAR1=5 84 ..N CODE D 85 ...I "^7^8^12^"[("^"_$P(V,"^",4)_"^")&(TYP["N"!(TYP["H")!($$HYBRID^PRSAENT1($G(DFN)))) S CODE="N" Q 86 ...I "^7^8^12^"[("^"_$P(V,"^",4)_"^")&(PMP'="")&("^S^T^U^V^"[(U_PMP_U)) S CODE="N" Q 87 ...I $P(V,"^",4)=11,($$HYBRID^PRSAENT1($G(DFN))) S CODE="N" Q 88 ...I $P(V,"^",4)=11&(PMP'="")&("^S^T^U^V^"[(U_PMP_U)) S CODE="N" Q 89 ...I "^7^8^9^11^"[("^"_$P(V,"^",4)_"^")&(TYP'["N")&(TYP'["H")&('$$HYBRID^PRSAENT1($G(DFN))) S CODE="n" Q 90 ...I "^7^8^9^11^"[("^"_$P(V,"^",4)_"^")&("^S^T^U^V^"'[(U_PMP_U)) S CODE="n" Q 91 ...I $P(V,"^",4)=17 S CODE="N" Q ; Code 17 - OT/CT with premiums 92 ...I VAR1=5 S CODE=VAR Q 93 ...S CODE=1 94 ..S DAY(DY,"P")=$E(DAY(DY,"P"),0,T-1)_CODE_$E(DAY(DY,"P"),T+1,999) 95 .I "ALSRUFGD"[VAR,VAR1=5 S VAR1=VAR 96 .I $D(FLAG) S VAR1=FLAG K FLAG 97 .; 98 FOPTHR .; part time hrs (PT/PH 8b codes) for CODE O firefighters 99 .I +VAR1,"Ff"[TYP,PMP="O",(NH=448!(NH>320&(NH(1)'=NH(2)))) S Y=32 D SET 100 .; 101 FRCPTHR .; part time hrs (PT/PH 8b codes) for code R & C firefighters 102 .; don't include UNSCHEDULED REGULAR (var1=4) 103 .I +VAR1,VAR1'=4,"Ff"[TYP,"RC"[PMP S Y=32 D SET 104 .; 105 .;patch 45 & 54 106 .; Set non pay hrs in the basic tour for firefighters with premium 107 .;pay indicator of C. 108 .I "nW"[VAR1,"Ff"[TYP,"C"=PMP D 109 ..; 110 ..; Y designates location in WK array where NT/NH will be stored. 111 ..; F node was set to 1 for periods of addtl ff hrs during 1st pass 112 ..; thru scheduled ToD. Count NT/NH if this is not addtl ff hrs. 113 ..; 114 ..I '$E(DAY(DY,"F"),T) S Y=47 D SET 115 .S S="LSWnAREUP HYXOVQTFGD" I S[VAR1&(DY>0&(DY<15)!(DY=0&(T>96))) D ;save in WK array 116 ..S S(1)=$F(S,VAR1)-1 117 ..S S=$P("1^2^3^4^5^6^0^8^0^9^24^42^43^0^33^0^19^44^45^46","^",S(1)) ;WK location 118 ..Q:S=0 119 ..; Patch *40 removed A (authorized absence) from leave counted in LU. 120 ..; LU is only used to determine if night differential granted for 121 ..; leave should be backed out. 122 ..I TYP'["D","LSRUFGD"[VAR1 S LU=LU+1 ;increment leave counter 123 ..I TYP'["D","LSRUFGD"[VAR1,(DY=0!(DY=14)&(T>96)),LU>0 S LU=LU-1 124 ..S Y=S D SET S:TYP["D" Q=1 125 ..K S,VAR1 126 ; 127 S DAY(DY,"W")=$E(DAYZ,1,96) ;todays activity 128 S DAY(DY,"N")=$E(DAYZ,97,999) ;tomorrows activity from today/if any 129 S DAY(DY,"r")=$E(DAYR,1,96) ; Today's Recess 130 S DAY(DY,"rN")=$E(DAYR,97,999) ; Tomorrow's Recess/if any 131 S:$E(DAY(DY,"P"),97,999)'="" DAY(DY,"P1")=$E(DAY(DY,"P"),97,999) ;non-prem ot for next day 132 S DAY(DY,"P")=$E(DAY(DY,"P"),1,96) ;non-prem ot for today 133 I DAY(DY,"N")?1"0"."0",DAY(DY,"rN")'["r" S DAY(DY,"N")="" 134 S DAY(DY,"HOL")=$E(DAYH,1,96) 135 ; 136 ;P 45 FIREFIGHTER ADDITIONAL FIREFIGHTER HRS NODE FOR THIS DAY 137 I $G(PRS8AFFH) D 138 . N PRSFFHR,PRSF1,PRSF2,PRSF3,SEG1,SEG2 139 .; 140 .;GET THE POSITIONAL START AND STOPS FOR THIS SEGMENT 141 . S SEG1=$P(V,U,1),SEG2=$P(V,U,2) 142 .;EXISTING PORTION OF F NODE UP TO CURRENT SEGMENT 143 . S PRSF1=$E(DAYF,1,SEG1-1) 144 .;CURRENT SEGMENT UP TO END OF DAY 145 . S PRSF2=$E(DAYZ,SEG1,SEG2) 146 .;CURRENT F NODE PAST CURRENT SEGMENT TO END OF THE TOUR WHICH 147 .;MAY FALL IN TODAY OR NEXT DAY. 148 .S PRSF3=$E(DAYF,SEG2+1,999) 149 .; 150 .;UPDATE THE DAY ARRAY AND THE TMP GLOBAL WITH WORK STRING. 151 .;EACH CHAR THAT IS SET TO 1 REPRESENTS A 15 MIN SEGMENT THAT 152 .;THE FIREFIGHTER WAS SCHEDULED FOR ADDITIONAL FF HRS. 153 .;FOR TOURS CROSSING MIDNIGHT THIS STRING WILL BE LONGER THAN 96 154 .;CHARACTERS. CHARACTERS IN POSITIONS PAST 96 REPRESENT TIMES PAST 155 .;MIDNIGHT OF THE CURRENT DAY (TOMORROW). 156 .S PRSFFHR=PRSF1_PRSF2_PRSF3 157 .S DAY(DY,"F")=PRSFFHR 158 .S ^TMP($J,"PRS8",DY,"F")=PRSFFHR 159 ; 160 I DY<15 S X=$E(DAYH,97,999) I X'?."0" S ^TMP($J,"PRS8",DY+1,"HOL")=X_$E($G(^TMP($J,"PRS8",DY+1,"HOL")),$L(X)+1,999),DAY(DY+1,"HOL")=X 161 ; 162 MOVE ; --- entry point for just moving previous days hrs to today 163 I $D(DAY(DY-1,"N")),$L(DAY(DY-1,"N")) D 164 .S X=DAY(DY-1,"N")_$E(DAY(DY,"W"),$L(DAY(DY-1,"N"))+1,96) 165 .S DAY(DY,"W")=X 166 I $D(DAY(DY-1,"P1")),$L(DAY(DY-1,"P1")) D 167 .S X=DAY(DY-1,"P1")_$E(DAY(DY,"P"),$L(DAY(DY-1,"P1"))+1,96) 168 .S DAY(DY,"P")=X 169 I $D(DAY(DY-1,"rN")),$L(DAY(DY-1,"rN")) D 170 .S X=DAY(DY-1,"rN")_$E(DAY(DY,"r"),$L(DAY(DY-1,"rN"))+1,96) 171 .S DAY(DY,"r")=X 172 ; 173 END ; --- all done here 174 K CNT,OC,Q,S,SB,SL,SLP,T,VAR1,X,Y Q 175 ; 176 SET ; --- set WK variable 177 I (DY=0&(T<97))!(DY=14&(T>96))!(DY>14) Q 178 S ZZ=WK,WK=$S(DY>7:2,1:1) 179 I TYP'["D",DY=7,T>96 S WK=2 180 S $P(WK(WK),"^",Y)=$P(WK(WK),"^",Y)+1 181 ; 182 ; The passing of Public Law 106-554 allows taking ML in hours. 183 ; ML will now be recorded in 15 minute segments in the WK(3) array 184 ; for employees entitled to take ML in hours. PRS*4.0*69 185 ; 186 I VAR1="M",$$MLINHRS^PRSAENT(DFN) D 187 . S WK=3,Y=11 188 . S $P(WK(WK),"^",Y)=$P(WK(WK),"^",Y)+1 189 ; 190 ; IF a part-time employee and they have either LWOP or Non-Pay 191 ; THEN decrement total hours for the week and the pay period. 192 ; PRS*4.0*52. 193 ; 194 I "Wn"[VAR1,TYP["P" S TH=TH-1,TH(WK)=TH(WK)-1 195 S WK=ZZ Q 1 PRS8AC ;HISC/MRL-DECOMPOSITION, ACTIVITY STRING ;01/22/04 2 ;;4.0;PAID;**40,45,54,52,69,75,90,96**;Sep 21, 1995 3 ; 4 ;The primary purpose of this routine is to create the activity 5 ;string [the "W" node] for each day of activity. While creating 6 ;this string certain counts will also be tallied. These include 7 ;Standby, On-Call and the various absence categories. Actual 8 ;Call Back hrs are also counted in this routine for the purpose 9 ;of reducing the OC later on in the process. 10 ; 11 ;Called by Routines: PRS8EX, PRS8ST. 12 ; 13 Q:VAR="" 14 I $S($P(V,"^",1)="":1,$P(V,"^",2)="":1,1:0) Q ;no times 15 S Q=0 16 I DY>0,DY<15 D G END:Q 17 .I DAY(DY,"OFF"),"LSWARUHFGD"[VAR S Q=1 ;exc invalid day off VAR 18 K OC,FLAG 19 ; 20 S DAYZ=DAY(DY,"W")_$G(DAY(DY,"N")),MTM=0 21 S DAYH=$G(DAY(DY,"HOL"))_$G(DAY(DY+1,"HOL")) ;holiday node 22 ; 23 ;P 45 FIREFIGHTERS F NODE TO TRACK ADDITIONAL FF HRS 24 S DAYF=$G(DAY(DY,"F")) 25 ; 26 F T=+V:1:+$P(V,"^",2) D 27 .I +VAR,$E(DAYH,T),$E(DAYZ,T)?1A Q ;no override holiday 28 .I VAR="A"&(JURY=1) S VAR="J" 29 .S VAR1=VAR Q:VAR1="" S DAYZ(1)=$E(DAYZ,T) 30 .I "HhJLSARWMNUnVXYTFGD"[VAR1,$E(DAYZ,T)="m" Q 31 .I T=+V,"12345E"[VAR1 S DAY(DY,"DWK")=1 ;count days worked 32 .I T=+V,"Vh"[VAR1,TYP["I" S DAY(DY,"DWK")=1 ;count days worked for cop 33 .I "JLSWNnARUXYFGD"[VAR1,T'>96,'$E(DAYZ,T) Q ;invalid outside tour 34 .I "EOPQT4"[VAR1,T'>96,$E(DAYZ,T) Q ;can't earn ct/use ot during work 35 .I "OE"[VAR1,"BC"[DAYZ(1),$L(DAYZ(1)) D ; Change OT or CT to CB/SB OT 36 ..S VAR1=$C($A($E(DAYZ,T))+32) 37 ..I $E(DAYZ,T)="C",VAR="E" S VAR1="t" ; Comp time on on-call = "t" 38 .I "BC"[VAR1,DAYZ(1)="O",$L(DAYZ(1)) D ; Change CB/SB to CB/SB OT 39 ..S VAR1=$C($A($E(VAR1))+32) 40 .I "Hh"[VAR1 D Q:VAR1="H" 41 ..S DAYH=$E(DAYH,0,T-1)_$S(VAR1="H":1,$E(DAYZ,T)&($E(DAYZ,T)'=4)!(TYP["I")!(TYP["P"&(TYP["N"!(TYP["H")))!(VAR1="h"):2,1:0)_$E(DAYH,T+1,999) ;holiday node 42 ..I VAR1="h" S VAR1="O" ;convert HW to OT 43 ..I VAR="h",$E(DAYZ,T)=5 S FLAG=5 44 .I $E(DAYZ,T)=5,"ALSRUFGD"[VAR1 S VAR1=$E(DAYZ,T) 45 .I $E(DAYZ,T)="-","BbCctes"[VAR1 Q ;unavail for oc/sb or sch ot/ct 46 .S DAYZ=$E(DAYZ,0,T-1)_VAR1_$E(DAYZ,T+1,999) I $E($G(DAY(DY-1,"N")),T)'="",VAR1'=$E($G(DAY(DY-1,"N")),T) S DAY(DY-1,"N")=$E(DAY(DY-1,"N"),0,T-1)_VAR1_$E(DAY(DY-1,"N"),T+1,999) ;save VAR 47 .I VAR1="J" S Y=5 D SET ;set authorized absence for jury duty 48 .I VAR1="M" S Y=5 D SET ; authorized absence for ML 49 .;ot on non-premium T&L 50 .I ("Eocb"[VAR1!(VAR1="O"&'$E(DAYH,T)))&("^^10^11^12^13^15^16^"[("^"_$P(V,"^",4)_"^"))!(VAR1=5&("ALSRUFGD"[VAR))!(VAR1=4&(TYP["P"!(TYP["I"&(TYP["N"!(TYP["H"!($$HYBRID^PRSAENT1($G(DFN)))))))&("^7^9^11^12^14^"[("^"_$P(V,"^",4)_"^"))) D 51 ..Q:$E(DAY(DY,"P"),T)=5&("ALSRUFGD"'[VAR) 52 ..I $D(FLAG) S FLAG=VAR1,VAR1=5 53 ..N CODE D 54 ...I "^7^8^12^"[("^"_$P(V,"^",4)_"^")&(TYP["N"!(TYP["H")!($$HYBRID^PRSAENT1($G(DFN)))) S CODE="N" Q 55 ...I "^7^8^12^"[("^"_$P(V,"^",4)_"^")&(PMP'="")&("^S^T^U^V^"[(U_PMP_U)) S CODE="N" Q 56 ...I $P(V,"^",4)=11,($$HYBRID^PRSAENT1($G(DFN))) S CODE="N" Q 57 ...I $P(V,"^",4)=11&(PMP'="")&("^S^T^U^V^"[(U_PMP_U)) S CODE="N" Q 58 ...I "^7^8^9^11^"[("^"_$P(V,"^",4)_"^")&(TYP'["N")&(TYP'["H")&('$$HYBRID^PRSAENT1($G(DFN))) S CODE="n" Q 59 ...I "^7^8^9^11^"[("^"_$P(V,"^",4)_"^")&("^S^T^U^V^"'[(U_PMP_U)) S CODE="n" Q 60 ...I VAR1=5 S CODE=VAR Q 61 ...S CODE=1 62 ..S DAY(DY,"P")=$E(DAY(DY,"P"),0,T-1)_CODE_$E(DAY(DY,"P"),T+1,999) 63 .I "ALSRUFGD"[VAR,VAR1=5 S VAR1=VAR 64 .I $D(FLAG) S VAR1=FLAG K FLAG 65 .; 66 FOPTHR .; part time hrs (PT/PH 8b codes) for CODE O firefighters 67 .I +VAR1,"Ff"[TYP,PMP="O",(NH=448!(NH>320&(NH(1)'=NH(2)))) S Y=32 D SET 68 .; 69 FRCPTHR .; part time hrs (PT/PH 8b codes) for code R & C firefighters 70 .; don't include UNSCHEDULED REGULAR (var1=4) 71 .I +VAR1,VAR1'=4,"Ff"[TYP,"RC"[PMP S Y=32 D SET 72 .; 73 .;patch 45 & 54 74 .; Set non pay hrs in the basic tour for firefighters with premium 75 .;pay indicator of C. 76 .I "nW"[VAR1,"Ff"[TYP,"C"=PMP D 77 ..; 78 ..; Y designates location in WK array where NT/NH will be stored. 79 ..; F node was set to 1 for periods of addtl ff hrs during 1st pass 80 ..; thru scheduled ToD. Count NT/NH if this is not addtl ff hrs. 81 ..; 82 ..I '$E(DAY(DY,"F"),T) S Y=47 D SET 83 .S S="LSWnAREUP HYXOVQTFGD" I S[VAR1&(DY>0&(DY<15)!(DY=0&(T>96))) D ;save in WK array 84 ..S S(1)=$F(S,VAR1)-1 85 ..S S=$P("1^2^3^4^5^6^0^8^0^9^24^42^43^0^33^0^19^44^45^46","^",S(1)) ;WK location 86 ..Q:S=0 87 ..; Patch *40 removed A (authorized absence) from leave counted in LU. 88 ..; LU is only used to determine if night differential granted for 89 ..; leave should be backed out. 90 ..I TYP'["D","LSRUFGD"[VAR1 S LU=LU+1 ;increment leave counter 91 ..I TYP'["D","LSRUFGD"[VAR1,(DY=0!(DY=14)&(T>96)),LU>0 S LU=LU-1 92 ..S Y=S D SET S:TYP["D" Q=1 93 ..K S,VAR1 94 ; 95 ; 96 S DAY(DY,"W")=$E(DAYZ,1,96) ;todays activity 97 S DAY(DY,"N")=$E(DAYZ,97,999) ;tomorrows activity from today/if any 98 S:$E(DAY(DY,"P"),97,999)'="" DAY(DY,"P1")=$E(DAY(DY,"P"),97,999) ;non-prem ot for next day 99 S DAY(DY,"P")=$E(DAY(DY,"P"),1,96) ;non-prem ot for today 100 I DAY(DY,"N")?1"0"."0" S DAY(DY,"N")="" 101 S DAY(DY,"HOL")=$E(DAYH,1,96) 102 ; 103 ;P 45 FIREFIGHTER ADDITIONAL FIREFIGHTER HRS NODE FOR THIS DAY 104 I $G(PRS8AFFH) D 105 . N PRSFFHR,PRSF1,PRSF2,PRSF3,SEG1,SEG2 106 .; 107 .;GET THE POSITIONAL START AND STOPS FOR THIS SEGMENT 108 . S SEG1=$P(V,U,1),SEG2=$P(V,U,2) 109 .;EXISTING PORTION OF F NODE UP TO CURRENT SEGMENT 110 . S PRSF1=$E(DAYF,1,SEG1-1) 111 .;CURRENT SEGMENT UP TO END OF DAY 112 . S PRSF2=$E(DAYZ,SEG1,SEG2) 113 .;CURRENT F NODE PAST CURRENT SEGMENT TO END OF THE TOUR WHICH 114 .;MAY FALL IN TODAY OR NEXT DAY. 115 .S PRSF3=$E(DAYF,SEG2+1,999) 116 .; 117 .;UPDATE THE DAY ARRAY AND THE TMP GLOBAL WITH WORK STRING. 118 .;EACH CHAR THAT IS SET TO 1 REPRESENTS A 15 MIN SEGMENT THAT 119 .;THE FIREFIGHTER WAS SCHEDULED FOR ADDITIONAL FF HRS. 120 .;FOR TOURS CROSSING MIDNIGHT THIS STRING WILL BE LONGER THAN 96 121 .;CHARACTERS. CHARACTERS IN POSITIONS PAST 96 REPRESENT TIMES PAST 122 .;MIDNIGHT OF THE CURRENT DAY (TOMORROW). 123 .S PRSFFHR=PRSF1_PRSF2_PRSF3 124 .S DAY(DY,"F")=PRSFFHR 125 .S ^TMP($J,"PRS8",DY,"F")=PRSFFHR 126 ; 127 I DY<15 S X=$E(DAYH,97,999) I X'?."0" S ^TMP($J,"PRS8",DY+1,"HOL")=X_$E($G(^TMP($J,"PRS8",DY+1,"HOL")),$L(X)+1,999),DAY(DY+1,"HOL")=X 128 ; 129 MOVE ; --- entry point for just moving previous days hrs to today 130 I $D(DAY(DY-1,"N")),$L(DAY(DY-1,"N")) D 131 .S X=DAY(DY-1,"N")_$E(DAY(DY,"W"),$L(DAY(DY-1,"N"))+1,96) 132 .S DAY(DY,"W")=X 133 I $D(DAY(DY-1,"P1")),$L(DAY(DY-1,"P1")) D 134 .S X=DAY(DY-1,"P1")_$E(DAY(DY,"P"),$L(DAY(DY-1,"P1"))+1,96) 135 .S DAY(DY,"P")=X 136 ; 137 END ; --- all done here 138 K CNT,OC,Q,S,SB,SL,SLP,T,VAR1,X,Y Q 139 ; 140 SET ; --- set WK variable 141 I (DY=0&(T<97))!(DY=14&(T>96))!(DY>14) Q 142 S ZZ=WK,WK=$S(DY>7:2,1:1) 143 I TYP'["D",DY=7,T>96 S WK=2 144 S $P(WK(WK),"^",Y)=$P(WK(WK),"^",Y)+1 145 ; 146 ; The passing of Public Law 106-554 allows taking ML in hours. 147 ; ML will now be recorded in 15 minute segments in the WK(3) array 148 ; for employees entitled to take ML in hours. PRS*4.0*69 149 ; 150 I VAR1="M",$$MLINHRS^PRSAENT(DFN) D 151 . S WK=3,Y=11 152 . S $P(WK(WK),"^",Y)=$P(WK(WK),"^",Y)+1 153 ; 154 ; IF a part-time employee and they have either LWOP or Non-Pay 155 ; THEN decrement total hours for the week and the pay period. 156 ; PRS*4.0*52. 157 ; 158 I "Wn"[VAR1,TYP["P" S TH=TH-1,TH(WK)=TH(WK)-1 159 S WK=ZZ Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRS8CR.m
r613 r623 1 PRS8CR ;HISC/MRL-DECOMPOSITION, CREATE STRING ;01/17/07 2 ;;4.0;PAID;**2,6,45,69,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;This routine take the information contained in the WK array 6 ;and creates the activity string to be passed to Austin. The 7 ;WK(1) node contains those items pertaining to Week 1 activity, 8 ;WK(2) contains those items pertaining to Week 2 activity and 9 ;WK(3) contains the Miscellaneous information shown on the bottom 10 ;of the timecard. 11 ; 12 ;Called by Routines: PRS8DR 13 ; 14 ;Variable S contains the lengths of each of the Values for the 15 ;different time codes. Used to format values with leading and 16 ;trailing zero's 17 N MLINHRS 18 S MLINHRS=$$MLINHRS^PRSAENT(DFN) 19 S S="333333333333333333333333333333333443623233333333333" 20 S E(1)="ANSKWDNOAURTCECUUNNANBSPSASBSCDADBDCTFOAOBOCYAOKOMRARBRCHAHBHCPTPAONYDHDVCEA EB TATCFAFCADNTRSSRSDND" 21 S E(2)="ALSLWPNPABRLCTCOUSNRNSSQSESFSGDEDFDGTGOEOFOGYEOSOURERFRGHLHMHNPHPBCLYHHOVSEC ED TBTDFBFDAFNHRNSSSHNU" 22 S E(3)="NLDWINTLLULNLDDTTOLAMLCAPCCYRRFFFECD" 23 K V S V="" F I=1,2,3 S V(I)="" 24 ; 25 ;Next section gets Week 1 and Week 2 data and stores in V(WK) 26 F J=1,2 F I=1:1:38,40,42:1:51 S X=+$P(WK(J),"^",I) I X]"" D 27 .; Don't report PT/PT for nurses on AWS schedules 28 .Q:$E(AC,2)=1&($P(C0,U,16)=72)&(I=32) ; 36/40 AWS 29 .Q:$E(AC,2)=2&($P(C0,U,16)=80)&(I=32) ; 9month AWS 30 .; 31 .I TYP'["D",I'=38,I'=40 D QH 32 .I TYP["D" S X=+X_"0" 33 .I TYP["Pd",$E(ENT,2)'="D",$P(WK(J),"^",32)="",V(J)="" S V(J)=V(J)_$S(J=1:"PT000",J=2:"PH000",1:"") ;for p/t drs put PT,PH in 8B string even if they are 0 (PT+PH=NH) 34 .I I=32,TYP["P",TYP["N",TYP'["B"!(TYP["H"),'X D Q 35 ..S X=$E("0000000",0,+$E(S,I)-$L(X))_X 36 ..S V(J)=V(J)_$E(E(J),I+(I-1),I*2)_X 37 ..Q 38 .I I=37,$P(C0,"^",20)="P",$P(C0,"^",21)="U" D 39 ..S X=$E("0000000",0,+$E(S,I)-$L(X))_X 40 ..I 'X S V(J)=V(J)_$E(E(J),I+(I-1),I*2)_X 41 ..Q 42 .S X=+X I I=32,TYP["Pd",X=0 S X=1 43 .Q:'X 44 .I I=32,TYP["Pd",X=1 S X=0 45 .I I=38!(I=40) D 46 ..S Z=X,X=4*$P(WK(J),"^",I+1) D QH 47 ..S X=($E("00",0,$E(S,I)-$L(Z))_+Z)_($E("000",0,$E(S,I+1)-$L(+X))_+X) ;combine env. diff. % and hours 48 ..Q 49 .E S X=$E("0000000",0,+$E(S,I)-$L(X))_+X 50 .I +X S V(J)=V(J)_$E(E(J),I+(I-1),I*2)_X,V=V+X 51 ; 52 ;Now we get miscellaneous data 53 ; 54 S S="22134446114423146" 55 F I=1:1:17 S X=$P(WK(3),"^",I) I X'="" D 56 .I I=11 D 57 . . I MLINHRS D QH ; Convert to 1/4 hours. 58 . . I MLINHRS=0 S X=X_"0" ; Convert to 1/4 hours. 59 .S X=$E("000000",0,+$E(S,I)-$L(X))_X 60 .I $D(X) S V(3)=V(3)_$E(E(3),I+(I-1),I*2)_X,V=V+X 61 ; 62 ;finish up 63 ; 64 S VAL="" I $L(V(1))!($L(V(2)))!($L(V(3))) S X=V(1)_V(2)_V(3)_"CD"_$E("000000",0,6-$L(+V))_+V,VAL=X 65 ; 66 STUB ; --- enter here to create stub only 67 I '($D(VAL)#2) S VAL="" 68 ; code below to add CP field to STUB record (32nd position) 69 S CPFX="" 70 S CPFX=$P($G(^PRST(458,PY,"E",DFN,0)),"^",6) ;get CP from 458 71 I CPFX="" S CPFX=$P($G(^PRSPC(DFN,1)),"^",7) ;if 458 null get from 450 72 I "0"[CPFX S CPFX=" " ;if it is 0 or "" set CPFX = " " 73 S PPE=$G(^PRST(458,+PY,0)),PPE=$P(PPE,"^",1),PPI=+PY D ^PRSAXSR 74 S VAL=HDR_CPFX_VAL ;decomp no longer saves 8B in 5 node (6/95) 75 K I,J,S Q 76 ; 77 QH ; --- for persons paid hourly/convert to Quarter Hours 78 ; 79 I I'=37 S X1=X#4,X=X\4_+X1 K X1 80 Q 1 PRS8CR ;HISC/MRL-DECOMPOSITION, CREATE STRING ;8/23/01 2 ;;4.0;PAID;**2,6,45,69**;Sep 21, 1995 3 ; 4 ;This routine take the information contained in the WK array 5 ;and creates the activity string to be passed to Austin. The 6 ;WK(1) node contains those items pertaining to Week 1 activity, 7 ;WK(2) contains those items pertaining to Week 2 activity and 8 ;WK(3) contains the Miscellaneous information shown on the bottom 9 ;of the timecard. 10 ; 11 ;Called by Routines: PRS8DR 12 ; 13 ;Variable S contains the lengths of each of the Values for the 14 ;different time codes. Used to format values with leading and 15 ;trailing zero's 16 N MLINHRS 17 S MLINHRS=$$MLINHRS^PRSAENT(DFN) 18 S S="33333333333333333333333333333333344362323333333" 19 S E(1)="ANSKWDNOAURTCECUUNNANBSPSASBSCDADBDCTFOAOBOCYAOKOMRARBRCHAHBHCPTPAONYDHDVCEA EB TATCFAFCADNT" 20 S E(2)="ALSLWPNPABRLCTCOUSNRNSSQSESFSGDEDFDGTGOEOFOGYEOSOURERFRGHLHMHNPHPBCLYHHOVSEC ED TBTDFBFDAFNH" 21 S E(3)="NLDWINTLLULNLDDTTOLAMLCAPCCYRRFFFECD" 22 K V S V="" F I=1,2,3 S V(I)="" 23 ; 24 ;Next section gets Week 1 and Week 2 data and stores in V(WK) 25 F J=1,2 F I=1:1:38,40,42,43,44,45,46,47 S X=+$P(WK(J),"^",I) I X]"" D 26 .I TYP'["D",I'=38,I'=40 D QH 27 .I TYP["D" S X=+X_"0" 28 .I TYP["Pd",$E(ENT,2)'="D",$P(WK(J),"^",32)="",V(J)="" S V(J)=V(J)_$S(J=1:"PT000",J=2:"PH000",1:"") ;for p/t drs put PT,PH in 8B string even if they are 0 (PT+PH=NH) 29 .I I=32,TYP["P",TYP["N",TYP'["B"!(TYP["H"),'X D Q 30 ..S X=$E("0000000",0,+$E(S,I)-$L(X))_X 31 ..S V(J)=V(J)_$E(E(J),I+(I-1),I*2)_X 32 ..Q 33 .I I=37,$P(C0,"^",20)="P",$P(C0,"^",21)="U" D 34 ..S X=$E("0000000",0,+$E(S,I)-$L(X))_X 35 ..I 'X S V(J)=V(J)_$E(E(J),I+(I-1),I*2)_X 36 ..Q 37 .S X=+X I I=32,TYP["Pd",X=0 S X=1 38 .Q:'X 39 .I I=32,TYP["Pd",X=1 S X=0 40 .I I=38!(I=40) D 41 ..S Z=X,X=4*$P(WK(J),"^",I+1) D QH 42 ..S X=($E("00",0,$E(S,I)-$L(Z))_+Z)_($E("000",0,$E(S,I+1)-$L(+X))_+X) ;combine env. diff. % and hours 43 ..Q 44 .E S X=$E("0000000",0,+$E(S,I)-$L(X))_+X 45 .I +X S V(J)=V(J)_$E(E(J),I+(I-1),I*2)_X,V=V+X 46 ; 47 ;Now we get miscellaneous data 48 ; 49 S S="22134446114423146" 50 F I=1:1:17 S X=$P(WK(3),"^",I) I X'="" D 51 .I I=11 D 52 . . I MLINHRS D QH ; Convert to 1/4 hours. 53 . . I MLINHRS=0 S X=X_"0" ; Convert to 1/4 hours. 54 .S X=$E("000000",0,+$E(S,I)-$L(X))_X 55 .I $D(X) S V(3)=V(3)_$E(E(3),I+(I-1),I*2)_X,V=V+X 56 ; 57 ;finish up 58 ; 59 S VAL="" I $L(V(1))!($L(V(2)))!($L(V(3))) S X=V(1)_V(2)_V(3)_"CD"_$E("000000",0,6-$L(+V))_+V,VAL=X 60 ; 61 STUB ; --- enter here to create stub only 62 I '($D(VAL)#2) S VAL="" 63 ; code below to add CP field to STUB record (32nd position) 64 S CPFX="" 65 S CPFX=$P($G(^PRST(458,PY,"E",DFN,0)),"^",6) ;get CP from 458 66 I CPFX="" S CPFX=$P($G(^PRSPC(DFN,1)),"^",7) ;if 458 null get from 450 67 I "0"[CPFX S CPFX=" " ;if it is 0 or "" set CPFX = " " 68 S PPE=$G(^PRST(458,+PY,0)),PPE=$P(PPE,"^",1),PPI=+PY D ^PRSAXSR 69 S VAL=HDR_CPFX_VAL ;decomp no longer saves 8B in 5 node (6/95) 70 K I,J,S Q 71 ; 72 QH ; --- for persons paid hourly/convert to Quarter Hours 73 ; 74 I I'=37 S X1=X#4,X=X\4_+X1 K X1 75 Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRS8DR.m
r613 r623 1 PRS8DR ;HISC/MRL,JAH/WCIOFO-DECOMPOSITION, DRIVER ;4/09/2007 2 ;;4.0;PAID;**22,29,56,90,111,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;This routine determines whether or not the parameters necessary 6 ;to decompose time are in existence. The majority of variables 7 ;involving processing an individual employee are defined in this 8 ;routine. 9 ; 10 ;The following lines establish variables necessary to process a 11 ;specific employees time for the specified pay period. 12 ; 13 ;Called by Routines: PRS8, PRS8DR (tag 1) 14 ; 15 N PRVAL,RESTORE 16 ; 17 D ONE^PRS8CV ;clean up variables 18 S SAVE=+$G(SAVE),SEE=+$G(SEE) 19 S TMTD=$G(^PRST(458,+PY,"E",DFN,0)),TMTD=$S($P(TMTD,"^",2)="X":1,1:0) 20 K WK F I=1,2,3 S WK(I)="" ;weekly totals (wk3=misc data) 21 D ^PRSAENT S VAL="" ;get entitlement (ENT) 22 I PP="S" G END ;Manila citizen/don't decompose/no stub 23 I $G(PB)["$" G STUB^PRS8CR ;don't decompose stipend/create stub 24 ; Set NAWS to type of AWS 25 N NAWS 26 S NAWS=0 27 I "KM"[$E(AC,1),$E(AC,2)=1,NH=72 S NAWS="36/40 AWS" 28 I $E(AC,1)="M",$E(AC,2)=2,NH=80 S NAWS="9Mo AWS" 29 ; 30 I "^P^X^"[(U_$P($G(^PRST(458,+PY,"E",DFN,0)),"^",2)_U) S RESTORE=1 31 D AUTOPINI^PRS8(+PY,+DFN,$G(RESTORE),.PRVAL) ; remove auto-posted data 32 S DOUB=0 I $E(ENT,26),$E(ENT,29) S DOUB=1 ;count standby & oncall same 33 S FLX="" S FLX=$P($G(^PRST(458,+PY,"E",DFN,0)),"^",6) 34 I +NAWS=36 S FLX="C" 35 S (SST,TAL)="",X=$P(C0,"^",8) I X'="" D ;T&L Unit 36 .S X=$O(^PRST(455.5,"B",X,0)) ;get ien 37 .S TAL=$G(^PRST(455.5,+X,0)),X=$P(TAL,"^",8) ;get sleep start time 38 .I $L(X) S (NDAY,LAST,Y,Y1)=0 D 15^PRS8SU 39 .S SST=$S(+X:X,1:93) K X,Y1,LAST,X ;sleep start time 40 .K SL,SB,ST ;make sure standby variable don't exist 41 S (CAMISC,CYA,CYA2806,WPCYA,LU)=0 ; << ADDED >> calendar year adjust./leave used in pp 42 S (NH(1),NH(2))=0 ;normal hrs/pp total/week(1)/week(2) 43 S (TH,TH(1),TH(2))=0 ;total hours 44 N CT S (CT(1),CT(2))=0 ; counter for compensatory time 45 K DWK S DWK=0 ;count of days worked - for intermittents 46 S NH=NH/.25 ;turn Norm hrs into 15min increments 47 K TOUR S (TOUR(1),TOUR(2))="" ;tour code for wg/week(1)/week(2) 48 K TYP S TYP="" I $E(ENT)="D"!($E(ENT,1,2)="0D") S TYP=TYP_"D" ;daily pay basis 49 I PP?1N.E!(PP="U") S TYP=TYP_"W" ;wagegrade 50 I PP'="","KM"[PP S TYP=TYP_"N" ;nurse 51 I +$E(AC,2)=1,NH=192 S TYP=TYP_"B" ;baylor plan 52 I $G(PMP)'="","EF"[PMP S TYP=TYP_"H" ;Nurse Hybrid 53 I $E($G(AC),2)=3 S TYP=TYP_"I" ;intermittent 54 I NH>320 S TYP=TYP_"F" I NH'>448 S TYP=TYP_"f" ;firefighter 55 ; Nurses on the 9month AWS will be treated as FT employees during the 9 months 56 ; that they are working. Prevent a "P" from being added to TYP. 57 I NH,NH'>319,$E(AC,2)'=1 S TYP=TYP_"P" ;part-time 58 I PP="L",$E(AC,2)=2 S TYP=TYP_"d" ;doctor 59 I PP="L",$E(AC,2)=1 S TYP=TYP_"dR" ;doctor/resident or intern 60 S (PTH,PTH(1),PTH(2))=0 ;part-time hours 61 K WKL S (WKL(1),WKL(2))=0 ;count leave used in week during ND hours 62 K MEAL S $P(MEAL,"1^",14)="",MEAL=MEAL_1 ;mealtime 63 S (MILV,WCMP)=0 ;ML and PC indicators 64 S (CBCK(1),CBCK(2))=0 ;call back hrs by week counter 65 I TYP="" S TYP="*" 66 K I,PB,PP,X,X1,X2 67 D ^PRS8SU ;set up employee variables and commence decomposing 68 D ^PRS8CR 69 D:$D(PRVAL) AUTOPRES^PRS8(+PY,+DFN,.PRVAL) ; restore auto-posted data 70 I SEE D ^PRS8VW 71 ; 72 END ; --- This is where we end this process 73 G ONE^PRS8CV ;clean up 74 Q 75 ; 76 1 ; --- enter here to print single entry and close device 77 D ^PRS8DR,^%ZISC Q 1 PRS8DR ;HISC/MRL,JAH/WCIOFO-DECOMPOSITION, DRIVER ;1/25/2007 2 ;;4.0;PAID;**22,29,56,90,111**;Sep 21, 1995;Build 2 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;This routine determines whether or not the parameters necessary 6 ;to decompose time are in existance. The majority of variables 7 ;involving processing an individual employee are defined in this 8 ;routine. 9 ; 10 ;The following lines establish variables necessary to process a 11 ;specific employees time for the specified pay period. 12 ; 13 ;Called by Routines: PRS8, PRS8DR (tag 1) 14 ; 15 N PRVAL,RESTORE 16 ; 17 D ONE^PRS8CV ;clean up variables 18 S SAVE=+$G(SAVE),SEE=+$G(SEE) 19 S TMTD=$G(^PRST(458,+PY,"E",DFN,0)),TMTD=$S($P(TMTD,"^",2)="X":1,1:0) 20 K WK F I=1,2,3 S WK(I)="" ;weekly totals (wk3=misc data) 21 D ^PRSAENT S VAL="" ;get entitlement (ENT) 22 I PP="S" G END ;manilla citizen/don't decompose/no stub 23 I $G(PB)["$" G STUB^PRS8CR ;don't decompose stipend/create stub 24 I "^P^X^"[(U_$P($G(^PRST(458,+PY,"E",DFN,0)),"^",2)_U) S RESTORE=1 25 D AUTOPINI^PRS8(+PY,+DFN,$G(RESTORE),.PRVAL) ; remove auto-posted data 26 S DOUB=0 I $E(ENT,26),$E(ENT,29) S DOUB=1 ;count standby & oncall same 27 S FLX="" S FLX=$P($G(^PRST(458,+PY,"E",DFN,0)),"^",6) 28 S (SST,TAL)="",X=$P(C0,"^",8) I X'="" D ;T&L Unit 29 .S X=$O(^PRST(455.5,"B",X,0)) ;get ien 30 .S TAL=$G(^PRST(455.5,+X,0)),X=$P(TAL,"^",8) ;get sleep start time 31 .I $L(X) S (NDAY,LAST,Y,Y1)=0 D 15^PRS8SU 32 .S SST=$S(+X:X,1:93) K X,Y1,LAST,X ;sleep start time 33 .K SL,SB,ST ;make sure standby variable don't exist 34 S (CAMISC,CYA,CYA2806,WPCYA,LU)=0 ; << ADDED >> calendar year adjust./leave used in pp 35 S (NH(1),NH(2))=0 ;normal hrs/pp total/week(1)/week(2) 36 S (TH,TH(1),TH(2))=0 ;total hours 37 N CT S (CT(1),CT(2))=0 ; counter for compensatory time 38 K DWK S DWK=0 ;count of days worked - for intermittents 39 S NH=NH/.25 ;turn Norm hrs into 15min increments 40 K TOUR S (TOUR(1),TOUR(2))="" ;tour code for wg/week(1)/week(2) 41 K TYP S TYP="" I $E(ENT)="D"!($E(ENT,1,2)="0D") S TYP=TYP_"D" ;daily pay basis 42 I PP?1N.E!(PP="U") S TYP=TYP_"W" ;wagegrade 43 I PP'="","KM"[PP S TYP=TYP_"N" ;nurse 44 I +$E(AC,2)=1,NH=192 S TYP=TYP_"B" ;baylor plan 45 I $G(PMP)'="","EF"[PMP S TYP=TYP_"H" ;Nurse Hybrid 46 I $E($G(AC),2)=3 S TYP=TYP_"I" ;intermittent 47 I NH>320 S TYP=TYP_"F" I NH'>448 S TYP=TYP_"f" ;firefighter 48 I NH,NH'>319 S TYP=TYP_"P" ;part-time 49 I PP="L",$E(AC,2)=2 S TYP=TYP_"d" ;doctor 50 I PP="L",$E(AC,2)=1 S TYP=TYP_"dR" ;doctor/resident or intern 51 S (PTH,PTH(1),PTH(2))=0 ;part-time hours 52 K WKL S (WKL(1),WKL(2))=0 ;count leave used in week during ND hours 53 K MEAL S $P(MEAL,"1^",14)="",MEAL=MEAL_1 ;mealtime 54 S (MILV,WCMP)=0 ;ML and PC indicators 55 S (CBCK(1),CBCK(2))=0 ;call back hrs by week counter 56 I TYP="" S TYP="*" 57 K I,PB,PP,X,X1,X2 58 D ^PRS8SU ;set up employee variables and commence decomposing 59 D ^PRS8CR 60 D:$D(PRVAL) AUTOPRES^PRS8(+PY,+DFN,.PRVAL) ; restore auto-posted data 61 I SEE D ^PRS8VW 62 ; 63 END ; --- This is where we end this process 64 G ONE^PRS8CV ;clean up 65 Q 66 ; 67 1 ; --- enter here to print single entry and close device 68 D ^PRS8DR,^%ZISC Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRS8EX.m
r613 r623 1 PRS8EX ;HISC/MRL,WCIOFO/SAB-DECOMPOSITION, EXCEPTIONS ;1/31/2007 2 ;;4.0;PAID;**2,40,56,69,111,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;This routine is used to process most exceptions to the normal 6 ;tod. It is used, for example, to determine whether or not the 7 ;employee is entitled to such exceptions as Leave, OT, etc., 8 ;and then calls ^PRS8AC to process them. 9 ; 10 ;Called by Routines: PRS8ST 11 ; 12 S TT=$P(V,"^",3) ;type of time 13 I TT="OT",+$P(V,"^",4)=8,$E(ENT,18) S TT="TT" ;ot in travel status 14 I TT="CU",$P(V,"^",4)=6 Q ;comp for religious purposes/don't code 15 I TT="HW",$E(ENT,1,2)="0D" S TT="RG" 16 I TT="OT",TYP["P",TYP'["B" S TT="RG" ;To convert Pt ot to RG 17 I TT="HW",TYP'["D",+V,+$P(V,"^",2) D 18 .I $P(V,"^",2)-V-1<8 D ; <2 hrs HW 19 ..S ^TMP($J,"PRS8",DY,"HW")=$G(^TMP($J,"PRS8",DY,"HW"))_$P(V,U,1,2)_U 20 ..Q 21 .I TYP["P",$P(V,"^",2)>96 S LEN=$P(V,"^",2)-96 D ;two day tour of HW for part timers 22 ..S ^TMP($J,"PRS8",DY+1,"HWK")=$G(^TMP($J,"PRS8",DY+1,"HWK"))_1_U_LEN_U 23 ..K LEN 24 ..Q 25 .I TYP["P",TYP["N"!(TYP["H"),'$E(DAY(DY,"W"),+V) D ; part time nurses, uscheduled HW. 26 ..S ^TMP($J,"PRS8",DY,"HWK")=$G(^TMP($J,"PRS8",DY,"HWK"))_$P(V,U,1,2)_U 27 ..Q 28 .Q 29 S X="^AL^SL^WP^NP^AA^RL^CU^CT^CP^HX^ML^TR^TV^OT^RG^TT^SB^ON^NL^HW^CB^AD^DL^RS" ;code 30 S X=($F(X,"^"_TT)\3)+4,(X,TT(1))=$P($T(ACT+X),";;",2) ;parameters 31 S GO=0 I '+X!($E(ENT,+X)) S GO=1 ;entitlement exists-continue 32 I TT="RG",$E(ENT,2)'=0 S GO=1 ;intermittent 33 I TT="RG"!(TT="CP"),$E(ENT,2)="D" S DAY(DY,"DWK")=1 ;intrmtnt-count days worked (for RG or CP) 34 I TT="OT",'GO,$E(ENT,13)!$E(ENT,14) S GO=1 ;entitled to ot 35 I TT="UN" S GO=1,VAR="-" ;unavailable 36 I TYP["W",TT="RG",$P(V,"^",4)=7 D 37 .;wage grade employee working regular unscheduled hours for 38 .;shift coverage (7) can get shift differential based on the higher 39 .;of the unscheduled tour's shift or their normal shift. 40 .;The unscheduled tour and corresponding differential will be saved 41 .;in the "SD" node and used by PRS8PP when differentials are 42 .;computed. 43 .N ST,EN,SD,MID 44 .S ST=$P(V,"^"),EN=$P(V,"^",2) Q:'ST!'EN 45 .S MID=ST+EN/2 46 .; check for 2day tour and if found use combined tour (recompute MID) 47 .; to determine appropriate shift differential. 48 .; if start is 1 (midnight) then check previous day for a similar tour 49 .; that ended at 96 (midnight). 50 . I ST=1 D 51 .. N PRSI,PRSX 52 .. S PRSX=$G(^TMP($J,"PRS8",DY-1,2)) 53 .. F PRSI=1:1:7 Q:$P(PRSX,U,(PRSI-1)*4+1)="" D 54 ... I $P(PRSX,U,(PRSI-1)*4+2)=96,$P(PRSX,U,(PRSI-1)*4+3)="RG",$P(PRSX,U,(PRSI-1)*4+4)=7 S MID=($P(PRSX,U,(PRSI-1)*4+1)+EN+96)/2 55 .; if end is 96 (midnight) then check next day for a similar tour that 56 .; starts at 1 (midnight). 57 . I EN=96 D 58 .. N PRSI,PRSX 59 .. S PRSX=$G(^TMP($J,"PRS8",DY+1,2)) 60 .. F PRSI=1:1:7 Q:$P(PRSX,U,(PRSI-1)*4+1)="" D 61 ... I $P(PRSX,U,(PRSI-1)*4+1)=1,$P(PRSX,U,(PRSI-1)*4+3)="RG",$P(PRSX,U,(PRSI-1)*4+4)=7 S MID=(ST+$P(PRSX,U,(PRSI-1)*4+2)+96)/2 62 .; determine shift differential (if any) based on unscheduled tour hours 63 .S SD=0 64 .I MID<32.5 S SD=3 ; majority of tour before 8a 65 .I MID>60.5,MID'>94.5 S SD=2 ; majority of tour after 3p, upto 11:30p 66 .I MID>94.5,MID<128.5 S SD=3 ; majority of tour after 11:30p, before 8a 67 .; use employee's normal shift if higher than shift based on hours 68 .I TOUR>1,TOUR>SD S SD=TOUR 69 .S:SD ^TMP($J,"PRS8",DY,"SD")=$G(^TMP($J,"PRS8",DY,"SD"))_ST_U_EN_U_SD_U 70 .Q 71 I (TT="OT"!(TT="RG")!(TT="CT")),"^13^14^"[("^"_$P(V,"^",4)_"^")!($P(V,"^",4)=12&(TYP["N"!(TYP["H"))) D 72 .S ^TMP($J,"PRS8",DY,"CB")=$G(^TMP($J,"PRS8",DY,"CB"))_$P(V,"^",1,2)_"^" 73 .Q 74 I TYP'["D",TT="HX"!(TT="HW") S GO=1 ;process holiday excused/worked 75 G END:'GO ;nothing to process 76 I TT'="UN" S VAR=$P(X,"^",3) ;increment time code 77 I '$S(VAR'="W":1,'CYA:1,DY<CYA:1,1:0) D 78 .S WPCY=1 ;flag to save WOP in hours from 1/1 for calendar year adjustment 79 I TYP'["D" D G END ;process hourly people and quit 80 .; The following 2 lines commented out because for Employees that are 81 .; non-daily tour (TYP'["D"), policy is has been described that all 82 .; ML/COP has to be posted by time-keeper. 83 .; If this changes, then uncomment these lines, remove the line adding 84 .; military leave and COP that follows, and refer to routine PRS8UP. 85 .; I VAR="M" S ^TMP($J,"PRS8",DY,"ML")=1,MILV=1 ;military leave taken 86 .; I VAR="V" S ^TMP($J,"PRS8",DY,"CP")=1,WCMP=1 ;cont of pay indicator 87 .I DY>0,DY<15 D 88 ..; Post ML for employees who are charged in days. 89 ..I VAR="M",$$MLINHRS^PRSAENT(DFN)=0 D 90 ...S X=$P(TT(1),"^",4) D SET ; military leave & auth. absence 91 ..I VAR="V",'$G(^TMP($J,"PRS8",DY,"CP")) S X="M",^TMP($J,"PRS8",DY,"CP")=1 D SET ; COP 92 ..Q 93 .D ^PRS8AC ;update activity string 94 .Q 95 ; Employees with daily tours (TYP["D") 96 I DY>0,DY<15,VAR="M" S X=$P(TT(1),"^",4) D SET S X=5 D SET G END ;military leave & auth. absence 97 I DY>0,DY<15,$$HOLIDAY^PRS8UT(PY,DFN,DY) D G END ;holiday-no charge 98 .I TT="RG" S DAY(DY,"W")=VAR,X=$S('$E(ENT,TOUR+21):9,1:TOUR+28) D SET ; If worked on holiday count it. 99 .Q 100 S D=DY 101 I TT="NP"!($P(DAY(D,0),"^",2)'=1) S DAY(D,"W")=VAR,X=$P(TT(1),"^",4) I X'="",DY>0,DY<15 D SET I VAR="V" S X="M" D SET I VAR="V",TYP["DI",$E(ENT,2)="D" S X=9 D SET ; IF INT RESDNT PAID IN DAYS HAS COP POSTED PAY UN/US ALSO 102 D ENCAP^PRS8EX0 103 ; 104 END ; --- all done here 105 K A,D,DD,GO,TT,X,Z 106 Q 107 ; 108 SET ; --- enter here to set without VAL defined 109 ; Quit if this day has already been counted through the encapsulation 110 ; check that is performed in ENCAP^PRS8EX0. 111 Q:$D(^TMP($J,"PRS8",DY,2,0)) 112 ; 113 Q:X="K"&($P(V,"^",1)>96)!((X="K")&($D(^TMP($J,"PRS8",DY,"ML")))) S ^TMP($J,"PRS8",DY,"ML")=1 ;stop counting ML twice for two day tours & split tours, but allow PC 114 I +X S $P(WK(WK),"^",+X)=$P(WK(WK),"^",+X)+1 115 E S X=$A(X)-64,$P(WK(3),"^",+X)=$P(WK(3),"^",+X)+1 116 Q 117 ; 118 ACT ; --- define variable X for action 119 ; - piece 1 = entitlement (ENT) string $Extract to check 120 ; - 2 = Literal name of exception 121 ; - 3 = Time String code (DAY(X,"W")) 122 ;; 123 ;;30^Annual Leave^L^1 124 ;;31^Sick Leave^S^2 125 ;;33^Without Pay^W^3 126 ;;36^Non-Pay Status^n^4 127 ;;35^Authorized Absence^A^5 128 ;;30^Restored Leave^R^6 129 ;;28^Comp Used^U^8 130 ;;28^Comp Earned^E^7 131 ;;37^Continuation of Pay^V^33 132 ;;38^Holiday Excused^H 133 ;;34^Military Leave^M^K 134 ;;0^Training^X^43 135 ;;0^Travel^Y^42 136 ;;12^Overtime^O 137 ;;2^Unscheduled^4^9 138 ;;18^OT in Travel Status^T 139 ;;29^Standby^B 140 ;;26^On-Call^C 141 ;;36^Nonpay A/L^N^A 142 ;;38^Holiday Worked^h 143 ;;31^Care and Bereavement^F^44 144 ;;31^Adoption^G^45 145 ;;35^Donor Leave^D^46 146 ;;5^Recess^r^48 1 PRS8EX ;HISC/MRL,WCIOFO/SAB-DECOMPOSITION, EXCEPTIONS ;1/25/2007 2 ;;4.0;PAID;**2,40,56,69,111**;Sep 21, 1995;Build 2 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;This routine is used to process most exceptions to the normal 6 ;tod. It is used, for example, to determine whether or not the 7 ;employee is entitled to such exceptions as Leave, OT, etc., 8 ;and then calls ^PRS8AC to process them. 9 ; 10 ;Called by Routines: PRS8ST 11 ; 12 S TT=$P(V,"^",3) ;type of time 13 I TT="OT",+$P(V,"^",4)=8,$E(ENT,18) S TT="TT" ;ot in travel status 14 I TT="CU",$P(V,"^",4)=6 Q ;comp for religious purposes/don't code 15 I TT="HW",$E(ENT,1,2)="0D" S TT="RG" 16 I TT="OT",TYP["P",TYP'["B" S TT="RG" ;To convert Pt ot to RG 17 I TT="HW",TYP'["D",+V,+$P(V,"^",2) D 18 .I $P(V,"^",2)-V-1<8 D ; <2 hrs HW 19 ..S ^TMP($J,"PRS8",DY,"HW")=$G(^TMP($J,"PRS8",DY,"HW"))_$P(V,U,1,2)_U 20 ..Q 21 .I TYP["P",$P(V,"^",2)>96 S LEN=$P(V,"^",2)-96 D ;two day tour of HW for part timers 22 ..S ^TMP($J,"PRS8",DY+1,"HWK")=$G(^TMP($J,"PRS8",DY+1,"HWK"))_1_U_LEN_U 23 ..K LEN 24 ..Q 25 .I TYP["P",TYP["N"!(TYP["H"),'$E(DAY(DY,"W"),+V) D ; part time nurses, uscheduled HW. 26 ..S ^TMP($J,"PRS8",DY,"HWK")=$G(^TMP($J,"PRS8",DY,"HWK"))_$P(V,U,1,2)_U 27 ..Q 28 .Q 29 S X="^AL^SL^WP^NP^AA^RL^CU^CT^CP^HX^ML^TR^TV^OT^RG^TT^SB^ON^NL^HW^CB^AD^DL" ;code 30 S X=($F(X,"^"_TT)\3)+4,(X,TT(1))=$P($T(ACT+X),";;",2) ;parameters 31 S GO=0 I '+X!($E(ENT,+X)) S GO=1 ;entitlement exists-continue 32 I TT="RG",$E(ENT,2)'=0 S GO=1 ;intermittent 33 I TT="RG"!(TT="CP"),$E(ENT,2)="D" S DAY(DY,"DWK")=1 ;intrmtnt-count days worked (for RG or CP) 34 I TT="OT",'GO,$E(ENT,13)!$E(ENT,14) S GO=1 ;entitled to ot 35 I TT="UN" S GO=1,VAR="-" ;unavailable 36 I TYP["W",TT="RG",$P(V,"^",4)=7 D 37 .;wage grade employee working regular unscheduled hours for 38 .;shift coverage (7) can get shift differential based on the higher 39 .;of the unscheduled tour's shift or their normal shift. 40 .;The unscheduled tour and corresponding differential will be saved 41 .;in the "SD" node and used by PRS8PP when differentials are 42 .;computed. 43 .N ST,EN,SD,MID 44 .S ST=$P(V,"^"),EN=$P(V,"^",2) Q:'ST!'EN 45 .S MID=ST+EN/2 46 .; check for 2day tour and if found use combined tour (recompute MID) 47 .; to determine appropriate shift differential. 48 .; if start is 1 (midnight) then check previous day for a similar tour 49 .; that ended at 96 (midnight). 50 . I ST=1 D 51 .. N PRSI,PRSX 52 .. S PRSX=$G(^TMP($J,"PRS8",DY-1,2)) 53 .. F PRSI=1:1:7 Q:$P(PRSX,U,(PRSI-1)*4+1)="" D 54 ... I $P(PRSX,U,(PRSI-1)*4+2)=96,$P(PRSX,U,(PRSI-1)*4+3)="RG",$P(PRSX,U,(PRSI-1)*4+4)=7 S MID=($P(PRSX,U,(PRSI-1)*4+1)+EN+96)/2 55 .; if end is 96 (midnight) then check next day for a similar tour that 56 .; starts at 1 (midnight). 57 . I EN=96 D 58 .. N PRSI,PRSX 59 .. S PRSX=$G(^TMP($J,"PRS8",DY+1,2)) 60 .. F PRSI=1:1:7 Q:$P(PRSX,U,(PRSI-1)*4+1)="" D 61 ... I $P(PRSX,U,(PRSI-1)*4+1)=1,$P(PRSX,U,(PRSI-1)*4+3)="RG",$P(PRSX,U,(PRSI-1)*4+4)=7 S MID=(ST+$P(PRSX,U,(PRSI-1)*4+2)+96)/2 62 .; determine shift differential (if any) based on unscheduled tour hours 63 .S SD=0 64 .I MID<32.5 S SD=3 ; majority of tour before 8a 65 .I MID>60.5,MID'>94.5 S SD=2 ; majority of tour after 3p, upto 11:30p 66 .I MID>94.5,MID<128.5 S SD=3 ; majority of tour after 11:30p, before 8a 67 .; use employee's normal shift if higher than shift based on hours 68 .I TOUR>1,TOUR>SD S SD=TOUR 69 .S:SD ^TMP($J,"PRS8",DY,"SD")=$G(^TMP($J,"PRS8",DY,"SD"))_ST_U_EN_U_SD_U 70 .Q 71 I (TT="OT"!(TT="RG")!(TT="CT")),"^13^14^"[("^"_$P(V,"^",4)_"^")!($P(V,"^",4)=12&(TYP["N"!(TYP["H"))) D 72 .S ^TMP($J,"PRS8",DY,"CB")=$G(^TMP($J,"PRS8",DY,"CB"))_$P(V,"^",1,2)_"^" 73 .Q 74 I TYP'["D",TT="HX"!(TT="HW") S GO=1 ;process holiday excused/worked 75 G END:'GO ;nothing to process 76 I TT'="UN" S VAR=$P(X,"^",3) ;increment time code 77 I '$S(VAR'="W":1,'CYA:1,DY<CYA:1,1:0) D 78 .S WPCY=1 ;flag to save WOP in hours from 1/1 for calander year adjustment 79 I TYP'["D" D G END ;process hourly people and quit 80 .; The following 2 lines commented out because for Employees that are 81 .; non-daily tour (TYP'["D"), policy is has been described that all 82 .; ML/COP has to be posted by time-keeper. 83 .; If this changes, then uncomment these lines, remove the line adding 84 .; military leave and COP that follows, and refer to routine PRS8UP. 85 .; I VAR="M" S ^TMP($J,"PRS8",DY,"ML")=1,MILV=1 ;military leave taken 86 .; I VAR="V" S ^TMP($J,"PRS8",DY,"CP")=1,WCMP=1 ;cont of pay indicator 87 .I DY>0,DY<15 D 88 ..; Post ML for employees who are charged in days. 89 ..I VAR="M",$$MLINHRS^PRSAENT(DFN)=0 D 90 ...S X=$P(TT(1),"^",4) D SET ; military leave & auth. absence 91 ..I VAR="V",'$G(^TMP($J,"PRS8",DY,"CP")) S X="M",^TMP($J,"PRS8",DY,"CP")=1 D SET ; COP 92 ..Q 93 .D ^PRS8AC ;update activity string 94 .Q 95 ; Employees with daily tours (TYP["D") 96 I DY>0,DY<15,VAR="M" S X=$P(TT(1),"^",4) D SET S X=5 D SET G END ;military leave & auth. absence 97 I DY>0,DY<15,$$HOLIDAY^PRS8UT(PY,DFN,DY) D G END ;holiday-no charge 98 .I TT="RG" S DAY(DY,"W")=VAR,X=$S('$E(ENT,TOUR+21):9,1:TOUR+28) D SET ; If worked on holiday count it. 99 .Q 100 S D=DY 101 I TT="NP"!($P(DAY(D,0),"^",2)'=1) S DAY(D,"W")=VAR,X=$P(TT(1),"^",4) I X'="",DY>0,DY<15 D SET I VAR="V" S X="M" D SET I VAR="V",TYP["DI",$E(ENT,2)="D" S X=9 D SET ; IF INT RESDNT PAID IN DAYS HAS COP POSTED PAY UN/US ALSO 102 D ENCAP^PRS8EX0 103 ; 104 END ; --- all done here 105 K A,D,DD,GO,TT,X,Z 106 Q 107 ; 108 SET ; --- enter here to set without VAL defined 109 ; Quit if this day has already been counted through the encapsulation 110 ; check that is performed in ENCAP^PRS8EX0. 111 Q:$D(^TMP($J,"PRS8",DY,2,0)) 112 ; 113 Q:X="K"&($P(V,"^",1)>96)!((X="K")&($D(^TMP($J,"PRS8",DY,"ML")))) S ^TMP($J,"PRS8",DY,"ML")=1 ;stop counting ML twice for two day tours & split tours, but allow PC 114 I +X S $P(WK(WK),"^",+X)=$P(WK(WK),"^",+X)+1 115 E S X=$A(X)-64,$P(WK(3),"^",+X)=$P(WK(3),"^",+X)+1 116 Q 117 ; 118 ACT ; --- define variable X for action 119 ; - piece 1 = entitlement (ENT) string $Extract to check 120 ; - 2 = Literal name of exception 121 ; - 3 = Time String code (DAY(X,"W")) 122 ;; 123 ;;30^Annual Leave^L^1 124 ;;31^Sick Leave^S^2 125 ;;33^Without Pay^W^3 126 ;;36^Non-Pay Status^n^4 127 ;;35^Authorized Absence^A^5 128 ;;30^Restored Leave^R^6 129 ;;28^Comp Used^U^8 130 ;;28^Comp Earned^E^7 131 ;;37^Continuation of Pay^V^33 132 ;;38^Holiday Excused^H 133 ;;34^Military Leave^M^K 134 ;;0^Training^X^43 135 ;;0^Travel^Y^42 136 ;;12^Overtime^O 137 ;;2^Unscheduled^4^9 138 ;;18^OT in Travel Status^T 139 ;;29^Standby^B 140 ;;26^On-Call^C 141 ;;36^Nonpay A/L^N^A 142 ;;38^Holiday Worked^h 143 ;;31^Care and Bereavement^F^44 144 ;;31^Adoption^G^45 145 ;;35^Donor Leave^D^46 -
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 -
WorldVistAEHR/trunk/r/PAID-PRS/PRS8HR.m
r613 r623 1 PRS8HR ;HISC/MRL,WCIOFO/JAH-DECOMPOSITION, HOURS ;06/25/07 2 ;;4.0;PAID;**2,22,29,42,52,102,108,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;This routine is called by ^PRS8PP (premium pay calculator) 6 ;===================================================================== 7 ; ** indicates incompleted comments 8 ; 9 ;VARIABLE DEFINITION 10 ; 11 ; TYP = contains codes representing type of employee. 12 ; It's a composite code string w/ characters that 13 ; represent pay plan, duty basis, & normal hours. 14 ; CODE REPRESENTS CODE REPRESENTS 15 ; D daily f firefighter 16 ; W wagegrade P part-time 17 ; N nurse d doctor 18 ; B baylor plan dR doctor/resident or intern 19 ; H Nurse Hybrid "" * 20 ; I intermittent 21 ; VAL = Single char code represents employee's work status for 22 ; current 15 min increment. 23 ; FLX = Flex tour indicator. 24 ; TH(W) = Tour Hours for week 1, TH(1) & week 2, TH(2) 25 ; TH = Tour Hours 26 ; HTP = PAYABLE hours worked today. 27 ; HT = Hours worked today. 28 ; AV = String w/ most normal types of time (see bottom of PRS8EX) 29 ; does NOT contain premium times or unscheduled time (OoEes4) 30 ;==================================================================== 31 ; 32 S AV="1235nHMLSWNARUXYVJFGD" 33 ; 34 ; Loop thru each quarter hour segment of day. 35 ; Check for times in AV array. 36 ; Proceed w/ calculation if Overtime worked on Holiday. 37 ; 38 F M=1:1:96 D 39 . S VAL=$E(D,M) 40 .; 41 .; If non premium type of time or (overtime on holiday) 42 .; 43 . I AV[VAL!(VAL="O"&($E(DAY(DAY,"HOL"),M)=2)) D CALC 44 Q 45 ; 46 ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 47 ; 48 CALC ; --- Entry point for calculating placement of time 49 ; 50 ; Set up variables for calculations and comparisons in this routine 51 ; 52 N HOLWKD,HOLEX,HOLWKEX 53 D ^PRS8HRSV 54 ; 55 ; IF intermittent employee on continuation of pay OR overtime on 56 ; holiday THEN increment Pay Period tour hours and current weeks 57 ; tour hours. 58 ; 59 I TYP["I",VAL["V"!(VAL="O"&(HOLWKD)) S TH=TH+1,TH(W)=TH(W)+1 60 ; 61 ; IF part time doctor & total hours = 80 & type of 62 ; time is unscheduled, overtime, comptime THEN quit 63 ; 64 I TYP["d",TYP["P",TH=320,"4OosEe"[VAL Q 65 ; 66 ; IF INT doctor & total hours = 80 THEN quit 67 ; 68 I TYP["I",$E(AC,1)="L",TH=320,"4OosEe"[VAL Q 69 ; 70 ; IF type of time is anything but Leave Without Pay "W" or Non-Pay "n" 71 ; THEN increment total hrs HT & increment HTP. Also update 72 ; ^TMP global for reference during the processing of On-Call (PRS8OC). 73 ; 74 I "Wn"'[VAL S HT=HT+1,HTP=HTP+1,^TMP($J,"PRS8",DAY,"HT")=HT 75 ; 76 ;--------------------------------------------------------- 77 ; IF entitled to VCS commission sales & normal time(1) ??(2,3) 78 ; & holiday excused set X to type of time=Piece Worker Hol excused. 79 ; Then IF part time set X to part time hours code. 80 ; 81 I $E(ENT,38),"123"[VAL,HOLEX S X=36 D CHK^PRS8HRSV D Q:X 82 . I TYP["P" S X=32 D CHK^PRS8HRSV 83 ; 84 ;--------------------------------------------------------------- 85 ; 86 ; Don't mess w/ fire fighters 87 ; 88 Q:"Ff"[TYP 89 ; 90 S GO=0 91 ; IF compressed tour & parttime & tour hours are over 80 92 ; OR tour hours = 80 & it's overtime, comptime, or unscheduled reg. 93 ; 94 ; Check for FT Compressed 95 I $E(AC,2)=1,NH>319,FLX="C",("OoseE4"[VAL) S GO=1 96 ; 97 ; Check for week 98 I (TH(W)>160&("OoseE4"[VAL))!(TH(W)=160&("OosEe4"[VAL)) S GO=1 99 ; 100 ; Check for day 101 I HT>32,"OoseE4"[VAL S GO=1 102 ; 103 ; Following segment is concerned w/ variations of part time 104 ; employees (TYP["P"), & 1 baylor (TYP["B"). 105 ;------------------------------------------------------------------- 106 ; 107 ; Doctor over 8 hours 108 ; 109 I TYP["Pd",HT>32 S GO=0 ; part-time doctors PT + PH must = NH 110 ; 111 I TYP["P",HOLWKD S GO=0 112 ; 113 ; Baylor plan & ct/ot/s 114 ; 115 I TYP["B","EeOos"[VAL S GO=1 116 ; 117 ;------------------------------------------------------------------- 118 ; GO set in cases where employee maybe eligible for OT 119 ; due to over > 8/day OR > 40/week. 120 ; 121 S X=0 I GO D TH^PRS8HRSV D OVER840^PRS8HROT Q 122 ; 123 ;------------------------------------------------------------------- 124 ;------------------------------------------------------------------- 125 ; GO not set for compressed schedule of at least 80 hrs. 126 ; GO not set for non compressed schedule of over 40 hrs. 127 ; IF GO is set and we are evaluating normal hours or 128 ; HOLIDAY OVERTIME use NORMHRS to increment TIME 129 ; in week array. THEN QUIT. 130 ; 131 S GO=1 132 I FLX="C",NH>319 S GO=0 133 I FLX'="C",NH(WK)>160,TYP'["Pd" S GO=0 ;IF pt-doctor don't set GO=0 134 I GO,"1235nHMLSWNARUXYVJFGD"[VAL!(VAL="O"&(HOLWKD)) D NORMHRS^PRS8HROT Q 135 ; 136 ;-------------------------------------------------------------------- 137 ; Check employees with Normal hours less than 80. (Baylor NH=320) 138 ; 139 I NH'>319!(($E(AC,2)=2)&(NH=320)) D TH^PRS8HRSV D Q 140 .I FLX="C" D Q:X 141 ..; 142 ..; For PT employees review hours worked to determine X 143 ..I "OosEe4"'[VAL S X=32 ; All tour time = PT/PH 144 ..; 145 ..; Checks for CT 146 ..I "Ee"[VAL D 147 ...; <8/DAY & <40/WK = UN/US 148 ...I HT'>32,TH(W)'>160 S X=9 Q 149 ...S X=7 ; CE/CT 150 ..; 151 ..; Checks for all other types of time 152 ..I "Oos4"[VAL D 153 ...I HT>32 S X=TOUR+15 Q ; DA/DE 154 ...I TH(W)>160 S X=TOUR+19 Q ; OA/OE 155 ...S X=9 ; UN/US 156 ..D CHK^PRS8HRSV 157 .; 158 .; Under 8/day, 40/week, and not coded as overtime or comptime 159 .; or overtime on holiday. 160 .; 161 .; Checks for non-compressed employees 162 .I HT'>32,TH(W)'>160,"OoseE"'[VAL!(VAL="O"&(HOLWKD)) S X=0 D Q:X 163 ..; 164 ..; Not intermittent, normal hours and not unscheduled reg. 165 ..; TIME gets parttime hours. 166 ..; 167 ..I TYP'["I",AV[VAL,VAL'=4 S X=32 D CHK^PRS8HRSV Q 168 ..; 169 ..; All else fails - TIME gets unscheduled regular. 170 ..; 171 ..S X=9 D CHK^PRS8HRSV Q 172 .; 173 .; Part time doctor w/ unscheduled reg. TIME gets unscheduled reg. 174 .; 175 .I TYP["P",TYP["d",VAL=4 S X=9 D CHK^PRS8HRSV Q 176 .; 177 .; Over 8/day 178 .; 179 .I HT>32 D G8^PRS8HRSV Q:X 180 .; 181 .; For all time left except comptime set TIME to appropriate OT 182 .; unless comptime has been worked earlier in the week making 183 .; the total hours less than 40, then TIME gets unscheduled reg. 184 .; COMPTIME OVER 8/DAY WILL BE CREDITED HERE 185 .; 186 .S X=$S("Ee"'[VAL:TOUR+19,(TH(W)'>160)&(HT'>32):9,1:7) 187 .I TYP["P",VAL[4,TH(W)'>160,HT'>32 S X=9 188 .I TYP["P",VAL="O",TH(W)'>160,HT'>32 S X=9 189 .D CHK^PRS8HRSV 190 Q 1 PRS8HR ;HISC/MRL,WCIOFO/JAH-DECOMPOSITION, HOURS ;05/05/06 2 ;;4.0;PAID;**2,22,29,42,52,102,108**;Sep 21, 1995 3 ; 4 ;This routine is called by ^PRS8PP (premium pay calculator) 5 ;===================================================================== 6 ; ** indicates incompleted comments 7 ; 8 ;VARIABLE DEFINITION 9 ; 10 ; TYP = contains codes representing type of employee. 11 ; It's a composite code string w/ characters that 12 ; represent pay plan, duty basis, & normal hours. 13 ; CODE REPRESENTS CODE REPRESENTS 14 ; D daily f firefighter 15 ; W wagegrade P part-time 16 ; N nurse d doctor 17 ; B baylor plan dR doctor/resident or intern 18 ; H Nurse Hybrid "" * 19 ; I intermittent 20 ; VAL = Single char code represents employee's work status for 21 ; current 15 min increment. 22 ; FLX = Flex tour indicator. 23 ; TH(W) = Tour Hours for week 1, TH(1) & week 2, TH(2) 24 ; TH = Tour Hours 25 ; HTP = PAYABLE hours worked today. 26 ; HT = Hours worked today. 27 ; AV = String w/ most normal types of time (see bottom of PRS8EX) 28 ; does NOT contain premium times or unscheduled time (OoEes4) 29 ;==================================================================== 30 ; 31 S AV="1235nHMLSWNARUXYVJFGD" 32 ; 33 ; Loop thru each quarter hour segment of day. 34 ; Check for times in AV array. 35 ; Proceed w/ calculation if Overtime worked on Holiday. 36 ; 37 F M=1:1:96 D 38 . S VAL=$E(D,M) 39 .; 40 .; If non premium type of time or (overtime on holiday) 41 .; 42 . I AV[VAL!(VAL="O"&($E(DAY(DAY,"HOL"),M)=2)) D CALC 43 Q 44 ; 45 ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 46 ; 47 CALC ; --- Entry point for calculating placement of time 48 ; 49 ; Set up variables for calculations and comparisons in this routine 50 ; 51 N HOLWKD,HOLEX,HOLWKEX 52 D ^PRS8HRSV 53 ; 54 ; IF intermittent employee on continuation of pay OR overtime on 55 ; holiday THEN increment Pay Period tour hours and current weeks 56 ; tour hours. 57 ; 58 I TYP["I",VAL["V"!(VAL="O"&(HOLWKD)) S TH=TH+1,TH(W)=TH(W)+1 59 ; 60 ; IF part time doctor & total hours = 80 & type of 61 ; time is unscheduled, overtime, comptime THEN quit 62 ; 63 I TYP["d",TYP["P",TH=320,"4OosEe"[VAL Q 64 ; 65 ; IF INT doctor & total hours = 80 THEN quit 66 ; 67 I TYP["I",$E(AC,1)="L",TH=320,"4OosEe"[VAL Q 68 ; 69 ; IF type of time is anything but (leave w/out pay, comp time) 70 ; THEN increment total hrs(HT) & increment HTP if type of 71 ; time not non pay or leave w/out pay. 72 ; 73 ; Update daily counter - *102 added non-pay back into daily count 74 ; 75 S HT=HT+1,HTP=HTP+1 76 ; 77 ;--------------------------------------------------------- 78 ; IF entitled to VCS commission sales & normal time(1) ??(2,3) 79 ; & holiday excused set X to type of time=Piece Worker Hol excused. 80 ; Then IF part time set X to part time hours code. 81 ; 82 I $E(ENT,38),"123"[VAL,HOLEX S X=36 D CHK^PRS8HRSV D Q:X 83 . I TYP["P" S X=32 D CHK^PRS8HRSV 84 ; 85 ;--------------------------------------------------------------- 86 ; 87 ; Don't mess w/ fire fighters 88 ; 89 Q:"Ff"[TYP 90 ; 91 S GO=0 92 ; IF compressed tour & parttime & tour hours are over 80 93 ; OR tour hours = 80 & it's overtime, comptime, or unscheduled reg. 94 ; 95 ; Check for FT Compressed 96 I NH>319,FLX="C",("OoseE4"[VAL) S GO=1 97 ; 98 ; Check for week 99 I (TH(W)>160&("OoseE4"[VAL))!(TH(W)=160&("OosEe4"[VAL)) S GO=1 100 ; 101 ; Check for day 102 I HT>32,"OoseE4"[VAL S GO=1 103 ; 104 ; Following segment is concerned w/ variations of part time 105 ; employees (TYP["P"), & 1 baylor (TYP["B"). 106 ;------------------------------------------------------------------- 107 ; 108 ; Doctor over 8 hours 109 ; 110 I TYP["Pd",HT>32 S GO=0 ; part-time doctors PT + PH must = NH 111 ; 112 I TYP["P",HOLWKD S GO=0 113 ; 114 ; Baylor plan & ct/ot/s 115 ; 116 I TYP["B","EeOos"[VAL S GO=1 117 ; 118 ;------------------------------------------------------------------- 119 ; GO set in cases where employee maybe eligible for OT 120 ; due to over > 8/day OR > 40/week. 121 ; 122 S X=0 I GO D TH^PRS8HRSV D OVER840^PRS8HROT Q 123 ; 124 ;------------------------------------------------------------------- 125 ;------------------------------------------------------------------- 126 ; GO not set for compressed schedule of at least 80 hrs. 127 ; GO not set for non compressed schedule of over 40 hrs. 128 ; IF GO is set and we are evaluating normal hours or 129 ; HOLIDAY OVERTIME use NORMHRS to increment TIME 130 ; in week array. THEN QUIT. 131 ; 132 S GO=1 133 I FLX="C",NH>319 S GO=0 134 I FLX'="C",NH(WK)>160,TYP'["Pd" S GO=0 ;IF pt-doctor don't set GO=0 135 I GO,"1235nHMLSWNARUXYVJFGD"[VAL!(VAL="O"&(HOLWKD)) D NORMHRS^PRS8HROT Q 136 ; 137 ;-------------------------------------------------------------------- 138 ; Check employees with Normal hours less than 80. (Baylor NH=320) 139 ; 140 I NH'>319 D TH^PRS8HRSV D Q 141 .I FLX="C" D Q:X 142 ..; 143 ..; For PT employees review hours worked to determine X 144 ..I "OosEe4"'[VAL S X=32 ; All tour time = PT/PH 145 ..; 146 ..; Checks for CT 147 ..I "Ee"[VAL D 148 ...; <8/DAY & <40/WK = UN/US 149 ...I HT'>32,TH(W)'>160 S X=9 Q 150 ...S X=7 ; CE/CT 151 ..; 152 ..; Checks for all other types of time 153 ..I "Oos4"[VAL D 154 ...I HT>32 S X=TOUR+15 Q ; DA/DE 155 ...I TH(W)>160 S X=TOUR+19 Q ; OA/OE 156 ...S X=9 ; UN/US 157 ..D CHK^PRS8HRSV 158 .; 159 .; Under 8/day, 40/week, and not coded as overtime or comptime 160 .; or overtime on holiday. 161 .; 162 .; Checks for non-compressed employees 163 .I HT'>32,TH(W)'>160,"OoseE"'[VAL!(VAL="O"&(HOLWKD)) S X=0 D Q:X 164 ..; 165 ..; Not intermittent, normal hours and not unscheduled reg. 166 ..; TIME gets parttime hours. 167 ..; 168 ..I TYP'["I",AV[VAL,VAL'=4 S X=32 D CHK^PRS8HRSV Q 169 ..; 170 ..; All else fails - TIME gets unscheduled regular. 171 ..; 172 ..S X=9 D CHK^PRS8HRSV Q 173 .; 174 .; Part time doctor w/ unscheduled reg. TIME gets unscheduled reg. 175 .; 176 .I TYP["P",TYP["d",VAL=4 S X=9 D CHK^PRS8HRSV Q 177 .; 178 .; Over 8/day 179 .; 180 .I HT>32 D G8^PRS8HRSV Q:X 181 .; 182 .; For all time left except comptime set TIME to appropriate OT 183 .; unless comptime has been worked earlier in the week making 184 .; the total hours less than 40, then TIME gets unscheduled reg. 185 .; COMPTIME OVER 8/DAY WILL BE CREDITED HERE 186 .; 187 .S X=$S("Ee"'[VAL:TOUR+19,(TH(W)'>160)&(HT'>32):9,1:7) 188 .I TYP["P",VAL[4,TH(W)'>160,HT'>32 S X=9 189 .D CHK^PRS8HRSV 190 Q 191 ; 192 ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 193 ; ### DELETE UNLESS EARLIER CHECK WAS RESTORED 194 CT2DAY() ;Determine if comptime eligible including 2 day tour. 195 ; 196 N TOUREC,TWODAY 197 S (RTN,TWODAY)=0 198 ; 199 ; IF time segment contains Scheduled or unscheduled comptime 200 ; or overtime and there is some time in tour hours worked THEN 201 ; check if it's a 2 day tour. For 2 day tours some of time worked 202 ; won't be in HT variable since it occured on other day of two 203 ; day tour, it's not valid to simply check the HT variable for 204 ; 8 hours of work. (patch PRS*4*22) 205 ; 206 I "OosEe4"[VAL,(HT>0),(NH>319) D 207 .S TOUREC=$P($G(DAY(DAY,0)),"^",2) 208 .I TOUREC>0 S TWODAY=$P($G(^PRST(457.1,TOUREC,0)),"^",5) 209 .I TWODAY="Y" S RTN=1 210 Q RTN -
WorldVistAEHR/trunk/r/PAID-PRS/PRS8HRSV.m
r613 r623 1 PRS8HRSV ;WCIOFO/JAH-HOLIDAY FLAG, TIME CHECKER, WK() SET; 04/05/07 2 ;;4.0;PAID;**29,52,102,108,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; Set up variable for holiday worked or holiday excused 5 ; Holiday worked coded 2 in DAY array 6 ; Holiday excused coded 1 in DAY array 7 ; A NON holiday is coded as all zero's in day array. 8 ; 9 ; HOLIDAY WORKED 10 S HOLWKD=$E(DAY(DAY,"HOL"),M)=2 11 ; 12 ; HOLIDAY EXCUSED 13 S HOLEX=$E(DAY(DAY,"HOL"),M)=1 14 ; 15 ; HOLIDAY EXCUSED OR HOLIDAY WORKED 16 S HOLWKEX=$E(DAY(DAY,"HOL"),M) 17 Q 18 ; 19 ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 20 ; 21 CHK ; --- Check ENT for acceptable X value 22 ; Pieces of Y have values in locations corresponding to premium 23 ; times in value of X. Values in Y string are locations 24 ; in entitlement string where associated time in X is 25 ; located. 26 ; -------------------------------------------------- 27 ; | Fixed | Premium 28 ; Piece | Position in| Type Of Time 29 ; Of Y-String | Entitlement| 30 ; & **WK() | String | 31 ; ----------- | -----------| -------------------- 32 ; 7 | 28 | comp earned 33 ; 9 | 2 | unscheduled regular 34 ; 16 | 19 | hrs excess 8-d 35 ; 17 | 20 | hrs excess 8-d2 36 ; 18 | 21 | hrs excess 8 d3 37 ; 20 | 12 | OT total hrs d 38 ; 21 | 13 | OT total hrs d2 39 ; 22 | 14 | OT total hrs d3 40 ; --------------------------------------------------- 41 ; 42 N ZZ S Y="^^^^^^28^^2^^^^^^^19^20^21^^12^13^14^^^^3^4^^^^" 43 ; 44 ; Set Y to a premium time in Y string, based on X 45 ; OR set Y to zero if X is a non premium time or parttime hours. 46 ; 47 I X'=32 S Y=+$P(Y,"^",X) 48 ; 49 ; IF Y is premium time & not Unscheduled regular but employee not 50 ; ENTITLED to that type of time THEN set X to zero. 51 ; 52 I +Y,Y'=2,'$E(ENT,+Y) S X=0 53 ; 54 ; Overtime & Not entitled set X & Y to unscheduled regular 55 ; 56 I "^12^13^14^"[("^"_Y_"^"),'X S X=9,Y=2 57 ; 58 ; IF regular unscheduled (Y=2) & not hourly for regular unscheduled 59 ; THEN set X=0, unless Baylor then X gets regular unscheduled. 60 ; 61 I X,Y=2,$E(ENT,+Y)'="H" S X=$S(TYP'["B":0,1:9) 62 ; 63 ; IF 36/40 AWS with WP determine eligibility for OT/CT 64 ; Skip this check if time is HW (X=29) or OT on Hol (X=24) 65 ; 66 I "KM"[$E(AC,1),$E(AC,2)=1,$P(C0,U,16)=72,X'=32,X'=29,X'=24 D 67 . I HT>32 S X=$S(VAL="O":TOUR+15,VAL="e":7,1:X) Q 68 . I TH(W)>160 S X=$S(VAL="O":TOUR+19,VAL="e":7,1:X) Q 69 . I HT'>32,TH(W)'>160 S X=9 70 ; 71 ; If X is hours in excess of 8/day & > 40/week & type of time 72 ; is compensatory time X = 0 73 ; 74 I "^16^17^18^"[("^"_X_"^"),TH(WK)>160,"Ee"[VAL S X=0 75 ; 76 ; ** Significance of checking "X" now as opposed to Y. 77 ; 78 K Y Q:'X 79 ; 80 ; (Hours excess 8/day, OT hours, Reg hours @ OT rate, Holiday hours, 81 ; part time hours) OR unscheduled regular & Nurse or Nurse Hybrid. 82 ; ### DO WE NEED TO ADD !HYBRID TO THIS CHECK ??? 83 I "^16^17^18^20^21^22^29^30^31^32^"[("^"_X_"^")!(X=9&(TYP["N"!(TYP["H"))) D 84 .; 85 .; If today holiday or holiday benefit day for employee 86 .; 87 .I $$HOLIDAY^PRS8UT(PY,DFN,DAY) D Q:'X 88 ..; 89 ..; If part time hours & entitled to (Holiday [Shift day, 2 or 3]) 90 ..; 91 ..I X=32,$E(ENT,TOUR+21),HOLWKD S ZZ=X,X=$S($G(DAY(DAY,"OFF"))'=1:TOUR+28,1:9) D SET S X=$S(TYP'["I":ZZ,1:9) Q 92 ..; 93 ..; IF not part time hours & intermittent employee & employee 94 ..; entitled to holiday overtime & holiday worked THEN set TIME 95 ..; to OT on Holiday and credit that TIME in SET. 96 ..; 97 ..I X'=32,TYP["I",$E(ENT,25),HOLWKD S ZZ=X,X=24 D SET S X=0 98 ..; 99 ..; IF conditions same as above except employee is NOT entitled 100 ..; to Holiday OT THEN use X as coded to credit TIME. 101 ..; 102 ..I X'=32,TYP["I",'$E(ENT,25),HOLWKD S ZZ=0 D SET S X=9 103 ..; 104 ..; IF not part time hours & emp. is entitled to Holiday OT But 105 ..; they did not work the holiday THEN if emp. is part time or 106 ..; intermittent set type of time to Regular hrs @ OT rate 3 107 ..; otherwise OT @ Holiday rate & IF the original coded TIME 108 ..; NOT = reg hrs @ OT rate(shift D,2,3) THEN credit TIME at 109 ..; OT on holiday or Reg hours @ OT rate. THEN also credit time 110 ..; as unscheduled regular. ** why code time twice? 111 ..; 112 ..I X'=32,$E(ENT,25),'HOLWKD D 113 ...S ZZ=X 114 ...; for 36/40 AWS w/ WP or NP report OT on Holiday as (OK/OS) 115 ...; For 9mo AWS w/ Recess report OT on Holiday as (OK/OS) 116 ...I +NAWS,VAL["O",$E(DAY(DAY,"HOL"),M)=0 S X=24 D SET S X=0 Q 117 ...; 118 ...S X=$S(TYP["P"!(TYP["I"):TOUR+28,1:24) D SET 119 ...I TYP["P"!(TYP["I") S X=9 D SET 120 ...S X=0 121 .; 122 .; IF type of time is part time hours for intermittent employee 123 .; THEN set TIME = unscheduled regular. 124 .; 125 .I X=32,TYP["I" S X=9 126 .; 127 .; Part time hours or unscheduled regular. 128 .; 129 .Q:X=32!(X=9) 130 .; 131 .; IF employee worked holiday THEN set TIME to zero & if original 132 .; coded type of time is NOT regular hours @ OT rate DO 133 .; 134 .I HOLWKD S ZZ=X,X=0 D 135 ..; 136 ..; IF entitled to Holiday pay for this shift THEN set TIME 137 ..; to Holiday HRS (shift d, 2 or 3) 138 ..; 139 ..I $E(ENT,TOUR+21) S X=TOUR+28 140 ; 141 ; IF employee is part time & either a nurse or nurse hybrid 142 ; & they worked the holiday 143 ; ### SHOULD HYBRID BE ADDED TO THIS CHECK HOW SHOULD THESE HYBRIDS 144 ; ### TREATED ON A HOLIDAY 145 I TYP["P",TYP["N"!(TYP["H"),HOLWKD,X=32 D 146 .; 147 .; J gets start & stop times for employee's holiday tour. 148 .; Start/stop times are represented w/ natural numbers 149 .; from 0-96. Each 15 minute segment of the 24 hour period 150 .; beginning & ending at midnight can be represented w/ 151 .; a positive integer. I.e. 1 = mid-12:15am, 152 .; 2 = 12:15-12:30a ... 96 = 11:45pm-mid. 153 .; 154 .; Loop thru each set of start & stop times. IF the single 155 .; 1/4 hr segment we're working w/ falls w/in any of the nurses 156 .; start & stop times THEN set TIME to Holiday Hours Day. 157 .; 158 .N I,J S J=$G(^TMP($J,"PRS8",DAY,"HWK")),ZZ=X 159 .; 160 .F I=1:2 Q:$P(J,U,I)="" I M'<$P(J,U,I),M'>$P(J,U,I+1) S X=29 161 .; 162 .; Holiday hrs-Day. reset X if 2 day tour. Otherwise X = 0. 163 .; 164 .I X=29 D SET S X=$S($P(^PRST(457.1,$P(DAY(DAY-1,0),U,2),0),U,5)="Y":ZZ,1:0) 165 ; 166 ; 167 SET ; --- Set value into WK array 168 ; 169 ; Nurses on the 36/40 AWS are FT with Normal Hours of 72. Nurses on the 9 month 170 ; AWS are PT with Normal Hours of 80. Neither will not have Part Time Hours 171 ; counted in their 8B string. 172 ; 173 Q:$E(AC,2)=1&($P(C0,U,16)=72)&(X=32) ; 36/40 AWS 174 Q:$E(AC,2)=2&(NH=320)&(X=32) ; 9month AWS before any Recess processed 175 ; 176 ; Full time employee & part time hours & normal hours WK1 + WK2 177 ; = biweekly normal hours. 178 ; 179 I $P(C0,"^",10)=1,X=32,NH(1)+NH(2)=NH Q 180 ; 181 ; For all types of TIME, increment the WK array. 182 ; 183 I +X D Q 184 . S $P(WK(W),"^",+X)=$P(WK(W),"^",+X)+1 185 ; 186 ; When X is zero, reset to originally coded time. 187 ; 188 I 'X S X=ZZ Q 189 Q 190 ; 191 ; 192 TH ; --- increment total hours & compensatory time hours. 193 ; Posted RG/OT/CT that is >8/day but < 40/week and < 80/pp will not be 194 ; counted in TH or TH(W) 195 ; 196 ; I $S(VAL=4:1,"osEe"[VAL!(VAL="O"&('HOLWKD)):1,1:0) S TH=TH+1,TH(W)=TH(W)+1 197 ; 198 I $S(VAL=4:1,"osEe"[VAL!(VAL="O"&('HOLWKD)):1,1:0) D 199 . Q:(HT>32)&(TH(W)<160)&(NH<320)&($E(ENT,19)=1) 200 . Q:(HT>32)&(TH(W)<160)&(NH=320)&($E(ENT,19)=1)&($E(AC,2)=2) ; 9month AWS 201 . S TH=TH+1,TH(W)=TH(W)+1 202 Q 203 ; 204 ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 205 ; 206 G8 ; --- Check for greater than 8 hours in day 207 ; 208 Q:HTP'>32!(VAL="E") 209 ; 210 ; Checks for Hours Excess 8/day (DA/DE) 211 S X=TOUR+15 D CHK^PRS8HRSV 212 I X,NH<320,CYA2806>0 S CYA2806=CYA2806-1 213 Q:X 214 ; 215 ; Checks for OT Total Hours (OA/OE) 216 I TYP["I"!(TYP["P"),TYP'["B",TH(W)>160 S X=TOUR+19 D CHK^PRS8HRSV 217 Q 218 ; 219 ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 1 PRS8HRSV ;WCIOFO/JAH-HOLIDAY FLAG, TIME CHECKER, WK() SET; 05/02/06 2 ;;4.0;PAID;**29,52,102,108**;Sep 21, 1995 3 ; Set up variable for holiday worked or holiday exused 4 ; Holiday worked coded 2 in DAY array 5 ; Holiday exused coded 1 in DAY array 6 ; A NON holiday is coded as all zero's in day array. 7 ; 8 ; HOLIDAY WORKED 9 S HOLWKD=$E(DAY(DAY,"HOL"),M)=2 10 ; 11 ; HOLIDAY EXCUSED 12 S HOLEX=$E(DAY(DAY,"HOL"),M)=1 13 ; 14 ; HOLIDAY EXCUSED OR HOLIDAY WORKED 15 S HOLWKEX=$E(DAY(DAY,"HOL"),M) 16 Q 17 ; 18 ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 19 ; 20 CHK ; --- Check ENT for acceptable X value 21 ; Pieces of Y have values in locations corresponding to premium 22 ; times in value of X. Values in Y string are locations 23 ; in entitlement string where associated time in X is 24 ; located. 25 ; -------------------------------------------------- 26 ; | Fixed | Premium 27 ; Piece | Position in| Type Of Time 28 ; Of Y-String | Entitlement| 29 ; & **WK() | String | 30 ; ----------- | -----------| -------------------- 31 ; 7 | 28 | comp earned 32 ; 9 | 2 | unscheduled regular 33 ; 16 | 19 | hrs excess 8-d 34 ; 17 | 20 | hrs excess 8-d2 35 ; 18 | 21 | hrs excess 8 d3 36 ; 20 | 12 | OT total hrs d 37 ; 21 | 13 | OT total hrs d2 38 ; 22 | 14 | OT total hrs d3 39 ; --------------------------------------------------- 40 ; 41 N ZZ S Y="^^^^^^28^^2^^^^^^^19^20^21^^12^13^14^^^^3^4^^^^" 42 ; 43 ; Set Y to a premium time in Y string, based on X 44 ; OR set Y to zero if X is a non premium time or parttime hours. 45 ; 46 I X'=32 S Y=+$P(Y,"^",X) 47 ; 48 ; IF Y is premium time & not Unscheduled regular but employee not 49 ; ENTITLED to that type of time THEN set X to zero. 50 ; 51 I +Y,Y'=2,'$E(ENT,+Y) S X=0 52 ; 53 ; Overtime & Not entitled set X & Y to unscheduled regular 54 ; 55 I "^12^13^14^"[("^"_Y_"^"),'X S X=9,Y=2 56 ; 57 ; IF regular unscheduled (Y=2) & not hourly for regular unscheduled 58 ; THEN set X=0, unless Baylor then X gets regular unscheduled. 59 ; 60 I X,Y=2,$E(ENT,+Y)'="H" S X=$S(TYP'["B":0,1:9) 61 ; 62 ; If X is hours in excess of 8/day & > 40/week & type of time 63 ; is compensatory time X = 0 64 ; 65 I "^16^17^18^"[("^"_X_"^"),TH(WK)>160,"Ee"[VAL S X=0 66 ; 67 ; ** Significance of checking "X" now as opposed to Y. 68 ; 69 K Y Q:'X 70 ; 71 ; (Hours excess 8/day, OT hours, Reg hours @ OT rate, Holiday hours, 72 ; part time hours) OR unscheduled regular & Nurse or Nurse Hybrid. 73 ; ### DO WE NEED TO ADD !HYBRID TO THIS CHECK ??? 74 I "^16^17^18^20^21^22^29^30^31^32^"[("^"_X_"^")!(X=9&(TYP["N"!(TYP["H"))) D 75 .; 76 .; If today holiday or holiday benefit day for employee 77 .; 78 .I $$HOLIDAY^PRS8UT(PY,DFN,DAY) D Q:'X 79 ..; 80 ..; If part time hours & entitled to (Holiday [Shift day, 2 or 3]) 81 ..; 82 ..I X=32,$E(ENT,TOUR+21),HOLWKD S ZZ=X,X=$S($G(DAY(DAY,"OFF"))'=1:TOUR+28,1:9) D SET S X=$S(TYP'["I":ZZ,1:9) Q 83 ..; 84 ..; IF not part time hours & intermittent employee & employee 85 ..; entitled to holiday overtime & holiday worked THEN set TIME 86 ..; to OT on Holiday and credit that TIME in SET. 87 ..; 88 ..I X'=32,TYP["I",$E(ENT,25),HOLWKD S ZZ=X,X=24 D SET S X=0 89 ..; 90 ..; IF conditions same as above except employee is NOT entitled 91 ..; to Holiday OT THEN use X as coded to credit TIME. 92 ..; 93 ..I X'=32,TYP["I",'$E(ENT,25),HOLWKD S ZZ=0 D SET S X=9 94 ..; 95 ..; IF not part time hours & emp. is entitled to Holiday OT But 96 ..; they did not work the holiday THEN if emp. is part time or 97 ..; intermittent set type of time to Regular hrs @ OT rate 3 98 ..; otherwise OT @ Holiday rate & IF the original coded TIME 99 ..; NOT = reg hrs @ OT rate(shift D,2,3) THEN credit TIME at 100 ..; OT on holiday or Reg hours @ OT rate. THEN also credit time 101 ..; as unscheduled regular. ** why code time twice? 102 ..; 103 ..I X'=32,$E(ENT,25),'HOLWKD D 104 ...S ZZ=X 105 ...S X=$S(TYP["P"!(TYP["I"):TOUR+28,1:24) D SET 106 ...I TYP["P"!(TYP["I") S X=9 D SET 107 ...S X=0 108 .; 109 .; IF type of time is part time hours for intermittent employee 110 .; THEN set TIME = unscheduled regular. 111 .; 112 .I X=32,TYP["I" S X=9 113 .; 114 .; Part time hours or unscheduled regular. 115 .; 116 .Q:X=32!(X=9) 117 .; 118 .; IF employee worked holiday THEN set TIME to zero & if original 119 .; coded type of time is NOT regular hours @ OT rate DO 120 .; 121 .I HOLWKD S ZZ=X,X=0 D 122 ..; 123 ..; IF entitled to Holiday pay for this shift THEN set TIME 124 ..; to Holiday HRS (shift d, 2 or 3) 125 ..; 126 ..I $E(ENT,TOUR+21) S X=TOUR+28 127 ; 128 ; IF employee is part time & either a nurse or nurse hybrid 129 ; & they worked the holiday 130 ; ### SHOULD HYBRID BE ADDED TO THIS CHECK HOW SHOULD THESE HYBRIDS 131 ; ### TREATED ON A HOLIDAY 132 I TYP["P",TYP["N"!(TYP["H"),HOLWKD,X=32 D 133 .; 134 .; J gets start & stop times for employee's holiday tour. 135 .; Start/stop times are represented w/ natural numbers 136 .; from 0-96. Each 15 minute segment of the 24 hour period 137 .; beginning & ending at midnight can be represented w/ 138 .; a positive integer. I.e. 1 = mid-12:15am, 139 .; 2 = 12:15-12:30a ... 96 = 11:45pm-mid. 140 .; 141 .; Loop thru each set of start & stop times. IF the single 142 .; 1/4 hr segment we're working w/ falls w/in any of the nurses 143 .; start & stop times THEN set TIME to Holiday Hours Day. 144 .; 145 .N I,J S J=$G(^TMP($J,"PRS8",DAY,"HWK")),ZZ=X 146 .; 147 .F I=1:2 Q:$P(J,U,I)="" I M'<$P(J,U,I),M'>$P(J,U,I+1) S X=29 148 .; 149 .; Holiday hrs-Day. reset X if 2 day tour. Otherwise X = 0. 150 .; 151 .I X=29 D SET S X=$S($P(^PRST(457.1,$P(DAY(DAY-1,0),U,2),0),U,5)="Y":ZZ,1:0) 152 ; 153 ; 154 SET ; --- Set value into WK array 155 ; 156 ; Full time employee & part time hours & normal hours WK1 + WK2 157 ; = biweekly normal hours. 158 ; 159 I $P(C0,"^",10)=1,X=32,NH(1)+NH(2)=NH Q 160 ; 161 ; For all types of TIME, increment the WK array. 162 ; 163 I +X D Q 164 . S $P(WK(W),"^",+X)=$P(WK(W),"^",+X)+1 165 ; 166 ; When X is zero, reset to originally coded time. 167 ; 168 I 'X S X=ZZ Q 169 Q 170 ; 171 ; 172 TH ; --- increment total hours & compensatory time hours. 173 ; Posted RG/OT/CT that is >8/day but < 40/week and < 80/pp will not be 174 ; counted in TH or TH(W) 175 ; 176 ; I $S(VAL=4:1,"osEe"[VAL!(VAL="O"&('HOLWKD)):1,1:0) S TH=TH+1,TH(W)=TH(W)+1 177 ; 178 I $S(VAL=4:1,"osEe"[VAL!(VAL="O"&('HOLWKD)):1,1:0) D 179 . Q:(HT>32)&(TH(W)<160)&(NH<320)&($E(ENT,19)=1) 180 . S TH=TH+1,TH(W)=TH(W)+1 181 Q 182 ; 183 ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 184 ; 185 G8 ; --- Check for greater than 8 hours in day 186 ; 187 Q:HTP'>32!(VAL="E") 188 ; 189 ; Checks for Hours Excess 8/day (DA/DE) 190 S X=TOUR+15 D CHK^PRS8HRSV 191 I X,NH<320,CYA2806>0 S CYA2806=CYA2806-1 192 Q:X 193 ; 194 ; Checks for OT Total Hours (OA/OE) 195 I TYP["I"!(TYP["P"),TYP'["B",TH(W)>160 S X=TOUR+19 D CHK^PRS8HRSV 196 Q 197 ; 198 ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -
WorldVistAEHR/trunk/r/PAID-PRS/PRS8MSC0.m
r613 r623 1 PRS8MSC0 ;HISC/DAD,WCIOFO/JAH,SAB - MISC TIME CARD ADJUST(contd) ;4/04/2007 2 ;;4.0;PAID;**22,35,40,56,111,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ; for employee on daily tour check if no duty performed during week 6 I TYP["D" D NODUTY^PRS8MSC1 7 ; 8 S B="",Z0="" S $P(B,"B",97)="",$P(Z0,"0",97)="",FLAG=0 9 F X=1:1:PEROWK S Y=$P(PEROWK(X),"^",4),DAT=$P(PEROWK(X),"^",1,3),DY=$P(DAT,"^",1),BEG=$P(DAT,"^",2),END=$P(DAT,"^",3) D 10 .I $L(Y)'<96,TYP'["Ff",$E(ENT,27) D ; slp for 24hr cvg 11 ..S SLMAX=32,(SLW,SLY,SLST,SLSTR,SLST1,SLY1,SL1,SL2,SL3)="" 12 ..I END=96 D 13 ...S SLST=$P($G(PEROWK(X)),"^",4),SL2=$E(SLST,SST,$L(SLST)),SL1=$E(SLST,1,SLMAX-$L(SL2)),SL3=$L(SL2) 14 ...S SLSTR=SL1_SL2 15 ...I DOUB S SLSTR=$TR(SLSTR,"Cct","Bbb") ; if PPC = W then OC = SB 16 ...S SLSTR=$TR(SLSTR,$TR(SLSTR,"Bb"),Z0) 17 ...S SLY=$L($TR(SLSTR,"b0")),SLW=$L($TR(SLSTR,"B0")) 18 ...I SLW>12 Q 19 ...I DY=0 S FLAG=SL3 20 ...S Y=$L(SLSTR)-SLW 21 ...I FLAG>0&(DY=1) S Y=Y-FLAG,FLAG=0 22 ...S D=DY,P=25 D SET Q 23 ..E D 24 ...S SLST=$G(^TMP($J,"PRS8",DY,"W"))_$G(^TMP($J,"PRS8",DY+1,"W")) 25 ...S SLSTR=$E(SLST,1,SST+(SLMAX-1)) 26 ...I DOUB S SLSTR=$TR(SLSTR,"Cct","Bbb") ; if PPC = W then OC = SB 27 ...S SLSTR=$TR(SLSTR,$TR(SLSTR,"Bb"),Z0) 28 ...S SLY=$E(SLSTR,SST,96),SLY1=$E(SLSTR,97,$L(SLSTR)) 29 ...S SLSTR=SLY_SLY1,SLW=$L($TR(SLSTR,"B0")) 30 ...I SLW>12 Q 31 ...S D=DY,Y=$L($TR(SLY,"b0")),P=25 D SET 32 ...Q:DY=0 S D=DY+1,Y=$L($TR(SLY1,"b0")) D SET 33 ...Q 34 ..K BEG,DAT,END,NL,SLW,SLY,SLST,SLSTR,SLST1,SLY1,SL1,SL2,SL3 Q 35 .Q 36 S D="",(H,ROSS)=1 K OT,UN,DA,CT 37 F H=H:ROSS:PEROT D ; calculate CB OT and FF OT/sleep time 38 .S Y=PEROT(H),Z=$P(Y,"^",3) 39 .I "Ff"[TYP D ;K OT,UN,DA D ; FF sleep time 40 ..F M=1:1:$L(Z) D ; following FF OT per Mary Baker 4/1/93 41 ...I D'=+Y+(($P(Y,"^",2)+M-2)\96) D 42 ....S D=+Y+(($P(Y,"^",2)+M-2)\96),HT=0 43 ....Q 44 ...S HT=HT+1 45 ...I $E(Z,H)="E" S CT(D)=$G(CT(D))+1 Q 46 ...I M'>32 S:HT'>32 OT(D)=$G(OT(D))+1 S:HT>32 DA(D)=$G(DA(D))+1 ; FF OT 47 ...I M>32,$L(Z)'<96&(M'>64)!($L(Z)<96) S DA(D)=$G(DA(D))+1 ; FF hrs>8 48 ...I $L(Z)'<96,M>64 D ; FF 2/3 rule 49 ....I M'>96 S UN(D)=$G(UN(D))+1 ; first 8 sleep time 50 ....E S DA(D)=$G(DA(D))+1 ; rest hrs >8 51 ....Q 52 ...Q 53 ..Q 54 .I $L(Z)<8 D ; call back OT at least 2 hrs 55 ..S YY=Y,ZZ=Z N X,Y,START,STOP,T,TT,Z,DD,TL S Y=YY,Z=ZZ 56 ..S CB=$G(^TMP($J,"PRS8",+Y,"CB")) 57 ..;no call back OT today or send bulletin 58 ..Q:(CB="")!($$OTNXTPP(+Y,CB,$P(C0,"^",1),PY,$P(C0,"^",8))) 59 ..S Q=0 F ZZ=1:2 Q:'$P(CB,"^",ZZ) I $P(Y,"^",2)=$P(CB,"^",ZZ) S Q=1 60 ..Q:'Q ; this OT episode not call back 61 ..S OT=Y,START=$P(OT,"^",2),STOP=$P(OT,"^",2)+$L(Z)-1,T=START,TT=$S(T>96:T-96,1:T) 62 ..S W=$G(^TMP($J,"PRS8",+OT,"W")),WEEK=$S(+OT>7:2,1:1) 63 ..S W1=$G(^TMP($J,"PRS8",OT-1,"W")) 64 ..S W2=$G(^TMP($J,"PRS8",OT+1,"W")) 65 ..S (Z,X)=0 F Z=1:1:8-(STOP-START+1) D Q:X=0 66 ...S DD=Z 67 ...I TT-DD>0 S X=$E(W,TT-DD) 68 ...E S X=$E(W1,96+T-DD) 69 ...I "123m"[X,$E($G(^TMP($J,"PRS8",$S(TT-DD>0:+OT,1:OT-1),"HOL")),$S(TT-DD>0:TT-DD,1:96+T-DD))=1 S X=0 ; HX becomes time off 70 ...Q 71 ..S ZZ=Z S:X=0&Z ZZ=ZZ-1 S X=0,T=STOP,TT=$S(T>96:T-96,1:T) 72 ..F Z=1:1:8-(STOP-START+1+ZZ) D Q:X=0 73 ...S DD=STOP-START+1+ZZ+Z 74 ...I T+Z'>96 S X=$E(W,T+Z) 75 ...E S X=$E(W2,T-96+Z) 76 ...I "123m"[X,$E($G(^TMP($J,"PRS8",$S(T+Z'>96:+OT,1:OT+1),"HOL")),$S(T+Z'>96:T+Z,1:T-96+Z))=1 S X=0 ; HX becomes time off 77 ...Q 78 ..S Z=ZZ+Z-(X=0&Z) 79 ..I STOP-START+1+Z<8 D 80 ...I TYP["W",$E($P(PEROT(H),"^",3))'="E"&($G(^TMP($J,"PRS8",$P(PEROT(H),"^",1),"OFF"))=0) S TOUR=$G(^TMP($J,"PRS8",$P(PEROT(H),"^",1),"TOUR")) 81 ...S D=+OT,P=$S($E($P(PEROT(H),"^",3))'="E":TOUR+19,1:7),Y=8-(STOP-START+1+Z) 82 ...; 83 ...I TYP["P",TYP'["B",P'=7,'+NAWS D 84 ....I $P($G(^TMP($J,"PRS8",$P(PEROT(H),"^",1),"OFF")),"^",1)=1&(TH(WEEK)'>160) S Y=0 Q 85 ....I $P(C0,"^",12)="E" S P=$S($L($TR(W,"0O"))>31&(TH(WEEK)'>160):TOUR+25,1:P) D:Y SET S Y=$S(TH(WEEK)'>160:Y,1:0) S P=9 D:Y SET S Y=0 86 ...I $P(C0,"^",12)="N",P'=7 S P=$S($L($TR(W,"0O"))>31:TOUR+15,1:P) D:Y SET S Y=0 87 ...D:Y&('+NAWS) SET 88 ...; 89 ...I +NAWS D Q ; Checks for just the AWS nurses 90 ....N CNT,HT,I 91 ....S CNT=Y,Y=1,HT=$G(^TMP($J,"PRS8",D,"HT")) 92 ....F I=1:1:CNT D 93 .....I HT'<32 S P=$S(P'=7:TOUR+15,1:P) D SET1 Q ; DA/DE or CE/CT 94 .....I TH($S(+OT>7:2,1:1))'<160 S P=$S(P'=7:TOUR+19,1:P) D SET1 Q ; OA/OE or CE/CT 95 .....I HT<32,TH($S(+OT>7:2,1:1))<160 S P=9 D SET1 Q ; UN/US 96 ..Q 97 .Q 98 F X="OT","DA","UN","CT" D ; store FF OT into WK array 99 .N Y S P=$S(X="OT":TOUR+19,X="DA"&$E(ENT,TOUR+18):TOUR+15,X="DA":TOUR+19,X="CT":TOUR+6,1:9) 100 .F D=0:0 S D=$O(@(X_"("_D_")")) Q:D'>0 S Y=@(X_"("_D_")") D SET 101 .Q 102 ; 103 ; check/adjust night differential granted for leave 104 D LVND 105 Q 106 SET ; Set sleep time into WK array 107 Q:D<1!(D>14) 108 S WEEK=$S(D>7:2,1:1) 109 S $P(WK(WEEK),"^",P)=$P(WK(WEEK),"^",P)+Y 110 Q 111 ; 112 SET1 ; Set sleep time into WK array 113 Q:D<1!(D>14) 114 S WEEK=$S(D>7:2,1:1) 115 S $P(WK(WEEK),"^",P)=$P(WK(WEEK),"^",P)+Y 116 Q:(HT>32)&(TH(WEEK)<160)&(NH<320)&($E(ENT,19)=1) 117 Q:(HT>32)&(TH(WEEK)<160)&(NH=320)&($E(ENT,19)=1)&($E(AC,2)=2) ; 9month AWS 118 S HT=HT+1,TH(WEEK)=TH(WEEK)+1 119 S ^TMP($J,"PRS8",D,"HT")=^TMP($J,"PRS8",D,"HT")+1 120 Q 121 ; 122 OTNXTPP(DAY,CALLBK,EMPNM,PPIEN,TLU) ; 123 ;OT or CT connects to a tour of duty in the next pay period. 124 ;JAH-patch PRS*4*22 125 ;If OT or CT are worked in last 2 hours of pay period & 1st day 126 ;of next pay period is missing a tour beginning at midnight, send 127 ;a bulletin warning that call back will be paid unless corrective 128 ;action is taken. 129 ;(i.e a nurse comes in before midnight on last saturday of 130 ;pay period & works for a period less than 2 hrs. before her tour 131 ;that begins at midnight on Sunday, first day of the next pp) 132 ; 133 ; CALLBK = start and stop position in 96 char BCD string. 134 ; RECORD = pointer from employee's tour info to a record 135 ; in tour of duty file. 136 ; DAY = day of the pay period 137 ; D1NXTPP = BOOLEAN; set to true if tour on day 1 of next pay period 138 ; begins at midnight, otherwise false 139 ; NEXTP = next pay period in 97-05 format. 140 ; CURP = current pay period in 99-02 format. 141 ; TLU = 3 digit time & leave unit of employee. 142 N D1NXTPP,RECORD,CURP,NEXTP,XMDUZ,XMB,XMY,XMDUZ 143 S (RTN,D1NXTPP)=0 144 S RECORD=$P($G(^TMP($J,"PRS8",15,0)),"^",2) 145 I RECORD'="" S D1NXTPP=($P($G(^PRST(457.1,RECORD,1)),"^")="MID") 146 I (DAY=14)&($P(CALLBK,"^",2)=96) D 147 . I (D1NXTPP) S RTN=1 148 . E D 149 .. S CURP=$P($G(^PRST(458,PPIEN,0)),"^",1) 150 .. S NXTP=$E($$NXTPP^PRSAPPU(CURP),3,7) 151 ..; Send bulletin to G.PAD 152 .. S XMY("G.PAD@"_^XMB("NETNAME"))="" 153 .. S XMDUZ="DHCP PAID package" 154 .. S XMB="PRS LAST SAT OT/CT" 155 ..; 156 ..; employee name, pay period number, next pay period 157 .. S XMB(1)=EMPNM,XMB(2)=CURP,XMB(3)=NXTP,XMB(4)=TLU 158 .. D ^XMB 159 Q RTN 160 ; 161 LVND ; Leave Night Differential 162 ; back out ND granted for leave if employee took 8 or more hrs of leave 163 ; a non-wage grade employee can receive night differential when 164 ; on leave as long as the employee has taken less than 8 hours of 165 ; leave during the pay period. 166 ; input (note: units are count of 15min time segments): 167 ; LU - leave taken during pay period (set in PRS8AC, PRS8MT) 168 ; WK(#) - piece 10 contains total shift-2 ND for week # 169 ; WKL(#) - ND granted for leave during week # (set in PRS8PP) 170 ; output: 171 ; WK(#) - piece 10 may be modified 172 ; WKL(#) - may be modified 173 N W 174 Q:TYP["W" ; Doesn't apply to Wage Grade 175 Q:LU'>31 ; Didn't take 8hrs of leave 176 F W=1,2 D ; For each week subtract leave ND from total ND 177 . Q:'WKL(W) ; No leave ND to subtract 178 . I +NAWS'=36 S $P(WK(W),"^",10)=$P(WK(W),"^",10)-WKL(W) ; Subtract 179 . ; For 36/40 AWS subtract time from Night Differential-AWS (piece 51) 180 . I +NAWS=36 S $P(WK(W),"^",51)=$P(WK(W),"^",51)-WKL(W) 181 . S WKL(W)=0 ; Reset leave ND amount 182 Q 1 PRS8MSC0 ;HISC/DAD,WCIOFO/JAH,SAB - MISC TIME CARD ADJUST(contd) ;1/25/2007 2 ;;4.0;PAID;**22,35,40,56,111**;Sep 21, 1995;Build 2 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ; for employee on daily tour check if no duty performed during week 6 I TYP["D" D NODUTY^PRS8MSC1 7 ; 8 S B="",Z0="" S $P(B,"B",97)="",$P(Z0,"0",97)="",FLAG=0 9 F X=1:1:PEROWK S Y=$P(PEROWK(X),"^",4),DAT=$P(PEROWK(X),"^",1,3),DY=$P(DAT,"^",1),BEG=$P(DAT,"^",2),END=$P(DAT,"^",3) D 10 .I $L(Y)'<96,TYP'["Ff",$E(ENT,27) D ; slp for 24hr cvg 11 ..S SLMAX=32,(SLW,SLY,SLST,SLSTR,SLST1,SLY1,SL1,SL2,SL3)="" 12 ..I END=96 D 13 ...S SLST=$P($G(PEROWK(X)),"^",4),SL2=$E(SLST,SST,$L(SLST)),SL1=$E(SLST,1,SLMAX-$L(SL2)),SL3=$L(SL2) 14 ...S SLSTR=SL1_SL2 15 ...I DOUB S SLSTR=$TR(SLSTR,"Cct","Bbb") ; if PPC = W then OC = SB 16 ...S SLSTR=$TR(SLSTR,$TR(SLSTR,"Bb"),Z0) 17 ...S SLY=$L($TR(SLSTR,"b0")),SLW=$L($TR(SLSTR,"B0")) 18 ...I SLW>12 Q 19 ...I DY=0 S FLAG=SL3 20 ...S Y=$L(SLSTR)-SLW 21 ...I FLAG>0&(DY=1) S Y=Y-FLAG,FLAG=0 22 ...S D=DY,P=25 D SET Q 23 ..E D 24 ...S SLST=$G(^TMP($J,"PRS8",DY,"W"))_$G(^TMP($J,"PRS8",DY+1,"W")) 25 ...S SLSTR=$E(SLST,1,SST+(SLMAX-1)) 26 ...I DOUB S SLSTR=$TR(SLSTR,"Cct","Bbb") ; if PPC = W then OC = SB 27 ...S SLSTR=$TR(SLSTR,$TR(SLSTR,"Bb"),Z0) 28 ...S SLY=$E(SLSTR,SST,96),SLY1=$E(SLSTR,97,$L(SLSTR)) 29 ...S SLSTR=SLY_SLY1,SLW=$L($TR(SLSTR,"B0")) 30 ...I SLW>12 Q 31 ...S D=DY,Y=$L($TR(SLY,"b0")),P=25 D SET 32 ...Q:DY=0 S D=DY+1,Y=$L($TR(SLY1,"b0")) D SET 33 ...Q 34 ..K BEG,DAT,END,NL,SLW,SLY,SLST,SLSTR,SLST1,SLY1,SL1,SL2,SL3 Q 35 .Q 36 S D="",(H,ROSS)=1 K OT,UN,DA,CT 37 F H=H:ROSS:PEROT D ; calculate CB OT and FF OT/sleep time 38 .S Y=PEROT(H),Z=$P(Y,"^",3) 39 .I "Ff"[TYP D ;K OT,UN,DA D ; FF sleep time 40 ..F M=1:1:$L(Z) D ; following FF OT per Mary Baker 4/1/93 41 ...I D'=+Y+(($P(Y,"^",2)+M-2)\96) D 42 ....S D=+Y+(($P(Y,"^",2)+M-2)\96),HT=0 43 ....Q 44 ...S HT=HT+1 45 ...I $E(Z,H)="E" S CT(D)=$G(CT(D))+1 Q 46 ...I M'>32 S:HT'>32 OT(D)=$G(OT(D))+1 S:HT>32 DA(D)=$G(DA(D))+1 ; FF OT 47 ...I M>32,$L(Z)'<96&(M'>64)!($L(Z)<96) S DA(D)=$G(DA(D))+1 ; FF hrs>8 48 ...I $L(Z)'<96,M>64 D ; FF 2/3 rule 49 ....I M'>96 S UN(D)=$G(UN(D))+1 ; first 8 sleep time 50 ....E S DA(D)=$G(DA(D))+1 ; rest hrs >8 51 ....Q 52 ...Q 53 ..Q 54 .I $L(Z)<8 D ; call back OT at least 2 hrs 55 ..S YY=Y,ZZ=Z N X,Y,START,STOP,T,TT,Z,DD,TL S Y=YY,Z=ZZ 56 ..S CB=$G(^TMP($J,"PRS8",+Y,"CB")) 57 ..;no call back OT today or send bulletin 58 ..Q:(CB="")!($$OTNXTPP(+Y,CB,$P(C0,"^",1),PY,$P(C0,"^",8))) 59 ..S Q=0 F ZZ=1:2 Q:'$P(CB,"^",ZZ) I $P(Y,"^",2)=$P(CB,"^",ZZ) S Q=1 60 ..Q:'Q ; this OT episode not call back 61 ..S OT=Y,START=$P(OT,"^",2),STOP=$P(OT,"^",2)+$L(Z)-1,T=START,TT=$S(T>96:T-96,1:T) 62 ..S W=$G(^TMP($J,"PRS8",+OT,"W")),WEEK=$S(+OT>7:2,1:1) 63 ..S W1=$G(^TMP($J,"PRS8",OT-1,"W")) 64 ..S W2=$G(^TMP($J,"PRS8",OT+1,"W")) 65 ..S (Z,X)=0 F Z=1:1:8-(STOP-START+1) D Q:X=0 66 ...S DD=Z 67 ...I TT-DD>0 S X=$E(W,TT-DD) 68 ...E S X=$E(W1,96+T-DD) 69 ...I "123m"[X,$E($G(^TMP($J,"PRS8",$S(TT-DD>0:+OT,1:OT-1),"HOL")),$S(TT-DD>0:TT-DD,1:96+T-DD))=1 S X=0 ; HX becomes time off 70 ...Q 71 ..S ZZ=Z S:X=0&Z ZZ=ZZ-1 S X=0,T=STOP,TT=$S(T>96:T-96,1:T) 72 ..F Z=1:1:8-(STOP-START+1+ZZ) D Q:X=0 73 ...S DD=STOP-START+1+ZZ+Z 74 ...I T+Z'>96 S X=$E(W,T+Z) 75 ...E S X=$E(W2,T-96+Z) 76 ...I "123m"[X,$E($G(^TMP($J,"PRS8",$S(T+Z'>96:+OT,1:OT+1),"HOL")),$S(T+Z'>96:T+Z,1:T-96+Z))=1 S X=0 ; HX becomes time off 77 ...Q 78 ..S Z=ZZ+Z-(X=0&Z) 79 ..I STOP-START+1+Z<8 D 80 ...I TYP["W",$E($P(PEROT(H),"^",3))'="E"&($G(^TMP($J,"PRS8",$P(PEROT(H),"^",1),"OFF"))=0) S TOUR=$G(^TMP($J,"PRS8",$P(PEROT(H),"^",1),"TOUR")) 81 ...S D=+OT,P=$S($E($P(PEROT(H),"^",3))'="E":TOUR+19,1:7),Y=8-(STOP-START+1+Z) 82 ...I TYP["P",TYP'["B",P'=7 D 83 ....I $P($G(^TMP($J,"PRS8",$P(PEROT(H),"^",1),"OFF")),"^",1)=1&(TH(WEEK)'>160) S Y=0 Q 84 ....I $P(C0,"^",12)="E" S P=$S($L($TR(W,"0O"))>31&(TH(WEEK)'>160):TOUR+25,1:P) D:Y SET S Y=$S(TH(WEEK)'>160:Y,1:0) S P=9 D:Y SET S Y=0 85 ...I $P(C0,"^",12)="N",P'=7 S P=$S($L($TR(W,"0O"))>31:TOUR+15,1:P) D:Y SET S Y=0 86 ...D:Y SET 87 ..Q 88 .Q 89 F X="OT","DA","UN","CT" D ; store FF OT into WK array 90 .N Y S P=$S(X="OT":TOUR+19,X="DA"&$E(ENT,TOUR+18):TOUR+15,X="DA":TOUR+19,X="CT":TOUR+6,1:9) 91 .F D=0:0 S D=$O(@(X_"("_D_")")) Q:D'>0 S Y=@(X_"("_D_")") D SET 92 .Q 93 ; 94 ; check/adjust night differential granted for leave 95 D LVND 96 Q 97 SET ; Set sleep time into WK array 98 Q:D<1!(D>14) 99 S WEEK=$S(D>7:2,1:1) 100 S $P(WK(WEEK),"^",P)=$P(WK(WEEK),"^",P)+Y 101 Q 102 OTNXTPP(DAY,CALLBK,EMPNM,PPIEN,TLU) ; 103 ;OT or CT connects to a tour of duty in the next pay period. 104 ;JAH-patch PRS*4*22 105 ;If OT or CT are worked in last 2 hours of pay period & 1st day 106 ;of next pay period is missing a tour beginning at midnight, send 107 ;a bulletin warning that call back will be paid unless corrective 108 ;action is taken. 109 ;(i.e a nurse comes in before midnight on last saturday of 110 ;pay period & works for a period less than 2 hrs. before her tour 111 ;that begins at midnight on Sunday, first day of the next pp) 112 ; 113 ; CALLBK = start and stop position in 96 char BCD string. 114 ; RECORD = pointer from employee's tour info to a record 115 ; in tour of duty file. 116 ; DAY = day of the pay period 117 ; D1NXTPP = BOOLEAN; set to true if tour on day 1 of next pay period 118 ; begins at midnight, otherwise false 119 ; NEXTP = next pay period in 97-05 format. 120 ; CURP = current pay period in 99-02 format. 121 ; TLU = 3 digit time & leave unit of employee. 122 N D1NXTPP,RECORD,CURP,NEXTP,XMDUZ,XMB,XMY,XMDUZ 123 S (RTN,D1NXTPP)=0 124 S RECORD=$P($G(^TMP($J,"PRS8",15,0)),"^",2) 125 I RECORD'="" S D1NXTPP=($P($G(^PRST(457.1,RECORD,1)),"^")="MID") 126 I (DAY=14)&($P(CALLBK,"^",2)=96) D 127 . I (D1NXTPP) S RTN=1 128 . E D 129 .. S CURP=$P($G(^PRST(458,PPIEN,0)),"^",1) 130 .. S NXTP=$E($$NXTPP^PRSAPPU(CURP),3,7) 131 ..; Send bulletin to G.PAD 132 .. S XMY("G.PAD@"_^XMB("NETNAME"))="" 133 .. S XMDUZ="DHCP PAID package" 134 .. S XMB="PRS LAST SAT OT/CT" 135 ..; 136 ..; employee name, pay period number, next pay period 137 .. S XMB(1)=EMPNM,XMB(2)=CURP,XMB(3)=NXTP,XMB(4)=TLU 138 .. D ^XMB 139 Q RTN 140 ; 141 LVND ; Leave Night Differential 142 ; back out ND granted for leave if employee took 8 or more hrs of leave 143 ; a non-wage grade employee can receive night differential when 144 ; on leave as long as the employee has taken less than 8 hours of 145 ; leave during the pay period. 146 ; input (note: units are count of 15min time segments): 147 ; LU - leave taken during pay period (set in PRS8AC, PRS8MT) 148 ; WK(#) - piece 10 contains total shift-2 ND for week # 149 ; WKL(#) - ND granted for leave during week # (set in PRS8PP) 150 ; output: 151 ; WK(#) - piece 10 may be modified 152 ; WKL(#) - may be modified 153 N W 154 Q:TYP["W" ; Doesn't apply to Wage Grade 155 Q:LU'>31 ; Didn't take 8hrs of leave 156 F W=1,2 D ; For each week subtract leave ND from total ND 157 . Q:'WKL(W) ; No leave ND to subtract 158 . S $P(WK(W),"^",10)=$P(WK(W),"^",10)-WKL(W) ; Subtract 159 . S WKL(W)=0 ; Reset leave ND amount 160 Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRS8MT.m
r613 r623 1 PRS8MT ;HISC/MRL-DECOMPOSITION, MEALTIME ;02/21/08 2 ;;4.0;PAID;**2,40,69,102,109,112,116**;Sep 21, 1995;Build 23 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;This routine is used to determine placement of mealtime where 6 ;necessary. 7 ; 8 ;Called by Routines: PRS8ST 9 ; 10 MULT ; --- checking 1 node 11 I $$HOLIDAY^PRS8UT(PY,DFN,MDY),$G(^PRST(458,PY,"E",DFN,"D",MDY,2))["MID^MID^ON" Q ;don't add meal if mid-mid on-call on a holiday, quit routine 12 S TWO=DAY(MDY,"TWO") 13 S S=1 D SET D:'Q I TWO S S=2 D SET D:'Q 14 .S D1="",$P(D1,"0",193)="",V(1)=97,V(2)=0 15 .F I=1:3:28 S V=$P(N,"^",I,I+2) Q:$P(V,"^",1)="" D 16 ..S X=$P(V,"^",3) I "^^6^7^3^8^"'[("^"_X_"^") Q ;quit if not NH 17 ..F M=$P(V,"^"):1:$P(V,"^",2) D ; build up tour 18 ...S D1=$E(D1,1,M-1)_$S(X=""!(X=3):1,X=6:2,1:3)_$E(D1,M+1,192) 19 ...I V(1)>M S V(1)=M 20 ...I V(2)<M S V(2)=M 21 ..Q 22 .D:V(2) GETY 23 .F I="N","W" F J=MDY,MDY+1 S X=$G(DAY(J,I)) D 24 ..I X'="" S ^TMP($J,"PRS8",J,I)=X 25 ..Q 26 .Q 27 ; 28 END ; --- all done here 29 K A,B,C,D,DIF,DIF1,J,L,M,M1,MID,MT,N,PM,T,SPL,SPLX,USE,V(1),V(2),VT,X,X1,X2,Y 30 Q 31 ; 32 GETY ; --- this is where Y (placement of mealtime) is defined 33 S X=$E(D,V(1),V(2)),D1=$E(D1,V(1),V(2)) 34 N ORIGX,RECESS 35 S ORIGX=X ; Original copy of codes in X and 36 S RECESS=DAY(MDY,"r")_$G(DAY(MDY,"rN")) 37 S RECESS=$E(RECESS,V(1),V(2)) ; load any Recess 38 I X["5" D 39 . N DAYP 40 . ; loop thru string X and replace 5s by a leave code if one exists 41 . S DAYP=$E(DAY(MDY,"P"),V(1),V(2)) ; leave may be hidden here 42 . F M=1:1:$L(X) D 43 . . I $E(X,M)=5,$E(DAYP,M)'=0 S $E(X,M)=$E(DAYP,M) 44 S MID=V(2)-V(1)+1-MT\2,MID=MID+V(1) ;middle of tour 45 S PM=+$P($G(^PRST(457.1,+$P(DAY(MDY,0),"^",$S(S=1:2,1:13)),0)),"^",7) ;0=non=prem meal/1=prem. meal 46 S X1=$E(X),Q=1 47 F M=1:1:$L(X) D Q:'Q 48 .S Y=$E(X,M) 49 .I "1235C"[Y,"1235C"[X1 Q ; scheduled work time 50 .I "4OC"[Y,$E(RECESS,M)="r" S Q=0 Q ; Work performed while on Recess (9mo AWS) 51 .I Y'="O",Y'=X1 S Q=0 Q ; not same type of time, and non-OT 52 .I Y="O",($E(DAY($S(V(1)+M-1<97:MDY,1:MDY+1),"HOL"),$S(V(1)+M-1<97:V(1)+M-1,1:V(1)+M-1-96))'=2) S Q=0 Q ; OT indicating non-holiday worked gets no meal 53 .I Y="O",($E(DAY($S(V(1)+M-1<97:MDY,1:MDY+1),"HOL"),$S(V(1)+M-1<97:V(1)+M-1,1:V(1)+M-1-96))=2),"123C"[X1 S Q=0 Q ; OT indicating holiday worked and Excused. 54 .Q 55 I X["0" D 56 .I RECESS'["r" S SPL=$TR(X,"1235"),SPLX=$TR(X,SPL,$TR($J("",$L(SPL))," ")) 57 .I RECESS["r" S SPL=$TR(X,"01235"),SPLX=$TR(X,SPL,$TR($J("",$L(SPL))," ")) 58 .I SPLX="" S Q=1 59 ; 60 K M 61 ;--- one activity for entire tour 62 I Q S Q=0 D F M=1:1:MT S M(M)=Y+M-1 63 .I V(1)>24,V(2)<73 S Y=MID Q ;no premium time involved/ meal in middle 64 .S Q=0 D ;check for all premium 65 ..I V(1)<25,V(2)<25 S Q=1 Q ;all hours before 6am 66 ..I V(1)>72,V(2)>72,V(2)'>120 S Q=1 Q ;all hours after 6pm 67 .I Q S Y=MID Q ; all time premium time/ meal in middle 68 .I PM S Y=0 D 69 ..I V(2)>72 S Y=73-$S(V(2)-73>MT&(V(1)'>73):0,V(1)<25!(V(2)'<121):73,1:MT-(V(2)-73)) 70 ..I 'Y,V(1)<25 S Y=$S(25-V(1)>MT:25-MT,1:V(1)) 71 ..I 'Y S Y=$S(121-V(1)>MT:121-MT,1:V(1)) 72 .E S Y=0 D 73 ..I V(2)>72 S Y=$S(73-MT>V(1):73-MT,V(1)<25!(V(2)'<121):0,1:V(1)) 74 ..I 'Y,V(1)<25 S Y=$S(V(2)-MT>24:25,1:V(2)-MT+1) 75 ..I 'Y S Y=$S(V(2)-MT>120:121,1:V(2)-MT+1) 76 .I 'Y S Y=MID 77 .Q 78 ; --- multiple activities per tour 79 E D 80 .S Z=$TR(X,"1235"),X=$TR(X,Z,$TR($J("",$L(Z))," ","0")) 81 .; 82 .; if leave posted > or = to tour length + mt (ie didn't post around 83 .; lunch) it was resulting in OT (ZRIK strips HOL, OC, & no tour time) 84 .; 85 .S ZRIK=$TR(Z,"HC0") 86 .I MT>0,$L(ZRIK)'<(($P(DAY(DAY,0),"^",8)*4)+MT) S X="",$P(X,"1",$L(ZRIK)+1)="" 87 .Q:X?1"0"."0"&(RECESS'["r") 88 .S M=0 F A=1,2 Q:M=MT F B=MID,MID+1,MID-1:-1:V(1),MID+2:1:V(2) D Q:M=MT 89 ..Q:'$E(X,B-V(1)+1) 90 ..I A=1,PM,B<25!(B>72&(B<121)) S M=M+1,M(M)=B 91 ..I A=1,'PM,B>24&(B<73)!(B>120) S M=M+1,M(M)=B 92 ..I A=2 S M=M+1,M(M)=B 93 ..Q 94 .Q 95 Q:'$O(M(0)) 96 Y ; --- this is where meals get placed in string 97 F Y=0:0 S Y=$O(M(Y)) Q:Y'>0 D 98 . N ORIGAC ; original activity code 99 . S M=M(Y),(X,ORIGAC)=$E(D,M),X=$S(X="J":"A",X=5:$E(DAY(MDY,"P"),M),1:X) 100 . ; If a 9mo AWS works during Recess don't place meal over that type of time 101 . I +NAWS=9 D ; 9mo AWS nurses 102 . . ; If extra work (UN,OT,CT) was posted over the entire tour including the meal time 103 . . ; don't include meal time in the W node or you will reduce the extra work count. 104 . . ; Set X=0 to reduce the Recess count below. 105 . . I "4OEC"[ORIGAC&($L(ORIGX)=$L($TR(ORIGX,"1235"))) S X=0 Q 106 . . ; 107 . . ; If extra work posted over tour time that wasn't covered by Recess it will 108 . . ; be stored in the r node. If this time exists, add that time back into the 109 . . ; W node instead of the meal time. 110 . . I "1235"[ORIGAC,"4OEC"[$E(RECESS,M-V(1)+1) D Q 111 . . . S D=$E(D,0,M-1)_$E(RECESS,M-V(1)+1)_$E(D,M+1,999) 112 . . . S ORIGX=$E(ORIGX,1,M-V(1)-1)_$E(RECESS,M-V(1)+1)_$E(ORIGX,M-V(1)+2,999) 113 . . ; 114 . . ; For everything else, update D and ORIGX 115 . . S D=$E(D,0,M-1)_"m"_$E(D,M+1,999) 116 . . S ORIGX=$E(ORIGX,M-V(1)-1)_"m"_$E(ORIGX,M-V(1)+2,999) 117 . ; 118 . ; All employees other than 9mo AWS 119 . I +NAWS'=9 S D=$E(D,0,M-1)_"m"_$E(D,M+1,999) 120 . ; 121 . ; The following line has been updated to include a check for Recess as the 48th piece. 122 . ; Recess will be designated as a zero (0). 123 . S X=$S(X'="M":$F("LSWnAR*U************************V********YXFGD*0",X)-1,1:5) 124 . ; 125 . ; Firefighter checks 126 . I "Ff"[TYP,NH'=480!(NH(1)'=NH(2)) S X=32 127 . ;I X'=4,CYA2806>0 S CYA2806=CYA2806-1 ; << ADDED-> DROP LUNCH FROM CY ALSO>> 128 . Q:X'>0 129 . Q:MDY=0&(M(Y)<96)!(MDY=14&(M(Y)>97)) 130 . S W=$S(MDY<8:1,1:2) I MDY=7&(M(Y)>96) S W=2 131 . I $P(WK(W),"^",+X)>0 S $P(WK(W),"^",+X)=$P(WK(W),"^",+X)-1 ;subtract 132 . ; 133 . ; If Military Leave subtract the mealtime out of the WK(3) array. 134 . I ORIGAC="M",$P(WK(3),U,11)>0 S $P(WK(3),U,11)=$P(WK(3),U,11)-1 135 . ;I WPCYA>0 S WPCYA=WPCYA-1 ;lunch from total << AND FROM CA TOTAL >> 136 . ; PRS*4*40 added 8 (U), 44 (F), 45 (G), 46 (D) to following line 137 . ; because PRS8AC also increments LU for those types of time 138 . I +X,"^1^2^6^8^44^45^46^"[("^"_+X_"^") S LU=LU-1 ;reduce leave used 139 . I +X,"^3^"[("^"_+X_"^"),"P"[TYP S TH=TH+1,TH(W)=TH(W)+1 140 . Q 141 S DAY(MDY,"W")=$E(D,1,96) 142 S X=$E(D,97,999) I $L(X) D 143 .I $D(DAY(MDY+1,"W")) S DAY(MDY+1,"W")=X_$E(DAY(MDY+1,"W"),$L(X)+1,999) 144 .S DAY(MDY,"N")=X 145 Q 146 ; 147 SET ; --- set up for processing 148 K A,B S (A,B,Q,Y)=0 149 S MT=$G(DAY(MDY,"MT"_S)) I MT'>0 S Q=1 Q ; mealtime for tour? 150 S D=DAY(MDY,"W")_$G(DAY(MDY,"N")) ; get daily activity 151 S N=DAY(MDY,S*S) ; get tour 152 Q 1 PRS8MT ;HISC/MRL-DECOMPOSITION, MEALTIME ;11/22/06 2 ;;4.0;PAID;**2,40,69,102,109**;Sep 21, 1995;Build 5 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;This routine is used to determine placement of mealtime where 6 ;necessary. 7 ; 8 ;Called by Routines: PRS8ST 9 ; 10 MULT ; --- checking 1 node 11 I $$HOLIDAY^PRS8UT(PY,DFN,MDY),$G(^PRST(458,PY,"E",DFN,"D",MDY,2))["MID^MID^ON" Q ;don't add meal if mid-mid on-call on a holiday, quit routine 12 S TWO=DAY(MDY,"TWO") 13 S S=1 D SET D:'Q I TWO S S=2 D SET D:'Q 14 .S D1="",$P(D1,"0",193)="",V(1)=97,V(2)=0 15 .F I=1:3:28 S V=$P(N,"^",I,I+2) Q:$P(V,"^",1)="" D 16 ..S X=$P(V,"^",3) I "^^6^7^3^8^"'[("^"_X_"^") Q ;quit if not NH 17 ..F M=$P(V,"^"):1:$P(V,"^",2) D ; build up tour 18 ...S D1=$E(D1,1,M-1)_$S(X=""!(X=3):1,X=6:2,1:3)_$E(D1,M+1,192) 19 ...I V(1)>M S V(1)=M 20 ...I V(2)<M S V(2)=M 21 ..Q 22 .D:V(2) GETY 23 .F I="N","W" F J=MDY,MDY+1 S X=$G(DAY(J,I)) D 24 ..I X'="" S ^TMP($J,"PRS8",J,I)=X 25 ..Q 26 .Q 27 ; 28 END ; --- all done here 29 K A,B,C,D,DIF,DIF1,J,L,M,M1,MID,MT,N,PM,T,SPL,SPLX,USE,V(1),V(2),VT,X,X1,X2,Y 30 Q 31 ; 32 GETY ; --- this is where Y (placement of mealtime) is defined 33 S X=$E(D,V(1),V(2)),D1=$E(D1,V(1),V(2)) 34 I X["5" D 35 . N DAYP 36 . ; loop thru string X and replace 5s by a leave code if one exists 37 . S DAYP=$E(DAY(MDY,"P"),V(1),V(2)) ; leave may be hidden here 38 . F M=1:1:$L(X) D 39 . . I $E(X,M)=5,$E(DAYP,M)'=0 S $E(X,M)=$E(DAYP,M) 40 S MID=V(2)-V(1)+1-MT\2,MID=MID+V(1) ;middle of tour 41 S PM=+$P($G(^PRST(457.1,+$P(DAY(MDY,0),"^",$S(S=1:2,1:13)),0)),"^",7) ;0=non=prem meal/1=prem. meal 42 S X1=$E(X),Q=1 43 F M=1:1:$L(X) D Q:'Q 44 .S Y=$E(X,M) 45 .I "1235C"[Y,"1235C"[X1 Q ; scheduled work time 46 .I Y'="O",Y'=X1 S Q=0 Q ; not same type of time, and non-OT 47 .I Y="O",($E(DAY($S(V(1)+M-1<97:MDY,1:MDY+1),"HOL"),$S(V(1)+M-1<97:V(1)+M-1,1:V(1)+M-1-96))'=2) S Q=0 Q ; OT indicatin' non-holiday worked gets no meal 48 .I Y="O",($E(DAY($S(V(1)+M-1<97:MDY,1:MDY+1),"HOL"),$S(V(1)+M-1<97:V(1)+M-1,1:V(1)+M-1-96))=2),"123C"[X1 S Q=0 Q ; OT indicatin holiday worked and Excused. 49 .Q 50 I X["0" D 51 .S SPL=$TR(X,"1235"),SPLX=$TR(X,SPL,$TR($J("",$L(SPL))," ")) 52 .I SPLX="" S Q=1 53 ; --- one activity for entire tour 54 K M I Q S Q=0 D F M=1:1:MT S M(M)=Y+M-1 55 .I V(1)>24,V(2)<73 S Y=MID Q ;no premium time involved/ meal in middle 56 .S Q=0 D ;check for all premium 57 ..I V(1)<25,V(2)<25 S Q=1 Q ;all hours before 6am 58 ..I V(1)>72,V(2)>72,V(2)'>120 S Q=1 Q ;all hours after 6pm 59 .I Q S Y=MID Q ; all time premium time/ meal in middle 60 .I PM S Y=0 D 61 ..I V(2)>72 S Y=73-$S(V(2)-73>MT&(V(1)'>73):0,V(1)<25!(V(2)'<121):73,1:MT-(V(2)-73)) 62 ..I 'Y,V(1)<25 S Y=$S(25-V(1)>MT:25-MT,1:V(1)) 63 ..I 'Y S Y=$S(121-V(1)>MT:121-MT,1:V(1)) 64 .E S Y=0 D 65 ..I V(2)>72 S Y=$S(73-MT>V(1):73-MT,V(1)<25!(V(2)'<121):0,1:V(1)) 66 ..I 'Y,V(1)<25 S Y=$S(V(2)-MT>24:25,1:V(2)-MT+1) 67 ..I 'Y S Y=$S(V(2)-MT>120:121,1:V(2)-MT+1) 68 .I 'Y S Y=MID 69 .Q 70 ; --- multiple activities per tour 71 E D 72 . S Z=$TR(X,"1235"),X=$TR(X,Z,$TR($J("",$L(Z))," ","0")) 73 . S ZRIK=$TR(Z,"HC") I MT>0,$L(ZRIK)'<(($P(DAY(DAY,0),"^",8)*4)+MT) S X="",$P(X,"1",$L(ZRIK)+1)="" ;if leave posted > or = to tour length + mt (ie didn't post around lunch) it was resulting in OT (ZRIK strips HOL & OC) 74 . Q:X?1"0"."0" 75 . S M=0 F A=1,2 Q:M=MT F B=MID,MID+1,MID-1:-1:V(1),MID+2:1:V(2) D Q:M=MT 76 . . Q:'$E(X,B-V(1)+1) 77 . . I A=1,PM,B<25!(B>72&(B<121)) S M=M+1,M(M)=B 78 . . I A=1,'PM,B>24&(B<73)!(B>120) S M=M+1,M(M)=B 79 . . I A=2 S M=M+1,M(M)=B 80 . . Q 81 . Q 82 Q:'$O(M(0)) 83 Y ; --- this is where meals get placed in string 84 F Y=0:0 S Y=$O(M(Y)) Q:Y'>0 D 85 . N ORIGAC ; original activity code 86 . S M=M(Y),(X,ORIGAC)=$E(D,M),X=$S(X="J":"A",X=5:$E(DAY(MDY,"P"),M),1:X),D=$E(D,0,M-1)_"m"_$E(D,M+1,999) 87 . S X=$S(X'="M":$F("LSWnAR*U************************V********YXFGD",X)-1,1:5) 88 . I "Ff"[TYP,NH'=480!(NH(1)'=NH(2)) S X=32 89 . ;I X'=4,CYA2806>0 S CYA2806=CYA2806-1 ; << ADDED-> DROP LUNCH FROM CY ALSO>> 90 . Q:X'>0 91 . Q:MDY=0&(M(Y)<96)!(MDY=14&(M(Y)>97)) 92 . S W=$S(MDY<8:1,1:2) I MDY=7&(M(Y)>96) S W=2 93 . I $P(WK(W),"^",+X)>0 S $P(WK(W),"^",+X)=$P(WK(W),"^",+X)-1 ;subtract 94 . ; If Military Leave subtract the mealtime out of the WK(3) array. 95 . I ORIGAC="M",$P(WK(3),U,11)>0 S $P(WK(3),U,11)=$P(WK(3),U,11)-1 96 . ;I WPCYA>0 S WPCYA=WPCYA-1 ;lunch from total << AND FROM CA TOTAL >> 97 . ; PRS*4*40 added 8 (U), 44 (F), 45 (G), 46 (D) to following line 98 . ; because PRS8AC also increments LU for those types of time 99 . I +X,"^1^2^6^8^44^45^46^"[("^"_+X_"^") S LU=LU-1 ;reduce leave used 100 . I +X,"^3^"[("^"_+X_"^"),"P"[TYP S TH=TH+1,TH(W)=TH(W)+1 101 . Q 102 S DAY(MDY,"W")=$E(D,1,96) 103 S X=$E(D,97,999) I $L(X) D 104 .I $D(DAY(MDY+1,"W")) S DAY(MDY+1,"W")=X_$E(DAY(MDY+1,"W"),$L(X)+1,999) 105 .S DAY(MDY,"N")=X 106 Q 107 ; 108 SET ; --- set up for processing 109 K A,B S (A,B,Q,Y)=0 110 S MT=$G(DAY(MDY,"MT"_S)) I MT'>0 S Q=1 Q ; mealtime for tour? 111 S D=DAY(MDY,"W")_$G(DAY(MDY,"N")) ; get daily activity 112 S N=DAY(MDY,S*S) ; get tour 113 Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRS8OC.m
r613 r623 1 PRS8OC ;HISC/MGD-DECOMPOSITION, ON-CALL ;02/27/07 2 ;;4.0;PAID;**63,92,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;The following MUMPS code is used to credit the appropriate 6 ;categories on the timecard for work performed while On-Call. 7 ;All hours during which an individual is identified as being 8 ;On-Call are credited to blocks YD and YH (On Call Hrs) on 9 ;the timecard. Hours during an On-Call episode where an 10 ;individual is actually called in to perform work are credited 11 ;to blocks YA and YE (Sch CB OT) as appropriate. This credit 12 ;is given under the 2-hour minimum rule. When OT work is 13 ;performed during On-Call the actual On-Call Hours reported 14 ;are reduced by the ACTUAL number of hours worked (not by the 15 ;2-hour minimum). 16 ; 17 ;Called by Routines: PRS8ST 18 ; 19 ;C = On-Call 20 ;c = OT during OC 21 ;t = CT during OC 22 ; 23 S (I,D)=$S(T'>96:DAY,1:(DAY+1)) 24 S OC=$G(OC),OC(DAY)=$G(OC(DAY)),OC(DAY+1)=$G(OC(DAY+1)) ;oc variables 25 S CC=$G(CC),CC(DAY)=$G(CC(DAY)),CC(DAY+1)=$G(CC(DAY+1)) ;CT on OC count 26 S Y=35,Y(1)=1 D SET 27 I VAR1="C" D:OC!(CC) OCS ;on-call episode (ot OR ct) 28 S:"ct"[VAR1 OC=OC+1,OC(D)=OC(D)+1 S:VAR1="t" CC=CC+1,CC(D)=CC(D)+1 29 I "ct"[VAR1,DAY>0,DAY<15 S CBCK(WK)=CBCK(WK)+1 ;count actual CB hrs 30 Q:'OK!('$D(OC)) 31 I OC S Y=23 D OCS ;get rest of them 32 K OC,CC,Y,D Q 33 ; 34 OCS ; --- set On-Call minimum hours 35 ;set YA/YE for PPI="W" or "V" else set OT 36 I +NAWS=0 S Y=$S(CC:7,'DOUB:TOUR+19,1:23) 37 I +NAWS S Y=$S(CC:7,1:TOUR+19) 38 ; 39 N X,Z,DD,TT,CCCNT,NEXTT,OCCNT,TIMECNT 40 S TT=$S(T>96:T-96,1:T),TIMECNT=0 41 S X=$E(DAY($S(T>96:DAY+1,1:DAY),"W"),TT) 42 ; 43 ; If the current segment is the last of the On-Call OR the last of 44 ; the On-Call Callback and the next time segment is Unavailable ("-") 45 ; or not a type of work ("0") check to see if OT/reg sched is prior 46 ; to on call worked. 47 ; 48 S NEXTT=$S(T+1>96:T-95,1:TT+1) ; Next time segment 49 I "C"[X!(("ct"[X)&("-0"[$E($S(T+1>96:DAY(DAY+1,"W"),1:DAY(DAY,"W")),NEXTT))) D 50 .K XH S X=0 F Z=1:1:8-(OC(DAY)+$G(OC(DAY+1))) D Q:"01"[X 51 ..S DD=OC(DAY)+OC(DAY+1)+Z 52 ..I TT-DD>0 S X=$E(DAY(DAY,"W"),TT-DD) S:X="O"&($E(DAY(DAY,"HOL"),TT-DD)=2) X="h" 53 ..E S X=$E(DAY(DAY-1,"W"),96+T-DD) S:X="O"&($E(DAY(DAY-1,"HOL"),96+T-DD)=2) X="h" 54 ..I "123nHMLSWNARXYFGD"[X S X=1 Q ; on call abuts a reg sched TOD. 55 ..E I "EOhoscte"[X D ; on call abuts time worked outside posted TOD. 56 ...I "ct"'[X S TIMECNT=TIMECNT+1 ; Time already counted in WK(). 57 ...S XH=$S(X'="h":0,1:1),X=2 58 ..E S X=0 59 ..Q 60 .Q 61 E D ; Check to see if OT/reg sched is after on call worked 62 .K XH S X=0 F Z=1:1:8-(OC(DAY)+$G(OC(DAY+1))) D Q:"01"[X 63 ..S DD=OC(DAY)+OC(DAY+1)+Z 64 ..I T+Z'>96 S X=$E(DAY(DAY,"W"),T+Z) S:X="O"&($E(DAY(DAY,"HOL"),T+Z)=2) X="h" 65 ..E S X=$E(DAY(DAY+1,"W"),T-96+Z) S:X="O"&($E(DAY(DAY+1,"HOL"),T-96+Z)=2) X="h" 66 ..I "123nHMLSWNARXYFGD"[X S X=1 Q ; on call abuts a reg sched TOD. 67 ..E I "EOhoscte"[X D 68 ...I "ct"'[X S TIMECNT=TIMECNT+1 ; Time already counted in WK(). 69 ...S XH=$S(X'="h":0,1:1),X=2 70 ..E S X=0 71 ..Q 72 .Q 73 I $G(XH)'="" S:XH=1!'X Z=Z-1,X=2 74 ; 75 ; Check if Scheduled Call-Back OT crosses Midnight 76 ; 77 I '$D(CRSMID(D)),$E(DAY(DAY,"W"),1)="c",$E(DAY(DAY-1,"W"),96)="c" S FG=0 D Q:FG=1 78 .S CRSMID(D)=1 79 .I OC<7 D Q:FG=1 80 ..; crosses midnight, check if its <2 hours, CRSMID variable set to 81 ..; only do on segment that cross mid, not others 82 ..S CNTR=0 F CX=1:1:8-OC S:$E(DAY(DAY-1,"W"),97-CX)="c" CNTR=CNTR+1 83 ..I OC+CNTR'>8 D 84 ...S Y(1)=$S(X=1:OC,1:8-CNTR) 85 ...I +NAWS=0 D CHOL ; Process everyone but AWS nurses 86 ...I +NAWS D CHOL1 ; Process AWS nurses 87 ...S (OC,OC(D),CC,CC(D))=0,FG=1 88 ..Q 89 ; 90 ; Check if Comp Time crosses Midnight 91 ; 92 I '$D(CRSMID(D)),$E(DAY(DAY,"W"),1)="t",$E(DAY(DAY-1,"W"),96)="t" S FG=0 D Q:FG=1 93 .S CRSMID(D)=1 94 .I OC<7 D Q:FG=1 95 ..; crosses midnight, check if its <2 hours, CRSMID variable set to 96 ..; only do on segment that cross mid, not others 97 ..S CNTR=0 F CX=1:1:8-OC S:$E(DAY(DAY-1,"W"),97-CX)="t" CNTR=CNTR+1 98 ..I OC+CNTR'>8 D 99 ...S Y(1)=$S(X=1:OC,1:8-CNTR) 100 ...I +NAWS=0 D CHOL ; Process everyone but AWS nurses 101 ...I +NAWS D CHOL1 ; Process AWS nurses 102 ...S (OC,OC(D),CC,CC(D))=0,FG=1 103 ..Q 104 ; 105 I CC>0,CC<OC D ;SPLIT SEGMENT, MUST DO TWICE (FOR CT THEN FOR OT) 106 .F I=DAY:1:(DAY+1) I OC(I) D 107 ..S (OCCNT,CCCNT)=0 108 ..I X=2,OC(I)+TIMECNT<8 D ; Add time if 2 hour minimum was not met. 109 ...S TIMECNT=8-OC(I)-TIMECNT ; Amount of time short of the 2 hour min. 110 ...; 111 ...; If TIMECNT is an even number divide needed time equally among the 112 ...; CT and OT. 113 ...I TIMECNT#2=0 S CCCNT=TIMECNT/2,OCCNT=TIMECNT/2 114 ...; 115 ...; If TIMECNT is not an even number divide the time needed as equally 116 ...; as possible among the CT and OT w/ remaining 15 minutes going to OC. 117 ...I TIMECNT#2=1 S CCCNT=TIMECNT\2,OCCNT=(TIMECNT\2)+1 118 ...; 119 ..S Y(1)=$S(X=2:CC(I)+CCCNT,X:CC(I),OC(I)>7:CC(I),1:4),Y=7 120 ..I +NAWS=0 D CHOL ; Process everyone but AWS nurses 121 ..I +NAWS D CHOL1 ; Process AWS nurses 122 ..S Y(1)=$S(X=2:OC(I)-CC(I)+OCCNT,X:OC(I)-CC(I),OC(I)>7:OC(I)-CC(I),1:4) 123 ..S Y=$S('DOUB:TOUR+19,1:23) 124 ..I +NAWS=0 D CHOL ; Process everyone but AWS nurses 125 ..I +NAWS D CHOL1 ; Process AWS nurses 126 ..Q 127 .Q 128 E D ;NOT SPLIT SEGMENT 129 .F I=DAY:1:(DAY+1) I OC(I) D 130 ..I OC(I)<8,X=2 D 131 ...I T'=96 S OC(I)=8-TIMECNT 132 ...I T=96,"ct"'[$E(DAY(DAY+1,"W"),1) S OC(I)=8-TIMECNT 133 ..S Y(1)=$S(X:OC(I),OC(I)>7:OC(I),1:8) 134 ..I +NAWS=0 D CHOL ; Process everyone but AWS nurses 135 ..I +NAWS D CHOL1 ; Process AWS nurses 136 ..Q 137 .Q 138 K OC,CC Q 139 ; 140 CHOL ; --- Check for Holiday Callback 141 S TMP=Y,Y=0 142 ; Don't convert Overtime to Comptime 143 I TMP'=7,$E(ENT,25),$$HOLIDAY^PRS8UT(PY,DFN,+D) S Y=24 ;ot on actual hol 144 I 'Y,$E($G(DAY(I,"HOL")),$S(T>96:(T-96),1:T)) S Y=TOUR+28 ;holiday callback 145 I 'Y S Y=TMP 146 D SET S Y=$S(CC:7,'DOUB:TOUR+19,1:23) 147 Q 148 ; 149 SET ; --- set WK array 150 S W=$S(I<8:1,1:2) 151 I I<1!(I>14) Q 152 I Y(1)>32,'DOUB,$P(C0,"^",12)="N",Y'=7 D 153 .S $P(WK(W),"^",TOUR+15)=$P(WK(W),"^",TOUR+15)+(Y(1)-32) 154 .S $P(WK(W),"^",Y)=$P(WK(W),"^",Y)+32 ;if FLSA=N set >8 = DA 155 E S $P(WK(W),"^",Y)=$P(WK(W),"^",Y)+Y(1) 156 Q 157 ; 158 CHOL1 ; Checks for AWS nurses 159 N HT,J,K,T2ADD 160 S K=0,TMP=Y,Y=0 161 S T2ADD=$S(CC:Y(1)-CC,1:Y(1)-OC-CC) 162 ; Apply normal checks for OT on Hol and Hol Callback 163 I TMP'=7,$E(ENT,25),$$HOLIDAY^PRS8UT(PY,DFN,+D) S Y=24 ;ot on actual hol 164 I 'Y,$E($G(DAY(I,"HOL")),$S(T>96:(T-96),1:T)) S Y=TOUR+28 ;holiday callback 165 I 'Y S Y=TMP 166 I Y=24!(Y=(TOUR+28)) D SET Q 167 ; If not OT on Hol or Hol Callback Determine if we are setting OT or CT 168 S K=$S(Y=7:CC,1:OC) 169 F J=1:1:K D AWSWK ; Update actual time worked 170 F J=1:1:T2ADD D AWSWK ; Update time added to reach 2 hour min 171 Q 172 ; 173 AWSWK ; Determine what type of time to add based on 8/day and 40/wk 174 S HT=+$G(^TMP($J,"PRS8",D,"HT")) 175 I HT'<32 S Y=$S(Y'=7:TOUR+15,1:Y) D SET1 Q 176 I TH(W)'<160 S Y=$S(Y'=7:TOUR+19,1:Y) D SET1 Q 177 I HT<32,TH(W)<160 S Y=9 D SET1 178 Q 179 ; 180 SET1 ; Set WK array for AWS nurses 181 S $P(WK(W),"^",Y)=$P(WK(W),"^",Y)+1 182 Q:HT'<32 183 S TH=TH+1,TH(WK)=TH(WK)+1 184 S ^TMP($J,"PRS8",DAY,"HT")=HT+1 185 Q 1 PRS8OC ;HISC/MGD-DECOMPOSITION, ON-CALL ;02/17/04 2 ;;4.0;PAID;**63,92**;Sep 21, 1995 3 ; 4 ;The following MUMPS code is used to credit the appropriate 5 ;categories on the timecard for work performed while On-Call. 6 ;All hours during which an individual is identified as being 7 ;On-Call are credited to blocks YD and YH (On Call Hrs) on 8 ;the timecard. Hours during an On-Call episode where an 9 ;individual is actually called in to perform work are credited 10 ;to blocks YA and YE (Sch CB OT) as appropriate. This credit 11 ;is given under the 2-hour minimum rule. When OT work is 12 ;performed during On-Call the actual On-Call Hours reported 13 ;are reduced by the ACTUAL number of hours worked (not by the 14 ;2-hour minimum). 15 ; 16 ;Called by Routines: PRS8ST 17 ; 18 ;C = On-Call 19 ;c = OT during OC 20 ;t = CT during OC 21 ; 22 S (I,D)=$S(T'>96:DAY,1:(DAY+1)) 23 S OC=$G(OC),OC(DAY)=$G(OC(DAY)),OC(DAY+1)=$G(OC(DAY+1)) ;oc variables 24 S CC=$G(CC),CC(DAY)=$G(CC(DAY)),CC(DAY+1)=$G(CC(DAY+1)) ;CT on OC count 25 S Y=35,Y(1)=1 D SET 26 I VAR1="C" D:OC!(CC) OCS ;on-call episode (ot OR ct) 27 S:"ct"[VAR1 OC=OC+1,OC(D)=OC(D)+1 S:VAR1="t" CC=CC+1,CC(D)=CC(D)+1 28 I "ct"[VAR1,DAY>0,DAY<15 S CBCK(WK)=CBCK(WK)+1 ;count actual CB hrs 29 Q:'OK!('$D(OC)) 30 I OC S Y=23 D OCS ;get rest of them 31 K OC,CC,Y,D Q 32 ; 33 OCS ; --- set On-Call minimum hours 34 ;set YA/YE for PPI="W" or "V" else set OT 35 S Y=$S(CC:7,'DOUB:TOUR+19,1:23) 36 N X,Z,DD,TT,CCCNT,NEXTT,OCCNT,TIMECNT 37 S TT=$S(T>96:T-96,1:T),TIMECNT=0 38 S X=$E(DAY($S(T>96:DAY+1,1:DAY),"W"),TT) 39 ; 40 ; If the current segment is the last of the On-Call OR the last of 41 ; the On-Call Callback and the next time segment is Unavailable ("-") 42 ; or not a type of work ("0") check to see if OT/reg sched is prior 43 ; to on call worked. 44 ; 45 S NEXTT=$S(T+1>96:T-95,1:TT+1) ; Next time segment 46 I "C"[X!(("ct"[X)&("-0"[$E($S(T+1>96:DAY(DAY+1,"W"),1:DAY(DAY,"W")),NEXTT))) D 47 .K XH S X=0 F Z=1:1:8-(OC(DAY)+$G(OC(DAY+1))) D Q:"01"[X 48 ..S DD=OC(DAY)+OC(DAY+1)+Z 49 ..I TT-DD>0 S X=$E(DAY(DAY,"W"),TT-DD) S:X="O"&($E(DAY(DAY,"HOL"),TT-DD)=2) X="h" 50 ..E S X=$E(DAY(DAY-1,"W"),96+T-DD) S:X="O"&($E(DAY(DAY-1,"HOL"),96+T-DD)=2) X="h" 51 ..I "123nHMLSWNARXYFGD"[X S X=1 Q ; on call abuts a reg sched TOD. 52 ..E I "EOhoscte"[X D ; on call abuts time worked outside posted TOD. 53 ...I "ct"'[X S TIMECNT=TIMECNT+1 ; Time already counted in WK(). 54 ...S XH=$S(X'="h":0,1:1),X=2 55 ..E S X=0 56 ..Q 57 .Q 58 E D ; Check to see if OT/reg sched is after on call worked 59 .K XH S X=0 F Z=1:1:8-(OC(DAY)+$G(OC(DAY+1))) D Q:"01"[X 60 ..S DD=OC(DAY)+OC(DAY+1)+Z 61 ..I T+Z'>96 S X=$E(DAY(DAY,"W"),T+Z) S:X="O"&($E(DAY(DAY,"HOL"),T+Z)=2) X="h" 62 ..E S X=$E(DAY(DAY+1,"W"),T-96+Z) S:X="O"&($E(DAY(DAY+1,"HOL"),T-96+Z)=2) X="h" 63 ..I "123nHMLSWNARXYFGD"[X S X=1 Q ; on call abuts a reg sched TOD. 64 ..E I "EOhoscte"[X D 65 ...I "ct"'[X S TIMECNT=TIMECNT+1 ; Time already counted in WK(). 66 ...S XH=$S(X'="h":0,1:1),X=2 67 ..E S X=0 68 ..Q 69 .Q 70 I $G(XH)'="" S:XH=1!'X Z=Z-1,X=2 71 ; 72 ; Check if Scheduled Call-Back OT crosses Midnight 73 ; 74 I '$D(CRSMID(D)),$E(DAY(DAY,"W"),1)="c",$E(DAY(DAY-1,"W"),96)="c" S FG=0 D Q:FG=1 75 .S CRSMID(D)=1 76 .I OC<7 D Q:FG=1 77 ..; crosses midnight, check if its <2 hours, CRSMID variable set to 78 ..; only do on segment that cross mid, not others 79 ..S CNTR=0 F CX=1:1:8-OC S:$E(DAY(DAY-1,"W"),97-CX)="c" CNTR=CNTR+1 80 ..I OC+CNTR'>8 D 81 ...S Y(1)=$S(X=1:OC,1:8-CNTR) 82 ...D CHOL 83 ...S (OC,OC(D),CC,CC(D))=0,FG=1 84 ..Q 85 ; 86 ; Check if Comp Time crosses Midnight 87 ; 88 I '$D(CRSMID(D)),$E(DAY(DAY,"W"),1)="t",$E(DAY(DAY-1,"W"),96)="t" S FG=0 D Q:FG=1 89 .S CRSMID(D)=1 90 .I OC<7 D Q:FG=1 91 ..; crosses midnight, check if its <2 hours, CRSMID variable set to 92 ..; only do on segment that cross mid, not others 93 ..S CNTR=0 F CX=1:1:8-OC S:$E(DAY(DAY-1,"W"),97-CX)="t" CNTR=CNTR+1 94 ..I OC+CNTR'>8 D 95 ...S Y(1)=$S(X=1:OC,1:8-CNTR) 96 ...D CHOL 97 ...S (OC,OC(D),CC,CC(D))=0,FG=1 98 ..Q 99 ; 100 I CC>0,CC<OC D ;SPLIT SEGMENT, MUST DO TWICE (FOR CT THEN FOR OT) 101 .F I=DAY:1:(DAY+1) I OC(I) D 102 ..S (OCCNT,CCCNT)=0 103 ..I X=2,OC(I)+TIMECNT<8 D ; Add time if 2 hour minimum was not met. 104 ...S TIMECNT=8-OC(I)-TIMECNT ; Amount of time short of the 2 hour min. 105 ...; 106 ...; If TIMECNT is an even number divide needed time equally among the 107 ...; CT and OT. 108 ...I TIMECNT#2=0 S CCCNT=TIMECNT/2,OCCNT=TIMECNT/2 109 ...; 110 ...; If TIMECNT is not an even number divide the time needed as equally 111 ...; as possible among the CT and OT w/ remaining 15 minutes going to OC. 112 ...I TIMECNT#2=1 S CCCNT=TIMECNT\2,OCCNT=(TIMECNT\2)+1 113 ...; 114 ..S Y(1)=$S(X=2:CC(I)+CCCNT,X:CC(I),OC(I)>7:CC(I),1:4),Y=7 115 ..D CHOL 116 ..S Y(1)=$S(X=2:OC(I)-CC(I)+OCCNT,X:OC(I)-CC(I),OC(I)>7:OC(I)-CC(I),1:4) 117 ..S Y=$S('DOUB:TOUR+19,1:23) 118 ..D CHOL 119 ..Q 120 .Q 121 E D ;NOT SPLIT SEGMENT 122 .F I=DAY:1:(DAY+1) I OC(I) D 123 ..I OC(I)<8,X=2 D 124 ...I T'=96 S OC(I)=8-TIMECNT 125 ...I T=96,"ct"'[$E(DAY(DAY+1,"W"),1) S OC(I)=8-TIMECNT 126 ..S Y(1)=$S(X:OC(I),OC(I)>7:OC(I),1:8) 127 ..D CHOL 128 ..Q 129 .Q 130 K OC,CC Q 131 ; 132 CHOL ; --- Check for Holiday Callback 133 S TMP=Y,Y=0 134 ; Don't convert Overtime to Comptime 135 I TMP'=7,$E(ENT,25),$$HOLIDAY^PRS8UT(PY,DFN,+D) S Y=24 ;ot on actual hol 136 I 'Y,$E($G(DAY(I,"HOL")),$S(T>96:(T-96),1:T)) S Y=TOUR+28 ;holiday callback 137 I 'Y S Y=TMP 138 D SET S Y=$S(CC:7,'DOUB:TOUR+19,1:23) 139 Q 140 ; 141 SET ; --- set WK array 142 S W=$S(I<8:1,1:2) 143 I I<1!(I>14) Q 144 I Y(1)>32,'DOUB,$P(C0,"^",12)="N",Y'=7 D 145 .S $P(WK(W),"^",TOUR+15)=$P(WK(W),"^",TOUR+15)+(Y(1)-32) 146 .S $P(WK(W),"^",Y)=$P(WK(W),"^",Y)+32 ;if FLSA=N set >8 = DA 147 E S $P(WK(W),"^",Y)=$P(WK(W),"^",Y)+Y(1) 148 Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRS8PP.m
r613 r623 1 PRS8PP ;HISC/MRL,WIRMFO/MGD-DECOMP, PREMIUM PAYS ;05/10/07 2 ;;4.0;PAID;**22,40,75,92,96,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;This routine is the entry point for determining certain premium 6 ;pays for an employee. Included are overtime (OT), 7 ;night differential (ND), unscheduled hours (UH), etc. 8 ; 9 ;Called by Routines: PRS8ST 10 ; 11 S D=DAY(DAY,"W") ; Daily activity string. 12 S W=$S(DAY<8:1,1:2) ; Week. 13 I D?1"0"."0" Q ; No activity this date. 14 S NDC=1,(HT,HTP,HTFFOT)=0 ; Counter for hrs worked this 15 ; day (HT=Hours total). 16 N HYBRID ; HYBRID under P.L 107-135 17 S HYBRID=$$HYBRID^PRSAENT1($G(DFN)) 18 D ^PRS8HR ; calculate Norm hrs first 19 F M=1:1:96 S VAL=$E(D,M) I VAL'=0 D ;loop thru minutes of day 20 .S DH=DAY(DAY,"DH1") 21 .I TWO,M'<+$P(DAY(DAY,"TWO"),"^",2) S DH=DAY(DAY,"DH2") ; Daily hrs. 22 .I NDC,"CWB"'[VAL D ND ; Get ND. 23 .I TYP["B",+VAL Q ; Baylor get no premium during tod. 24 .I "1234OosEe"'[VAL Q ; Don't chk for non-work status. 25 .S X=$E(D,M,96) ; Remainder of day. 26 .I X?1N.N,X'[4 Q ; No hrs left other than normal. 27 .I "J123MLSWNARXYOFGD"'[VAL!(VAL="O"&($E(DAY(DAY,"HOL"),M)'=2)) S AV="OosEe" D CALC^PRS8HR 28 K AV,D,GO,M,NDC,X,X1,J1,J2 Q 29 ; 30 ND ; --- compute ND 31 ; Process wagegrade 32 I TYP["W" D Q 33 . ; process WG scheduled time 34 . I "J23LSARMXYUVFGD"[VAL!(VAL="O"&($E(DAY(DAY,"HOL"),M)=2)) D 35 . . N DAT,DAYN,FND,M1,NODE,SC,TS 36 . . ; find tour segment that contains the time and get it's special code 37 . . S FND=0,SC="" ; FND true if found in schedule, SC = special code 38 . . ; look in schedule of current day for M and previous day for M+96 39 . . ; (in 2day tour, previous day's schedules >96 are Today's activity) 40 . . F DAYN=DAY,DAY-1 D Q:FND 41 . . . S M1=$S(DAYN=DAY:M,1:M+96) 42 . . . ; loop thru both tours in day 43 . . . F NODE=1,4 S DAT=$G(^TMP($J,"PRS8",DAYN,NODE)) Q:DAT="" D Q:FND 44 . . . . ; loop thru tour segments in tour 45 . . . . F TS=1:1:7 Q:$P(DAT,U,(TS-1)*3+1)="" D Q:FND 46 . . . . . ; check if time contained in tour segment 47 . . . . . I M1'<$P(DAT,U,(TS-1)*3+1),M1'>$P(DAT,U,(TS-1)*3+2) S FND=1,SC=$P(DAT,U,(TS-1)*3+3) 48 . . ; 49 . . ; if time not found in any schedule, base SC on value of variable 50 . . ; TOUR for Today (or previous day when no scheduled tour Today). 51 . . I 'FND S SC=$S($G(^TMP($J,"PRS8",DAY,1))=""&(DAY(DAY-1,"TOUR")>1):DAY(DAY-1,"TOUR")+4,1:TOUR+4) 52 . . Q:"^6^7^"'[(U_SC_U) ; tour segment not coded for shift 2 or 3 53 . . S X=(SC-4)+8 ; determine where to store in WK array 54 . . I $E(ENT,X-4) D SET ; if employee entitled then store result 55 . ; 56 . ; process WG unscheduled time 57 . I VAL=4!(VAL="O") D 58 . . N T,SD 59 . . ; unscheduled regular tours for 'shift coverage' that are eligible 60 . . ; for shift 2 or 3 differential were saved in "SD" by PRS8EX. 61 . . S SD=$G(^TMP($J,"PRS8",DAY,"SD")) 62 . . Q:SD="" 63 . . ; see if time belongs to a tour saved in "SD" and if so use the 64 . . ; associated shift (2 or 3) 65 . . S SD(1)=0 ; init shift 66 . . F T=1:3 S SD(0)=$P(SD,U,T,T+2) Q:SD(0)=""!(SD(0)?1."^") D Q:SD(1) 67 . . . I M'<+SD(0),M'>$P(SD(0),"^",2) S SD(1)=$P(SD(0),"^",3) 68 . . I SD(1) S X=SD(1)+8 I $E(ENT,X-4) D SET 69 ; 70 ; Process Other Employees (non-Wage Grade) 71 ; 72 ; Not entitled to ND 73 I '$E(ENT,6) Q 74 ; 75 ; not entitled to ND if No Premium Pay tour 76 I $P(DAY(DAY,1),"^",3)=8 Q 77 ; 78 ; check if time segment could be eligible for ND 79 I $$NOTND(TYP,DAY,M) Q 80 ; 81 S AV="J1234ALSRMUEOosecbVXYFGD" 82 ; 83 ; Grant ND for time before 6a/after 6p or anytime when nurse/hybrid 84 ; works tour coverage 85 I M<25!(M>72)!($E(DAY(DAY,"P"),M)="N"&(TYP["N"!(TYP["H")!(HYBRID))),AV[VAL D 86 . ; The Hybrids defined in Public Law 107-135 will only receive Night 87 . ; Differential time for OT and CT worked between 6 p.m. and 6 a.m. 88 . Q:HYBRID!(PMP'=""&("^S^T^U^V^"[(U_PMP_U)))&(M'<25&(M'>72)) 89 . ; Tour time between 6 p.m. and 6 a.m. counts toward ND 90 . N DAT,DAYN,FND,M1,NODE,SC,TS,TOT 91 . ; find tour segment that contains the time and get it's special code 92 . S FND=0,SC="" ; FND true if found in schedule, SC = special code 93 . S TOT="" ; Type Of Time 94 . ; look in schedule of current day for M and previous day for M+96 95 . ; (in 2day tour, previous day's schedules >96 are Today's activity) 96 . F DAYN=DAY,DAY-1 D Q:FND 97 . . S M1=$S(DAYN=DAY:M,1:M+96) 98 . . S DAT=$G(^TMP($J,"PRS8",DAYN,2)) D Q:FND 99 . . . ; loop thru tour segments in exceptions 100 . . . F TS=1:1:7 Q:$P(DAT,U,(TS-1)*4+1)="" D Q:FND 101 . . . . ; check if time contained in exception segment 102 . . . . I M1'<$P(DAT,U,(TS-1)*4+1),M1'>$P(DAT,U,(TS-1)*4+2) D 103 . . . . . S TOT=$P(DAT,U,(TS-1)*4+3) 104 . . . . . ; On-Call and Recess are the only types of exceptions 105 . . . . . ; where OT, CT and RG can be posted for the same 15 minute 106 . . . . . ; segment of time, so don't stop searching if you find these. 107 . . . . . I TOT="ON"!(TOT="RS") S TOT="" Q 108 . . . . . S FND=1,SC=$P(DAT,U,(TS-1)*4+4) 109 . . . . . Q 110 . Q:TOT="OT"&("^11^12^17^"'[(U_SC_U)) ; Pre-Scheduled & Tour Coverage & OT/CT With Premiums 111 . Q:TOT="CT"&("^12^17^"'[(U_SC_U)) ; Tour Coverage & OT/CT With Premiums 112 . ; Code 17 - OT/CT with premiums only get ND for 6p-6a 113 . Q:TOT="OT"!(TOT="CT")!(TOT="RG")&(SC=17)&((M'<25)&(M'>72)) 114 . Q:TOT="RG"&(SC'=7)&(SC'=17) ; Shift Coverage & OT/CT With Premiums 115 . S X=10 116 . ; for 36/40 AWS, premium time resulting from their tour 117 . ; will be mapped to Night Differential-AWS (ND/NU) and 118 . ; Paid at the AAC with the 1872 divisor for the hourly rate (36*52) 119 . I +NAWS=36,("OEc"'[VAL!(TOT="HW")) S X=51 120 . D SET 121 . ; keep leave count since it may need to be backed out by PRS8MSC0 122 . I "LSRUFGD"[VAL S WKL(WK)=WKL(WK)+1 123 ; 124 ; Nurse can get ND for 6a-6p time when part of tour with 4+ hrs in 6p-6a 125 ; check is made when M=24 (just before 6am) or M=73 (just after 6pm). 126 ; if tour eligible (4+ hours in 'night' time) then ND is granted for 127 ; the portion of the tour that falls within the 'day' time. 128 I TYP["N"!(TYP["H"),M=73!(M=24),AV_"m"[VAL D 129 . N C,J,Q,X,X1,X2,XD 130 . ; 131 . ; quit if 'day' time is for tour coverage since already counted 132 . I $E(DAY(DAY,"P"),$S(M=73:72,1:25))="N" Q 133 . ; 134 . ; first check if tour has at least 4 hours of 'night' (6pm-6am) time 135 . S XD=$S(M=24:-1,1:1) ; loop direction, [6am back, 6pm forward] 136 . S X1=M,X2=X1+(XD*15) ; start and stop of 4 hour range 137 . ; loop thru tour 'night' time - stop if tour ends or after 4 hours 138 . S C=1 ; init flag, false when tour has less than 4 hours of 'night' 139 . F J=X1:XD:X2 D Q:'C 140 . . I AV_"m"'[$E(D,J) S C=0 Q ; inappropriate type of time 141 . . I $$NOTND(TYP,DAY,J) S C=0 Q 142 . . ; scheduled TOD considered as separate from covered TOD 143 . . I $E(DAY(DAY,"P"),M)'=$E(DAY(DAY,"P"),J) S C=0 Q 144 . ; 145 . Q:'C ; tour not eligible (less than 4 hours of 'night') 146 . ; 147 . ; loop thru day time (6am-6pm) portion of tour and grant ND 148 . ; don't pay ND for meal-time (m) but continue loop 149 . S XD=$S(M=24:1,1:-1) ; loop direction [6am forward, 6pm back] 150 . S X1=M+XD,X2=X1+(47*XD) ; start and stop for day time (12 hours) 151 . S Q=0 ; init flag, true when end of tour reached 152 . F J=X1:XD:X2 D Q:Q 153 . . I AV_"m"'[$E(D,J) S Q=1 Q ; inappropriate time 154 . . I $$NOTND(TYP,DAY,J) S Q=1 Q 155 . . ; scheduled TOD considered as separate from covered TOD 156 . . I $E(DAY(DAY,"P"),M)'=$E(DAY(DAY,"P"),J) S Q=1 Q 157 . . ; grant ND (unless meal-time, etc.), keep count of leave since it 158 . . ; may need to be backed out by PRS8MSC0 159 . . I AV[$E(D,J) D 160 . . . S X=10 161 . . . ; For 36/46 AWS nurses ND for Holiday Worked (HA/HL) and normal 162 . . . ; tour time will be reported as Night Differential-AWS (ND/NU) 163 . . . I +NAWS=36 D 164 . . . . I $E(DAY(DAY,"HOL"),J)=2 S X=51 Q ; Holiday Worked 165 . . . . I "OEc"'[VAL S X=51 ; Tour time 166 . . . D SET 167 . . . S:"LSRUFGD"[$E(D,J) WKL(WK)=WKL(WK)+1 168 ; 169 Q 170 ; 171 SETJ ; --- set week node (J variable defined) 172 Q:$E(D,J)="m" 173 ; 174 SET ; --- actually set the piece 175 S $P(WK(WK),"^",X)=$P(WK(WK),"^",X)+1 176 Q 177 ; 178 NOTND(PRSTY,PRSDY,PRSTM) ; Not Eligible Night Differential 179 ; in PRSTY type of employee 180 ; PRSDY day (1-14) 181 ; PRSTM time segment (1-96) 182 ; returns 0 or 1 (True when not eligible for ND) 183 ; 184 N VAL 185 S VAL=$E(DAY(PRSDY,"W"),PRSTM) 186 ; 187 ; not entitled to ND 188 I ($E(DAY(PRSDY,"P"),PRSTM)=5) Q 1 189 ; 190 ; OT on non-premium T&L 191 I "EOosecb"[VAL,$E(DAY(PRSDY,"P"),PRSTM),VAL'="O"!(VAL="O"&($E(DAY(PRSDY,"HOL"),PRSTM)'=2)) Q 1 192 ; 193 ; Nurses do not get ND for OT that is not for ND Tour Coverage 194 I "Ecb"[VAL!(VAL="O"&'$E(DAY(PRSDY,"HOL"),PRSTM)),PRSTY["N"!(PRSTY["H")!(HYBRID)!("^S^T^U^V^"[(U_PMP_U)),$E(DAY(PRSDY,"P"),PRSTM)'="N" Q 1 195 ; 196 ; Baylor gets no ND for work time on regularly scheduled day 197 I TYP["B","^1^7^8^14^"[("^"_DAY_"^"),"1234ALSRMUNVXYFGD"[VAL Q 1 198 ; 199 ; GS Employees do not get ND for OT that is not Pre-Scheduled 200 I "Ecb"[VAL!(VAL="O"&'$E(DAY(PRSDY,"HOL"),PRSTM)),PRSTY'["N",PRSTY'["H",'HYBRID,("^S^T^U^V^"'[(U_PMP_U)),$E(DAY(PRSDY,"P"),PRSTM)'="n" Q 1 201 ; 202 ; Unsch Reg time needs to be Pre-scheduled to get ND 203 I VAL=4,PRSTY["P"!(PRSTY["I"&(PRSTY["N"!(PRSTY["H"))),"Nn"'[$E(DAY(PRSDY,"P"),PRSTM) Q 1 204 Q 0 ; did not fail any of the checks 1 PRS8PP ;HISC/MRL,WIRMFO/MGD-DECOMP, PREMIUM PAYS ;02/27/04 2 ;;4.0;PAID;**22,40,75,92,96**;Sep 21, 1995 3 ; 4 ;This routine is the entry point for determining certain premium 5 ;pays for an employee. Included are overtime (OT), 6 ;night differential (ND), unscheduled hours (UH), etc. 7 ; 8 ;Called by Routines: PRS8ST 9 ; 10 S D=DAY(DAY,"W") ; Daily activity string. 11 S W=$S(DAY<8:1,1:2) ; Week. 12 I D?1"0"."0" Q ; No activity this date. 13 S NDC=1,(HT,HTP,HTFFOT)=0 ; Counter for hrs worked this 14 ; day (HT=Hours total). 15 N HYBRID ; HYBRID under P.L 107-135 16 S HYBRID=$$HYBRID^PRSAENT1($G(DFN)) 17 D ^PRS8HR ; calculate Norm hrs first 18 F M=1:1:96 S VAL=$E(D,M) I VAL'=0 D ;loop thru minutes of day 19 .S DH=DAY(DAY,"DH1") 20 .I TWO,M'<+$P(DAY(DAY,"TWO"),"^",2) S DH=DAY(DAY,"DH2") ; Daily hrs. 21 .I NDC,"CWB"'[VAL D ND ; Get ND. 22 .I TYP["B",+VAL Q ; Baylor get no premium during tod. 23 .I "1234OosEe"'[VAL Q ; Don't chk for non-work status. 24 .S X=$E(D,M,96) ; Remainder of day. 25 .I X?1N.N,X'[4 Q ; No hrs left other than normal. 26 .I "J123MLSWNARXYOFGD"'[VAL!(VAL="O"&($E(DAY(DAY,"HOL"),M)'=2)) S AV="OosEe" D CALC^PRS8HR 27 K AV,D,GO,M,NDC,X,X1,J1,J2 Q 28 ; 29 ND ; --- compute ND 30 ; Process wagegrade 31 I TYP["W" D Q 32 . ; process WG scheduled time 33 . I "J23LSARMXYUVFGD"[VAL!(VAL="O"&($E(DAY(DAY,"HOL"),M)=2)) D 34 . . N DAT,DAYN,FND,M1,NODE,SC,TS 35 . . ; find tour segment that contains the time and get it's special code 36 . . S FND=0,SC="" ; FND true if found in schedule, SC = special code 37 . . ; look in schedule of current day for M and previous day for M+96 38 . . ; (in 2day tour, previous day's schedules >96 are Today's activity) 39 . . F DAYN=DAY,DAY-1 D Q:FND 40 . . . S M1=$S(DAYN=DAY:M,1:M+96) 41 . . . ; loop thru both tours in day 42 . . . F NODE=1,4 S DAT=$G(^TMP($J,"PRS8",DAYN,NODE)) Q:DAT="" D Q:FND 43 . . . . ; loop thru tour segments in tour 44 . . . . F TS=1:1:7 Q:$P(DAT,U,(TS-1)*3+1)="" D Q:FND 45 . . . . . ; check if time contained in tour segment 46 . . . . . I M1'<$P(DAT,U,(TS-1)*3+1),M1'>$P(DAT,U,(TS-1)*3+2) S FND=1,SC=$P(DAT,U,(TS-1)*3+3) 47 . . ; 48 . . ; if time not found in any schedule, base SC on value of variable 49 . . ; TOUR for Today (or previous day when no scheduled tour Today). 50 . . I 'FND S SC=$S($G(^TMP($J,"PRS8",DAY,1))=""&(DAY(DAY-1,"TOUR")>1):DAY(DAY-1,"TOUR")+4,1:TOUR+4) 51 . . Q:"^6^7^"'[(U_SC_U) ; tour segment not coded for shift 2 or 3 52 . . S X=(SC-4)+8 ; determine where to store in WK array 53 . . I $E(ENT,X-4) D SET ; if employee entitled then store result 54 . ; 55 . ; process WG unscheduled time 56 . I VAL=4!(VAL="O") D 57 . . N T,SD 58 . . ; unscheduled regular tours for 'shift coverage' that are eligible 59 . . ; for shift 2 or 3 differential were saved in "SD" by PRS8EX. 60 . . S SD=$G(^TMP($J,"PRS8",DAY,"SD")) 61 . . Q:SD="" 62 . . ; see if time belongs to a tour saved in "SD" and if so use the 63 . . ; associated shift (2 or 3) 64 . . S SD(1)=0 ; init shift 65 . . F T=1:3 S SD(0)=$P(SD,U,T,T+2) Q:SD(0)=""!(SD(0)?1."^") D Q:SD(1) 66 . . . I M'<+SD(0),M'>$P(SD(0),"^",2) S SD(1)=$P(SD(0),"^",3) 67 . . I SD(1) S X=SD(1)+8 I $E(ENT,X-4) D SET 68 ; 69 ; Process Other Employees (non-Wage Grade) 70 ; 71 ; Not entitled to ND 72 I '$E(ENT,6) Q 73 ; 74 ; not entitled to ND if No Premium Pay tour 75 I $P(DAY(DAY,1),"^",3)=8 Q 76 ; 77 ; check if time segment could be eligible for ND 78 I $$NOTND(TYP,DAY,M) Q 79 ; 80 S AV="J1234ALSRMUEOosecbVXYFGD" 81 ; 82 ; Grant ND for time before 6a/after 6p or anytime when nurse/hybrid 83 ; works tour coverage 84 I M<25!(M>72)!($E(DAY(DAY,"P"),M)="N"&(TYP["N"!(TYP["H")!(HYBRID))),AV[VAL D 85 . ; The Hybrids defined in Public Law 107-135 will only receive Night 86 . ; Differential time for OT and CT worked between 6 p.m. and 6 a.m. 87 . Q:HYBRID!(PMP'=""&("^S^T^U^V^"[(U_PMP_U)))&(M'<25&(M'>72)) 88 . ; Tour time between 6 p.m. and 6 a.m. counts toward ND 89 . N DAT,DAYN,FND,M1,NODE,SC,TS,TOT 90 . ; find tour segment that contains the time and get it's special code 91 . S FND=0,SC="" ; FND true if found in schedule, SC = special code 92 . S TOT="" ; Type Of Time 93 . ; look in schedule of current day for M and previous day for M+96 94 . ; (in 2day tour, previous day's schedules >96 are Today's activity) 95 . F DAYN=DAY,DAY-1 D Q:FND 96 . . S M1=$S(DAYN=DAY:M,1:M+96) 97 . . S DAT=$G(^TMP($J,"PRS8",DAYN,2)) D Q:FND 98 . . . ; loop thru tour segments in exceptions 99 . . . F TS=1:1:7 Q:$P(DAT,U,(TS-1)*3+1)="" D Q:FND 100 . . . . ; check if time contained in exception segment 101 . . . . I M1'<$P(DAT,U,(TS-1)*3+1),M1'>$P(DAT,U,(TS-1)*3+2) D 102 . . . . . S FND=1,TOT=$P(DAT,U,(TS-1)*3+3),SC=$P(DAT,U,(TS-1)*3+4) 103 . Q:TOT="OT"&("^11^12^"'[(U_SC_U)) ; Pre-Scheduled & Tour Coverage 104 . Q:TOT="CT"&(SC'=12) ; Tour Coverage 105 . Q:TOT="RG"&(SC'=7) ; Shift Coverage 106 . S X=10 D SET 107 . ; keep leave count since it may need to be backed out by PRS8MSC0 108 . I "LSRUFGD"[VAL S WKL(WK)=WKL(WK)+1 109 ; 110 ; Nurse can get ND for 6a-6p time when part of tour with 4+ hrs in 6p-6a 111 ; check is made when M=24 (just before 6am) or M=73 (just after 6pm). 112 ; if tour eligible (4+ hours in 'night' time) then ND is granted for 113 ; the portion of the tour that falls within the 'day' time. 114 I TYP["N"!(TYP["H"),M=73!(M=24),AV_"m"[VAL D 115 . N C,J,Q,X,X1,X2,XD 116 . ; 117 . ; quit if 'day' time is for tour coverage since already counted 118 . I $E(DAY(DAY,"P"),$S(M=73:72,1:25))="N" Q 119 . ; 120 . ; first check if tour has at least 4 hours of 'night' (6pm-6am) time 121 . S XD=$S(M=24:-1,1:1) ; loop direction, [6am back, 6pm forward] 122 . S X1=M,X2=X1+(XD*15) ; start and stop of 4 hour range 123 . ; loop thru tour 'night' time - stop if tour ends or after 4 hours 124 . S C=1 ; init flag, false when tour has less than 4 hours of 'night' 125 . F J=X1:XD:X2 D Q:'C 126 . . I AV_"m"'[$E(D,J) S C=0 Q ; inappropriate type of time 127 . . I $$NOTND(TYP,DAY,J) S C=0 Q 128 . . ; scheduled TOD considered as separate from covered TOD 129 . . I $E(DAY(DAY,"P"),M)'=$E(DAY(DAY,"P"),J) S C=0 Q 130 . ; 131 . Q:'C ; tour not eligible (less than 4 hours of 'night') 132 . ; 133 . ; loop thru day time (6am-6pm) portion of tour and grant ND 134 . ; don't pay ND for meal-time (m) but continue loop 135 . S XD=$S(M=24:1,1:-1) ; loop direction [6am forward, 6pm back] 136 . S X1=M+XD,X2=X1+(47*XD) ; start and stop for day time (12 hours) 137 . S Q=0 ; init flag, true when end of tour reached 138 . F J=X1:XD:X2 D Q:Q 139 . . I AV_"m"'[$E(D,J) S Q=1 Q ; inappropriate time 140 . . I $$NOTND(TYP,DAY,J) S Q=1 Q 141 . . ; scheduled TOD considered as separate from covered TOD 142 . . I $E(DAY(DAY,"P"),M)'=$E(DAY(DAY,"P"),J) S Q=1 Q 143 . . ; grant ND (unless meal-time, etc.), keep count of leave since it 144 . . ; may need to be backed out by PRS8MSC0 145 . . I AV[$E(D,J) S X=10 D SET S:"LSRUFGD"[$E(D,J) WKL(WK)=WKL(WK)+1 146 ; 147 Q 148 ; 149 SETJ ; --- set week node (J variable defined) 150 Q:$E(D,J)="m" 151 ; 152 SET ; --- actually set the piece 153 S $P(WK(WK),"^",X)=$P(WK(WK),"^",X)+1 154 Q 155 ; 156 NOTND(PRSTY,PRSDY,PRSTM) ; Not Eligible Night Differential 157 ; in PRSTY type of employee 158 ; PRSDY day (1-14) 159 ; PRSTM time segment (1-96) 160 ; returns 0 or 1 (True when not eligible for ND) 161 ; 162 N VAL 163 S VAL=$E(DAY(PRSDY,"W"),PRSTM) 164 ; 165 ; not entitled to ND 166 I ($E(DAY(PRSDY,"P"),PRSTM)=5) Q 1 167 ; 168 ; OT on non-premium T&L 169 I "EOosecb"[VAL,$E(DAY(PRSDY,"P"),PRSTM),VAL'="O"!(VAL="O"&($E(DAY(PRSDY,"HOL"),PRSTM)'=2)) Q 1 170 ; 171 ; Nurses do not get ND for OT that is not for ND Tour Coverage 172 I "Ecb"[VAL!(VAL="O"&'$E(DAY(PRSDY,"HOL"),PRSTM)),PRSTY["N"!(PRSTY["H")!(HYBRID)!("^S^T^U^V^"[(U_PMP_U)),$E(DAY(PRSDY,"P"),PRSTM)'="N" Q 1 173 ; 174 ; Baylor gets no ND for work time on regularly scheduled day 175 I TYP["B","^1^7^8^14^"[("^"_DAY_"^"),"1234ALSRMUNVXYFGD"[VAL Q 1 176 ; 177 ; GS Employees do not get ND for OT that is not Pre-Scheduled 178 I "Ecb"[VAL!(VAL="O"&'$E(DAY(PRSDY,"HOL"),PRSTM)),PRSTY'["N",PRSTY'["H",'HYBRID,("^S^T^U^V^"'[(U_PMP_U)),$E(DAY(PRSDY,"P"),PRSTM)'="n" Q 1 179 ; 180 ; Unsch Reg time needs to be Pre-scheduled to get ND 181 I VAL=4,PRSTY["P"!(PRSTY["I"&(PRSTY["N"!(PRSTY["H"))),"Nn"'[$E(DAY(PRSDY,"P"),PRSTM) Q 1 182 Q 0 ; did not fail any of the checks -
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 -
WorldVistAEHR/trunk/r/PAID-PRS/PRS8SU.m
r613 r623 1 PRS8SU ;HISC/MRL-DECOMPOSITION, SET-UP ;02/20/08 2 ;;4.0;PAID;**112,116**;Sep 21, 1995;Build 23 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;This routine sets up various data elements required to process 6 ;a decomp. The ^TMP array is built for each day of the 7 ;pay period (1-14) and includes tour information, exceptions, 8 ;holiday information, etc. All times are converted to 15-minute 9 ;increments in this routine (the number of 15-minute increments 10 ;into the day). Additionally, the credit tour for WG 11 ;employees is determined in this routine. 12 ; 13 ;Called by Routines: PRS8DR 14 ; 15 K ^TMP($J,"PRS8") 16 K D,DAY F DAY=0:1:15 D 17 .I 'CYA,DAY>1,DAY<15,$E($P(PPD,"^",DAY),4,7)="0101" S CYA=DAY 18 .S P=0 I 'DAY S P=+PPD(0),D=14 ;last day of previous pp 19 .I DAY=15 S P=+PPD(15),D=1 ;first day of next pp 20 .I P S ZZ=$S(D=14:0,1:15) 21 .I 'P S P=+PY,(ZZ,D)=+DAY 22 .S W=$S(D<8:1,1:2) K DADRFM S DADRFM=1 23 .S TWO=0 F N=0,1,4,2,10 S Z=$G(^PRST(458,+P,"E",+DFN,"D",+D,N)) D 24 ..S (N14,NDAY,LAST,QT)=0,D(N)=Z,N1=$S(N=2:4,1:3) 25 ..I N=0,$S(ZZ<15:1,1:0) F J=2,13 I +$P(D(0),"^",J) D 26 ...S X=+$P(D(0),"^",$S(J=2:8,1:14)) Q:'X ;normal hours 27 ...I DAY'=0 S X=X\.25 S NH(W)=NH(W)+X ;increment NH 28 ...S Z1=Z,Z=X,D1=D,X="DH"_$S(J=2:1,1:2) D SET S Z=Z1 ;save NH 29 ...S X=+$P(D(0),"^",J) 30 ...S X=+$P($G(^PRST(457.1,+X,0)),"^",3) Q:'X ;mltime 31 ...S X=X\15,MT($S(J=2:1,1:2))=X ;save mltime 32 ...I X S X1=Z,Z=X,D1=D,X="MT"_$S(J=2:1,1:2) D SET S Z=X1 33 ..I "^1^2^4^"[("^"_N_"^") F K=1:N1 S V=$P(Z,"^",K,K+1) Q:QT D 34 ...S X=$P(Z,U,K,999) S:X?1"^"."^"!(X="")!(N14=1) QT=1 I QT!($P(Z,U,K)="") Q 35 ...S:K=1 (NDAY,LAST)=0 F K1=1,2 S X=$P(V,"^",K1),(Y,Y1)=K1-1 I X'="" D 36 ....S FLAG=1 I N=2&(K1=1)&("^HW^"[("^"_$P(Z,"^",K+2)_"^")) S FLAG=$S(NDAY=1!(LAST>96)&("^HW^"[("^"_$P(Z,"^",K+2)_"^"))&((X["A")!(X["MID")):0,1:1),NDAY=0 37 ....S:$P(D(0),"^",14)'=""&(X="MID")&(LAST=96)&(N=2)&(K1=1) FLAG=0 S:N=2&(K1=1)&(FLAG=1) (NDAY,LAST)=0 S Y=K1-1 D 15 38 ....I N=2,"^RG^OT^CT^ON^SB^"'[("^"_$P(Z,"^",K+2)_"^") D 39 .....S Y=+$O(DADRFM("S",(-X-.01))),Y1=+$O(DADRFM("F",(X-.01))) 40 .....I $G(DADRFM("S",Y))'=$G(DADRFM("F",Y1)) S X=X+96 41 .....Q 42 ....S $P(Z,"^",K+(K1-1))=X ;15-minute conversion 43 ....I K1=1,N=1!(N=4) S DADRFM("S",-X)=DADRFM 44 ....I K1=2,N=1!(N=4) S DADRFM("F",X)=DADRFM,DADRFM=DADRFM+1 45 ....I K1=2,X>96,N'=2 S Y=$P(Z,"^",(K+K1)) I Y=""!("12345"'[Y) S X=X-96 D 46 .....I "^0^7^14^"'[("^"_+ZZ_"^") Q 47 .....I $G(^TMP($J,"PRS8",DAY,"MT1"))>1 S X=X-$G(^TMP($J,"PRS8",DAY,"MT1")) 48 .....I ZZ=0!(ZZ=7) S NH($S('ZZ:1,1:2))=NH($S('ZZ:1,1:2))+X 49 .....Q:'ZZ ;already moved previous time to this pp 50 .....S NH($S(D=7:1,1:2))=NH($S(D=7:1,1:2))-X 51 .....Q 52 ....Q 53 ...I N=4,Z?1AN.E!(Z?1"^".AN) D ;2-tour day 54 ....I +D(1)'>+Z S TWO=1_"^"_+Z ;early tour first 55 ....E S TWO=2_"^"_+D(1) ;late tour first 56 ....Q:+TWO=1 ;we're gonna switch 1&4 nodes if necessary now 57 ....S X1=^TMP($J,"PRS8",DAY,1),D1=D,X=1,D(1)=Z D SET ;move 4 node to 1 58 ....S Z=X1,N14=1 K X,X1 ;this will move 1 node to 4 59 ..S D(N)=Z,D1=D,X=N D SET 60 .K DADRFM,MT1,MT2 61 .S Z=TWO,D1=D,X="TWO" D SET 62 .S Z="",$P(Z,"0",97)="",D1=D,X="W" D SET ;activity string 63 .S X="HOL" D SET ;save holiday string 64 .S X="P" D SET ;premium node 65 .S X="r" D SET ;Recess node 66 .S X=D(0),OFF=0 I $P(X,"^",2)=1 S OFF=1 ;day off 67 .S Z=OFF,X="OFF" D SET 68 .I +TWO=2 S MT2=$G(^TMP($J,"PRS8",D1,"MT2")),MT1=$G(^TMP($J,"PRS8",D1,"MT1")),^TMP($J,"PRS8",D1,"MT2")=MT1,^TMP($J,"PRS8",D1,"MT1")=MT2 69 .I TYP["W" D ; -- compute credit tour for WG 70 ..S X=D(0) I DAY=0 S (L,T)=0 71 ..I $P(X,"^",3) S X=$G(^PRST(457.1,+$P(X,"^",4),1)) ;temp tour 72 ..E S X=D(1) ;not temporary 73 ..S S=0 F J=1,4 Q:D(J)="" F I=3:3:28 Q:S!($P(D(J),"^",(I-2))="") D 74 ...I "^6^7^"[("^"_+$P(D(J),"^",I)_"^") S S=+$P(D(J),"^",I)-4 75 ..I 'OFF S:'S S=1 S:(DAY>0)&(DAY<15) L=S ;credit tour 76 ..I DAY>0,DAY<15 D 77 ...I 'T S T=+S 78 ...I S S T=S ;T=credit tour on days off 79 ..S Z=S S:TYP'["W"&(Z>1) Z=1 S D1=DAY,X="TOUR" D SET 80 ..I DAY=7!(DAY=14) S TOUR((DAY\7))=$S(T:T,1:1),T=0 ;save tour 81 I TYP["B" S NH=320,(NH(1),NH(2))=160,TH=192,(TH(1),TH(2))=96 ; Baylor NH=40 hrs to mimic full time, TH = 24 hrs for reality 82 E S TH=NH,TH(1)=NH(1),TH(2)=NH(2) ;total hrs for pp 83 ; 84 ; Update NH for the nurses on the 36/40 AWS 85 I "KM"[$E(AC,1),$E(AC,2)=1,NH=288 S NH=320,(NH(1),NH(2))=160,TH=320,(TH(1),TH(2))=160 86 ; 87 I TYP["W",L>1 S $P(WK(3),"^",3)=L ;last tour (IN) in misc for WG 88 S VALOLD=$G(^PRST(458,+PY,"E",+DFN,5)) ;existing decomp 89 K D,D1,DAY,NDAY,FLAG,J,K,K1,L,LAST,MT,N,N1,N14,P,QT,T,V,W,X,Y,Y1,Z 90 G ^PRS8ST ;start decomp 91 ; 92 15 ; --- convert time to 15-minute increments 93 ; 94 ; Need to conditionally set Y $S(Y=0 mid=00:00, y=1: mid=24:00) 95 ; based on whether exception is within or outside the tour. 96 D MIL^PRSATIM ;convert to military (24hr) time 97 I +Y<1000 S Y=$E("0000",0,4-$L(Y))_Y 98 S X=(+$E(Y,1,2)*4)+($E(Y,3,4)\15) 99 I 'Y1 S X=X+1 ; Add 15 minutes to start time 100 I X<LAST S X=X+96,NDAY=1 ;new day 101 S LAST=X Q 102 ; 103 SET ; --- save value (Z) in ^TMP($J,"PRS8",DAY,X) 104 ; 105 S D1=+ZZ 106 S ^TMP($J,"PRS8",D1,X)=Z Q 107 ; 108 TAL ; --- T&L Unit (whole zeroth node) 109 ; 110 S X=$O(^PRST(455.5,"B",X,0)) 111 S X=$G(^PRST(455.5,+X,0)) I $E(X)="" S X="" 1 PRS8SU ;HISC/MRL-DECOMPOSITION, SET-UP ;7/15/93 10:40 2 ;;4.0;PAID;;Sep 21, 1995 3 ; 4 ;This routine sets up various data elements required to process 5 ;a decomp. The ^TMP array is built for each day of the 6 ;pay period (1-14) and includes tour information, exceptions, 7 ;holiday information, etc. All times are converted to 15-minute 8 ;increments in this routine (the number of 15-minute increments 9 ;into the day). Additionally, the credity tour for WG 10 ;employees is determined in this routine. 11 ; 12 ;Called by Routines: PRS8DR 13 ; 14 K ^TMP($J,"PRS8") 15 K D,DAY F DAY=0:1:15 D 16 .I 'CYA,DAY>1,DAY<15,$E($P(PPD,"^",DAY),4,7)="0101" S CYA=DAY 17 .S P=0 I 'DAY S P=+PPD(0),D=14 ;last day of previous pp 18 .I DAY=15 S P=+PPD(15),D=1 ;first day of next pp 19 .I P S ZZ=$S(D=14:0,1:15) 20 .I 'P S P=+PY,(ZZ,D)=+DAY 21 .S W=$S(D<8:1,1:2) K DADRFM S DADRFM=1 22 .S TWO=0 F N=0,1,4,2,10 S Z=$G(^PRST(458,+P,"E",+DFN,"D",+D,N)) D 23 ..S (N14,NDAY,LAST,QT)=0,D(N)=Z,N1=$S(N=2:4,1:3) 24 ..I N=0,$S(ZZ<15:1,1:0) F J=2,13 I +$P(D(0),"^",J) D 25 ...S X=+$P(D(0),"^",$S(J=2:8,1:14)) Q:'X ;normal hours 26 ...I DAY'=0 S X=X\.25 S NH(W)=NH(W)+X ;increment NH 27 ...S Z1=Z,Z=X,D1=D,X="DH"_$S(J=2:1,1:2) D SET S Z=Z1 ;save NH 28 ...S X=+$P(D(0),"^",J) 29 ...S X=+$P($G(^PRST(457.1,+X,0)),"^",3) Q:'X ;mltime 30 ...S X=X\15,MT($S(J=2:1,1:2))=X ;save mltime 31 ...I X S X1=Z,Z=X,D1=D,X="MT"_$S(J=2:1,1:2) D SET S Z=X1 32 ..I "^1^2^4^"[("^"_N_"^") F K=1:N1 S V=$P(Z,"^",K,K+1) Q:QT D 33 ...S X=$P(Z,U,K,999) S:X?1"^"."^"!(X="")!(N14=1) QT=1 I QT!($P(Z,U,K)="") Q 34 ...S:K=1 (NDAY,LAST)=0 F K1=1,2 S X=$P(V,"^",K1),(Y,Y1)=K1-1 I X'="" D 35 ....S FLAG=1 I N=2&(K1=1)&("^HW^"[("^"_$P(Z,"^",K+2)_"^")) S FLAG=$S(NDAY=1!(LAST>96)&("^HW^"[("^"_$P(Z,"^",K+2)_"^"))&((X["A")!(X["MID")):0,1:1),NDAY=0 36 ....S:$P(D(0),"^",14)'=""&(X="MID")&(LAST=96)&(N=2)&(K1=1) FLAG=0 S:N=2&(K1=1)&(FLAG=1) (NDAY,LAST)=0 S Y=K1-1 D 15 37 ....I N=2,"^RG^OT^CT^ON^SB^HW^"'[("^"_$P(Z,"^",K+2)_"^") D 38 .....S Y=+$O(DADRFM("S",(-X-.01))),Y1=+$O(DADRFM("F",(X-.01))) 39 .....I $G(DADRFM("S",Y))'=$G(DADRFM("F",Y1)) S X=X+96 40 .....Q 41 ....S $P(Z,"^",K+(K1-1))=X ;15-minute conversion 42 ....I K1=1,N=1!(N=4) S DADRFM("S",-X)=DADRFM 43 ....I K1=2,N=1!(N=4) S DADRFM("F",X)=DADRFM,DADRFM=DADRFM+1 44 ....I K1=2,X>96,N'=2 S Y=$P(Z,"^",(K+K1)) I Y=""!("12345"'[Y) S X=X-96 D 45 .....I "^0^7^14^"'[("^"_+ZZ_"^") Q 46 .....I $G(^TMP($J,"PRS8",DAY,"MT1"))>1 S X=X-$G(^TMP($J,"PRS8",DAY,"MT1")) 47 .....I ZZ=0!(ZZ=7) S NH($S('ZZ:1,1:2))=NH($S('ZZ:1,1:2))+X 48 .....Q:'ZZ ;already moved previous time to this pp 49 .....S NH($S(D=7:1,1:2))=NH($S(D=7:1,1:2))-X 50 .....Q 51 ....Q 52 ...I N=4,Z?1AN.E!(Z?1"^".AN) D ;2-tour day 53 ....I +D(1)'>+Z S TWO=1_"^"_+Z ;early tour first 54 ....E S TWO=2_"^"_+D(1) ;late tour first 55 ....Q:+TWO=1 ;we're gonna switch 1&4 nodes if necessary now 56 ....S X1=^TMP($J,"PRS8",DAY,1),D1=D,X=1,D(1)=Z D SET ;move 4 node to 1 57 ....S Z=X1,N14=1 K X,X1 ;this will move 1 node to 4 58 ..S D(N)=Z,D1=D,X=N D SET 59 .K DADRFM,MT1,MT2 60 .S Z=TWO,D1=D,X="TWO" D SET 61 .S Z="",$P(Z,"0",97)="",D1=D,X="W" D SET ;activity string 62 .S X="HOL" D SET ;save holiday string 63 .S X="P" D SET ;premium node 64 .S X=D(0),OFF=0 I $P(X,"^",2)=1 S OFF=1 ;day off 65 .S Z=OFF,X="OFF" D SET 66 .I +TWO=2 S MT2=$G(^TMP($J,"PRS8",D1,"MT2")),MT1=$G(^TMP($J,"PRS8",D1,"MT1")),^TMP($J,"PRS8",D1,"MT2")=MT1,^TMP($J,"PRS8",D1,"MT1")=MT2 67 .I TYP["W" D ; -- compute credit tour for WG 68 ..S X=D(0) I DAY=0 S (L,T)=0 69 ..I $P(X,"^",3) S X=$G(^PRST(457.1,+$P(X,"^",4),1)) ;temp tour 70 ..E S X=D(1) ;not temporary 71 ..S S=0 F J=1,4 Q:D(J)="" F I=3:3:28 Q:S!($P(D(J),"^",(I-2))="") D 72 ...I "^6^7^"[("^"_+$P(D(J),"^",I)_"^") S S=+$P(D(J),"^",I)-4 73 ..I 'OFF S:'S S=1 S:(DAY>0)&(DAY<15) L=S ;credit tour 74 ..I DAY>0,DAY<15 D 75 ...I 'T S T=+S 76 ...I S S T=S ;T=credit tour on days off 77 ..S Z=S S:TYP'["W"&(Z>1) Z=1 S D1=DAY,X="TOUR" D SET 78 ..I DAY=7!(DAY=14) S TOUR((DAY\7))=$S(T:T,1:1),T=0 ;save tour 79 I TYP["B" S NH=320,(NH(1),NH(2))=160,TH=192,(TH(1),TH(2))=96 ; Baylor NH=40 hrs to mimic full time, TH = 24 hrs for reality 80 E S TH=NH,TH(1)=NH(1),TH(2)=NH(2) ;total hrs for pp 81 I TYP["W",L>1 S $P(WK(3),"^",3)=L ;last tour (IN) in misc for WG 82 S VALOLD=$G(^PRST(458,+PY,"E",+DFN,5)) ;existing decomp 83 K D,D1,DAY,NDAY,FLAG,J,K,K1,L,LAST,MT,N,N1,N14,P,QT,T,V,W,X,Y,Y1,Z 84 G ^PRS8ST ;start decomp 85 ; 86 15 ; --- convert time to 15-minute increments 87 ; 88 ; Need to conditionally set Y $S(Y=0 mid=00:00, y=1: mid=24:00) 89 ; based on whether exception is within or outsided tour. 90 D MIL^PRSATIM ;convert to military (24hr) time 91 I +Y<1000 S Y=$E("0000",0,4-$L(Y))_Y 92 S X=(+$E(Y,1,2)*4)+($E(Y,3,4)\15) 93 I 'Y1 S X=X+1 ; Add 15 minutes to start time 94 I X<LAST S X=X+96,NDAY=1 ;new day 95 S LAST=X Q 96 ; 97 SET ; --- save value (Z) in ^TMP($J,"PRS8",DAY,X) 98 ; 99 S D1=+ZZ 100 S ^TMP($J,"PRS8",D1,X)=Z Q 101 ; 102 TAL ; --- T&L Unit (whole zeroth node) 103 ; 104 S X=$O(^PRST(455.5,"B",X,0)) 105 S X=$G(^PRST(455.5,+X,0)) I $E(X)="" S X="" -
WorldVistAEHR/trunk/r/PAID-PRS/PRS8VW.m
r613 r623 1 PRS8VW ;HISC/MRL-DECOMPOSITION, VIEW RESULTS ;03/22/07 2 ;;4.0;PAID;**2,6,27,45,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;This routine is used to view the results of the decomposition. 6 ;The variables VAL and VALOLD must be passed. VAL is the current 7 ;decomposition string. VALOLD, which may be null, is the results 8 ;of a previous decomposition run (what's in the 5 node of file 458 9 ;prior to running decomposition). 10 ; 11 ;Called by Routines: PRS8, PRS8DR 12 S (NEW,VAL)=$G(VAL),(OLD,VALOLD)=$G(VALOLD) 13 N DASH1,DASH2 14 S $P(DASH1,"-",79)="-",$P(DASH2,"=",79)="=" 15 I +$E(NEW,2,4) S NEW=$E(VAL,33,999) ; 33rd position because CP field 16 I +$E(OLD,2,4) S OLD=$E(VALOLD,33,999) ;is added(either "C","F"or" ") 17 D E 18 W @IOF 19 I "C"'[$E(IOST) D 20 .S X="Decomposition of Time" W ?(80-$L(X)/2),X,! 21 .D NOW^%DTC S Y=% X ^DD("DD") 22 .S X=$G(^VA(200,+$G(DUZ),0)),TR="User: "_$S($P(X,"^",1)'="":$P(X,"^",1),1:"Unknown") 23 .S TR=TR_" " 24 .S X="Run Date: "_Y,TR=$E(TR,1,(79-$L(X)))_X 25 S X=$P(C0,"^",1)_" [SSN: "_$P(C0,"^",9)_"]" W !,X 26 S X="Pay Period: "_(^PRST(458,+PY,0)) W ?(79-$L(X)),$P(X,"^",1) 27 D CTID 28 W !,DASH2 29 W !,"Loc.",?10,"Data Element",?44,"Code",?52,"Old Value",?67,"New Value" 30 W !,"----",?10,"------------",?44,"----",?52,"---------",?67,"---------" 31 K I,L,X,USED 32 D ^PRS8VW1 33 D STUB 34 I "C"'[$E(IOST) D 35 .W !,DASH1 36 .W !,TR 37 D ONE^PRS8CV,^%ZISC Q 38 ; 39 CERT ; entry point to show supervisor result of decomp before certifying 40 N DASH1,DASH2 41 S $P(DASH1,"-",79)="-",$P(DASH2,"=",79)="=" 42 S (NEW,VAL)=$G(VAL) 43 I +$E(NEW,2,4) S NEW=$E(VAL,33,999) ;because CP field is added to STUB 44 D E2 45 W @IOF 46 I "C"'[$E(IOST) D 47 .S X="Decomposition of Time" W ?(80-$L(X)/2),X,! 48 .D NOW^%DTC S Y=% X ^DD("DD") 49 .S X=$G(^VA(200,+$G(DUZ),0)),TR="User: "_$S($P(X,"^",1)'="":$P(X,"^",1),1:"Unknown") 50 .S TR=TR_" " 51 .S X="Run Date: "_Y,TR=$E(TR,1,(79-$L(X)))_X 52 S H="PAY PERIOD SUMMARY" W !,$J(H,40+($L(H)/2)),! 53 S X=$P(C0,"^",1)_" [SSN: "_$E($P(C0,"^",9))_"XXXX"_$E($P(C0,"^",9),6,9)_"]" W !,X 54 S X="Pay Period: "_(^PRST(458,+PY,0)) W ?(79-$L(X)),$P(X,"^",1) 55 D CTID 56 W !,DASH2 57 W ! 58 K I,L,X,USED 59 D ^PRS8VW2 60 I "C"'[$E(IOST) D 61 .W !,DASH1 62 .W !,TR 63 K H,R,Z Q 64 E2 ; --- create E array 65 S E(1)="ANSKWDNOAURTCECUUNNANBSPSASBSCDADBDCTFOAOBOCYAOKOMRARBRCHAHBHCPTPAONYDHDVCEAEBTATCFAFCADNTRSSRSDND" 66 S E(2)="ALSLWPNPABRLCTCOUSNRNSSQSESFSGDEDFDGTGOEOFOGYEOSOURERFRGHLHMHNPHPBCLYHHOVSECEDTBTDFBFDAFNHRNSSSHNU" 67 S E(3)="NLDWMLCAPCCYFE" Q 68 STUB ; --- show stub record 69 S X1=$G(HDR),X2=$E(VAL,1,32) 70 I X1="" S X1=$E(VALOLD,1,32) 71 I X1="" S X1=X2 72 I $L(X1)<$L(X2) S X1=X2 73 W !!,"STUB RECORD >>>>> ",$S(X1'="":X1,1:"Not Available At this Time...") Q 74 ; 75 E ; --- create E array 76 S E(1)="ANSKWDNOAURTCECUUNNANBSPSASBSCDADBDCTFOAOBOCYAOKOMRARBRCHAHBHCPTPAONYDHDVCEAEBTATCFAFCADNTRSSRSDND" 77 S E(2)="ALSLWPNPABRLCTCOUSNRNSSQSESFSGDEDFDGTGOEOFOGYEOSOURERFRGHLHMHNPHPBCLYHHOVSECEDTBTDFBFDAFNHRNSSSHNU" 78 S E(3)="NLDWINTLLULNLDDTTOLAMLCAPCCYRRFFFECD" Q 79 CTID ; compressed tour indicator display 80 ; in - PY (pay period ien), DFN (employee ien) 81 N FLX,FLXP 82 S FLX=$P($G(^PRST(458,+PY,"E",DFN,0)),U,6) ; for current pay period 83 S FLXP=$P($G(^PRST(458,+PY-1,"E",DFN,0)),U,6) ; for previous pay period 84 I FLX]"",FLX'="0" D 85 . W !,"This is a ",$$EXTERNAL^DILFD(458.01,5,"",FLX)," tour!" 86 I FLX]"",FLXP]"",FLX'=FLXP D 87 . W !,"Note: The Compressed Tour Indicator has been changed since" 88 . W !," the previous pay period (from " 89 . W $$EXTERNAL^DILFD(458.01,5,"",FLXP) 90 . W " to ",$$EXTERNAL^DILFD(458.01,5,"",FLX),")." 91 Q 1 PRS8VW ;HISC/MRL-DECOMPOSITION, VIEW RESULTS ;11/4/97 2 ;;4.0;PAID;**2,6,27,45**;Sep 21, 1995 3 ; 4 ;This routine is used to view the results of the decomposition. 5 ;The variables VAL and VALOLD must be passed. VAL is the current 6 ;decomposition string. VALOLD, which may be null, is the results 7 ;of a previous decomposition run (what's in the 5 node of file 458 8 ;prior to running decomposition). 9 ; 10 ;Called by Routines: PRS8, PRS8DR 11 S (NEW,VAL)=$G(VAL),(OLD,VALOLD)=$G(VALOLD) 12 I +$E(NEW,2,4) S NEW=$E(VAL,33,999) ; 33rd position because CP field 13 I +$E(OLD,2,4) S OLD=$E(VALOLD,33,999) ;is added(either "C","F"or" ") 14 D E 15 W @IOF 16 I "C"'[$E(IOST) D 17 .S X="Decomposition of Time" W ?(80-$L(X)/2),X,! 18 .D NOW^%DTC S Y=% X ^DD("DD") 19 .S X=$G(^VA(200,+$G(DUZ),0)),TR="User: "_$S($P(X,"^",1)'="":$P(X,"^",1),1:"Unknown") 20 .S TR=TR_" " 21 .S X="Run Date: "_Y,TR=$E(TR,1,(79-$L(X)))_X 22 S X=$P(C0,"^",1)_" [SSN: "_$P(C0,"^",9)_"]" W !,X 23 S X="Pay Period: "_(^PRST(458,+PY,0)) W ?(79-$L(X)),$P(X,"^",1) 24 D CTID 25 W ! F I=1:1:79 W "=" 26 W !,"Loc.",?10,"Data Element",?44,"Code",?52,"Old Value",?67,"New Value" 27 W !,"----",?10,"------------",?44,"----",?52,"---------",?67,"---------" 28 K I,L,X,USED 29 D ^PRS8VW1 30 D STUB 31 I "C"'[$E(IOST) D 32 .W ! F I=1:1:79 W "-" 33 .W !,TR 34 D ONE^PRS8CV,^%ZISC Q 35 ; 36 CERT ; entry point to show supervisor result of decomp before certifying 37 S (NEW,VAL)=$G(VAL) 38 I +$E(NEW,2,4) S NEW=$E(VAL,33,999) ;because CP field is added to STUB 39 D E2 40 W @IOF 41 I "C"'[$E(IOST) D 42 .S X="Decomposition of Time" W ?(80-$L(X)/2),X,! 43 .D NOW^%DTC S Y=% X ^DD("DD") 44 .S X=$G(^VA(200,+$G(DUZ),0)),TR="User: "_$S($P(X,"^",1)'="":$P(X,"^",1),1:"Unknown") 45 .S TR=TR_" " 46 .S X="Run Date: "_Y,TR=$E(TR,1,(79-$L(X)))_X 47 S H="PAY PERIOD SUMMARY" W !,$J(H,40+($L(H)/2)),! 48 S X=$P(C0,"^",1)_" [SSN: "_$P(C0,"^",9)_"]" W !,X 49 S X="Pay Period: "_(^PRST(458,+PY,0)) W ?(79-$L(X)),$P(X,"^",1) 50 D CTID 51 W ! F I=1:1:79 W "=" 52 W ! 53 K I,L,X,USED 54 D ^PRS8VW2 55 I "C"'[$E(IOST) D 56 .W ! F I=1:1:79 W "-" 57 .W !,TR 58 K H,R,Z Q 59 E2 ; --- create E array 60 S E(1)="ANSKWDNOAURTCECUUNNANBSPSASBSCDADBDCTFOAOBOCYAOKOMRARBRCHAHBHCPTPAONYDHDVCEAEBTATCFAFCADNT" 61 S E(2)="ALSLWPNPABRLCTCOUSNRNSSQSESFSGDEDFDGTGOEOFOGYEOSOURERFRGHLHMHNPHPBCLYHHOVSECEDTBTDFBFDAFNH" 62 S E(3)="NLDWMLCAPCCYFE" Q 63 STUB ; --- show stub record 64 S X1=$G(HDR),X2=$E(VAL,1,32) 65 I X1="" S X1=$E(VALOLD,1,32) 66 I X1="" S X1=X2 67 I $L(X1)<$L(X2) S X1=X2 68 W !!,"STUB RECORD >>>>> ",$S(X1'="":X1,1:"Not Available At this Time...") Q 69 ; 70 E ; --- create E array 71 S E(1)="ANSKWDNOAURTCECUUNNANBSPSASBSCDADBDCTFOAOBOCYAOKOMRARBRCHAHBHCPTPAONYDHDVCEAEBTATCFAFCADNT" 72 S E(2)="ALSLWPNPABRLCTCOUSNRNSSQSESFSGDEDFDGTGOEOFOGYEOSOURERFRGHLHMHNPHPBCLYHHOVSECEDTBTDFBFDAFNH" 73 S E(3)="NLDWINTLLULNLDDTTOLAMLCAPCCYRRFFFECD" Q 74 CTID ; compressed tour indicator display 75 ; in - PY (pay period ien), DFN (employee ien) 76 N FLX,FLXP 77 S FLX=$P($G(^PRST(458,+PY,"E",DFN,0)),U,6) ; for current pay period 78 S FLXP=$P($G(^PRST(458,+PY-1,"E",DFN,0)),U,6) ; for previous pay period 79 I FLX]"",FLX'="0" D 80 . W !,"This is a ",$$EXTERNAL^DILFD(458.01,5,"",FLX)," tour!" 81 I FLX]"",FLXP]"",FLX'=FLXP D 82 . W !,"Note: The Compressed Tour Indicator has been changed since" 83 . W !," the previous pay period (from " 84 . W $$EXTERNAL^DILFD(458.01,5,"",FLXP) 85 . W " to ",$$EXTERNAL^DILFD(458.01,5,"",FLX),")." 86 Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRS8VW1.m
r613 r623 1 PRS8VW1 ;HISC/MRL-DECOMPOSITION, VIEW RESULTS, CONT. ;01/23/07 2 ;;4.0;PAID;**6,35,45,69,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;This routine is used to view the results of the decomposition. 6 ;It is a continuation of routine ^PRS8VW. 7 ; 8 ;See routine PRS8VW2 at label TYP for type of time 9 ;text displayed from this routine. 10 ; 11 ;Called by Routines: PRS8VW1 12 ; 13 S CHECK=0 14 ; 15 EN ; --- entry point from PRS8CK1 16 S E=E(1),W="Wk-1",LOC=1 D SHOW 17 S E=E(2),W="Wk-2",LOC=2 D SHOW 18 S E=E(3),W="Misc",LOC=0 D SHOW 19 I 'CHECK,"C"'[$E(IOST) D 20 .W !,DASH1 21 .W !,TR 22 K %,CHECK,D,E,I,L,LOC,USED,W,X,Y Q 23 ; 24 SHOW ; --- show information 25 F I=1:2 S X=$E(E,I,I+1) Q:X="" D 26 .I $D(USED(X)) Q 27 .S USED(X)="" 28 .S X(1)=$F(OLD,X),X(2)=$F(NEW,X) ; try to find time code in TT8B 29 .I 'CHECK,'X(1),'X(2) Q ;not in either string 30 .I CHECK S LOC(1)=(I\2+1) S:'LOC LOC(1)=LOC(1)+50 D 31 ..S FOUND(LOC(1))=$G(FOUND(LOC(1))) 32 ..S $P(FOUND(LOC(1)),"^",$S(LOC<2:1,1:4))=X 33 .S Y=$P($T(@($E(X)_"^PRS8VW2")),";;",2) 34 .S Y(1)=$F(Y,$E(X,2)_":") 35 .S Y=$P($E(Y,Y(1),999),":",1,2) 36 .I 'CHECK W !,W,?10,$P($T(TYP+Y^PRS8VW2),";;",2),?45,X 37 .S X=X(1),X1=52 D CON 38 .S X=X(2),X1=67 D CON 39 Q 40 ; 41 CON ; --- convert to proper format 42 I '+X S X=$E("00000000000",1,+$P(Y,":",2)) 43 I X,X1=52 S (X,Z)=$E(OLD,X(1),X(1)+$P(Y,":",2)-1) 44 I X,X1=67 S:'$D(Z) Z="" S X=$E(NEW,X(2),X(2)+$P(Y,":",2)-1) 45 I 'CHECK W ?X1,$J(X,9) D Q 46 .I OLD=""!(NEW="") Q 47 .I X1=67,Z'="",X'=Z W " *" 48 S LOC(2)=$S(X1=52:2,1:3) I LOC=2 S LOC(2)=LOC(2)+3 49 S $P(FOUND(LOC(1)),"^",LOC(2))=X 50 Q:X1'=67 51 I $P(FOUND(LOC(1)),"^",1)="CD" Q 52 S S=0,X=FOUND(LOC(1)) 53 I +$P(X,"^",2)!(+$P(X,"^",3)) S S=1 54 I 'S,LOC,+$P(X,"^",5)!(+$P(X,"^",6)) S S=1 55 I 'S,LOC'=1 K FOUND(LOC(1)) 56 Q 1 PRS8VW1 ;HISC/MRL-DECOMPOSITION, VIEW RESULTS, CONT. ;8/23/01 2 ;;4.0;PAID;**6,35,45,69**;Sep 21, 1995 3 ; 4 ;This routine is used to view the results of the decomposition. 5 ;It is a continuation of routine ^PRS8VW. 6 ; 7 ;See routine PRS8VW2 at label TYP for type of time 8 ;text displayed from this routine. 9 ; 10 ;Called by Routines: PRS8VW1 11 ; 12 S CHECK=0 13 ; 14 EN ; --- entry point from PRS8CK1 15 S E=E(1),W="Wk-1",LOC=1 D SHOW 16 S E=E(2),W="Wk-2",LOC=2 D SHOW 17 S E=E(3),W="Misc",LOC=0 D SHOW 18 I 'CHECK,"C"'[$E(IOST) D 19 .W ! F I=1:1:79 W "-" 20 .W !,TR 21 K %,CHECK,D,E,I,L,LOC,USED,W,X,Y Q 22 ; 23 SHOW ; --- show information 24 F I=1:2 S X=$E(E,I,I+1) Q:X="" D 25 .I $D(USED(X)) Q 26 .S USED(X)="" 27 .S X(1)=$F(OLD,X),X(2)=$F(NEW,X) ; try to find time code in TT8B 28 .I 'CHECK,'X(1),'X(2) Q ;not in either string 29 .I CHECK S LOC(1)=(I\2+1) S:'LOC LOC(1)=LOC(1)+50 D 30 ..S FOUND(LOC(1))=$G(FOUND(LOC(1))) 31 ..S $P(FOUND(LOC(1)),"^",$S(LOC<2:1,1:4))=X 32 .S Y=$P($T(@$E(X)),";;",2) 33 .S Y(1)=$F(Y,$E(X,2)_":") 34 .S Y=$P($E(Y,Y(1),999),":",1,2) 35 .I 'CHECK W !,W,?10,$P($T(TYP+Y^PRS8VW2),";;",2),?45,X 36 .S X=X(1),X1=52 D CON 37 .S X=X(2),X1=67 D CON 38 Q 39 ; 40 CON ; --- convert to proper format 41 I '+X S X=$E("00000000000",1,+$P(Y,":",2)) 42 I X,X1=52 S (X,Z)=$E(OLD,X(1),X(1)+$P(Y,":",2)-1) 43 I X,X1=67 S:'$D(Z) Z="" S X=$E(NEW,X(2),X(2)+$P(Y,":",2)-1) 44 I 'CHECK W ?X1,$J(X,9) D Q 45 .I OLD=""!(NEW="") Q 46 .I X1=67,Z'="",X'=Z W " *" 47 S LOC(2)=$S(X1=52:2,1:3) I LOC=2 S LOC(2)=LOC(2)+3 48 S $P(FOUND(LOC(1)),"^",LOC(2))=X 49 Q:X1'=67 50 I $P(FOUND(LOC(1)),"^",1)="CD" Q 51 S S=0,X=FOUND(LOC(1)) 52 I +$P(X,"^",2)!(+$P(X,"^",3)) S S=1 53 I 'S,LOC,+$P(X,"^",5)!(+$P(X,"^",6)) S S=1 54 I 'S,LOC'=1 K FOUND(LOC(1)) 55 Q 56 ; 57 ; This internal table stores types of time codes and their 58 ; corresponding descriptions and TT8B value field lengths. Each 59 ; single char line label below is the 1st char of a type of time code. 60 ; The text on the corresponding line contains '^' delimited 61 ; pieces. The 1st char of those pieces is the 2nd char of a type of 62 ; time. The text description for that time code is given by the 63 ; the number in the 2nd ':' delimited piece. That number indicates 64 ; the line number below the label TYP in routine PRS8VW2. The 3rd 65 ; ':' delimited piece is the length of the time code's value in the 66 ; TT8B String. 67 ; 68 A ;;N:1:3^U:5:3^L:1:3^B:5:3^D:63:3^F:63:3 69 C ;;E:7:3^U:8:3^T:7:3^O:8:3^L:34:4^A:55:4^Y:57:3^D:60:6 70 D ;;A:16:3^B:17:3^C:18:3^E:16:3^F:17:3^G:18:3^W:45:2^T:48:6 71 E ;;A:38:5^B:40:5^C:38:5^D:40:5 72 F ;;F:59:4^A:61:3^B:61:3^C:62:3^D:62:3^E:64:6 73 H ;;A:29:3^B:30:3^C:31:3^L:29:3^M:30:3^N:31:3^D:36:3^O:36:3 74 I ;;N:46:1 75 L ;;U:48:4^N:49:4^D:50:4^A:53:1 76 M ;;L:54:4 77 N ;;O:4:3^A:10:3^B:11:3^P:4:3^R:10:3^S:11:3^L:44:2^T:65:3^H:65:3 78 O ;;A:20:3^B:21:3^C:22:3^K:24:3^M:25:3^N:34:4^E:20:3^F:21:3^G:22:3^S:24:3^U:25:3 79 P ;;T:32:3^A:33:3^H:32:3^B:33:3^C:56:2 80 R ;;T:6:3^A:26:3^B:27:3^C:28:3^L:6:3^E:26:3^F:27:3^G:28:3^R:58:1 81 S ;;K:2:3^P:12:3^A:13:3^B:14:3^C:15:3^L:2:3^Q:12:3^E:13:3^F:14:3^G:15:3 82 T ;;F:19:3^A:42:3^C:43:3^G:19:3^B:42:3^D:43:3^L:47:3^O:52:1 83 U ;;N:9:3^S:9:3 84 V ;;C:37:6^S:37:6 85 W ;;D:3:3^P:3:3 86 Y ;;A:23:3^D:35:4^E:23:3^H:35:4 87 Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRS8VW2.m
r613 r623 1 PRS8VW2 ;HISC/MRL,RTK-DECOMPOSITION, VIEW RESULTS ;03/28/07 2 ;;4.0;PAID;**6,32,34,45,69,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ; This routine is used to show the results of the decomp to 6 ; the supervisor before certification. It takes the values 7 ; in the 8B string (NEW) and prints each type of time with the 8 ; amount in a more readable format (ie - value in 8B = OE163, 9 ; would print --> Week 1 Overtime 16.75 10 ; Called from CERT+18^PRS8VW, a continuation from that entry point. 11 ; 12 S CHECK=0 13 ; 14 EN ; 15 S E=E(1),W="Week 1",LOC=1 D SHOW 16 S E=E(2),W="Week 2",LOC=2 D SHOW 17 S E=E(3),W="Misc",LOC=0 D SHOW 18 I 'CHECK,"C"'[$E(IOST) D 19 .W !,DASH1 20 .W !,TR 21 K %,CHECK,D,E,I,L,LOC,USED,W,X,Y Q 22 ; 23 SHOW ; --- show information 24 F I=1:2 S X=$E(E,I,I+1) Q:X="" D 25 .I $D(USED(X)) Q 26 .S USED(X)="" 27 .S X(1)=$F(NEW,X) 28 .I 'CHECK,'X(1) Q ;not in string 29 .I CHECK S LOC(1)=(I\2+1) S:'LOC LOC(1)=LOC(1)+50 D 30 ..S FOUND(LOC(1))=$G(FOUND(LOC(1))) 31 ..S $P(FOUND(LOC(1)),"^",$S(LOC<2:1,1:4))=X 32 .; 33 .;read from tables below 34 .; 35 .S Y=$P($T(@$E(X)),";;",2) 36 .S Y(1)=$F(Y,$E(X,2)_":") 37 .S Y=$P($E(Y,Y(1),999),":",1,2) 38 .I 'CHECK W !,W,?15,$P($T(TYP+Y),";;",2) 39 .S X=X(1),X1=52 D CON 40 Q 41 ; 42 CON ; --- convert to proper format 43 I '+X S X=$E("00000000000",1,+$P(Y,":",2)) 44 I X,X1=52 S (X,Z)=$E(NEW,X(1),X(1)+$P(Y,":",2)-1) 45 I I=73!(W="Misc"&(I=13)) S R=X/100 W ?50,$J(R,6,2) Q 46 I W="Misc",I=3 S X=X*10 47 S R=$E(X,1,$L(X)-1)_$S($E(X,$L(X))=3:".75",$E(X,$L(X))=2:".5",$E(X,$L(X))=1:".25",1:"") W ?50,$J(R,6,2) Q 48 Q 49 ; 50 ; This internal table stores types of time codes and their 51 ; corresponding descriptions and TT8B value field lengths. Each 52 ; single char line label below is the 1st char of a type of time code. 53 ; The text on the corresponding line contains '^' delimited 54 ; pieces. The 1st char of those pieces is the 2nd char of a type of 55 ; time. The text description for that time code is given by the 56 ; the number in the 2nd ':' delimited piece. That number indicates 57 ; the line number below the label TYP in routine PRS8VW2. The 3rd 58 ; ':' delimited piece is the length of the time code's value in the 59 ; TT8B String. 60 ; 61 A ;;N:1:3^U:5:3^L:1:3^B:5:3^D:63:3^F:63:3 62 C ;;E:7:3^U:8:3^T:7:3^O:8:3^L:34:4^A:55:4^Y:57:3^D:60:6 63 D ;;A:16:3^B:17:3^C:18:3^E:16:3^F:17:3^G:18:3^W:45:2^T:48:6 64 E ;;A:38:5^B:40:5^C:38:5^D:40:5 65 F ;;F:59:4^A:61:3^B:61:3^C:62:3^D:62:3^E:64:6 66 H ;;A:29:3^B:30:3^C:31:3^L:29:3^M:30:3^N:31:3^D:36:3^O:36:3 67 I ;;N:46:1 68 L ;;U:48:4^N:49:4^D:50:4^A:53:1 69 M ;;L:54:4 70 N ;;O:4:3^A:10:3^B:11:3^P:4:3^R:10:3^S:11:3^L:44:2^T:65:3^H:65:3^D:69:3^U:69:3 71 O ;;A:20:3^B:21:3^C:22:3^K:24:3^M:25:3^N:34:4^E:20:3^F:21:3^G:22:3^S:24:3^U:25:3 72 P ;;T:32:3^A:33:3^H:32:3^B:33:3^C:56:2 73 R ;;T:6:3^A:26:3^B:27:3^C:28:3^L:6:3^E:26:3^F:27:3^G:28:3^R:58:1^S:66:3^N:66:3 74 S ;;K:2:3^P:12:3^A:13:3^B:14:3^C:15:3^L:2:3^Q:12:3^E:13:3^F:14:3^G:15:3^R:67:3^S:67:3^D:68:3^H:68:3 75 T ;;F:19:3^A:42:3^C:43:3^G:19:3^B:42:3^D:43:3^L:47:3^O:52:1 76 U ;;N:9:3^S:9:3 77 V ;;C:37:6^S:37:6 78 W ;;D:3:3^P:3:3 79 Y ;;A:23:3^D:35:4^E:23:3^H:35:4 80 ; 81 TYP ; literal values of activities (actual name) 82 ;;Annual Leave 83 ;;Sick Leave 84 ;;Leave Without Pay 85 ;;Non-Pay Time 86 ;;Authorized Absence 87 ;;Restored Annual Leave 88 ;;Comp Time/Credit Hrs Earned 89 ;;Comp Time/Credit Hrs Used 90 ;;Unscheduled Regular 91 ;;Night Differential-2 92 ;;Night Differential-3 93 ;;Saturday Premium 94 ;;Sunday Premium-D 95 ;;Sunday Premium-2 96 ;;Sunday Premium-3 97 ;;Overtime Hrs > 8 Day-D 98 ;;Overtime Hrs > 8 Day-2 99 ;;Overtime Hrs > 8 Day-3 100 ;;Travel OT-FLSA 101 ;;Overtime Total Hours-D 102 ;;Overtime Total Hours-2 103 ;;Overtime Total Hours-3 104 ;;Scheduled Call-Back OT 105 ;;Overtime on Holiday 106 ;;Sleep Time 107 ;;Reg Hrs @ Overtime Rate-D 108 ;;Reg Hrs @ Overtime Rate-2 109 ;;Reg Hrs @ Overtime Rate-3 110 ;;Holiday Hours-D 111 ;;Holiday Hours-2 112 ;;Holiday Hours-3 113 ;;Part Time Hours 114 ;;Continuation of Pay 115 ;;Standby Hours 116 ;;On-Call Hours 117 ;;Pieceworker Holiday Excused 118 ;;VCS Sales 119 ;;Environmental Differential 120 ;; 121 ;;Hazardous Duty Pay 122 ;; 123 ;;Travel 124 ;;Training 125 ;;Non-Pay Annual Leave 126 ;;Days Worked 127 ;;Insurance 128 ;;T&L Change 129 ;;Lump Sum Units-D 130 ;;Lump Sum Units-2 131 ;;Lump Sum Units-3 132 ;;Lump Sum Expiration Date 133 ;;Optional Withholding Tax 134 ;;Foreign Cola 135 ;;Military Leave 136 ;;Calendar Year Adjustment 137 ;;Workers Compensation 138 ;;SF 2806 Adjustment 139 ;;Payment Record Requested 140 ;;Fire Fighter Normal Hours 141 ;;Control Data 142 ;;Care and Bereavement 143 ;;Adoption 144 ;;Donor Leave 145 ;;Fee Basis 146 ;;Base Tour Non Pay Hours 147 ;;Recess 148 ;;Saturday Premium-AWS 149 ;;Sunday Premium-AWS 150 ;;Night Differential-AWS 1 PRS8VW2 ;HISC/MRL,RTK-DECOMPOSITION, VIEW RESULTS ;09/27/01 2 ;;4.0;PAID;**6,32,34,45,69**;Sep 21, 1995 3 ; 4 ; This routine is used to show the results of the decomp to 5 ; the supervisor before certification. It takes the values 6 ; in the 8B string (NEW) and prints each type of time with the 7 ; amount in a more readable format (ie - value in 8B = OE163, 8 ; would print --> Week 1 Overtime 16.75 9 ; Called from CERT+18^PRS8VW, a continuation from that entry point. 10 ; 11 S CHECK=0 12 ; 13 EN ; 14 S E=E(1),W="Week 1",LOC=1 D SHOW 15 S E=E(2),W="Week 2",LOC=2 D SHOW 16 S E=E(3),W="Misc",LOC=0 D SHOW 17 I 'CHECK,"C"'[$E(IOST) D 18 .W ! F I=1:1:79 W "-" 19 .W !,TR 20 K %,CHECK,D,E,I,L,LOC,USED,W,X,Y Q 21 ; 22 SHOW ; --- show information 23 F I=1:2 S X=$E(E,I,I+1) Q:X="" D 24 .I $D(USED(X)) Q 25 .S USED(X)="" 26 .S X(1)=$F(NEW,X) 27 .I 'CHECK,'X(1) Q ;not in string 28 .I CHECK S LOC(1)=(I\2+1) S:'LOC LOC(1)=LOC(1)+50 D 29 ..S FOUND(LOC(1))=$G(FOUND(LOC(1))) 30 ..S $P(FOUND(LOC(1)),"^",$S(LOC<2:1,1:4))=X 31 .; 32 .;read from tables below 33 .; 34 .S Y=$P($T(@$E(X)),";;",2) 35 .S Y(1)=$F(Y,$E(X,2)_":") 36 .S Y=$P($E(Y,Y(1),999),":",1,2) 37 .I 'CHECK W !,W,?15,$P($T(TYP+Y),";;",2) 38 .S X=X(1),X1=52 D CON 39 Q 40 ; 41 CON ; --- convert to proper format 42 I '+X S X=$E("00000000000",1,+$P(Y,":",2)) 43 I X,X1=52 S (X,Z)=$E(NEW,X(1),X(1)+$P(Y,":",2)-1) 44 I I=73!(W="Misc"&(I=13)) S R=X/100 W ?50,$J(R,6,2) Q 45 I W="Misc",I=3 S X=X*10 46 S R=$E(X,1,$L(X)-1)_$S($E(X,$L(X))=3:".75",$E(X,$L(X))=2:".5",$E(X,$L(X))=1:".25",1:"") W ?50,$J(R,6,2) Q 47 Q 48 ; 49 ; See description of similar table in routine PRS8VW1 for 50 ; explanation of table below. 51 ; 52 A ;;N:1:3^U:5:3^L:1:3^B:5:3^D:63:3^F:63:3 53 C ;;E:7:3^U:8:3^T:7:3^O:8:3^L:34:4^A:55:4^Y:57:3^D:60:6 54 D ;;A:16:3^B:17:3^C:18:3^E:16:3^F:17:3^G:18:3^W:45:2^T:48:6 55 E ;;A:38:5^B:40:5^C:38:5^D:40:5 56 F ;;F:59:4^A:61:3^B:61:3^C:62:3^D:62:3^E:64:6 57 H ;;A:29:3^B:30:3^C:31:3^L:29:3^M:30:3^N:31:3^D:36:3^O:36:3 58 I ;;N:46:1 59 L ;;U:48:4^N:49:4^D:50:4^A:53:1 60 M ;;L:54:4 61 N ;;O:4:3^A:10:3^B:11:3^P:4:3^R:10:3^S:11:3^L:44:2^T:65:3^H:65:3 62 O ;;A:20:3^B:21:3^C:22:3^K:24:3^M:25:3^N:34:4^E:20:3^F:21:3^G:22:3^S:24:3^U:25:3 63 P ;;T:32:3^A:33:3^H:32:3^B:33:3^C:56:2 64 R ;;T:6:3^A:26:3^B:27:3^C:28:3^L:6:3^E:26:3^F:27:3^G:28:3^R:58:1 65 S ;;K:2:3^P:12:3^A:13:3^B:14:3^C:15:3^L:2:3^Q:12:3^E:13:3^F:14:3^G:15:3 66 T ;;F:19:3^A:42:3^C:43:3^G:19:3^B:42:3^D:43:3^L:47:3^O:52:1 67 U ;;N:9:3^S:9:3 68 V ;;C:37:6^S:37:6 69 W ;;D:3:3^P:3:3 70 Y ;;A:23:3^D:35:4^E:23:3^H:35:4 71 ; 72 TYP ; literal values of acitivites (actual name) 73 ;;Annual Leave 74 ;;Sick Leave 75 ;;Leave Without Pay 76 ;;Non-Pay Time 77 ;;Authorized Absence 78 ;;Restored Annual Leave 79 ;;Comp Time/Credit Hrs Earned 80 ;;Comp Time/Credit Hrs Used 81 ;;Unscheduled Regular 82 ;;Night Differential-2 83 ;;Night Differential-3 84 ;;Saturday Premium 85 ;;Sunday Premium-D 86 ;;Sunday Premium-2 87 ;;Sunday Premium-3 88 ;;Overtime Hrs > 8 Day-D 89 ;;Overtime Hrs > 8 Day-2 90 ;;Overtime Hrs > 8 Day-3 91 ;;Travel OT-FLSA 92 ;;Overtime Total Hours-D 93 ;;Overtime Total Hours-2 94 ;;Overtime Total Hours-3 95 ;;Scheduled Call-Back OT 96 ;;Overtime on Holiday 97 ;;Sleep Time 98 ;;Reg Hrs @ Overtime Rate-D 99 ;;Reg Hrs @ Overtime Rate-2 100 ;;Reg Hrs @ Overtime Rate-3 101 ;;Holiday Hours-D 102 ;;Holiday Hours-2 103 ;;Holiday Hours-3 104 ;;Part Time Hours 105 ;;Continuation of Pay 106 ;;Standby Hours 107 ;;On-Call Hours 108 ;;Pieceworker Holiday Excused 109 ;;VCS Sales 110 ;;Environmental Differential 111 ;; 112 ;;Hazardous Duty Pay 113 ;; 114 ;;Travel 115 ;;Training 116 ;;Non-Pay Annual Leave 117 ;;Days Worked 118 ;;Insurance 119 ;;T&L Change 120 ;;Lump Sum Units-D 121 ;;Lump Sum Units-2 122 ;;Lump Sum Units-3 123 ;;Lump Sum Expiration Date 124 ;;Optional Withholding Tax 125 ;;Foreign Cola 126 ;;Military Leave 127 ;;Calendar Year Adjustment 128 ;;Workers Compensation 129 ;;SF 2806 Adjustment 130 ;;Payment Record Requested 131 ;;Fire Fighter Normal Hours 132 ;;Control Data 133 ;;Care and Bereavement 134 ;;Adoption 135 ;;Donor Leave 136 ;;Fee Basis 137 ;;Base Tour Non Pay Hours -
WorldVistAEHR/trunk/r/PAID-PRS/PRS8WE2.m
r613 r623 1 PRS8WE2 ;WCIOFO/MGD-DECOMPOSITION, WEEKEND PREMIUM PART 2 ;3/23/07 2 ;;4.0;PAID;**90,92,96,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 COUNT(DAYN,SEG) ; Increase count of premium for tour 5 ; input 6 ; DAYN = day # (0-15) being counted 7 ; SEG = segment # (1-96) in DAYN being counted 8 ; D(DAYN) 9 ; P(DAYN) 10 ; H(DAYN) 11 ; CNT(DAYN,shift) - optional 12 ; output 13 ; CNT(DAYN,shift) = current count for tour being processed 14 ; 15 N DAT,FND,M1,NODE,NOTELG,POST,PREVDAY,RC,SC,SHIFT,TDAY,TOUR,TOURS,TS 16 ; perform final checks 17 I ("EetOscbT"[$E(D(DAYN),SEG)),$E(H(DAYN),SEG)'=2,$E(P(DAYN),SEG) Q 18 I TYP["P","4"[$E(D(DAYN),SEG),$E(H(DAYN),SEG)'=2,$E(P(DAYN),SEG)=0 Q 19 ; 20 ; If Hybrid employee as defined by Public Law P.L. 107-135, check 21 ; to see if the time was on a tour of duty or an exception. Tours 22 ; worked on Sat or Sun qualify for Premium time. If the time was 23 ; an exception, check the Remarks Code to see if the segment can be 24 ; counted as Premium time. 25 ; 26 S (FND,NOTELG)=0 27 ; Quit if Sunday and employee is not entitled to Sun Prem Pay 28 Q:SATNOSUN&("^1^8^15^"[(U_DAY_U))&(TP="SUN") 29 I HYBRID!(PMP'=""&("^S^T^U^V^"[(U_PMP_U))) D Q:NOTELG 30 . ; Check to see if the time was on a tour or an exception 31 . N INC,END 32 . F TOURS=1,4,2 D Q:NOTELG!(FND) 33 . . S TOUR=$G(^TMP($J,"PRS8",DAYN,TOURS)) 34 . . Q:TOUR="" 35 . . S INC=$S(TOURS=2:4,1:3) 36 . . S END=$S(TOURS=2:25,1:19) 37 . . F POST=1:INC:END I $P(TOUR,"^",POST)'="" D Q:NOTELG!(FND) 38 . . . ; Quit if SEG is not within the start/stop time 39 . . . Q:SEG<$P(TOUR,"^",POST)!(SEG>$P(TOUR,"^",POST+1)) 40 . . . S FND=1 41 . . . Q:TOURS=1!(TOURS=4) ; If on a Tour it counts as Premium 42 . . . S RC=$P(TOUR,"^",POST+3) 43 . . . ; Remarks Code must be OT/CT on Premium (#9), Tour Coverage (#12), 44 . . . ; CB - Premium T&L (#14) or OT/CT With Premiums (#17) to qualify for Premium pay. 45 . . . I "^9^12^14^17^"'[("^"_RC_"^") S NOTELG=1 46 . Q:FND 47 . ; 48 . ; If we didn't find SEG in either of the two tours or the 49 . ; exceptions then check to see if it crossed over into this day. 50 . S PREVDAY=DAYN-1 51 . N INC,END 52 . F TOURS=1,4,2 D Q:NOTELG 53 . . S TOUR=$G(^TMP($J,"PRS8",PREVDAY,TOURS)) 54 . . Q:TOUR="" 55 . . S INC=$S(TOURS=2:4,1:3) 56 . . S END=$S(TOURS=2:25,1:19) 57 . . F POST=1:4:25 I $P(TOUR,"^",POST)'="" D Q:NOTELG!(FND) 58 . . . ; Quit if SEG is not within the start/stop time 59 . . . Q:(SEG+96)<$P(TOUR,"^",POST)!((SEG+96)>$P(TOUR,"^",POST+1)) 60 . . . S FND=1 61 . . . Q:TOURS=1!(TOURS=4) ; If on a Tour it counts as Premium 62 . . . S RC=$P(TOUR,"^",POST+3) 63 . . . ; Remarks Code must be OT/CT on Premium (#9), Tour Coverage (#12), 64 . . . ; CB - Premium T&L (#14) or OT/CT With Premiums to qualify for premium pay. 65 . . . I "^9^12^14^17^"'[("^"_RC_"^") S NOTELG=1 66 ; 67 I $E(H(DAYN),SEG)=1!($E(P(DAYN),SEG)=5) Q 68 ; determine special code 69 S SHIFT=1 70 I TP="SUN",TYP["W" D 71 . ; Check to see if shift 2 or 3 is recorded for the segment worked 72 . I "^2^3^"[(U_$E(D(DAYN),SEG)_U) S SHIFT=$E(D(DAYN),SEG) Q 73 . S FND=0,SC="" 74 . ; Check for Holiday Worked on a Holiday 75 . I $E(D(DAYN),SEG)="O",$E(H(DAYN),SEG)=2 D 76 . . F TDAY=DAYN,DAYN-1 D Q:FND 77 . . . S M1=$S(TDAY=DAYN:SEG,1:SEG+96) 78 . . . ; loop through both tours in day 79 . . . F NODE=1,4 S DAT=$G(^TMP($J,"PRS8",TDAY,NODE)) Q:DAT="" D Q:FND 80 . . . . ; loop through tour segments in tour 81 . . . . F TS=1:1:7 Q:$P(DAT,U,(TS-1)*3+1)="" D Q:FND 82 . . . . . ; check if time is contained in tour segment 83 . . . . . I M1'<$P(DAT,U,(TS-1)*3+1),M1'>$P(DAT,U,(TS-1)*3+2) D 84 . . . . . . S SC=$P(DAT,U,(TS-1)*3+3),SHIFT=$S(SC=6:2,SC=7:3,1:1) 85 . . . . . . I "^2^3^"[(U_SHIFT_U) S FND=1 86 ; 87 ;Set shift 2 for 36/40 AWS nurses with premium time outside tour 88 ;for this time segment i.e. overtime(O), comp time(C) or called in from 89 ;on-call(c) 90 I +NAWS=36,"cOE"[$E(D(DAYN),SEG) S SHIFT=2 91 ; add to count 92 S CNT(DAYN,SHIFT)=$G(CNT(DAYN,SHIFT))+1 93 Q 94 ; 95 SAVE ; Update WK array with final count for tour 96 ; input 97 ; TP - type of premium (SAT or SUN) 98 ; CNT(day,shift)=amount 99 ; 100 N AMT,DAYN,PC,SHIFT,WEEK 101 S DAYN=0 F S DAYN=$O(CNT(DAYN)) Q:DAYN="" D 102 . Q:DAYN<1!(DAYN>14) 103 . S WEEK=$S(DAYN<8:1,1:2) 104 . S SHIFT="" F S SHIFT=$O(CNT(DAYN,SHIFT)) Q:SHIFT="" D 105 . . S AMT=CNT(DAYN,SHIFT) 106 . . S PC=$S(TP="SAT":0,1:SHIFT)+12 107 . . ;Shift 2 used for 36/40 nurses premium time within tour using the 2080 divisor (40*52). 108 . . ;Saturday Premium-AWS (SR/SS) and Sunday Premium-AWS (SD/SH) 109 . . ;Paid at the AAC with the 1872 divisor for the hourly rate (36*52) 110 . . ;for time outside the tour. 111 . . S:+NAWS=36 PC=$S(SHIFT=2:$S(TP="SAT":12,1:13),TP="SAT":49,1:50) 112 . . S $P(WK(WEEK),U,PC)=$P(WK(WEEK),U,PC)+AMT 113 Q 114 ; 115 ;PRS8WE 1 PRS8WE2 ;WCIOFO/MGD-DECOMPOSITION, WEEKEND PREMIUM PART 2 ;10/22/04 2 ;;4.0;PAID;**90,92,96**;Sep 21, 1995 3 ; 4 COUNT(DAYN,SEG) ; Increase count of premium for tour 5 ; input 6 ; DAYN = day # (0-15) being counted 7 ; SEG = segment # (1-96) in DAYN being counted 8 ; D(DAYN) 9 ; P(DAYN) 10 ; H(DAYN) 11 ; CNT(DAYN,shift) - optional 12 ; output 13 ; CNT(DAYN,shift) = current count for tour being processed 14 ; 15 N DAT,FND,M1,NODE,NOTELG,POST,PREVDAY,RC,SC,SHIFT,TDAY,TOUR,TOURS,TS 16 ; perform final checks 17 I ("EetOscbT"[$E(D(DAYN),SEG)),$E(H(DAYN),SEG)'=2,$E(P(DAYN),SEG) Q 18 I TYP["P","4"[$E(D(DAYN),SEG),$E(H(DAYN),SEG)'=2,$E(P(DAYN),SEG)=0 Q 19 ; 20 ; If Hybrid employee as defined by Public Law P.L. 107-135, check 21 ; to see if the time was on a tour of duty or an exception. Tours 22 ; worked on Sat or Sun qualify for Premium time. If the time was 23 ; an exception, check the Remarks Code to see if the segment can be 24 ; counted as Premium time. 25 ; 26 S (FND,NOTELG)=0 27 ; Quit if Sunday and employee is not entitled to Sun Prem Pay 28 Q:SATNOSUN&("^1^8^15^"[(U_DAY_U))&(TP="SUN") 29 I HYBRID!(PMP'=""&("^S^T^U^V^"[(U_PMP_U))) D Q:NOTELG 30 . ; Check to see if the time was on a tour or an exception 31 . N INC,END 32 . F TOURS=1,4,2 D Q:NOTELG!(FND) 33 . . S TOUR=$G(^TMP($J,"PRS8",DAYN,TOURS)) 34 . . Q:TOUR="" 35 . . S INC=$S(TOURS=2:4,1:3) 36 . . S END=$S(TOURS=2:25,1:19) 37 . . F POST=1:INC:END I $P(TOUR,"^",POST)'="" D Q:NOTELG!(FND) 38 . . . ; Quit if SEG is not within the start/stop time 39 . . . Q:SEG<$P(TOUR,"^",POST)!(SEG>$P(TOUR,"^",POST+1)) 40 . . . S FND=1 41 . . . Q:TOURS=1!(TOURS=4) ; If on a Tour it counts as Premium 42 . . . S RC=$P(TOUR,"^",POST+3) 43 . . . ; Remarks Code must be OT/CT on Premium (#9), Tour Coverage (#12) 44 . . . ; or CB - Premium T&L (#14) to qualify for Premium pay. 45 . . . I "^9^12^14^"'[("^"_RC_"^") S NOTELG=1 46 . Q:FND 47 . ; 48 . ; If we didn't find SEG in either of the two tours or the 49 . ; exceptions then check to see if it crossed over into this day. 50 . S PREVDAY=DAYN-1 51 . N INC,END 52 . F TOURS=1,4,2 D Q:NOTELG 53 . . S TOUR=$G(^TMP($J,"PRS8",PREVDAY,TOURS)) 54 . . Q:TOUR="" 55 . . S INC=$S(TOURS=2:4,1:3) 56 . . S END=$S(TOURS=2:25,1:19) 57 . . F POST=1:4:25 I $P(TOUR,"^",POST)'="" D Q:NOTELG!(FND) 58 . . . ; Quit if SEG is not within the start/stop time 59 . . . Q:(SEG+96)<$P(TOUR,"^",POST)!((SEG+96)>$P(TOUR,"^",POST+1)) 60 . . . S FND=1 61 . . . Q:TOURS=1!(TOURS=4) ; If on a Tour it counts as Premium 62 . . . S RC=$P(TOUR,"^",POST+3) 63 . . . ; Remarks Code must be OT/CT on Premium (#9), Tour Coverage (#12) 64 . . . ; or CB - Premium T&L (#14) to qualify for premium pay. 65 . . . I "^9^12^14^"'[("^"_RC_"^") S NOTELG=1 66 ; 67 I $E(H(DAYN),SEG)=1!($E(P(DAYN),SEG)=5) Q 68 ; determine special code 69 S SHIFT=1 70 I TP="SUN",TYP["W" D 71 . ; Check to see if shift 2 or 3 is recorded for the segment worked 72 . I "^2^3^"[(U_$E(D(DAYN),SEG)_U) S SHIFT=$E(D(DAYN),SEG) Q 73 . S FND=0,SC="" 74 . ; Check for Holiday Worked on a Holiday 75 . I $E(D(DAYN),SEG)="O",$E(H(DAYN),SEG)=2 D 76 . . F TDAY=DAYN,DAYN-1 D Q:FND 77 . . . S M1=$S(TDAY=DAYN:SEG,1:SEG+96) 78 . . . ; loop through both tours in day 79 . . . F NODE=1,4 S DAT=$G(^TMP($J,"PRS8",TDAY,NODE)) Q:DAT="" D Q:FND 80 . . . . ; loop through tour segments in tour 81 . . . . F TS=1:1:7 Q:$P(DAT,U,(TS-1)*3+1)="" D Q:FND 82 . . . . . ; check if time is contained in tour segment 83 . . . . . I M1'<$P(DAT,U,(TS-1)*3+1),M1'>$P(DAT,U,(TS-1)*3+2) D 84 . . . . . . S SC=$P(DAT,U,(TS-1)*3+3),SHIFT=$S(SC=6:2,SC=7:3,1:1) 85 . . . . . . I "^2^3^"[(U_SHIFT_U) S FND=1 86 ; 87 ; add to count 88 S CNT(DAYN,SHIFT)=$G(CNT(DAYN,SHIFT))+1 89 Q 90 ; 91 SAVE ; Update WK array with final count for tour 92 ; input 93 ; TP - type of premium (SAT or SUN) 94 ; CNT(day,shift)=amount 95 ; 96 N AMT,DAYN,PC,SHIFT,WEEK 97 S DAYN=0 F S DAYN=$O(CNT(DAYN)) Q:DAYN="" D 98 . Q:DAYN<1!(DAYN>14) 99 . S WEEK=$S(DAYN<8:1,1:2) 100 . S SHIFT="" F S SHIFT=$O(CNT(DAYN,SHIFT)) Q:SHIFT="" D 101 . . S AMT=CNT(DAYN,SHIFT) 102 . . S PC=$S(TP="SAT":0,1:SHIFT)+12 103 . . S $P(WK(WEEK),U,PC)=$P(WK(WEEK),U,PC)+AMT 104 Q 105 ; 106 ;PRS8WE -
WorldVistAEHR/trunk/r/PAID-PRS/PRSACED2.m
r613 r623 1 PRSACED2 ; HISC/FPT-T&A Edits ;11/24/1999 2 ;;4.0;PAID;**45,54,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ; initialize array that stores 8b values. This array is used 6 ; for edit checks that involve more than one type of time. 7 ; nodes 14-17 were initialized and set in PRSACED1. 8 F Z=1:1:13 S E(Z)=0 9 ; 10 F K=29:1:32,34:1:42,46,47 S X=$P(C0,"^",K) I X'="" S LAB=$P(T0," ",K-12) D @LAB 11 F K=11:1:14,16:1:24,28,29,58,59 S X=$P(C1,"^",K) I X'="" S LAB=$P(T1," ",K) D @LAB 12 I E(1)+E(2)=0 G E1 13 I "0123456789GHU"[PAY,E(1)>60!(E(2)>60) S ERR=41 D ERR^PRSACED 14 E1 I "^R^C^"'[(U_PMP_U),E(3)>20!(E(4)>20) S ERR=55 D ERR^PRSACED 15 I E(5)>24!(E(6)>24) S ERR=61 D ERR^PRSACED 16 I NOR>80,(E(5)+E(6)) S ERR=168 D ERR^PRSACED 17 ; RA or RE hours may not exceed PT or PH hours minus 53. 18 ; RA is stored in E(3), RE in E(4), PT in E(10) and PH in E(11). 19 ; only check firefighters with premium pay indicator R or C (patch *54) 20 I "^R^C^"[(U_PMP_U) D 21 . I E(3),(E(3)>(E(10)-53)) S ERR=175 D ERR^PRSACED 22 . I E(4),(E(4)>(E(11)-53)) S ERR=176 D ERR^PRSACED 23 ; 24 ; NT, NH, NO, NP, WD, WP in E(12), E(13), E(14), E(15), E(16), E(17) 25 ; NT hrs can't exceed WD + NO. NH hrs can't exceed WP + NP. 26 ; 27 I E(12)>(E(14)+E(16)) S ERR=178 D ERR^PRSACED 28 I E(13)>(E(15)+E(17)) S ERR=179 D ERR^PRSACED 29 ; 30 I E(7)+E(8)=0 G E2 31 I DUT=1,CWK'="C" S MX=NOR/2 I E(7)>MX!(E(8)>MX) S ERR=80 D ERR^PRSACED 32 G:DUT=1 E2 S X1=$P(C0,"^",42)+$P(C0,"^",21),X1=X1\10+(X1#10*.25) 33 I E(7)>X1 S ERR=81 D ERR^PRSACED 34 S X1=$P(C1,"^",24)+$P(C1,"^",3),X1=X1\10+(X1#10*.25) 35 I E(8)>X1 S ERR=81 D ERR^PRSACED 36 E2 I NOR=112,DUT=1,'$P(C0,"^",42)!('$P(C1,"^",24)) S ERR=67 D ERR^PRSACED 37 I E(9),'$P(C1,"^",46),E(9)'=+NOR S ERR=65 D ERR^PRSACED 38 ;exclude 9/3 month employee 39 I DUT=2,'(NOR="01"&("LMN"[PAY)),'(NOR="80"&(PAY="M")),$P(C0,"^",42)=""!($P(C1,"^",24)="") S ERR=66 D ERR^PRSACED 40 G ^PRSACED3 41 OA ; 42 OE I "ABCKMN"[PAY,X>600 S ERR=35 D ERR^PRSACED 43 I "ABCGKMNU0123456789"'[PAY S ERR=36 D ERR^PRSACED 44 S X1=LAB="OE"+1,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 45 Q 46 OB ; 47 OF I "ABCGU0123456789"'[PAY S ERR=37 D ERR^PRSACED 48 I "ABC"[PAY,X>60 S ERR=38 D ERR^PRSACED 49 S X1=LAB="OF"+1,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 50 Q 51 OC ; 52 OG I "0123456789GU"'[PAY S ERR=39 D ERR^PRSACED 53 S X1=LAB="OG"+1,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 54 Q 55 OK ; 56 OS I "ABCKM"'[PAY S ERR=44 D ERR^PRSACED 57 I "ABC"[PAY,PMP="" S ERR=45 D ERR^PRSACED 58 I FLSA'="E" S ERR=46 D ERR^PRSACED 59 Q 60 OM I X>560 S ERR=48 D ERR^PRSACED 61 I ($P(C0,"^",44)'>0),NOR'>80 S ERR=50 D ERR^PRSACED 62 I X>$P(C0,"^",44) S ERR=62 D ERR^PRSACED 63 Q 64 OU I X>560 S ERR=49 D ERR^PRSACED 65 I ($P(C1,"^",26)'>0),NOR'>80 S ERR=51 D ERR^PRSACED 66 I X>$P(C1,"^",26) S ERR=63 D ERR^PRSACED 67 Q 68 RA ;RA is stored in E(3), RE in E(4) 69 RE I "ABCGKMNU0123456789"'[PAY S ERR=52 D ERR^PRSACED 70 S X1=LAB="RE"+3,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 71 Q 72 RB ; 73 RF I "BGU0123456789"'[PAY S ERR=53 D ERR^PRSACED 74 S X1=LAB="RF"+3,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 75 Q 76 RC ; 77 RG I "0123456789AGKMNU"'[PAY S ERR=54 D ERR^PRSACED 78 I PAY="A",X>200 S ERR=56 D ERR^PRSACED 79 S X1=LAB="RG"+3,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 80 Q 81 HA ; 82 HL I "ABCGKMNU0123456789"'[PAY S ERR=57 D ERR^PRSACED 83 S X1=LAB="HL"+5,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 84 Q 85 HB ; 86 HM I "BGU0123456789"'[PAY S ERR=58 D ERR^PRSACED 87 S X1=LAB="HM"+5,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 88 Q 89 HC ; 90 HN I "0123456789GKMU"'[PAY S ERR=59 D ERR^PRSACED 91 S X1=LAB="HN"+5,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 92 Q 93 HD ; 94 HO I X>240 S ERR=60 D ERR^PRSACED 95 I PAY'="U" S ERR=76 D ERR^PRSACED 96 I PB'="P" S ERR=76 D ERR^PRSACED 97 Q 98 PT ; 99 PH I 'X,'LVG,'(DUT=2&("BLM"[PAY)) S ERR=64 D ERR^PRSACED 100 I DUT=1,NOR'>80 S ERR=67 D ERR^PRSACED 101 I DUT=3 S ERR=68 D ERR^PRSACED 102 ; total part time hours stored in E(9) 103 S E(9)=E(9)+$E(X,1,2)+($E(X,3)*.25) 104 ; Save PT in E(10) and PH in E(11) 105 S X1=LAB="PH"+10,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 106 Q 107 EA S E(7)=E(7)+$E(X,3,4)+($E(X,5)*.25) 108 EB I LAB="EB" S E(7)=E(7)+$E(X,3,4)+($E(X,5)*.25) 109 EC I LAB="EC" S E(8)=E(8)+$E(X,3,4)+($E(X,5)*.25) 110 ED I LAB="ED" S E(8)=E(8)+$E(X,3,4)+($E(X,5)*.25) 111 I "GU1234567"'[PAY S ERR=78 D ERR^PRSACED 112 I $E(X,1,2)>50 S ERR=79 D ERR^PRSACED 113 Q 114 NT ; Special firefighter codes 115 NH ; NT is stored in E(12), NH in E(13) 116 I NOR'>80 S ERR=177 D ERR^PRSACED 117 S X1=LAB="NH"+12,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 118 Q 1 PRSACED2 ; HISC/FPT-T&A Edits ;11/24/1999 2 ;;4.0;PAID;**45,54**;Sep 21, 1995 3 ; 4 ; initialize array that stores 8b values. This array is used 5 ; for edit checks that involve more than one type of time. 6 ; nodes 14-17 were initialized and set in PRSACED1. 7 F Z=1:1:13 S E(Z)=0 8 ; 9 F K=29:1:32,34:1:42,46,47 S X=$P(C0,"^",K) I X'="" S LAB=$P(T0," ",K-12) D @LAB 10 F K=11:1:14,16:1:24,28,29,58,59 S X=$P(C1,"^",K) I X'="" S LAB=$P(T1," ",K) D @LAB 11 I E(1)+E(2)=0 G E1 12 I "0123456789GHU"[PAY,E(1)>60!(E(2)>60) S ERR=41 D ERR^PRSACED 13 E1 I "^R^C^"'[(U_PMP_U),E(3)>20!(E(4)>20) S ERR=55 D ERR^PRSACED 14 I E(5)>24!(E(6)>24) S ERR=61 D ERR^PRSACED 15 I NOR>80,(E(5)+E(6)) S ERR=168 D ERR^PRSACED 16 ; RA or RE hours may not exceed PT or PH hours minus 53. 17 ; RA is stored in E(3), RE in E(4), PT in E(10) and PH in E(11). 18 ; only check firefighters with premium pay indicator R or C (patch *54) 19 I "^R^C^"[(U_PMP_U) D 20 . I E(3),(E(3)>(E(10)-53)) S ERR=175 D ERR^PRSACED 21 . I E(4),(E(4)>(E(11)-53)) S ERR=176 D ERR^PRSACED 22 ; 23 ; NT, NH, NO, NP, WD, WP in E(12), E(13), E(14), E(15), E(16), E(17) 24 ; NT hrs can't exceed WD + NO. NH hrs can't exceed WP + NP. 25 ; 26 I E(12)>(E(14)+E(16)) S ERR=178 D ERR^PRSACED 27 I E(13)>(E(15)+E(17)) S ERR=179 D ERR^PRSACED 28 ; 29 I E(7)+E(8)=0 G E2 30 I DUT=1,CWK'="C" S MX=NOR/2 I E(7)>MX!(E(8)>MX) S ERR=80 D ERR^PRSACED 31 G:DUT=1 E2 S X1=$P(C0,"^",42)+$P(C0,"^",21),X1=X1\10+(X1#10*.25) 32 I E(7)>X1 S ERR=81 D ERR^PRSACED 33 S X1=$P(C1,"^",24)+$P(C1,"^",3),X1=X1\10+(X1#10*.25) 34 I E(8)>X1 S ERR=81 D ERR^PRSACED 35 E2 I NOR=112,DUT=1,'$P(C0,"^",42)!('$P(C1,"^",24)) S ERR=67 D ERR^PRSACED 36 I E(9),'$P(C1,"^",46),E(9)'=+NOR S ERR=65 D ERR^PRSACED 37 I DUT=2,'(NOR="01"&("LMN"[PAY)),$P(C0,"^",42)=""!($P(C1,"^",24)="") S ERR=66 D ERR^PRSACED 38 G ^PRSACED3 39 OA ; 40 OE I "ABCKMN"[PAY,X>600 S ERR=35 D ERR^PRSACED 41 I "ABCGKMNU0123456789"'[PAY S ERR=36 D ERR^PRSACED 42 S X1=LAB="OE"+1,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 43 Q 44 OB ; 45 OF I "ABCGU0123456789"'[PAY S ERR=37 D ERR^PRSACED 46 I "ABC"[PAY,X>60 S ERR=38 D ERR^PRSACED 47 S X1=LAB="OF"+1,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 48 Q 49 OC ; 50 OG I "0123456789GU"'[PAY S ERR=39 D ERR^PRSACED 51 S X1=LAB="OG"+1,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 52 Q 53 OK ; 54 OS I "ABCKM"'[PAY S ERR=44 D ERR^PRSACED 55 I "ABC"[PAY,PMP="" S ERR=45 D ERR^PRSACED 56 I FLSA'="E" S ERR=46 D ERR^PRSACED 57 Q 58 OM I X>560 S ERR=48 D ERR^PRSACED 59 I ($P(C0,"^",44)'>0),NOR'>80 S ERR=50 D ERR^PRSACED 60 I X>$P(C0,"^",44) S ERR=62 D ERR^PRSACED 61 Q 62 OU I X>560 S ERR=49 D ERR^PRSACED 63 I ($P(C1,"^",26)'>0),NOR'>80 S ERR=51 D ERR^PRSACED 64 I X>$P(C1,"^",26) S ERR=63 D ERR^PRSACED 65 Q 66 RA ;RA is stored in E(3), RE in E(4) 67 RE I "ABCGKMNU0123456789"'[PAY S ERR=52 D ERR^PRSACED 68 S X1=LAB="RE"+3,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 69 Q 70 RB ; 71 RF I "BGU0123456789"'[PAY S ERR=53 D ERR^PRSACED 72 S X1=LAB="RF"+3,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 73 Q 74 RC ; 75 RG I "0123456789AGKMNU"'[PAY S ERR=54 D ERR^PRSACED 76 I PAY="A",X>200 S ERR=56 D ERR^PRSACED 77 S X1=LAB="RG"+3,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 78 Q 79 HA ; 80 HL I "ABCGKMNU0123456789"'[PAY S ERR=57 D ERR^PRSACED 81 S X1=LAB="HL"+5,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 82 Q 83 HB ; 84 HM I "BGU0123456789"'[PAY S ERR=58 D ERR^PRSACED 85 S X1=LAB="HM"+5,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 86 Q 87 HC ; 88 HN I "0123456789GKMU"'[PAY S ERR=59 D ERR^PRSACED 89 S X1=LAB="HN"+5,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 90 Q 91 HD ; 92 HO I X>240 S ERR=60 D ERR^PRSACED 93 I PAY'="U" S ERR=76 D ERR^PRSACED 94 I PB'="P" S ERR=76 D ERR^PRSACED 95 Q 96 PT ; 97 PH I 'X,'LVG,'(DUT=2&("BLM"[PAY)) S ERR=64 D ERR^PRSACED 98 I DUT=1,NOR'>80 S ERR=67 D ERR^PRSACED 99 I DUT=3 S ERR=68 D ERR^PRSACED 100 ; total part time hours stored in E(9) 101 S E(9)=E(9)+$E(X,1,2)+($E(X,3)*.25) 102 ; Save PT in E(10) and PH in E(11) 103 S X1=LAB="PH"+10,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 104 Q 105 EA S E(7)=E(7)+$E(X,3,4)+($E(X,5)*.25) 106 EB I LAB="EB" S E(7)=E(7)+$E(X,3,4)+($E(X,5)*.25) 107 EC I LAB="EC" S E(8)=E(8)+$E(X,3,4)+($E(X,5)*.25) 108 ED I LAB="ED" S E(8)=E(8)+$E(X,3,4)+($E(X,5)*.25) 109 I "GU1234567"'[PAY S ERR=78 D ERR^PRSACED 110 I $E(X,1,2)>50 S ERR=79 D ERR^PRSACED 111 Q 112 NT ; Special firefighter codes 113 NH ; NT is stored in E(12), NH in E(13) 114 I NOR'>80 S ERR=177 D ERR^PRSACED 115 S X1=LAB="NH"+12,E(X1)=E(X1)+$E(X,1,2)+($E(X,3)*.25) 116 Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRSACED5.m
r613 r623 1 PRSACED5 ; HISC/REL/FPT/PLT-T&A Cross-Edits ;11/20/06 12:53 2 ;;4.0;PAID;**102,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 G D1:DUT=1,D2:DUT=2,D3:DUT=3 Q 6 D1 G:+NOR N1 7 I "045"'[LVG S ERR=151 D ERR^PRSACED 8 I "LJXWPQY"'[PAY S ERR=152 D ERR^PRSACED 9 Q:"45"'[LVG 10 S E(1)=0 F K=13:1:18 S X=$P(C0,"^",K),E(1)=E(1)+$E(X,1,2)+($E(X,3)*.25) 11 S E(2)=0 F K=48:1:53 S X=$P(C0,"^",K),E(2)=E(2)+$E(X,1,2)+($E(X,3)*.25) 12 I E(1)>7!(E(2)>7) S ERR=159 D ERR^PRSACED 13 I LVG=5 I E(1)+E(2)+$P(C1,"^",30)>14 S ERR=160 D ERR^PRSACED 14 Q 15 ;36/40 employee has 8b normal hour = 72 16 N1 I '(NOR=48!(NOR=72)&("KM"[PAY)),NOR<80 S ERR=153 D ERR^PRSACED 17 I '(PAY="W"&(LVG=0)),"123"'[LVG S ERR=154 D ERR^PRSACED 18 S E(1)=0 F K=13:1:18,20,43 S X=$P(C0,"^",K),E(1)=E(1)+$E(X,1,2)+($E(X,3)*.25) 19 S E(2)=0 F K=48:1:53 S X=$P(C0,"^",K),E(2)=E(2)+$E(X,1,2)+($E(X,3)*.25) 20 F K=2,25 S X=$P(C1,"^",K),E(2)=E(2)+$E(X,1,2)+($E(X,3)*.25) 21 G:NOR=80 N2 22 I $P(C0,"^",42)+$P(C1,"^",24)=0 S MX=NOR/2 I E(1)>MX!(E(2)>MX) S ERR=161 D ERR^PRSACED 23 S X=$P(C0,"^",42) I X S X=$E(X,1,2)+($E(X,3)*.25) I E(1)>X S ERR=163 D ERR^PRSACED 24 S X=$P(C1,"^",24) I X S X=$E(X,1,2)+($E(X,3)*.25) I E(2)>X S ERR=163 D ERR^PRSACED 25 Q 26 N2 I CWK'="C",E(1)>45!(E(2)>45) S ERR=165 D ERR^PRSACED 27 I CWK="C",E(1)+E(2)>80 S ERR=166 D ERR^PRSACED 28 Q 29 ;exclude 9/3 month employee 30 D2 I PAY'="M"!(FLSA'="E"),NOR<1!(NOR>79) S ERR=155 D ERR^PRSACED 31 I "0123"'[LVG S ERR=156 D ERR^PRSACED 32 I "ABCGLMNRU0123456789PQT"'[PAY S ERR=157 D ERR^PRSACED 33 ;exclude 9/3 month employee 34 QUIT:"123"'[LVG!(NOR="80"&(PAY="M")) 35 S E(1)=0 F K=13:1:18,20,43 S X=$P(C0,"^",K),E(1)=E(1)+$E(X,1,2)+($E(X,3)*.25) 36 S E(2)=0 F K=48:1:53 S X=$P(C0,"^",K),E(2)=E(2)+$E(X,1,2)+($E(X,3)*.25) 37 F K=2,25 S X=$P(C1,"^",K),E(2)=E(2)+$E(X,1,2)+($E(X,3)*.25) 38 S X=$P(C0,"^",42),X=$E(X,1,2)+($E(X,3)*.25) I E(1)>X S ERR=164 D ERR^PRSACED 39 S X=$P(C1,"^",24),X=$E(X,1,2)+($E(X,3)*.25) I E(2)>X S ERR=164 D ERR^PRSACED 40 Q:CWK'="C" 41 S E(1)=0 F K=29,30,31 S X=$P(C0,"^",K),E(1)=E(1)+$E(X,1,2)+($E(X,3)*.25) 42 F K=11,12,13 S X=$P(C1,"^",K),E(1)=E(1)+$E(X,1,2)+($E(X,3)*.25) 43 S E(2)=0 F K=21,42 S X=$P(C0,"^",K),E(2)=E(2)+$E(X,1,2)+($E(X,3)*.25) 44 F K=16,51 S X=$P(C0,"^",K),E(2)=E(2)-$E(X,1,2)-($E(X,3)*.25) 45 F K=3,24 S X=$P(C1,"^",K),E(2)=E(2)+$E(X,1,2)+($E(X,3)*.25) 46 ; The following line was commented out for DFAS Release #1 per Angela Curtiss instructions. 47 ; I E(1),E(2)<80 S ERR=170 D ERR^PRSACED - 48 Q 49 D3 I +NOR!LVG S ERR=158 D ERR^PRSACED 50 Q 1 PRSACED5 ; HISC/REL/FPT-T&A Cross-Edits ;02/07/06 12:53 2 ;;4.0;PAID;**102**;Sep 21, 1995 3 G D1:DUT=1,D2:DUT=2,D3:DUT=3 Q 4 D1 G:+NOR N1 5 I "045"'[LVG S ERR=151 D ERR^PRSACED 6 I "LJXWPQY"'[PAY S ERR=152 D ERR^PRSACED 7 Q:"45"'[LVG 8 S E(1)=0 F K=13:1:18 S X=$P(C0,"^",K),E(1)=E(1)+$E(X,1,2)+($E(X,3)*.25) 9 S E(2)=0 F K=48:1:53 S X=$P(C0,"^",K),E(2)=E(2)+$E(X,1,2)+($E(X,3)*.25) 10 I E(1)>7!(E(2)>7) S ERR=159 D ERR^PRSACED 11 I LVG=5 I E(1)+E(2)+$P(C1,"^",30)>14 S ERR=160 D ERR^PRSACED 12 Q 13 N1 I '(NOR=48&("KM"[PAY)),NOR<80 S ERR=153 D ERR^PRSACED 14 I '(PAY="W"&(LVG=0)),"123"'[LVG S ERR=154 D ERR^PRSACED 15 S E(1)=0 F K=13:1:18,20,43 S X=$P(C0,"^",K),E(1)=E(1)+$E(X,1,2)+($E(X,3)*.25) 16 S E(2)=0 F K=48:1:53 S X=$P(C0,"^",K),E(2)=E(2)+$E(X,1,2)+($E(X,3)*.25) 17 F K=2,25 S X=$P(C1,"^",K),E(2)=E(2)+$E(X,1,2)+($E(X,3)*.25) 18 G:NOR=80 N2 19 I $P(C0,"^",42)+$P(C1,"^",24)=0 S MX=NOR/2 I E(1)>MX!(E(2)>MX) S ERR=161 D ERR^PRSACED 20 S X=$P(C0,"^",42) I X S X=$E(X,1,2)+($E(X,3)*.25) I E(1)>X S ERR=163 D ERR^PRSACED 21 S X=$P(C1,"^",24) I X S X=$E(X,1,2)+($E(X,3)*.25) I E(2)>X S ERR=163 D ERR^PRSACED 22 Q 23 N2 I CWK'="C",E(1)>45!(E(2)>45) S ERR=165 D ERR^PRSACED 24 I CWK="C",E(1)+E(2)>80 S ERR=166 D ERR^PRSACED 25 Q 26 D2 I NOR<1!(NOR>79) S ERR=155 D ERR^PRSACED 27 I "0123"'[LVG S ERR=156 D ERR^PRSACED 28 I "ABCGLMNRU0123456789PQT"'[PAY S ERR=157 D ERR^PRSACED 29 Q:"123"'[LVG 30 S E(1)=0 F K=13:1:18,20,43 S X=$P(C0,"^",K),E(1)=E(1)+$E(X,1,2)+($E(X,3)*.25) 31 S E(2)=0 F K=48:1:53 S X=$P(C0,"^",K),E(2)=E(2)+$E(X,1,2)+($E(X,3)*.25) 32 F K=2,25 S X=$P(C1,"^",K),E(2)=E(2)+$E(X,1,2)+($E(X,3)*.25) 33 S X=$P(C0,"^",42),X=$E(X,1,2)+($E(X,3)*.25) I E(1)>X S ERR=164 D ERR^PRSACED 34 S X=$P(C1,"^",24),X=$E(X,1,2)+($E(X,3)*.25) I E(2)>X S ERR=164 D ERR^PRSACED 35 Q:CWK'="C" 36 S E(1)=0 F K=29,30,31 S X=$P(C0,"^",K),E(1)=E(1)+$E(X,1,2)+($E(X,3)*.25) 37 F K=11,12,13 S X=$P(C1,"^",K),E(1)=E(1)+$E(X,1,2)+($E(X,3)*.25) 38 S E(2)=0 F K=21,42 S X=$P(C0,"^",K),E(2)=E(2)+$E(X,1,2)+($E(X,3)*.25) 39 F K=16,51 S X=$P(C0,"^",K),E(2)=E(2)-$E(X,1,2)-($E(X,3)*.25) 40 F K=3,24 S X=$P(C1,"^",K),E(2)=E(2)+$E(X,1,2)+($E(X,3)*.25) 41 ; The following line was commented out for DFAS Release #1 per Angela Curtiss instructions. 42 ; I E(1),E(2)<80 S ERR=170 D ERR^PRSACED - 43 Q 44 D3 I +NOR!LVG S ERR=158 D ERR^PRSACED 45 Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRSACED6.m
r613 r623 1 PRSACED6 ; HISC/FPT-T&A Cross-Edits ;11/27/95 10:01 2 ;;4.0;PAID;**6,45,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 CODES ; Set variables T0 and T1 with 8B code list 5 ; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 6 ; 7 S T0="AN SK WD NO AU RT CE CU UN NA NB SP DA SA SB SC OA OB OC OK DB OM RA RB RC HA HB HC HD PT PA ON VC EA EB AL SL WP NP AB RL FA FB FC FD AD AF FE",N1=60 8 S T1="CT CO US NR NS DC TF SE SF SG OE OF OG OS TA OU RE RF RG HL HM HN HO PH PB CL VS EC ED NL DW IN TL LU LN LD TO LA ML CA PC TC CY RR SQ FF DE DF YA DG TG YD YE TB DT YH TD NT NH RS RN ND NU SR SS SD SH",N2=67 9 Q 10 STUB ; parse out 'stub' variables from 8b record 11 S RECORD=^PRST(458,PPI,"E",DFN,5) 12 S STA=$E(RECORD,2,4) 13 S SSN=$E(RECORD,5,13) 14 S NCODE=$E(RECORD,14,16) 15 S DAYNO=$E(RECORD,17,19) 16 S TL=$E(RECORD,22,24) 17 S LVG=$E(RECORD,25) 18 S NOR=$E(RECORD,26,27) 19 S PAY=$E(RECORD,28) 20 S DUT=$E(RECORD,29) 21 S RECORD=$E(RECORD,33,$L(RECORD)) 22 S (C0,C1)="",EOR=0 23 Q:RECORD="" 24 TYPE ; parse out type of time from 8b record 25 I EOR=1 K EOR,LOOP,MATCH,RECORD,TYPE,VALUE Q 26 S TYPE=$E(RECORD,1,2) 27 I TYPE="CD" S VALUE=$E(RECORD,3,$L(RECORD)) D CD S EOR=1 G TYPE 28 F LOOP=3:1:$L(RECORD) Q:$E(RECORD,LOOP)?1U 29 S:LOOP=$L(RECORD) EOR=1 30 S VALUE=$S(EOR=1:$E(RECORD,3,LOOP),1:$E(RECORD,3,LOOP-1)) 31 S:EOR=0 RECORD=$E(RECORD,LOOP,$L(RECORD)) 32 S MATCH=0 33 S Z=$F(T0,TYPE) 34 I Z>2 S $P(C0,"^",(Z/3)+12)=VALUE,MATCH=1 35 G:MATCH=1 TYPE 36 S Z=$F(T1,TYPE) 37 I Z>2 S $P(C1,"^",Z/3)=VALUE 38 G TYPE 39 CD ; calculate/compare cd value 40 S END=$L(C0,"^"),CD=0 41 F LOOP=13:1:END S CD=CD+$P(C0,"^",LOOP) 42 S END=$L(C1,"^") 43 F LOOP=1:1:END S CD=CD+$P(C1,"^",LOOP) 44 I CD'=+VALUE W !,"THE CD VALUE DID NOT ADD UP CORRECTLY FOR ",$P($G(^PRSPC(DFN,0)),"^",1) 45 K CD,END Q 1 PRSACED6 ; HISC/FPT-T&A Cross-Edits ;11/27/95 10:01 2 ;;4.0;PAID;**6,45**;Sep 21, 1995 3 CODES ; Set variables T0 and T1 with 8B code list 4 ; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 5 ; 6 S T0="AN SK WD NO AU RT CE CU UN NA NB SP DA SA SB SC OA OB OC OK DB OM RA RB RC HA HB HC HD PT PA ON VC EA EB AL SL WP NP AB RL FA FB FC FD AD AF FE",N1=60 7 S T1="CT CO US NR NS DC TF SE SF SG OE OF OG OS TA OU RE RF RG HL HM HN HO PH PB CL VS EC ED NL DW IN TL LU LN LD TO LA ML CA PC TC CY RR SQ FF DE DF YA DG TG YD YE TB DT YH TD NT NH",N2=59 8 Q 9 STUB ; parse out 'stub' variables from 8b record 10 S RECORD=^PRST(458,PPI,"E",DFN,5) 11 S STA=$E(RECORD,2,4) 12 S SSN=$E(RECORD,5,13) 13 S NCODE=$E(RECORD,14,16) 14 S DAYNO=$E(RECORD,17,19) 15 S TL=$E(RECORD,22,24) 16 S LVG=$E(RECORD,25) 17 S NOR=$E(RECORD,26,27) 18 S PAY=$E(RECORD,28) 19 S DUT=$E(RECORD,29) 20 S RECORD=$E(RECORD,33,$L(RECORD)) 21 S (C0,C1)="",EOR=0 22 Q:RECORD="" 23 TYPE ; parse out type of time from 8b record 24 I EOR=1 K EOR,LOOP,MATCH,RECORD,TYPE,VALUE Q 25 S TYPE=$E(RECORD,1,2) 26 I TYPE="CD" S VALUE=$E(RECORD,3,$L(RECORD)) D CD S EOR=1 G TYPE 27 F LOOP=3:1:$L(RECORD) Q:$E(RECORD,LOOP)?1U 28 S:LOOP=$L(RECORD) EOR=1 29 S VALUE=$S(EOR=1:$E(RECORD,3,LOOP),1:$E(RECORD,3,LOOP-1)) 30 S:EOR=0 RECORD=$E(RECORD,LOOP,$L(RECORD)) 31 S MATCH=0 32 S Z=$F(T0,TYPE) 33 I Z>2 S $P(C0,"^",(Z/3)+12)=VALUE,MATCH=1 34 G:MATCH=1 TYPE 35 S Z=$F(T1,TYPE) 36 I Z>2 S $P(C1,"^",Z/3)=VALUE 37 G TYPE 38 CD ; calculate/compare cd value 39 S END=$L(C0,"^"),CD=0 40 F LOOP=13:1:END S CD=CD+$P(C0,"^",LOOP) 41 S END=$L(C1,"^") 42 F LOOP=1:1:END S CD=CD+$P(C1,"^",LOOP) 43 I CD'=+VALUE W !,"THE CD VALUE DID NOT ADD UP CORRECTLY FOR ",$P($G(^PRSPC(DFN,0)),"^",1) 44 K CD,END Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRSAENT.m
r613 r623 1 PRSAENT ;HISC/MGD-Entitlement String ;10/21/04 2 ;;4.0;PAID;**6,21,45,69,75,76,90,96,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;VARS: 6 ; C0=employees 0 node of master record in file 450 7 ; NH= employees 8B normal hours 8 ; FLX= compressed/flextime code (0=none,C=compressed,F=flextime) 9 ; PMP= premium pay indicator 10 ; ( D = entitled Sun., F = entitled Sat./Sun., 11 ; E = entitled variable Sat./Sun. premium pay, 12 ; G = entitled variable Sun. prem pay 13 ; X = title 5 employees 14 ; R, C, O = 3 types of firefighters ) 15 ; AC= 3 single char codes concat. w/o delims + a possible 4th char. 16 ; AC= PP_DutyBasis(full-1,part-2,intermit-3)_FLSA(E=Exempt,N=NonExempt) 17 ; _(*EWXY8BT02S9P) 18 ; PP= employees pay plan (possible chars 0AEFGJKLMNPQRSTUWXY) 19 ; PB= pay basis-code for time condition for computing pay. 20 ; TA= type of appointment (career, career conditional, etc.) 21 ; OCC= 4 digit cost center for fund appropriation accounting 22 ; LVG= one digit code for employees leave group. 23 ; ASS= specialty assignment of physicians,dentists, nurses, 24 ; summer employees,trainees and other special programs. 25 ; ENT= 39 character entitlement string 26 ; PMP = Premium Pay Code 27 ; 28 N PAYPDTMP,PPLOLD,DUTYTEMP,FLSATEMP 29 ; 30 S C0=^PRSPC(DFN,0) 31 ; 32 ; pay plan in master record. 33 S PP=$P(C0,"^",21) 34 ; 35 ;===================================================================== 36 ; duty basis from master record 37 S DUTYTEMP=$P(C0,"^",10) 38 ; 39 ; FLSA indicator from master record 40 S FLSATEMP=$P(C0,"^",12) 41 ; 42 ;Make sure we've called this routine from an entry point that uses 43 ;PY for pay period. A few reports, call PRSAENT from TYPSTF^PRSRUT0 44 ;and the reports aren't concerned about differing pay plans from 45 ;other pay periods. 46 ; 47 I +($G(PY))>0 D 48 .S PAYPDTMP=$P($G(^PRST(458,+PY,0)),"^") ;pay period we're working with. 49 .S PPLOLD=$$OLDPP^PRS8UT(PAYPDTMP,+DFN) ;pay plan from PAYPDTMP. 50 .;if we find an old pay plan and it's different than the master record 51 .;use the old pay plan to determine VCS or FEE. 52 .I PPLOLD'=0,(PP'=PPLOLD) D 53 .. S PP=PPLOLD 54 .. S DUTYTEMP=OLDPP("DUTYBS") 55 ;===================================================================== 56 ; 57 ; Numeric Pay plans are all Wage grade. Set them to 0. 58 S:PP?1N PP=0 59 ; 60 ; 61 S:"BC"[PP PP="A" 62 I "0AEFGJKLMNPQRSTUWXY"'[PP D NO Q 63 S NH=+$P(C0,"^",16) 64 S FLX=$P($G(^PRSPC(DFN,1)),"^",7) 65 S PMP=$P($G(^PRSPC(DFN,"PREMIUM")),"^",6) 66 S AC=PP_DUTYTEMP_FLSATEMP 67 I $L(AC)'=3 D NO Q 68 ; 69 ; 70 D @PP 71 D FND 72 Q 73 ;=========================================================== 74 ; 75 0 Q 76 ; 77 A ;patch 45: firefighters entitlements are based on PMP Codes. 78 ; Code O still uses nh>80 to determine entitlement. 79 I "RC"[PMP S AC=AC_PMP Q 80 ; 81 ;This check does not concern itself with whether or not a code 82 ; O is present. Simply if not a code R or C then an over 80 83 ; must be a code O firefighter under the rules implemented in 84 ; patch 45. 85 ; 86 I "CR"'[PMP,NH>80 S AC=AC_"*" Q 87 ; 88 Q:PMP="" 89 I $E(AC,2)'=3,"WXY"[PMP S AC=AC_PMP Q 90 S:"EF"[PMP AC=AC_"E" 91 ;The following check is for Public Law 108-170 92 S:"STUV"[PMP AC=AC_PMP 93 Q 94 E Q 95 F Q 96 G I $E(AC,2)<3 Q 97 S TA=$P(C0,"^",43) S:TA=8 AC=AC_"8" Q 98 J Q 99 K S:NH=48 AC=AC_"B" Q 100 L I $E(AC,2)=2 S PB=$P(C0,"^",20) S:PB=0 AC=AC_"*" Q 101 I $E(AC,2)=3 S OCC=$P(C0,"^",17),OCC=+$E(OCC,5,6) S:OCC>20&(OCC<38) AC=AC_"*" Q 102 S LVG=$P(C0,"^",15) S:LVG=5 AC=AC_"*" Q 103 M I $E(AC,2)=1,NH=48 S AC=AC_"B" Q 104 I $E(AC,2)=2,NH=80 S AC=AC_"R" Q 105 I $E(AC,2)=2 S PB=$P(C0,"^",20) I PB=0 S AC=AC_"0" Q 106 I $E(AC,2)=3 S PB=$P(C0,"^",20) I PB=2 S AC=AC_"2" Q 107 S OCC=$P(C0,"^",17) S:OCC="" OCC="*" 108 S:" 061056 061057 "[OCC AC=AC_"T" 109 S:" 061071 061072 061080 061083 061084 "[OCC AC=AC_"T" 110 S:" 060552 060556 "[OCC AC=AC_"T" Q 111 N S ASS=$P(C0,"^",4),PB=$P(C0,"^",20) 112 ;The following check is for Public Law 108-170 113 I "^S^T^U^V^"[("^"_PMP_"^") S AC=AC_PMP Q 114 I AC="N2E",PB=0 S AC=AC_"0" Q 115 I $E(AC,2)=3,PB="S" S AC=AC_"$" Q 116 S OCC=$P(C0,"^",17) S:OCC="" OCC="*" 117 I OCC="069961" S AC=AC_"T" Q ; Student Nurse Technician 118 I OCC="069964" S AC=AC_"T" Q ; Student Nurse Technician 119 S AC=AC_$S(ASS="TR":"T",ASS?1"T"1N:"T",ASS?1"A"1N:"T",1:"") Q 120 P Q 121 Q I $E(AC,2)'=2 Q 122 S PB=$P(C0,"^",20) S:PB=0 AC=AC_"0" Q 123 R Q 124 S Q 125 T I $E(AC,2)'=3 Q 126 S PB=$P(C0,"^",20) S:PB=9 AC=AC_"9" Q 127 U S PB=$P(C0,"^",20) I $E(AC,3)="N",PB="P" S AC=AC_"P" 128 Q 129 W Q 130 X S:'NH AC=AC_"0" Q 131 Y Q 132 ; 133 ;= = = = = = = = = = = = = = = = = = = = = = = = 134 FND ;Look up the 39 character entitlement string in the entitlement table 135 ;The lookup is based on the AC x-ref that matches the AC variable that 136 ;is built in this routine from the three 1 character codes from the 137 ;450 fields (pay plan, duty basis, FLSA). 138 ; 139 S A1=$O(^PRST(457.5,"AC",AC,0)) 140 D NO 141 I +A1 S ENT=^PRST(457.5,A1,1) 142 ; The following check was added to address the Hybrid employees 143 ; defined in Public Law 107-135. These Hybrids do not have a 144 ; Premium Pay Indicator but are entitled to Saturday and Sunday 145 ; Premium Pay. 146 I $$HYBRID^PRSAENT1(DFN) D 147 . S $E(ENT,8,9)="11" 148 ; 149 Q 150 ;= = = = = = = = = = = = = = = = = = = = = = = = 151 NO S ENT="" 152 Q 153 ; 154 MLINHRS(IEN) ; 155 ;---------------------------------------------------------------------- 156 ; Determine if the employee is entitled to Military Leave in hours. 157 ; 158 ; Input Vars: 159 ; IEN - the ien number of the employee in the PAID EMPLOYEE (#450) 160 ; file. 161 ; 162 ; Local Vars: 163 ; DATA - the 0 node of the employee from the PAID EMPLOYEE (#450) 164 ; file. 165 ; DB - Duty Basis field #9 from the #450 file. 166 ; NH - Normal Hours field # 15 from the #450 file. 167 ; PP - Pay Plan field # 20 from the #450 file. 168 ; 169 ; Output: 170 ; 1 : Entitled to ML in hours. 171 ; 0 : Entitled to ML in days. 172 ; X : Some of the required fields were not defined or the employee 173 ; is not entitled to Military Leave. 174 ;---------------------------------------------------------------------- 175 ; Quit if no IEN passed in 176 ; 177 Q:'+IEN "X" 178 ; 179 ; Verify that ENT is defined. If not call PRSAENT to define it. 180 ; 181 I '$D(ENT) D PRSAENT 182 ; 183 ; Quit if the Entitlement string is not defined for the employee 184 ; 185 Q:ENT="" "X" 186 ; 187 ; Quit if the employee is not entitled to Military Leave 188 ; 189 Q:'$E(ENT,34) "X" 190 ; 191 N DATA,PP,DB,NH 192 S DATA=$G(^PRSPC(IEN,0)) 193 Q:DATA="" "X" 194 S DB=$P(DATA,U,10),NH=$P(DATA,U,16),PP=$P(DATA,U,21) 195 Q:DB=""!(NH="")!(PP="") "X" ; Quit if DB or NH or PP is not defined. 196 ; 197 ; Check for ML in Days 198 ; 199 I DB=1,NH=0,"^J^L^P^Q^X^"[PP Q 0 200 ; 201 ; Otherwise the employee is entitled to ML in hours. 202 ; 203 Q 1 1 PRSAENT ;HISC/MGD-Entitlement String ;10/21/04 2 ;;4.0;PAID;**6,21,45,69,75,76,90,96**;Sep 21, 1995 3 ; 4 ;VARS: 5 ; C0=employees 0 node of master record in file 450 6 ; NH= employees 8B normal hours 7 ; FLX= compressed/flextime code (0=none,C=compressed,F=flextime) 8 ; PMP= premium pay indicator 9 ; ( D = entitled Sun., F = entitled Sat./Sun., 10 ; E = entitled variable Sat./Sun. premium pay, 11 ; G = entitled variable Sun. prem pay 12 ; X = title 5 employees 13 ; R, C, O = 3 types of firefighters ) 14 ; AC= 3 single char codes concat. w/o delims + a possible 4th char. 15 ; AC= PP_DutyBasis(full-1,part-2,intermit-3)_FLSA(E=Exempt,N=NonExempt) 16 ; _(*EWXY8BT02S9P) 17 ; PP= employees pay plan (possible chars 0AEFGJKLMNPQRSTUWXY) 18 ; PB= pay basis-code for time condition for computing pay. 19 ; TA= type of appointment (career, career conditional, etc.) 20 ; OCC= 4 digit cost center for fund appropriation accounting 21 ; LVG= one digit code for employees leave group. 22 ; ASS= specialty assignment of physicians,dentists, nurses, 23 ; summer employees,trainees and other special programs. 24 ; ENT= 39 character entitlement string 25 ; PMP = Premium Pay Code 26 ; 27 N PAYPDTMP,PPLOLD,DUTYTEMP,FLSATEMP 28 ; 29 S C0=^PRSPC(DFN,0) 30 ; 31 ; pay plan in master record. 32 S PP=$P(C0,"^",21) 33 ; 34 ;===================================================================== 35 ; duty basis from master record 36 S DUTYTEMP=$P(C0,"^",10) 37 ; 38 ; FLSA indicator from master record 39 S FLSATEMP=$P(C0,"^",12) 40 ; 41 ;Make sure we've called this routine from an entry point that uses 42 ;PY for pay period. A few reports, call PRSAENT from TYPSTF^PRSRUT0 43 ;and the reports aren't concerned about differing pay plans from 44 ;other pay periods. 45 ; 46 I +($G(PY))>0 D 47 .S PAYPDTMP=$P($G(^PRST(458,+PY,0)),"^") ;pay period we're working with. 48 .S PPLOLD=$$OLDPP^PRS8UT(PAYPDTMP,+DFN) ;pay plan from PAYPDTMP. 49 .;if we find an old pay plan and it's different than the master record 50 .;use the old pay plan to determine VCS or FEE. 51 .I PPLOLD'=0,(PP'=PPLOLD) D 52 .. S PP=PPLOLD 53 .. S DUTYTEMP=OLDPP("DUTYBS") 54 ;===================================================================== 55 ; 56 ; Numeric Pay plans are all Wage grade. Set them to 0. 57 S:PP?1N PP=0 58 ; 59 ; 60 S:"BC"[PP PP="A" 61 I "0AEFGJKLMNPQRSTUWXY"'[PP D NO Q 62 S NH=+$P(C0,"^",16) 63 S FLX=$P($G(^PRSPC(DFN,1)),"^",7) 64 S PMP=$P($G(^PRSPC(DFN,"PREMIUM")),"^",6) 65 S AC=PP_DUTYTEMP_FLSATEMP 66 I $L(AC)'=3 D NO Q 67 ; 68 ; 69 D @PP 70 D FND 71 Q 72 ;=========================================================== 73 ; 74 0 Q 75 ; 76 A ;patch 45: firefighters entitlements are based on PMP Codes. 77 ; Code O still uses nh>80 to determine entitlement. 78 I "RC"[PMP S AC=AC_PMP Q 79 ; 80 ;This check does not concern itself with whether or not a code 81 ; O is present. Simply if not a code R or C then an over 80 82 ; must be a code O firefighter under the rules implemented in 83 ; patch 45. 84 ; 85 I "CR"'[PMP,NH>80 S AC=AC_"*" Q 86 ; 87 Q:PMP="" 88 I $E(AC,2)'=3,"WXY"[PMP S AC=AC_PMP Q 89 S:"EF"[PMP AC=AC_"E" 90 ;The following check is for Public Law 108-170 91 S:"STUV"[PMP AC=AC_PMP 92 Q 93 E Q 94 F Q 95 G I $E(AC,2)<3 Q 96 S TA=$P(C0,"^",43) S:TA=8 AC=AC_"8" Q 97 J Q 98 K S:NH=48 AC=AC_"B" Q 99 L I $E(AC,2)=2 S PB=$P(C0,"^",20) S:PB=0 AC=AC_"*" Q 100 I $E(AC,2)=3 S OCC=$P(C0,"^",17),OCC=+$E(OCC,5,6) S:OCC>20&(OCC<38) AC=AC_"*" Q 101 S LVG=$P(C0,"^",15) S:LVG=5 AC=AC_"*" Q 102 M I $E(AC,2)=1,NH=48 S AC=AC_"B" Q 103 I $E(AC,2)=2 S PB=$P(C0,"^",20) I PB=0 S AC=AC_"0" Q 104 I $E(AC,2)=3 S PB=$P(C0,"^",20) I PB=2 S AC=AC_"2" Q 105 S OCC=$P(C0,"^",17) S:OCC="" OCC="*" 106 S:" 061056 061057 "[OCC AC=AC_"T" 107 S:" 061071 061072 061080 061083 061084 "[OCC AC=AC_"T" 108 S:" 060552 060556 "[OCC AC=AC_"T" Q 109 N S ASS=$P(C0,"^",4),PB=$P(C0,"^",20) 110 ;The following check is for Public Law 108-170 111 I "^S^T^U^V^"[("^"_PMP_"^") S AC=AC_PMP Q 112 I AC="N2E",PB=0 S AC=AC_"0" Q 113 I $E(AC,2)=3,PB="S" S AC=AC_"$" Q 114 S OCC=$P(C0,"^",17) S:OCC="" OCC="*" 115 I OCC="069961" S AC=AC_"T" Q ; Student Nurse Technician 116 I OCC="069964" S AC=AC_"T" Q ; Student Nurse Technician 117 S AC=AC_$S(ASS="TR":"T",ASS?1"T"1N:"T",ASS?1"A"1N:"T",1:"") Q 118 P Q 119 Q I $E(AC,2)'=2 Q 120 S PB=$P(C0,"^",20) S:PB=0 AC=AC_"0" Q 121 R Q 122 S Q 123 T I $E(AC,2)'=3 Q 124 S PB=$P(C0,"^",20) S:PB=9 AC=AC_"9" Q 125 U S PB=$P(C0,"^",20) I $E(AC,3)="N",PB="P" S AC=AC_"P" 126 Q 127 W Q 128 X S:'NH AC=AC_"0" Q 129 Y Q 130 ; 131 ;= = = = = = = = = = = = = = = = = = = = = = = = 132 FND ;Look up the 39 character entitlement string in the entitlement table 133 ;The lookup is based on the AC x-ref that matches the AC variable that 134 ;is built in this routine from the three 1 character codes from the 135 ;450 fields (pay plan, duty basis, FLSA). 136 ; 137 S A1=$O(^PRST(457.5,"AC",AC,0)) 138 D NO 139 I +A1 S ENT=^PRST(457.5,A1,1) 140 ; The following check was added to address the Hybrid employees 141 ; defined in Public Law 107-135. These Hybrids do not have a 142 ; Premium Pay Indicator but are entitled to Saturday and Sunday 143 ; Premium Pay. 144 I $$HYBRID^PRSAENT1(DFN) D 145 . S $E(ENT,8,9)="11" 146 ; 147 Q 148 ;= = = = = = = = = = = = = = = = = = = = = = = = 149 NO S ENT="" 150 Q 151 ; 152 MLINHRS(IEN) ; 153 ;---------------------------------------------------------------------- 154 ; Determine if the employee is entitled to Military Leave in hours. 155 ; 156 ; Input Vars: 157 ; IEN - the ien number of the employee in the PAID EMPLOYEE (#450) 158 ; file. 159 ; 160 ; Local Vars: 161 ; DATA - the 0 node of the employee from the PAID EMPLOYEE (#450) 162 ; file. 163 ; DB - Duty Basis field #9 from the #450 file. 164 ; NH - Normal Hours field # 15 from the #450 file. 165 ; PP - Pay Plan field # 20 from the #450 file. 166 ; 167 ; Output: 168 ; 1 : Entitled to ML in hours. 169 ; 0 : Entitled to ML in days. 170 ; X : Some of the required fields were not defined or the employee 171 ; is not entitled to Military Leave. 172 ;---------------------------------------------------------------------- 173 ; Quit if no IEN passed in 174 ; 175 Q:'+IEN "X" 176 ; 177 ; Verify that ENT is defined. If not call PRSAENT to define it. 178 ; 179 I '$D(ENT) D PRSAENT 180 ; 181 ; Quit if the Entitlement string is not defined for the employee 182 ; 183 Q:ENT="" "X" 184 ; 185 ; Quit if the employee is not entitled to Military Leave 186 ; 187 Q:'$E(ENT,34) "X" 188 ; 189 N DATA,PP,DB,NH 190 S DATA=$G(^PRSPC(IEN,0)) 191 Q:DATA="" "X" 192 S DB=$P(DATA,U,10),NH=$P(DATA,U,16),PP=$P(DATA,U,21) 193 Q:DB=""!(NH="")!(PP="") "X" ; Quit if DB or NH or PP is not defined. 194 ; 195 ; Check for ML in Days 196 ; 197 I DB=1,NH=0,"^J^L^P^Q^X^"[PP Q 0 198 ; 199 ; Otherwise the employee is entitled to ML in hours. 200 ; 201 Q 1 -
WorldVistAEHR/trunk/r/PAID-PRS/PRSAENX.m
r613 r623 1 PRSAENX ; HISC/REL-List Entitlement ;3/12/93 12:58 2 ;;4.0;PAID;**34,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 K DIC S DIC="^PRST(457.5,",DIC(0)="AEQM" W ! D ^DIC G:Y<1 EX S ENT=^PRST(457.5,+Y,1),NAM=$P(Y,"^",2) 5 W ! K IOP,%ZIS S %ZIS("A")="Select Device: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP EX 6 I $D(IO("Q")) S PRSAPGM="Q1^PRSAENX",PRSALST="NAM^ENT" D QUE^PRSAUTL G EX 7 U IO D Q1 D ^%ZISC K %ZIS,IOP G EX 8 Q1 ; Display Entitlement Entry 9 W:$E(IOST,1,2)="C-" @IOF W !?29,"PAY ENTITLEMENT TABLE" 10 W !,"Name: ",NAM,! D Q2 11 I $E(IOST,1,2)="C-" R !!,"Press RETURN to Continue. ",X:DTIME 12 Q 13 Q2 ; Display Entitlement List 14 S M("H")="Hrs.",M("D")="Days",M(0)="No",M(1)="Yes" 15 F K=1:1:19 W !,$P($T(ENT+K),";;",2),?30,M($E(ENT,K)),?40,$P($T(ENT+K+19),";;",2),?70,M($E(ENT,K+19)) 16 Q 17 EX G KILL^XUSCLEAN 18 ENT ;; 19 1 ;;Regular Scheduled 20 2 ;;Regular Unscheduled 21 3 ;;FF Reg. Sch. Hrs. Over 53 22 4 ;;Reserved for future use 23 5 ;;Recess Periods 24 6 ;;Night Differential - 2 25 7 ;;Night Differential - 3 26 8 ;;Saturday Premium 27 9 ;;Sunday - Day 28 10 ;;Sunday - 2 29 11 ;;Sunday - 3 30 12 ;;Overtime - Day 31 13 ;;Overtime - 2 32 14 ;;Overtime - 3 33 15 ;;Hazardous Duty 34 16 ;;Environmental Differential 35 17 ;;Scheduled CB OT 36 18 ;;Travel OT 37 19 ;;Hrs. >8 - Day 38 20 ;;Hrs. > 8 - 2 39 21 ;;Hrs. > 8 - 3 40 22 ;;Holiday - Day 41 23 ;;Holiday - 2 42 24 ;;Holiday - 3 43 25 ;;Holiday OT 44 26 ;;On Call 45 27 ;;Sleep Time 46 28 ;;CompTime/CreditHrs Earn/Use 47 29 ;;Standby 48 30 ;;Annual/Restored Leave 49 31 ;;Sick Leave 50 32 ;;NonPay Annual Leave 51 33 ;;AWOL/Susp/LWOP 52 34 ;;Military Leave 53 35 ;;Authorized Absence 54 36 ;;Non-Pay 55 37 ;;Continuation of Pay 56 38 ;;VCS Commission Sales 57 39 ;;FireFighter Overtime 1 PRSAENX ; HISC/REL-List Entitlement ;3/12/93 12:58 2 ;;4.0;PAID;**34**;Sep 21, 1995 3 K DIC S DIC="^PRST(457.5,",DIC(0)="AEQM" W ! D ^DIC G:Y<1 EX S ENT=^PRST(457.5,+Y,1),NAM=$P(Y,"^",2) 4 W ! K IOP,%ZIS S %ZIS("A")="Select Device: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP EX 5 I $D(IO("Q")) S PRSAPGM="Q1^PRSAENX",PRSALST="NAM^ENT" D QUE^PRSAUTL G EX 6 U IO D Q1 D ^%ZISC K %ZIS,IOP G EX 7 Q1 ; Display Entitlement Entry 8 W:$E(IOST,1,2)="C-" @IOF W !?29,"PAY ENTITLEMENT TABLE" 9 W !,"Name: ",NAM,! D Q2 10 I $E(IOST,1,2)="C-" R !!,"Press RETURN to Continue. ",X:DTIME 11 Q 12 Q2 ; Display Entitlement List 13 S M("H")="Hrs.",M("D")="Days",M(0)="No",M(1)="Yes" 14 F K=1:1:19 W !,$P($T(ENT+K),";;",2),?30,M($E(ENT,K)),?40,$P($T(ENT+K+19),";;",2),?70,M($E(ENT,K+19)) 15 Q 16 EX G KILL^XUSCLEAN 17 ENT ;; 18 1 ;;Regular Scheduled 19 2 ;;Regular Unscheduled 20 3 ;;Reg. Hrs. at OT Rate - Day 21 4 ;;Reg. Hrs. at OT Rate - 2 22 5 ;;Reg. Hrs. at OT Rate - 3 23 6 ;;Night Differential - 2 24 7 ;;Night Differential - 3 25 8 ;;Saturday Premium 26 9 ;;Sunday - Day 27 10 ;;Sunday - 2 28 11 ;;Sunday - 3 29 12 ;;Overtime - Day 30 13 ;;Overtime - 2 31 14 ;;Overtime - 3 32 15 ;;Hazardous Duty 33 16 ;;Environmental Differential 34 17 ;;Scheduled CB OT 35 18 ;;Travel OT 36 19 ;;Hrs. >8 - Day 37 20 ;;Hrs. > 8 - 2 38 21 ;;Hrs. > 8 - 3 39 22 ;;Holiday - Day 40 23 ;;Holiday - 2 41 24 ;;Holiday - 3 42 25 ;;Holiday OT 43 26 ;;On Call 44 27 ;;Sleep Time 45 28 ;;CompTime/CreditHrs Earn/Use 46 29 ;;Standby 47 30 ;;Annual/Restored Leave 48 31 ;;Sick Leave 49 32 ;;NonPay Annual Leave 50 33 ;;AWOL/Susp/LWOP 51 34 ;;Military Leave 52 35 ;;Authorized Absence 53 36 ;;Non-Pay 54 37 ;;Continuation of Pay 55 38 ;;VCS Commission Sales 56 39 ;;FireFighter Overtime -
WorldVistAEHR/trunk/r/PAID-PRS/PRSALVS.m
r613 r623 1 PRSALVS ;HISC/REL-Display Leave Request ;11/21/06 2 ;;4.0;PAID;**9,69,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 S DFN="",SSN=$P($G(^VA(200,DUZ,1)),"^",9) I SSN'="" S DFN=$O(^PRSPC("SSN",SSN,0)) 5 I 'DFN W !!,*7,"Your SSN was not found in both the New Person & Employee File!" G EX 6 D HDR 7 K %DT S %DT="AEX",%DT("A")="Begin with Date: ",%DT("B")="T" W ! D ^%DT K %DT S:$D(DTOUT) Y=0 G:Y<1 EX S EDT=9999999-Y 8 W ! S NUM=0 D DISP,H1 G EX 9 DISP ; Display Leave Requests 10 S LVT=";"_$P(^DD(458.1,6,0),"^",3),LVS=";"_$P(^DD(458.1,8,0),"^",3),CNT=0,QT=0 K:NUM R 11 F DTI=0:0 S DTI=$O(^PRST(458.1,"AD",DFN,DTI)) Q:DTI=""!(DTI>EDT) F DA=0:0 S DA=$O(^PRST(458.1,"AD",DFN,DTI,DA)) Q:DA="" D LST G:QT D0 12 W:'CNT !,"No Requests on File." 13 D0 Q 14 LST ; Display Request 15 S Z=$G(^PRST(458.1,DA,0)) Q:Z="" Q:$P(Z,"^",9)="X" S SCOM=$P($G(^(1)),"^",1) I NUM,$P(Z,"^",9)'="R" Q:"D"[$P(Z,"^",9) D Q:Z="" 16 .S X=$P(Z,"^",3),X=$G(^PRST(458,"AD",+X)) 17 .S Y=$G(^PRST(458,+$P(X,"^",1),"E",DFN,"D",+$P(X,"^",2),2)) 18 .Q:Y'[$P(Z,"^",7) S Z="" Q 19 I CNT D:$Y>(IOSL-4) H1 Q:QT 20 S CNT=CNT+1 W ! I NUM W $J(CNT,2)," " S R(CNT)=DA 21 W $P(Z,"^",4)," " S X=$P(Z,"^",3) D DTP^PRSAPPU W Y," to ",$P(Z,"^",6)," " 22 S X=$P(Z,"^",5) D DTP^PRSAPPU W Y," " 23 S X=$P(Z,"^",15) I X W X," ",$S($P(Z,"^",16)="D":"days",1:"hrs")," " 24 S X=$P(Z,"^",7),%=$F(LVT,";"_X_":") I %>0 W $P($E(LVT,%,999),";",1)," " 25 S X=$P(Z,"^",9) 26 S %=$F(LVS,";"_X_":") I %>0 W $P($E(LVS,%,999),";",1) 27 S X=$P(Z,"^",8) W:X'="" !?5,X S Y=$P(Z,"^",11) D DTP^PRSAUDP W !?5,"Requested: ",Y 28 W:SCOM'="" !?5,"Supr: ",SCOM Q 29 BAL ; Leave Balance 30 N CNT,PPE S Z=$P($G(^PRST(458.1,DA,0)),"^",7),(BAL,INC,CNT)="" Q:Z="" 31 I "CB AD"[Z N Z S Z="SL" 32 Q:"AL SL CU ML RL"'[Z D ^PRSALVT I NH'=48!(DB'=1) G B0 33 I Z="AL" S BAL=$P($G(^PRSPC(DFN,"BAYLOR")),"^",1) G B2 34 I Z="SL" S BAL=$P($G(^PRSPC(DFN,"BAYLOR")),"^",13) G B2 35 I Z="RL" S BAL=$G(^PRSPC(DFN,"BAYLOR")),BAL=$P(BAL,"^",9)+$P(BAL,"^",10) G B2 36 G B1 37 B0 I Z="AL" S BAL=$P($G(^PRSPC(DFN,"ANNUAL")),"^",3) G B2 38 I Z="SL" S BAL=$P($G(^PRSPC(DFN,"SICK")),"^",3) G B2 39 I Z="RL" S BAL=$G(^PRSPC(DFN,"ANNUAL")),BAL=$P(BAL,"^",10)+$P(BAL,"^",11) G B2 40 B1 I Z="ML" S BAL=$P($G(^PRSPC(DFN,"MILITARY")),"^",1) G B2 41 Q:Z'="CU" S Z="CT",Y=$G(^PRSPC(DFN,"COMP")) 42 F K=1:1:8 S BAL=BAL+$P(Y,"^",K) 43 B2 S LST=+$P($G(^PRSPC(DFN,"MISC4")),"^",16),D1=DT D PP^PRSAPPU S YR=$P(PPE,"-",1) 44 S D1=+$P(PPE,"-",2),YR=$S(D1'<LST:YR,1:$E(199+YR,2,3)),PPE=YR_"-"_$S(LST>9:LST,1:"0"_LST) 45 S PPI=$O(^PRST(458,"B",PPE,0)),SDT=DT I PPI S D1=$P($G(^PRST(458,PPI,2)),"^",14),SDT=$P($G(^(1)),"^",14) 46 I PRT W !,Z," Leave Balance: ",$S(Z="ML":$J(BAL,13,2),1:$J(BAL,13,3))," as of ",D1 47 I "AL SL"'[Z Q 48 S EDT=$P($G(^PRST(458.1,DA,0)),"^",5) I EDT'>SDT G B3 49 S X1=EDT,X2=SDT D ^%DTC S INC=X+13\14*$S(Z="AL":AINC,1:SINC) 50 I NH=80,DB=2 S X1=EDT,X2=X+13\14*14-X D C^%DTC S INC=INC-$$RT(X,SDT) S:INC<0 INC=0 51 I PRT W !,Z," Estimated Earnings: ",$J(INC,8,3) 52 S LST=9999999-SDT,CNT=0 53 F DTI=0:0 S DTI=$O(^PRST(458.1,"AD",DFN,DTI)) Q:DTI=""!(DTI>LST) F RDA=0:0 S RDA=$O(^PRST(458.1,"AD",DFN,DTI,RDA)) Q:RDA="" I $G(^(RDA))'>EDT D 54 .S Z1=$G(^PRST(458.1,RDA,0)) S X1=$P(Z1,"^",7) S:"CB AD"[X1 X1="SL" Q:X1'=Z Q:"AR"'[$P(Z1,"^",9) 55 .I NH=72,DB=1 S $P(Z1,U,15)=$$LC($P(Z1,U,15)) 56 .S CNT=CNT+$P(Z1,"^",15) 57 .I $P(Z1,"^",3)'<SDT,$P(Z1,"^",5)'>EDT Q 58 .S X1=$P(Z1,"^",5),X2=$P(Z1,"^",3) D ^%DTC S Z3=$P(Z1,"^",15)/$S($G(X):X,1:1) 59 .I $P(Z1,"^",3)<SDT S X1=SDT,X2=$P(Z1,"^",3) D ^%DTC I X>0 S CNT=CNT-(X*Z3) 60 .I $P(Z1,"^",5)>EDT S X1=$P(Z1,"^",5),X2=EDT D ^%DTC I X>0 S CNT=CNT-(X*Z3) 61 .Q 62 I PRT W !,Z," Estimated Usage: ",$J(CNT,11,3) 63 B3 S BAL=BAL+INC-CNT I PRT W !,Z," Projected Balance: ",$J(BAL,9,3) 64 I PRT,BAL<0 W !,"Warning: Approval MAY result in a negative leave balance." 65 Q 66 HDR ; Display Header 67 W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM",!?32,"LEAVE REQUESTS" 68 S X=$G(^PRSPC(DFN,0)) W !!,$P(X,"^",1) S X=$P(X,"^",9) I X W ?50,"XXX-XX-",$E(X,6,9) Q 69 H1 I $E(IOST,1,2)="C-" R !!,"Press RETURN to Continue.",X:DTIME S:'$T!(X["^") QT=1 I 'QT W @IOF,! 70 Q 71 EX G KILL^XUSCLEAN 72 ;Multiply leave request by 1.111 and round down to the quarter hour 73 ;for 36/40 nurses 74 LC(X) S X=X*1.111\.25*.25 Q X 75 ;Calculate number of Recess hours scheduled for a 9-month AWS Nurse 76 ;before the date leave has been requested for 77 RT(EDT,SDT) N SFY,EFY,T,WK 78 S SFY=$E($P($$GETFSCYR^PRSARC04(SDT),U,2),3,6),EFY=$E($P($$GETFSCYR^PRSARC04(EDT),U,2),3,6) 79 D RES^PRSARC05(.WK,DFN,SFY,EFY,SDT,EDT) S (I,T)=0 F S I=$O(WK(I)) Q:I="" S T=T+WK(I) 80 ;Calculate the number of hours of leave that would have been 81 ;accumulated for the time the nurse was on recess. 82 Q T/80*$S(Z="AL":AINC,1:SINC)\.25*.25 1 PRSALVS ;HISC/REL-Display Leave Request ;09/21/01 2 ;;4.0;PAID;**9,69**;Sep 21, 1995 3 S DFN="",SSN=$P($G(^VA(200,DUZ,1)),"^",9) I SSN'="" S DFN=$O(^PRSPC("SSN",SSN,0)) 4 I 'DFN W !!,*7,"Your SSN was not found in both the New Person & Employee File!" G EX 5 D HDR 6 K %DT S %DT="AEX",%DT("A")="Begin with Date: ",%DT("B")="T" W ! D ^%DT K %DT S:$D(DTOUT) Y=0 G:Y<1 EX S EDT=9999999-Y 7 W ! S NUM=0 D DISP,H1 G EX 8 DISP ; Display Leave Requests 9 S LVT=";"_$P(^DD(458.1,6,0),"^",3),LVS=";"_$P(^DD(458.1,8,0),"^",3),CNT=0,QT=0 K:NUM R 10 F DTI=0:0 S DTI=$O(^PRST(458.1,"AD",DFN,DTI)) Q:DTI=""!(DTI>EDT) F DA=0:0 S DA=$O(^PRST(458.1,"AD",DFN,DTI,DA)) Q:DA="" D LST G:QT D0 11 W:'CNT !,"No Requests on File." 12 D0 Q 13 LST ; Display Request 14 S Z=$G(^PRST(458.1,DA,0)) Q:Z="" Q:$P(Z,"^",9)="X" S SCOM=$P($G(^(1)),"^",1) I NUM,$P(Z,"^",9)'="R" Q:"D"[$P(Z,"^",9) D Q:Z="" 15 .S X=$P(Z,"^",3),X=$G(^PRST(458,"AD",+X)) 16 .S Y=$G(^PRST(458,+$P(X,"^",1),"E",DFN,"D",+$P(X,"^",2),2)) 17 .Q:Y'[$P(Z,"^",7) S Z="" Q 18 I CNT D:$Y>(IOSL-4) H1 Q:QT 19 S CNT=CNT+1 W ! I NUM W $J(CNT,2)," " S R(CNT)=DA 20 W $P(Z,"^",4)," " S X=$P(Z,"^",3) D DTP^PRSAPPU W Y," to ",$P(Z,"^",6)," " 21 S X=$P(Z,"^",5) D DTP^PRSAPPU W Y," " 22 S X=$P(Z,"^",15) I X W X," ",$S($P(Z,"^",16)="D":"days",1:"hrs")," " 23 S X=$P(Z,"^",7),%=$F(LVT,";"_X_":") I %>0 W $P($E(LVT,%,999),";",1)," " 24 S X=$P(Z,"^",9) 25 S %=$F(LVS,";"_X_":") I %>0 W $P($E(LVS,%,999),";",1) 26 S X=$P(Z,"^",8) W:X'="" !?5,X S Y=$P(Z,"^",11) D DTP^PRSAUDP W !?5,"Requested: ",Y 27 W:SCOM'="" !?5,"Supr: ",SCOM Q 28 BAL ; Leave Balance 29 N CNT,PPE S Z=$P($G(^PRST(458.1,DA,0)),"^",7),(BAL,INC,CNT)="" Q:Z="" 30 I "CB AD"[Z N Z S Z="SL" 31 Q:"AL SL CU ML RL"'[Z D ^PRSALVT I NH'=48!(DB'=1) G B0 32 I Z="AL" S BAL=$P($G(^PRSPC(DFN,"BAYLOR")),"^",1) G B2 33 I Z="SL" S BAL=$P($G(^PRSPC(DFN,"BAYLOR")),"^",13) G B2 34 I Z="RL" S BAL=$G(^PRSPC(DFN,"BAYLOR")),BAL=$P(BAL,"^",9)+$P(BAL,"^",10) G B2 35 G B1 36 B0 I Z="AL" S BAL=$P($G(^PRSPC(DFN,"ANNUAL")),"^",3) G B2 37 I Z="SL" S BAL=$P($G(^PRSPC(DFN,"SICK")),"^",3) G B2 38 I Z="RL" S BAL=$G(^PRSPC(DFN,"ANNUAL")),BAL=$P(BAL,"^",10)+$P(BAL,"^",11) G B2 39 B1 I Z="ML" S BAL=$P($G(^PRSPC(DFN,"MILITARY")),"^",1) G B2 40 Q:Z'="CU" S Z="CT",Y=$G(^PRSPC(DFN,"COMP")) 41 F K=1:1:8 S BAL=BAL+$P(Y,"^",K) 42 B2 S LST=+$P($G(^PRSPC(DFN,"MISC4")),"^",16),D1=DT D PP^PRSAPPU S YR=$P(PPE,"-",1) 43 S D1=+$P(PPE,"-",2),YR=$S(D1'<LST:YR,1:$E(199+YR,2,3)),PPE=YR_"-"_$S(LST>9:LST,1:"0"_LST) 44 S PPI=$O(^PRST(458,"B",PPE,0)),SDT=DT I PPI S D1=$P($G(^PRST(458,PPI,2)),"^",14),SDT=$P($G(^(1)),"^",14) 45 I PRT W !,Z," Leave Balance: ",$S(Z="ML":$J(BAL,13,2),1:$J(BAL,13,3))," as of ",D1 46 I "AL SL"'[Z Q 47 S EDT=$P($G(^PRST(458.1,DA,0)),"^",5) I EDT'>SDT G B3 48 S X1=EDT,X2=SDT D ^%DTC S INC=X+13\14*$S(Z="AL":AINC,1:SINC) 49 I PRT W !,Z," Estimated Earnings: ",$J(INC,8,3) 50 S LST=9999999-SDT,CNT=0 51 F DTI=0:0 S DTI=$O(^PRST(458.1,"AD",DFN,DTI)) Q:DTI=""!(DTI>LST) F RDA=0:0 S RDA=$O(^PRST(458.1,"AD",DFN,DTI,RDA)) Q:RDA="" I $G(^(RDA))'>EDT D 52 .S Z1=$G(^PRST(458.1,RDA,0)) S X1=$P(Z1,"^",7) S:"CB AD"[X1 X1="SL" Q:X1'=Z Q:"AR"'[$P(Z1,"^",9) 53 .S CNT=CNT+$P(Z1,"^",15) 54 .I $P(Z1,"^",3)'<SDT,$P(Z1,"^",5)'>EDT Q 55 .S X1=$P(Z1,"^",5),X2=$P(Z1,"^",3) D ^%DTC S Z3=$P(Z1,"^",15)/$S($G(X):X,1:1) 56 .I $P(Z1,"^",3)<SDT S X1=SDT,X2=$P(Z1,"^",3) D ^%DTC I X>0 S CNT=CNT-(X*Z3) 57 .I $P(Z1,"^",5)>EDT S X1=$P(Z1,"^",5),X2=EDT D ^%DTC I X>0 S CNT=CNT-(X*Z3) 58 .Q 59 I PRT W !,Z," Estimated Usage: ",$J(CNT,11,3) 60 B3 S BAL=BAL+INC-CNT I PRT W !,Z," Projected Balance: ",$J(BAL,9,3) 61 I PRT,BAL<0 W !,"Warning: Approval MAY result in a negative leave balance." 62 Q 63 HDR ; Display Header 64 W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM",!?32,"LEAVE REQUESTS" 65 S X=$G(^PRSPC(DFN,0)) W !!,$P(X,"^",1) S X=$P(X,"^",9) I X W ?50,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9) Q 66 H1 I $E(IOST,1,2)="C-" R !!,"Press RETURN to Continue.",X:DTIME S:'$T!(X["^") QT=1 I 'QT W @IOF,! 67 Q 68 EX G KILL^XUSCLEAN -
WorldVistAEHR/trunk/r/PAID-PRS/PRSAOTT.m
r613 r623 1 PRSAOTT ;WCIOFO/JAH/PLT- 8B CODES ARRAY. COMPARE OT (8B-vs-APPROVED). ;11/29/2006 2 ;;4.0;PAID;**37,43,54,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;Function & subroutine Index for this routine. 6 ; 7 ; APOTWEEK(PAYPRD,WEEKID,EMP450).....return all approved OT in a week. 8 ; ARRAY8B(RECORD)...............Build employee 8B array for payperiod. 9 ; CODES(WEEK)........return string of valid time codes for week 1,2,3. 10 ; GET8BCDS(TT8B).................return timecode portion of 8B string. 11 ; GET8BOT(EMPIEN,WEEK,TT8B)..........return all OT in an 8b string. 12 ; GETOTS(PP,EI,T8,WK,.O8,.OA)......Get overtimes (tt8b & approved). 13 ; OTREQ(REC).................returns true if Request is type Overtime. 14 ; OTAPPR(REC)...................returns true if a Request is Approved. 15 ; WEEKRNG(PPE,WEEK,FIRST,LAST)........1st & last FM days in a pp week. 16 ; WARNSUP(PPE,EI,E8B,WK,OTERR,O8,OA)... check ot's for a week & warn. 17 Q 18 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 19 GETOTS(PP,EI,T8,WK,O8,OA) ;Get overtimes (tt8b & approved) 20 ; Sample call: 21 ; D GETOTS("98-05",1255,TT8BSTRING,1,.O8,.OA) 22 ; where TT8BSTRING might be = 23 ; "658229548868WIL 8B268380A106 AN320NA060DA030NR300SE080CD000790" 24 ; 25 ; subroutine returns overtime from request file & TT8B string for 26 ; week specified in parameter 4 27 ; 28 ; Input: PP - Pay period in format YY-PP. 29 ; EI - Employees ien from file 450. 30 ; T8 - Entire 8B record. Stored in 31 ; ^PRST(458,PP,"E",EI,5). 32 ; Output: O8 - TT8B overtime calculated 33 ; OA - approved overtime in request fiLE 34 ; 35 S (OA,O8)=0 36 Q:((WK'=1)&(WK'=2)) 37 ; 38 S O8=$$GET8BOT^PRSAOTT(EI,WK,T8) ; get all OT from 8b string 39 S OA=$$APOTWEEK^PRSAOTT(PP,WK,EI) ; get approved overtime 40 Q 41 ; 42 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 43 WARNSUP(PPE,EI,E8B,WK,OTERR,O8,OA) ;Gets overtime from request 44 ; file & TT8B string & displays warning if 8B string has more 45 ; OT than approved requests. 46 ; 47 ;Input: PPE - (P)ay (P)eriod (E)xternal in format YY-PP. 48 ; EI - (E)mployees (I)nternal entry # from file 450. 49 ; E8B - (E)ntire (8B) record. Stored in ^PRST(458,PP,"E",EI,5). 50 ; WK - week number 1 or 2 of pay period. 51 ;Output: Warning message to screen. 52 ;Local: OA - (O)vertime (A)pproved from requests file. 53 ; O8 - (O)vertime totaled from (8)b string. 54 ; 55 S (OA,O8,OTERR)=0 56 ; Compare week of approved ot requests to 8B OT. 57 S O8=$$GET8BOT(EI,WK,E8B) ; get all OT from 8b string 58 S OA=$$APOTWEEK(PPE,WK,EI) ; get approved overtime 59 I OA<O8 D DISPLAY(EI,O8,OA,WK) S OTERR=1 ; Display warning if calc>apprv 60 Q 61 ; 62 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 63 DISPLAY(IEN,OT8B,OTRQ,WK) ;Output warning message. 8b ot > approved ot. 64 ; 65 ; Input: IEN - employees 450 ien. 66 ; OT8B - employees total overtime calculated from 8b string. 67 ; OTRQ - employees total approved OT request's from 458.2 68 ; WK - week 1 or 2 of payperiod. 69 ; 70 W !,?3,"WARNING: Week ",WK," -Overtime being paid (",OT8B,") is more than approved (",OTRQ,")." 71 Q 72 ; 73 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 74 GET8BOT(EMPIEN,WEEK,TT8B) ; 75 ; Output: Function returns total hrs of overtime that is coded 76 ; into TT8B string for either week (1) or (2). 77 ; Input: EMPIEN - internal entry # of employee to check 8B overtime 78 ; WEEK - week (1) or (2) of pay period to check 8B overtime. 79 ; TT8B - full 8B string stub & values. 80 ; 81 N PPIEN,TT8BOT,OTCODES,CODE,OTTOTAL,OTTMP 82 S OTTOTAL=0 83 ; 84 ; get time coded portion of 8B string 85 ; 86 S TT8B=$$GET8BCDS(TT8B) 87 Q:$L(TT8B)<2 OTTOTAL ; Aint no coded OT if there aint no codes. 88 ; 89 ; create array of codes & values for this 8b string. 90 D ARRAY8B(TT8B) 91 ; 92 ; create string with all overtime codes. 93 S OTCODES=$S(WEEK=1:"^DA^DB^DC^OA^OB^OC^OK^",1:"^DE^DF^DG^OE^OF^OG^OS^") 94 ; Only count total regular hours @ OT rate when not a firefighter 95 ; with premium pay code "R" or "C". These firefighters get RA/RE from 96 ; their scheduled tour and do not need to have overtime requests. *54 97 I "^R^C^"'[(U_$P($G(^PRSPC(EMPIEN,"PREMIUM")),U,6)_U) D 98 . S OTCODES=OTCODES_$S(WEEK=1:"RA^RB^RC^",1:"RE^RF^RG^") 99 ; 100 ; loop thru employees 8b array to see if they have any of 101 ; overtime codes & add any of them up. 102 ; 103 S CODE="" 104 F S CODE=$O(TT8B(WEEK,CODE)) Q:CODE="" D 105 . I OTCODES[("^"_CODE_"^") D 106 .. S OTTMP=TT8B(WEEK,CODE) 107 .. S OTTOTAL=OTTOTAL+$E(OTTMP,1,2)+($E(OTTMP,3)*.25) 108 Q OTTOTAL 109 ; 110 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 111 ; 112 APOTWEEK(PAYPRD,WEEKID,EMP450) ; 113 ;Function returns approved overtime totals for a week. 114 ;Input: PPE,PAYPRD - pay period of concern. YY-PP 115 ; WEEKID - week (1) or week (2) of pay period 116 ; EMP450 - employees internal entry number in file 450. 117 ;Output: TOTALOT - total hrs of overtime for a week 118 ; 119 ;local vars: D1 - 1st day of payperiod-returned by NX^PRSAPPU 120 ; OTREC - a record containing 1 overtime request. 121 ; START,STOP - 1st & last FM days of week (Sun,Sat) 122 ; 123 ; quit returning 0 if anything is missing. 124 Q:$G(PAYPRD)=""!$G(WEEKID)=""!$G(EMP450)="" 0 125 ; 126 ; Loop thru OT/CT requests file x-ref on requested work date & 127 ; add up all employees approved OT requests within week. 128 ; 129 N D1,PPE,TOTALOT,START,STOP,OTREC 130 S TOTALOT=0 131 D WEEKRNG(PAYPRD,WEEKID,.START,.STOP) 132 S D1=START-.1 133 F S D1=$O(^PRST(458.2,"AD",EMP450,D1)) Q:D1>STOP!(D1="") D 134 . S OTREC="" 135 . F S OTREC=$O(^PRST(458.2,"AD",EMP450,D1,OTREC)) Q:OTREC="" D 136 .. I $$OTREQ(OTREC),$$OTAPPR(OTREC) D 137 ... S TOTALOT=TOTALOT+$P($G(^PRST(458.2,OTREC,0)),"^",6) 138 Q TOTALOT 139 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 140 OTREQ(REC) ;Function returns true if Request is type Overtime. 141 Q:$G(REC)="" 0 142 Q $P($G(^PRST(458.2,REC,0)),"^",5)="OT" 143 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 144 OTAPPR(REC) ;Function returns true if a Request is Approved. 145 Q:$G(REC)="" 0 146 Q "AS"[$P($G(^PRST(458.2,REC,0)),"^",8) 147 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 148 WEEKRNG(PPE,WEEK,FIRST,LAST) ; 149 ; 150 ; Routine takes a pay period & a week number & returns 151 ; 1st & last FileMan days of specified week. 152 ; Input: PPE - pay period in format YY-PP. 153 ; WEEK - week (1) or (2). 154 ; Output: .FIRST - first day of specified week-FM format 155 ; .LAST - last day of specified week-FM format 156 N D1,X1,X2,PPD1 157 D NX^PRSAPPU S PPD1=D1 158 I WEEK=1 D 159 . S (FIRST,X1)=PPD1,X2=6 D C^%DTC S LAST=X 160 E D 161 . S X1=PPD1,X2=7 D C^%DTC S FIRST=X 162 . S X1=PPD1,X2=13 D C^%DTC S LAST=X 163 Q 164 ; 165 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 166 GET8BCDS(TT8B) ; GET 8B time CoDeS 167 ; Input: Full 8b record as stored on node 5 of employee record 168 ; in time & attendance file. 169 ; Output: Function returns section of 8b record with pay 170 ; codes & values. 171 ; 172 ; i.e. return last portion of 8b record ----- <<AN280AL120CD00040>> 173 ; ^PRST(458,,"E",,5)=658226944741FLI 8B256280A112 AN280AL120CD00040 174 ; 175 ; Input: FULL 8B RECORD 176 ; 177 Q $E(TT8B,33,$L(TT8B)) 178 ; 179 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 180 ARRAY8B(RECORD) ; Build employee 8B array. 181 ; calls to this routine are responsible for cleaning up TT8B( array. 182 ; 183 ; Build a TT8B array which contains ONLY codes & values 184 ; that are in employees 8B record. 185 ; 186 ; Input: RECORD - last portion of 8B array with codes & values. 187 ; e.g. <<AN280AL120CD00040>> (see GET8BCDS^PRSAOTT) 188 ; 189 ; Output: array subscripted by time code & set equal to value. 190 ; e.g. TT8B(1,"AN")=010 191 ; TT8B(1,"DA")=020 192 ; TT8B(1,"NA")=020 193 ; TT8B(2,"SL")=080 194 ; TT8B(3,"CD")=000130 195 ; 196 K TT8B S TT8B(0)=0 197 Q:$G(RECORD)="" 198 N EOR,TYPE,VALUE,LOOP,WK 199 S EOR=0 200 F D Q:EOR=1 201 . S TYPE=$E(RECORD,1,2) 202 .; I TYPE="CD" S VALUE=$E(RECORD,3,$L(RECORD)) S EOR=1 203 .; 204 .;traverse record to next code so LOOP gets len of curr code value 205 .; 206 . F LOOP=3:1:$L(RECORD) Q:$E(RECORD,LOOP)?1U 207 . S:LOOP=$L(RECORD) EOR=1 208 . S VALUE=$S(EOR=1:$E(RECORD,3,LOOP),1:$E(RECORD,3,LOOP-1)) 209 . S:EOR=0 RECORD=$E(RECORD,LOOP,$L(RECORD)) 210 .; 211 .;Put code into corresponding week of TT8B array. 212 .; 213 . S WK=$S($F($$CODES(1),TYPE):1,$F($$CODES(2),TYPE):2,$F($$CODES(3),TYPE):3,1:"unknown") 214 . S TT8B(WK,TYPE)=VALUE,TT8B(0)=TT8B(0)+1 215 Q 216 ; 217 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 218 CODES(WEEK) ; 219 ; 8b string can contain any number of codes. Some of codes 220 ; are strictly for types of time in week 1 & some are for week 2. 221 ; There are also pay period codes that are independant from weeks. 222 ; 223 ; This function returns a string of codes for specified 224 ; week (1) or (2) -OR- (3)---8b codes independant of week. 225 ; 226 ; Input: WEEK - week (1) (2) of pay period. 227 ; 228 Q:$G(WEEK)="" 0 229 Q:WEEK=1 "AN SK WD NO AU RT CE CU UN NA NB SP SA SB SC DA DB DC TF OA OB OC YA OK OM RA RB RC HA HB HC PT PA ON YD HD VC EA EB TA TC FA FC AD NT RS ND SR SD" 230 ; 231 Q:WEEK=2 "AL SL WP NP AB RL CT CO US NR NS SQ SE SF SG DE DF DG TG OE OF OG YE OS OU RE RF RG HL HM HN PH PB CL YH HO VS EC ED TB TD FB FD AF NH RN NU SS SH" 232 ; 233 Q:WEEK=3 "NL DW IN TL LU LN LD DT TO LA ML CA PC CY RR FF FE CD" 234 Q 0 1 PRSAOTT ;WCIOFO/JAH- 8B CODES ARRAY. COMPARE OT (8B-vs-APPROVED). ;11/29/1999 2 ;;4.0;PAID;**37,43,54**;Sep 21, 1995 3 ; 4 ;Function & subroutine Index for this routine. 5 ; 6 ; APOTWEEK(PAYPRD,WEEKID,EMP450).....return all approved OT in a week. 7 ; ARRAY8B(RECORD)...............Build employee 8B array for payperiod. 8 ; CODES(WEEK)........return string of valid time codes for week 1,2,3. 9 ; GET8BCDS(TT8B).................return timecode portion of 8B string. 10 ; GET8BOT(EMPIEN,WEEK,TT8B)..........return all OT in an 8b string. 11 ; GETOTS(PP,EI,T8,WK,.O8,.OA)......Get overtimes (tt8b & approved). 12 ; OTREQ(REC).................returns true if Request is type Overtime. 13 ; OTAPPR(REC)...................returns true if a Request is Approved. 14 ; WEEKRNG(PPE,WEEK,FIRST,LAST)........1st & last FM days in a pp week. 15 ; WARNSUP(PPE,EI,E8B,WK,OTERR,O8,OA)... check ot's for a week & warn. 16 Q 17 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 18 GETOTS(PP,EI,T8,WK,O8,OA) ;Get overtimes (tt8b & approved) 19 ; Sample call: 20 ; D GETOTS("98-05",1255,TT8BSTRING,1,.O8,.OA) 21 ; where TT8BSTRING might be = 22 ; "658229548868WIL 8B268380A106 AN320NA060DA030NR300SE080CD000790" 23 ; 24 ; subroutine returns overtime from request file & TT8B string for 25 ; week specified in parameter 4 26 ; 27 ; Input: PP - Pay period in format YY-PP. 28 ; EI - Employees ien from file 450. 29 ; T8 - Entire 8B record. Stored in 30 ; ^PRST(458,PP,"E",EI,5). 31 ; Output: O8 - TT8B overtime calculated 32 ; OA - approved overtime in request fiLE 33 ; 34 S (OA,O8)=0 35 Q:((WK'=1)&(WK'=2)) 36 ; 37 S O8=$$GET8BOT^PRSAOTT(EI,WK,T8) ; get all OT from 8b string 38 S OA=$$APOTWEEK^PRSAOTT(PP,WK,EI) ; get approved overtime 39 Q 40 ; 41 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 42 WARNSUP(PPE,EI,E8B,WK,OTERR,O8,OA) ;Gets overtime from request 43 ; file & TT8B string & displays warning if 8B string has more 44 ; OT than approved requests. 45 ; 46 ;Input: PPE - (P)ay (P)eriod (E)xternal in format YY-PP. 47 ; EI - (E)mployees (I)nternal entry # from file 450. 48 ; E8B - (E)ntire (8B) record. Stored in ^PRST(458,PP,"E",EI,5). 49 ; WK - week number 1 or 2 of pay period. 50 ;Output: Warning message to screen. 51 ;Local: OA - (O)vertime (A)pproved from requests file. 52 ; O8 - (O)vertime totaled from (8)b string. 53 ; 54 S (OA,O8,OTERR)=0 55 ; Compare week of approved ot requests to 8B OT. 56 S O8=$$GET8BOT(EI,WK,E8B) ; get all OT from 8b string 57 S OA=$$APOTWEEK(PPE,WK,EI) ; get approved overtime 58 I OA<O8 D DISPLAY(EI,O8,OA,WK) S OTERR=1 ; Display warning if calc>apprv 59 Q 60 ; 61 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 62 DISPLAY(IEN,OT8B,OTRQ,WK) ;Output warning message. 8b ot > approved ot. 63 ; 64 ; Input: IEN - employees 450 ien. 65 ; OT8B - employees total overtime calculated from 8b string. 66 ; OTRQ - employees total approved OT request's from 458.2 67 ; WK - week 1 or 2 of payperiod. 68 ; 69 W !,?3,"WARNING: Week ",WK," -Overtime being paid (",OT8B,") is more than approved (",OTRQ,")." 70 Q 71 ; 72 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 73 GET8BOT(EMPIEN,WEEK,TT8B) ; 74 ; Output: Function returns total hrs of overtime that is coded 75 ; into TT8B string for either week (1) or (2). 76 ; Input: EMPIEN - internal entry # of employee to check 8B overtime 77 ; WEEK - week (1) or (2) of pay period to check 8B overtime. 78 ; TT8B - full 8B string stub & values. 79 ; 80 N PPIEN,TT8BOT,OTCODES,CODE,OTTOTAL,OTTMP 81 S OTTOTAL=0 82 ; 83 ; get time coded portion of 8B string 84 ; 85 S TT8B=$$GET8BCDS(TT8B) 86 Q:$L(TT8B)<2 OTTOTAL ; Aint no coded OT if there aint no codes. 87 ; 88 ; create array of codes & values for this 8b string. 89 D ARRAY8B(TT8B) 90 ; 91 ; create string with all overtime codes. 92 S OTCODES=$S(WEEK=1:"^DA^DB^DC^OA^OB^OC^OK^",1:"^DE^DF^DG^OE^OF^OG^OS^") 93 ; Only count total regular hours @ OT rate when not a firefighter 94 ; with premium pay code "R" or "C". These firefighters get RA/RE from 95 ; their scheduled tour and do not need to have overtime requests. *54 96 I "^R^C^"'[(U_$P($G(^PRSPC(EMPIEN,"PREMIUM")),U,6)_U) D 97 . S OTCODES=OTCODES_$S(WEEK=1:"RA^RB^RC^",1:"RE^RF^RG^") 98 ; 99 ; loop thru employees 8b array to see if they have any of 100 ; overtime codes & add any of them up. 101 ; 102 S CODE="" 103 F S CODE=$O(TT8B(WEEK,CODE)) Q:CODE="" D 104 . I OTCODES[("^"_CODE_"^") D 105 .. S OTTMP=TT8B(WEEK,CODE) 106 .. S OTTOTAL=OTTOTAL+$E(OTTMP,1,2)+($E(OTTMP,3)*.25) 107 Q OTTOTAL 108 ; 109 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 110 ; 111 APOTWEEK(PAYPRD,WEEKID,EMP450) ; 112 ;Function returns approved overtime totals for a week. 113 ;Input: PPE,PAYPRD - pay period of concern. YY-PP 114 ; WEEKID - week (1) or week (2) of pay period 115 ; EMP450 - employees internal entry number in file 450. 116 ;Output: TOTALOT - total hrs of overtime for a week 117 ; 118 ;local vars: D1 - 1st day of payperiod-returned by NX^PRSAPPU 119 ; OTREC - a record containing 1 overtime request. 120 ; START,STOP - 1st & last FM days of week (Sun,Sat) 121 ; 122 ; quit returning 0 if anything is missing. 123 Q:$G(PAYPRD)=""!$G(WEEKID)=""!$G(EMP450)="" 0 124 ; 125 ; Loop thru OT/CT requests file x-ref on requested work date & 126 ; add up all employees approved OT requests within week. 127 ; 128 N D1,PPE,TOTALOT,START,STOP,OTREC 129 S TOTALOT=0 130 D WEEKRNG(PAYPRD,WEEKID,.START,.STOP) 131 S D1=START-.1 132 F S D1=$O(^PRST(458.2,"AD",EMP450,D1)) Q:D1>STOP!(D1="") D 133 . S OTREC="" 134 . F S OTREC=$O(^PRST(458.2,"AD",EMP450,D1,OTREC)) Q:OTREC="" D 135 .. I $$OTREQ(OTREC),$$OTAPPR(OTREC) D 136 ... S TOTALOT=TOTALOT+$P($G(^PRST(458.2,OTREC,0)),"^",6) 137 Q TOTALOT 138 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 139 OTREQ(REC) ;Function returns true if Request is type Overtime. 140 Q:$G(REC)="" 0 141 Q $P($G(^PRST(458.2,REC,0)),"^",5)="OT" 142 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 143 OTAPPR(REC) ;Function returns true if a Request is Approved. 144 Q:$G(REC)="" 0 145 Q "AS"[$P($G(^PRST(458.2,REC,0)),"^",8) 146 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 147 WEEKRNG(PPE,WEEK,FIRST,LAST) ; 148 ; 149 ; Routine takes a pay period & a week number & returns 150 ; 1st & last FileMan days of specified week. 151 ; Input: PPE - pay period in format YY-PP. 152 ; WEEK - week (1) or (2). 153 ; Output: .FIRST - first day of specified week-FM format 154 ; .LAST - last day of specified week-FM format 155 N D1,X1,X2,PPD1 156 D NX^PRSAPPU S PPD1=D1 157 I WEEK=1 D 158 . S (FIRST,X1)=PPD1,X2=6 D C^%DTC S LAST=X 159 E D 160 . S X1=PPD1,X2=7 D C^%DTC S FIRST=X 161 . S X1=PPD1,X2=13 D C^%DTC S LAST=X 162 Q 163 ; 164 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 165 GET8BCDS(TT8B) ; GET 8B time CoDeS 166 ; Input: Full 8b record as stored on node 5 of employee record 167 ; in time & attendance file. 168 ; Output: Function returns section of 8b record with pay 169 ; codes & values. 170 ; 171 ; i.e. return last portion of 8b record ----- <<AN280AL120CD00040>> 172 ; ^PRST(458,,"E",,5)=658226944741FLI 8B256280A112 AN280AL120CD00040 173 ; 174 ; Input: FULL 8B RECORD 175 ; 176 Q $E(TT8B,33,$L(TT8B)) 177 ; 178 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 179 ARRAY8B(RECORD) ; Build employee 8B array. 180 ; calls to this routine are responsible for cleaning up TT8B( array. 181 ; 182 ; Build a TT8B array which contains ONLY codes & values 183 ; that are in employees 8B record. 184 ; 185 ; Input: RECORD - last portion of 8B array with codes & values. 186 ; e.g. <<AN280AL120CD00040>> (see GET8BCDS^PRSAOTT) 187 ; 188 ; Output: array subscripted by time code & set equal to value. 189 ; e.g. TT8B(1,"AN")=010 190 ; TT8B(1,"DA")=020 191 ; TT8B(1,"NA")=020 192 ; TT8B(2,"SL")=080 193 ; TT8B(3,"CD")=000130 194 ; 195 K TT8B S TT8B(0)=0 196 Q:$G(RECORD)="" 197 N EOR,TYPE,VALUE,LOOP,WK 198 S EOR=0 199 F D Q:EOR=1 200 . S TYPE=$E(RECORD,1,2) 201 .; I TYPE="CD" S VALUE=$E(RECORD,3,$L(RECORD)) S EOR=1 202 .; 203 .;traverse record to next code so LOOP gets len of curr code value 204 .; 205 . F LOOP=3:1:$L(RECORD) Q:$E(RECORD,LOOP)?1U 206 . S:LOOP=$L(RECORD) EOR=1 207 . S VALUE=$S(EOR=1:$E(RECORD,3,LOOP),1:$E(RECORD,3,LOOP-1)) 208 . S:EOR=0 RECORD=$E(RECORD,LOOP,$L(RECORD)) 209 .; 210 .;Put code into corresponding week of TT8B array. 211 .; 212 . S WK=$S($F($$CODES(1),TYPE):1,$F($$CODES(2),TYPE):2,$F($$CODES(3),TYPE):3,1:"unknown") 213 . S TT8B(WK,TYPE)=VALUE,TT8B(0)=TT8B(0)+1 214 Q 215 ; 216 ;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 217 CODES(WEEK) ; 218 ; 8b string can contain any number of codes. Some of codes 219 ; are strictly for types of time in week 1 & some are for week 2. 220 ; There are also pay period codes that are independant from weeks. 221 ; 222 ; This function returns a string of codes for specified 223 ; week (1) or (2) -OR- (3)---8b codes independant of week. 224 ; 225 ; Input: WEEK - week (1) (2) of pay period. 226 ; 227 Q:$G(WEEK)="" 0 228 Q:WEEK=1 "AN SK WD NO AU RT CE CU UN NA NB SP SA SB SC DA DB DC TF OA OB OC YA OK OM RA RB RC HA HB HC PT PA ON YD HD VC EA EB TA TC FA FC AD" 229 ; 230 Q:WEEK=2 "AL SL WP NP AB RL CT CO US NR NS SQ SE SF SG DE DF DG TG OE OF OG YE OS OU RE RF RG HL HM HN PH PB CL YH HO VS EC ED TB TD FB FD AF" 231 ; 232 Q:WEEK=3 "NL DW IN TL LU LN LD DT TO LA ML CA PC CY RR FF FE CD" 233 Q 0 -
WorldVistAEHR/trunk/r/PAID-PRS/PRSAPPH.m
r613 r623 1 PRSAPPH ; WOIFO/JAH - Holiday Utilities ;12/07/072 ;;4.0;PAID;**33,66,113,112,116**;Sep 21, 1995;Build 233 4 5 6 7 8 9 E 10 11 12 13 14 E0 15 16 Q:DB'=1 Q:NH=48!(NH=72)G P1:DAY<0,P3:DAY>1417 P0 18 19 20 21 22 23 G U1:DB=2!(NH=72)I FLX'="C" G EF:(DAY#7=1),EB:(DAY#7=0)24 25 26 27 28 29 30 31 32 EF 33 34 35 FUTRHOL() 36 37 PREVSET() 38 39 40 41 EB 42 43 44 P1 45 46 47 48 49 50 P3 51 52 53 54 55 56 57 PN 58 59 60 61 62 63 64 65 PF 66 67 68 69 70 S0 71 72 73 74 75 76 77 78 79 80 81 82 83 UPD 84 85 U1 86 87 REM 88 89 90 91 92 93 FND 94 95 96 1 PRSAPPH ; HISC/REL-Holiday Utilities ;01/03/07 2 ;;4.0;PAID;**33,66,113**;Sep 21, 1995;Build 3 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 K HOL S PDT=$G(^PRST(458,PPI,1)) Q:PDT="" S X1=$P(PDT,"^",1),X2=-6 D C^%DTC 5 S PRS8D=X D EN^PRS8HD 6 S PDH=PRS8D F DAY=1:1:25 S X1=PRS8D,X2=DAY D C^%DTC S PDH=PDH_"^"_X 7 F DAY=1:1:26 S Z=$P(PDH,"^",DAY) I $D(HD(Z)) S HOL(Z)=$S(DAY<7:-DAY,1:DAY-6) 8 K HO,HD,PRS8D,PDH Q 9 E ; Set Holidays for Employees 10 S FLX=$P($G(^PRST(458,PPI,"E",DFN,0)),"^",6),DB=$P($G(^PRSPC(DFN,0)),"^",10) 11 S NH=$P($G(^PRSPC(DFN,0)),"^",16) Q:NH>80 12 F LLL=0:0 S LLL=$O(HOL(LLL)) Q:LLL<1 S DAY=HOL(LLL) D E0 13 Q 14 E0 ; Find Benefit Day 15 Q:DAY=15 I DAY>0,DAY<15 G P0 16 Q:DB'=1 Q:NH=48 G P1:DAY<0,P3:DAY>14 17 P0 S TC=$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",2) Q:'TC 18 I (TC=3)!(TC=4) G U1 19 I DB=1,NH=48 G U1 20 S C=0 21 I TC=2!$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",8)!$P($G(^(0)),"^",14),'$P($G(^(0)),"^",12) G S0 22 Q:$P($G(^(0)),"^",12)=LLL&(TT="HX") 23 G:DB=2 U1 I FLX'="C" G EF:(DAY#7=1),EB:(DAY#7=0) 24 S C=0 F X1=$S(DAY<8:1,1:8):1:DAY I '$P($G(^PRST(458,PPI,"E",DFN,"D",X1,0)),"^",8),'$P($G(^(0)),"^",14) S C=C+1 25 I FLX'="C" G EF:C<2,EB 26 I C'=2 G EF:C<3,EB 27 I DAY#7 F X1=DAY+1:1:$S(DAY<8:7,1:14) I '$P($G(^PRST(458,PPI,"E",DFN,"D",X1,0)),"^",8),'$P($G(^(0)),"^",14) S C=C+1 28 G EB:C=2,EF 29 ; 30 ;if looking forward, don't set off for another holiday 31 ; 32 EF F DAY=DAY+1:1:14 S TC=$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",2) Q:TC="" I TC=2!$P($G(^(0)),"^",8)!$P($G(^(0)),"^",14),'$$FUTRHOL(),$$PREVSET() G S0 33 Q 34 ; 35 FUTRHOL() ;Check to see if day is another future holiday. 36 Q $G(HOL($P($G(^PRST(458,PPI,1)),"^",DAY)))>0 37 PREVSET() ; Day NOT Already Set as holiday 38 Q ('($P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",12)>0)!($P($G(^(0)),"^",12)=LLL)) 39 ; 40 ;back up to find an available day to set the Holiday. 41 EB F DAY=DAY-1:-1:1 S TC=$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",2) Q:TC="" I $$PREVSET(),TC=2!$P($G(^(0)),"^",8)!$P($G(^(0)),"^",14) G S0 42 Q 43 ; 44 P1 I FLX'="C" Q:DAY'=-5 S C=13 D PF Q:'Z S DAY=0 G EF 45 S C=8-DAY D PF Q:'Z 46 S DAY=8-DAY,C=0 F X1=8:1:DAY I '$P($G(^PRST(458,PPI-1,"E",DFN,"D",X1,0)),"^",8),'$P($G(^(0)),"^",14) S C=C+1 47 Q:C>2 I C<2 S DAY=0 G EF 48 I DAY<14 F X1=DAY+1:1:14 I '$P($G(^PRST(458,PPI-1,"E",DFN,"D",X1,0)),"^",8),'$P($G(^(0)),"^",14) S C=C+1 49 Q:C=2 S DAY=0 G EF 50 P3 I FLX'="C" Q:DAY'=16 S C=2 D PN Q:'Z S DAY=15 G EB 51 Q:DAY=15 S C=DAY-14 D PN Q:'Z I DAY>16 S DAY=15 G EB 52 S C=2 F L1=3:1:7 D 53 .S X1=$G(^PRST(458,PPI+1,"E",DFN,"D",L1,0)) I X1'="" S:$P(X1,"^",8)+$P(X1,"^",14)=0 C=C+1 Q 54 .S X1=$P($G(^PRST(458,PPI,"E",DFN,"D",L1,0)),"^",2,4) I $P(X1,"^",3),$P(X1,"^",4) S X1=$P(X1,"^",4) 55 .S:'$P($G(^PRST(457.1,+X1,0)),"^",6) C=C+1 Q 56 Q:C>2 S DAY=15 G EB 57 PN ; Determine TC for next Pay Period; if Z=1 then all TC=1 for days 1 to C 58 S Z=1 F C=C:-1:1 D Q:'Z 59 .S X1=$P($G(^PRST(458,PPI+1,"E",DFN,"D",C,0)),"^",2) I X1=2 S Z=0 Q 60 .I X1'="" S X1=$P($G(^PRST(458,PPI+1,"E",DFN,"D",C,0)),"^",8)+$P($G(^(0)),"^",14) S:X1 Z=0 Q 61 .S X1=$P($G(^PRST(458,PPI,"E",DFN,"D",C,0)),"^",2,4) I $P(X1,"^",2),$P(X1,"^",3) S X1=$P(X1,"^",3) 62 .S X1=+X1 I X1=0!(X1=2) S Z=0 Q 63 .S:$P($G(^PRST(457.1,X1,0)),"^",6) Z=0 Q 64 Q 65 PF ; Determine TC for prior PP 66 S Z=1 F C=C:1:14 D Q:'Z 67 .S X1=$P($G(^PRST(458,PPI-1,"E",DFN,"D",C,0)),"^",2) I X1=""!(X1=2) S Z=0 Q 68 .S X1=$P($G(^PRST(458,PPI-1,"E",DFN,"D",C,0)),"^",8)+$P($G(^(0)),"^",14) S:X1 Z=0 Q 69 Q 70 S0 ; Set Holiday (Excused or Worked) 71 I TT="HX",$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",12)=LLL Q 72 S Z=$G(^PRST(458,PPI,"E",DFN,"D",DAY,1)) I Z="" S $P(^(2),"^",3)=TT Q:TT="HW" G UPD 73 S ZS=$G(^PRST(458,PPI,"E",DFN,"D",DAY,4)) I ZS'="" D FND 74 S ZS="",L1=1 F K=1:3:19 Q:$P(Z,"^",K)="" D 75 .I $P(Z,"^",K+2),"RG"'[$P($G(^PRST(457.2,+$P(Z,"^",K+2),0)),"^",2) Q 76 .S $P(ZS,"^",L1)=$P(Z,"^",K),$P(ZS,"^",L1+1)=$P(Z,"^",K+1) 77 .S $P(ZS,"^",L1+2)=TT S L1=L1+4 Q 78 S:ZS'="" ^PRST(458,PPI,"E",DFN,"D",DAY,2)=ZS Q:TT="HW" G:'DUP UPD 79 ; Remove holiday on another day 80 S K=PPI F L1=$S(DAY-8>0:DAY-8,1:1):1:$S(DAY+8<15:DAY+8,1:14) I $P($G(^PRST(458,K,"E",DFN,"D",L1,0)),"^",12)=LLL D REM 81 I DAY<9 S K=PPI-1 F L1=(DAY+6):1:14 I $P($G(^PRST(458,K,"E",DFN,"D",L1,0)),"^",12)=LLL D REM 82 I DAY>6 S K=PPI+1 F L1=1:1:(DAY-6) I $P($G(^PRST(458,K,"E",DFN,"D",L1,0)),"^",12)=LLL D REM 83 UPD ; Update status 84 S $P(^PRST(458,PPI,"E",DFN,"D",DAY,10),"^",1,4)="T^"_DUZ_"^"_NOW_"^2" 85 U1 ; Mark as Holiday 86 S $P(^PRST(458,PPI,"E",DFN,"D",DAY,0),"^",12)=LLL Q 87 REM ; Remove posting for moved holiday 88 I $P($G(^PRST(458,K,"E",DFN,0)),"^",2)'="T" Q 89 S $P(^PRST(458,K,"E",DFN,"D",L1,0),"^",12)="" 90 S ZS=$G(^PRST(458,K,"E",DFN,"D",L1,2)) Q:ZS="" 91 I ZS["HX"!(ZS["HW") K ^PRST(458,K,"E",DFN,"D",L1,2),^(3),^(10) 92 Q 93 FND ; Determine which tour is first 94 N X,Y S X=$P(Z,"^",1),Y=0 D MIL^PRSATIM S K=Y 95 S X=$P(ZS,"^",1),Y=0 D MIL^PRSATIM S:Y<K Z=ZS Q 96 Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRSAPPO.m
r613 r623 1 PRSAPPO ; HISC/MGD - Open New Pay Period ;07/30/07 2 ;;4.0;PAID;**93,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 S PPI=$P(^PRST(458,0),"^",3),PPE=$P(^PRST(458,PPI,0),"^",1) 5 D NX^PRSAPPU S X1=D1,X2=14 D C^%DTC S D1=X 6 S X1=DT,X2=7 D C^%DTC I D1>X W *7,!!,"You cannot open a Pay Period more than 7 days in advance!" G EX 7 D PP^PRSAPPU S X=D1 D DTP^PRSAPPU 8 A1 W !!,"Do you wish to Open Pay Period ",PPE," beginning ",Y," ? " 9 R X:DTIME G:'$T!(X["^") EX S:X="" X="*" S X=$TR(X,"yesno","YESNO") 10 I $P("YES",X,1)'="",$P("NO",X,1)'="" W !?5,*7,"Answer YES or NO" G A1 11 G:$E(X,1)'="Y" EX 12 I $D(^PRST(458,"B",PPE)) W !!,*7,"That Pay Period is already open!" G EX 13 K DIC,DD,DO S DIC="^PRST(458,",DIC(0)="L",DLAYGO=458,X=PPE D FILE^DICN G:Y<1 EX 14 K DIC,DLAYGO S PPI=+Y,PPIP=PPI-1 15 A2 I PPIP,'$D(^PRST(458,PPIP)) S PPIP=PPIP-1 G A2 16 ; Generate dates 17 S Y1=D1 F K=1:1:13 S X2=K,X1=D1 D C^%DTC S Y1=Y1_"^"_X 18 S Y2="" F K=1:1:14 S X=$P(Y1,"^",K) D DTP^PRSAPPU S Y=$P("Sat Sun Mon Tue Wed Thu Fri"," ",K#7+1)_" "_Y S $P(Y2,"^",K)=Y 19 S ^PRST(458,PPI,1)=Y1,^(2)=Y2 20 F K=1:1:14 S X=$P(Y1,"^",K),^PRST(458,"AD",X)=PPI_"^"_K 21 A3 S ^PRST(458,PPI,"E",0)="^458.01P^^" D NOW^%DTC S NOW=% D ^PRSAPPH 22 W !!,"Moving Current Employees into Pay Period ... " S N=0 23 N MDAT,MIEN,PRSIEN 24 S ATL="ATL00" F S ATL=$O(^PRSPC(ATL)) Q:ATL'?1"ATL".E S TLE=$E(ATL,4,6),NAM="" F S NAM=$O(^PRSPC(ATL,NAM)) Q:NAM="" F DFN=0:0 S DFN=$O(^PRSPC(ATL,NAM,DFN)) Q:DFN<1 D 25 .Q:$D(^PRST(458,PPI,"E",DFN,"D",14,0)) 26 .I $P($G(^PRSPC(DFN,"LWOP")),"^",1)="Y" Q 27 .I $P($G(^PRSPC(DFN,1)),"^",20)="Y" Q 28 .I $P($G(^PRSPC(DFN,1)),"^",33)'="N" Q 29 .S C0=^PRSPC(DFN,0) 30 .I $P(C0,U,10)=2,$P(C0,U,16)=80 S NAWS="9Mo AWS",CT9=$G(CT9)+1 31 .I $P(C0,U,10)=1,$P(C0,U,16)=72 S NAWS="36/40 AWS",CT36=$G(CT36)+1 32 .S PRSIEN=DFN,MDAT=$P(PDT,U,1) 33 .S MIEN=$$MIEN^PRSPUT1(PRSIEN,MDAT) 34 .D MOV I $D(HOL),'MIEN S TT="HX",DUP=0 D E^PRSAPPH 35 .; 36 .; Call to Autopost PT Phy Leave 37 .I $G(MIEN) D PLPP^PRSPLVA(PRSIEN,PPI) 38 .; 39 .; Call to Autopost PT Phy Extended Absence 40 .I $G(MIEN) D PEAPP^PRSPEAA(PRSIEN,PPI) 41 .S N=N+1 W:N#100=0 "." Q 42 ;SEND A MESSAGE WHEN A 9 MONTH AWS NURSE IS ACTIVATED AT A SITE 43 I +$G(NAWS) D 44 .I $G(CT9) S TMP(1)=CT9_" 9 month AWS nurse(s) set up" 45 .I $G(CT36) S TMP(2)=CT36_" 36/40 AWS nurse(s) set up" 46 .S S=$$KSP^XUPARAM("INST")_"," D FIND^DIC(456,,,"Q",+S) 47 .S IND=$S($D(^TMP("DILIST",$J,0)):+^(0),1:$O(^PRST(456,0))) 48 .S CM9=$$GET1^DIQ(456,IND,2),CM36=$$GET1^DIQ(456,IND,4) 49 .S MAX=$$GET1^DIQ(456,IND,3) N FDA,DIERR 50 .I $G(CT9),CM9<MAX S FDA(456,IND_",",2)=CM9+1 51 .I $G(CT36),CM36<MAX S FDA(456,IND_",",4)=CM36+1 52 .Q:'$D(FDA) D FILE^DIE("","FDA"),MSG^DIALOG() 53 .S S=$$GET1^DIQ(4,+S,99)_" "_$$GET1^DIQ(4,+S,100),XMTEXT="TMP(" 54 .S TMP(3)="At "_S,XMDUZ=.5,XMY("VHAOIPAIDETANAWSBULLETIN@VA.GOV")="" 55 .S XMSUB=+S_" 36/40, 9 month AWS nurse(s) deployed PRS*4.0*112" 56 .D ^XMD K TMP 57 S $P(^PRST(458,PPI,"E",0),"^",3,4)=N_"^"_N W !!,N," Employee Records created.",! 58 EX G KILL^XUSCLEAN 59 RES ; Re-start/Re-open a Pay Period 60 S PPI=$P(^PRST(458,0),"^",3),PPIP=PPI-1 G A3 61 MOV ; Create PP entry for Employee 62 I '$D(^PRST(458,PPI,"E",DFN,0)) S ^(0)=DFN_"^T" D 63 .S CPI=$G(^PRST(458,PPIP,"E",DFN,0)) 64 .S CPI=$S($P(CPI,"^",7)'="":$P(CPI,"^",7),$P(CPI,"^",6)'="":$P(CPI,"^",6),1:$P($G(^PRSPC(DFN,1)),"^",7)) 65 .S:CPI="" CPI=0 S $P(^PRST(458,PPI,"E",DFN,0),"^",6)=CPI Q 66 I '$D(^PRST(458,PPI,"E",DFN,"D",0)) S ^(0)="^458.02^14^14" 67 ; 68 ; if there's a PTP memo and this is the 1st PP for the memo then 69 ; set the memo status to Active 70 I $G(MIEN),($P($G(^PRST(458.7,+MIEN,9,1,0)),U,1)=$P($G(^PRST(458,PPI,0)),U,1)) D 71 . N IENS,PRSFDA 72 . S IENS=+MIEN_"," 73 . S PRSFDA(458.7,IENS,5)=2 ; 2:ACTIVE 74 . D FILE^DIE("","PRSFDA") 75 . K PRSFDA 76 ; 77 F DAY=1:1:14 I '$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",2) D 78 . D M1 79 . ; Update Daily ESR and post Holiday Excused 80 . I MIEN D ESRUPDT^PRSPUT3(PPI,DFN,DAY) 81 Q 82 ; 83 M1 ; Set a day 84 S Z=$G(^PRST(458,PPIP,"E",DFN,"D",DAY,0)),TD=$P(Z,"^",2) I $P(Z,"^",3) S TD=$P(Z,"^",4) 85 S X=$G(^PRST(457.1,+TD,1)),TDH=$P($G(^(0)),"^",6) 86 S ^PRST(458,PPI,"E",DFN,"D",DAY,0)=DAY_"^"_TD S:TDH'="" $P(^(0),"^",8)=TDH S:X'="" ^(1)=X 87 Q 1 PRSAPPO ; HISC/MGD - Open New Pay Period ;03/15/06 2 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 S PPI=$P(^PRST(458,0),"^",3),PPE=$P(^PRST(458,PPI,0),"^",1) 5 D NX^PRSAPPU S X1=D1,X2=14 D C^%DTC S D1=X 6 S X1=DT,X2=7 D C^%DTC I D1>X W *7,!!,"You cannot open a Pay Period more than 7 days in advance!" G EX 7 D PP^PRSAPPU S X=D1 D DTP^PRSAPPU 8 A1 W !!,"Do you wish to Open Pay Period ",PPE," beginning ",Y," ? " 9 R X:DTIME G:'$T!(X["^") EX S:X="" X="*" S X=$TR(X,"yesno","YESNO") 10 I $P("YES",X,1)'="",$P("NO",X,1)'="" W !?5,*7,"Answer YES or NO" G A1 11 G:$E(X,1)'="Y" EX 12 I $D(^PRST(458,"B",PPE)) W !!,*7,"That Pay Period is already open!" G EX 13 K DIC,DD,DO S DIC="^PRST(458,",DIC(0)="L",DLAYGO=458,X=PPE D FILE^DICN G:Y<1 EX 14 K DIC,DLAYGO S PPI=+Y,PPIP=PPI-1 15 A2 I PPIP,'$D(^PRST(458,PPIP)) S PPIP=PPIP-1 G A2 16 ; Generate dates 17 S Y1=D1 F K=1:1:13 S X2=K,X1=D1 D C^%DTC S Y1=Y1_"^"_X 18 S Y2="" F K=1:1:14 S X=$P(Y1,"^",K) D DTP^PRSAPPU S Y=$P("Sat Sun Mon Tue Wed Thu Fri"," ",K#7+1)_" "_Y S $P(Y2,"^",K)=Y 19 S ^PRST(458,PPI,1)=Y1,^(2)=Y2 20 F K=1:1:14 S X=$P(Y1,"^",K),^PRST(458,"AD",X)=PPI_"^"_K 21 A3 S ^PRST(458,PPI,"E",0)="^458.01P^^" D NOW^%DTC S NOW=% D ^PRSAPPH 22 W !!,"Moving Current Employees into Pay Period ... " S N=0 23 N MDAT,MIEN,PRSIEN 24 S ATL="ATL00" F S ATL=$O(^PRSPC(ATL)) Q:ATL'?1"ATL".E S TLE=$E(ATL,4,6),NAM="" F S NAM=$O(^PRSPC(ATL,NAM)) Q:NAM="" F DFN=0:0 S DFN=$O(^PRSPC(ATL,NAM,DFN)) Q:DFN<1 D 25 .Q:$D(^PRST(458,PPI,"E",DFN,"D",14,0)) 26 .I $P($G(^PRSPC(DFN,"LWOP")),"^",1)="Y" Q 27 .I $P($G(^PRSPC(DFN,1)),"^",20)="Y" Q 28 .I $P($G(^PRSPC(DFN,1)),"^",33)'="N" Q 29 .S PRSIEN=DFN,MDAT=$P(PDT,U,1) 30 .S MIEN=$$MIEN^PRSPUT1(PRSIEN,MDAT) 31 .D MOV I $D(HOL),'MIEN S TT="HX",DUP=0 D E^PRSAPPH 32 .; 33 .; Call to Autopost PT Phy Leave 34 .I $G(MIEN) D PLPP^PRSPLVA(PRSIEN,PPI) 35 .; 36 .; Call to autopost PT Phy Extended Absence 37 .I $G(MIEN) D PEAPP^PRSPEAA(PRSIEN,PPI) 38 .S N=N+1 W:N#100=0 "." Q 39 S $P(^PRST(458,PPI,"E",0),"^",3,4)=N_"^"_N W !!,N," Employee Records created.",! 40 EX G KILL^XUSCLEAN 41 RES ; Re-start/Re-open a Pay Period 42 S PPI=$P(^PRST(458,0),"^",3),PPIP=PPI-1 G A3 43 MOV ; Create PP entry for Employee 44 I '$D(^PRST(458,PPI,"E",DFN,0)) S ^(0)=DFN_"^T" D 45 .S CPI=$G(^PRST(458,PPIP,"E",DFN,0)) 46 .S CPI=$S($P(CPI,"^",7)'="":$P(CPI,"^",7),$P(CPI,"^",6)'="":$P(CPI,"^",6),1:$P($G(^PRSPC(DFN,1)),"^",7)) 47 .S:CPI="" CPI=0 S $P(^PRST(458,PPI,"E",DFN,0),"^",6)=CPI Q 48 I '$D(^PRST(458,PPI,"E",DFN,"D",0)) S ^(0)="^458.02^14^14" 49 ; 50 ; if there's a PTP memo and this is the 1st PP for the memo then 51 ; set the memo status to Active 52 I $G(MIEN),($P($G(^PRST(458.7,+MIEN,9,1,0)),U,1)=$P($G(^PRST(458,PPI,0)),U,1)) D 53 . N IENS,PRSFDA 54 . S IENS=+MIEN_"," 55 . S PRSFDA(458.7,IENS,5)=2 ; 2:ACTIVE 56 . D FILE^DIE("","PRSFDA") 57 . K PRSFDA 58 ; 59 F DAY=1:1:14 I '$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",2) D 60 . D M1 61 . ; Update Daily ESR and post Holiday Excused 62 . I MIEN D ESRUPDT^PRSPUT3(PPI,DFN,DAY) 63 Q 64 ; 65 M1 ; Set a day 66 S Z=$G(^PRST(458,PPIP,"E",DFN,"D",DAY,0)),TD=$P(Z,"^",2) I $P(Z,"^",3) S TD=$P(Z,"^",4) 67 S X=$G(^PRST(457.1,+TD,1)),TDH=$P($G(^(0)),"^",6) 68 S ^PRST(458,PPI,"E",DFN,"D",DAY,0)=DAY_"^"_TD S:TDH'="" $P(^(0),"^",8)=TDH S:X'="" ^(1)=X 69 Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRSASR.m
r613 r623 1 PRSASR ;HISC/MGD,WOIFO/JAH/PLT - Supervisor Certification ;02/05/2005 2 ;;4.0;PAID;**2,7,8,22,37,43,82,93,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;Called by Pay Per Cert Option on T&A Superv menu. Timecard 4 each 6 ;employee in this supervs T&L is displayed. Superv prompted at each 7 ;display as to whether card is ready 4 certification. Cards that r 8 ;ready r saved in ^TMP. After this review--elect sign code is 9 ;required to release approved cards to payroll. Upon ES 10 ; 8b, exceptions, & ot warnings r stored & timecard status 11 ;changed to 'P'--'released to payroll' 12 ; 13 ;===================================================================== 14 ; 15 ;Set up reverse video ON & OFF for tour error highlighting 16 N IORVOFF,IORVON,IOINHI,IOINORM,IOBOFF,IOBON,RESP 17 S X="IORVOFF;IORVON;IOBOFF;IOBON;IOINHI;IOINORM" D ENDR^%ZISS 18 ; 19 N MIDPP,DUMMY 20 S MIDPP="In middle of Pay Period; Cannot Certify & Release." 21 W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM" 22 W !?27,"SUPERVISORY CERTIFICATION" 23 S PRSTLV=3 D ^PRSAUTL G:TLI<1 EX 24 D NOW^%DTC 25 S DT=%\1,APDT=%,Y=$G(^PRST(458,"AD",DT)),PPI=$P(Y,"^",1),DAY=$P(Y,"^",2) 26 I DAY>5,DAY<11 W $C(7),!!,MIDPP G EX 27 I DAY<6 S X1=DT,X2=-7 D C^%DTC S PPI=$P($G(^PRST(458,"AD",X)),"^",1) G:'PPI EX 28 ; ----------------------------------------- 29 P0 ;PDT = string of pay period dates with format - Sun 29-Sep-96^ 30 ;PDTI = string of pay period dates in fileman format. 31 ;PPI = pay period internal entry number in file 458. 32 ;GLOB = global reference for employees pay period record 33 ; returned from $$AVAILREC & passed to UNLOCK. 34 ; ----------------------------------------- 35 ; 36 S PDT=$G(^PRST(458,PPI,2)),PDTI=$G(^(1)),QT=0 K ^TMP($J) 37 ; 38 ; ----------------------------------------- 39 ;Loop thru this supervisor's T&L unit on x-ref in 450. 40 ;$$availrec() ensures there's data & node with employee's 41 ;pay period record is NOT locked, then locks node. 42 ;Call to CHK checks for needed approvals for current employee 43 ;If supervisor decides record is not ready, during this call, 44 ;then node is unlocked. Records that super accepts for release 45 ;are not unlocked until they are processed thru temp global 46 ;& their status' are updated. 47 ; --------------------------------------------------- 48 ; 49 S NN="",CKS=1 50 F S NN=$O(^PRSPC("ATL"_TLE,NN)) Q:NN="" F DFN=0:0 S DFN=$O(^PRSPC("ATL"_TLE,NN,DFN)) Q:DFN<1 I $$AVAILREC^PRSLIB00("SUP",.GLOB) D CHK I QT G T0 51 ; 52 ; --------------------------------------------------- 53 ;Loop through T&L unit file x-ref 2 c if this supervisor certifies 54 ;payperiod data for other supervisors of other T&L units. If so 55 ;process after ensuring node to be certified is available. 56 ; --------------------------------------------------- 57 ; 58 S CKS=0 59 F VA2=0:0 S VA2=$$TLSUP Q:VA2<1 S SSN=$$SSN I SSN'="" S DFN=$$DFN S Z=$P($G(^PRSPC(+DFN,0)),"^",8) I Z'="",Z'=TLE,$$AVAILREC^PRSLIB00("SUP",.GLOB) D CHK I QT G EX:'$T,T0 60 ; 61 ; --------------------------------------------------- 62 T0 I $D(^TMP($J,"E")) G T1 63 W !!,"No records have been selected for certification." 64 S DUMMY=$$ASK^PRSLIB00(1) G EX 65 ; 66 ; --------------------------------------------------- 67 ; 68 T1 ;if supervisor signs off then update all records in tmp 69 ;otherwise remove any auto posting. 70 D ^PRSAES I ESOK D 71 .D NOW^%DTC S APDT=% 72 .F DFN=0:0 S DFN=$O(^TMP($J,"E",DFN)) Q:DFN<1 S VAL=$G(^(DFN)) D PROC 73 I 'ESOK D 74 .F DFN=0:0 S DFN=$O(^TMP($J,"E",DFN)) Q:DFN<1 D 75 ..D AUTOPINI^PRS8(PPI,DFN) 76 D EX 77 Q 78 ; 79 ; --------------------------------------------------- 80 CHK ; Check for needed approvals 81 N PRSENT,PRSWOC 82 S STAT=$P($G(^PRST(458,PPI,"E",DFN,0)),"^",2) I "PX"[STAT Q 83 I USR=DFN Q:'$D(^XUSEC("PRSA SIGN",DUZ)) 84 E I CKS S SSN=$P($G(^PRSPC(DFN,0)),"^",9) I SSN S EDUZ=+$O(^VA(200,"SSN",SSN,0)) I $D(^PRST(455.5,"AS",EDUZ,TLI)) Q:$P($G(^PRST(455.5,TLI,"S",EDUZ,0)),"^",2)'=TLE 85 S HDR=0 D HDR,^PRSAENT S PRSENT=ENT 86 ; 87 ;Loop to display tour, exceptions(leave, etc..) & errors. 88 ; 89 S (XF,X9)=0 90 F DAY=1:1:14 D TOURERR($P(PDT,"^",DAY),.X9,.XF) D:$Y>(IOSL-6)&(DAY<14) HDR G:QT O1 91 ; 92 ;Display VCS commission sales, if applicable 93 S Z=$G(^PRST(458,PPI,"E",DFN,2)) 94 I Z'="" D:$Y>(IOSL-11) HDR Q:QT D VCS^PRSASR1 95 ; 96 ; 97 S Z=$G(^PRST(458,PPI,"E",DFN,4)) 98 I Z'="" D:$Y>(IOSL-9) HDR Q:QT D ED^PRSASR1 99 I XF W !,IORVON,"Serious error; cannot release.",IORVOFF S QT=$$ASK^PRSLIB00() Q 100 S QT=$$ASK^PRSLIB00() Q:QT 101 ; 102 ;PRS8 call creates & stores 8B string in employees attendance 103 ;record. Later, under a payroll option, string will be 104 ;transmitted to Austin. 105 ; 106 N NN D ONE^PRS8 S C0=$G(^PRSPC(DFN,0)),PY=PPI D CERT^PRS8VW S QT=0 107 ; 108 ;Show OT (approve-vs-8B) warning & save in TMP. 109 N WK,OTERR,O8,OA 110 F WK=1:1:2 D 111 . D WARNSUP^PRSAOTT(PPE,DFN,VAL,WK,.OTERR,.O8,.OA) 112 . I OTERR S ^TMP($J,"OT",DFN,WK)=O8_"^"_OA 113 ; 114 ;warning message for rs/rn and on type of time 115 I $E(PRSENT,5) D 116 . I @($TR($$CD8B^PRSU1B2(VAL,"RS^3^RN^3",1),U,"+")_"-("_$TR($$RSHR^PRSU1B2(DFN,PPI),U,"+")_")") W !,?3,"WARNING: The total scheduled recess hours for this pay period does not match the total RS/RN posted." 117 . I $G(PRSWOC)]"" W !,?3,"Warning: The entire tour for day# ",PRSWOC," is posted RECESS. The On-Call will be paid unless posted UNAVAILABLE." 118 . QUIT 119 ; 120 LD ; Check for changes to the Labor Distribution Codes made during the pay 121 ; period. 122 I $D(^PRST(458,PPI,"E",DFN,"LDAUD")) D LD^PRSASR1 123 ; --------------------------------------------------- 124 OK ;Prompt Supervisor to release timecard. If yes, store in ^TMP(. 125 ;If supervisor answers no then bypass & unlock record. 126 ; --------------------------------------------------- 127 W !!,IORVON,"Release to Payroll?",IORVOFF," " 128 R X:DTIME S:'$T!(X["^") QT=1 Q:QT S:X="" X="*" S X=$TR(X,"yesno","YESNO") 129 I $P("YES",X,1)'="",$P("NO",X,1)'="" W $C(7)," Answer YES or NO" G OK 130 I X?1"Y".E S ^TMP($J,"E",DFN)=VAL 131 E D 132 . D AUTOPINI^PRS8(PPI,DFN) ; remove any auto posting 133 . D UNLOCK^PRSLIB00(GLOB) ; unlock record 134 . K ^TMP($J,"LOCK",DFN) ;clean out of local lock list. 135 O1 Q 136 ; 137 PROC ; Set Approval, file any exceptions & update 8B string 138 ; 139 ; get employees entitlement string in variable A1 140 D ^PRSAENT 141 ; 142 ; set approvals 143 S $P(^PRST(458,PPI,"E",DFN,0),"^",3,5)=DUZ_"^"_APDT_"^"_A1 144 ; VCS approval 145 I $D(^PRST(458,PPI,"E",DFN,2)) S $P(^(2),"^",17,18)=DUZ_"^"_APDT 146 ; 147 ; loop thru any exceptions & file in 458.5 148 I $D(^TMP($J,"X",DFN)) S K="" F S K=$O(^TMP($J,"X",DFN,K)) Q:K="" S DAY=$P(K," ",1),X1=$P(PDTI,"^",DAY),X2=$G(^(K)) D ^PRSATPF 149 ; 150 ; file overtime warnings 151 F WK=1:1:2 I $G(^TMP($J,"OT",DFN,WK))'="" D 152 . S O8=$P(^TMP($J,"OT",DFN,WK),"^") 153 . S OA=$P(^TMP($J,"OT",DFN,WK),"^",2) 154 . D FILEOTW^PRSAOTTF(PPI,DFN,WK,O8,OA) 155 ; 156 ;set 8b string & change status of timecard to payroll 157 S ^PRST(458,PPI,"E",DFN,5)=VAL S $P(^PRST(458,PPI,"E",DFN,0),"^",2)="P" 158 ; 159 ; If employee is a PT Phys w/ memo update hours credited 160 D PTP^PRSASR1(DFN,PPI) 161 ; 162 ;unlock employees time card record 163 S GLOB="^PRST(458,"_PPI_","_"""E"""_","_DFN_",0)" 164 D UNLOCK^PRSLIB00(GLOB) 165 K ^TMP($J,"LOCK",DFN) ;clean out of local lock list. 166 Q 167 ; 168 ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 169 ; 170 HDR ; Display Header 171 I HDR S QT=$$ASK^PRSLIB00() Q:QT 172 S X=$G(^PRSPC(DFN,0)) W !,@IOF,?3,$P(X,"^",1) S X=$P(X,"^",9) I X W ?68,$E(X),"XX-XX-",$E(X,6,9) S HDR=1 173 W !,?6,"Date",?20,"Scheduled Tour",?40,"Tour Exceptions",?63,IORVON,"Tour Errors",IORVOFF 174 W !?3 F I=1:1:72 W "-" 175 Q 176 ;==================================================================== 177 HDR2 ; Display Header don't quit 178 N HOLD 179 S HOLD=$$ASK^PRSLIB00(1) 180 S X=$G(^PRSPC(DFN,0)) W !,@IOF,?3,$P(X,"^",1) S X=$P(X,"^",9) I X W ?68,$E(X),"XX-XX-",$E(X,6,9) 181 W !,?6,"Date",?20,"Scheduled Tour",?40,"Tour Exceptions",?63,IORVON,"Tour Errors",IORVOFF 182 W !?3 F I=1:1:72 W "-" 183 Q 184 ;==================================================================== 185 ; 186 EX ; clean up variables & unlock any leftover time card nodes 187 N EMPREC 188 S EMPREC="" 189 F S EMPREC=$O(^TMP($J,"LOCK",EMPREC)) Q:EMPREC="" D 190 . S GLOB="^PRST(458,"_PPI_","_"""E"""_","_EMPREC_",0)" 191 . D UNLOCK^PRSLIB00(GLOB) 192 K ^TMP($J) G KILL^XUSCLEAN 193 Q 194 ; 195 ; 196 ;These extrinsic functions simply remove lengthy code from long, 197 ;single line, nested loop. 198 ; --------------------------------------------------- 199 TLSUP() ;get next supervisor who certifies other supervisors 200 Q $O(^PRST(455.5,"ASX",TLE,VA2)) 201 ; --------------------------------------------------- 202 SSN() ;get ssn of supervisor to be certified by this supervisor. 203 Q $P($G(^VA(200,VA2,1)),"^",9) 204 ; --------------------------------------------------- 205 DFN() ;get internal entry number of supvisor of other T&L 2b approved 206 ;by current supervisor. 207 Q $O(^PRSPC("SSN",SSN,0)) 208 ;==================================================================== 209 TOURERR(DTE,X9,XF) ;DISPLAY TOUR & ERRORS 210 ; 211 N IORVOFF,IORVON,RESP,ERRLEN 212 S X="IORVOFF;IORVON" D ENDR^%ZISS 213 D F1^PRSADP1,^PRSATPE 214 F K=1:1 Q:'$D(Y1(K))&'$D(Y2(K)) D 215 . I $Y>(IOSL-4) D HDR2 216 . W:K>1 ! 217 . W:$D(Y1(K)) ?21,Y1(K) 218 . W:$P($G(Y2(K)),"^")'="" ?45,$P(Y2(K),"^",1) 219 . I $P($G(Y2(K)),"^",2)'="" W:$X>44 ! W ?45,$P(Y2(K),"^",2) 220 W:Y3'="" !?10,Y3 221 I $D(ER) S:FATAL XF=1 F K=0:0 S K=$O(ER(K)) Q:K<1 D 222 . I $Y>(IOSL-4) D HDR2 223 .W:X9!($X>55) ! S ERRLEN=23 224 .I $P(ER(K),"^",2)'="" S ERRLEN=$L(ER(K)) 225 .W ?(IOM-(ERRLEN+1)),IORVON 226 .W:$P(ER(K),"^",2)'="" $P(ER(K),"^",2) 227 .W " ",$P(ER(K),"^",1),IORVOFF 228 .S X9=0 S:'XF ^TMP($J,"X",DFN,DAY_" "_K)=ER(K) 229 .Q 230 Q 1 PRSASR ;HISC/MGD,WOIFO/JAH - Supervisor Certification ;02/05/2005 2 ;;4.0;PAID;**2,7,8,22,37,43,82,93**;Sep 21, 1995;Build 7 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;Called by Pay Per Cert Option on T&A Superv menu. Timecard 4 each 6 ;employee in this supervs T&L is displayed. Superv prompted at each 7 ;display as to whether card is ready 4 certification. Cards that r 8 ;ready r saved in ^TMP. After this review--elect sign code is 9 ;required to release approved cards to payroll. Upon ES 10 ; 8b, exceptions, & ot warnings r stored & timecard status 11 ;changed to 'P'--'released to payroll' 12 ; 13 ;===================================================================== 14 ; 15 ;Set up reverse video ON & OFF for tour error highlighting 16 N IORVOFF,IORVON,IOINHI,IOINORM,IOBOFF,IOBON,RESP 17 S X="IORVOFF;IORVON;IOBOFF;IOBON;IOINHI;IOINORM" D ENDR^%ZISS 18 ; 19 N MIDPP,DUMMY 20 S MIDPP="In middle of Pay Period; Cannot Certify & Release." 21 W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM" 22 W !?27,"SUPERVISORY CERTIFICATION" 23 S PRSTLV=3 D ^PRSAUTL G:TLI<1 EX 24 D NOW^%DTC 25 S DT=%\1,APDT=%,Y=$G(^PRST(458,"AD",DT)),PPI=$P(Y,"^",1),DAY=$P(Y,"^",2) 26 I DAY>5,DAY<11 W $C(7),!!,MIDPP G EX 27 I DAY<6 S X1=DT,X2=-7 D C^%DTC S PPI=$P($G(^PRST(458,"AD",X)),"^",1) G:'PPI EX 28 ; ----------------------------------------- 29 P0 ;PDT = string of pay period dates with format - Sun 29-Sep-96^ 30 ;PDTI = string of pay period dates in fileman format. 31 ;PPI = pay period internal entry number in file 458. 32 ;GLOB = global reference for employees pay period record 33 ; returned from $$AVAILREC & passed to UNLOCK. 34 ; ----------------------------------------- 35 ; 36 S PDT=$G(^PRST(458,PPI,2)),PDTI=$G(^(1)),QT=0 K ^TMP($J) 37 ; 38 ; ----------------------------------------- 39 ;Loop thru this supervisor's T&L unit on x-ref in 450. 40 ;$$availrec() ensures there's data & node with employee's 41 ;pay period record is NOT locked, then locks node. 42 ;Call to CHK checks for needed approvals for current employee 43 ;If supervisor decides record is not ready, during this call, 44 ;then node is unlocked. Records that super accepts for release 45 ;are not unlocked until they are processed thru temp global 46 ;& their status' are updated. 47 ; --------------------------------------------------- 48 ; 49 S NN="",CKS=1 50 F S NN=$O(^PRSPC("ATL"_TLE,NN)) Q:NN="" F DFN=0:0 S DFN=$O(^PRSPC("ATL"_TLE,NN,DFN)) Q:DFN<1 I $$AVAILREC^PRSLIB00("SUP",.GLOB) D CHK I QT G T0 51 ; 52 ; --------------------------------------------------- 53 ;Loop through T&L unit file x-ref 2 c if this supervisor certifies 54 ;payperiod data for other supervisors of other T&L units. If so 55 ;process after ensuring node to be certified is available. 56 ; --------------------------------------------------- 57 ; 58 S CKS=0 59 F VA2=0:0 S VA2=$$TLSUP Q:VA2<1 S SSN=$$SSN I SSN'="" S DFN=$$DFN S Z=$P($G(^PRSPC(+DFN,0)),"^",8) I Z'="",Z'=TLE,$$AVAILREC^PRSLIB00("SUP",.GLOB) D CHK I QT G EX:'$T,T0 60 ; 61 ; --------------------------------------------------- 62 T0 I $D(^TMP($J,"E")) G T1 63 W !!,"No records have been selected for certification." 64 S DUMMY=$$ASK^PRSLIB00(1) G EX 65 ; 66 ; --------------------------------------------------- 67 ; 68 T1 ;if supervisor signs off then update all records in tmp 69 ;otherwise remove any auto posting. 70 D ^PRSAES I ESOK D 71 .D NOW^%DTC S APDT=% 72 .F DFN=0:0 S DFN=$O(^TMP($J,"E",DFN)) Q:DFN<1 S VAL=$G(^(DFN)) D PROC 73 I 'ESOK D 74 .F DFN=0:0 S DFN=$O(^TMP($J,"E",DFN)) Q:DFN<1 D 75 ..D AUTOPINI^PRS8(PPI,DFN) 76 D EX 77 Q 78 ; 79 ; --------------------------------------------------- 80 CHK ; Check for needed approvals 81 S STAT=$P($G(^PRST(458,PPI,"E",DFN,0)),"^",2) I "PX"[STAT Q 82 I USR=DFN Q:'$D(^XUSEC("PRSA SIGN",DUZ)) 83 E I CKS S SSN=$P($G(^PRSPC(DFN,0)),"^",9) I SSN S EDUZ=+$O(^VA(200,"SSN",SSN,0)) I $D(^PRST(455.5,"AS",EDUZ,TLI)) Q:$P($G(^PRST(455.5,TLI,"S",EDUZ,0)),"^",2)'=TLE 84 S HDR=0 D HDR 85 ; 86 ;Loop to display tour, exceptions(leave, etc..) & errors. 87 ; 88 S (XF,X9)=0 89 F DAY=1:1:14 D TOURERR($P(PDT,"^",DAY),.X9,.XF) D:$Y>(IOSL-6)&(DAY<14) HDR G:QT O1 90 ; 91 ;Display VCS commission sales, if applicable 92 S Z=$G(^PRST(458,PPI,"E",DFN,2)) 93 I Z'="" D:$Y>(IOSL-11) HDR Q:QT D VCS^PRSASR1 94 ; 95 ; 96 S Z=$G(^PRST(458,PPI,"E",DFN,4)) 97 I Z'="" D:$Y>(IOSL-9) HDR Q:QT D ED^PRSASR1 98 I XF W !,IORVON,"Serious error; cannot release.",IORVOFF S QT=$$ASK^PRSLIB00() Q 99 S QT=$$ASK^PRSLIB00() Q:QT 100 ; 101 ;PRS8 call creates & stores 8B string in employees attendance 102 ;record. Later, under a payroll option, string will be 103 ;transmitted to Austin. 104 ; 105 N NN D ONE^PRS8 S C0=$G(^PRSPC(DFN,0)),PY=PPI D CERT^PRS8VW S QT=0 106 ; 107 ;Show OT (approve-vs-8B) warning & save in TMP. 108 N WK,OTERR,O8,OA 109 F WK=1:1:2 D 110 . D WARNSUP^PRSAOTT(PPE,DFN,VAL,WK,.OTERR,.O8,.OA) 111 . I OTERR S ^TMP($J,"OT",DFN,WK)=O8_"^"_OA 112 ; 113 LD ; Check for changes to the Labor Distribution Codes made during the pay 114 ; period. 115 I $D(^PRST(458,PPI,"E",DFN,"LDAUD")) D LD^PRSASR1 116 ; --------------------------------------------------- 117 OK ;Prompt Supervisor to release timecard. If yes, store in ^TMP(. 118 ;If supervisor answers no then bypass & unlock record. 119 ; --------------------------------------------------- 120 W !!,IORVON,"Release to Payroll?",IORVOFF," " 121 R X:DTIME S:'$T!(X["^") QT=1 Q:QT S:X="" X="*" S X=$TR(X,"yesno","YESNO") 122 I $P("YES",X,1)'="",$P("NO",X,1)'="" W $C(7)," Answer YES or NO" G OK 123 I X?1"Y".E S ^TMP($J,"E",DFN)=VAL 124 E D 125 . D AUTOPINI^PRS8(PPI,DFN) ; remove any auto posting 126 . D UNLOCK^PRSLIB00(GLOB) ; unlock record 127 . K ^TMP($J,"LOCK",DFN) ;clean out of local lock list. 128 O1 Q 129 ; 130 PROC ; Set Approval, file any exceptions & update 8B string 131 ; 132 ; get employees entitlement string in variable A1 133 D ^PRSAENT 134 ; 135 ; set approvals 136 S $P(^PRST(458,PPI,"E",DFN,0),"^",3,5)=DUZ_"^"_APDT_"^"_A1 137 ; VCS approval 138 I $D(^PRST(458,PPI,"E",DFN,2)) S $P(^(2),"^",17,18)=DUZ_"^"_APDT 139 ; 140 ; loop thru any exceptions & file in 458.5 141 I $D(^TMP($J,"X",DFN)) S K="" F S K=$O(^TMP($J,"X",DFN,K)) Q:K="" S DAY=$P(K," ",1),X1=$P(PDTI,"^",DAY),X2=$G(^(K)) D ^PRSATPF 142 ; 143 ; file overtime warnings 144 F WK=1:1:2 I $G(^TMP($J,"OT",DFN,WK))'="" D 145 . S O8=$P(^TMP($J,"OT",DFN,WK),"^") 146 . S OA=$P(^TMP($J,"OT",DFN,WK),"^",2) 147 . D FILEOTW^PRSAOTTF(PPI,DFN,WK,O8,OA) 148 ; 149 ;set 8b string & change status of timecard to payroll 150 S ^PRST(458,PPI,"E",DFN,5)=VAL S $P(^PRST(458,PPI,"E",DFN,0),"^",2)="P" 151 ; 152 ; If employee is a PT Phys w/ memo update hours credited 153 D PTP^PRSASR1(DFN,PPI) 154 ; 155 ;unlock employees time card record 156 S GLOB="^PRST(458,"_PPI_","_"""E"""_","_DFN_",0)" 157 D UNLOCK^PRSLIB00(GLOB) 158 K ^TMP($J,"LOCK",DFN) ;clean out of local lock list. 159 Q 160 ; 161 ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 162 ; 163 HDR ; Display Header 164 I HDR S QT=$$ASK^PRSLIB00() Q:QT 165 S X=$G(^PRSPC(DFN,0)) W !,@IOF,?3,$P(X,"^",1) S X=$P(X,"^",9) I X W ?68,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9) S HDR=1 166 W !,?6,"Date",?20,"Scheduled Tour",?40,"Tour Exceptions",?63,IORVON,"Tour Errors",IORVOFF 167 W !?3 F I=1:1:72 W "-" 168 Q 169 ;==================================================================== 170 HDR2 ; Display Header don't quit 171 N HOLD 172 S HOLD=$$ASK^PRSLIB00(1) 173 S X=$G(^PRSPC(DFN,0)) W !,@IOF,?3,$P(X,"^",1) S X=$P(X,"^",9) I X W ?68,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9) 174 W !,?6,"Date",?20,"Scheduled Tour",?40,"Tour Exceptions",?63,IORVON,"Tour Errors",IORVOFF 175 W !?3 F I=1:1:72 W "-" 176 Q 177 ;==================================================================== 178 ; 179 EX ; clean up variables & unlock any leftover time card nodes 180 N EMPREC 181 S EMPREC="" 182 F S EMPREC=$O(^TMP($J,"LOCK",EMPREC)) Q:EMPREC="" D 183 . S GLOB="^PRST(458,"_PPI_","_"""E"""_","_EMPREC_",0)" 184 . D UNLOCK^PRSLIB00(GLOB) 185 K ^TMP($J) G KILL^XUSCLEAN 186 Q 187 ; 188 ;==================================================================== 189 ;These extrinsic functions simply remove lengthy code from long, 190 ;single line, nested loop. 191 ; --------------------------------------------------- 192 TLSUP() ;get next supervisor who certifies other supervisors 193 Q $O(^PRST(455.5,"ASX",TLE,VA2)) 194 ; --------------------------------------------------- 195 SSN() ;get ssn of supervisor to be certified by this supervisor. 196 Q $P($G(^VA(200,VA2,1)),"^",9) 197 ; --------------------------------------------------- 198 DFN() ;get internal entry number of supvisor of other T&L 2b approved 199 ;by current supervisor. 200 Q $O(^PRSPC("SSN",SSN,0)) 201 ;==================================================================== 202 TOURERR(DTE,X9,XF) ;DISPLAY TOUR & ERRORS 203 ; 204 N IORVOFF,IORVON,RESP,ERRLEN 205 S X="IORVOFF;IORVON" D ENDR^%ZISS 206 D F1^PRSADP1,^PRSATPE 207 F K=1:1 Q:'$D(Y1(K))&'$D(Y2(K)) D 208 . I $Y>(IOSL-4) D HDR2 209 . W:K>1 ! 210 . W:$D(Y1(K)) ?21,Y1(K) 211 . W:$P($G(Y2(K)),"^")'="" ?45,$P(Y2(K),"^",1) 212 . I $P($G(Y2(K)),"^",2)'="" W:$X>44 ! W ?45,$P(Y2(K),"^",2) 213 W:Y3'="" !?10,Y3 214 I $D(ER) S:FATAL XF=1 F K=0:0 S K=$O(ER(K)) Q:K<1 D 215 . I $Y>(IOSL-4) D HDR2 216 .W:X9!($X>55) ! S ERRLEN=23 217 .I $P(ER(K),"^",2)'="" S ERRLEN=$L(ER(K)) 218 .W ?(IOM-(ERRLEN+1)),IORVON 219 .W:$P(ER(K),"^",2)'="" $P(ER(K),"^",2) 220 .W " ",$P(ER(K),"^",1),IORVOFF 221 .S X9=0 S:'XF ^TMP($J,"X",DFN,DAY_" "_K)=ER(K) 222 .Q 223 Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRSASR1.m
r613 r623 1 PRSASR1 ;WCIOFO/JAH - Display VCS, Fee, ED ;02/20/082 ;;4.0;PAID;**6,21,82,93,116**;Sep 21, 1995;Build 23 3 4 VCS 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 ED 28 29 30 31 32 33 34 35 LD 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 LDHDR 80 81 82 83 84 85 86 87 88 LDHOLD 89 90 91 92 93 94 95 I X W ?68,$E(X),"XX-XX-",$E(X,6,9)96 97 98 99 100 PTP(PRSIEN,PPI) 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 AMT(ESR) 205 206 207 208 209 210 211 212 213 1 PRSASR1 ;HISC/MGD - Display VCS, Fee, ED ;04/19/05 2 ;;4.0;PAID;**6,21,82,93**;Sep 21, 1995;Build 7 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 VCS ; Display VCS Sales/Fee Basis 5 ; 6 N OLDPP 7 S PAYP=$P($G(^PRSPC(DFN,0)),"^",21) 8 ; Check the pay plan for the pay period we are dealing with 9 ; in case it's a previous pay period where an employee 10 ; had a different pay plan. 11 ; 1st put pay period in YY-PP format 4 call 2 lookup old pay plan. 12 ;Only check if called from option Display employee pay period PPERIOD 13 ;will be defined. 14 I $G(PPERIOD) D 15 .;S PPERIOD=$S(Y["-":$P(Y,"^",2),1:$P(^PRST(458,$P(Y,"^"),0),"^")) 16 .S OLDPP=$$OLDPP^PRS8UT(PPERIOD,DFN) 17 .I OLDPP'=0,(OLDPP'=PAYP) D 18 .. S PAYP=OLDPP 19 .. W !,"Employee is NOT currently under this pay plan." 20 ; 21 W !!?30,$S(PAYP="F":"Fee Basis Appointee",1:"VCS Commission Sales") 22 W !!?13,"Sun Mon Tue Wed Thu Fri Sat",! 23 W !,"Week 1" S L1=1 F K=1:1:7 S L1=L1+10,Z1=$P(Z,"^",K) I Z1'="" W ?L1,$J(Z1,7,2) 24 W !,"Week 2" S L1=1 F K=8:1:14 S L1=L1+10,Z1=$P(Z,"^",K) I Z1'="" W ?L1,$J(Z1,7,2) 25 I PAYP="F" W !! F K=19:1:21 S Z1=$P(Z,"^",K) W "Total ",$P("Hours Days Procedures"," ",K-18),": ",Z1," " 26 Q 27 ED ; Display Envir. Diff. 28 W !!?26,"Environmental Differentials",! 29 S Y="" F K=1:2:5 S Z1=$P(Z,"^",K) Q:'Z1 S:Y'="" Y=Y_"; " S Y=Y_$P($G(^PRST(457.6,+Z1,0)),"^",1)_" "_$P(Z,"^",K+1)_" Hrs." 30 I Y'="" W !,"Week 1: ",Y 31 S Y="" F K=7:2:11 S Z1=$P(Z,"^",K) Q:'Z1 S:Y'="" Y=Y_"; " S Y=Y_$P($G(^PRST(457.6,+Z1,0)),"^",1)_" "_$P(Z,"^",K+1)_" Hrs." 32 I Y'="" W !,"Week 2: ",Y 33 Q 34 ; 35 LD ; Display changes to the Labor Distribution Codes within the Pay 36 ; Period. 37 ; 38 N DASH,DESC,IENS,LDCC,LDCCB,LDCCEX,LDCODE,LDCNT,LDDOA,LDFCP 39 N LDHOLD,LDPCT,LDTOI,PRSLD,Y 40 S $P(DASH,"-",80)="" 41 W ! 42 D LDHOLD 43 W !,"Current Labor Distribution Values:" 44 S LDDOA=$$GET1^DIQ(450,DFN,756,"E") 45 S LDCCB=$$GET1^DIQ(450,DFN,755,"E") 46 S LDTOI=$$GET1^DIQ(450,DFN,755.1,"E") 47 W !,LDDOA,?24,LDCCB,?61,LDTOI 48 F PRSLD=1:1:4 D 49 . S LDCODE=$$GET1^DIQ(450.0757,PRSLD_","_DFN,1) 50 . S LDPCT=$$GET1^DIQ(450.0757,PRSLD_","_DFN,2) 51 . S LDCC=$$GET1^DIQ(450.0757,PRSLD_","_DFN,3) 52 . S Y=LDCC,SUB454="CC" 53 . D OT^PRSDUTIL K SUB454 54 . S LDCCEX=$E(Y,1,30) 55 . S LDFCP=$$GET1^DIQ(450.0757,PRSLD_","_DFN,4) 56 . W !,"Code",PRSLD,": ",LDCODE,?12,LDPCT,?24,LDCC," - ",LDCCEX,?70,LDFCP 57 ; 58 W !!,"The previous Labor Distribution Values:" 59 S LDCNT="A" 60 S LDCNT=$O(^PRST(458,PPI,"E",DFN,"LDAUD",LDCNT),-1) 61 Q:'LDCNT 62 S IENS=LDCNT_","_DFN_","_PPI_"," 63 S LDDOA=$$GET1^DIQ(458.1105,IENS,1,"E") 64 S LDCCB=$$GET1^DIQ(458.1105,IENS,2,"E") 65 S LDTOI=$$GET1^DIQ(458.1105,IENS,3,"E") 66 W !,LDDOA,?24,LDCCB,?61,LDTOI 67 F PRSLD=1:1:4 D 68 . S IENS=PRSLD_","_LDCNT_","_DFN_","_PPI_"," 69 . S LDCODE=$$GET1^DIQ(458.11054,IENS,1) 70 . S LDPCT=$$GET1^DIQ(458.11054,IENS,2) 71 . S LDCC=$$GET1^DIQ(458.11054,IENS,3) 72 . S Y=LDCC,SUB454="CC" 73 . D OT^PRSDUTIL K SUB454 74 . S LDCCEX=$E(Y,1,30) 75 . S LDFCP=$$GET1^DIQ(458.11054,IENS,4) 76 . W !,"Code",PRSLD,": ",LDCODE,?12,LDPCT,?24,LDCC," - ",LDCCEX,?70,LDFCP 77 Q 78 ; 79 LDHDR ; Labor Distribution Header information 80 ; 81 W !?15,"Labor Distribution Changes within the Pay Period:" 82 W !,"Date/Time",?24,"Changed by",?61,"Type of Interface" 83 W !,"Code",?12,"Percent",?24,"Cost Center - Description" 84 W ?65,"Fund Ctrl Pt" 85 W !,DASH 86 Q 87 ; 88 LDHOLD ; Pause of more LD changes that will fit on 1 screen. 89 ; 90 N X 91 S LDHOLD=$$ASK^PRSLIB00(1) 92 S X=$G(^PRSPC(DFN,0)) 93 W !,@IOF,?3,$P(X,"^",1) 94 S X=$P(X,"^",9) 95 I X W ?68,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9) 96 W !,DASH 97 D LDHDR 98 Q 99 ; 100 PTP(PRSIEN,PPI) ; Updates hours credited for PT Phys w/ Memorandums 101 ; This API can be used for initial and subsequent calculation 102 ; of the PTP's ESR. 103 ; algorithm for this API follows: 104 ; 1. Grab copy of currently stored pay period hours 105 ; 2. Look at ESR/timecard data to recalculate pay period hours 106 ; 3. Calculate net difference between 1 and 2 107 ; 4. update current pay period with new pp totals from (2) above 108 ; 5. add net diff (3) to memo totals 109 ; 110 N AHRS,AHTCM,AMT,COHRS,DIFFNP,DIFFRG,DIFFWP,INPH,ITHP,ITHW,IWPH 111 N MDAT,MDATA,MEAL,MIEN,MPPIEN,POHC,POT,PPC,PPE 112 N PPHRS,PPNP,PPWP,PRSX,START,STOP,THP,TOT,TOTAL,TOTNP,TOTWP 113 S MDAT=$P($G(^PRST(458,PPI,1)),U,1) 114 S MIEN=+$$MIEN^PRSPUT1(PRSIEN,MDAT) 115 Q:'MIEN ; Not a PTP w/ memo 116 S PPE=$P($G(^PRST(458,PPI,0)),U,1) 117 ; 118 ; Locate this PP in the PTP's memorandum 119 S MPPIEN=$O(^PRST(458.7,MIEN,9,"B",PPE,0)) 120 Q:'MPPIEN ; PP not found within memo (###exception message) 121 ; 122 ;get the current values for this pay period under the memo. 123 S PRSX=$G(^PRST(458.7,MIEN,9,MPPIEN,0)) 124 S PPHRS=+$P(PRSX,U,2) ; Actual hours of work credited 125 S PPNP=+$P(PRSX,U,3) ; Actual hours of Non Pay 126 S PPWP=+$P(PRSX,U,4) ; Actual hours of LWOP 127 K PRSX 128 ; 129 ; Load the memo totals 130 S MDATA=$G(^PRST(458.7,MIEN,0)) 131 S AHRS=+$P(MDATA,U,4) ; Agreed Hours 132 S COHRS=+$P(MDATA,U,9) ; Carryover Hours 133 S ITHW=+$P(MDATA,U,10) ; Initial Total Hours Worked 134 S ITHP=+$P(MDATA,U,11) ; Initial Total Hours Paid 135 S INPH=+$P(MDATA,U,12) ; Initial Non-Pay Hours 136 S IWPH=+$P(MDATA,U,13) ; Initial Without Pay Hours 137 S (AHTCM,DIFFRG,DIFFNP,DIFFWP)=0 138 ; 139 ; Get Non pay and Leave without pay times from 8b string or recalc. 140 N TAMTS 141 S TAMTS("WP","Leave Without Pay")="" 142 S TAMTS("NP","Non-Pay Time")="" 143 D PP8BAMT^PRSPUT3(.TAMTS,PPI,PRSIEN) 144 S TOTAL("WP")=$G(TAMTS("WP","Leave Without Pay")) 145 S TOTAL("NP")=$G(TAMTS("NP","Non-Pay Time")) 146 S DIFFNP=TOTAL("NP")-PPNP 147 S DIFFWP=TOTAL("WP")-PPWP 148 ; 149 ; Loop thru day and ESR segments looking for leave and RG time 150 N DAY,ESR,RGCODES,SEG,TOT 151 S RGCODES="AA,AD,AL,CB,CP,DL,HX,ML,RG,RL,SL,TR,TV" 152 S TOTAL("RG")=0 153 F DAY=1:1:14 D 154 . ; only add totals for supervisor approved days 155 . Q:$$GETSTAT^PRSPESR1(PRSIEN,PPI,DAY)'=5 156 . S ESR=$G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,5)) 157 . Q:ESR="" 158 . F SEG=0:1:6 Q:$P(ESR,U,(5*SEG)+3)="" D 159 . . S TOT=$P(ESR,U,(5*SEG)+3) 160 . . ; Types Of Time that might have been worked in week 1 161 . . I RGCODES[TOT D Q 162 . . . S TOTAL("RG")=TOTAL("RG")+$$AMT(ESR) 163 ; 164 ; Checks for Regular Time 165 S DIFFRG=TOTAL("RG")-PPHRS 166 ; determine number of memo pay periods that have been certified 167 S PRSX=$$MEMCPP^PRSPUT3(MIEN) 168 S PPC=$P(PRSX,U,2)+$S(PPE]$P(PRSX,U):1,1:0) 169 ; 170 ; Update pp totals with current calculated values 171 K IEN4587,PRSFDA 172 S IEN4587=MIEN_"," 173 S PRSFDA(458.701,MPPIEN_","_IEN4587,1)=TOTAL("RG") ; PP new REG hrs 174 S PRSFDA(458.701,MPPIEN_","_IEN4587,2)=TOTAL("NP") ; PP new NP hrs 175 S PRSFDA(458.701,MPPIEN_","_IEN4587,3)=TOTAL("WP") ; PP new WP hrs 176 ; 177 ; update memo grand totals with differences found 178 S TOTNP=INPH+DIFFNP 179 S TOTWP=IWPH+DIFFWP 180 S PRSFDA(458.7,IEN4587,11)=TOTNP ; NP hrs 181 S PRSFDA(458.7,IEN4587,12)=TOTWP ; WP hrs 182 S PRSFDA(458.7,IEN4587,9)=ITHW+DIFFRG ; tot hrs worked (all creditable) 183 ; 184 ; If this is the first time the PP has been processed PPHRS will be null 185 ; so add the average hrs/pp, otherwise this count has already been added 186 S THP=ITHP+$S(PPHRS="":AHRS/26,1:0) 187 S PRSFDA(458.7,IEN4587,10)=$FN(THP-DIFFNP-DIFFWP,"",2) ; tot hrs paid 188 S PRSFDA(458.7,IEN4587,13)=$FN(PPC/26,"",2) ; % of memo completed 189 ; % OF HOURS COMPLETED 190 S POHC=$FN((ITHW+COHRS+DIFFRG)/(AHRS-TOTNP-TOTWP),"",2) 191 S PRSFDA(458.7,IEN4587,14)=POHC 192 ; 193 ; ave hrs/pp to complete mem (if certifying last pay period then then 194 ; you're out of pay periods so use 0.00 to report how many more hours) 195 S AHTCM=$S(PPC>25:"0.00",1:$FN((AHRS-(ITHW+COHRS+DIFFRG)/(26-PPC)),"",2)) 196 S PRSFDA(458.7,IEN4587,15)=AHTCM 197 ; % off target 198 S POT=((AHRS/26)*PPC)-TOTNP-TOTWP 199 S POT=(ITHW+COHRS+DIFFRG)-POT/POT,POT=POT*100,POT=$FN(POT,"",2) 200 S PRSFDA(458.7,IEN4587,16)=POT 201 D FILE^DIE("","PRSFDA") 202 Q 203 ; 204 AMT(ESR) ; Return hours elapsed for time segment in decimal format 205 ; deduct meal 206 ; e.g. AMT=2.5 (2 hours 30 min) 207 N START,STOP,MEAL,AMT,X 208 S START=$P(ESR,U,(5*SEG)+1),STOP=$P(ESR,U,(5*SEG)+2) 209 S MEAL=$P(ESR,U,(5*SEG)+5) 210 S AMT=$$ELAPSE^PRSPESR2(MEAL,START,STOP) 211 S X=$P(AMT,":",2) S X=$S(X=30:5,X=15:25,X=45:75,1:0) 212 S AMT=+$P(AMT,":",1)_"."_X 213 Q AMT -
WorldVistAEHR/trunk/r/PAID-PRS/PRSATE.m
r613 r623 1 PRSATE ;WCIOFO/JAH - Enter/Edit Employee (emp) Tour of Duty (ToD) ;03/15/2005 2 ;;4.0;PAID;**8,11,27,45,55,93,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 N PPI,PPE,PRSTLV,TLI,TLE,DFN 5 ; 6 ; PPI = pay period (pp) internal #. 7 ; PPE = pp external form (99-06). 8 ; PRSTLV = flag indicates timekeeper (TK) in T&L lookup ^PRSAUTL. 9 ; TLI = T&L unit internal #. 10 ; TLU = T&L unit # 3-digit 11 ; 12 ; -Get current pp-internal & external. -Ask user for T&L. 13 ; -Loop to ask for emp until TK is done. 14 ; --Emp lookup screens emps not in T&L returned by PRSAUTL call. 15 ; 16 S PRSTLV=2 D ^PRSAUTL Q:TLI<1 17 F S DFN=$$GETEMP^PRSATE6(TLE) Q:DFN<1 D 18 . S PPI=$P(^PRST(458,0),"^",3),PPE=$P($G(^PRST(458,PPI,0)),"^",1) 19 . D TOUREDIT(DFN,PPI,PPE,TLI,TLE,PRSTLV) 20 Q 21 ;======================= 22 ; 23 TOUREDIT(DFN,PPI,PPE,TLI,TLE,PRSTLV) ; 24 ; 25 N C0,NH,FLX,PMP,PP,PB,ENT,SRT,WTL,TYP,Z,TD,ERROR,NOERROR 26 ; 27 ; Entitlement lookup leaks many variables. Following R used in 28 ; this routine but may be looked up again despite the fact they R 29 ; leaked by ^PRSAENT. See PRSAENT for further doc. 30 ; 31 ; C0=emps 0 node in file 450 NH= emps 8B normal hrs 32 ; FLX= compressed/flextime code (0=none,C=compressed,F=flextime) 33 ; PMP= premium pay indicator 34 ; ( D=entitled Sun., F=entitled Sat./Sun., 35 ; E=entitled variable Sat./Sun. premium pay, 36 ; G=entitled variable Sun. prem pay, X=title 5 emps 37 ; R,C,O=different types of firefighters) 38 ; * PP= emps pay plan 39 ; DB = pay basis-1:full,2:part,3:intermit 40 ; ENT= 39 char entitlement string 41 ; 42 ; Entitlement lookup. 43 ; 44 D ^PRSAENT I ENT="" D ERROR(1) S OUT=1 Q 45 ; 46 ; Display header/Ask pp (NOL^PRSATE2 returns SRT = Current, Next, Last) 47 ; 48 D NOW^%DTC S NOW=% K % 49 W:$E(IOST,1,2)="C-" @IOF 50 W !?26,"VA TIME & ATTENDANCE SYSTEM" 51 W !?29,"EMPLOYEE TOUR OF DUTY" 52 D HDR^PRSADP1,NOL^PRSATE2 53 Q:SRT="^" 54 I SRT="L" S PPI=PPI-1,PPE=$P($G(^PRST(458,PPI,0)),"^",1) 55 ; 56 ; Get emp's flexitime code 57 ; 58 S FLX=$$FLEXIND^PRSATE6(PPI,DFN,SRT) 59 ; 60 ; Is emp entitled reg. shed. hrs.? 61 ; 62 I $E(ENT,1)="0" D 63 . S Z=$E(ENT,2),TD=$S(Z="D":3,1:4) D NONE 64 E D 65 .; 66 .; initialize t&l for this ToD 67 .; 68 . S WTL=TLI 69 . I "NL"[SRT D 70 .. S TYP=0 71 . E D 72 .. S TYP=$$ISTEMPTR() 73 ..; 74 ..; For temp ToDs--ask user for T&L ToD will be worked 75 ..; Quit if we don't get a valid T&L unit. 76 ..; 77 .. I TYP S WTL=$$ASKTLWRK^PRSATE6(TLE) 78 .; 79 .; Save current ToD in case user aborts with an unacceptable ToD. 80 .; 81 . D SAVETOUR^PRSATE6(PPI,DFN) 82 .; 83 . I WTL'<1,TYP'["^" D 84 .. D A1 85 ..; 86 ..; verify firefighter ToD after compressed ind. edit. Don't accept 87 ..; ToD until its within guidlines. If TK force exits, restore old ToD. 88 ..; 89 .. S NOERROR=0 90 .. F D Q:NOERROR 91 ... N ERROR D FFTOUR^PRSATE6(PPI,DFN,SRT,.ERROR) 92 ... I $$ISERRORS^PRSATE6(.ERROR) D 93 .... I $$ASKTOFIX^PRSATE6() D 94 ..... D A1 95 .... E D 96 ..... D RESTORE^PRSATE6(PPI,DFN) S NOERROR=1 97 ... E D 98 .... S NOERROR=1 99 K NOW Q 100 ;======================= 101 ; 102 ISTEMPTR() ; IS TEMPORARY ToD ? 103 ; Ask user if ToD is temp or perm & convert TYP to true false flag 104 ; Permanent set TYP=0, Temporary set TYP=true (1) 105 ; 106 S TYP=$$ASKTEMP^PRSATE6() I TYP'["^" S TYP=$E(TYP,1)="T",WTL=TLI 107 Q TYP 108 ;======================= 109 ; 110 A1 ; Set up for emps ToD look up. Screen allows Daily ToDs & days off 111 ; for daily emps. Everyone else gets days off & all other ToDs. 112 ; Screen further ensures ToD is available either to all t&ls 113 ; or to t&l that this emp is working in. 114 ; 115 N DIC,X 116 S DIC="^PRST(457.1,",DIC(0)="AEQMN" 117 S DIC("S")="I "_$S($E(ENT,1)="D":"Y<3",1:"Y>5!(Y=1)")_",$P(^PRST(457.1,+Y,0),U,4)!($D(^PRST(457.1,+Y,""T"",""B"",WTL)))" 118 ; 119 ; Setup a fixed or varying ToD. Compressed ToDs must be varying; 120 ; ask TK about all others. 121 ; 122 S DB=$P(C0,U,10) I FLX="C"!("KM"[PP&(DB=1)&(NH=72)) D 123 . D VAR 124 E D 125 . S X=$$ASKFIXED() 126 . Q:X="^" 127 . I X="N" D 128 .. D VAR 129 . E D FX 130 K DB Q 131 ;======================= 132 ; 133 FX ; Fixed ToD 134 S DIC("A")="Select TOUR OF DUTY: " 135 W ! D ^DIC 136 Q:Y'>0 137 S TD=+Y,Y=$G(^PRST(457.1,TD,1)),TDH=$P(^(0),"^",6),HRS=TDH*10 138 S (ZENT,STR)="" 139 D OT^PRSATP,VS^PRSATE0 140 I STR'="" W *7,!!,STR G FX 141 I '$D(^PRST(458,PPI,"E",DFN,"D",0)) S ^(0)="^458.02^14^14" 142 I SRT="N" D 143 . D F1 144 E D 145 . F DAY=2:1:6,9:1:13 D SET 146 . S TD=1,(Y,TDH)="" F DAY=1,7,8,14 D SET 147 . W " ... done" D:HRS'=NH ERROR(2,NH,HRS) 148 . D T2,^PRSATE5 149 D HOL,RS K HRS,STR 150 Q 151 ;======================= 152 ; 153 F1 F DAY=2:1:6,9:1:13 D NX 154 S TD=1 F DAY=1,7,8,14 D NX 155 W " ... done" 156 D:HRS'=NH ERROR(2,NH,HRS) 157 Q 158 ;======================= 159 ; 160 VAR ; Variable ToD 161 D ^PRSATE0 162 I SRT'="N" D T2,^PRSATE5 163 D HOL,RS 164 Q 165 ;======================= 166 ; 167 NONE ; No ToD 168 N TYP2,UPDT,Y,TDH 169 W !!,"This is an intermittent employee with no specified tour." 170 W !!,"Time records will now be updated to indicate this." 171 I '$D(^PRST(458,PPI,"E",DFN,"D",0)) S ^(0)="^458.02^14^14" 172 I '$$PERM^PRSALIB(PPI,DFN) D 173 . W !!,"Not all tour days are assigned a permanent status." 174 . I $$UPDTQ^PRSALIB(),$$TMPST^PRSALIB(.TYP2) D UPDSTAT^PRSALIB(PPI,DFN,TYP2) 175 S (Y,TDH)="",TYP=0,WTL=TLI 176 I SRT="N" D 177 . F DAY=1:1:14 D NX 178 E D 179 . F DAY=1:1:14 D SET 180 W " ... done" 181 D HOL,RS 182 Q 183 ;======================= 184 ; 185 RS ; Get Comp Ind 186 S Y=$G(^PRST(458,PPI,"E",DFN,0)) 187 S FLX=$S((SRT="N")&($P(Y,U,7)]""):$P(Y,U,7),1:$P(Y,U,6)) 188 S DIR(0)="SAM^C:Compressed;F:Flexitime;0:None" 189 S DIR("A")="Compressed Tour Indicator: " 190 S DIR("B")=$S(FLX="C":"Compressed",FLX="F":"Flexitime",1:"None") 191 D ^DIR K DIR I "^C^F^0^"'[(U_Y_U) S Y=FLX 192 ; 193 ; Intermittent employee cannot have compressed tour. 194 ; 195 I $P(C0,U,10)=3,Y="C" D G RS 196 . W *7,!?5,"Compressed tour not valid for this employee." 197 ; 198 I Y="F" S Z=0 D I Z G RS 199 .S PAY=$P(C0,U,21),PB=$P(C0,U,20) 200 .I "0123456789GU"'[PAY S Z=1 201 .I PAY="G",PB'=2 S Z=1 202 .I PAY="U","27EXT"'[PB S Z=1 203 .I Z W *7,!?5,"Flexitime not valid for this employee." 204 .Q 205 S $P(^PRST(458,PPI,"E",DFN,0),U,$S(SRT="N":7,1:6))=Y 206 I $D(^PRST(458,"ATC",DFN)) D UPD^PRSASAL 207 K PAY,ZENT Q 208 ;======================= 209 ; 210 NX ; Set Next ToD 211 S Z=$G(^PRST(458,PPI,"E",DFN,"D",DAY,0)) 212 Q:$P(Z,"^",2)=TD&('$P(Z,"^",3)) 213 ; 214 S $P(Z,"^",3,4)="2^"_TD,$P(Z,"^",10,11)=DUZ_"^"_NOW 215 S ^PRST(458,PPI,"E",DFN,"D",DAY,0)=Z,^PRST(458,"ATC",DFN,PPI,DAY)="" 216 Q 217 ;======================= 218 ; 219 SET ; Set ToD 220 N ZLASTPP 221 S U="^" 222 ; 223 ; Get Zero node of emp pp rec, Old ToD, & Prior scheduled ToD. 224 ; ZLASTPP is true if a ToD present on this day last pp. 225 ; 226 S Z=$G(^PRST(458,PPI,"E",DFN,"D",DAY,0)) 227 S ZLASTPP=$P($G(^PRST(458,PPI-1,"E",DFN,"D",DAY,0)),U,2)'="" 228 S OLD=$P(Z,U,2),SCH=$P(Z,U,4) 229 ; 230 ; Quit if old ToD=this ToD & emp rec start/stop=ToD file start/stop. 231 ; 232 Q:(OLD=TD)&($G(^PRST(458,PPI,"E",DFN,"D",DAY,1))=Y) 233 ; 234 ; Z is updated with new ToD info & replaces the emp ToD record. 235 ; 236 S $P(Z,U,8)=TDH 237 S $P(Z,U,10,11)=DUZ_U_NOW 238 I $P(Z,U,12) S $P(Z,U,12)="" ; remove holiday flag 239 ; 240 ; Temp ToD, store T&L ToD will be worked if it's not emp's usual t&l. 241 ; 242 I TYP S:TLI'=WTL $P(Z,U,9)=WTL 243 ; 244 ; No existing ToD on this day. 245 ; 246 I OLD="" D 247 . S $P(Z,U,1,3)=DAY_U_TD_U_TYP 248 . I ZLASTPP D S0 249 E D 250 .; 251 .; clean out postings and other ToD info since ToD is changing 252 .; 253 . D CLEANTOD(PPI,DFN,DAY,TD) 254 .; 255 .; 256 .; 257 . S:SCH $P(Z,U,5,7)="^^" 258 . I SCH="" D 259 .. S $P(Z,U,2,4)=TD_U_TYP_U_OLD 260 .. D S0 261 . E D 262 .. I SCH=TD D 263 ... S $P(Z,U,2,4)=TD_"^^" 264 ... K ^PRST(458,"ATC",DFN,PPI,DAY) 265 .. E D 266 ... S $P(Z,U,2,3)=TD_U_TYP 267 ... D S0 268 ; 269 D S1 270 K OLD,SCH Q 271 ;======================= 272 ; 273 ; Set up x-ref for supervisor approval of ToD change 274 ; 275 S0 S ^PRST(458,"ATC",DFN,PPI,DAY)="" 276 Q 277 ;======================= 278 ; 279 S1 ; 280 S ^PRST(458,PPI,"E",DFN,"D",DAY,0)=Z S:Y'="" ^(1)=Y 281 Q 282 ;======================= 283 ; 284 T2 ; Ask if second ToD 285 N X 286 ; 287 ; Don't ask for Daily ToDs 288 ; 289 Q:$E(ENT,1)="D" 290 ; 291 S X=$$ASK2NDTR() 292 Q:X'="Y" G ^PRSATE4 293 ;======================= 294 ; 295 HOL ; Determine if Holiday within ToD 296 N DAY 297 D ^PRSAPPH 298 Q:'$D(HOL) 299 S TT="HX",DUP=1 300 D E^PRSAPPH K DUP,HOL,TT 301 Q 302 ;======================= 303 ; 304 CLEANTOD(PPI,DFN,DAY,TD) ; CLEAN OUT TOUR 305 N PRSDT,MIEN 306 K ^PRST(458,PPI,"E",DFN,"D",DAY,1),^(2),^(3),^(10) I TD<5 K ^(4) S $P(Z,U,13,15)="^^" 307 ; if employee is PTP with active memo then reset the ESR day 308 S PRSDT=$P($G(^PRST(458,PPI,1)),U,DAY) 309 S MIEN=$$MIEN^PRSPUT1(DFN,PRSDT) 310 I MIEN D 311 . N PRSFDA 312 . S PRSFDA(458.02,DAY_","_DFN_","_PPI_",",146)="3" ; status = resubmit 313 . S PRSFDA(458.02,DAY_","_DFN_","_PPI_",",148)="Tour Changed" ; remarks 314 . D FILE^DIE("","PRSFDA"),MSG^DIALOG() 315 Q 316 ;======================= 317 ; 318 ERROR(NUM,VAR1,VAR2) ; 319 W *7,!! 320 I NUM=1 W "Employee has no Pay Entitlement table entry." 321 I NUM=2 D 322 . Q:$G(NH)=112 323 . W "Warning: Normal Hours are ",$G(VAR1),"; Tour Hours are ",$G(VAR2) 324 Q 325 ;======================= 326 ; 327 ASKFIXED() ;GET USER'S YES OR NO RESPONSE TO FIXED ToD QUESTION 328 N DIR,DIRUT,Y 329 S DIR("A")="Do you wish to enter a fixed Mon-Fri Tour" 330 S DIR(0)="Y" 331 S DIR("?")="Answer NO to create any other type of tour." 332 S DIR("?",1)="Fixed tours are Monday - Friday with the same hours." 333 D ^DIR 334 Q $S(Y=1:"Y",Y=0:"N",1:"^") 335 ;======================= 336 ; 337 ASK2NDTR() ;GET USER'S YES OR NO RESPONSE TO 2nd ToD QUESTION 338 N DIR,DIRUT,Y 339 S DIR("A")="Do you wish to enter a Second Tour for any Day" 340 S DIR(0)="Y" 341 S DIR("B")="N" 342 S DIR("?",1)="Answer Yes to add a second tour. No to continue." 343 S DIR("?")="Enter ^ to escape and cancel this tour change." 344 D ^DIR 345 Q $S(Y=1:"Y",Y=0:"N",1:"^") 346 ;======================= 347 ; 1 PRSATE ;WCIOFO/JAH - Enter/Edit Employee (emp) Tour of Duty (ToD) ;03/15/2005 2 ;;4.0;PAID;**8,11,27,45,55,93**;Sep 21, 1995;Build 7 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 N PPI,PPE,PRSTLV,TLI,TLE,DFN 5 ; 6 ; PPI = pay period (pp) internal #. 7 ; PPE = pp external form (99-06). 8 ; PRSTLV = flag indicates timekeeper (TK) in T&L lookup ^PRSAUTL. 9 ; TLI = T&L unit internal #. 10 ; TLU = T&L unit # 3-digit 11 ; 12 ; -Get current pp-internal & external. -Ask user for T&L. 13 ; -Loop to ask for emp until TK is done. 14 ; --Emp lookup screens emps not in T&L returned by PRSAUTL call. 15 ; 16 S PRSTLV=2 D ^PRSAUTL Q:TLI<1 17 F S DFN=$$GETEMP^PRSATE6(TLE) Q:DFN<1 D 18 . S PPI=$P(^PRST(458,0),"^",3),PPE=$P($G(^PRST(458,PPI,0)),"^",1) 19 . D TOUREDIT(DFN,PPI,PPE,TLI,TLE,PRSTLV) 20 Q 21 ;======================= 22 ; 23 TOUREDIT(DFN,PPI,PPE,TLI,TLE,PRSTLV) ; 24 ; 25 N C0,NH,FLX,PMP,PP,PB,ENT,SRT,WTL,TYP,Z,TD,ERROR,NOERROR 26 ; 27 ; Entitlement lookup leaks many variables. Following R used in 28 ; this routine but may be looked up again despite the fact they R 29 ; leaked by ^PRSAENT. See PRSAENT for further doc. 30 ; 31 ; C0=emps 0 node in file 450 NH= emps 8B normal hrs 32 ; FLX= compressed/flextime code (0=none,C=compressed,F=flextime) 33 ; PMP= premium pay indicator 34 ; ( D=entitled Sun., F=entitled Sat./Sun., 35 ; E=entitled variable Sat./Sun. premium pay, 36 ; G=entitled variable Sun. prem pay, X=title 5 emps 37 ; R,C,O=different types of firefighters) 38 ; * PP= emps pay plan 39 ; DB = pay basis-1:full,2:part,3:intermit 40 ; ENT= 39 char entitlement string 41 ; 42 ; Entitlement lookup. 43 ; 44 D ^PRSAENT I ENT="" D ERROR(1) S OUT=1 Q 45 ; 46 ; Display header/Ask pp (NOL^PRSATE2 returns SRT = Current, Next, Last) 47 ; 48 D NOW^%DTC S NOW=% 49 W:$E(IOST,1,2)="C-" @IOF 50 W !?26,"VA TIME & ATTENDANCE SYSTEM" 51 W !?29,"EMPLOYEE TOUR OF DUTY" 52 D HDR^PRSADP1,NOL^PRSATE2 53 Q:SRT="^" 54 I SRT="L" S PPI=PPI-1,PPE=$P($G(^PRST(458,PPI,0)),"^",1) 55 ; 56 ; Get emp's flexitime code 57 ; 58 S FLX=$$FLEXIND^PRSATE6(PPI,DFN,SRT) 59 ; 60 ; Is emp entitled reg. shed. hrs.? 61 ; 62 I $E(ENT,1)="0" D 63 . S Z=$E(ENT,2),TD=$S(Z="D":3,1:4) D NONE 64 E D 65 .; 66 .; initialize t&l for this ToD 67 .; 68 . S WTL=TLI 69 . I "NL"[SRT D 70 .. S TYP=0 71 . E D 72 .. S TYP=$$ISTEMPTR() 73 ..; 74 ..; For temp ToDs--ask user for T&L ToD will be worked 75 ..; Quit if we don't get a valid T&L unit. 76 ..; 77 .. I TYP S WTL=$$ASKTLWRK^PRSATE6(TLE) 78 .; 79 .; Save current ToD in case user aborts with an unacceptable ToD. 80 .; 81 . D SAVETOUR^PRSATE6(PPI,DFN) 82 .; 83 . I WTL'<1,TYP'["^" D 84 .. D A1 85 ..; 86 ..; verify firefighter ToD after compressed ind. edit. Don't accept 87 ..; ToD until its within guidlines. If TK force exits, restore old ToD. 88 ..; 89 .. S NOERROR=0 90 .. F D Q:NOERROR 91 ... N ERROR D FFTOUR^PRSATE6(PPI,DFN,SRT,.ERROR) 92 ... I $$ISERRORS^PRSATE6(.ERROR) D 93 .... I $$ASKTOFIX^PRSATE6() D 94 ..... D A1 95 .... E D 96 ..... D RESTORE^PRSATE6(PPI,DFN) S NOERROR=1 97 ... E D 98 .... S NOERROR=1 99 Q 100 ;======================= 101 ; 102 ISTEMPTR() ; IS TEMPORARY ToD ? 103 ; Ask user if ToD is temp or perm & convert TYP to true false flag 104 ; Permanent set TYP=0, Temporary set TYP=true (1) 105 ; 106 S TYP=$$ASKTEMP^PRSATE6() I TYP'["^" S TYP=$E(TYP,1)="T",WTL=TLI 107 Q TYP 108 ;======================= 109 ; 110 A1 ; Set up for emps ToD look up. Screen allows Daily ToDs & days off 111 ; for daily emps. Everyone else gets days off & all other ToDs. 112 ; Screen further ensures ToD is available either to all t&ls 113 ; or to t&l that this emp is working in. 114 ; 115 N DIC,X 116 S DIC="^PRST(457.1,",DIC(0)="AEQMN" 117 S DIC("S")="I "_$S($E(ENT,1)="D":"Y<3",1:"Y>5!(Y=1)")_",$P(^PRST(457.1,+Y,0),U,4)!($D(^PRST(457.1,+Y,""T"",""B"",WTL)))" 118 ; 119 ; Setup a fixed or varying ToD. Compressed ToDs must be varying; 120 ; ask TK about all others. 121 ; 122 I FLX="C" D 123 . D VAR 124 E D 125 . S X=$$ASKFIXED() 126 . Q:X="^" 127 . I X="N" D 128 .. D VAR 129 . E D FX 130 Q 131 ;======================= 132 ; 133 FX ; Fixed ToD 134 S DIC("A")="Select TOUR OF DUTY: " 135 W ! D ^DIC 136 Q:Y'>0 137 S TD=+Y,Y=$G(^PRST(457.1,TD,1)),TDH=$P(^(0),"^",6),HRS=TDH*10 138 S (ZENT,STR)="" 139 D OT^PRSATP,VS^PRSATE0 140 I STR'="" W *7,!!,STR G FX 141 I '$D(^PRST(458,PPI,"E",DFN,"D",0)) S ^(0)="^458.02^14^14" 142 I SRT="N" D 143 . D F1 144 E D 145 . F DAY=2:1:6,9:1:13 D SET 146 . S TD=1,(Y,TDH)="" F DAY=1,7,8,14 D SET 147 . W " ... done" D:HRS'=NH ERROR(2,NH,HRS) 148 . D T2,^PRSATE5 149 D HOL,RS 150 Q 151 ;======================= 152 ; 153 F1 F DAY=2:1:6,9:1:13 D NX 154 S TD=1 F DAY=1,7,8,14 D NX 155 W " ... done" 156 D:HRS'=NH ERROR(2,NH,HRS) 157 Q 158 ;======================= 159 ; 160 VAR ; Variable ToD 161 D ^PRSATE0 162 I SRT'="N" D T2,^PRSATE5 163 D HOL,RS 164 Q 165 ;======================= 166 ; 167 NONE ; No ToD 168 N TYP2,UPDT,Y,TDH 169 W !!,"This is an intermittent employee with no specified tour." 170 W !!,"Time records will now be updated to indicate this." 171 I '$D(^PRST(458,PPI,"E",DFN,"D",0)) S ^(0)="^458.02^14^14" 172 I '$$PERM^PRSALIB(PPI,DFN) D 173 . W !!,"Not all tour days are assigned a permanent status." 174 . I $$UPDTQ^PRSALIB(),$$TMPST^PRSALIB(.TYP2) D UPDSTAT^PRSALIB(PPI,DFN,TYP2) 175 S (Y,TDH)="",TYP=0,WTL=TLI 176 I SRT="N" D 177 . F DAY=1:1:14 D NX 178 E D 179 . F DAY=1:1:14 D SET 180 W " ... done" 181 D HOL,RS 182 Q 183 ;======================= 184 ; 185 RS ; Get Comp Ind 186 S Y=$G(^PRST(458,PPI,"E",DFN,0)) 187 S FLX=$S((SRT="N")&($P(Y,U,7)]""):$P(Y,U,7),1:$P(Y,U,6)) 188 S DIR(0)="SAM^C:Compressed;F:Flexitime;0:None" 189 S DIR("A")="Compressed Tour Indicator: " 190 S DIR("B")=$S(FLX="C":"Compressed",FLX="F":"Flexitime",1:"None") 191 D ^DIR K DIR I "^C^F^0^"'[(U_Y_U) S Y=FLX 192 ; 193 ; Intermittent employee cannot have compressed tour. 194 ; 195 I $P(C0,U,10)=3,Y="C" D G RS 196 . W *7,!?5,"Compressed tour not valid for this employee." 197 ; 198 I Y="F" S Z=0 D I Z G RS 199 .S PAY=$P(C0,U,21),PB=$P(C0,U,20) 200 .I "0123456789GU"'[PAY S Z=1 201 .I PAY="G",PB'=2 S Z=1 202 .I PAY="U","27EXT"'[PB S Z=1 203 .I Z W *7,!?5,"Flexitime not valid for this employee." 204 .Q 205 S $P(^PRST(458,PPI,"E",DFN,0),U,$S(SRT="N":7,1:6))=Y 206 I $D(^PRST(458,"ATC",DFN)) D UPD^PRSASAL 207 Q 208 ;======================= 209 ; 210 NX ; Set Next ToD 211 S Z=$G(^PRST(458,PPI,"E",DFN,"D",DAY,0)) 212 Q:$P(Z,"^",2)=TD&('$P(Z,"^",3)) 213 ; 214 S $P(Z,"^",3,4)="2^"_TD,$P(Z,"^",10,11)=DUZ_"^"_NOW 215 S ^PRST(458,PPI,"E",DFN,"D",DAY,0)=Z,^PRST(458,"ATC",DFN,PPI,DAY)="" 216 Q 217 ;======================= 218 ; 219 SET ; Set ToD 220 N ZLASTPP 221 S U="^" 222 ; 223 ; Get Zero node of emp pp rec, Old ToD, & Prior scheduled ToD. 224 ; ZLASTPP is true if a ToD present on this day last pp. 225 ; 226 S Z=$G(^PRST(458,PPI,"E",DFN,"D",DAY,0)) 227 S ZLASTPP=$P($G(^PRST(458,PPI-1,"E",DFN,"D",DAY,0)),U,2)'="" 228 S OLD=$P(Z,U,2),SCH=$P(Z,U,4) 229 ; 230 ; Quit if old ToD=this ToD & emp rec start/stop=ToD file start/stop. 231 ; 232 Q:(OLD=TD)&($G(^PRST(458,PPI,"E",DFN,"D",DAY,1))=Y) 233 ; 234 ; Z is updated with new ToD info & replaces the emp ToD record. 235 ; 236 S $P(Z,U,8)=TDH 237 S $P(Z,U,10,11)=DUZ_U_NOW 238 I $P(Z,U,12) S $P(Z,U,12)="" ; remove holiday flag 239 ; 240 ; Temp ToD, store T&L ToD will be worked if it's not emp's usual t&l. 241 ; 242 I TYP S:TLI'=WTL $P(Z,U,9)=WTL 243 ; 244 ; No existing ToD on this day. 245 ; 246 I OLD="" D 247 . S $P(Z,U,1,3)=DAY_U_TD_U_TYP 248 . I ZLASTPP D S0 249 E D 250 .; 251 .; clean out postings and other ToD info since ToD is changing 252 .; 253 . D CLEANTOD(PPI,DFN,DAY,TD) 254 .; 255 .; 256 .; 257 . S:SCH $P(Z,U,5,7)="^^" 258 . I SCH="" D 259 .. S $P(Z,U,2,4)=TD_U_TYP_U_OLD 260 .. D S0 261 . E D 262 .. I SCH=TD D 263 ... S $P(Z,U,2,4)=TD_"^^" 264 ... K ^PRST(458,"ATC",DFN,PPI,DAY) 265 .. E D 266 ... S $P(Z,U,2,3)=TD_U_TYP 267 ... D S0 268 ; 269 D S1 270 Q 271 ;======================= 272 ; 273 ; Set up x-ref for supervisor approval of ToD change 274 ; 275 S0 S ^PRST(458,"ATC",DFN,PPI,DAY)="" 276 Q 277 ;======================= 278 ; 279 S1 ; 280 S ^PRST(458,PPI,"E",DFN,"D",DAY,0)=Z S:Y'="" ^(1)=Y 281 Q 282 ;======================= 283 ; 284 T2 ; Ask if second ToD 285 N X 286 ; 287 ; Don't ask for Daily ToDs 288 ; 289 Q:$E(ENT,1)="D" 290 ; 291 S X=$$ASK2NDTR() 292 Q:X'="Y" G ^PRSATE4 293 ;======================= 294 ; 295 HOL ; Determine if Holiday within ToD 296 N DAY 297 D ^PRSAPPH 298 Q:'$D(HOL) 299 S TT="HX",DUP=1 300 D E^PRSAPPH 301 Q 302 ;======================= 303 ; 304 CLEANTOD(PPI,DFN,DAY,TD) ; CLEAN OUT TOUR 305 N PRSDT,MIEN 306 K ^PRST(458,PPI,"E",DFN,"D",DAY,1),^(2),^(3),^(10) I TD<5 K ^(4) S $P(Z,U,13,15)="^^" 307 ; if employee is PTP with active memo then reset the ESR day 308 S PRSDT=$P($G(^PRST(458,PPI,1)),U,DAY) 309 S MIEN=$$MIEN^PRSPUT1(DFN,PRSDT) 310 I MIEN D 311 . N PRSFDA 312 . S PRSFDA(458.02,DAY_","_DFN_","_PPI_",",146)="3" ; status = resubmit 313 . S PRSFDA(458.02,DAY_","_DFN_","_PPI_",",148)="Tour Changed" ; remarks 314 . D FILE^DIE("","PRSFDA"),MSG^DIALOG() 315 Q 316 ;======================= 317 ; 318 ERROR(NUM,VAR1,VAR2) ; 319 W *7,!! 320 I NUM=1 W "Employee has no Pay Entitlement table entry." 321 I NUM=2 D 322 . Q:$G(NH)=112 323 . W "Warning: Normal Hours are ",$G(VAR1),"; Tour Hours are ",$G(VAR2) 324 Q 325 ;======================= 326 ; 327 ASKFIXED() ;GET USER'S YES OR NO RESPONSE TO FIXED ToD QUESTION 328 N DIR,DIRUT,Y 329 S DIR("A")="Do you wish to enter a fixed Mon-Fri Tour" 330 S DIR(0)="Y" 331 S DIR("?")="Answer NO to create any other type of tour." 332 S DIR("?",1)="Fixed tours are Monday - Friday with the same hours." 333 D ^DIR 334 S RESP=$S(Y=1:"Y",Y=0:"N",1:"^") 335 Q RESP 336 ;======================= 337 ; 338 ASK2NDTR() ;GET USER'S YES OR NO RESPONSE TO 2nd ToD QUESTION 339 N DIR,DIRUT,Y 340 S DIR("A")="Do you wish to enter a Second Tour for any Day" 341 S DIR(0)="Y" 342 S DIR("B")="N" 343 S DIR("?",1)="Answer Yes to add a second tour. No to continue." 344 S DIR("?")="Enter ^ to escape and cancel this tour change." 345 D ^DIR 346 S RESP=$S(Y=1:"Y",Y=0:"N",1:"^") 347 Q RESP 348 ;======================= 349 ; -
WorldVistAEHR/trunk/r/PAID-PRS/PRSATE0.m
r613 r623 1 PRSATE0 ; HISC/REL-Edit Variable Tours ;5/30/95 14:37 2 ;;4.0;PAID;**112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 S TOLD="" F K=1:1:14 S Z=$P($G(^PRST(458,PPI,"E",DFN,"D",K,0)),"^",2),$P(TOLD,"^",K)=Z I SRT="N",$P($G(^(0)),"^",3) S $P(TOLD,"^",K)=$P(^(0),"^",4) 5 K K S ^PRST(458,PPI,"E",DFN,"T")=TOLD D DT^PRSATE2 6 K DDSFILE,DA,DR,PRSAERR S DDSFILE=458,DDSFILE(1)=458.01,DA(1)=PPI,DA=DFN 7 S DR="[PRSA TE EDIT]" D ^DDS K DS Q:$D(PRSAERR) 8 S TNEW=$G(^PRST(458,PPI,"E",DFN,"T")) K ^PRST(458,PPI,"E",DFN,"T") 9 I '$D(^PRST(458,PPI,"E",DFN,"D",0)) S ^(0)="^458.02^14^14" 10 F DAY=1:1:14 S TD=$P(TNEW,"^",DAY) I TD>0 D S1 11 K TNEW,TOLD Q 12 S1 ; Set Tour if necessary 13 I TD=$P(TOLD,"^",DAY),$G(^PRST(457.1,+TD,1))=$G(^PRST(457.1,+$P(TOLD,"^",DAY),1)) Q 14 I SRT'="N" S Y=$G(^PRST(457.1,TD,1)),TDH=$P(^(0),"^",6) D SET^PRSATE Q 15 D NX^PRSATE Q 16 VS ; Validate tour segments 17 S TRG=0 F K=1:3:19 Q:$P(Y,"^",K)="" S Z=$P(Y,"^",K+2) S:'Z TRG=1 I Z D 18 .S Z=$P($G(^PRST(457.2,Z,0)),"^",2) I Z="RG" S TRG=1 Q 19 .I ZENT'[Z S STR="Tour Indicator contains type of time to which employee is not entitled." 20 .Q 21 Q 22 VAL ; Validate Tour 23 N NAWS,SNAWS,TDT S (ZENT,STR)="" K PRSAERR D OT^PRSATP S DB=$P(C0,U,10) I "KM"[PP,DB=1,NH=72 S NAWS=1 24 S (HRS,TRS,TDT)=0 F DAY=1:1:14 D I STR'="" G V1 25 .S TD=$$GET^DDSVAL(DIE,.DA,DAY+200),Z=$P($G(^PRST(457.1,+TD,0)),"^",6) S:Z HRS=HRS+Z S Y=$G(^(1)) 26 .I DAY=7!(DAY=14)&'TDT S TDT=$P($G(^PRST(457.1,+TD,0)),U,5)="Y" 27 .I $D(NAWS) S:Z'=12&Z NAWS=0 S $P(SNAWS,U,DAY)=TD I Z=12 S NAWS(DAY-1\7+1)=$G(NAWS(DAY-1\7+1))+1 28 .D VS S:TRG TRS=TRS+1 29 I FLX="C",TRS>9 S STR="Warning: Compressed Schedule has more than 9 Tours!" D HLP^DDSUTL(.STR) 30 I NH'=HRS,NH'=112 S STR="Warning: Normal Hours are "_NH_"; Tour Hours are "_HRS D HLP^DDSUTL(.STR) 31 I $D(NAWS) D 32 .I $G(NAWS(1))'=3!($G(NAWS(2))'=3)!'NAWS S STR=$P($T(NAWS1),";",3) D HLP^DDSUTL(.STR) 33 .D TOURHRS^PRSARC07(.HRS,PPI,DFN,SNAWS) 34 .I $G(HRS("W1"))'=36!($G(HRS("W2"))'=36) S STR=$P($T(NAWS2),";",3) D HLP^DDSUTL(.STR) 35 .I $G(TDT) S STR=$P($T(NAWS3),";",3) D HLP^DDSUTL(.STR) 36 K K,STR,TRG,TRS Q 37 V1 S (DDSERROR,PRSAERR)=1 D HLP^DDSUTL(.STR) K DDSERROR Q 38 NAWS1 ;;Warning: There are not three 12 hour tours in week 1 and/or week 2 for this AWS 36/40 Nurse 39 NAWS2 ;;Warning: Hours in week 1 and/or week 2 are not 36 for this AWS 36/40 Nurse. 40 NAWS3 ;;Warning: Tour overlaps two administrative work weeks for this 36/40 Nurse. 1 PRSATE0 ; HISC/REL-Edit Variable Tours ;5/30/95 14:37 2 ;;4.0;PAID;;Sep 21, 1995 3 S TOLD="" F K=1:1:14 S Z=$P($G(^PRST(458,PPI,"E",DFN,"D",K,0)),"^",2),$P(TOLD,"^",K)=Z I SRT="N",$P($G(^(0)),"^",3) S $P(TOLD,"^",K)=$P(^(0),"^",4) 4 S ^PRST(458,PPI,"E",DFN,"T")=TOLD D DT^PRSATE2 5 K DDSFILE,DA,DR,PRSAERR S DDSFILE=458,DDSFILE(1)=458.01,DA(1)=PPI,DA=DFN 6 S DR="[PRSA TE EDIT]" D ^DDS K DS Q:$D(PRSAERR) 7 S TNEW=$G(^PRST(458,PPI,"E",DFN,"T")) K ^PRST(458,PPI,"E",DFN,"T") 8 I '$D(^PRST(458,PPI,"E",DFN,"D",0)) S ^(0)="^458.02^14^14" 9 F DAY=1:1:14 S TD=$P(TNEW,"^",DAY) I TD>0 D S1 10 Q 11 S1 ; Set Tour if necessary 12 I TD=$P(TOLD,"^",DAY),$G(^PRST(457.1,+TD,1))=$G(^PRST(457.1,+$P(TOLD,"^",DAY),1)) Q 13 I SRT'="N" S Y=$G(^PRST(457.1,TD,1)),TDH=$P(^(0),"^",6) D SET^PRSATE Q 14 D NX^PRSATE Q 15 VS ; Validate tour segments 16 S TRG=0 F K=1:3:19 Q:$P(Y,"^",K)="" S Z=$P(Y,"^",K+2) S:'Z TRG=1 I Z D 17 .S Z=$P($G(^PRST(457.2,Z,0)),"^",2) I Z="RG" S TRG=1 Q 18 .I ZENT'[Z S STR="Tour Indicator contains type of time to which employee is not entitled." 19 .Q 20 Q 21 VAL ; Validate Tour 22 S (ZENT,STR)="" K PRSAERR D OT^PRSATP 23 S (HRS,TRS)=0 F DAY=1:1:14 S TD=$$GET^DDSVAL(DIE,.DA,DAY+200) S Z=$P($G(^PRST(457.1,+TD,0)),"^",6) S:Z HRS=HRS+Z S Y=$G(^(1)) D VS S:TRG TRS=TRS+1 I STR'="" G V1 24 I FLX="C",TRS>9 S STR="Warning: Compressed Schedule has more than 9 Tours!" D HLP^DDSUTL(.STR) 25 I NH'=HRS,NH'=112 S STR="Warning: Normal Hours are "_NH_"; Tour Hours are "_HRS D HLP^DDSUTL(.STR) 26 Q 27 V1 S (DDSERROR,PRSAERR)=1 D HLP^DDSUTL(.STR) Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRSATP.m
r613 r623 1 PRSATP ;HISC/REL,WIRMFO/MGD/PLT - Timekeeper Post Time ;11/21/06 2 ;;4.0;PAID;**22,57,69,92,102,93,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; input (from calling option) 5 ; PTPF - (optional) part-time physician flag, true (=1) when called 6 ; by the posting option for part-time physicians with a memo. 7 ; 8 N GLOB ; global reference for employee's time & attendance record. 9 N PRSDT 10 S PRSTLV=2 D ^PRSAUTL G:TLI<1 EX S %DT="X",X="T+3" D ^%DT 11 S %DT="AEPX",%DT("A")="Posting Date: ",%DT("B")="T-1",%DT(0)=-Y W ! D ^%DT 12 G:Y<1 EX S (PRSDT,D1)=Y S Y=$G(^PRST(458,"AD",D1)),PPI=$P(Y,"^",1),DAY=$P(Y,"^",2) 13 I PPI="" W !!,$C(7),"Pay Period is Not Open Yet!" G EX 14 S PPE=$P($G(^PRST(458,PPI,0)),"^",1),DTE=$P($G(^PRST(458,PPI,2)),"^",DAY),DTI=$P($G(^(1)),"^",DAY) 15 D2 W !!,"Would you like to edit the T & A RECORDs in alphabetical order" S %=1 D YN^DICN I % S LP=% G EX:%=-1,LOOP:%=1,NME 16 W !!,"Answer YES if you want all RECORDs brought up for which no data" 17 W !,"has been entered." G D2 18 ; 19 ; 20 LOOP ; 21 S LP=1,NN="" 22 F S NN=$O(^PRSPC("ATL"_TLE,NN)) Q:NN="" F DFN=0:0 S DFN=$O(^PRSPC("ATL"_TLE,NN,DFN)) Q:DFN<1 I $$PTPSCR(DFN,PRSDT,$G(PTPF)) S GLOB="" D POST D:GLOB]"" UNLOCK^PRSLIB00(GLOB) I 'LP G EX 23 G EX 24 NME K DIC S DIC("A")="Select EMPLOYEE: ",DIC("S")="I $P(^(0),""^"",8)=TLE,$D(^PRST(458,PPI,""E"",+Y)),$$PTPSCR^PRSATP(+Y,PRSDT,$G(PTPF))",DIC(0)="AEQM",DIC="^PRSPC(",D="ATL"_TLE W ! D IX^DIC S DFN=+Y K DIC 25 G:DFN<1 EX S GLOB="" D POST D:GLOB]"" UNLOCK^PRSLIB00(GLOB) G NME 26 POST S TC=$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",2),TC2=$P($G(^(0)),"^",13) 27 I 'TC Q:LP'=2 W !!?5,"This Employee has no tour entered for this date." Q 28 I "T"'[$P($G(^PRST(458,PPI,"E",DFN,0)),"^",2) W:LP=2 $C(7),!!,"This Employee has already been sent to Payroll." Q 29 S STAT=$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,10)),"^",1) 30 I LP=1,"1 3 4"[TC!(STAT'="") Q 31 ; 32 ; check if ESR is approved when posting PT Phy with memo 33 I $G(PTPF),$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,7)),U)=5 D Q:'Y!$D(DIRUT) 34 . W $C(7),! 35 . W !,"This day was auto-posted from an approved Electronic Subsidiary Record (ESR)." 36 . W !,"Normally, changes should be accomplished by having the T & L supervisor return" 37 . W !,"the ESR day to the part-time physician for correction." 38 . W !,"An exception to the above is when AWOL, On Suspension, or Non-Pay must be" 39 . W !,"posted, since those can not be entered via the ESR.",! 40 . S DIR(0)="Y" 41 . S DIR("A")="Do you want to manually post this day on the timecard" 42 . S DIR("B")="NO" 43 . D ^DIR K DIR 44 ; 45 ; lock employee record for editing by timekeeper 46 I '$$AVAILREC^PRSLIB00("TK",.GLOB,.STOP) S:LP=1&$G(STOP) LP=0 Q 47 D ^PRSADP1,LP,^PRSATP2,^PRSAENT 48 G P0:TC>4,P0:TC=2,P0:TC=3,P3:TC=4,P1 49 P0 R !!,"Did Employee Only Work Scheduled Tour? ",X:DTIME S:'$T X="^^" S:X["^^" LP=0 Q:X["^" S X=$TR(X,"yesnor","YESNOR") 50 S:X="" X="*" I $P("YES",X,1)'="",$P("NO",X,1)'="",X'="R" W $C(7),!?5," Answer YES or NO or R for Normal Posting with Remarks" G P0 51 S X=$E(X,1) I "YR"'[X G P1 52 S PTY=1 I STAT'="" K ^PRST(458,PPI,"E",DFN,"D",DAY,2),^(3) 53 I TC=3 S $P(^PRST(458,PPI,"E",DFN,"D",DAY,2),"^",3)="RG",STAT="T" 54 I STAT'="",$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",12) D NOW^%DTC S NOW=%,TT="HW" D S0^PRSAPPH 55 S LV="" D A2^PRSATP0:X="R" G UPD 56 P1 R !!,"Was Employee Absent the Entire Tour? ",X:DTIME S:'$T X="^" Q:X["^" S X=$TR(X,"yesno","YESNO") 57 S:X="" X="*" I $P("YES",X,1)'="",$P("NO",X,1)'="" W $C(7)," Answer YES or NO" G P1 58 I X?1"Y".E D ^PRSATP0 Q:X["^" G UPD 59 I $E(ENT,1,2)["D" K ^PRST(458,PPI,"E",DFN,"D",DAY,2),^(3),^(10) Q 60 P3 S ZENT=$S($E(ENT,2)="H"&('$G(PTPF)):"RG ",$E(ENT,1,2)="00":"RG ",1:"") 61 I TC=1 D OT S:$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",12)&(AC="M2E") ZENT=ZENT_"HW " S ZENT=ZENT_"NP CP " G P31 62 I TC=3!(TC=4) D LV S:$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",12)&($E(ENT,22)) ZENT=ZENT_"HW " G P31 63 D LV,OT S ZENT=ZENT_"TV TR " S:$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",12) ZENT=ZENT_"HX HW " 64 P31 S DDSFILE=458,DDSFILE(1)=458.02,DA(2)=PPI,DA(1)=DFN,DA=DAY 65 S Z=$G(^PRST(458,PPI,"E",DFN,"D",DAY,2)) K ZS 66 S DR="[PRSA TP POST1]" D ^DDS K DS Q:'$D(ZS) 67 I ZS'="" S ^PRST(458,PPI,"E",DFN,"D",DAY,2)=ZS,PTY=3 G UPD 68 I $D(^PRST(458,PPI,"E",DFN,"D",DAY,2)) K ^(2),^(3),^(10) 69 Q 70 UPD ; Update status 71 D NOW^%DTC 72 S $P(^PRST(458,PPI,"E",DFN,"D",DAY,10),"^",1,4)="T^"_DUZ_"^"_%_"^"_PTY 73 N DAH,DBH,HOL,QUIT 74 S (DAH,DBH,HOL,QUIT)="" 75 ; 76 ; Check to holiday encapsulated by a form a non-pay 77 D HENCAP^PRSATP3(PPI,DFN,DAY,.DBH,.HOL,.DAH,.QUIT) 78 Q:QUIT 79 D UPDT^PRSATP3(DFN,DBH,HOL,DAH) 80 K DAH,DBH,HOL,QUIT 81 Q 82 LP W !!,"Enter '^' to bypass this employee." W:LP=1 " Enter '^^' to stop T&L editing." W ! Q 83 LV S Z1="30 31 31 31 32 33 28 35 35 30 36 37 38",Z2="AL SL CB AD NL WP CU AA DL RL NP CP HX" 84 ; 85 ; Check to see if the employee is entitled to Military Leave and add 86 ; ML to list if they are. Added to be compliant with Public Law 87 ; 106-554. 88 S:$E(ENT,34) Z1=Z1_" 34",Z2=Z2_" ML" 89 ;9/3 month employee entitled RS with recess hours in file# 458.8 90 S:$E(ENT,5)&$P($$RSHR^PRSU1B2(DFN,PPE),U,DAY>7+1) Z1=Z1_" 5",Z2=Z2_" RS" 91 F K=1:1:$L(Z1," ") I $E(ENT,$P(Z1," ",K)) S ZENT=ZENT_$P(Z2," ",K)_" " 92 QUIT 93 ; 94 OT ; Get entitled out-of-tour types of time 95 S Z1="12 28 26",Z2="OT CT ON" F K=1:1:3 I $E(ENT,$P(Z1," ",K)) S ZENT=ZENT_$P(Z2," ",K)_" " I ZENT'["UN" S ZENT=ZENT_"UN " 96 I $E(ENT,29),'$E(ENT,26) S ZENT=ZENT_"SB " S:ZENT'["UN" ZENT=ZENT_"UN " 97 ; Allow Stand By for employees w/ Prem Pay Ind = W or V 98 I $E(ENT,29),$E(ENT,26),"^W^V^"[(U_PMP_U) S ZENT=ZENT_"SB " S:ZENT'["UN" ZENT=ZENT_"UN " 99 Q 100 EX ;clean up lock global which is set in $$AVAILREC^PRSLIB00 101 K ^TMP($J,"LOCK") 102 ;generic cleanup 103 G KILL^XUSCLEAN 104 ; 105 PTPSCR(PRSIEN,PSTDT,PTPF) ; part-time physician screen extrinsic function 106 ; input 107 ; PRSIEN - Employee IEN (file 450) 108 ; PSTDT - Date being posted (FileMan internal) 109 ; PTPF - (opt) Part-time physician flag, equals true (1) when screen 110 ; should only allow selection of part-time physician with 111 ; memo and false (null or 0) when screen should only 112 ; allow selection of employees that are not part-time 113 ; physicians with memo. 114 ; result 115 ; returns a boolean value (1 or 0) or null 116 ; =1 if employee passed screen 117 ; (PTPF true and employee is PTP with memo) OR 118 ; (PTPF false and employee is not PTP with memo) 119 ; =0 if employee did not pass screen 120 ; =null value if required inputs were not provided 121 ; 122 N PRSRET,PTPM 123 S PTPF=$G(PTPF) 124 S PRSRET="" ; init return 125 I PRSIEN,PSTDT D 126 . ; determine if employee is PT physician with memo on the posting date 127 . S PTPM=$S($$MIEN^PRSPUT1(PRSIEN,PSTDT)>0:1,1:0) 128 . ; apply screen 129 . S PRSRET=$S(PTPF&PTPM:1,'PTPF&'PTPM:1,1:0) 130 ; 131 Q PRSRET 132 ; 133 ;PRSATP 1 PRSATP ;HISC/REL,WIRMFO/MGD - Timekeeper Post Time ;3/21/06 2 ;;4.0;PAID;**22,57,69,92,102,93**;Sep 21, 1995;Build 7 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; input (from calling option) 5 ; PTPF - (optional) part-time physician flag, true (=1) when called 6 ; by the posting option for part-time physicians with a memo. 7 ; 8 N GLOB ; global reference for employee's time & attendance record. 9 N PRSDT 10 S PRSTLV=2 D ^PRSAUTL G:TLI<1 EX S %DT="X",X="T+3" D ^%DT 11 S %DT="AEPX",%DT("A")="Posting Date: ",%DT("B")="T-1",%DT(0)=-Y W ! D ^%DT 12 G:Y<1 EX S (PRSDT,D1)=Y S Y=$G(^PRST(458,"AD",D1)),PPI=$P(Y,"^",1),DAY=$P(Y,"^",2) 13 I PPI="" W !!,$C(7),"Pay Period is Not Open Yet!" G EX 14 S PPE=$P($G(^PRST(458,PPI,0)),"^",1),DTE=$P($G(^PRST(458,PPI,2)),"^",DAY),DTI=$P($G(^(1)),"^",DAY) 15 D2 W !!,"Would you like to edit the T & A RECORDs in alphabetical order" S %=1 D YN^DICN I % S LP=% G EX:%=-1,LOOP:%=1,NME 16 W !!,"Answer YES if you want all RECORDs brought up for which no data" 17 W !,"has been entered." G D2 18 ; 19 ; 20 LOOP ; 21 S LP=1,NN="" 22 F S NN=$O(^PRSPC("ATL"_TLE,NN)) Q:NN="" F DFN=0:0 S DFN=$O(^PRSPC("ATL"_TLE,NN,DFN)) Q:DFN<1 I $$PTPSCR(DFN,PRSDT,$G(PTPF)) S GLOB="" D POST D:GLOB]"" UNLOCK^PRSLIB00(GLOB) I 'LP G EX 23 G EX 24 NME K DIC S DIC("A")="Select EMPLOYEE: ",DIC("S")="I $P(^(0),""^"",8)=TLE,$D(^PRST(458,PPI,""E"",+Y)),$$PTPSCR^PRSATP(+Y,PRSDT,$G(PTPF))",DIC(0)="AEQM",DIC="^PRSPC(",D="ATL"_TLE W ! D IX^DIC S DFN=+Y K DIC 25 G:DFN<1 EX S GLOB="" D POST D:GLOB]"" UNLOCK^PRSLIB00(GLOB) G NME 26 POST S TC=$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",2),TC2=$P($G(^(0)),"^",13) 27 I 'TC Q:LP'=2 W !!?5,"This Employee has no tour entered for this date." Q 28 I "T"'[$P($G(^PRST(458,PPI,"E",DFN,0)),"^",2) W:LP=2 $C(7),!!,"This Employee has already been sent to Payroll." Q 29 S STAT=$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,10)),"^",1) 30 I LP=1,"1 3 4"[TC!(STAT'="") Q 31 ; 32 ; check if ESR is approved when posting PT Phy with memo 33 I $G(PTPF),$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,7)),U)=5 D Q:'Y!$D(DIRUT) 34 . W $C(7),! 35 . W !,"This day was auto-posted from an approved Electronic Subsidiary Record (ESR)." 36 . W !,"Normally, changes should be accomplished by having the T & L supervisor return" 37 . W !,"the ESR day to the part-time physician for correction." 38 . W !,"An exception to the above is when AWOL, On Suspension, or Non-Pay must be" 39 . W !,"posted, since those can not be entered via the ESR.",! 40 . S DIR(0)="Y" 41 . S DIR("A")="Do you want to manually post this day on the timecard" 42 . S DIR("B")="NO" 43 . D ^DIR K DIR 44 ; 45 ; lock employee record for editing by timekeeper 46 I '$$AVAILREC^PRSLIB00("TK",.GLOB,.STOP) S:LP=1&$G(STOP) LP=0 Q 47 D ^PRSADP1,LP,^PRSATP2,^PRSAENT 48 G P0:TC>4,P0:TC=2,P0:TC=3,P3:TC=4,P1 49 P0 R !!,"Did Employee Only Work Scheduled Tour? ",X:DTIME S:'$T X="^^" S:X["^^" LP=0 Q:X["^" S X=$TR(X,"yesnor","YESNOR") 50 S:X="" X="*" I $P("YES",X,1)'="",$P("NO",X,1)'="",X'="R" W $C(7),!?5," Answer YES or NO or R for Normal Posting with Remarks" G P0 51 S X=$E(X,1) I "YR"'[X G P1 52 S PTY=1 I STAT'="" K ^PRST(458,PPI,"E",DFN,"D",DAY,2),^(3) 53 I TC=3 S $P(^PRST(458,PPI,"E",DFN,"D",DAY,2),"^",3)="RG",STAT="T" 54 I STAT'="",$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",12) D NOW^%DTC S NOW=%,TT="HW" D S0^PRSAPPH 55 S LV="" D A2^PRSATP0:X="R" G UPD 56 P1 R !!,"Was Employee Absent the Entire Tour? ",X:DTIME S:'$T X="^" Q:X["^" S X=$TR(X,"yesno","YESNO") 57 S:X="" X="*" I $P("YES",X,1)'="",$P("NO",X,1)'="" W $C(7)," Answer YES or NO" G P1 58 I X?1"Y".E D ^PRSATP0 Q:X["^" G UPD 59 I $E(ENT,1,2)["D" K ^PRST(458,PPI,"E",DFN,"D",DAY,2),^(3),^(10) Q 60 P3 S ZENT=$S($E(ENT,2)="H"&('$G(PTPF)):"RG ",$E(ENT,1,2)="00":"RG ",1:"") 61 I TC=1 D OT S:$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",12)&(AC="M2E") ZENT=ZENT_"HW " S ZENT=ZENT_"NP CP " G P31 62 I TC=3!(TC=4) D LV S:$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",12)&($E(ENT,22)) ZENT=ZENT_"HW " G P31 63 D LV,OT S ZENT=ZENT_"TV TR " S:$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",12) ZENT=ZENT_"HX HW " 64 P31 S DDSFILE=458,DDSFILE(1)=458.02,DA(2)=PPI,DA(1)=DFN,DA=DAY 65 S Z=$G(^PRST(458,PPI,"E",DFN,"D",DAY,2)) K ZS 66 S DR="[PRSA TP POST1]" D ^DDS K DS Q:'$D(ZS) 67 I ZS'="" S ^PRST(458,PPI,"E",DFN,"D",DAY,2)=ZS,PTY=3 G UPD 68 I $D(^PRST(458,PPI,"E",DFN,"D",DAY,2)) K ^(2),^(3),^(10) 69 Q 70 UPD ; Update status 71 D NOW^%DTC 72 S $P(^PRST(458,PPI,"E",DFN,"D",DAY,10),"^",1,4)="T^"_DUZ_"^"_%_"^"_PTY 73 N DAH,DBH,HOL,QUIT 74 S (DAH,DBH,HOL,QUIT)="" 75 ; 76 ; Check to holiday encapsulated by a form a non-pay 77 D HENCAP^PRSATP3(PPI,DFN,DAY,.DBH,.HOL,.DAH,.QUIT) 78 Q:QUIT 79 D UPDT^PRSATP3(DFN,DBH,HOL,DAH) 80 K DAH,DBH,HOL,QUIT 81 Q 82 LP W !!,"Enter '^' to bypass this employee." W:LP=1 " Enter '^^' to stop T&L editing." W ! Q 83 LV S Z1="30 31 31 31 32 33 28 35 35 30 36 37 38",Z2="AL SL CB AD NL WP CU AA DL RL NP CP HX" 84 ; 85 ; Check to see if the employee is entitled to Military Leave and add 86 ; ML to list if they are. Added to be compliant with Public Law 87 ; 106-554. 88 ; 89 I $E(ENT,34) D 90 . S Z1=Z1_" 34",Z2=Z2_" ML" 91 . F K=1:1:14 I $E(ENT,$P(Z1," ",K)) S ZENT=ZENT_$P(Z2," ",K)_" " 92 ; 93 I '$E(ENT,34) D 94 . F K=1:1:13 I $E(ENT,$P(Z1," ",K)) S ZENT=ZENT_$P(Z2," ",K)_" " 95 Q 96 OT ; Get entitled out-of-tour types of time 97 S Z1="12 28 26",Z2="OT CT ON" F K=1:1:3 I $E(ENT,$P(Z1," ",K)) S ZENT=ZENT_$P(Z2," ",K)_" " I ZENT'["UN" S ZENT=ZENT_"UN " 98 I $E(ENT,29),'$E(ENT,26) S ZENT=ZENT_"SB " S:ZENT'["UN" ZENT=ZENT_"UN " 99 ; Allow Stand By for employees w/ Prem Pay Ind = W or V 100 I $E(ENT,29),$E(ENT,26),"^W^V^"[(U_PMP_U) S ZENT=ZENT_"SB " S:ZENT'["UN" ZENT=ZENT_"UN " 101 Q 102 EX ;clean up lock global which is set in $$AVAILREC^PRSLIB00 103 K ^TMP($J,"LOCK") 104 ;generic cleanup 105 G KILL^XUSCLEAN 106 ; 107 PTPSCR(PRSIEN,PSTDT,PTPF) ; part-time physician screen extrinsic function 108 ; input 109 ; PRSIEN - Employee IEN (file 450) 110 ; PSTDT - Date being posted (FileMan internal) 111 ; PTPF - (opt) Part-time physician flag, equals true (1) when screen 112 ; should only allow selection of part-time physician with 113 ; memo and false (null or 0) when screen should only 114 ; allow selection of employees that are not part-time 115 ; physicians with memo. 116 ; result 117 ; returns a boolean value (1 or 0) or null 118 ; =1 if employee passed screen 119 ; (PTPF true and employee is PTP with memo) OR 120 ; (PTPF false and employee is not PTP with memo) 121 ; =0 if employee did not pass screen 122 ; =null value if required inputs were not provided 123 ; 124 N PRSRET,PTPM 125 S PTPF=$G(PTPF) 126 S PRSRET="" ; init return 127 I PRSIEN,PSTDT D 128 . ; determine if employee is PT physician with memo on the posting date 129 . S PTPM=$S($$MIEN^PRSPUT1(PRSIEN,PSTDT)>0:1,1:0) 130 . ; apply screen 131 . S PRSRET=$S(PTPF&PTPM:1,'PTPF&'PTPM:1,1:0) 132 ; 133 Q PRSRET 134 ; 135 ;PRSATP -
WorldVistAEHR/trunk/r/PAID-PRS/PRSATP1.m
r613 r623 1 PRSATP1 ; HISC/REL,WOIFO/PLT - Daily Post verification ;11/28/2006 2 ;;4.0;PAID;**34,57,112**;Sep 21, 1995;Build 54 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ;routine is called to validate data entered during the 5 ;screenman posting of an employees pay period 6 ; 7 K T S ZS="",TWO=$P($G(^PRST(457.1,+TC,0)),"^",5),DY2=TWO="Y" I TC2,'DY2 S TWO=$P($G(^PRST(457.1,+TC2,0)),"^",5),DY2=TWO="Y" 8 F K=1:4:25 I $P(Z,"^",K)'="" D 9 .S X=$P(Z,"^",K)_"^"_$P(Z,"^",K+1) I $P(Z,"^",K+1)="" D E8 Q 10 .D CNV^PRSATIM S Z1=$P(Y,"^",1),Z2=$P(Y,"^",2) D V0 11 .I Z2>1440,TWO'="Y","OT CT SB ON UA"'[$P(Z,"^",K+2) D E4 Q 12 .I Z2>2880 D E5 Q 13 .I $P(Z,"^",K+2)="" D E9 Q 14 .;check duplicate start time if no rs-type of time in exception string z for node 2 15 .I Z'["^RS",'(Z["HX"&("ON HW"[$P(Z,"^",K+2))),'(Z["^ON"&(Z["OT")),'(Z["^ON"&(Z["CT")),$D(T(Z1)) D E3 Q 16 .I $P(Z,"^",K+2)="HW",Z'["HX",'$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",12) D E7 Q 17 .I $P(Z,"^",K+2)'="" S T(Z1)=$G(T(Z1))_$P(Z,U,K+2)_U,T(Z1,K)=Z2_"^"_$P(Z,"^",K,K+3) 18 .Q 19 I '$D(T) Q 20 ;check duplicate start time if rs in exception string z for node 2. 21 S Z1="" I Z["^RS",'(Z["^ON"&(Z["OT")),'(Z["^ON"&(Z["CT")) F S Z1=$O(T(Z1)) QUIT:Z1="" QUIT:Z["HX"&("^ON^HW^"[T(Z1)) I $L(T(Z1),U)>2 D QUIT:Z1="*" 22 . N A 23 . S A=T(Z1),A=U_A 24 . I $L(A,U)>4 S Z1="*" QUIT 25 . I A'["^RS^" S A=$P(A,"^ON")_$P(A,"^ON",2) S:A="" A="^ON" I "^CT^"'[A,"^OT^"'[A,Z'["^HX"!("^HW^"'[A) S Z1="*" QUIT 26 . I A["^RS^" S A=$P(A,"^RS")_$P(A,"^RS",2) S:A="" A="^RS" I "^CT^OT^RG^ON^HW^"'[A S Z1="*" QUIT 27 . QUIT 28 G:Z1="*" E3 29 ;exclude rs with ct, ot, rg, on, hw for error e2 check 30 I Z'["HX",'(Z["^ON"&(Z["OT")),'(Z["^ON"&(Z["CT")) S Z1="" F S Z1=$O(T(Z1)) Q:Z1="" G:Z1'<T(Z1,$O(T(Z1,0))) E1 S Y=$O(T(Z1)) I Y,T(Z1,$O(T(Z1,0)))>Y G E2:'(T(Z1)["RS^"&("^CT^OT^RG^ON^HW^"[T(Y)))&'("^CT^OT^RG^ON^HW^"[T(Z1)&(T(Y)["RS^")) 31 S Z1="",LL=1 F S Z1=$O(T(Z1)) Q:Z1="" F K=0:0 S K=$O(T(Z1,K)) Q:K<1 D 32 .S $P(ZS,"^",LL)=$P(T(Z1,K),"^",2),$P(ZS,"^",LL+1)=$P(T(Z1,K),"^",3),$P(ZS,"^",LL+2)=$P(T(Z1,K),"^",4) S:$P(T(Z1,K),"^",5)'="" $P(ZS,"^",LL+3)=$P(T(Z1,K),"^",5) 33 .S LL=LL+4 Q 34 S Z1=$$GET^DDSVAL(DIE,.DA,70) 35 I Z1="" F K=1:4:25 G:$P(Z,"^",K+2)="AA" E6 I $P(Z,"^",K+2)="WP",$P(Z,"^",K+3)=3 G E10 36 ;loop thru posting checking for comptime w/out remarks code. 37 F K=1:4:25 G:($P(Z,"^",K+2)="CT")&($P(Z,"^",K+3)="") E11 38 F K=1:4:25 G:($P(Z,"^",K+2)="CU")&($P(Z,"^",K+3)="") E12 39 ;Now loop again checking to make sure compressed tours aren't 40 ;trying to post credit hours remarks. 41 I $$COMPR(PPI,DFN) F K=1:4:25 G:$$CTCH(Z,K) E13 42 Q 43 ;------------------------------------------------- 44 COMPR(P,D) ;return true if employee has a compressed tour indicator 45 ; this pay period 46 ; INPUT: P--pay period ien; D--Day number 47 ; 48 Q $P($G(^PRST(458,+P,"E",D,0)),"^",6)="C" 49 ;------------------------------------------------- 50 CTCH(Z,K) ;return true if comp/credit earned (CT) posted and 51 ; the remarks code is credit hours. 52 ; INPUT: Z--Posting node from file 458 53 ; K--segment of posting node 54 Q $P(Z,"^",K+2)="CT"&($P(Z,"^",K+3)="16") 55 ;------------------------------------------------- 56 ; 57 V0 I Z2>Z1 S:DY2=1&($O(T(0))>Z1) DY2=2 I DY2=2 S Z1=Z1+1440,Z2=Z2+1440 58 S:Z2'>Z1 Z2=Z2+1440,DY2=2 Q 59 E1 S STR="A start time is not less than a stop time." G E20 60 E2 S STR="End of one segment must not be greater than start of next." G E20 61 E3 S STR="Duplicate start times encountered." G E20 62 E4 S STR="Segment of second day encountered; no two-day tour specified." G E20 63 E5 S STR="Segment of third day encountered." G E20 64 E6 S STR="Remarks must be entered when AA is posted." G E20 65 E7 S STR="HW can only be posted with HX or on a Holiday." G E20 66 E8 S STR="Stop Time not entered for a segment." G E20 67 E9 S STR="Type of Time not entered for a segment." G E20 68 E10 S STR="Remarks must be entered for WP due to AWOL." G E20 69 E11 S STR="REMARKS CODE must be entered when CT is posted." G E20 70 E12 S STR="REMARKS CODE must be entered when CU is posted." G E20 71 E13 S STR="REMARKS CODE: Compressed tours can't earn credit hours." G E20 72 E20 K ZS,T S DDSERROR=1,TIM=0 D HLP^DDSUTL(.STR) Q 1 PRSATP1 ; HISC/REL-Daily Post verification ;2/28/2000 2 ;;4.0;PAID;**34,57**;Sep 21, 1995 3 ;routine is called to validate data entered during the 4 ;screenman posting of an employees pay period 5 ; 6 K T S ZS="",TWO=$P($G(^PRST(457.1,+TC,0)),"^",5),DY2=TWO="Y" I TC2,'DY2 S TWO=$P($G(^PRST(457.1,+TC2,0)),"^",5),DY2=TWO="Y" 7 F K=1:4:25 I $P(Z,"^",K)'="" D 8 .S X=$P(Z,"^",K)_"^"_$P(Z,"^",K+1) I $P(Z,"^",K+1)="" D E8 Q 9 .D CNV^PRSATIM S Z1=$P(Y,"^",1),Z2=$P(Y,"^",2) D V0 10 .I Z2>1440,TWO'="Y","OT CT SB ON UA"'[$P(Z,"^",K+2) D E4 Q 11 .I Z2>2880 D E5 Q 12 .I $P(Z,"^",K+2)="" D E9 Q 13 .I '(Z["HX"&("ON HW"[$P(Z,"^",K+2))),'(Z["^ON"&(Z["OT")),'(Z["^ON"&(Z["CT")),$D(T(Z1)) D E3 Q 14 .I $P(Z,"^",K+2)="HW",Z'["HX",'$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",12) D E7 Q 15 .I $P(Z,"^",K+2)'="" S T(Z1,K)=Z2_"^"_$P(Z,"^",K,K+3) 16 .Q 17 I '$D(T) Q 18 I Z'["HX",'(Z["^ON"&(Z["OT")),'(Z["^ON"&(Z["CT")) S Z1="" F S Z1=$O(T(Z1)) Q:Z1="" G:Z1'<T(Z1,$O(T(Z1,0))) E1 S Y=$O(T(Z1)) I Y,T(Z1,$O(T(Z1,0)))>Y G E2 19 S Z1="",LL=1 F S Z1=$O(T(Z1)) Q:Z1="" F K=0:0 S K=$O(T(Z1,K)) Q:K<1 D 20 .S $P(ZS,"^",LL)=$P(T(Z1,K),"^",2),$P(ZS,"^",LL+1)=$P(T(Z1,K),"^",3),$P(ZS,"^",LL+2)=$P(T(Z1,K),"^",4) S:$P(T(Z1,K),"^",5)'="" $P(ZS,"^",LL+3)=$P(T(Z1,K),"^",5) 21 .S LL=LL+4 Q 22 S Z1=$$GET^DDSVAL(DIE,.DA,70) 23 I Z1="" F K=1:4:25 G:$P(Z,"^",K+2)="AA" E6 I $P(Z,"^",K+2)="WP",$P(Z,"^",K+3)=3 G E10 24 ;loop thru posting checking for comptime w/out remarks code. 25 F K=1:4:25 G:($P(Z,"^",K+2)="CT")&($P(Z,"^",K+3)="") E11 26 F K=1:4:25 G:($P(Z,"^",K+2)="CU")&($P(Z,"^",K+3)="") E12 27 ;Now loop again checking to make sure compressed tours aren't 28 ;trying to post credit hours remarks. 29 I $$COMPR(PPI,DFN) F K=1:4:25 G:$$CTCH(Z,K) E13 30 Q 31 ;------------------------------------------------- 32 COMPR(P,D) ;return true if employee has a compressed tour indicator 33 ; this pay period 34 ; INPUT: P--pay period ien; D--Day number 35 ; 36 Q $P($G(^PRST(458,+P,"E",D,0)),"^",6)="C" 37 ;------------------------------------------------- 38 CTCH(Z,K) ;return true if comp/credit earned (CT) posted and 39 ; the remarks code is credit hours. 40 ; INPUT: Z--Posting node from file 458 41 ; K--segment of posting node 42 Q $P(Z,"^",K+2)="CT"&($P(Z,"^",K+3)="16") 43 ;------------------------------------------------- 44 ; 45 V0 I Z2>Z1 S:DY2=1&($O(T(0))>Z1) DY2=2 I DY2=2 S Z1=Z1+1440,Z2=Z2+1440 46 S:Z2'>Z1 Z2=Z2+1440,DY2=2 Q 47 E1 S STR="A start time is not less than a stop time." G E20 48 E2 S STR="End of one segment must not be greater than start of next." G E20 49 E3 S STR="Duplicate start times encountered." G E20 50 E4 S STR="Segment of second day encountered; no two-day tour specified." G E20 51 E5 S STR="Segment of third day encountered." G E20 52 E6 S STR="Remarks must be entered when AA is posted." G E20 53 E7 S STR="HW can only be posted with HX or on a Holiday." G E20 54 E8 S STR="Stop Time not entered for a segment." G E20 55 E9 S STR="Type of Time not entered for a segment." G E20 56 E10 S STR="Remarks must be entered for WP due to AWOL." G E20 57 E11 S STR="REMARKS CODE must be entered when CT is posted." G E20 58 E12 S STR="REMARKS CODE must be entered when CU is posted." G E20 59 E13 S STR="REMARKS CODE: Compressed tours can't earn credit hours." G E20 60 E20 K ZS,T S DDSERROR=1,TIM=0 D HLP^DDSUTL(.STR) Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRSATPE.m
r613 r623 1 PRSATPE ;WOIFO/PLT - Find Exceptions ;12/3/07 2 ;;4.0;PAID;**26,34,69,102,112,116**;Sep 21, 1995;Build 23 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 K ER S (ECNT,FATAL)=0,X0=$G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),STAT=$P($G(^(10)),"^",1) 5 N MLTIME S MLTIME=0 6 S TC=$P(X0,"^",2) I 'TC S ER(1)=$P($T(ERTX+1),";;",2),FATAL=1 G EX 7 ; 8 ;ensure Normal Hrs = tour hrs for hourly employees 9 I DAY=14 I '$$HRSMATCH(PPI,DFN) S FATAL=1,ERR=21 D ERR3640 G EX 10 ; 11 I "1 3 4"'[TC,STAT="" S ER(1)=$P($T(ERTX+2),";;",2),FATAL=1 G EX 12 ; 13 ; Validate NAWS 36/40 nurse tours--can't certify if errors 14 N NAWSERR S NAWSERR=0 15 I DAY=7!(DAY=14),$$NAWS3640(DFN,PPI) D 16 . I $$SAT2DAY(DAY/7,DFN,PPI) D 17 .. S FATAL=1 S ERR=16 D ERR3640 S ERR=17 D ERR3640 18 .. S NAWSERR=1 19 . I $$THREE12(DAY/7,DFN,PPI) D 20 .. S FATAL=1 I 'NAWSERR S ERR=16 D ERR3640 21 .. S ERR=$S(DAY=7:19,1:20) D ERR3640 22 I DAY=1,$$NAWS3640(DFN,PPI),$$CARRYOVR(DFN,PPI) D 23 . S FATAL=1 S ERR=16 D ERR3640 S ERR=18 D ERR3640 24 ; 25 S X2=$G(^PRST(458,PPI,"E",DFN,"D",DAY,2)) G:X2="" EX S X1=$G(^(1)),X4=$G(^(4)),K=$P($G(^(10)),U,4) 26 ;check recess entire day having un-unavailable posted for all scheduled on-on call 27 I $E($G(PRSENT),5),K=2,X2["^RS" D 28 . F K=1:3 QUIT:$P(X1,U,K,999)="" S Z=$P(X1,U,K+2) I Z,$P($G(^PRST(457.2,Z,0)),"^",2)="ON",X2'[($P(X1,U,K,K+1)_"^UN") S PRSWOC=$G(PRSWOC)_DAY_"," QUIT 29 . I $G(PRSWOC)'[(DAY_",") F K=1:3 QUIT:$P(X4,U,K,999)="" S Z=$P(X4,U,K+2) I Z,$P($G(^PRST(457.2,Z,0)),"^",2)="ON",X2'[($P(X4,U,K,K+1)_"^UN") S PRSWOC=$G(PRSWOC)_DAY_"," QUIT 30 . QUIT 31 ; 32 K TM I X2["OT"!(X2["CT") D TM 33 K T,TRS F K=1:3 Q:$P(X1,"^",K)="" S Z=$P(X1,"^",K+2) I $S('Z:1,1:$P($G(^PRST(457.2,Z,0)),"^",2)="RG") D 34 .S X=$P(X1,"^",K,K+1) D CNV^PRSATIM S Z1=$P(Y,"^",1),Z2=$P(Y,"^",2) D V0 35 .I Z1'="",$G(T(Z1))="*" K T(Z1) S T(Z2)="*" Q 36 .S T(Z1)="",T(Z2)="*" Q 37 I X4'="" F K=1:3 Q:$P(X4,"^",K)="" S Z=$P(X4,"^",K+2) I $S('Z:1,1:$P($G(^PRST(457.2,Z,0)),"^",2)="RG") D 38 .S X=$P(X4,"^",K,K+1) D CNV^PRSATIM S Z1=$P(Y,"^",1),Z2=$P(Y,"^",2) D V0 39 .I Z1'="",$G(T(Z1))="*" K T(Z1) S T(Z2)="*" Q 40 .S T(Z1)="",T(Z2)="*" Q 41 ; 42 ;find rs-type of time segments of trs array in x2 posted string 43 I X2["^RS" F K=1:4:25 QUIT:$P(X2,U,K,999)="" S X=$P(X2,"^",K,K+1) I "^"'[X,$P(X2,"^",K+2)="RS" D 44 . S TT=$P(X2,"^",K+2) D CNV^PRSATIM S Z1=$P(Y,"^",1),Z2=$P(Y,"^",2) D V1 45 . I Z1'="",$G(TRS(Z1))="*" K TRS(Z1) S TRS(Z2)="*" QUIT 46 . S TRS(Z1)="",TRS(Z2)="*" 47 . QUIT 48 ; Checks for Daily employees 49 I "^"[$P(X2,"^",1,2) S TT=$P(X2,"^",3),K=1,DN=0,Y0="" G L0 50 F K=1:4:25 S X=$P(X2,"^",K,K+1) I "^"'[X D 51 . N Z3,Z4 52 . S TT=$P(X2,"^",K+2) 53 . D CNV^PRSATIM S Y0=Y,Z1=$P(Y,"^",1),Z2=$P(Y,"^",2) D V1 S TIM=Z2-Z1/60 54 . S Z3=Z1,Z4=Z2 55 . I TT="ML" S MLTIME=MLTIME+TIM 56 . S Z1=$O(T(Z1)) S:Z1'="" Z1=T(Z1) 57 . S Z2=$O(T(Z2-1)) S:Z2'="" Z2=T(Z2) 58 . ;trs=1 if absolute outside rs, 2 if absolute inside rs, 3 if overlap (in/outside) rs and inside tour of duty 59 . ;if exception segment start/ending time outside tour of duty, reset z3 and z4 60 . I Z1]""!(Z2]""),X2["^RS" S:Z1=""&(Z2="*") Z3=$O(T(Z3)) S:Z1="*"&(Z2="") Z4=$O(T(Z3)) S Z3=$O(TRS(Z3)) S:Z3]"" Z3=TRS(Z3) S Z4=$O(TRS(Z4-1)) S:Z4]"" Z4=TRS(Z4) S TRS=$S(Z3=""&(Z4=""):1,Z3="*"&(Z4="*"):2,1:3) 61 . I TT="UN" D UN^PRSATPH QUIT 62 . I "CT OT ON SB RG"[TT D OT QUIT 63 . D LV QUIT 64 ; 65 ; Check for a minimum of 1 hour ML 66 ; 67 I TT="ML",MLTIME<1 S ER(1)=$P($T(ERTX+14),";;",2),FATAL=1 G EX 68 ; 69 EX Q 70 V0 I Z2>Z1 S:$O(T(""))'<Z2 Z1=Z1+1440,Z2=Z2+1440 Q 71 S Z2=Z2+1440 Q 72 V1 S DN=0 I Z2>Z1 Q:"CT OT ON SB UN RG"[TT S:$O(T(""))'<Z2 Z1=Z1+1440,Z2=Z2+1440,DN=2 Q 73 S Z2=Z2+1440,DN=1 Q 74 OT ; Check OT/CT Request 75 I Z1'=""!(Z2'="") D O2 I $G(ERR)=6 S FATAL=1 D ERR 76 I DN=1,$O(T(1440))="" D NX^PRSATPH 77 I 'DN,$O(T(""))=""!($P(Y0,"^",1)'>$O(T(""))) D PR^PRSATPH 78 I "ON SB RG"[TT Q 79 ; check status of request(s) 80 S DTI=$P($G(^PRST(458,PPI,1)),U,DAY) Q:'DTI 81 S STAT="" ; init highest status var 82 S DA=0 F S DA=$O(^PRST(458.2,"AD",DFN,DTI,DA)) Q:'DA D Q:STAT="A" 83 . S Z=$G(^PRST(458.2,DA,0)) 84 . Q:$P(Z,"^",5)'=TT ; ignore different type 85 . I $F("RSA",$P(Z,U,8))>$F("RSA",STAT) S STAT=$P(Z,U,8) ; higher status 86 I STAT="" S ERR=3 D ERR Q ; none with requested or higher status 87 I STAT'="A" D Q ; none approved 88 . S ERR=$S(STAT="R":8,1:9) D ERR 89 . ; check posted hours vs requested since no approved request 90 . S TM(TT,"R")=$G(TM(TT,"R"))-TIM I TM(TT,"R")<0 S ERR=7 D ERR 91 ; check posted hours vs approved since we have an approved request 92 S TM(TT,"A")=$G(TM(TT,"A"))-TIM I TM(TT,"A")<0 S ERR=13 D ERR 93 Q 94 O2 ; Check for valid with-in tour or cross-tour situations 95 I TT="ON"&(X2["HX") Q 96 ;I "OT CT"[TT,TIM'>1 Q 97 ;none-leave hours are inside tour hours, but quit if inside rs hours 98 QUIT:$G(TRS)=2!(TT="HW"&(X2["^RS")) S ERR=6 QUIT 99 TM ; Get OT,CT request,approve times 100 S DTI=$P($G(^PRST(458,PPI,1)),"^",DAY),DA=0 Q:'DTI 101 T1 S DA=$O(^PRST(458.2,"AD",DFN,DTI,DA)) I 'DA Q 102 S Z=$G(^PRST(458.2,DA,0)),STAT=$P(Z,"^",8) I STAT'="","XD"[STAT G T1 103 S TT=$P(Z,"^",5) I TT'="OT",TT'="CT" G T1 104 S TM(TT,"R")=$G(TM(TT,"R"))+$P(Z,"^",6) ; requested sum 105 I STAT="A" S TM(TT,"A")=$G(TM(TT,"A"))+$P(Z,"^",6) ; approved sum 106 G T1 107 LV ; Check Leave Request 108 I TC=3!(TC=4) Q 109 I TC=1,TT="HW" Q 110 ;leave hours are (overlap) outside tour hours or (overlap) inside recess hours 111 I ($G(TRS)'=1&(TT="HW")&$G(TRS)) QUIT 112 I Z1'="*"!(Z2'="*")!($G(TRS)'=1&(TT'="RS")&$G(TRS)) S ERR=5,FATAL=1 D ERR 113 ; 114 L0 N REMARK S REMARK=$P(X2,"^",K+3) 115 Q:REMARK&(REMARK'=15&(REMARK'=16)) 116 I "HX"[TT D HENCAP 117 ;no leave request for non-leave hour and rs types 118 QUIT:"RG CP NP HX HW TR TV RS"[TT 119 S DTI=$P($G(^PRST(458,PPI,1)),"^",DAY) Q:'DTI S (DT1,DT2)=DTI 120 I DN D D2 S:DN=2 DT1=DT2 121 S DTIN=9999999-DT2,DA=0 122 F KK=0:0 S KK=$O(^PRST(458.1,"AD",DFN,KK)) G:KK=""!(KK>DTIN) L3 F DA=0:0 S DA=$O(^PRST(458.1,"AD",DFN,KK,DA)) Q:DA="" I ^(DA)'>DT1 D L1 G:LF L4 123 Q 124 L1 S Z=$G(^PRST(458.1,DA,0)),LF=0 Q:$P(Z,"^",7)'=TT S STAT=$P(Z,"^",9) I "XD"[STAT Q 125 G:Y0="" L2 S Z1=$P(Y0,"^",1),Z2=$P(Y0,"^",2) 126 S X=$P(Z,"^",4)_"^"_$P(Z,"^",6) D CNV^PRSATIM 127 I $P(Z,"^",3)=DT1,$P(Y,"^",1)>Z1 Q 128 I $P(Z,"^",5)=DT2,$P(Y,"^",2)<Z2 Q 129 L2 I STAT'="A" S ERR=4 D ERR 130 S LF=1 Q 131 L3 S ERR=3 D ERR Q 132 L4 Q 133 D2 I DAY<14 S DT2=$P($G(^PRST(458,PPI,1)),"^",DAY+1) Q 134 N X1,X2 S X1=DT1,X2=1 D C^%DTC S DT2=X Q 135 ; 136 HENCAP ; Check for Holiday encapsulated by non-pay 137 N DAH,DBH,HOL,QUIT 138 S (DAH,DBH,HOL,QUIT)="" 139 D HENCAP^PRSATP4(PPI,DFN,DAY,.DBH,.HOL,.DAH,.QUIT) 140 Q:QUIT 141 Q:HOL="" 142 S ERR=15 D ERR Q ; Holiday in current PP 143 Q 144 NAWS3640(PRSEMP,PPI) ; return true if NAWS 36/40 Nurse for this PPI 145 N EMPNODE,PAYPLAN,DTYBASIS,NORMHRS,S8 146 S S8=$G(^PRST(458,PPI,"E",PRSEMP,5)) 147 I S8'="",($E(S8,26,27)'=72!("KM"'[$E(S8,28))!($E(S8,29)'=1)) Q 0 148 S EMPNODE=$G(^PRSPC(PRSEMP,0)) 149 S PAYPLAN=$P(EMPNODE,U,21) 150 S DTYBASIS=$P(EMPNODE,U,10) 151 S NORMHRS=$P(EMPNODE,U,16) 152 Q "KM"[PAYPLAN&(DTYBASIS=1)&(NORMHRS=72) 153 SAT2DAY(WK,PRSIEN,PPI) ; 154 N HRS,SUNTRHRS,SAT2DAY,PRSD 155 S SAT2DAY=0 156 S PRSD=$S(WK=1:7,1:14) 157 S SAT2DAY=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)),"^",2) 158 I SAT2DAY>0 S SAT2DAY=$P($G(^PRST(457.1,SAT2DAY,0)),U,5)="Y" 159 Q SAT2DAY 160 CARRYOVR(PRSIEN,PPI) ; true if hours are coming in from last pp 161 N PRIORSAT,SAT2DAY 162 S SAT2DAY=0 163 S PRIORSAT=$P($G(^PRST(458,PPI-1,"E",PRSIEN,"D",14,0)),U,2) 164 I PRIORSAT>0 S SAT2DAY=$P($G(^PRST(457.1,PRIORSAT,0)),U,5)="Y" 165 Q SAT2DAY 166 THREE12(WK,PRSIEN,PPI) ; 167 N PRSD,TOURDTY,COUNT,ST,EN 168 S COUNT=0 169 S ST=$S(WK=1:1,1:8),EN=$S(WK=1:7,1:14) 170 F PRSD=ST:1:EN D 171 . S TOURDTY=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)),"^",2) 172 . I $P($G(^PRST(457.1,TOURDTY,0)),U,6)=12 S COUNT=COUNT+1 173 I COUNT'=3 Q 1 174 N HRS 175 D TOURHRS^PRSARC07(.HRS,PPI,PRSIEN) 176 Q:(HRS($S(WK=1:"W1",1:"W2"))'=36) 1 177 Q 0 178 HRSMATCH(PPI,DFN) ; Return true if hourly employee tour hrs '= 8B normal hrs 179 N MATCH,HRS,NH,ENT,ENTPTR 180 I $G(PPI)'>0!($G(DFN)'>0) Q 1 181 S MATCH=1 182 S NH=-1 183 S ENTPTR=$P($G(^PRST(458,PPI,"E",DFN,0)),U,5) 184 I ENTPTR'="" D 185 . S ENT=$P($G(^PRST(457.5,ENTPTR,1)),U) 186 . S NH=$E($G(^PRST(458,PPI,"E",DFN,5)),26,27) 187 . Q:NH="00" 188 . I +NH'>0 S NH=$P($G(^PRSPC(DFN,0)),U,50) 189 I $G(ENT)="" D ^PRSAENT 190 I $G(ENT)'="",$E(ENT)'="D",($E(ENT,1,2)'="0D"),$G(NH)'=112 D 191 . D TOURHRS^PRSARC07(.HRS,PPI,DFN) 192 . I ($G(HRS("W1"))+$G(HRS("W2")))'=+$G(NH) S MATCH=0 193 Q MATCH 194 ; 195 ERR ; Set Error 196 S ECNT=ECNT+1,ER(ECNT)=TT_$P($T(ERTX+ERR),";;",2)_"^"_$P(X2,"^",K) Q 197 ERR3640 ; Set NAWS (36/40) Errors and errors not related to a single segment 198 S ECNT=ECNT+1,ER(ECNT)=$P($T(ERTX+ERR),";;",2) Q 199 ERTX ;; 200 1 ;;No Tour Entered^ 201 2 ;;No Time Posted^ 202 3 ;; not Requested 203 4 ;; Requested but not Approved 204 5 ;; Posted outside of Tour Hours or within Recess Hours 205 6 ;; Posted within Tour Hours or outside of Recess Hours 206 7 ;; Posted exceeds Requested Hours 207 8 ;; Requested but pending Supervisor Approval 208 9 ;; Supervisor Approved but pending Director Approval 209 10 ;; Overlaps with the start of the next day's Tour 210 11 ;; Overlaps with the prior day's Tour 211 12 ;; can only be posted against OT, CT, ON, & SB in Tour 212 13 ;; Posted exceeds Approved Hours 213 14 ;; The minimum charge for Military Leave is one hour 214 15 ;; was encapsulated by non-pay 215 16 ;;36/40 AWS tours require 216 17 ;; -no 2 day tours on Sat 217 18 ;; -no prior pp carryover 218 19 ;; -3 12 hr tours/wk 1 219 20 ;; -3 12 hr tours/wk 2 220 21 ;;Normal/Tour hrs unequal 1 PRSATPE ;HISC/REL-Find Exceptions ;12/08/05 2 ;;4.0;PAID;**26,34,69,102**;Sep 21, 1995 3 K ER S (ECNT,FATAL)=0,X0=$G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),STAT=$P($G(^(10)),"^",1) 4 N MLTIME S MLTIME=0 5 S TC=$P(X0,"^",2) I 'TC S ER(1)=$P($T(ERTX+1),";;",2),FATAL=1 G EX 6 I "1 3 4"'[TC,STAT="" S ER(1)=$P($T(ERTX+2),";;",2),FATAL=1 G EX 7 S X2=$G(^PRST(458,PPI,"E",DFN,"D",DAY,2)) G:X2="" EX S X1=$G(^(1)),X4=$G(^(4)) 8 K TM I X2["OT"!(X2["CT") D TM 9 K T F K=1:3 Q:$P(X1,"^",K)="" S Z=$P(X1,"^",K+2) I $S('Z:1,1:$P($G(^PRST(457.2,Z,0)),"^",2)="RG") D 10 .S X=$P(X1,"^",K,K+1) D CNV^PRSATIM S Z1=$P(Y,"^",1),Z2=$P(Y,"^",2) D V0 11 .I Z1'="",$G(T(Z1))="*" K T(Z1) S T(Z2)="*" Q 12 .S T(Z1)="",T(Z2)="*" Q 13 I X4'="" F K=1:3 Q:$P(X4,"^",K)="" S Z=$P(X4,"^",K+2) I $S('Z:1,1:$P($G(^PRST(457.2,Z,0)),"^",2)="RG") D 14 .S X=$P(X4,"^",K,K+1) D CNV^PRSATIM S Z1=$P(Y,"^",1),Z2=$P(Y,"^",2) D V0 15 .I Z1'="",$G(T(Z1))="*" K T(Z1) S T(Z2)="*" Q 16 .S T(Z1)="",T(Z2)="*" Q 17 ; 18 ; Checks for Daily employees 19 I "^"[$P(X2,"^",1,2) S TT=$P(X2,"^",3),K=1,DN=0,Y0="" G L0 20 F K=1:4:25 S X=$P(X2,"^",K,K+1) I "^"'[X D 21 .S TT=$P(X2,"^",K+2) 22 .D CNV^PRSATIM S Y0=Y,Z1=$P(Y,"^",1),Z2=$P(Y,"^",2) D V1 S TIM=Z2-Z1/60 23 .I TT="ML" S MLTIME=MLTIME+TIM 24 .S Z1=$O(T(Z1)) S:Z1'="" Z1=T(Z1) 25 .S Z2=$O(T(Z2-1)) S:Z2'="" Z2=T(Z2) 26 .I TT="UN" D UN^PRSATPH Q 27 .I "CT OT ON SB RG"[TT D OT Q 28 .D LV Q 29 ; 30 ; Check for a minimum of 1 hour ML 31 ; 32 I TT="ML",MLTIME<1 S ER(1)=$P($T(ERTX+14),";;",2),FATAL=1 G EX 33 ; 34 EX Q 35 V0 I Z2>Z1 S:$O(T(""))'<Z2 Z1=Z1+1440,Z2=Z2+1440 Q 36 S Z2=Z2+1440 Q 37 V1 S DN=0 I Z2>Z1 Q:"CT OT ON SB UN RG"[TT S:$O(T(""))'<Z2 Z1=Z1+1440,Z2=Z2+1440,DN=2 Q 38 S Z2=Z2+1440,DN=1 Q 39 OT ; Check OT/CT Request 40 I Z1'=""!(Z2'="") D O2 I $G(ERR)=6 S FATAL=1 D ERR 41 I DN=1,$O(T(1440))="" D NX^PRSATPH 42 I 'DN,$O(T(""))=""!($P(Y0,"^",1)'>$O(T(""))) D PR^PRSATPH 43 I "ON SB RG"[TT Q 44 ; check status of request(s) 45 S DTI=$P($G(^PRST(458,PPI,1)),U,DAY) Q:'DTI 46 S STAT="" ; init highest status var 47 S DA=0 F S DA=$O(^PRST(458.2,"AD",DFN,DTI,DA)) Q:'DA D Q:STAT="A" 48 . S Z=$G(^PRST(458.2,DA,0)) 49 . Q:$P(Z,"^",5)'=TT ; ignore different type 50 . I $F("RSA",$P(Z,U,8))>$F("RSA",STAT) S STAT=$P(Z,U,8) ; higher status 51 I STAT="" S ERR=3 D ERR Q ; none with requested or higher status 52 I STAT'="A" D Q ; none approved 53 . S ERR=$S(STAT="R":8,1:9) D ERR 54 . ; check posted hours vs requested since no approved request 55 . S TM(TT,"R")=$G(TM(TT,"R"))-TIM I TM(TT,"R")<0 S ERR=7 D ERR 56 ; check posted hours vs approved since we have an approved request 57 S TM(TT,"A")=$G(TM(TT,"A"))-TIM I TM(TT,"A")<0 S ERR=13 D ERR 58 Q 59 O2 ; Check for valid with-in tour or cross-tour situations 60 I TT="ON"&(X2["HX") Q 61 ;I "OT CT"[TT,TIM'>1 Q 62 S ERR=6 Q 63 TM ; Get OT,CT request,approve times 64 S DTI=$P($G(^PRST(458,PPI,1)),"^",DAY),DA=0 Q:'DTI 65 T1 S DA=$O(^PRST(458.2,"AD",DFN,DTI,DA)) I 'DA Q 66 S Z=$G(^PRST(458.2,DA,0)),STAT=$P(Z,"^",8) I STAT'="","XD"[STAT G T1 67 S TT=$P(Z,"^",5) I TT'="OT",TT'="CT" G T1 68 S TM(TT,"R")=$G(TM(TT,"R"))+$P(Z,"^",6) ; requested sum 69 I STAT="A" S TM(TT,"A")=$G(TM(TT,"A"))+$P(Z,"^",6) ; approved sum 70 G T1 71 LV ; Check Leave Request 72 I TC=3!(TC=4) Q 73 I TC=1,TT="HW" Q 74 I Z1'="*"!(Z2'="*") S ERR=5,FATAL=1 D ERR 75 ; 76 L0 N REMARK S REMARK=$P(X2,"^",K+3) 77 Q:REMARK&(REMARK'=15&(REMARK'=16)) 78 I "HX"[TT D HENCAP 79 Q:"RG CP NP HX HW TR TV"[TT 80 S DTI=$P($G(^PRST(458,PPI,1)),"^",DAY) Q:'DTI S (DT1,DT2)=DTI 81 I DN D D2 S:DN=2 DT1=DT2 82 S DTIN=9999999-DT2,DA=0 83 F KK=0:0 S KK=$O(^PRST(458.1,"AD",DFN,KK)) G:KK=""!(KK>DTIN) L3 F DA=0:0 S DA=$O(^PRST(458.1,"AD",DFN,KK,DA)) Q:DA="" I ^(DA)'>DT1 D L1 G:LF L4 84 Q 85 L1 S Z=$G(^PRST(458.1,DA,0)),LF=0 Q:$P(Z,"^",7)'=TT S STAT=$P(Z,"^",9) I "XD"[STAT Q 86 G:Y0="" L2 S Z1=$P(Y0,"^",1),Z2=$P(Y0,"^",2) 87 S X=$P(Z,"^",4)_"^"_$P(Z,"^",6) D CNV^PRSATIM 88 I $P(Z,"^",3)=DT1,$P(Y,"^",1)>Z1 Q 89 I $P(Z,"^",5)=DT2,$P(Y,"^",2)<Z2 Q 90 L2 I STAT'="A" S ERR=4 D ERR 91 S LF=1 Q 92 L3 S ERR=3 D ERR Q 93 L4 Q 94 D2 I DAY<14 S DT2=$P($G(^PRST(458,PPI,1)),"^",DAY+1) Q 95 N X1,X2 S X1=DT1,X2=1 D C^%DTC S DT2=X Q 96 ; 97 HENCAP ; Check for Holiday encapsulated by non-pay 98 N DAH,DBH,HOL,QUIT 99 S (DAH,DBH,HOL,QUIT)="" 100 D HENCAP^PRSATP4(PPI,DFN,DAY,.DBH,.HOL,.DAH,.QUIT) 101 Q:QUIT 102 Q:HOL="" 103 S ERR=15 D ERR Q ; Holiday in current PP 104 Q 105 ; 106 ERR ; Set Error 107 S ECNT=ECNT+1,ER(ECNT)=TT_$P($T(ERTX+ERR),";;",2)_"^"_$P(X2,"^",K) Q 108 ERTX ;; 109 1 ;;No Tour Entered^ 110 2 ;;No Time Posted^ 111 3 ;; not Requested 112 4 ;; Requested but not Approved 113 5 ;; Posted outside of Tour Hours 114 6 ;; Posted within Tour Hours 115 7 ;; Posted exceeds Requested Hours 116 8 ;; Requested but pending Supervisor Approval 117 9 ;; Supervisor Approved but pending Director Approval 118 10 ;; Overlaps with the start of the next day's Tour 119 11 ;; Overlaps with the prior day's Tour 120 12 ;; can only be posted against OT, CT, ON, & SB in Tour 121 13 ;; Posted exceeds Approved Hours 122 14 ;; The minimum charge for Military Leave is one hour 123 15 ;; was encapsulated by non-pay -
WorldVistAEHR/trunk/r/PAID-PRS/PRSAUDP.m
r613 r623 1 PRSAUDP ; WOIFO/DWA - Display Employee Pay Period Audit Data ;12/3/07 2 ;;4.0;PAID;**116**;Sep 21, 1995;Build 23 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ;called by PRSADP2 5 D RET Q:QT 6 S STATYPE=$P(^DD(458.1101,4,0),"^",3) 7 S PG=PG+1,X=$G(^PRSPC(DFN,0)) W @IOF,!,?3,$P(X,U,1) S X=$P(X,U,9) 8 I '$G(PRSTLV)!($G(PRSTLV)=1) W ?68,"XXX-XX-",$E(X,6,9) 9 I $G(PRSTLV)=2!($G(PRSTLV)=3) W ?68,$E(X),"XX-XX-",$E(X,6,9) 10 I $G(PRSTLV)=7 W ?68,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9) 11 W !,?26,"Corrected T&A History",!! 12 AUN S AUN=0 F S AUN=$O(^PRST(458,PPI,"E",DFN,"X",AUN)) Q:AUN=""!(QT=1) D B 13 W @IOF 14 EX K AUN,AX0,B,CA,CB,CC,CD,DAY,DB,DISP,DTE,IFN,J,TYP,X,STATYPE,STATUS,LNE,DFN,AUR 15 Q 16 B S B=-1 S B=$O(^PRST(458,PPI,"E",DFN,"X",AUN,B)) Q:B=""!(QT=1) S AX0=$G(^(B)) 17 F CA=1:1:11 S AX0(CA)=$P(AX0,U,CA) 18 S STDT="" F CB=2,11,9,7 S Y=AX0(CB) D DTP S AX0(CB)=Y S:Y'="" STDT=Y K Y ;date/time(s) 19 F CC=3,6,8,10 I AX0(CC)]"" I $D(^VA(200,AX0(CC),0)) S AX0(CC)=$P(^VA(200,AX0(CC),0),U,1) ;names 20 S TYP=AX0(4),LNE="" S $P(LNE,"-",80)="" S STATUS=$P($P(STATYPE,AX0(5)_":",2),";",1) 21 Q:TYP'?1U Q:"TVH"'[TYP D @TYP 22 I $D(^PRST(458,PPI,"E",DFN,"X",AUN,7)) W !!,"Change Remarks: ",^(7) 23 D RET Q 24 RET I $E(IOST,1,2)="C-" R !!,"Press RETURN to Continue.",X:DTIME S:'$T!(X[U) QT=1 W @IOF 25 Q 26 T ;Time/Tour Change 27 W !,"Status: ",STATUS,?29,"* * * Prior Data * * *",?58,STDT S IFN=AUN S DAY=$P($G(^PRST(458,PPI,"E",DFN,"X",IFN,1)),"^",1),DTE=$P($G(^PRST(458,PPI,2)),"^",+DAY) D GET^PRSAPPP,DIS^PRSAPPQ 28 W !!?27,"* * * Corrected Data * * *" S IFN=AUN+1 D GET^PRSAPPP,DIS^PRSAPPQ W !,LNE,! 29 Q 30 V ;VCS Sales Change 31 W !,"Status: ",STATUS,?29,"* * * Prior Data * * *",?58,STDT S IFN=AUN D GET^PRSAPPP S Z=AUR(1) D VCS^PRSAPPQ 32 W !!?27,"* * * Corrected Data * * *" S IFN=AUN+1 D GET^PRSAPPP S Z=AUR(1) D VCS^PRSAPPQ W !,LNE,! 33 Q 34 H ;Hazard Change 35 W !,"Status: ",STATUS,?29,"* * * Prior Data * * *",?58,STDT S IFN=AUN D GET^PRSAPPP S Z=AUR(1) D ED^PRSAPPQ 36 W !!?27,"* * * Corrected Data * * *" S IFN=AUN+1 D GET^PRSAPPP S Z=AUR(1) D ED^PRSAPPQ W !,LNE,! 37 Q 38 DTP ; Printable Date/Time 39 Q:'Y S %=Y,Y=$J(+$E(Y,6,7),2)_"-"_$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$E(Y,4,5))_"-"_$E(Y,2,3) 40 S:%#1 %=+$E(%_"0",9,10)_"^"_$E(%_"000",11,12),Y=Y_$J($S(%>12:%-12,1:+%),3)_":"_$P(%,"^",2)_$S(%<12:"am",%<24:"pm",1:"m") K % Q 1 PRSAUDP ; HISC/JLS-Display Employee Pay Period Audit Data ;5/13/94 09:43 2 ;;4.0;PAID;;Sep 21, 1995 3 ;called by PRSADP2 4 D RET Q:QT 5 S STATYPE=$P(^DD(458.1101,4,0),"^",3) 6 S PG=PG+1,X=$G(^PRSPC(DFN,0)) W @IOF,!,?3,$P(X,U,1) S X=$P(X,U,9) W ?68,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9),!,?26,"Corrected T&A History",!! 7 AUN S AUN=0 F S AUN=$O(^PRST(458,PPI,"E",DFN,"X",AUN)) Q:AUN=""!(QT=1) D B 8 W @IOF 9 EX K AUN,AX0,B,CA,CB,CC,CD,DAY,DB,DISP,DTE,IFN,J,TYP,X,STATYPE,STATUS,LNE,DFN,AUR 10 Q 11 B S B=-1 S B=$O(^PRST(458,PPI,"E",DFN,"X",AUN,B)) Q:B=""!(QT=1) S AX0=$G(^(B)) 12 F CA=1:1:11 S AX0(CA)=$P(AX0,U,CA) 13 S STDT="" F CB=2,11,9,7 S Y=AX0(CB) D DTP S AX0(CB)=Y S:Y'="" STDT=Y K Y ;date/time(s) 14 F CC=3,6,8,10 I AX0(CC)]"" I $D(^VA(200,AX0(CC),0)) S AX0(CC)=$P(^VA(200,AX0(CC),0),U,1) ;names 15 S TYP=AX0(4),LNE="" S $P(LNE,"-",80)="" S STATUS=$P($P(STATYPE,AX0(5)_":",2),";",1) 16 Q:TYP'?1U Q:"TVH"'[TYP D @TYP 17 I $D(^PRST(458,PPI,"E",DFN,"X",AUN,7)) W !!,"Change Remarks: ",^(7) 18 D RET Q 19 RET I $E(IOST,1,2)="C-" R !!,"Press RETURN to Continue.",X:DTIME S:'$T!(X[U) QT=1 W @IOF 20 Q 21 T ;Time/Tour Change 22 W !,"Status: ",STATUS,?29,"* * * Prior Data * * *",?58,STDT S IFN=AUN S DAY=$P($G(^PRST(458,PPI,"E",DFN,"X",IFN,1)),"^",1),DTE=$P($G(^PRST(458,PPI,2)),"^",+DAY) D GET^PRSAPPP,DIS^PRSAPPQ 23 W !!?27,"* * * Corrected Data * * *" S IFN=AUN+1 D GET^PRSAPPP,DIS^PRSAPPQ W !,LNE,! 24 Q 25 V ;VCS Sales Change 26 W !,"Status: ",STATUS,?29,"* * * Prior Data * * *",?58,STDT S IFN=AUN D GET^PRSAPPP S Z=AUR(1) D VCS^PRSAPPQ 27 W !!?27,"* * * Corrected Data * * *" S IFN=AUN+1 D GET^PRSAPPP S Z=AUR(1) D VCS^PRSAPPQ W !,LNE,! 28 Q 29 H ;Hazard Change 30 W !,"Status: ",STATUS,?29,"* * * Prior Data * * *",?58,STDT S IFN=AUN D GET^PRSAPPP S Z=AUR(1) D ED^PRSAPPQ 31 W !!?27,"* * * Corrected Data * * *" S IFN=AUN+1 D GET^PRSAPPP S Z=AUR(1) D ED^PRSAPPQ W !,LNE,! 32 Q 33 DTP ; Printable Date/Time 34 Q:'Y S %=Y,Y=$J(+$E(Y,6,7),2)_"-"_$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$E(Y,4,5))_"-"_$E(Y,2,3) 35 S:%#1 %=+$E(%_"0",9,10)_"^"_$E(%_"000",11,12),Y=Y_$J($S(%>12:%-12,1:+%),3)_":"_$P(%,"^",2)_$S(%<12:"am",%<24:"pm",1:"m") K % Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRSDEU03.m
r613 r623 1 PRSDEU03 ;HISC/MGD-PAID EDIT AND UPDATE DOWNLOAD RECORD 3 LAYOUT ;05/13/04 2 ;;4.0;PAID;**73,106**;Sep 21, 1995;Build 5 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 F CC=1:1 S GRP=$T(@CC) Q:GRP="" S GRPVAL=$P(RCD,":",CC) I GRPVAL'="" S GNUM=$P(GRP,";",4),LTH=$P(GRP,";",5),PIC=$P(GRP,";",6) D:PIC=9 PIC9^PRSDUTIL F EE=1:1:GNUM S FLD=$T(@CC+EE) D EPTSET^PRSDSET 5 Q 6 RECORD ;;Record 3;29 7 ;; 8 1 ;;Group 1;1;3;9 9 ;;MXFTAXEX;FEDERAL TAX EXEMPTIONS;1;3;FED;6;D SIGN^PRSDUTIL S DATA=+DATA;;;217 10 ;; 11 2 ;;Group 2;1;5;9 12 ;;MXADDFWH;FEDERAL TAX ADDNL AMT WITHHELD;1;5;FED;2;D SIGN^PRSDUTIL S DATA=+DATA;;;213 13 ;; 14 3 ;;Group 3;1;9;9 15 ;;MXFTWHQ;FEDERAL TAX AMT WITHHELD QTD;1;9;FED;3;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;214 16 ;; 17 4 ;;Group 4;1;9;9 18 ;;MXFTWHYD;FEDERAL TAX AMT WITHHELD YTD;1;9;FED;4;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;215 19 ;; 20 5 ;;Group 5;1;9;9 21 ;;MXGROSSQ;FEDERAL TAX GROSS PAY QTD;1;9;FED;7;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;218 22 ;; 23 6 ;;Group 6;1;9;9 24 ;;MXGRSYTD;FEDERAL TAX GROSS PAY YTD;1;9;FED;8;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;219 25 ;; 26 7 ;;Group 7;3;6;X 27 ;;MXSTX-GSACODE;STATE TAX-1 GSA CODE;1;2;STATE;10;;;;381 28 ;;MXSTX-MARITAL-STATUS;STATE TAX-1 MARITAL STATUS;3;4;STATE;11;;;;382 29 ;;MXSTX-RESIDENCE;STATE TAX-1 RESIDENCE STATE;5;6;STATE;12;;;;383 30 ;; 31 8 ;;Group 8;2;6;9 32 ;;MXSTX-EXEMPTION-1;STATE TAX-1 EXEMPTION CODE-1;1;3;STATE;6;D SIGN^PRSDUTIL,D^PRSDUTIL S DATA=+DATA;;;377 33 ;;MXSTX-EXEMPTION-2;STATE TAX-1 EXEMPTION CODE-2;4;6;STATE;7;D SIGN^PRSDUTIL S DATA=+DATA;;;378 34 ;; 35 9 ;;Group 9;1;5;9 36 ;;MXSTX-ADDITIONAL-WITH;STATE TAX-1 ADDNL AMT WITHHELD;1;5;STATE;2;D SIGN^PRSDUTIL S DATA=+DATA;;;373 37 ;; 38 10 ;;Group 10;1;9;9 39 ;;MXSTX-CURRENT-TAX;STATE TAX-1 AMT WITHHELD CTPTD;1;9;STATE;3;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;374 40 ;; 41 11 ;;Group 11;1;9;9 42 ;;MXSTX-YTD-TAX;STATE TAX-1 AMT WITHHELD YTD;1;9;STATE;4;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;375 43 ;; 44 12 ;;Group 12;1;9;9 45 ;;MXSTX-CURRENT-GROSS;STATE TAX-1 GROSS PAY CTPTD;1;9;STATE;8;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;379 46 ;; 47 13 ;;Group 13;1;9;9 48 ;;MXSTX-YTD-GROSS;STATE TAX-1 GROSS PAY YTD;1;9;STATE;9;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;380 49 ;; 50 14 ;;Group 14;1;7;9 51 ;;MXMEDTRF;MEDICARE WAGES PRIOR AGCY YTD;1;7;MEDICARE;8;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;257 52 ;; 53 15 ;;Group 15;3;10;X 54 ;;MXCTX-GSACODE;CITY TAX-1 GSA CODE;1;6;CITY;9;;;;195 55 ;;MXCTX-MARITAL-STATUS;CITY TAX-1 MARITAL STATUS;7;8;CITY;10;;;;196 56 ;;MXCTX-RESIDENCE;CITY TAX-1 RESIDENCE STATE;9;10;CITY;11;;;;197 57 ;; 58 16 ;;Group 16;2;6;9 59 ;;MXCTX-EXEMPTION-1;CITY TAX-1 EXEMPTION CODE-1;1;3;CITY;5;D SIGN^PRSDUTIL,D^PRSDUTIL S DATA=+DATA;;;191 60 ;;MXCTX-EXEMPTION-2;CITY TAX-1 EXEMPTION CODE-2;4;6;CITY;6;D SIGN^PRSDUTIL S DATA=+DATA;;;192 61 ;; 62 17 ;;Group 17;1;5;9 63 ;;MXCTX-ADDITIONAL-WITH;CITY TAX-1 ADDNL AMT WITHHELD;1;5;CITY;1;D SIGN^PRSDUTIL S DATA=+DATA;;;187 64 ;; 65 18 ;;Group 18;1;5;9 66 ;;MXSTX-PR-EXEMPTION;PUERTO RICO STATE TAX EXEMPT;1;5;STATE;1;D SIGN^PRSDUTIL S DATA=+DATA;;;372 67 ;; 68 19 ;;Group 19;2;9;X 69 ;;MXVALTNO;VOLUNTARY ALLOTMENT-1 CTRL NO;1;4;VALLOT;3;;;;437 70 ;;MXVALAMT;VOLUNTARY ALLOTMENT-1 AMT;5;9;VALLOT;1;D SIGN^PRSDUTIL S DATA=+DATA;;;435 71 ;; 72 20 ;;Group 20;2;8;X 73 ;;MXCFCCOD;CFC CODE;1;3;CFC;2;;;;210 74 ;;MXCFCBIW;CFC BIWEEKLY DEDUCTION;4;8;CFC;1;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;209 75 ;; 76 21 ;;Group 21;1;5;9 77 ;;MXHRUNAL;UNIFORM ALLOWANCE HOURLY RATE;1;5;UNIFORM;3;D SIGN^PRSDUTIL S DATA=$E(DATA,1,5) D DDDD^PRSDUTIL;;;565 78 ;; 79 22 ;;Group 22;2;8;X 80 ;;MXUNRID1;BUS CODE;1;4;1;5;;;;52 81 ;;MXUNCOD1;UNION CODE-1;5;8;UNION;1;;;;428 82 ;; 83 23 ;;Group 23;1;5;9 84 ;;MXUNDES1;UNION DUES-1 DEDUCTION EPPD;1;5;UNION;5;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;432 85 ;; 86 24 ;;Group 24;1;7;9 87 ;;SLCBLYTD;CARE/BEREAVE LEAVE USED LYTD;1;7;SICK;10;D SIGN^PRSDUTIL,DDD^PRSDUTIL;;;711 88 ;; 89 25 ;;Group 25;1;7;9 90 ;;SLADLYTD;ADOPTION LEAVE USED LYTD;1;7;SICK;12;D SIGN^PRSDUTIL,DDD^PRSDUTIL;;;713 91 ;; 92 26 ;;Group 26;1;7;9 93 ;;OSLLYTD;OTHER SICK LEAVE USED LYTD;1;7;SICK;14;D SIGN^PRSDUTIL,DDD^PRSDUTIL;;;715 94 ;; 95 27 ;;Group 27;1;7;9 96 ;;DLLYTD;DONOR LEAVE USED LYTD;1;7;SICK;16;D SIGN^PRSDUTIL,DDD^PRSDUTIL;;;717 97 ;; 98 28 ;;Group 28;1;8;X 99 ;;MXWIGDTE;WGI DUE DATE;1;8;0;51;D DATE^PRSDUTIL;;;600 100 ;; 101 29 ;;Group 29;1;1;X 102 ;;MXLCKFEDTX;FEDERAL TAX LOCK-IN INDICATOR;1;1;FED;13;;;;754 1 PRSDEU03 ;HISC/MGD-PAID EDIT AND UPDATE DOWNLOAD RECORD 3 LAYOUT ;05/13/04 2 ;;4.0;PAID;**73**;Sep 21, 1995 3 F CC=1:1 S GRP=$T(@CC) Q:GRP="" S GRPVAL=$P(RCD,":",CC) I GRPVAL'="" S GNUM=$P(GRP,";",4),LTH=$P(GRP,";",5),PIC=$P(GRP,";",6) D:PIC=9 PIC9^PRSDUTIL F EE=1:1:GNUM S FLD=$T(@CC+EE) D EPTSET^PRSDSET 4 Q 5 RECORD ;;Record 3;29 6 ;; 7 1 ;;Group 1;1;3;9 8 ;;MXFTAXEX;FEDERAL TAX EXEMPTIONS;1;3;FED;6;D SIGN^PRSDUTIL S DATA=+DATA;;;217 9 ;; 10 2 ;;Group 2;1;5;9 11 ;;MXADDFWH;FEDERAL TAX ADDNL AMT WITHHELD;1;5;FED;2;D SIGN^PRSDUTIL S DATA=+DATA;;;213 12 ;; 13 3 ;;Group 3;1;9;9 14 ;;MXFTWHQ;FEDERAL TAX AMT WITHHELD QTD;1;9;FED;3;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;214 15 ;; 16 4 ;;Group 4;1;9;9 17 ;;MXFTWHYD;FEDERAL TAX AMT WITHHELD YTD;1;9;FED;4;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;215 18 ;; 19 5 ;;Group 5;1;9;9 20 ;;MXGROSSQ;FEDERAL TAX GROSS PAY QTD;1;9;FED;7;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;218 21 ;; 22 6 ;;Group 6;1;9;9 23 ;;MXGRSYTD;FEDERAL TAX GROSS PAY YTD;1;9;FED;8;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;219 24 ;; 25 7 ;;Group 7;3;6;X 26 ;;MXSTX-GSACODE;STATE TAX-1 GSA CODE;1;2;STATE;10;;;;381 27 ;;MXSTX-MARITAL-STATUS;STATE TAX-1 MARITAL STATUS;3;4;STATE;11;;;;382 28 ;;MXSTX-RESIDENCE;STATE TAX-1 RESIDENCE STATE;5;6;STATE;12;;;;383 29 ;; 30 8 ;;Group 8;2;6;9 31 ;;MXSTX-EXEMPTION-1;STATE TAX-1 EXEMPTION CODE-1;1;3;STATE;6;D SIGN^PRSDUTIL,D^PRSDUTIL S DATA=+DATA;;;377 32 ;;MXSTX-EXEMPTION-2;STATE TAX-1 EXEMPTION CODE-2;4;6;STATE;7;D SIGN^PRSDUTIL S DATA=+DATA;;;378 33 ;; 34 9 ;;Group 9;1;5;9 35 ;;MXSTX-ADDITIONAL-WITH;STATE TAX-1 ADDNL AMT WITHHELD;1;5;STATE;2;D SIGN^PRSDUTIL S DATA=+DATA;;;373 36 ;; 37 10 ;;Group 10;1;9;9 38 ;;MXSTX-CURRENT-TAX;STATE TAX-1 AMT WITHHELD CTPTD;1;9;STATE;3;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;374 39 ;; 40 11 ;;Group 11;1;9;9 41 ;;MXSTX-YTD-TAX;STATE TAX-1 AMT WITHHELD YTD;1;9;STATE;4;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;375 42 ;; 43 12 ;;Group 12;1;9;9 44 ;;MXSTX-CURRENT-GROSS;STATE TAX-1 GROSS PAY CTPTD;1;9;STATE;8;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;379 45 ;; 46 13 ;;Group 13;1;9;9 47 ;;MXSTX-YTD-GROSS;STATE TAX-1 GROSS PAY YTD;1;9;STATE;9;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;380 48 ;; 49 14 ;;Group 14;1;7;9 50 ;;MXMEDTRF;MEDICARE WAGES PRIOR AGCY YTD;1;7;MEDICARE;8;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;257 51 ;; 52 15 ;;Group 15;3;10;X 53 ;;MXCTX-GSACODE;CITY TAX-1 GSA CODE;1;6;CITY;9;;;;195 54 ;;MXCTX-MARITAL-STATUS;CITY TAX-1 MARITAL STATUS;7;8;CITY;10;;;;196 55 ;;MXCTX-RESIDENCE;CITY TAX-1 RESIDENCE STATE;9;10;CITY;11;;;;197 56 ;; 57 16 ;;Group 16;2;6;9 58 ;;MXCTX-EXEMPTION-1;CITY TAX-1 EXEMPTION CODE-1;1;3;CITY;5;D SIGN^PRSDUTIL,D^PRSDUTIL S DATA=+DATA;;;191 59 ;;MXCTX-EXEMPTION-2;CITY TAX-1 EXEMPTION CODE-2;4;6;CITY;6;D SIGN^PRSDUTIL S DATA=+DATA;;;192 60 ;; 61 17 ;;Group 17;1;5;9 62 ;;MXCTX-ADDITIONAL-WITH;CITY TAX-1 ADDNL AMT WITHHELD;1;5;CITY;1;D SIGN^PRSDUTIL S DATA=+DATA;;;187 63 ;; 64 18 ;;Group 18;1;5;9 65 ;;MXSTX-PR-EXEMPTION;PUERTO RICO STATE TAX EXEMPT;1;5;STATE;1;D SIGN^PRSDUTIL S DATA=+DATA;;;372 66 ;; 67 19 ;;Group 19;2;9;X 68 ;;MXVALTNO;VOLUNTARY ALLOTMENT-1 CTRL NO;1;4;VALLOT;3;;;;437 69 ;;MXVALAMT;VOLUNTARY ALLOTMENT-1 AMT;5;9;VALLOT;1;D SIGN^PRSDUTIL S DATA=+DATA;;;435 70 ;; 71 20 ;;Group 20;2;8;X 72 ;;MXCFCCOD;CFC CODE;1;3;CFC;2;;;;210 73 ;;MXCFCBIW;CFC BIWEEKLY DEDUCTION;4;8;CFC;1;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;209 74 ;; 75 21 ;;Group 21;1;5;9 76 ;;MXHRUNAL;UNIFORM ALLOWANCE HOURLY RATE;1;5;UNIFORM;3;D SIGN^PRSDUTIL S DATA=$E(DATA,1,4) D DDDD^PRSDUTIL;;;565 77 ;; 78 22 ;;Group 22;2;8;X 79 ;;MXUNRID1;BUS CODE;1;4;1;5;;;;52 80 ;;MXUNCOD1;UNION CODE-1;5;8;UNION;1;;;;428 81 ;; 82 23 ;;Group 23;1;5;9 83 ;;MXUNDES1;UNION DUES-1 DEDUCTION EPPD;1;5;UNION;5;D SIGN^PRSDUTIL,DD^PRSDUTIL;;;432 84 ;; 85 24 ;;Group 24;1;7;9 86 ;;SLCBLYTD;CARE/BEREAVE LEAVE USED LYTD;1;7;SICK;10;D SIGN^PRSDUTIL,DDD^PRSDUTIL;;;711 87 ;; 88 25 ;;Group 25;1;7;9 89 ;;SLADLYTD;ADOPTION LEAVE USED LYTD;1;7;SICK;12;D SIGN^PRSDUTIL,DDD^PRSDUTIL;;;713 90 ;; 91 26 ;;Group 26;1;7;9 92 ;;OSLLYTD;OTHER SICK LEAVE USED LYTD;1;7;SICK;14;D SIGN^PRSDUTIL,DDD^PRSDUTIL;;;715 93 ;; 94 27 ;;Group 27;1;7;9 95 ;;DLLYTD;DONOR LEAVE USED LYTD;1;7;SICK;16;D SIGN^PRSDUTIL,DDD^PRSDUTIL;;;717 96 ;; 97 28 ;;Group 28;1;8;X 98 ;;MXWIGDTE;WGI DUE DATE;1;8;0;51;D DATE^PRSDUTIL;;;600 99 ;; 100 29 ;;Group 29;1;1;X 101 ;;MXLCKFEDTX;FEDERAL TAX LOCK-IN INDICATOR;1;1;FED;13;;;;754 -
WorldVistAEHR/trunk/r/PAID-PRS/PRSDSERV.m
r613 r623 1 PRSDSERV ;WOIFO/MGD,PLT - PAID DOWNLOAD MESSAGE SERVER ;12/3/07 2 ;;4.0;PAID;**6,78,82,116**;Sep 21, 1995;Build 23 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 D NOW^%DTC S TIME=% S XMPOS=1 D REC^XMS3 G:XMER'=0 EXIT 5 S LPE=$E(XMRG,1,7) I LPE'?1"**"2N1"PDH",LPE'="****PDH" G EXIT 6 ; EMPCNT = # emp in this mail message 7 ; SEQNUM = Mail message sequence number if more than one message 8 S EMPCNT=+$E(XMRG,9,12),SEQNUM=$E(XMRG,13,16),TYPE=$E(XMRG,23) 9 S DATE=$E(XMRG,24,31),STA="",SUB="TMP" 10 I "IEPTD"'[TYPE G EXIT 11 ; Check to see if the message was previously loaded 12 I $D(^PRSD(450.12,"B",XMZ)) G EXIT 13 S MTYPE=$S(TYPE="I":"Initial",TYPE="E":"Edit & Update",TYPE="P":"Payrun",TYPE="T":"Transfer",1:"") 14 ; Set Lines Per Employee (LPE) for the correct interface 15 S LPE=$E(LPE,3,4),LPE=$S(LPE?2N:+LPE,TYPE="I":20,(TYPE="E")!(TYPE="T"):15,TYPE="P":9,1:0) 16 D REC^XMS3 G:XMER'=0 EXIT S STA=$E(XMRG,1,3) I STA'?3N G EXIT 17 I TYPE="D" D ^PRSDDL G EXIT ; Process Separation download 18 ; Mark message as received. This info is for the reports sent to the 19 ; PAD mail group. 20 I $D(^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM)) D G EXIT 21 .S ^TMP($J,"PRSD",999)=MTYPE_" message "_SEQNUM_" received." 22 .D SETPRS S MNR="" D PROC^PRSDPROC 23 I $D(^PRSD(450.12,"C",TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM)) G EXIT 24 K DD,DO S DIC="^PRSD(450.12,",DIC(0)="L",X=XMZ D FILE^DICN 25 S PRSDIEN=+Y,$P(^PRSD(450.12,+Y,0),U,2)=TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM 26 S $P(^PRSD(450.12,+Y,0),U,3)="R",$P(^PRSD(450.12,+Y,0),U,4)=TIME 27 S ^PRSD(450.12,"C",TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM,+Y)="" 28 SETPRS ;start employee record 29 S XMPOS=2 F A=1:1:EMPCNT D SSNLOOP Q:SSN=999999999 30 I $D(^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM)) K ^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM) Q 31 S:SSN'=999999999 $P(^PRSD(450.12,PRSDIEN,0),U,3)="S" 32 EXIT K %,%H,%I,A,AA,AAA,ADDFLG,B,BB,CC,DA,DATA,DATE,DBNAME,DIC,DIK,DINUM 33 K DLAYGO,DLID,E1,E2,EE,ECNT,ECOUNT,EMPCNT,ERRCNT,ERRFLG,ERRID,ERRIEN,SUB 34 K ERRMSG,FLD,FLDNUM,GNUM,GRP,GRPVAL,IEN,II,LPE,LTH,MO,MFLD,MTYPE,MULT 35 K NAME,NODE,NODE459,PIC,PIECE,PIECE459,PP,PP455,PPIEN,PRSD,PRSDIEN,RCD 36 K RTN,RTNNUM,RTYPE,SEQNUM,SSN,SSNLINE,STA,STA450,SUM,TMPIEN,TMPLINE 37 K TIME,TYPE,X,XCNP,XMDUZ,XMSUB,XMTEXT,XMY,Y,YR,XMPOS,XMRG,XMER,XMLOC 38 K XMMG,MNR,PDATE,CDATE,X1,X2 39 REMSB I $D(XMZ) S XMSER="S.PRSD" D REMSBMSG^XMA1C K XMSER 40 Q 41 SSNLOOP D REC^XMS3 42 S SSN=$S(TYPE="I":$P(XMRG,":",2),1:$E(XMRG,4,12)) 43 S SSN=$E("000000000",$L(SSN)+1,9)_SSN 44 ; The last employee in the last MailMan message has a SSN=999999999 45 ; This triggers the software to begin processing the download. 46 I SSN=999999999 D Q 47 .I TYPE="I" K ^XTMP("PRS","ERR") 48 .S ^XTMP("PRS","LSN",TYPE,DATE,STA)=SEQNUM 49 .S:$D(PRSDIEN) $P(^PRSD(450.12,PRSDIEN,0),U,3)="S" H 600 50 .D REMSB S ECNT=0 D START,START,^PRSDERR,^PRSDSTAT S SSN=999999999 51 S (PDATE,CDATE)=$P(TIME,".",1),X1=PDATE,X2=90 D C^%DTC S PDATE=X 52 S ^XTMP("PRS",0)=PDATE_"^"_CDATE 53 K KFLG S XMPOS=XMPOS-1 54 F B=1:1:LPE D REC^XMS3 I (($L(XMRG,":")-1)'=$L(XMRG))!(TYPE="I") S TMPLINE=$E("000",$L(XMPOS)+1,3)_XMPOS,^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,XMZ_"-"_TMPLINE_"-"_B)=XMRG I TYPE="T",B=6 D TRANSCK^PRSDERR 55 I $D(KFLG) K ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN),KFLG 56 Q 57 START ; Process download 58 ; RTYPE is used to determine which series of routines to call to 59 ; process the download 60 S SSN="",RTYPE=$S(TYPE="I":"LD",(TYPE="E")!(TYPE="T"):"EU",TYPE="P":"PR",1:"") 61 F S SSN=$O(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN)) Q:SSN="" D 62 . L +^XTMP("PRS",SUB,DATE,TYPE,STA,SSN):0 63 . I $T D 64 . . S TMPIEN=$O(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,"")) 65 . . I TMPIEN'="" D 66 . . . S RCD=^(TMPIEN),ERRFLG="" 67 . . . D SSN 68 . . . D:ERRFLG'="Y" LDINIT,PROC,PROC2,LDFNL,LDCMP 69 . . . D:ERRFLG="Y" TMPERR D UNL 70 Q 71 ; Piece together the routine name and call the routine 72 PROC S TMPIEN="" F S TMPIEN=$O(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN)) Q:TMPIEN="" S RCD=^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN),RTNNUM=$P(TMPIEN,"-",3) S:$L(RTNNUM)=1 RTNNUM=0_RTNNUM S RTN="^PRSD"_RTYPE_RTNNUM D:$T(@RTN)]"" @RTN 73 Q 74 PROC2 I TYPE="P",PP'="" D ^PRSDCOMP ;Compute calculated fields 75 S NODE=0 F EE=1:1 S NODE=$O(^PRSPC(IEN,NODE)) Q:NODE="" I $D(^PRSPC(IEN,NODE))#2 S DATA=^PRSPC(IEN,NODE) I $L(DATA,U)-1=$L(DATA) K ^PRSPC(IEN,NODE) 76 K ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q 77 TMPERR I TYPE="P",PP="" G TMPERR1 78 S TMPIEN="" F S TMPIEN=$O(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN)) Q:TMPIEN="" S RCD=^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN),^XTMP("PRS","ERR",DATE,TYPE,STA,SSN,TMPIEN)=RCD 79 TMPERR1 K ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q 80 UNL L -^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q 81 SSN I TYPE="P",'$D(^PRSPC("SSN",SSN)) S ERRMSG="SSN "_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_" not found" D ERR Q 82 I TYPE="I" S NAME=$P(RCD,":",4) 83 I (TYPE="E")!(TYPE="T") S NAME=$P(RCD,":",2),DATA=$E(NAME,1,27) I DATA'="" D RTS^PRSDUTIL S NAME=DATA S:TYPE="T" ^TMP($J,"PRS",NAME,SSN)="" 84 I '$D(^PRSPC("SSN",SSN)) D ^PRSDADD K DA,DIE,DR,OLDSSN,VAIEN,VANAME Q:ERRFLG="Y" G SSNOUT 85 S IEN=0,IEN=$O(^PRSPC("SSN",SSN,IEN)) 86 SSNOUT I TYPE="P" D ^PRSDPTYP I PP="" S ERRFLG="Y" Q 87 S ECNT=ECNT+1 88 Q 89 ERR K DD,DO S DIC="^PRSD(450.11,",DIC(0)="L",X=TYPE_"-"_DATE_"-"_STA D FILE^DICN I Y>0 S $P(^PRSD(450.11,+Y,0),U,3)=ERRMSG 90 S ERRFLG="Y" 91 Q 92 LDINIT ; Load Initial Labor Distribution Values 93 S LDINIT=$$LDLOAD() 94 Q 95 LDFNL ; Load Final Labor Distribution Values 96 S LDFNL=$$LDLOAD() 97 Q 98 LDLOAD() ; Retrieve current Labor Distribution Values from #450 99 ; 100 N LD,LDCC,LDCODE,LDFCP,LDPCT,PRSLD 101 S LD="" 102 F PRSLD=1:1:4 D 103 . S LDCODE=$$GET1^DIQ(450.0757,PRSLD_","_IEN,1) 104 . S LDPCT=$$GET1^DIQ(450.0757,PRSLD_","_IEN,2) 105 . S LDCC=$$GET1^DIQ(450.0757,PRSLD_","_IEN,3) 106 . S LDFCP=$$GET1^DIQ(450.0757,PRSLD_","_IEN,4) 107 . S LD=LD_LDCODE_U_LDPCT_U_LDCC_U_LDFCP_U 108 Q LD 109 ; 110 LDCMP ; Compare Initial and Final Labor Distribution for changes 111 ; and update audit trail in #458 if necessary. 112 Q:LDINIT=LDFNL 113 N PPA,I,IENS,IENS1,INDX,J,LDA,PRSFDA,TLDPER 114 ; Get IEN for current Pay Period 115 S PPA=$P($G(^PRST(458,"AD",$P(TIME,".",1))),U,1) 116 Q:PPA="" 117 ; 118 ; Get next multiple number 119 S LDA="A",LDA=$O(^PRST(458,PPA,"E",IEN,"LDAUD",LDA),-1) 120 S LDA=$S(LDA>0:LDA+1,1:1) 121 ; 122 ; Set Audit information into #450 123 S DA=IEN,DIE="^PRSPC(" 124 S DR="755///^S X=$O(^VA(200,""B"",""CENTRAL,PAID"",0))" 125 D ^DIE 126 S DR="755.1///^S X=TYPE" 127 D ^DIE 128 S DR="756///^S X=TIME" 129 D ^DIE 130 ; 131 ; If there is no entry for this employee in the Pay Period, create 132 ; a record for them 133 I '$D(^PRSPC(458,PPA,"E",IEN)) D 134 . S IENS=","_PPA_"," 135 . S PRSFDA(458.01,"?+1"_IENS,.01)=IEN 136 . D UPDATE^DIE("","PRSFDA") 137 ; 138 ; Set LD AUDIT record into #458.1105 139 S IENS=","_IEN_IENS 140 K PRSFDA 141 S PRSFDA(458.1105,"?+1"_IENS,.01)=LDA 142 S PRSFDA(458.1105,"?+1"_IENS,1)=TIME 143 S PRSFDA(458.1105,"?+1"_IENS,2)=$O(^VA(200,"B","CENTRAL PAID",0)) 144 S PRSFDA(458.1105,"?+1"_IENS,3)=TYPE 145 D UPDATE^DIE("","PRSFDA") 146 ; 147 ; Central PAID only sends LD fields that have changed. Run check on 148 ; percentages and delete all LD fields in #450 after 99% has been reached 149 S TLDPER=0 150 F I=0:1:3 S TLDPER=TLDPER+$P(LDFNL,U,I*4+2) Q:TLDPER'<.99 151 S J=(I+1)*4+1 ; Set counter for LDINIT 152 F J=J:1:16 S $P(LDINIT,U,J)="" 153 S I=I+2 ; Adjust counter for deletion of multiples 154 K PRSFDA 155 S DA(1)=IEN 156 F I=I:1:4 D 157 . S DA=I,DIK="^PRSPC("_DA(1)_",""LD""," 158 . D ^DIK 159 ; 160 ; Set LABOR DISTRIBUTION (Multiple-458.11054) 161 S LD=$O(^PRST(458,PPA,"E",IEN,"LDAUD",0)) 162 F PRSLD=0:1:3 D 163 . S J=PRSLD+1 164 . S IENS1="+"_J_","_LD_IENS 165 . ; Don't record empty multiples 166 . Q:$P(LDINIT,U,PRSLD*4+2)="" ; PERCENT 167 . K PRSFDA 168 . S PRSFDA(458.11054,IENS1,.01)=PRSLD+1 169 . S PRSFDA(458.11054,IENS1,1)=$P(LDINIT,U,PRSLD*4+1) ; CODE 170 . S PRSFDA(458.11054,IENS1,2)=$P(LDINIT,U,PRSLD*4+2) ; PERCENT 171 . S PRSFDA(458.11054,IENS1,3)=$P(LDINIT,U,PRSLD*4+3) ; COST CENTER 172 . S PRSFDA(458.11054,IENS1,4)=$P(LDINIT,U,PRSLD*4+4) ; FUND CTRL PT 173 . D UPDATE^DIE("","PRSFDA") 174 K LDINIT,LDFNL 175 Q 1 PRSDSERV ;HISC/MGD-PAID DOWNLOAD MESSAGE SERVER ;09/13/2003 2 ;;4.0;PAID;**6,78,82**;Sep 21, 1995 3 D NOW^%DTC S TIME=% S XMPOS=1 D REC^XMS3 G:XMER'=0 EXIT 4 G:$E(XMRG,1,7)'="****PDH" EXIT 5 ; EMPCNT = # emp in this mail message 6 ; SEQNUM = Mail message sequence number if more than one message 7 S EMPCNT=+$E(XMRG,9,12),SEQNUM=$E(XMRG,13,16),TYPE=$E(XMRG,23) 8 S DATE=$E(XMRG,24,31),STA="",SUB="TMP" 9 I "IEPTD"'[TYPE G EXIT 10 ; Check to see if the message was previously loaded 11 I $D(^PRSD(450.12,"B",XMZ)) G EXIT 12 S MTYPE=$S(TYPE="I":"Initial",TYPE="E":"Edit & Update",TYPE="P":"Payrun",TYPE="T":"Transfer",1:"") 13 D REC^XMS3 G:XMER'=0 EXIT S STA=$E(XMRG,1,3) I STA'?3N G EXIT 14 I TYPE="D" D ^PRSDDL G EXIT ; Process Separation download 15 ; Mark message as received. This info is for the reports sent to the 16 ; PAD mail group. 17 I $D(^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM)) D G EXIT 18 .S ^TMP($J,"PRSD",999)=MTYPE_" message "_SEQNUM_" received." 19 .D SETPRS S MNR="" D PROC^PRSDPROC 20 I $D(^PRSD(450.12,"C",TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM)) G EXIT 21 K DD,DO S DIC="^PRSD(450.12,",DIC(0)="L",X=XMZ D FILE^DICN 22 S PRSDIEN=+Y,$P(^PRSD(450.12,+Y,0),U,2)=TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM 23 S $P(^PRSD(450.12,+Y,0),U,3)="R",$P(^PRSD(450.12,+Y,0),U,4)=TIME 24 S ^PRSD(450.12,"C",TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM,+Y)="" 25 ; Set Lines Per Employee (LPE) for the correct interface 26 SETPRS S LPE=$S(TYPE="I":20,(TYPE="E")!(TYPE="T"):15,TYPE="P":9,1:0) 27 S XMPOS=2 F A=1:1:EMPCNT D SSNLOOP Q:SSN=999999999 28 I $D(^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM)) K ^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM) Q 29 S:SSN'=999999999 $P(^PRSD(450.12,PRSDIEN,0),U,3)="S" 30 EXIT K %,%H,%I,A,AA,AAA,ADDFLG,B,BB,CC,DA,DATA,DATE,DBNAME,DIC,DIK,DINUM 31 K DLAYGO,DLID,E1,E2,EE,ECNT,ECOUNT,EMPCNT,ERRCNT,ERRFLG,ERRID,ERRIEN,SUB 32 K ERRMSG,FLD,FLDNUM,GNUM,GRP,GRPVAL,IEN,II,LPE,LTH,MO,MFLD,MTYPE,MULT 33 K NAME,NODE,NODE459,PIC,PIECE,PIECE459,PP,PP455,PPIEN,PRSD,PRSDIEN,RCD 34 K RTN,RTNNUM,RTYPE,SEQNUM,SSN,SSNLINE,STA,STA450,SUM,TMPIEN,TMPLINE 35 K TIME,TYPE,X,XCNP,XMDUZ,XMSUB,XMTEXT,XMY,Y,YR,XMPOS,XMRG,XMER,XMLOC 36 K XMMG,MNR,PDATE,CDATE,X1,X2 37 REMSB I $D(XMZ) S XMSER="S.PRSD" D REMSBMSG^XMA1C K XMSER 38 Q 39 SSNLOOP D REC^XMS3 40 S SSN=$S(TYPE="I":$P(XMRG,":",2),1:$E(XMRG,4,12)) 41 S SSN=$E("000000000",$L(SSN)+1,9)_SSN 42 ; The last employee in the last MailMan message has a SSN=999999999 43 ; This triggers the software to begin processing the download. 44 I SSN=999999999 D Q 45 .I TYPE="I" K ^XTMP("PRS","ERR") 46 .S ^XTMP("PRS","LSN",TYPE,DATE,STA)=SEQNUM 47 .S:$D(PRSDIEN) $P(^PRSD(450.12,PRSDIEN,0),U,3)="S" H 600 48 .D REMSB S ECNT=0 D START,START,^PRSDERR,^PRSDSTAT S SSN=999999999 49 S (PDATE,CDATE)=$P(TIME,".",1),X1=PDATE,X2=90 D C^%DTC S PDATE=X 50 S ^XTMP("PRS",0)=PDATE_"^"_CDATE 51 K KFLG S XMPOS=XMPOS-1 52 F B=1:1:LPE D REC^XMS3 I (($L(XMRG,":")-1)'=$L(XMRG))!(TYPE="I") S TMPLINE=$E("000",$L(XMPOS)+1,3)_XMPOS,^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,XMZ_"-"_TMPLINE_"-"_B)=XMRG I TYPE="T",B=6 D TRANSCK^PRSDERR 53 I $D(KFLG) K ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN),KFLG 54 Q 55 START ; Process download 56 ; RTYPE is used to determine which series of routines to call to 57 ; process the download 58 S SSN="",RTYPE=$S(TYPE="I":"LD",(TYPE="E")!(TYPE="T"):"EU",TYPE="P":"PR",1:"") 59 F S SSN=$O(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN)) Q:SSN="" D 60 . L +^XTMP("PRS",SUB,DATE,TYPE,STA,SSN):0 61 . I $T D 62 . . S TMPIEN=$O(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,"")) 63 . . I TMPIEN'="" D 64 . . . S RCD=^(TMPIEN),ERRFLG="" 65 . . . D SSN 66 . . . D:ERRFLG'="Y" LDINIT,PROC,PROC2,LDFNL,LDCMP 67 . . . D:ERRFLG="Y" TMPERR D UNL 68 Q 69 ; Piece together the routine name and call the routine 70 PROC S TMPIEN="" F S TMPIEN=$O(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN)) Q:TMPIEN="" S RCD=^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN),RTNNUM=$P(TMPIEN,"-",3) S:$L(RTNNUM)=1 RTNNUM=0_RTNNUM S RTN="^PRSD"_RTYPE_RTNNUM D @RTN 71 Q 72 PROC2 I TYPE="P",PP'="" D ^PRSDCOMP ;Compute calculated fields 73 S NODE=0 F EE=1:1 S NODE=$O(^PRSPC(IEN,NODE)) Q:NODE="" I $D(^PRSPC(IEN,NODE))#2 S DATA=^PRSPC(IEN,NODE) I $L(DATA,U)-1=$L(DATA) K ^PRSPC(IEN,NODE) 74 K ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q 75 TMPERR I TYPE="P",PP="" G TMPERR1 76 S TMPIEN="" F S TMPIEN=$O(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN)) Q:TMPIEN="" S RCD=^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN),^XTMP("PRS","ERR",DATE,TYPE,STA,SSN,TMPIEN)=RCD 77 TMPERR1 K ^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q 78 UNL L -^XTMP("PRS",SUB,DATE,TYPE,STA,SSN) Q 79 SSN I TYPE="P",'$D(^PRSPC("SSN",SSN)) S ERRMSG="SSN "_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_" not found" D ERR Q 80 I TYPE="I" S NAME=$P(RCD,":",4) 81 I (TYPE="E")!(TYPE="T") S NAME=$P(RCD,":",2),DATA=$E(NAME,1,27) I DATA'="" D RTS^PRSDUTIL S NAME=DATA S:TYPE="T" ^TMP($J,"PRS",NAME,SSN)="" 82 I '$D(^PRSPC("SSN",SSN)) D ^PRSDADD K DA,DIE,DR,OLDSSN,VAIEN,VANAME Q:ERRFLG="Y" G SSNOUT 83 S IEN=0,IEN=$O(^PRSPC("SSN",SSN,IEN)) 84 SSNOUT I TYPE="P" D ^PRSDPTYP I PP="" S ERRFLG="Y" Q 85 S ECNT=ECNT+1 86 Q 87 ERR K DD,DO S DIC="^PRSD(450.11,",DIC(0)="L",X=TYPE_"-"_DATE_"-"_STA D FILE^DICN I Y>0 S $P(^PRSD(450.11,+Y,0),U,3)=ERRMSG 88 S ERRFLG="Y" 89 Q 90 LDINIT ; Load Initial Labor Distribution Values 91 S LDINIT=$$LDLOAD() 92 Q 93 LDFNL ; Load Final Labor Distribution Values 94 S LDFNL=$$LDLOAD() 95 Q 96 LDLOAD() ; Retrieve current Labor Distribution Values from #450 97 ; 98 N LD,LDCC,LDCODE,LDFCP,LDPCT,PRSLD 99 S LD="" 100 F PRSLD=1:1:4 D 101 . S LDCODE=$$GET1^DIQ(450.0757,PRSLD_","_IEN,1) 102 . S LDPCT=$$GET1^DIQ(450.0757,PRSLD_","_IEN,2) 103 . S LDCC=$$GET1^DIQ(450.0757,PRSLD_","_IEN,3) 104 . S LDFCP=$$GET1^DIQ(450.0757,PRSLD_","_IEN,4) 105 . S LD=LD_LDCODE_U_LDPCT_U_LDCC_U_LDFCP_U 106 Q LD 107 ; 108 LDCMP ; Compare Initial and Final Labor Distribution for changes 109 ; and update audit trail in #458 if necessary. 110 Q:LDINIT=LDFNL 111 N PPA,I,IENS,IENS1,INDX,J,LDA,PRSFDA,TLDPER 112 ; Get IEN for current Pay Period 113 S PPA=$P($G(^PRST(458,"AD",$P(TIME,".",1))),U,1) 114 Q:PPA="" 115 ; 116 ; Get next multiple number 117 S LDA="A",LDA=$O(^PRST(458,PPA,"E",IEN,"LDAUD",LDA),-1) 118 S LDA=$S(LDA>0:LDA+1,1:1) 119 ; 120 ; Set Audit information into #450 121 S DA=IEN,DIE="^PRSPC(" 122 S DR="755///^S X=$O(^VA(200,""B"",""CENTRAL,PAID"",0))" 123 D ^DIE 124 S DR="755.1///^S X=TYPE" 125 D ^DIE 126 S DR="756///^S X=TIME" 127 D ^DIE 128 ; 129 ; If there is no entry for this employee in the Pay Period, create 130 ; a record for them 131 I '$D(^PRSPC(458,PPA,"E",IEN)) D 132 . S IENS=","_PPA_"," 133 . S PRSFDA(458.01,"?+1"_IENS,.01)=IEN 134 . D UPDATE^DIE("","PRSFDA") 135 ; 136 ; Set LD AUDIT record into #458.1105 137 S IENS=","_IEN_IENS 138 K PRSFDA 139 S PRSFDA(458.1105,"?+1"_IENS,.01)=LDA 140 S PRSFDA(458.1105,"?+1"_IENS,1)=TIME 141 S PRSFDA(458.1105,"?+1"_IENS,2)=$O(^VA(200,"B","CENTRAL PAID",0)) 142 S PRSFDA(458.1105,"?+1"_IENS,3)=TYPE 143 D UPDATE^DIE("","PRSFDA") 144 ; 145 ; Central PAID only sends LD fields that have changed. Run check on 146 ; percentages and delete all LD fields in #450 after 99% has been reached 147 S TLDPER=0 148 F I=0:1:3 S TLDPER=TLDPER+$P(LDFNL,U,I*4+2) Q:TLDPER'<.99 149 S J=(I+1)*4+1 ; Set counter for LDINIT 150 F J=J:1:16 S $P(LDINIT,U,J)="" 151 S I=I+2 ; Adjust counter for deletion of multiples 152 K PRSFDA 153 S DA(1)=IEN 154 F I=I:1:4 D 155 . S DA=I,DIK="^PRSPC("_DA(1)_",""LD""," 156 . D ^DIK 157 ; 158 ; Set LABOR DISTRIBUTION (Multiple-458.11054) 159 S LD=$O(^PRST(458,PPA,"E",IEN,"LDAUD",0)) 160 F PRSLD=0:1:3 D 161 . S J=PRSLD+1 162 . S IENS1="+"_J_","_LD_IENS 163 . ; Don't record empty multiples 164 . Q:$P(LDINIT,U,PRSLD*4+2)="" ; PERCENT 165 . K PRSFDA 166 . S PRSFDA(458.11054,IENS1,.01)=PRSLD+1 167 . S PRSFDA(458.11054,IENS1,1)=$P(LDINIT,U,PRSLD*4+1) ; CODE 168 . S PRSFDA(458.11054,IENS1,2)=$P(LDINIT,U,PRSLD*4+2) ; PERCENT 169 . S PRSFDA(458.11054,IENS1,3)=$P(LDINIT,U,PRSLD*4+3) ; COST CENTER 170 . S PRSFDA(458.11054,IENS1,4)=$P(LDINIT,U,PRSLD*4+4) ; FUND CTRL PT 171 . D UPDATE^DIE("","PRSFDA") 172 K LDINIT,LDFNL 173 Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRSDW450.m
r613 r623 1 PRSDW450 ;HISC/GWB-WRITE PAID EMPLOYEE DATA ;03/14/03 2 ;;4.0;PAID;**2,78,106**;Sep 21, 1995;Build 5 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 WRITE S NODEDD=^DD(450,FIELDN,0) 5 S NODEUTIL=$G(^UTILITY("DIQ1",$J,450,DA,FIELDN,"E")) 6 I CATEGORY="VERIFICATION OF EMPLOYMENT",FIELDN=556 D DSPYTD^PRSDYTD Q:PRTC=0 7 I CATEGORY="BENEFITS",FIELDN=427 D D CHECK Q:PRTC=0 8 .W:TSPYTD'=0 !,"TSP EMP DED YTD",?30,$J($FN(TSPYTD,",",2),14) K TSPYTD 9 I CATEGORY="BENEFITS",FIELDN=232 D D CHECK Q:PRTC=0 10 .W:HBDYTD'=0 !,"HEALTH BENEFITS DEDUCTION YTD",?30,$J($FN(HBDYTD,",",2),14) K HBDYTD 11 I (NODEUTIL="")!(NODEUTIL="NA") K NODEDD,NODEUTIL Q 12 S INTERNAL=^UTILITY("DIQ1",$J,450,DA,FIELDN,"I") 13 S DESC=^UTILITY("DIQ1",$J,450,DA,FIELDN,"E") 14 I CATEGORY="VERIFICATION OF EMPLOYMENT",FIELDN=28,INTERNAL<50 W !,"HOURLY RATE",?30,$J($FN(INTERNAL,",",2),14) D CHECK Q:PRTC=0 S INTERNAL=INTERNAL*2087,DESC=DESC_" X 2087" 15 I $P(NODEDD,U,2)["NJ",+INTERNAL=0 K NODEDD,NODEUTIL Q 16 I PRTC=1 D HDR^PRSDSRS S PRTC="" 17 W !,$P(NODEDD,U,1) 18 I FIELDN>88,FIELDN<116.3 S INTERNAL="",FNM=$P(NODEDD,U,1) D G CHECK 19 .I $D(^PRSP(454,1,"PUC","C",FNM)) S FUIEN=$O(^PRSP(454,1,"PUC","C",FNM,0)),INTERNAL=$P(^PRSP(454,1,"PUC",FUIEN,0),U,1) 20 .I INTERNAL'="",$P(^PRSP(454,1,"PUC",FUIEN,0),U,3)'="" S INTERNAL=INTERNAL_" "_$P(^PRSP(454,1,"PUC",FUIEN,0),U,3) 21 .W ?30,$J(DESC,14),?47,INTERNAL 22 I (FIELDN=349)!(FIELDN=355)!(FIELDN=363)!(FIELDN=369) W ?47,DESC G CHECK 23 I (FIELDN=725)!(FIELDN=731)!(FIELDN=740)!(FIELDN=746) W ?47,DESC G CHECK 24 I FIELDN=565 W ?38,$J(INTERNAL,6,4) G CHECK 25 W ?30,$S($P(NODEDD,U,5)["""$""":$J($FN(INTERNAL,",",2),14),$P(NODEDD,U,2)["NJ":$J(INTERNAL,14,2),$P(NODEDD,U,2)["D":$J(DESC,14),1:$J(INTERNAL,14)) 26 I $P(NODEDD,U,2)'["D",INTERNAL'=DESC D DESC 27 K DESC,INTERNAL,NODEDD,NODEUTIL,FNM,FUIEN 28 CHECK I $E(IOST,1)="C",$Y>(IOSL-4) D PRTC 29 Q 30 PRTC W ! K DIR,DIRUT,DIROUT,DTOUT,DUOUT 31 S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR S PRTC=Y 32 S:$D(DIRUT) PRTC=0 33 Q 34 DESC I $L(DESC)<33 W ?47,DESC Q 35 S COLUMN=47,LGTH=0 36 F L1=1:1 Q:LGTH=$L(DESC)!(LGTH>($L(DESC))) W:$L($P(DESC," ",L1))>(80-COLUMN) ! S:$L($P(DESC," ",L1))>(80-COLUMN) COLUMN=47 W ?COLUMN,$P(DESC," ",L1) S COLUMN=COLUMN+$L($P(DESC," ",L1))+1,LGTH=LGTH+$L($P(DESC," ",L1))+1 37 K COLUMN,LGTH,L1 38 Q 1 PRSDW450 ;HISC/GWB-WRITE PAID EMPLOYEE DATA ;03/14/03 2 ;;4.0;PAID;**2,78**;Sep 21, 1995 3 WRITE S NODEDD=^DD(450,FIELDN,0) 4 S NODEUTIL=$G(^UTILITY("DIQ1",$J,450,DA,FIELDN,"E")) 5 I CATEGORY="VERIFICATION OF EMPLOYMENT",FIELDN=556 D DSPYTD^PRSDYTD Q:PRTC=0 6 I CATEGORY="BENEFITS",FIELDN=427 D D CHECK Q:PRTC=0 7 .W:TSPYTD'=0 !,"TSP EMP DED YTD",?30,$J($FN(TSPYTD,",",2),14) K TSPYTD 8 I CATEGORY="BENEFITS",FIELDN=232 D D CHECK Q:PRTC=0 9 .W:HBDYTD'=0 !,"HEALTH BENEFITS DEDUCTION YTD",?30,$J($FN(HBDYTD,",",2),14) K HBDYTD 10 I (NODEUTIL="")!(NODEUTIL="NA") K NODEDD,NODEUTIL Q 11 S INTERNAL=^UTILITY("DIQ1",$J,450,DA,FIELDN,"I") 12 S DESC=^UTILITY("DIQ1",$J,450,DA,FIELDN,"E") 13 I CATEGORY="VERIFICATION OF EMPLOYMENT",FIELDN=28,INTERNAL<50 W !,"HOURLY RATE",?30,$J($FN(INTERNAL,",",2),14) D CHECK Q:PRTC=0 S INTERNAL=INTERNAL*2087,DESC=DESC_" X 2087" 14 I $P(NODEDD,U,2)["NJ",+INTERNAL=0 K NODEDD,NODEUTIL Q 15 I PRTC=1 D HDR^PRSDSRS S PRTC="" 16 W !,$P(NODEDD,U,1) 17 I FIELDN>88,FIELDN<116.3 S INTERNAL="",FNM=$P(NODEDD,U,1) D G CHECK 18 .I $D(^PRSP(454,1,"PUC","C",FNM)) S FUIEN=$O(^PRSP(454,1,"PUC","C",FNM,0)),INTERNAL=$P(^PRSP(454,1,"PUC",FUIEN,0),U,1) 19 .I INTERNAL'="",$P(^PRSP(454,1,"PUC",FUIEN,0),U,3)'="" S INTERNAL=INTERNAL_" "_$P(^PRSP(454,1,"PUC",FUIEN,0),U,3) 20 .W ?30,$J(DESC,14),?47,INTERNAL 21 I (FIELDN=349)!(FIELDN=355)!(FIELDN=363)!(FIELDN=369) W ?47,DESC G CHECK 22 I (FIELDN=725)!(FIELDN=731)!(FIELDN=740)!(FIELDN=746) W ?47,DESC G CHECK 23 W ?30,$S($P(NODEDD,U,5)["""$""":$J($FN(INTERNAL,",",2),14),$P(NODEDD,U,2)["NJ":$J(INTERNAL,14,2),$P(NODEDD,U,2)["D":$J(DESC,14),1:$J(INTERNAL,14)) 24 I $P(NODEDD,U,2)'["D",INTERNAL'=DESC D DESC 25 K DESC,INTERNAL,NODEDD,NODEUTIL,FNM,FUIEN 26 CHECK I $E(IOST,1)="C",$Y>(IOSL-4) D PRTC 27 Q 28 PRTC W ! K DIR,DIRUT,DIROUT,DTOUT,DUOUT 29 S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR S PRTC=Y 30 S:$D(DIRUT) PRTC=0 31 Q 32 DESC I $L(DESC)<33 W ?47,DESC Q 33 S COLUMN=47,LGTH=0 34 F L1=1:1 Q:LGTH=$L(DESC)!(LGTH>($L(DESC))) W:$L($P(DESC," ",L1))>(80-COLUMN) ! S:$L($P(DESC," ",L1))>(80-COLUMN) COLUMN=47 W ?COLUMN,$P(DESC," ",L1) S COLUMN=COLUMN+$L($P(DESC," ",L1))+1,LGTH=LGTH+$L($P(DESC," ",L1))+1 35 K COLUMN,LGTH,L1 36 Q -
WorldVistAEHR/trunk/r/PAID-PRS/PRSPUT3.m
r613 r623 1 PRSPUT3 ;WOIFO/MGD,JAH - PART TIME PHYSICIAN UTILITIES #1 ;03/23/072 ;;4.0;PAID;**93,112**;Sep 21, 1995;Build 54 3 4 5 6 7 PTP(PRSIEN) 8 9 10 11 12 13 14 15 16 17 18 19 20 AL(PRSIEN,ARRAY,INDEX) 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 GETACCRU(PRSIEN,EOLYD,LDP) 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 GETLOSE(APALHRS,ALBAL,ACCRUAL,MAXOVER) 85 86 87 88 89 GETLDOYR() 90 91 92 93 94 95 96 97 98 GETAPALH(PRSIEN,PPPIN,EOLYD) 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 ESRUPDT(PPI,PRSIEN,DAY) 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 MEMCPP(MIEN) 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 PP8BAMT(PPAMT,PPI,PRSIEN) 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 GET8B(PPI,PRSIEN) 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 CORRECT(PPI,PRSIEN) 231 232 233 234 235 236 237 238 239 240 EXTR8BT(S,T) 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 WKTT(T,TA,WK) 257 258 259 260 261 262 263 264 265 266 267 268 269 270 S CHKLN=$P($T(@(TCH1)+0^PRS8VW2),";;",2)271 272 273 274 275 276 277 278 279 280 281 1 PRSPUT3 ;WOIFO/MGD,JAH - PART TIME PHYSICIAN UTILITIES #1 ;06/15/05 2 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;Utilities for Part Time Physician patch PRS*4.0*93. 6 ; 7 PTP(PRSIEN) ;Check for potential PTP (has a memo on file) 8 ; input PRSIEN = employee IEN (file 450) 9 ; result = 1 or 0, true (1) if employee has any memos on file 10 Q $S($O(^PRST(458.7,"B",PRSIEN,0)):1,1:0) 11 ; 12 ;----------------------------------------------------------------------- 13 ; Display PTP AL info 14 ; Input: PRSIEN - IEN of PT Physician 15 ; ARRAY - Array where leave info is stored. (Optional) If not 16 ; specified, no array is created. 17 ; INDEX - Index to start array. (optional) set to 1 if not spec 18 ; Output: 2 line summary-current AL bal, fut reqs and potential loss. 19 ;----------------------------------------------------------------------- 20 AL(PRSIEN,ARRAY,INDEX) ; 21 Q:'PRSIEN 22 I $G(INDEX)="",($G(ARRAY)'="") D INDEX^PRSPUT1 23 N AINC,ALBAL,ALTBL,APALHRS,EOLYD,LVG,TEXT,X,X1,X2,Y,MAYLOSE,LDPINV 24 ; 25 ; Max Carryover 26 S MAXOVER=240 27 ; 28 ; current AL bal 29 S ALBAL=$P($G(^PRSPC(PRSIEN,"ANNUAL")),U,3) 30 ; 31 ; last day of curr leave yr 32 S EOLYD=$$GETLDOYR() 33 ; 34 ; last day proc from 459 & inverse 35 S LDP=$P($G(^PRST(458,$O(^PRST(458,"AB",$O(^PRST(459,"AB",""),-1),0)),1)),U,14) 36 S LDPINV=9999999-LDP 37 ; 38 ; future al approved (ranges from LastDayProcessed459-EndOfLeaveYear) 39 ; This is an estimate since we count all hrs for reqs that begin in 40 ; the current yr but cross into next 41 S APALHRS=$$GETAPALH(PRSIEN,LDPINV,EOLYD) 42 ; 43 ; accrual from last pp proc to EOY 44 S ACCRUAL=$$GETACCRU(PRSIEN,EOLYD,LDP) 45 ; 46 ; potential loss 47 S MAYLOSE=$$GETLOSE(APALHRS,ALBAL,ACCRUAL,MAXOVER) 48 ; 49 ; Display 50 S TEXT="" 51 D A1^PRSPUT1 ; Blank line 52 S TEXT="AL Bal: "_$J(ALBAL,6,2) 53 S $E(TEXT,17)="",TEXT=TEXT_"Approved future AL thru Leave Year: " 54 S TEXT=TEXT_$J(APALHRS,6,2) 55 S $E(TEXT,60)="",TEXT=TEXT_"Max carryover: "_MAXOVER 56 D A1^PRSPUT1 ; Line #1 57 S Y=EOLYD 58 D DD^%DT 59 S TEXT="Potential AL hours to be lost by "_Y_" excluding Approved AL: " 60 S TEXT=TEXT_MAYLOSE 61 D A1^PRSPUT1 ; Line #2 62 K INDEX 63 Q 64 ; 65 GETACCRU(PRSIEN,EOLYD,LDP) ; Calculate AL accrucal from last day of 66 ; pp processed in 459 (LDP) to end of leave year (EOLYD) 67 ; 68 N CO,LVG,NH,DB,AINC,X1,X2,INC 69 ; 70 S C0=$G(^PRSPC(PRSIEN,0)),LVG=$P(C0,"^",15),NH=+$P(C0,"^",16) 71 S DB=$P(C0,"^",10),AINC="" 72 Q:LVG'?1N!("123"'[LVG) 0 73 I LVG=1 D ; Leave Group 1 74 . S AINC=$S(DB=1:4,1:NH+AINC/20\1) 75 I LVG=2 D ; Leave Group 2 76 . S AINC=$S(DB=1:6,1:NH+AINC/13\1) 77 I LVG=3 D ; Leave Group 3 78 . S AINC=$S(DB=1:8,1:NH+AINC/10\1) 79 S X1=EOLYD,X2=LDP 80 D ^%DTC 81 S INC=X+13\14*AINC 82 Q INC 83 ; 84 GETLOSE(APALHRS,ALBAL,ACCRUAL,MAXOVER) ; Calculate potential hours to be lost 85 N ALTBL 86 S ALTBL=ALBAL+ACCRUAL-MAXOVER-APALHRS 87 Q $S(ALTBL<0:0,1:ALTBL) 88 ; 89 GETLDOYR() ; Calculate last day of the last pp of current year (EOLY) 90 N X,I,X1,X2,NEXTYR,PRSYRDT 91 S PRSYRDT=$P($T(DAT^PRSAPPU),";;",2) 92 F I=1:1 S NEXTYR=$P(PRSYRDT,",",I) Q:NEXTYR>DT!(NEXTYR="") 93 I NEXTYR="" Q DT 94 S X1=NEXTYR,X2=-1 95 D C^%DTC 96 Q X 97 ; 98 GETAPALH(PRSIEN,PPPIN,EOLYD) ; Approved AL hrs 99 ; 100 N APALHRS,EOLYDINV,LREND,LRIEN,LRSTRT,LRDATA 101 ; 102 S APALHRS=0 ; COUNTER-APproved Annual Leave HouR 103 S EOLYDINV=9999999-EOLYD 104 ; 105 ; use inverse dt to loop chrono from future requests to recent ones 106 ; Quit when end date hits last proc pp. Don't include canceled & other 107 ; leave type reqs from AD index. 108 ; 109 S LREND=0 110 F S LREND=$O(^PRST(458.1,"AD",PRSIEN,LREND)) Q:(LREND'>0)!(LREND>PPPIN) D 111 . S LRIEN=0 112 . F S LRIEN=$O(^PRST(458.1,"AD",PRSIEN,LREND,LRIEN)) Q:LRIEN'>0 D 113 . . S LRSTRT=^PRST(458.1,"AD",PRSIEN,LREND,LRIEN) 114 . . S LRSTRT=9999999-LRSTRT 115 . . ; 116 . . ; skip if lv doesn't start in range-last pp proc to EOLY 117 . . Q:LRSTRT'<PPPIN!(LRSTRT'>EOLYDINV) 118 . . ; skip if not AL or App 119 . . S LRDATA=$G(^PRST(458.1,LRIEN,0)) 120 . . Q:$P(LRDATA,U,7)'="AL"!($P(LRDATA,U,9)'="A") 121 . . S APALHRS=APALHRS+$P(LRDATA,U,15) 122 Q APALHRS 123 ; 124 ;----------------------------------------------------------------------- 125 ; Utility updates ESR Status and autopost any holidays 126 ; 127 ; Input: 128 ; PPI - The internal entry number of the PP 129 ; PRSIEN - The internal entry number of the PT Phy 130 ; DAY - (optional) If passed in the specific date (1-14) that 131 ; needs to be updated. If a specific date is not 132 ; passed in all 14 days will be reviewed and updated 133 ; as necessary. 134 ; 135 ; HOL and PDT need to be set by calling ^PRSAPPH prior to making this 136 ; call. 137 ; 138 ESRUPDT(PPI,PRSIEN,DAY) ; 139 ; 140 N END,HTOUR,IENS,MT,PRSFDA,START,STATUS,STOP,TOUR 141 S DAY=$G(DAY,"") 142 S START=$S(DAY:DAY,1:1) 143 S END=$S(DAY:DAY,1:14) 144 F DAY=START:1:END D 145 . S TOUR=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,0)),U,2) 146 . S STATUS=$S(TOUR>1:1,1:6) 147 . S IENS=DAY_","_PRSIEN_","_PPI_"," 148 . K PRSFDA 149 . S PRSFDA(458.02,IENS,146)=STATUS 150 . I $D(HOL($P(PDT,U,DAY))) D 151 . . S HTOUR=$G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,1)) 152 . . Q:HTOUR="" 153 . . S MT=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,0)),U,2) 154 . . S MT=$P($G(^PRST(457.1,MT,0)),U,3) 155 . . F I=0:1:6 Q:$P(HTOUR,U,(3*I)+1)="" D 156 . . . S START=$P(HTOUR,U,(3*I)+1),STOP=$P(HTOUR,U,(3*I)+2) 157 . . . S PRSFDA(458.02,IENS,110+(5*I))=START 158 . . . S PRSFDA(458.02,IENS,111+(5*I))=STOP 159 . . . S PRSFDA(458.02,IENS,112+(5*I))="HX" 160 . . S PRSFDA(458.02,IENS,146)=4 ; ESR DAILY STATUS = SIGNED 161 . . S PRSFDA(458.02,IENS,101)="" ; Reset timecard status to unposted. 162 . . S PRSFDA(458.02,IENS,114)=MT ; Meal time for 1st segment 163 . . S PRSFDA(458.02,IENS,147)=$$NOW^XLFDT() ; Date/Time stamp 164 . . S PRSFDA(458.02,IENS,149)=4 ; ESR Signed by Holiday 165 . D UPDATE^DIE("","PRSFDA","IENS"),MSG^DIALOG() 166 Q 167 ; 168 MEMCPP(MIEN) ; Memo Certified PP 169 ; This utility determine the last certified PP and the number of 170 ; certified PPs for a given memo. 171 ; input 172 ; MIEN - internal entry number of a memo in file 458.7 173 ; returns a string value 174 ; = last certified PP (external value)^number of certified PPs 175 ; example "05-01^3" 176 ; 177 N LASTPP,MPPIEN,PPC,PRSX 178 I '$G(MIEN) Q "^" 179 ; 180 S LASTPP="" ; last PP 181 S PPC=0 ; pp counter 182 ; loop thru PPs in memo 183 S MPPIEN=0 F S MPPIEN=$O(^PRST(458.7,MIEN,9,MPPIEN)) Q:'MPPIEN D 184 . S PRSX=$G(^PRST(458.7,MIEN,9,MPPIEN,0)) 185 . Q:$P(PRSX,U,2)="" ; REG HOURS is null so PP never certified 186 . S LASTPP=$P(PRSX,U,1) 187 . S PPC=PPC+1 188 ; 189 Q LASTPP_"^"_PPC 190 ; 191 PP8BAMT(PPAMT,PPI,PRSIEN) ; array TIMEAMTS passed by reference 192 ; subscripted w/ types of time CODE and type of time activity 193 ; from PRS8VW2 table. This routine sets each node of TIMEAMTS array 194 ; to the total hours (week one and two) in the pp 195 ; for that type of time activity. 196 ; 197 ; SAMPLE CALL: 198 ; S TAMTS("WP","Leave Without Pay")="" D PP8BTOT(.TAMTS,PPI,PRSIEN) 199 ; 200 ; SAMPLE RETURN ARRAY 201 ; TAMTS("WP","Leave Without Pay")=12.5 202 ; 203 N TT,STR8B,TC,TA,WK1CD,WK2CD,AMT1,AMT2 204 S STR8B=$$GET8B(PPI,PRSIEN) 205 S TC="" 206 F S TC=$O(PPAMT(TC)) Q:TC="" D 207 . S TA="" 208 . F S TA=$O(PPAMT(TC,TA)) Q:TA="" D 209 .. S WK1CD=$$WKTT(TC,TA,1) 210 .. S WK2CD=$$WKTT(TC,TA,2) 211 .. S AMT1=$$EXTR8BT(STR8B,WK1CD) 212 .. S AMT2=$$EXTR8BT(STR8B,WK2CD) 213 .. S PPAMT(TC,TA)=AMT1+AMT2 214 Q 215 GET8B(PPI,PRSIEN) ; get 8b from 5 node unless corrected timecard 216 ; has been done then we need to recompute 8B 217 N S8B 218 I $$CORRECT(PPI,PRSIEN) D 219 . N DFN,PY,VAL 220 .; new variables used BY callers to this API because the decomp 221 .; kills everything in its path. 222 . N QT,PP,%,C0,CNT,CT,D,DAY,HDR,I,K,MEAL,SSN,ST,TT,TYP,X,X1,Y,Y1,Z,ML,Z0,Z1 223 . S DFN=PRSIEN 224 . S PY=PPI 225 . D ONE^PRS8 226 . S S8B=$E($G(VAL),33,999) 227 E D 228 . S S8B=$E($G(^PRST(458,PPI,"E",PRSIEN,5)),33,999) 229 Q S8B 230 CORRECT(PPI,PRSIEN) ; return true if any corrected timecards exist for 231 ;this emp's pp that were approved by the final level supr apprl 232 N CORRECT,STATUS,TCD 233 S CORRECT=0 234 Q:($G(PPI)'>0)!($G(PRSIEN)'>0) 235 S TCD=0 236 F S TCD=$O(^PRST(458,PPI,"E",PRSIEN,"X",TCD)) Q:TCD'>0!(CORRECT) D 237 . S STATUS=$P($G(^PRST(458,PPI,"E",PRSIEN,"X",TCD,0)),U,5) 238 . I STATUS="P"!(STATUS="S") S CORRECT=1 239 Q CORRECT 240 EXTR8BT(S,T) ; EXTRACT THE 8B TYPE OF TIME FROM THE STUB AND RETURN THE 241 ; AMOUNT OF TIME FROM WEEK ONE AND TWO FOR THIS TYPE OF TIME 242 ; INPUT: S-8B STUB 243 ; T-TYPE OF TIME TO FIND ^ LENGTH OF DATA IN 8B 244 N AMT,LEN,POS,QH,HRS 245 S AMT="0.0" 246 S POS=$F(S,$P(T,U)) 247 I POS D 248 . S LEN=$P(T,U,2) 249 . S AMT=$E(S,POS,POS-1+LEN) 250 . S HRS=+$E(AMT,1,LEN-1) 251 . S QH=+$E(AMT,LEN,LEN) 252 . S QH=$S(QH=1:".25",QH=2:".5",QH=3:".75",1:".0") 253 . S AMT=HRS_QH 254 Q AMT 255 ; 256 WKTT(T,TA,WK) ; GET 8B STRING TIMECODE FOR WEEK ONE OR TWO AND LENGTH OF 257 ; THE DATA IN THE 8B STRING 258 ; Input: 259 ; T- type of time code from file 457.3 260 ; TA-time activity from the table in PRS8VW2 (e.g. Leave Without Pay) 261 ; WK-1 or 2 for the desired timecode week 262 ; 263 S WK=$S($G(WK)=2:2,1:1) 264 Q:$G(T)="" 265 N TCH1,TTEXT,CHKLN,I,FOUND,E,TTABLE,CHUNK,TABLEI,WKTTCODE 266 S FOUND=0 267 ; 268 S TCH1=$E(T,1,1) 269 D E2^PRS8VW 270 S CHKLN=$P($T(@(TCH1)+0^PRS8VW1),";;",2) 271 F I=1:1:$L(CHKLN,"^") D Q:FOUND 272 . S CHUNK=$P(CHKLN,U,I) 273 . S TABLEI=$P(CHUNK,":",2) 274 . S WKTTCODE=TCH1_$P(CHUNK,":") 275 . S TTABLE=$P($T(TYP+TABLEI^PRS8VW2),";;",2) 276 . I TTABLE=TA,$F(E(WK),WKTTCODE) D 277 .. S FOUND=1 278 ..; When found in PRS8VW2 table return code and length 279 .. S WKTTCODE=WKTTCODE_U_$P(CHUNK,":",3) 280 I 'FOUND S WKTTCODE=0 281 Q WKTTCODE
Note:
See TracChangeset
for help on using the changeset viewer.
