source: WorldVistAEHR/trunk/r/PAID-PRS/PRSALVR.m@ 619

Last change on this file since 619 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1PRSALVR ;HISC/REL - Leave Request ;11/30/2004
2 ;;4.0;PAID;**61,93**;Sep 21, 1995;Build 7
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 S DFN="",SSN=$P($G(^VA(200,DUZ,1)),"^",9) I SSN'="" S DFN=$O(^PRSPC("SSN",SSN,0))
5 I 'DFN W !!,*7,"Your SSN was not found in both the New Person & Employee File!" G EX
6 S TLE=$P($G(^PRSPC(DFN,0)),"^",8) S:TLE="" TLE=" " S TLI=+$O(^PRST(455.5,"B",TLE,0))
7 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"
8 F K=1:1:11 I $E(ENT,$P(Z1," ",K)) S ZENT=ZENT_$P(Z2," ",K)_" "
9 I ZENT="" W !!?5,"You are not entitled to any type of Leave." G EX
10 L +^PRST(458.1,0) K DDSFILE,DA,DR
11N1 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
12 S $P(^PRST(458.1,0),"^",3)=DA,$P(^(0),"^",4)=$P(^(0),"^",4)+1 L -^PRST(458.1,0)
13 S ^PRST(458.1,DA,0)=DA_"^"_DFN,^PRST(458.1,"B",DA,DA)="",^PRST(458.1,"C",DFN,DA)=""
14 S ZOLD=^PRST(458.1,DA,0) D ED
15 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
16ED ; Edit Leave Request
17 ;
18 N PPLCK,PPLCKE,SKIP
19 ; if request is approved and employee has any part-time physician memos
20 ; then lock appropriate pay periods
21 S SKIP=0
22 I $P(ZOLD,U,12),$$PTP^PRSPUT3($P(ZOLD,U,2)) D
23 . ; lock applicable time cards
24 . D LCK^PRSPAPU($P(ZOLD,U,2),$$FMADD^XLFDT($P(ZOLD,U,3),-1),$P(ZOLD,U,5),.PPLCK,.PPLCKE)
25 . ; if problem locking time cards
26 . I $D(PPLCKE) D
27 . . S SKIP=1 ; set flag to skip edit of leave
28 . . D TCULCK^PRSPAPU($P(ZOLD,U,2),.PPLCK) ; unlock any locked PP
29 . . D RLCKE^PRSPAPU(.PPLCKE) ; report problems
30 Q:SKIP ; don't proceed with edit
31 ;
32 S $P(^PRST(458.1,DA,0),"^",16)=$S(ENT["D":"D",1:"H") S X="IOUON;IOUOFF" D ENDR^%ZISS
33 S Y15=IOUON_"Number of "_$S(ENT["D":"Days",1:"Hours")_IOUOFF_":"
34 S DDSFILE=458.1,DR="[PRSA LV REQ]" D ^DDS K DS
35 I '$P(^PRST(458.1,DA,0),"^",3) S DIK="^PRST(458.1," D ^DIK K DIK Q
36 I ZOLD=^PRST(458.1,DA,0) Q
37 ;
38 ; if timecards were locked (PTP), unpost the leave and remove the locks
39 I $D(PPLCK) D
40 . D ULR^PRSPLVA(ZOLD)
41 . D TCULCK^PRSPAPU($P(ZOLD,U,2),.PPLCK)
42 ;
43 D NOW^%DTC S $P(^PRST(458.1,DA,0),"^",9,11)="R^"_DUZ_"^"_%,^PRST(458.1,"AR",DFN,DA)=""
44 I $P(ZOLD,"^",12) S $P(^PRST(458.1,DA,0),"^",12,14)="^^" K ^(1)
45 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
46 D CHK,UPD^PRSASAL Q
47OK ; Negative Balance Message
48 W !!,"WARNING: Your Leave Balance MAY go below zero!"
49 R !!,"Press RETURN to Continue.",X:DTIME Q
50VAL ; Validate request
51 Q:'$D(Z1) I $P(Z1,"^",1)>$P(Z1,"^",3) S STR="Start date cannot be after the ending date." G V1
52 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
53 Q:$P(Z1,"^",1)<$P(Z1,"^",3) S X=$P(Z1,"^",2)_"^"_$P(Z1,"^",4) D CNV^PRSATIM
54 S Z2=$P(Y,"^",1),Z4=$P(Y,"^",2)
55 I Z2'<Z4 S STR="Start time must be less than ending time." G V1
56 ;The following line of code intentally commented out as unnecessary
57 ;as well as causing an erroneous error message. Refer PRS*4*61
58 ;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)
59 Q
60V1 S DDSERROR=1 D HLP^DDSUTL(.STR) Q
61CHK ; Check if start date already posted
62 S Z1=$P(^PRST(458.1,DA,0),"^",3)
63 S Y=$G(^PRST(458,"AD",Z1)),PPI=$P(Y,"^",1),DAY=$P(Y,"^",2) I PPI="" Q
64 Q:'$D(^PRST(458,PPI,"E",DFN,"D",DAY,10)) S Y=$G(^(2)) Q:Y[$P(^PRST(458.1,DA,0),"^",7)
65 S XMB="PRSA LV TK" F XMKK=0:0 S XMKK=$O(^PRST(455.5,TLI,"T",XMKK)) Q:XMKK<1 S XMY(XMKK)=""
66 S XMB(1)=$P($G(^PRSPC(DFN,0)),"^",1)
67 S X=$P($G(^PRST(458.1,DA,0)),"^",3) D DTP^PRSAPPU S XMB(3)=Y,XMB(2)=""
68 S LVT=";"_$P(^DD(458.1,6,0),"^",3)
69 S X=$P($G(^PRST(458.1,DA,0)),"^",7),%=$F(LVT,";"_X_":") I %>0 S XMB(2)=$P($E(LVT,%,999),";",1)
70 D ^XMB K XMB,XMY,XMM,XMDT,XMKK Q
71EX G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.