source: WorldVistAEHR/trunk/r/PAID-PRS/PRSPSAP.m@ 836

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

initial load of WorldVistAEHR

File size: 6.2 KB
Line 
1PRSPSAP ;WOIFO/JAH - part time physician, supervisory approvals ;10/22/04
2 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 Q
5 ; T&A supervisor of PTP employee is required to review and take
6 ; one of the following actions on each signed day of the PTP's ESR:
7 ; 1. approve, 2. request resubmission or 3. bypass.
8 ; When the T&A Supervisor approves a signed day we attempt to
9 ; update the PTP's timecard for that day. Updates to the
10 ; timecard will be screened based on the status of the timecard
11 ; and the effect of any potential update.
12 ;
13 ; MAIN entry point called from option Approve Signed ESRs.
14 ;
15MAIN ;
16 K ^TMP($J,"PRSPSAP")
17 N PRSTLV,TLI,TLE,PRSIEN,ANYACT,AVAIL,OUT,DCNT,APRWHO
18 ; Make sure we have a signature code before continuing
19 I '$$ESIGC^PRSPUT2(1) W !! S OUT=$$ASK^PRSLIB00(1) Q
20 D HDROPT^PRSPSAP1
21 ; Prompt supervisor to pick one T&L unit for which they are assigned.
22 S PRSTLV=3
23 D ^PRSAUTL
24 Q:TLI<1
25 ;
26 ; Check if they only want to look at one employee
27 S APRWHO=$$ONEPTP^PRSPSAPU(TLE)
28 Q:APRWHO<0
29 ; ---------------------------------------------------
30 I APRWHO>0 D
31 . S NN=$P($G(^PRSPC(APRWHO,0)),U)
32 . D BLDLST(.OUT,TLE,NN)
33 E D
34 .; Loop thru supervisor's selected T&L
35 . S NN=""
36 . F S NN=$O(^PRSPC("ATL"_TLE,NN)) Q:NN=""!($G(OUT)>0) D
37 .. D BLDLST(.OUT,TLE,NN)
38 ;
39 ; display all the ASA records for action.
40 S OUT=0
41 D ASALIST^PRSPSAP1(.OUT)
42 ; check if there are any updates and then prompt for signature
43 ;
44 D ANYACT^PRSPSAP1(.ANYACT)
45 I ANYACT>0 D
46 . D SUMMARY(.ANYACT)
47 . D SIG^XUSESIG
48 .; update the timecard and ESR status for all actions when
49 .; a valid signature is applied
50 . I X1="" D
51 .. W @IOF,!!!,?10,"TIMECARD AND ESR WERE NOT UPDATED."
52 .E D
53 .. D TRANSACT^PRSPSAP2
54 ; remove any remaining PTP timecard locks held in this option
55 ; D EX^PRSASR
56 K ^TMP($J,"PRSPSAP")
57 Q
58 ;
59BLDLST(OUT,TLE,NN) ; BUILD LIST OF ALL APPROVAL ACTIONS FOR SINGLE EMPLOYEE
60 N PRSIEN,PPE,PPI,AVAIL,DCNT,PRSD,GLOB,DFN
61 S PRSIEN=0
62 S PRSIEN=$O(^PRSPC("ATL"_TLE,NN,PRSIEN)) Q:PRSIEN<1!($G(OUT)>0) D
63 . S PPE=""
64 . F S PPE=$O(^PRST(458,"ASA",PRSIEN,PPE)) Q:PPE=""!($G(OUT)>0) D
65 .. S PPI=$O(^PRST(458,"B",PPE,0))
66 ..; get lock for PTP's entire PP, then add record (PUSH) that
67 ..; requires supervisor action to the list
68 .. S DFN=PRSIEN
69 ..;
70 ..; $$availrec() locks PTP ESR node.
71 ..; unlock if supervisor bybasses unlock otherwise they
72 ..; are not unlocked until they are processed thru temp global
73 ..; & their status' are updated.
74 .. S AVAIL=$$AVAILREC^PRSLIB00("",.GLOB,.OUT)
75 .. Q:'AVAIL
76 .. ;
77 ..; add item to list and set up a day cross ref with count of days
78 .. S (DCNT,PRSD)=0
79 .. F S PRSD=$O(^PRST(458,"ASA",PRSIEN,PPE,PRSD)) Q:PRSD'>0 D
80 ... S DCNT=DCNT+1
81 ... D PUSH^PRSPSAP1(PPI,PRSIEN,PRSD,DCNT)
82 ;
83 Q
84 ;
85SUMMARY(AA) ;
86 W @IOF,!!!,"Supervisory Action Summary"
87 W !!,$J(AA,6)," actions require your electronic signature before being"
88 W !,?(6-$L(AA))," committed to the database."
89 I AA("A")>0 W !,$J(AA("A"),6)," ESR record marked for approval. (signature required)"
90 I AA("R")>0 W !,$J(AA("R"),6)," ESR records marked for resubmission. (signature required)"
91 I AA("B")>0 W !,$J(AA("B"),6)," ESR records explicitly bypassed."
92 I AA("N")>0 W !,$J(AA("N"),6)," ESR records with no action."
93 Q
94GETACT(ESRDTS,PRSIEN,PPI) ; return user choice of # (1-ACTCNT) or action
95 ; return 0 for ^ at first action prompt
96 ; return null for no response (user hit return)
97 ; return -1 if ^ at 2nd prompt (action on single day prompt)
98 N DIR,DIRUT,ACT,CT,NUMS
99 ;
100 ; get total items + marked items CT CT(1)
101 D MARKCNT^PRSPSAP1(.CT,PRSIEN,PPI)
102 I CT>1 D
103 . S NUMS=";"
104 . F I=1:1:CT D
105 .. S NUMS=NUMS_I_":"_$P(ESRDTS(I),U,2)_";"
106 ;
107 ; status already marked on all days
108 I (CT>1)&(CT=CT(1)) D
109 . S DIR(0)="SAO^"_NUMS
110 . S DIR("A")="Select an item #: "
111 . S DIR("?",1)="Enter an item from the left column to change status for that day"
112 E D
113 .; if all days don't have a superV action (marked) then prompt for
114 .; action on remaining days or pick a day (item)
115 . I CT>1 D
116 .. S DIR(0)="SAO^A:Approve;B:Bypass;R:Resubmit"_NUMS
117 .. S DIR("A")="(A)pprove, (B)ypass, (R)esubmit or enter an item #: "
118 .. S DIR("?",1)="Enter an action for all records without a status or enter an item #"
119 .. S DIR("?",2)="to then pick an action for that day."
120 .. S DIR("?",3)=" Type R for Resubmit when the part-time physician needs to correct an ESR day."
121 .. S DIR("?",4)=" Type B for Bypass to skip the day(s) for now and approve at a later time."
122 .. S DIR("?",5)=" Type A for Approve when the ESR day(s) appears correct."
123 .E D
124 ..; if only one item to pick, don't ask for item #
125 .. S DIR(0)="SAO^A:Approve;B:Bypass;R:Resubmit"
126 .. S DIR("A")="(A)pprove, (B)ypass, (R)esubmit: "
127 .. S DIR("?",1)="Enter an action for all records without a status"
128 .. S DIR("?",2)=" Type R for Resubmit when the part-time physician needs to correct an ESR day."
129 .. S DIR("?",3)=" Type B for Bypass to skip the day(s) for now and approve at a later time."
130 .. S DIR("?",4)=" Type A for Approve when the ESR day(s) appears correct."
131 ;
132 S DIR("?")=" Press [enter] to move to the next part time physician."
133 D ^DIR
134 S PICK=$G(Y)
135 I $G(Y)="" Q ""
136 ; if there was only one item then set pick to 1 plus action
137 I CT=1 S PICK=PICK_"^1"
138 I $G(DIRUT) S PICK=0
139 ;
140 ; item was picked
141 I PICK>0,(PICK<(CT+1)) D
142 . N DAYLNS,DIR,DIRUT,ESR,HPL
143 . D GETESR^PRSPSAP1(.ESR,PPI,PRSIEN,+ESRDTS(PICK))
144 . N COUNT S COUNT=PICK,COUNT(1)=0
145 . W ! D DAY^PRSPSAPU(.DAYLNS,ESRDTS(COUNT),.ESR,PRSIEN,PPI)
146 . S ACT=PICK
147 . S DIR(0)="SA^A:Approve;B:Bypass;R:Resubmit"
148 . S DIR("A")="(A)pprove, (B)ypass, (R)esubmit: "
149 . S DIR("?")="Select an action for the ESR day above."
150 . S DIR("?",1)=" Type R for Resubmit when the part-time physician needs to correct an ESR day."
151 . S DIR("?",2)=" Type B for Bypass to skip the day(s) for now and approve at a later time."
152 . S DIR("?",3)=" Type A for Approve when the ESR day(s) appears correct."
153 . S DIR("?",4)=" Type ^ to redisplay the current part time physician."
154 . D GETDAY^PRSPSAPU(.DAYLNS,.ESRDTS,.ESR,PICK,PRSIEN,PPI)
155 . S HPL=0
156 . F S HPL=$O(DAYLNS(HPL)) Q:HPL'>0 D
157 .. S DIR("?",HPL+4)=$G(DAYLNS(HPL))
158 . D ^DIR
159 . S PICK=$G(Y)_"^"_ACT
160 . I $G(DIRUT) S PICK=-1
161 Q PICK
162 ;
Note: See TracBrowser for help on using the repository browser.