PRS8UP ;HISC/MRL,JAH/WIRMFO-DECOMPOSITION, UPDATE TOTALS ;7/10/08
;;4.0;PAID;**6,21,30,45,117,132**;Sep 21, 1995;Build 13
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;This routine is used to collect information related to
;weekly activity which is unrelated to actual time, including
;VCS Sales, Environmental Differential, Hazard Pay,
;Lump Sum Data, etc.
;
;Called by Routines: PRS8ST
;
; -- VCS Sales (VC, VS)/Fee Basis (FE)
;
; If there is data (X) on the VCS sales node. (Both VCS sales and
; Fee Basis data is stored on this node). Then we need to check to
; see if the employee's pay plan is F=Fee Basis or U=VCS Sales.
;
;
; If we're dealing w/ previous pay period where an employee
; has changed pay plans, we need to check their pay plan for the
; pay period we are dealing with.
N PAYPDTMP,PPLOLD
S PAYPDTMP=$G(^PRST(458,+PY,0)) ;pay period we're working with.
S PPLOLD=$$OLDPP^PRS8UT(PAYPDTMP,+DFN) ;pay plan from PAYPDTMP.
S PPL=$P($G(^PRSPC(+DFN,0)),"^",21) ;pay plan in master record.
;
;if we find an old pay plan and it's different than the master record
;use the old pay plan to determine VCS or FEE.
I PPLOLD'=0,(PPL'=PPLOLD) S PPL=PPLOLD
;
S X=$G(^PRST(458,+PY,"E",+DFN,2)),(T,T(1),T(2))=0
I PPL'="F",X'="" F I=1:1:14 S V=+$P(X,"^",I),W=$S(I<8:1,1:2),T(W)=T(W)+V
I PPL'="F" F I=1,2 I $D(T(I)) D
.S X1=$P(T(I),".",2)
.S X1=X1_$E("00",0,2-$L(X1)) ;2 numbers for cents (X1)
.S X=+$P(T(I),".",1)
.S X=X_X1 I '+X Q ;no value/don't report
.S $P(WK(I),"^",37)=X
S X=$G(^PRST(458,+PY,"E",+DFN,2))
I PPL="F",X'="" F I=1:1:14 S V=+$P(X,"^",I),T=T+V
I PPL="F",$D(T) D
.S X1=$P(T,".",2)
.S X1=X1_$E("00",0,2-$L(X1))
.S X=+$P(T,".",1)
.S X=X_X1 I '+X Q ;if no value, don't save
.S $P(WK(3),"^",17)=X
K I,PPL,T,V,W,X,X1
;
; -- Environmental Differential (EA, EC)
; -- Hazardous Duty Pay (EB, ED)
;
S X=$G(^PRST(458,+PY,"E",+DFN,4))
F I=1,3,5,7,9,11 S Y=+$P(X,"^",I) D
.I I=1!(I=7) S T=0,W=1+(I=7)
.S Y=$G(^PRST(457.6,+Y,0)) Q:Y=""
.S Y=+$P(Y,"^",3) Q:'Y
.S Y=$E("00",0,2-$L(Y))_Y ;percentage
.S Y(1)=+$P(X,"^",I+1) Q:'Y(1)
.S Y(1)=$E("000",0,3-$L(Y(1)))_Y(1) ;hours
.S T=T+1
.I T<3 S $P(WK(W),"^",36+(T*2))=Y,$P(WK(W),"^",37+(T*2))=Y(1)
.K Y
K I,T,W,X,Y
;
;PRS4*117 CT Trav Earnd Wk 1&2. Convert file decimal to 1/4 hr integer
;
N CTTNODE,CTTW1,CTTW2 S CTTNODE=$G(^PRST(458,+PY,"E",+DFN,6))
S CTTW1=+$P(CTTNODE,U)*100/.25\100
S CTTW2=+$P(CTTNODE,U,2)*100/.25\100
I CTTW1>0 S $P(WK(1),"^",52)=CTTW1
I CTTW2>0 S $P(WK(2),"^",52)=CTTW2
;
;PRS4*117 Move Credit Hours back to the comptime buckets.
; Credit hours still reported under comptime 8B codes but are
; split out during decomp so appropriate rules are applied
; for credit hours. When credit hours 8B code reporting is
; implemented this code should be removed.[credit hours future use]
;
; { begin credit hours move to ct buckets
;
; For week 1 & 2, add credit hours to comptime buckets and zero
; out credit hours buckets.
;
F I=1,2 D
.; add
. S $P(WK(I),U,7)=$P(WK(I),U,7)+$P(WK(I),U,54)
. S $P(WK(I),U,8)=$P(WK(I),U,8)+$P(WK(I),U,55)
.;
.; zero out
. S $P(WK(I),U,54)=""
. S $P(WK(I),U,55)=""
;
; end credit hours move to ct buckets }
;
; PRS*4*132
; Telework hours are stored as actual hours for each day of the
; pay period. Loop through timecard and add up any telework hours
; recorded. Disregard two day tours as telework hours will be
; reported on the week in which the telework started.
;
; Store telework in wk array
;
F I=1,2 D
. N NODE,STW,ATW,MTW
. S (STW(I),ATW(I),MTW(I))=0
. N PRSD
. F PRSD=I*7-6:1:I*7 D
.. S NODE=$G(^PRST(458,+PY,"E",+DFN,"D",PRSD,8))
.. S STW(I)=STW(I)+$P(NODE,U,2)
.. S ATW(I)=ATW(I)+$P(NODE,U,4)
.. S MTW(I)=MTW(I)+$P(NODE,U,3)
. I TYP'["D" D
.. S STW(I)=STW(I)*100/.25\100
.. S ATW(I)=ATW(I)*100/.25\100
.. S MTW(I)=MTW(I)*100/.25\100
. S $P(WK(I),U,56)=STW(I)
. S $P(WK(I),U,57)=ATW(I)
. S $P(WK(I),U,58)=MTW(I)
;
; -- Lump Sum Data (LY, LH, LD, DT)
;
S (X,Y)=$G(^PRST(458,+PY,"E",+DFN,3)),(C,T(1),T(2),T(3))=""
I X'="" F I=2,3,4 S T(I-1)=+$P(X,"^",I) I +T(I-1) S C=1
I C F I=1,2,3 I +T(I) D
.S X1="."_$P(T(I),".",2)\.25 ;turn % into quarter hours
.S X=+$P(T(I),".",1)
.S X=X_+X1 I '+X Q
.S $P(WK(3),"^",4+I)=X
S X=$P(Y,"^",5)
I X?7N S X=$E(X,4,7)_$E(X,2,3),$P(WK(3),"^",8)=X
K I,C,T,X ;clean up/save new T&L as Y (if there)
;
; -- T&L Change (TL)
;
S X=$P(Y,"^") I $L(X)=3 S $P(WK(3),"^",4)=X
K X
;
; -- Optional Withholding Tax (TO)
;
I $P(Y,"^",7)="Y" S $P(WK(3),"^",9)=1
;
; -- Foreign Cola (LA)
;
I $P(Y,"^",8)="Y" S $P(WK(3),"^",10)=2
;
; -- Payment Records (RR)
;
I $P(Y,"^",6)="Y" S $P(WK(3),"^",15)=1
;
; -- Days Worked (DW)
;
I DWK,TYP["I" S $P(WK(3),"^",2)=+DWK
;
; -- Calendar Year Adjustment (CA)
;
; I $D(WPCY) S X=WPCYA S X=(X\4)_"0",$P(WK(3),"^",12)=X K WPCY,WPCYA
I $D(WPCY) D
. S X=WPCYA S:$E(ENT,1,2)["H" X=(X\4) I +X S X=X_"0",$P(WK(3),"^",12)=X
. K WPCY,WPCYA
E S X=+CAMISC I TYP["I",+X S X=X_"0",$P(WK(3),"^",12)=X
;
; -- Days Worked [SF 2806] (CY)
;
I CYA2806'=0 S X=+CYA2806 I (TYP["I"!(TYP["P")),TYP'["B",+X S:"56U"'[$P(C0,"^",21) X=(X\4)_(X#4),$P(WK(3),"^",14)=X
E S X=+CAMISC I TYP["I",+X S:"56U"'[$P(C0,"^",21) X=X_"0",$P(WK(3),"^",14)=X
;
; -- Fire Fighter Normal Hours (FF)
; Sum PT from week 1 with PH from week 2 and copy into FF
;
S $P(WK(3),"^",16)=""
I "Ff"[TYP,(("RC"[PMP)!(NH=448)!(NH>320&(NH(1)'=NH(2)))) D
. F I=1,2 D
.. S X=+$P(WK(I),"^",32)
.. I +X S $P(WK(3),"^",16)=$P(WK(3),"^",16)+X
;
S X=$P(WK(3),"^",16)
I X S $P(WK(3),"^",16)=(X\4)_(X#4) ;quarter hours
K I,X,Y
;
; -- reduce OC by OT where applicable
F I=1,2 I $P(WK(I),"^",35),+$G(CBCK(I)) D
.S $P(WK(I),"^",35)=$P(WK(I),"^",35)-CBCK(I)
;
; -- Military Leave (ML)
;I $G(MILV) S P=11 D DAYS
;
; -- Work Comp [Count COP days] (PC)
I $G(WCMP) S P=13 D DAYS
;
END ; --- all done here
Q
;
DAYS ; --- count total number of days for ML and PC
K NODE S NODE=$P("ML^^CP","^",P-10),(NODE(1),NODE(2))=""
F D=1:1:14 D
.S NODE(1)=NODE(1)_+$G(^TMP($J,"PRS8",D,NODE))
.S NODE(2)=NODE(2)_+$G(^TMP($J,"PRS8",D,"OFF"))
.I $E(NODE(1),D) D SET ;save day in WK(3)
S NODE(1)=$E("0*",1+$G(^TMP($J,"PRS8",0,NODE)))_NODE(1)_$E("0*",1+$G(^TMP($J,"PRS8",15,NODE))) ; assume ML/CP has been counted for past/future ppd
S NODE(2)=+$G(^TMP($J,"PRS8",0,"OFF"))_NODE(2)_+$G(^TMP($J,"PRS8",15,"OFF")) ; set off days for past/future ppd
S F=1 ;F=Forward check needed
F I=2:1:15 S X=$E(NODE(1),I),X1=$E(NODE(2),I) D
.I 'X1 S F=$S(X="*":I,1:-1) ;go forward into next week
.S (C,Q)=0 I X1,X'="*",$E(NODE(1),I-1)="*" F J=F+1:1:15 Q:Q D ; X'="*"" ==> X=1 for NODE="ML" if there is a problem with the counting of ML when the orders specify days off are not to be counted.
..S X=$E(NODE(1),J),X1=$E(NODE(2),J)
..I 'X1,X=0 S Q=1 Q ;worked
..I X="*" S Q=1,C=J-2 Q ;military leave
..I J=15,$E(NODE(1),J+1)="*" S Q=1,C=14 Q ; if last day in ppd, and there is ML/CP on the first day of next ppd, then count this ML/CP
.I C F J=I-1:1:C S D=J D SET ;save off days in pp
Q
;
SET ; --- set WK(3) Node for ML
S $P(WK(3),"^",+P)=$P(WK(3),"^",+P)+1
S NODE(1)=$E(NODE(1),0,D-1)_"*"_$E(NODE(1),D+1,99)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRS8UP 7504 printed Sep 23, 2025@19:59:28 Page 2
PRS8UP ;HISC/MRL,JAH/WIRMFO-DECOMPOSITION, UPDATE TOTALS ;7/10/08
+1 ;;4.0;PAID;**6,21,30,45,117,132**;Sep 21, 1995;Build 13
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;This routine is used to collect information related to
+5 ;weekly activity which is unrelated to actual time, including
+6 ;VCS Sales, Environmental Differential, Hazard Pay,
+7 ;Lump Sum Data, etc.
+8 ;
+9 ;Called by Routines: PRS8ST
+10 ;
+11 ; -- VCS Sales (VC, VS)/Fee Basis (FE)
+12 ;
+13 ; If there is data (X) on the VCS sales node. (Both VCS sales and
+14 ; Fee Basis data is stored on this node). Then we need to check to
+15 ; see if the employee's pay plan is F=Fee Basis or U=VCS Sales.
+16 ;
+17 ;
+18 ; If we're dealing w/ previous pay period where an employee
+19 ; has changed pay plans, we need to check their pay plan for the
+20 ; pay period we are dealing with.
+21 NEW PAYPDTMP,PPLOLD
+22 ;pay period we're working with.
SET PAYPDTMP=$GET(^PRST(458,+PY,0))
+23 ;pay plan from PAYPDTMP.
SET PPLOLD=$$OLDPP^PRS8UT(PAYPDTMP,+DFN)
+24 ;pay plan in master record.
SET PPL=$PIECE($GET(^PRSPC(+DFN,0)),"^",21)
+25 ;
+26 ;if we find an old pay plan and it's different than the master record
+27 ;use the old pay plan to determine VCS or FEE.
+28 IF PPLOLD'=0
IF (PPL'=PPLOLD)
SET PPL=PPLOLD
+29 ;
+30 SET X=$GET(^PRST(458,+PY,"E",+DFN,2))
SET (T,T(1),T(2))=0
+31 IF PPL'="F"
IF X'=""
FOR I=1:1:14
SET V=+$PIECE(X,"^",I)
SET W=$SELECT(I<8:1,1:2)
SET T(W)=T(W)+V
+32 IF PPL'="F"
FOR I=1,2
IF $DATA(T(I))
Begin DoDot:1
+33 SET X1=$PIECE(T(I),".",2)
+34 ;2 numbers for cents (X1)
SET X1=X1_$EXTRACT("00",0,2-$LENGTH(X1))
+35 SET X=+$PIECE(T(I),".",1)
+36 ;no value/don't report
SET X=X_X1
IF '+X
QUIT
+37 SET $PIECE(WK(I),"^",37)=X
End DoDot:1
+38 SET X=$GET(^PRST(458,+PY,"E",+DFN,2))
+39 IF PPL="F"
IF X'=""
FOR I=1:1:14
SET V=+$PIECE(X,"^",I)
SET T=T+V
+40 IF PPL="F"
IF $DATA(T)
Begin DoDot:1
+41 SET X1=$PIECE(T,".",2)
+42 SET X1=X1_$EXTRACT("00",0,2-$LENGTH(X1))
+43 SET X=+$PIECE(T,".",1)
+44 ;if no value, don't save
SET X=X_X1
IF '+X
QUIT
+45 SET $PIECE(WK(3),"^",17)=X
End DoDot:1
+46 KILL I,PPL,T,V,W,X,X1
+47 ;
+48 ; -- Environmental Differential (EA, EC)
+49 ; -- Hazardous Duty Pay (EB, ED)
+50 ;
+51 SET X=$GET(^PRST(458,+PY,"E",+DFN,4))
+52 FOR I=1,3,5,7,9,11
SET Y=+$PIECE(X,"^",I)
Begin DoDot:1
+53 IF I=1!(I=7)
SET T=0
SET W=1+(I=7)
+54 SET Y=$GET(^PRST(457.6,+Y,0))
if Y=""
QUIT
+55 SET Y=+$PIECE(Y,"^",3)
if 'Y
QUIT
+56 ;percentage
SET Y=$EXTRACT("00",0,2-$LENGTH(Y))_Y
+57 SET Y(1)=+$PIECE(X,"^",I+1)
if 'Y(1)
QUIT
+58 ;hours
SET Y(1)=$EXTRACT("000",0,3-$LENGTH(Y(1)))_Y(1)
+59 SET T=T+1
+60 IF T<3
SET $PIECE(WK(W),"^",36+(T*2))=Y
SET $PIECE(WK(W),"^",37+(T*2))=Y(1)
+61 KILL Y
End DoDot:1
+62 KILL I,T,W,X,Y
+63 ;
+64 ;PRS4*117 CT Trav Earnd Wk 1&2. Convert file decimal to 1/4 hr integer
+65 ;
+66 NEW CTTNODE,CTTW1,CTTW2
SET CTTNODE=$GET(^PRST(458,+PY,"E",+DFN,6))
+67 SET CTTW1=+$PIECE(CTTNODE,U)*100/.25\100
+68 SET CTTW2=+$PIECE(CTTNODE,U,2)*100/.25\100
+69 IF CTTW1>0
SET $PIECE(WK(1),"^",52)=CTTW1
+70 IF CTTW2>0
SET $PIECE(WK(2),"^",52)=CTTW2
+71 ;
+72 ;PRS4*117 Move Credit Hours back to the comptime buckets.
+73 ; Credit hours still reported under comptime 8B codes but are
+74 ; split out during decomp so appropriate rules are applied
+75 ; for credit hours. When credit hours 8B code reporting is
+76 ; implemented this code should be removed.[credit hours future use]
+77 ;
+78 ; { begin credit hours move to ct buckets
+79 ;
+80 ; For week 1 & 2, add credit hours to comptime buckets and zero
+81 ; out credit hours buckets.
+82 ;
+83 FOR I=1,2
Begin DoDot:1
+84 ; add
+85 SET $PIECE(WK(I),U,7)=$PIECE(WK(I),U,7)+$PIECE(WK(I),U,54)
+86 SET $PIECE(WK(I),U,8)=$PIECE(WK(I),U,8)+$PIECE(WK(I),U,55)
+87 ;
+88 ; zero out
+89 SET $PIECE(WK(I),U,54)=""
+90 SET $PIECE(WK(I),U,55)=""
End DoDot:1
+91 ;
+92 ; end credit hours move to ct buckets }
+93 ;
+94 ; PRS*4*132
+95 ; Telework hours are stored as actual hours for each day of the
+96 ; pay period. Loop through timecard and add up any telework hours
+97 ; recorded. Disregard two day tours as telework hours will be
+98 ; reported on the week in which the telework started.
+99 ;
+100 ; Store telework in wk array
+101 ;
+102 FOR I=1,2
Begin DoDot:1
+103 NEW NODE,STW,ATW,MTW
+104 SET (STW(I),ATW(I),MTW(I))=0
+105 NEW PRSD
+106 FOR PRSD=I*7-6:1:I*7
Begin DoDot:2
+107 SET NODE=$GET(^PRST(458,+PY,"E",+DFN,"D",PRSD,8))
+108 SET STW(I)=STW(I)+$PIECE(NODE,U,2)
+109 SET ATW(I)=ATW(I)+$PIECE(NODE,U,4)
+110 SET MTW(I)=MTW(I)+$PIECE(NODE,U,3)
End DoDot:2
+111 IF TYP'["D"
Begin DoDot:2
+112 SET STW(I)=STW(I)*100/.25\100
+113 SET ATW(I)=ATW(I)*100/.25\100
+114 SET MTW(I)=MTW(I)*100/.25\100
End DoDot:2
+115 SET $PIECE(WK(I),U,56)=STW(I)
+116 SET $PIECE(WK(I),U,57)=ATW(I)
+117 SET $PIECE(WK(I),U,58)=MTW(I)
End DoDot:1
+118 ;
+119 ; -- Lump Sum Data (LY, LH, LD, DT)
+120 ;
+121 SET (X,Y)=$GET(^PRST(458,+PY,"E",+DFN,3))
SET (C,T(1),T(2),T(3))=""
+122 IF X'=""
FOR I=2,3,4
SET T(I-1)=+$PIECE(X,"^",I)
IF +T(I-1)
SET C=1
+123 IF C
FOR I=1,2,3
IF +T(I)
Begin DoDot:1
+124 ;turn % into quarter hours
SET X1="."_$PIECE(T(I),".",2)\.25
+125 SET X=+$PIECE(T(I),".",1)
+126 SET X=X_+X1
IF '+X
QUIT
+127 SET $PIECE(WK(3),"^",4+I)=X
End DoDot:1
+128 SET X=$PIECE(Y,"^",5)
+129 IF X?7N
SET X=$EXTRACT(X,4,7)_$EXTRACT(X,2,3)
SET $PIECE(WK(3),"^",8)=X
+130 ;clean up/save new T&L as Y (if there)
KILL I,C,T,X
+131 ;
+132 ; -- T&L Change (TL)
+133 ;
+134 SET X=$PIECE(Y,"^")
IF $LENGTH(X)=3
SET $PIECE(WK(3),"^",4)=X
+135 KILL X
+136 ;
+137 ; -- Optional Withholding Tax (TO)
+138 ;
+139 IF $PIECE(Y,"^",7)="Y"
SET $PIECE(WK(3),"^",9)=1
+140 ;
+141 ; -- Foreign Cola (LA)
+142 ;
+143 IF $PIECE(Y,"^",8)="Y"
SET $PIECE(WK(3),"^",10)=2
+144 ;
+145 ; -- Payment Records (RR)
+146 ;
+147 IF $PIECE(Y,"^",6)="Y"
SET $PIECE(WK(3),"^",15)=1
+148 ;
+149 ; -- Days Worked (DW)
+150 ;
+151 IF DWK
IF TYP["I"
SET $PIECE(WK(3),"^",2)=+DWK
+152 ;
+153 ; -- Calendar Year Adjustment (CA)
+154 ;
+155 ; I $D(WPCY) S X=WPCYA S X=(X\4)_"0",$P(WK(3),"^",12)=X K WPCY,WPCYA
+156 IF $DATA(WPCY)
Begin DoDot:1
+157 SET X=WPCYA
if $EXTRACT(ENT,1,2)["H"
SET X=(X\4)
IF +X
SET X=X_"0"
SET $PIECE(WK(3),"^",12)=X
+158 KILL WPCY,WPCYA
End DoDot:1
+159 IF '$TEST
SET X=+CAMISC
IF TYP["I"
IF +X
SET X=X_"0"
SET $PIECE(WK(3),"^",12)=X
+160 ;
+161 ; -- Days Worked [SF 2806] (CY)
+162 ;
+163 IF CYA2806'=0
SET X=+CYA2806
IF (TYP["I"!(TYP["P"))
IF TYP'["B"
IF +X
if "56U"'[$PIECE(C0,"^",21)
SET X=(X\4)_(X#4)
SET $PIECE(WK(3),"^",14)=X
+164 IF '$TEST
SET X=+CAMISC
IF TYP["I"
IF +X
if "56U"'[$PIECE(C0,"^",21)
SET X=X_"0"
SET $PIECE(WK(3),"^",14)=X
+165 ;
+166 ; -- Fire Fighter Normal Hours (FF)
+167 ; Sum PT from week 1 with PH from week 2 and copy into FF
+168 ;
+169 SET $PIECE(WK(3),"^",16)=""
+170 IF "Ff"[TYP
IF (("RC"[PMP)!(NH=448)!(NH>320&(NH(1)'=NH(2))))
Begin DoDot:1
+171 FOR I=1,2
Begin DoDot:2
+172 SET X=+$PIECE(WK(I),"^",32)
+173 IF +X
SET $PIECE(WK(3),"^",16)=$PIECE(WK(3),"^",16)+X
End DoDot:2
End DoDot:1
+174 ;
+175 SET X=$PIECE(WK(3),"^",16)
+176 ;quarter hours
IF X
SET $PIECE(WK(3),"^",16)=(X\4)_(X#4)
+177 KILL I,X,Y
+178 ;
+179 ; -- reduce OC by OT where applicable
+180 FOR I=1,2
IF $PIECE(WK(I),"^",35)
IF +$GET(CBCK(I))
Begin DoDot:1
+181 SET $PIECE(WK(I),"^",35)=$PIECE(WK(I),"^",35)-CBCK(I)
End DoDot:1
+182 ;
+183 ; -- Military Leave (ML)
+184 ;I $G(MILV) S P=11 D DAYS
+185 ;
+186 ; -- Work Comp [Count COP days] (PC)
+187 IF $GET(WCMP)
SET P=13
DO DAYS
+188 ;
END ; --- all done here
+1 QUIT
+2 ;
DAYS ; --- count total number of days for ML and PC
+1 KILL NODE
SET NODE=$PIECE("ML^^CP","^",P-10)
SET (NODE(1),NODE(2))=""
+2 FOR D=1:1:14
Begin DoDot:1
+3 SET NODE(1)=NODE(1)_+$GET(^TMP($JOB,"PRS8",D,NODE))
+4 SET NODE(2)=NODE(2)_+$GET(^TMP($JOB,"PRS8",D,"OFF"))
+5 ;save day in WK(3)
IF $EXTRACT(NODE(1),D)
DO SET
End DoDot:1
+6 ; assume ML/CP has been counted for past/future ppd
SET NODE(1)=$EXTRACT("0*",1+$GET(^TMP($JOB,"PRS8",0,NODE)))_NODE(1)_$EXTRACT("0*",1+$GET(^TMP($JOB,"PRS8",15,NODE)))
+7 ; set off days for past/future ppd
SET NODE(2)=+$GET(^TMP($JOB,"PRS8",0,"OFF"))_NODE(2)_+$GET(^TMP($JOB,"PRS8",15,"OFF"))
+8 ;F=Forward check needed
SET F=1
+9 FOR I=2:1:15
SET X=$EXTRACT(NODE(1),I)
SET X1=$EXTRACT(NODE(2),I)
Begin DoDot:1
+10 ;go forward into next week
IF 'X1
SET F=$SELECT(X="*":I,1:-1)
+11 ; X'="*"" ==> X=1 for NODE="ML" if there is a problem with the counting of ML when the orders specify days off are not to be counted.
SET (C,Q)=0
IF X1
IF X'="*"
IF $EXTRACT(NODE(1),I-1)="*"
FOR J=F+1:1:15
if Q
QUIT
Begin DoDot:2
+12 SET X=$EXTRACT(NODE(1),J)
SET X1=$EXTRACT(NODE(2),J)
+13 ;worked
IF 'X1
IF X=0
SET Q=1
QUIT
+14 ;military leave
IF X="*"
SET Q=1
SET C=J-2
QUIT
+15 ; if last day in ppd, and there is ML/CP on the first day of next ppd, then count this ML/CP
IF J=15
IF $EXTRACT(NODE(1),J+1)="*"
SET Q=1
SET C=14
QUIT
End DoDot:2
+16 ;save off days in pp
IF C
FOR J=I-1:1:C
SET D=J
DO SET
End DoDot:1
+17 QUIT
+18 ;
SET ; --- set WK(3) Node for ML
+1 SET $PIECE(WK(3),"^",+P)=$PIECE(WK(3),"^",+P)+1
+2 SET NODE(1)=$EXTRACT(NODE(1),0,D-1)_"*"_$EXTRACT(NODE(1),D+1,99)
+3 QUIT
