- 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 Feb 18, 2025@23:50:03 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
