PRSASC3 ; HISC/REL,WOIFO/JAH - Supervisor Approve Prior PP Actions ;2/16/05
;;4.0;PAID;**6,93,132**;Sep 21, 1995;Build 13
;;Per VHA Directive 2004-038, this routine should not be modified.
DIS ; Display PP Action
N IFN
S Z=$G(^PRST(458,PPI,"E",DFN,"X",AUN,0)),TYP=$P(Z,"^",4) D DT:TYP="T",DV:TYP="V",DH:TYP="H"
I $D(^PRST(458,PPI,"E",DFN,"X",AUN,7)) W !!,"Change Remarks: ",^(7)
Q
DT ; Display Time
S DAY=$P($G(^PRST(458,PPI,"E",DFN,"X",AUN,1)),"^",1) Q:'DAY
W !!,?28,"Prior Pay Period Change"
W !,?7,"Date",?17,"TW Scheduled Tour",?46,"Tour Exceptions"
W !?3,"------------------------------------------------------------------------"
S DTE=$P($G(^PRST(458,PPI,2)),"^",DAY) S IFN=AUN+1 D GET^PRSAPPP D F0^PRSAPPQ Q
DV ; Display VCS/Fee changes
S PAYP=$P($G(^PRSPC(DFN,0)),"^",21)
S DTE=$P($G(^PRST(458,PPI,2)),"^",1)
W !!,$S(PAYP="F":"Fee Basis",1:"VCS Sales")," Adjustment for Pay Period beginning ",DTE
S IFN=AUN+1 D GET^PRSAPPP S Z=AUR(1) D VCS^PRSAPPQ Q
DH ; Display ED changes
S DTE=$P($G(^PRST(458,PPI,2)),"^",1)
W !!,"Envir. Differential Adjustment for Pay Period beginning ",DTE
S IFN=AUN+1 D GET^PRSAPPP S Z=AUR(1) D ED^PRSAPPQ Q
APP ; Approve PP Action
S DFN=$P(AP(5,NX),"^",1),ACT=$P(AP(5,NX),"^",2),PPI=$P(NX,"~",2),AUN=$P(NX,"~",3)
S Z=$G(^PRST(458,PPI,"E",DFN,"X",AUN,0)),$P(^(0),"^",5)=ACT
K ^PRST(458,NOD,DFN,PPI,AUN) S:"AS"[ACT ^PRST(458,"AX"_ACT,DFN,PPI,AUN)=""
; if second level approver then recalculate PTP's Hours bank
I NOD="AXS" D
. S $P(^PRST(458,PPI,"E",DFN,"X",AUN,0),"^",8,9)=DUZ_"^"_NOW
. D PTP^PRSASR1(DFN,PPI)
I NOD="AXR" S $P(^PRST(458,PPI,"E",DFN,"X",AUN,0),"^",10,11)=DUZ_"^"_NOW
S TYP=$P(Z,"^",4) G AT:TYP="T",AV:TYP="V",AH:TYP="H"
Q
AT ; Approve time
Q:"DX"'[ACT
; If disapproved, un-do
S DAY=$P($G(^PRST(458,PPI,"E",DFN,"X",AUN,1)),"^",1) Q:'DAY
S IFN=AUN+1 D GET^PRSAPPP
I AUC N L2 S L2=0 F L1=0,1,2,10,3,4,8 S L2=L2+1 S Z=$G(^PRST(458,PPI,"E",DFN,"X",AUN,$P("1^2^3^4^5^6^8",U,L2))) K ^PRST(458,PPI,"E",DFN,"D",DAY,L1) I Z'="" S ^(L1)=Z
;if PTP corrected timecard is disapproved then call hrs bank API
;since the unapproved work node for the corrected tc may have been
;used in a call to the hours bank. Call will quit if not PTP w/memo
D PTP^PRSASR1(DFN,PPI)
Q
AV ; Approve VCS/Fee Changes
I "DX"'[ACT S:ACT="S" $P(^PRST(458,PPI,"E",DFN,2),"^",17,18)=DUZ_"^"_NOW Q
; If disapproved, un-do
S IFN=AUN+1 D GET^PRSAPPP
I AUC S Z=$G(^PRST(458,PPI,"E",DFN,"X",AUN,1)) K ^PRST(458,PPI,"E",DFN,2) S:Z'="" ^(2)=Z
Q
AH ; Approve ED Changes
Q:"DX"'[ACT
; if disapproved, un-do
S IFN=AUN+1 D GET^PRSAPPP
I AUC S Z=$G(^PRST(458,PPI,"E",DFN,"X",AUN,1)) K ^PRST(458,PPI,"E",DFN,4) S:Z'="" ^(4)=Z
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSASC3 2731 printed Oct 16, 2024@18:25:04 Page 2
PRSASC3 ; HISC/REL,WOIFO/JAH - Supervisor Approve Prior PP Actions ;2/16/05
+1 ;;4.0;PAID;**6,93,132**;Sep 21, 1995;Build 13
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
DIS ; Display PP Action
+1 NEW IFN
+2 SET Z=$GET(^PRST(458,PPI,"E",DFN,"X",AUN,0))
SET TYP=$PIECE(Z,"^",4)
if TYP="T"
DO DT
if TYP="V"
DO DV
if TYP="H"
DO DH
+3 IF $DATA(^PRST(458,PPI,"E",DFN,"X",AUN,7))
WRITE !!,"Change Remarks: ",^(7)
+4 QUIT
DT ; Display Time
+1 SET DAY=$PIECE($GET(^PRST(458,PPI,"E",DFN,"X",AUN,1)),"^",1)
if 'DAY
QUIT
+2 WRITE !!,?28,"Prior Pay Period Change"
+3 WRITE !,?7,"Date",?17,"TW Scheduled Tour",?46,"Tour Exceptions"
+4 WRITE !?3,"------------------------------------------------------------------------"
+5 SET DTE=$PIECE($GET(^PRST(458,PPI,2)),"^",DAY)
SET IFN=AUN+1
DO GET^PRSAPPP
DO F0^PRSAPPQ
QUIT
DV ; Display VCS/Fee changes
+1 SET PAYP=$PIECE($GET(^PRSPC(DFN,0)),"^",21)
+2 SET DTE=$PIECE($GET(^PRST(458,PPI,2)),"^",1)
+3 WRITE !!,$SELECT(PAYP="F":"Fee Basis",1:"VCS Sales")," Adjustment for Pay Period beginning ",DTE
+4 SET IFN=AUN+1
DO GET^PRSAPPP
SET Z=AUR(1)
DO VCS^PRSAPPQ
QUIT
DH ; Display ED changes
+1 SET DTE=$PIECE($GET(^PRST(458,PPI,2)),"^",1)
+2 WRITE !!,"Envir. Differential Adjustment for Pay Period beginning ",DTE
+3 SET IFN=AUN+1
DO GET^PRSAPPP
SET Z=AUR(1)
DO ED^PRSAPPQ
QUIT
APP ; Approve PP Action
+1 SET DFN=$PIECE(AP(5,NX),"^",1)
SET ACT=$PIECE(AP(5,NX),"^",2)
SET PPI=$PIECE(NX,"~",2)
SET AUN=$PIECE(NX,"~",3)
+2 SET Z=$GET(^PRST(458,PPI,"E",DFN,"X",AUN,0))
SET $PIECE(^(0),"^",5)=ACT
+3 KILL ^PRST(458,NOD,DFN,PPI,AUN)
if "AS"[ACT
SET ^PRST(458,"AX"_ACT,DFN,PPI,AUN)=""
+4 ; if second level approver then recalculate PTP's Hours bank
+5 IF NOD="AXS"
Begin DoDot:1
+6 SET $PIECE(^PRST(458,PPI,"E",DFN,"X",AUN,0),"^",8,9)=DUZ_"^"_NOW
+7 DO PTP^PRSASR1(DFN,PPI)
End DoDot:1
+8 IF NOD="AXR"
SET $PIECE(^PRST(458,PPI,"E",DFN,"X",AUN,0),"^",10,11)=DUZ_"^"_NOW
+9 SET TYP=$PIECE(Z,"^",4)
if TYP="T"
GOTO AT
if TYP="V"
GOTO AV
if TYP="H"
GOTO AH
+10 QUIT
AT ; Approve time
+1 if "DX"'[ACT
QUIT
+2 ; If disapproved, un-do
+3 SET DAY=$PIECE($GET(^PRST(458,PPI,"E",DFN,"X",AUN,1)),"^",1)
if 'DAY
QUIT
+4 SET IFN=AUN+1
DO GET^PRSAPPP
+5 IF AUC
NEW L2
SET L2=0
FOR L1=0,1,2,10,3,4,8
SET L2=L2+1
SET Z=$GET(^PRST(458,PPI,"E",DFN,"X",AUN,$PIECE("1^2^3^4^5^6^8",U,L2)))
KILL ^PRST(458,PPI,"E",DFN,"D",DAY,L1)
IF Z'=""
SET ^(L1)=Z
+6 ;if PTP corrected timecard is disapproved then call hrs bank API
+7 ;since the unapproved work node for the corrected tc may have been
+8 ;used in a call to the hours bank. Call will quit if not PTP w/memo
+9 DO PTP^PRSASR1(DFN,PPI)
+10 QUIT
AV ; Approve VCS/Fee Changes
+1 IF "DX"'[ACT
if ACT="S"
SET $PIECE(^PRST(458,PPI,"E",DFN,2),"^",17,18)=DUZ_"^"_NOW
QUIT
+2 ; If disapproved, un-do
+3 SET IFN=AUN+1
DO GET^PRSAPPP
+4 IF AUC
SET Z=$GET(^PRST(458,PPI,"E",DFN,"X",AUN,1))
KILL ^PRST(458,PPI,"E",DFN,2)
if Z'=""
SET ^(2)=Z
+5 QUIT
AH ; Approve ED Changes
+1 if "DX"'[ACT
QUIT
+2 ; if disapproved, un-do
+3 SET IFN=AUN+1
DO GET^PRSAPPP
+4 IF AUC
SET Z=$GET(^PRST(458,PPI,"E",DFN,"X",AUN,1))
KILL ^PRST(458,PPI,"E",DFN,4)
if Z'=""
SET ^(4)=Z
+5 QUIT
