PRSACED5 ; HISC/REL/FPT/PLT-T&A Cross-Edits ;11/20/06 12:53
;;4.0;PAID;**102,112**;Sep 21, 1995;Build 54
;;Per VHA Directive 2004-038, this routine should not be modified.
;
G D1:DUT=1,D2:DUT=2,D3:DUT=3 Q
D1 G:+NOR N1
I "045"'[LVG S ERR=151 D ERR^PRSACED
I "LJXWPQY"'[PAY S ERR=152 D ERR^PRSACED
Q:"45"'[LVG
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)
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)
I E(1)>7!(E(2)>7) S ERR=159 D ERR^PRSACED
I LVG=5 I E(1)+E(2)+$P(C1,"^",30)>14 S ERR=160 D ERR^PRSACED
Q
;36/40 employee has 8b normal hour = 72
N1 I '(NOR=48!(NOR=72)&("KM"[PAY)),NOR<80 S ERR=153 D ERR^PRSACED
I '(PAY="W"&(LVG=0)),"123"'[LVG S ERR=154 D ERR^PRSACED
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)
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)
F K=2,25 S X=$P(C1,"^",K),E(2)=E(2)+$E(X,1,2)+($E(X,3)*.25)
G:NOR=80 N2
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
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
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
Q
N2 I CWK'="C",E(1)>45!(E(2)>45) S ERR=165 D ERR^PRSACED
I CWK="C",E(1)+E(2)>80 S ERR=166 D ERR^PRSACED
Q
;exclude 9/3 month employee
D2 I PAY'="M"!(FLSA'="E"),NOR<1!(NOR>79) S ERR=155 D ERR^PRSACED
I "0123"'[LVG S ERR=156 D ERR^PRSACED
I "ABCGLMNRU0123456789PQT"'[PAY S ERR=157 D ERR^PRSACED
;exclude 9/3 month employee
QUIT:"123"'[LVG!(NOR="80"&(PAY="M"))
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)
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)
F K=2,25 S X=$P(C1,"^",K),E(2)=E(2)+$E(X,1,2)+($E(X,3)*.25)
S X=$P(C0,"^",42),X=$E(X,1,2)+($E(X,3)*.25) I E(1)>X S ERR=164 D ERR^PRSACED
S X=$P(C1,"^",24),X=$E(X,1,2)+($E(X,3)*.25) I E(2)>X S ERR=164 D ERR^PRSACED
Q:CWK'="C"
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)
F K=11,12,13 S X=$P(C1,"^",K),E(1)=E(1)+$E(X,1,2)+($E(X,3)*.25)
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)
F K=16,51 S X=$P(C0,"^",K),E(2)=E(2)-$E(X,1,2)-($E(X,3)*.25)
F K=3,24 S X=$P(C1,"^",K),E(2)=E(2)+$E(X,1,2)+($E(X,3)*.25)
; The following line was commented out for DFAS Release #1 per Angela Curtiss instructions.
; I E(1),E(2)<80 S ERR=170 D ERR^PRSACED -
Q
D3 I +NOR!LVG S ERR=158 D ERR^PRSACED
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSACED5 2529 printed Sep 23, 2025@19:59:42 Page 2
PRSACED5 ; HISC/REL/FPT/PLT-T&A Cross-Edits ;11/20/06 12:53
+1 ;;4.0;PAID;**102,112**;Sep 21, 1995;Build 54
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 if DUT=1
GOTO D1
if DUT=2
GOTO D2
if DUT=3
GOTO D3
QUIT
D1 if +NOR
GOTO N1
+1 IF "045"'[LVG
SET ERR=151
DO ERR^PRSACED
+2 IF "LJXWPQY"'[PAY
SET ERR=152
DO ERR^PRSACED
+3 if "45"'[LVG
QUIT
+4 SET E(1)=0
FOR K=13:1:18
SET X=$PIECE(C0,"^",K)
SET E(1)=E(1)+$EXTRACT(X,1,2)+($EXTRACT(X,3)*.25)
+5 SET E(2)=0
FOR K=48:1:53
SET X=$PIECE(C0,"^",K)
SET E(2)=E(2)+$EXTRACT(X,1,2)+($EXTRACT(X,3)*.25)
+6 IF E(1)>7!(E(2)>7)
SET ERR=159
DO ERR^PRSACED
+7 IF LVG=5
IF E(1)+E(2)+$PIECE(C1,"^",30)>14
SET ERR=160
DO ERR^PRSACED
+8 QUIT
+9 ;36/40 employee has 8b normal hour = 72
N1 IF '(NOR=48!(NOR=72)&("KM"[PAY))
IF NOR<80
SET ERR=153
DO ERR^PRSACED
+1 IF '(PAY="W"&(LVG=0))
IF "123"'[LVG
SET ERR=154
DO ERR^PRSACED
+2 SET E(1)=0
FOR K=13:1:18,20,43
SET X=$PIECE(C0,"^",K)
SET E(1)=E(1)+$EXTRACT(X,1,2)+($EXTRACT(X,3)*.25)
+3 SET E(2)=0
FOR K=48:1:53
SET X=$PIECE(C0,"^",K)
SET E(2)=E(2)+$EXTRACT(X,1,2)+($EXTRACT(X,3)*.25)
+4 FOR K=2,25
SET X=$PIECE(C1,"^",K)
SET E(2)=E(2)+$EXTRACT(X,1,2)+($EXTRACT(X,3)*.25)
+5 if NOR=80
GOTO N2
+6 IF $PIECE(C0,"^",42)+$PIECE(C1,"^",24)=0
SET MX=NOR/2
IF E(1)>MX!(E(2)>MX)
SET ERR=161
DO ERR^PRSACED
+7 SET X=$PIECE(C0,"^",42)
IF X
SET X=$EXTRACT(X,1,2)+($EXTRACT(X,3)*.25)
IF E(1)>X
SET ERR=163
DO ERR^PRSACED
+8 SET X=$PIECE(C1,"^",24)
IF X
SET X=$EXTRACT(X,1,2)+($EXTRACT(X,3)*.25)
IF E(2)>X
SET ERR=163
DO ERR^PRSACED
+9 QUIT
N2 IF CWK'="C"
IF E(1)>45!(E(2)>45)
SET ERR=165
DO ERR^PRSACED
+1 IF CWK="C"
IF E(1)+E(2)>80
SET ERR=166
DO ERR^PRSACED
+2 QUIT
+3 ;exclude 9/3 month employee
D2 IF PAY'="M"!(FLSA'="E")
IF NOR<1!(NOR>79)
SET ERR=155
DO ERR^PRSACED
+1 IF "0123"'[LVG
SET ERR=156
DO ERR^PRSACED
+2 IF "ABCGLMNRU0123456789PQT"'[PAY
SET ERR=157
DO ERR^PRSACED
+3 ;exclude 9/3 month employee
+4 if "123"'[LVG!(NOR="80"&(PAY="M"))
QUIT
+5 SET E(1)=0
FOR K=13:1:18,20,43
SET X=$PIECE(C0,"^",K)
SET E(1)=E(1)+$EXTRACT(X,1,2)+($EXTRACT(X,3)*.25)
+6 SET E(2)=0
FOR K=48:1:53
SET X=$PIECE(C0,"^",K)
SET E(2)=E(2)+$EXTRACT(X,1,2)+($EXTRACT(X,3)*.25)
+7 FOR K=2,25
SET X=$PIECE(C1,"^",K)
SET E(2)=E(2)+$EXTRACT(X,1,2)+($EXTRACT(X,3)*.25)
+8 SET X=$PIECE(C0,"^",42)
SET X=$EXTRACT(X,1,2)+($EXTRACT(X,3)*.25)
IF E(1)>X
SET ERR=164
DO ERR^PRSACED
+9 SET X=$PIECE(C1,"^",24)
SET X=$EXTRACT(X,1,2)+($EXTRACT(X,3)*.25)
IF E(2)>X
SET ERR=164
DO ERR^PRSACED
+10 if CWK'="C"
QUIT
+11 SET E(1)=0
FOR K=29,30,31
SET X=$PIECE(C0,"^",K)
SET E(1)=E(1)+$EXTRACT(X,1,2)+($EXTRACT(X,3)*.25)
+12 FOR K=11,12,13
SET X=$PIECE(C1,"^",K)
SET E(1)=E(1)+$EXTRACT(X,1,2)+($EXTRACT(X,3)*.25)
+13 SET E(2)=0
FOR K=21,42
SET X=$PIECE(C0,"^",K)
SET E(2)=E(2)+$EXTRACT(X,1,2)+($EXTRACT(X,3)*.25)
+14 FOR K=16,51
SET X=$PIECE(C0,"^",K)
SET E(2)=E(2)-$EXTRACT(X,1,2)-($EXTRACT(X,3)*.25)
+15 FOR K=3,24
SET X=$PIECE(C1,"^",K)
SET E(2)=E(2)+$EXTRACT(X,1,2)+($EXTRACT(X,3)*.25)
+16 ; The following line was commented out for DFAS Release #1 per Angela Curtiss instructions.
+17 ; I E(1),E(2)<80 S ERR=170 D ERR^PRSACED -
+18 QUIT
D3 IF +NOR!LVG
SET ERR=158
DO ERR^PRSACED
+1 QUIT
