PRSASC1 ; HISC/MGD - File Approvals ;01/22/05
;;4.0;PAID;**55,93,132**;Sep 21, 1995;Build 13
;;Per VHA Directive 2004-038, this routine should not be modified.
D NOW^%DTC S NOW=%
F DA=0:0 S DA=$O(AP(1,DA)) Q:DA<1 D LV1
F DA=0:0 S DA=$O(AP(2,DA)) Q:DA<1 D OT1
F DA=0:0 S DA=$O(AP(3,DA)) Q:DA<1 D ED1
S NX="" F S NX=$O(AP(4,NX)) Q:NX="" D TC1
S NOD="AXR",NX="" F S NX=$O(AP(5,NX)) Q:NX="" D APP^PRSASC3
D UPD^PRSASAL,APP^PRSASAL Q
LV1 ; Process action
N SKIP
S SKIP=0
; if action = approve and employee has any PTP memos
I $P(AP(1,DA),"^",2)="A",$$PTP^PRSPUT3($P(AP(1,DA),"^",1)) D
. N LVY0,PPLCK,PPLCKE,PRSEX
. S LVY0=$G(^PRST(458.1,DA,0))
. ; lock applicable time cards
. D LCK^PRSPAPU($P(LVY0,U,2),$$FMADD^XLFDT($P(LVY0,U,3),-1),$P(LVY0,U,5),.PPLCK,.PPLCKE)
. ; if problem locking time cards
. I $D(PPLCKE) D
. . S SKIP=1 ; set flag to skip approval of leave
. . ; construct and send error message
. . D LVEMSG
. I '$G(SKIP),$D(PPLCK) D
. . ; attempt to auto post leave to ESR
. . D PLR^PRSPLVA(DA,,,.PRSEX)
. . ; if fatal error during auto post
. . I $D(PRSEX) D
. . . S SKIP=1 ; set flag to skip approval of leave
. . . ; construct and send error message
. . . D LVEMSG
. D TCULCK^PRSPAPU($P(LVY0,U,2),.PPLCK) ; remove any TC locks
Q:SKIP
S DFN=$P(AP(1,DA),"^",1),ACT=$P(AP(1,DA),"^",2),COM=$P(AP(1,DA),"^",3),X=ESNAM,X1=DUZ,X2=DA D EN^XUSHSHP
S $P(^PRST(458.1,DA,0),"^",9)=ACT K ^PRST(458.1,"AR",DFN,DA)
S $P(^PRST(458.1,DA,0),"^",12,14)=DUZ_"^"_NOW_"^"_X
S:COM'="" $P(^PRST(458.1,DA,1),"^",1)=COM Q
OT1 ; Process action
S DFN=$P(AP(2,DA),"^",1),ACT=$P(AP(2,DA),"^",2),COM=$P(AP(2,DA),"^",3),X=ESNAM,X1=DUZ,X2=DA D EN^XUSHSHP
I ACT="S" S ^PRST(458.2,"AS",DFN,DA)=""
S $P(^PRST(458.2,DA,0),"^",8)=ACT K ^PRST(458.2,"AR",DFN,DA)
S $P(^PRST(458.2,DA,0),"^",13,15)=DUZ_"^"_NOW_"^"_X
S:COM'="" $P(^PRST(458.2,DA,1),"^",1)=COM Q
ED1 ; Process action
S DFN=$P(AP(3,DA),"^",1),ACT=$P(AP(3,DA),"^",2),COM=$P(AP(3,DA),"^",3),X=ESNAM,X1=DUZ,X2=DA D EN^XUSHSHP
S $P(^PRST(458.3,DA,0),"^",9)=ACT K ^PRST(458.3,"AR",DFN,DA)
S $P(^PRST(458.3,DA,0),"^",12,14)=DUZ_"^"_NOW_"^"_X
S:COM'="" $P(^PRST(458.3,DA,1),"^",1)=COM D:ACT="A" ^PRSASC2 Q
TC1 ; Tour Process action
N PRSTW,PRSTWA,PRSTWB
S DFN=$P(AP(4,NX),"^",1),ACT=$P(AP(4,NX),"^",2),PPI=$P(NX,"~",2)
S PRSTWA=$$TWE^PRSATE0(DFN,PPI),PRSTWB=$P(PRSTWA,U,4)="Y"
S X=ESNAM,X1=DUZ,X2=DFN D EN^XUSHSHP
I ACT="A" F DAY=0:0 S DAY=$O(^PRST(458,"ATC",DFN,PPI,DAY)) G:DAY="" T1 S $P(^PRST(458,PPI,"E",DFN,"D",DAY,0),"^",5,7)=DUZ_"^"_NOW_"^"_X
; tour change(s) were disapproved or canceled so undo them
S STAT=$P($G(^PRST(458,PPI,"E",DFN,0)),"^",2) I STAT'="","PX"[STAT G T1
S TYP="" F DAY=0:0 S DAY=$O(^PRST(458,"ATC",DFN,PPI,DAY)) Q:DAY="" D
.; special undo if tour change made to next pay period
.I $P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),U,3)=2 D Q
..S $P(^PRST(458,PPI,"E",DFN,"D",DAY,0),U,3,4)="^"
..S $P(^PRST(458,PPI,"E",DFN,"D",DAY,0),U,10,11)=DUZ_"^"_NOW
..I $G(^PRST(458,PPI,"E",DFN,"D",DAY,8))]"" S $P(^(8),U,5)="" I ^(8)?."^" K ^PRST(458,PPI,"E",DFN,"D",DAY,8)
..QUIT
.; tour change not made to next pay period
.I $D(^PRST(458,PPI,"E",DFN,"D",DAY,4)) K ^(4) S $P(^(0),"^",13,15)="^^"
.I $D(^PRST(458,PPI,"E",DFN,"D",DAY,8)) S PRSTW(DAY)=$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,8)),U,5)
.S TD=$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",4),Y=$G(^PRST(457.1,+TD,1)),TDH=$P($G(^(0)),"^",6) D SET^PRSATE
.Q
T1 K ^PRST(458,"ATC",DFN,PPI) Q
;
LVEMSG ; Construct and send a leave approval error message
; inputs LVY0,PPLCKE(),
N LN,PRSARR,PRSI,PRST,TYPI,XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
S PRST(1)="You recently entered an approval for the following leave request:"
S PRST(2)=" "
S PRST(3)=" Employee: "_$P($G(^PRSPC($P(LVY0,U,2),0)),U)
S TYPI=$S($P(LVY0,U,7)'="":$O(^PRST(457.3,"B",$P(LVY0,U,7),0)),1:"")
I TYPI S PRST(3)=PRST(3)_" Type: "_$P($G(^PRST(457.3,TYPI,0)),U,3)
S PRST(4)=" "_$P(LVY0,U,4)_" "_$$FMTE^XLFDT($P(LVY0,U,3))
S PRST(4)=PRST(4)_" to "_$P(LVY0,U,6)_" "_$$FMTE^XLFDT($P(LVY0,U,5))
S PRST(5)=" "
S PRST(6)="The software was unable to save the approval of this leave"
S PRST(7)="request and nothing has been changed. The request will"
S PRST(8)="continue to appear as a pending action under the Supervisory"
S PRST(9)="Approvals option."
S PRST(10)=" "
S LN=10
; load lock problems (if any)
I $D(PPLCKE) D
. D RLCKE^PRSPAPU(.PPLCKE,0,"PRSARR")
. S PRSI=0
. F S PRSI=$O(PRSARR(PRSI)) Q:'PRSI S LN=LN+1,PRST(LN)=PRSARR(PRSI)
; load time card status problem (if any)
I $G(PRSEX) D
. S LN=LN+1,PRST(LN)="This leave request can not be approved because the employee is"
. S LN=LN+1,PRST(LN)="a part-time physician with a memorandum of service level"
. S LN=LN+1,PRST(LN)="expectations, and the leave request may impact a time card for"
. S LN=LN+1,PRST(LN)="pay period "_$P($G(^PRST(458,PRSEX,0)),U)_" that has a status of Payroll."
. S LN=LN+1,PRST(LN)="The request can be approved once the time card status changes."
. S LN=LN+1,PRST(LN)="(i.e. returned to Timekeeper or transmitted to Austin)"
S XMDUZ="PAID Package"
S XMSUB="Unable to File Approval of Leave Request"
S XMTEXT="PRST("
S XMY(DUZ)=""
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSASC1 5276 printed Dec 13, 2024@02:24:17 Page 2
PRSASC1 ; HISC/MGD - File Approvals ;01/22/05
+1 ;;4.0;PAID;**55,93,132**;Sep 21, 1995;Build 13
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 DO NOW^%DTC
SET NOW=%
+4 FOR DA=0:0
SET DA=$ORDER(AP(1,DA))
if DA<1
QUIT
DO LV1
+5 FOR DA=0:0
SET DA=$ORDER(AP(2,DA))
if DA<1
QUIT
DO OT1
+6 FOR DA=0:0
SET DA=$ORDER(AP(3,DA))
if DA<1
QUIT
DO ED1
+7 SET NX=""
FOR
SET NX=$ORDER(AP(4,NX))
if NX=""
QUIT
DO TC1
+8 SET NOD="AXR"
SET NX=""
FOR
SET NX=$ORDER(AP(5,NX))
if NX=""
QUIT
DO APP^PRSASC3
+9 DO UPD^PRSASAL
DO APP^PRSASAL
QUIT
LV1 ; Process action
+1 NEW SKIP
+2 SET SKIP=0
+3 ; if action = approve and employee has any PTP memos
+4 IF $PIECE(AP(1,DA),"^",2)="A"
IF $$PTP^PRSPUT3($PIECE(AP(1,DA),"^",1))
Begin DoDot:1
+5 NEW LVY0,PPLCK,PPLCKE,PRSEX
+6 SET LVY0=$GET(^PRST(458.1,DA,0))
+7 ; lock applicable time cards
+8 DO LCK^PRSPAPU($PIECE(LVY0,U,2),$$FMADD^XLFDT($PIECE(LVY0,U,3),-1),$PIECE(LVY0,U,5),.PPLCK,.PPLCKE)
+9 ; if problem locking time cards
+10 IF $DATA(PPLCKE)
Begin DoDot:2
+11 ; set flag to skip approval of leave
SET SKIP=1
+12 ; construct and send error message
+13 DO LVEMSG
End DoDot:2
+14 IF '$GET(SKIP)
IF $DATA(PPLCK)
Begin DoDot:2
+15 ; attempt to auto post leave to ESR
+16 DO PLR^PRSPLVA(DA,,,.PRSEX)
+17 ; if fatal error during auto post
+18 IF $DATA(PRSEX)
Begin DoDot:3
+19 ; set flag to skip approval of leave
SET SKIP=1
+20 ; construct and send error message
+21 DO LVEMSG
End DoDot:3
End DoDot:2
+22 ; remove any TC locks
DO TCULCK^PRSPAPU($PIECE(LVY0,U,2),.PPLCK)
End DoDot:1
+23 if SKIP
QUIT
+24 SET DFN=$PIECE(AP(1,DA),"^",1)
SET ACT=$PIECE(AP(1,DA),"^",2)
SET COM=$PIECE(AP(1,DA),"^",3)
SET X=ESNAM
SET X1=DUZ
SET X2=DA
DO EN^XUSHSHP
+25 SET $PIECE(^PRST(458.1,DA,0),"^",9)=ACT
KILL ^PRST(458.1,"AR",DFN,DA)
+26 SET $PIECE(^PRST(458.1,DA,0),"^",12,14)=DUZ_"^"_NOW_"^"_X
+27 if COM'=""
SET $PIECE(^PRST(458.1,DA,1),"^",1)=COM
QUIT
OT1 ; Process action
+1 SET DFN=$PIECE(AP(2,DA),"^",1)
SET ACT=$PIECE(AP(2,DA),"^",2)
SET COM=$PIECE(AP(2,DA),"^",3)
SET X=ESNAM
SET X1=DUZ
SET X2=DA
DO EN^XUSHSHP
+2 IF ACT="S"
SET ^PRST(458.2,"AS",DFN,DA)=""
+3 SET $PIECE(^PRST(458.2,DA,0),"^",8)=ACT
KILL ^PRST(458.2,"AR",DFN,DA)
+4 SET $PIECE(^PRST(458.2,DA,0),"^",13,15)=DUZ_"^"_NOW_"^"_X
+5 if COM'=""
SET $PIECE(^PRST(458.2,DA,1),"^",1)=COM
QUIT
ED1 ; Process action
+1 SET DFN=$PIECE(AP(3,DA),"^",1)
SET ACT=$PIECE(AP(3,DA),"^",2)
SET COM=$PIECE(AP(3,DA),"^",3)
SET X=ESNAM
SET X1=DUZ
SET X2=DA
DO EN^XUSHSHP
+2 SET $PIECE(^PRST(458.3,DA,0),"^",9)=ACT
KILL ^PRST(458.3,"AR",DFN,DA)
+3 SET $PIECE(^PRST(458.3,DA,0),"^",12,14)=DUZ_"^"_NOW_"^"_X
+4 if COM'=""
SET $PIECE(^PRST(458.3,DA,1),"^",1)=COM
if ACT="A"
DO ^PRSASC2
QUIT
TC1 ; Tour Process action
+1 NEW PRSTW,PRSTWA,PRSTWB
+2 SET DFN=$PIECE(AP(4,NX),"^",1)
SET ACT=$PIECE(AP(4,NX),"^",2)
SET PPI=$PIECE(NX,"~",2)
+3 SET PRSTWA=$$TWE^PRSATE0(DFN,PPI)
SET PRSTWB=$PIECE(PRSTWA,U,4)="Y"
+4 SET X=ESNAM
SET X1=DUZ
SET X2=DFN
DO EN^XUSHSHP
+5 IF ACT="A"
FOR DAY=0:0
SET DAY=$ORDER(^PRST(458,"ATC",DFN,PPI,DAY))
if DAY=""
GOTO T1
SET $PIECE(^PRST(458,PPI,"E",DFN,"D",DAY,0),"^",5,7)=DUZ_"^"_NOW_"^"_X
+6 ; tour change(s) were disapproved or canceled so undo them
+7 SET STAT=$PIECE($GET(^PRST(458,PPI,"E",DFN,0)),"^",2)
IF STAT'=""
IF "PX"[STAT
GOTO T1
+8 SET TYP=""
FOR DAY=0:0
SET DAY=$ORDER(^PRST(458,"ATC",DFN,PPI,DAY))
if DAY=""
QUIT
Begin DoDot:1
+9 ; special undo if tour change made to next pay period
+10 IF $PIECE($GET(^PRST(458,PPI,"E",DFN,"D",DAY,0)),U,3)=2
Begin DoDot:2
+11 SET $PIECE(^PRST(458,PPI,"E",DFN,"D",DAY,0),U,3,4)="^"
+12 SET $PIECE(^PRST(458,PPI,"E",DFN,"D",DAY,0),U,10,11)=DUZ_"^"_NOW
+13 IF $GET(^PRST(458,PPI,"E",DFN,"D",DAY,8))]""
SET $PIECE(^(8),U,5)=""
IF ^(8)?."^"
KILL ^PRST(458,PPI,"E",DFN,"D",DAY,8)
+14 QUIT
End DoDot:2
QUIT
+15 ; tour change not made to next pay period
+16 IF $DATA(^PRST(458,PPI,"E",DFN,"D",DAY,4))
KILL ^(4)
SET $PIECE(^(0),"^",13,15)="^^"
+17 IF $DATA(^PRST(458,PPI,"E",DFN,"D",DAY,8))
SET PRSTW(DAY)=$PIECE($GET(^PRST(458,PPI,"E",DFN,"D",DAY,8)),U,5)
+18 SET TD=$PIECE($GET(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",4)
SET Y=$GET(^PRST(457.1,+TD,1))
SET TDH=$PIECE($GET(^(0)),"^",6)
DO SET^PRSATE
+19 QUIT
End DoDot:1
T1 KILL ^PRST(458,"ATC",DFN,PPI)
QUIT
+1 ;
LVEMSG ; Construct and send a leave approval error message
+1 ; inputs LVY0,PPLCKE(),
+2 NEW LN,PRSARR,PRSI,PRST,TYPI,XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
+3 SET PRST(1)="You recently entered an approval for the following leave request:"
+4 SET PRST(2)=" "
+5 SET PRST(3)=" Employee: "_$PIECE($GET(^PRSPC($PIECE(LVY0,U,2),0)),U)
+6 SET TYPI=$SELECT($PIECE(LVY0,U,7)'="":$ORDER(^PRST(457.3,"B",$PIECE(LVY0,U,7),0)),1:"")
+7 IF TYPI
SET PRST(3)=PRST(3)_" Type: "_$PIECE($GET(^PRST(457.3,TYPI,0)),U,3)
+8 SET PRST(4)=" "_$PIECE(LVY0,U,4)_" "_$$FMTE^XLFDT($PIECE(LVY0,U,3))
+9 SET PRST(4)=PRST(4)_" to "_$PIECE(LVY0,U,6)_" "_$$FMTE^XLFDT($PIECE(LVY0,U,5))
+10 SET PRST(5)=" "
+11 SET PRST(6)="The software was unable to save the approval of this leave"
+12 SET PRST(7)="request and nothing has been changed. The request will"
+13 SET PRST(8)="continue to appear as a pending action under the Supervisory"
+14 SET PRST(9)="Approvals option."
+15 SET PRST(10)=" "
+16 SET LN=10
+17 ; load lock problems (if any)
+18 IF $DATA(PPLCKE)
Begin DoDot:1
+19 DO RLCKE^PRSPAPU(.PPLCKE,0,"PRSARR")
+20 SET PRSI=0
+21 FOR
SET PRSI=$ORDER(PRSARR(PRSI))
if 'PRSI
QUIT
SET LN=LN+1
SET PRST(LN)=PRSARR(PRSI)
End DoDot:1
+22 ; load time card status problem (if any)
+23 IF $GET(PRSEX)
Begin DoDot:1
+24 SET LN=LN+1
SET PRST(LN)="This leave request can not be approved because the employee is"
+25 SET LN=LN+1
SET PRST(LN)="a part-time physician with a memorandum of service level"
+26 SET LN=LN+1
SET PRST(LN)="expectations, and the leave request may impact a time card for"
+27 SET LN=LN+1
SET PRST(LN)="pay period "_$PIECE($GET(^PRST(458,PRSEX,0)),U)_" that has a status of Payroll."
+28 SET LN=LN+1
SET PRST(LN)="The request can be approved once the time card status changes."
+29 SET LN=LN+1
SET PRST(LN)="(i.e. returned to Timekeeper or transmitted to Austin)"
End DoDot:1
+30 SET XMDUZ="PAID Package"
+31 SET XMSUB="Unable to File Approval of Leave Request"
+32 SET XMTEXT="PRST("
+33 SET XMY(DUZ)=""
+34 DO ^XMD
+35 QUIT
