PRSASC ; HISC/MGD - Supervisor Certification ;01/22/05
;;4.0;PAID;**15,43,93**;Sep 21, 1995;Build 7
;;Per VHA Directive 2004-038, this routine should not be modified.
W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM",!?28,"SUPERVISOR'S APPROVALS"
S PRSTLV=3 D ^PRSAUTL G:TLI<1 EX S QT=0
S LVT=";"_$P(^DD(458.1,6,0),"^",3),LVS=";"_$P(^DD(458.1,8,0),"^",3) K AP
S OTS=";"_$P(^DD(458.2,10,0),"^",3)
S EDS=";"_$P(^DD(458.3,8,0),"^",3)
S NN="",CKS=1 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 D CHK I QT G ES
S CKS=0 F VA2=0:0 S VA2=$O(^PRST(455.5,"ASX",TLE,VA2)) Q:VA2<1 S SSN=$P($G(^VA(200,VA2,1)),"^",9) I SSN'="" S DFN=$O(^PRSPC("SSN",SSN,0)) I DFN,$P($G(^PRSPC(+DFN,0)),"^",8)'=TLE D CHK I QT G ES
ES I '$D(AP) W !!,"No actions to certify." G EX
D ^PRSAES G:'ESOK EX
; Queue approvals
K ZTUCI,ZTDTH,ZTIO,ZTSAVE S ZTRTN="^PRSASC1",ZTREQ="@",ZTIO="",ZTDTH=$H
S ZTSAVE("ZTREQ")="",ZTSAVE("AP(")="",ZTSAVE("ESNAM")="",ZTDESC=$P(XQY0,"^",1)
S ZTSAVE("TLI")="",ZTSAVE("TLE")=""
D ^%ZTLOAD W !,"Approvals Queued",! G EX
CHK ; Check for needed approvals
S HDR=0 I USR=DFN Q:'$D(^XUSEC("PRSA SIGN",DUZ))
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
F DA=0:0 S DA=$O(^PRST(458.1,"AR",DFN,DA)) Q:DA<1 D LV G:QT C1
F DA=0:0 S DA=$O(^PRST(458.2,"AR",DFN,DA)) Q:DA<1 D OT G:QT C1
F DA=0:0 S DA=$O(^PRST(458.3,"AR",DFN,DA)) Q:DA<1 D ED G:QT C1
I $D(^PRST(458,"ATC",DFN)) F PPI=0:0 S PPI=$O(^PRST(458,"ATC",DFN,PPI)) Q:PPI<1 S DA=DFN_"~"_PPI D TC G:QT C1
I $D(^PRST(458,"AXR",DFN)) F PPI=0:0 S PPI=$O(^PRST(458,"AXR",DFN,PPI)) Q:PPI<1 F AUN=0:0 S AUN=$O(^PRST(458,"AXR",DFN,PPI,AUN)) Q:AUN<1 S DA=DFN_"~"_PPI_"~"_AUN D PP G:QT C1
C1 Q
LV ; Leave Request
N PRSX
D:'HDR HDR S (NUM,CNT)=0,PRT=1 W ! D BAL^PRSALVS W ! D LST^PRSALVS
S PRSX=$$OKALVR^PRSPLVU(DA)
I PRSX'>0 D
. W !!,"This leave request can not be approved because the employee is"
. W !,"a part-time physician with a memorandum of service level"
. W !,"expectations, and the leave request may impact a time card for"
. W !,"pay period "_$P($G(^PRST(458,+$P(PRSX,U,2),0)),U)_" that has a status of Payroll."
. W !,"The request can be approved once the time card status changes."
. W !,"(i.e. returned to Timekeeper or transmitted to Austin)",!
S COM="" D LVOK Q:QT
I ACT="A",PRSX'>0 W !,"Approved action can't be accepted at this time" Q
S:ACT'="" AP(1,DA)=DFN_"^"_ACT_"^"_COM
Q
OT ; Overtime/CompTime Request
D:'HDR HDR S (NUM,CNT)=0 W ! D LST^PRSAOTS S COM="" D OK Q:QT I ACT'="" S:ACT="A" ACT="S" S AP(2,DA)=DFN_"^"_ACT_"^"_COM
Q
ED ; Environmental Diff. Request
D:'HDR HDR S (NUM,CNT)=0 W ! D LST^PRSAEDS S COM="" D OK Q:QT S:ACT'="" AP(3,DA)=DFN_"^"_ACT_"^"_COM Q
TC ; Tour Change
D:'HDR HDR D LST^PRSATE1 K COM D OK Q:QT S:ACT'="" AP(4,DA)=DFN_"^"_ACT Q
PP ; Prior Pay Period Change
D:'HDR HDR D DIS^PRSASC3 K COM D OK Q:QT I ACT'="" S:ACT="A" ACT="S" S AP(5,DA)=DFN_"^"_ACT
Q
OK R !!,"Disposition (A=Approve, D=Disapprove, X=Cancel, RETURN to bypass): ",ACT:DTIME S:'$T!(ACT["^") QT=1 Q:QT!(ACT="") S ACT=$TR(ACT,"adx","ADX") I ACT'?1U!("ADX"'[ACT) W *7,!,"Enter A, D or X or Press RETURN to bypass" G OK
Q:'$D(COM) S COM=""
O1 I ACT'="A" R !!,"Comment: ",COM:DTIME S:'$T!(COM["^") QT=1 Q:QT I COM'?.ANP W *7," ??" G O1
I ACT'="A",$L(COM)<4!($L(COM)>60)!(COM?1"?".E) W *7," A 4-60 character comment is required." G O1
Q
;
LVOK N PROMPT,REPROMPT
S PROMPT="Disposition (A=Approve, D=Disapprove, RETURN to bypass): "
S REPROMPT="Enter A or D or Press RETURN to bypass"
W !!,PROMPT
R ACT:DTIME
S:'$T!(ACT["^") QT=1
Q:QT!(ACT="")
S ACT=$TR(ACT,"ad","AD")
I ACT'?1U!("AD"'[ACT) W *7,!,REPROMPT G LVOK
Q:'$D(COM) S COM=""
D O1
Q
;
HDR ; Display Header
W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM",!?28,"SUPERVISOR'S APPROVALS"
S PPE="" D HDR^PRSADP1 S HDR=1 Q
EX G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSASC 4073 printed Oct 16, 2024@18:25:01 Page 2
PRSASC ; HISC/MGD - Supervisor Certification ;01/22/05
+1 ;;4.0;PAID;**15,43,93**;Sep 21, 1995;Build 7
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
WRITE !?26,"VA TIME & ATTENDANCE SYSTEM",!?28,"SUPERVISOR'S APPROVALS"
+4 SET PRSTLV=3
DO ^PRSAUTL
if TLI<1
GOTO EX
SET QT=0
+5 SET LVT=";"_$PIECE(^DD(458.1,6,0),"^",3)
SET LVS=";"_$PIECE(^DD(458.1,8,0),"^",3)
KILL AP
+6 SET OTS=";"_$PIECE(^DD(458.2,10,0),"^",3)
+7 SET EDS=";"_$PIECE(^DD(458.3,8,0),"^",3)
+8 SET NN=""
SET CKS=1
FOR
SET NN=$ORDER(^PRSPC("ATL"_TLE,NN))
if NN=""
QUIT
FOR DFN=0:0
SET DFN=$ORDER(^PRSPC("ATL"_TLE,NN,DFN))
if DFN<1
QUIT
DO CHK
IF QT
GOTO ES
+9 SET CKS=0
FOR VA2=0:0
SET VA2=$ORDER(^PRST(455.5,"ASX",TLE,VA2))
if VA2<1
QUIT
SET SSN=$PIECE($GET(^VA(200,VA2,1)),"^",9)
IF SSN'=""
SET DFN=$ORDER(^PRSPC("SSN",SSN,0))
IF DFN
IF $PIECE($GET(^PRSPC(+DFN,0)),"^",8)'=TLE
DO CHK
IF QT
GOTO ES
ES IF '$DATA(AP)
WRITE !!,"No actions to certify."
GOTO EX
+1 DO ^PRSAES
if 'ESOK
GOTO EX
+2 ; Queue approvals
+3 KILL ZTUCI,ZTDTH,ZTIO,ZTSAVE
SET ZTRTN="^PRSASC1"
SET ZTREQ="@"
SET ZTIO=""
SET ZTDTH=$HOROLOG
+4 SET ZTSAVE("ZTREQ")=""
SET ZTSAVE("AP(")=""
SET ZTSAVE("ESNAM")=""
SET ZTDESC=$PIECE(XQY0,"^",1)
+5 SET ZTSAVE("TLI")=""
SET ZTSAVE("TLE")=""
+6 DO ^%ZTLOAD
WRITE !,"Approvals Queued",!
GOTO EX
CHK ; Check for needed approvals
+1 SET HDR=0
IF USR=DFN
if '$DATA(^XUSEC("PRSA SIGN",DUZ))
QUIT
+2 IF '$TEST
IF CKS
SET SSN=$PIECE($GET(^PRSPC(DFN,0)),"^",9)
IF SSN
SET EDUZ=+$ORDER(^VA(200,"SSN",SSN,0))
IF $DATA(^PRST(455.5,"AS",EDUZ,TLI))
if $PIECE($GET(^PRST(455.5,TLI,"S",EDUZ,0)),"^",2)'=TLE
QUIT
+3 FOR DA=0:0
SET DA=$ORDER(^PRST(458.1,"AR",DFN,DA))
if DA<1
QUIT
DO LV
if QT
GOTO C1
+4 FOR DA=0:0
SET DA=$ORDER(^PRST(458.2,"AR",DFN,DA))
if DA<1
QUIT
DO OT
if QT
GOTO C1
+5 FOR DA=0:0
SET DA=$ORDER(^PRST(458.3,"AR",DFN,DA))
if DA<1
QUIT
DO ED
if QT
GOTO C1
+6 IF $DATA(^PRST(458,"ATC",DFN))
FOR PPI=0:0
SET PPI=$ORDER(^PRST(458,"ATC",DFN,PPI))
if PPI<1
QUIT
SET DA=DFN_"~"_PPI
DO TC
if QT
GOTO C1
+7 IF $DATA(^PRST(458,"AXR",DFN))
FOR PPI=0:0
SET PPI=$ORDER(^PRST(458,"AXR",DFN,PPI))
if PPI<1
QUIT
FOR AUN=0:0
SET AUN=$ORDER(^PRST(458,"AXR",DFN,PPI,AUN))
if AUN<1
QUIT
SET DA=DFN_"~"_PPI_"~"_AUN
DO PP
if QT
GOTO C1
C1 QUIT
LV ; Leave Request
+1 NEW PRSX
+2 if 'HDR
DO HDR
SET (NUM,CNT)=0
SET PRT=1
WRITE !
DO BAL^PRSALVS
WRITE !
DO LST^PRSALVS
+3 SET PRSX=$$OKALVR^PRSPLVU(DA)
+4 IF PRSX'>0
Begin DoDot:1
+5 WRITE !!,"This leave request can not be approved because the employee is"
+6 WRITE !,"a part-time physician with a memorandum of service level"
+7 WRITE !,"expectations, and the leave request may impact a time card for"
+8 WRITE !,"pay period "_$PIECE($GET(^PRST(458,+$PIECE(PRSX,U,2),0)),U)_" that has a status of Payroll."
+9 WRITE !,"The request can be approved once the time card status changes."
+10 WRITE !,"(i.e. returned to Timekeeper or transmitted to Austin)",!
End DoDot:1
+11 SET COM=""
DO LVOK
if QT
QUIT
+12 IF ACT="A"
IF PRSX'>0
WRITE !,"Approved action can't be accepted at this time"
QUIT
+13 if ACT'=""
SET AP(1,DA)=DFN_"^"_ACT_"^"_COM
+14 QUIT
OT ; Overtime/CompTime Request
+1 if 'HDR
DO HDR
SET (NUM,CNT)=0
WRITE !
DO LST^PRSAOTS
SET COM=""
DO OK
if QT
QUIT
IF ACT'=""
if ACT="A"
SET ACT="S"
SET AP(2,DA)=DFN_"^"_ACT_"^"_COM
+2 QUIT
ED ; Environmental Diff. Request
+1 if 'HDR
DO HDR
SET (NUM,CNT)=0
WRITE !
DO LST^PRSAEDS
SET COM=""
DO OK
if QT
QUIT
if ACT'=""
SET AP(3,DA)=DFN_"^"_ACT_"^"_COM
QUIT
TC ; Tour Change
+1 if 'HDR
DO HDR
DO LST^PRSATE1
KILL COM
DO OK
if QT
QUIT
if ACT'=""
SET AP(4,DA)=DFN_"^"_ACT
QUIT
PP ; Prior Pay Period Change
+1 if 'HDR
DO HDR
DO DIS^PRSASC3
KILL COM
DO OK
if QT
QUIT
IF ACT'=""
if ACT="A"
SET ACT="S"
SET AP(5,DA)=DFN_"^"_ACT
+2 QUIT
OK READ !!,"Disposition (A=Approve, D=Disapprove, X=Cancel, RETURN to bypass): ",ACT:DTIME
if '$TEST!(ACT["^")
SET QT=1
if QT!(ACT="")
QUIT
SET ACT=$TRANSLATE(ACT,"adx","ADX")
IF ACT'?1U!("ADX"'[ACT)
WRITE *7,!,"Enter A, D or X or Press RETURN to bypass"
GOTO OK
+1 if '$DATA(COM)
QUIT
SET COM=""
O1 IF ACT'="A"
READ !!,"Comment: ",COM:DTIME
if '$TEST!(COM["^")
SET QT=1
if QT
QUIT
IF COM'?.ANP
WRITE *7," ??"
GOTO O1
+1 IF ACT'="A"
IF $LENGTH(COM)<4!($LENGTH(COM)>60)!(COM?1"?".E)
WRITE *7," A 4-60 character comment is required."
GOTO O1
+2 QUIT
+3 ;
LVOK NEW PROMPT,REPROMPT
+1 SET PROMPT="Disposition (A=Approve, D=Disapprove, RETURN to bypass): "
+2 SET REPROMPT="Enter A or D or Press RETURN to bypass"
+3 WRITE !!,PROMPT
+4 READ ACT:DTIME
+5 if '$TEST!(ACT["^")
SET QT=1
+6 if QT!(ACT="")
QUIT
+7 SET ACT=$TRANSLATE(ACT,"ad","AD")
+8 IF ACT'?1U!("AD"'[ACT)
WRITE *7,!,REPROMPT
GOTO LVOK
+9 if '$DATA(COM)
QUIT
SET COM=""
+10 DO O1
+11 QUIT
+12 ;
HDR ; Display Header
+1 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
WRITE !?26,"VA TIME & ATTENDANCE SYSTEM",!?28,"SUPERVISOR'S APPROVALS"
+2 SET PPE=""
DO HDR^PRSADP1
SET HDR=1
QUIT
EX GOTO KILL^XUSCLEAN
