PRSALVR ;HISC/REL - Leave Request ;11/30/2004
;;4.0;PAID;**61,93**;Sep 21, 1995;Build 7
;;Per VHA Directive 2004-038, this routine should not be modified.
S DFN="",SSN=$P($G(^VA(200,DUZ,1)),"^",9) I SSN'="" S DFN=$O(^PRSPC("SSN",SSN,0))
I 'DFN W !!,*7,"Your SSN was not found in both the New Person & Employee File!" G EX
S TLE=$P($G(^PRSPC(DFN,0)),"^",8) S:TLE="" TLE=" " S TLI=+$O(^PRST(455.5,"B",TLE,0))
D ^PRSAENT S ZENT="",Z1="30 31 31 31 32 33 28 35 35 34 30",Z2="AL SL CB AD NL WP CU AA DL ML RL"
F K=1:1:11 I $E(ENT,$P(Z1," ",K)) S ZENT=ZENT_$P(Z2," ",K)_" "
I ZENT="" W !!?5,"You are not entitled to any type of Leave." G EX
L +^PRST(458.1,0) K DDSFILE,DA,DR
N1 S DA=$P(^PRST(458.1,0),"^",3)+1 I $D(^PRST(458.1,DA)) S $P(^PRST(458.1,0),"^",3)=DA G N1
S $P(^PRST(458.1,0),"^",3)=DA,$P(^(0),"^",4)=$P(^(0),"^",4)+1 L -^PRST(458.1,0)
S ^PRST(458.1,DA,0)=DA_"^"_DFN,^PRST(458.1,"B",DA,DA)="",^PRST(458.1,"C",DFN,DA)=""
S ZOLD=^PRST(458.1,DA,0) D ED
K DIR S DIR("A")="Do you wish to enter another Leave Request? ",DIR(0)="YA",DIR("B")="No" W ! D ^DIR G PRSALVR:Y,EX Q
ED ; Edit Leave Request
;
N PPLCK,PPLCKE,SKIP
; if request is approved and employee has any part-time physician memos
; then lock appropriate pay periods
S SKIP=0
I $P(ZOLD,U,12),$$PTP^PRSPUT3($P(ZOLD,U,2)) D
. ; lock applicable time cards
. D LCK^PRSPAPU($P(ZOLD,U,2),$$FMADD^XLFDT($P(ZOLD,U,3),-1),$P(ZOLD,U,5),.PPLCK,.PPLCKE)
. ; if problem locking time cards
. I $D(PPLCKE) D
. . S SKIP=1 ; set flag to skip edit of leave
. . D TCULCK^PRSPAPU($P(ZOLD,U,2),.PPLCK) ; unlock any locked PP
. . D RLCKE^PRSPAPU(.PPLCKE) ; report problems
Q:SKIP ; don't proceed with edit
;
S $P(^PRST(458.1,DA,0),"^",16)=$S(ENT["D":"D",1:"H") S X="IOUON;IOUOFF" D ENDR^%ZISS
S Y15=IOUON_"Number of "_$S(ENT["D":"Days",1:"Hours")_IOUOFF_":"
S DDSFILE=458.1,DR="[PRSA LV REQ]" D ^DDS K DS
I '$P(^PRST(458.1,DA,0),"^",3) S DIK="^PRST(458.1," D ^DIK K DIK Q
I ZOLD=^PRST(458.1,DA,0) Q
;
; if timecards were locked (PTP), unpost the leave and remove the locks
I $D(PPLCK) D
. D ULR^PRSPLVA(ZOLD)
. D TCULCK^PRSPAPU($P(ZOLD,U,2),.PPLCK)
;
D NOW^%DTC S $P(^PRST(458.1,DA,0),"^",9,11)="R^"_DUZ_"^"_%,^PRST(458.1,"AR",DFN,DA)=""
I $P(ZOLD,"^",12) S $P(^PRST(458.1,DA,0),"^",12,14)="^^" K ^(1)
S Z1=$P($G(^PRST(458.1,DA,0)),"^",7) I "AL SL CB AD"[Z1 S PRT=0 D BAL^PRSALVS I BAL<0 D OK
D CHK,UPD^PRSASAL Q
OK ; Negative Balance Message
W !!,"WARNING: Your Leave Balance MAY go below zero!"
R !!,"Press RETURN to Continue.",X:DTIME Q
VAL ; Validate request
Q:'$D(Z1) I $P(Z1,"^",1)>$P(Z1,"^",3) S STR="Start date cannot be after the ending date." G V1
S X1=$P(Z1,"^",3),X2=$P(Z1,"^",1) D ^%DTC I X>40 S STR="Period of leave cannot exceed 40 days." G V1
Q:$P(Z1,"^",1)<$P(Z1,"^",3) S X=$P(Z1,"^",2)_"^"_$P(Z1,"^",4) D CNV^PRSATIM
S Z2=$P(Y,"^",1),Z4=$P(Y,"^",2)
I Z2'<Z4 S STR="Start time must be less than ending time." G V1
;The following line of code intentally commented out as unnecessary
;as well as causing an erroneous error message. Refer PRS*4*61
;I "AL SL"[$P(Z1,"^",7) S PRT=0 D BAL^PRSALVS I BAL<0 S STR="WARNING: Your leave balance MAY go below zero." D HLP^DDSUTL(.STR)
Q
V1 S DDSERROR=1 D HLP^DDSUTL(.STR) Q
CHK ; Check if start date already posted
S Z1=$P(^PRST(458.1,DA,0),"^",3)
S Y=$G(^PRST(458,"AD",Z1)),PPI=$P(Y,"^",1),DAY=$P(Y,"^",2) I PPI="" Q
Q:'$D(^PRST(458,PPI,"E",DFN,"D",DAY,10)) S Y=$G(^(2)) Q:Y[$P(^PRST(458.1,DA,0),"^",7)
S XMB="PRSA LV TK" F XMKK=0:0 S XMKK=$O(^PRST(455.5,TLI,"T",XMKK)) Q:XMKK<1 S XMY(XMKK)=""
S XMB(1)=$P($G(^PRSPC(DFN,0)),"^",1)
S X=$P($G(^PRST(458.1,DA,0)),"^",3) D DTP^PRSAPPU S XMB(3)=Y,XMB(2)=""
S LVT=";"_$P(^DD(458.1,6,0),"^",3)
S X=$P($G(^PRST(458.1,DA,0)),"^",7),%=$F(LVT,";"_X_":") I %>0 S XMB(2)=$P($E(LVT,%,999),";",1)
D ^XMB K XMB,XMY,XMM,XMDT,XMKK Q
EX G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSALVR 3918 printed Oct 16, 2024@18:24:23 Page 2
PRSALVR ;HISC/REL - Leave Request ;11/30/2004
+1 ;;4.0;PAID;**61,93**;Sep 21, 1995;Build 7
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 SET DFN=""
SET SSN=$PIECE($GET(^VA(200,DUZ,1)),"^",9)
IF SSN'=""
SET DFN=$ORDER(^PRSPC("SSN",SSN,0))
+4 IF 'DFN
WRITE !!,*7,"Your SSN was not found in both the New Person & Employee File!"
GOTO EX
+5 SET TLE=$PIECE($GET(^PRSPC(DFN,0)),"^",8)
if TLE=""
SET TLE=" "
SET TLI=+$ORDER(^PRST(455.5,"B",TLE,0))
+6 DO ^PRSAENT
SET ZENT=""
SET Z1="30 31 31 31 32 33 28 35 35 34 30"
SET Z2="AL SL CB AD NL WP CU AA DL ML RL"
+7 FOR K=1:1:11
IF $EXTRACT(ENT,$PIECE(Z1," ",K))
SET ZENT=ZENT_$PIECE(Z2," ",K)_" "
+8 IF ZENT=""
WRITE !!?5,"You are not entitled to any type of Leave."
GOTO EX
+9 LOCK +^PRST(458.1,0)
KILL DDSFILE,DA,DR
N1 SET DA=$PIECE(^PRST(458.1,0),"^",3)+1
IF $DATA(^PRST(458.1,DA))
SET $PIECE(^PRST(458.1,0),"^",3)=DA
GOTO N1
+1 SET $PIECE(^PRST(458.1,0),"^",3)=DA
SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+1
LOCK -^PRST(458.1,0)
+2 SET ^PRST(458.1,DA,0)=DA_"^"_DFN
SET ^PRST(458.1,"B",DA,DA)=""
SET ^PRST(458.1,"C",DFN,DA)=""
+3 SET ZOLD=^PRST(458.1,DA,0)
DO ED
+4 KILL DIR
SET DIR("A")="Do you wish to enter another Leave Request? "
SET DIR(0)="YA"
SET DIR("B")="No"
WRITE !
DO ^DIR
if Y
GOTO PRSALVR
GOTO EX
QUIT
ED ; Edit Leave Request
+1 ;
+2 NEW PPLCK,PPLCKE,SKIP
+3 ; if request is approved and employee has any part-time physician memos
+4 ; then lock appropriate pay periods
+5 SET SKIP=0
+6 IF $PIECE(ZOLD,U,12)
IF $$PTP^PRSPUT3($PIECE(ZOLD,U,2))
Begin DoDot:1
+7 ; lock applicable time cards
+8 DO LCK^PRSPAPU($PIECE(ZOLD,U,2),$$FMADD^XLFDT($PIECE(ZOLD,U,3),-1),$PIECE(ZOLD,U,5),.PPLCK,.PPLCKE)
+9 ; if problem locking time cards
+10 IF $DATA(PPLCKE)
Begin DoDot:2
+11 ; set flag to skip edit of leave
SET SKIP=1
+12 ; unlock any locked PP
DO TCULCK^PRSPAPU($PIECE(ZOLD,U,2),.PPLCK)
+13 ; report problems
DO RLCKE^PRSPAPU(.PPLCKE)
End DoDot:2
End DoDot:1
+14 ; don't proceed with edit
if SKIP
QUIT
+15 ;
+16 SET $PIECE(^PRST(458.1,DA,0),"^",16)=$SELECT(ENT["D":"D",1:"H")
SET X="IOUON;IOUOFF"
DO ENDR^%ZISS
+17 SET Y15=IOUON_"Number of "_$SELECT(ENT["D":"Days",1:"Hours")_IOUOFF_":"
+18 SET DDSFILE=458.1
SET DR="[PRSA LV REQ]"
DO ^DDS
KILL DS
+19 IF '$PIECE(^PRST(458.1,DA,0),"^",3)
SET DIK="^PRST(458.1,"
DO ^DIK
KILL DIK
QUIT
+20 IF ZOLD=^PRST(458.1,DA,0)
QUIT
+21 ;
+22 ; if timecards were locked (PTP), unpost the leave and remove the locks
+23 IF $DATA(PPLCK)
Begin DoDot:1
+24 DO ULR^PRSPLVA(ZOLD)
+25 DO TCULCK^PRSPAPU($PIECE(ZOLD,U,2),.PPLCK)
End DoDot:1
+26 ;
+27 DO NOW^%DTC
SET $PIECE(^PRST(458.1,DA,0),"^",9,11)="R^"_DUZ_"^"_%
SET ^PRST(458.1,"AR",DFN,DA)=""
+28 IF $PIECE(ZOLD,"^",12)
SET $PIECE(^PRST(458.1,DA,0),"^",12,14)="^^"
KILL ^(1)
+29 SET Z1=$PIECE($GET(^PRST(458.1,DA,0)),"^",7)
IF "AL SL CB AD"[Z1
SET PRT=0
DO BAL^PRSALVS
IF BAL<0
DO OK
+30 DO CHK
DO UPD^PRSASAL
QUIT
OK ; Negative Balance Message
+1 WRITE !!,"WARNING: Your Leave Balance MAY go below zero!"
+2 READ !!,"Press RETURN to Continue.",X:DTIME
QUIT
VAL ; Validate request
+1 if '$DATA(Z1)
QUIT
IF $PIECE(Z1,"^",1)>$PIECE(Z1,"^",3)
SET STR="Start date cannot be after the ending date."
GOTO V1
+2 SET X1=$PIECE(Z1,"^",3)
SET X2=$PIECE(Z1,"^",1)
DO ^%DTC
IF X>40
SET STR="Period of leave cannot exceed 40 days."
GOTO V1
+3 if $PIECE(Z1,"^",1)<$PIECE(Z1,"^",3)
QUIT
SET X=$PIECE(Z1,"^",2)_"^"_$PIECE(Z1,"^",4)
DO CNV^PRSATIM
+4 SET Z2=$PIECE(Y,"^",1)
SET Z4=$PIECE(Y,"^",2)
+5 IF Z2'<Z4
SET STR="Start time must be less than ending time."
GOTO V1
+6 ;The following line of code intentally commented out as unnecessary
+7 ;as well as causing an erroneous error message. Refer PRS*4*61
+8 ;I "AL SL"[$P(Z1,"^",7) S PRT=0 D BAL^PRSALVS I BAL<0 S STR="WARNING: Your leave balance MAY go below zero." D HLP^DDSUTL(.STR)
+9 QUIT
V1 SET DDSERROR=1
DO HLP^DDSUTL(.STR)
QUIT
CHK ; Check if start date already posted
+1 SET Z1=$PIECE(^PRST(458.1,DA,0),"^",3)
+2 SET Y=$GET(^PRST(458,"AD",Z1))
SET PPI=$PIECE(Y,"^",1)
SET DAY=$PIECE(Y,"^",2)
IF PPI=""
QUIT
+3 if '$DATA(^PRST(458,PPI,"E",DFN,"D",DAY,10))
QUIT
SET Y=$GET(^(2))
if Y[$PIECE(^PRST(458.1,DA,0),"^",7)
QUIT
+4 SET XMB="PRSA LV TK"
FOR XMKK=0:0
SET XMKK=$ORDER(^PRST(455.5,TLI,"T",XMKK))
if XMKK<1
QUIT
SET XMY(XMKK)=""
+5 SET XMB(1)=$PIECE($GET(^PRSPC(DFN,0)),"^",1)
+6 SET X=$PIECE($GET(^PRST(458.1,DA,0)),"^",3)
DO DTP^PRSAPPU
SET XMB(3)=Y
SET XMB(2)=""
+7 SET LVT=";"_$PIECE(^DD(458.1,6,0),"^",3)
+8 SET X=$PIECE($GET(^PRST(458.1,DA,0)),"^",7)
SET %=$FIND(LVT,";"_X_":")
IF %>0
SET XMB(2)=$PIECE($EXTRACT(LVT,%,999),";",1)
+9 DO ^XMB
KILL XMB,XMY,XMM,XMDT,XMKK
QUIT
EX GOTO KILL^XUSCLEAN
