- 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 Feb 18, 2025@23:49:29 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