source: WorldVistAEHR/trunk/r/PAID-PRS/PRSASC1.m@ 1093

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

initial load of WorldVistAEHR
File size: 4.7 KB
Line 
1PRSASC1 ; HISC/MGD - File Approvals ;01/22/05
2 ;;4.0;PAID;**55,93**;Sep 21, 1995;Build 7
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 D NOW^%DTC S NOW=%
5 F DA=0:0 S DA=$O(AP(1,DA)) Q:DA<1 D LV1
6 F DA=0:0 S DA=$O(AP(2,DA)) Q:DA<1 D OT1
7 F DA=0:0 S DA=$O(AP(3,DA)) Q:DA<1 D ED1
8 S NX="" F S NX=$O(AP(4,NX)) Q:NX="" D TC1
9 S NOD="AXR",NX="" F S NX=$O(AP(5,NX)) Q:NX="" D APP^PRSASC3
10 D UPD^PRSASAL,APP^PRSASAL Q
11LV1 ; Process action
12 N SKIP
13 S SKIP=0
14 ; if action = approve and employee has any PTP memos
15 I $P(AP(1,DA),"^",2)="A",$$PTP^PRSPUT3($P(AP(1,DA),"^",1)) D
16 . N LVY0,PPLCK,PPLCKE,PRSEX
17 . S LVY0=$G(^PRST(458.1,DA,0))
18 . ; lock applicable time cards
19 . D LCK^PRSPAPU($P(LVY0,U,2),$$FMADD^XLFDT($P(LVY0,U,3),-1),$P(LVY0,U,5),.PPLCK,.PPLCKE)
20 . ; if problem locking time cards
21 . I $D(PPLCKE) D
22 . . S SKIP=1 ; set flag to skip approval of leave
23 . . ; construct and send error message
24 . . D LVEMSG
25 . I '$G(SKIP),$D(PPLCK) D
26 . . ; attempt to auto post leave to ESR
27 . . D PLR^PRSPLVA(DA,,,.PRSEX)
28 . . ; if fatal error during auto post
29 . . I $D(PRSEX) D
30 . . . S SKIP=1 ; set flag to skip approval of leave
31 . . . ; construct and send error message
32 . . . D LVEMSG
33 . D TCULCK^PRSPAPU($P(LVY0,U,2),.PPLCK) ; remove any TC locks
34 Q:SKIP
35 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
36 S $P(^PRST(458.1,DA,0),"^",9)=ACT K ^PRST(458.1,"AR",DFN,DA)
37 S $P(^PRST(458.1,DA,0),"^",12,14)=DUZ_"^"_NOW_"^"_X
38 S:COM'="" $P(^PRST(458.1,DA,1),"^",1)=COM Q
39OT1 ; Process action
40 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
41 I ACT="S" S ^PRST(458.2,"AS",DFN,DA)=""
42 S $P(^PRST(458.2,DA,0),"^",8)=ACT K ^PRST(458.2,"AR",DFN,DA)
43 S $P(^PRST(458.2,DA,0),"^",13,15)=DUZ_"^"_NOW_"^"_X
44 S:COM'="" $P(^PRST(458.2,DA,1),"^",1)=COM Q
45ED1 ; Process action
46 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
47 S $P(^PRST(458.3,DA,0),"^",9)=ACT K ^PRST(458.3,"AR",DFN,DA)
48 S $P(^PRST(458.3,DA,0),"^",12,14)=DUZ_"^"_NOW_"^"_X
49 S:COM'="" $P(^PRST(458.3,DA,1),"^",1)=COM D:ACT="A" ^PRSASC2 Q
50TC1 ; Process action
51 S DFN=$P(AP(4,NX),"^",1),ACT=$P(AP(4,NX),"^",2),PPI=$P(NX,"~",2)
52 S X=ESNAM,X1=DUZ,X2=DFN D EN^XUSHSHP
53 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
54 ; tour change(s) were disapproved or canceled so undo them
55 S STAT=$P($G(^PRST(458,PPI,"E",DFN,0)),"^",2) I STAT'="","PX"[STAT G T1
56 S TYP="" F DAY=0:0 S DAY=$O(^PRST(458,"ATC",DFN,PPI,DAY)) Q:DAY="" D
57 .; special undo if tour change made to next pay period
58 .I $P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),U,3)=2 D Q
59 ..S $P(^PRST(458,PPI,"E",DFN,"D",DAY,0),U,3,4)="^"
60 ..S $P(^PRST(458,PPI,"E",DFN,"D",DAY,0),U,10,11)=DUZ_"^"_NOW
61 .; tour change not made to next pay period
62 .I $D(^PRST(458,PPI,"E",DFN,"D",DAY,4)) K ^(4) S $P(^(0),"^",13,15)="^^"
63 .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
64 .Q
65T1 K ^PRST(458,"ATC",DFN,PPI) Q
66 ;
67LVEMSG ; Construct and send a leave approval error message
68 ; inputs LVY0,PPLCKE(),
69 N LN,PRSARR,PRSI,PRST,TYPI,XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
70 S PRST(1)="You recently entered an approval for the following leave request:"
71 S PRST(2)=" "
72 S PRST(3)=" Employee: "_$P($G(^PRSPC($P(LVY0,U,2),0)),U)
73 S TYPI=$S($P(LVY0,U,7)'="":$O(^PRST(457.3,"B",$P(LVY0,U,7),0)),1:"")
74 I TYPI S PRST(3)=PRST(3)_" Type: "_$P($G(^PRST(457.3,TYPI,0)),U,3)
75 S PRST(4)=" "_$P(LVY0,U,4)_" "_$$FMTE^XLFDT($P(LVY0,U,3))
76 S PRST(4)=PRST(4)_" to "_$P(LVY0,U,6)_" "_$$FMTE^XLFDT($P(LVY0,U,5))
77 S PRST(5)=" "
78 S PRST(6)="The software was unable to save the approval of this leave"
79 S PRST(7)="request and nothing has been changed. The request will"
80 S PRST(8)="continue to appear as a pending action under the Supervisory"
81 S PRST(9)="Approvals option."
82 S PRST(10)=" "
83 S LN=10
84 ; load lock problems (if any)
85 I $D(PPLCKE) D
86 . D RLCKE^PRSPAPU(.PPLCKE,0,"PRSARR")
87 . S PRSI=0
88 . F S PRSI=$O(PRSARR(PRSI)) Q:'PRSI S LN=LN+1,PRST(LN)=PRSARR(PRSI)
89 ; load time card status problem (if any)
90 I $G(PRSEX) D
91 . S LN=LN+1,PRST(LN)="This leave request can not be approved because the employee is"
92 . S LN=LN+1,PRST(LN)="a part-time physician with a memorandum of service level"
93 . S LN=LN+1,PRST(LN)="expectations, and the leave request may impact a time card for"
94 . S LN=LN+1,PRST(LN)="pay period "_$P($G(^PRST(458,PRSEX,0)),U)_" that has a status of Payroll."
95 . S LN=LN+1,PRST(LN)="The request can be approved once the time card status changes."
96 . S LN=LN+1,PRST(LN)="(i.e. returned to Timekeeper or transmitted to Austin)"
97 S XMDUZ="PAID Package"
98 S XMSUB="Unable to File Approval of Leave Request"
99 S XMTEXT="PRST("
100 S XMY(DUZ)=""
101 D ^XMD
102 Q
Note: See TracBrowser for help on using the repository browser.