source: FOIAVistA/trunk/r/PAID-PRS/PRSPBRP.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1PRSPBRP ;WOIFO/MGD - PTP BEGIN RECONCILIATION OF MEMORANDUM ;01/29/07
2 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ; The following routine will allow HR to begin the reconciliation
6 ; process for a memorandum that has expired or been terminated.
7 ; After the PT Physician is selected a summary screen will be
8 ; displayed to verify that the correct memo is selected.
9 ; Then a list of the reconciliation choices will be displayed and HR
10 ; will either print the reconciliation process or they will e-mail it
11 ; to the PT Physician.
12 ;
13 Q
14 ;
15MAIN ; Prompt for Part Time Physician
16 S QUIT=0
17 F D I QUIT D KILL Q
18 . S PRSIEN=""
19 . D PTP^PRSPRM
20 . I PRSIEN<1 S QUIT=1 Q
21 . D DRIVER
22 . K ^TMP($J,"PRSPBRP")
23 Q
24 ;
25DRIVER ; Main Driver
26 ;
27 ; Find any memorandums that meet the begin reconciliation qualifications
28 D MEM
29 Q:'MIEN
30 ; Display employee and memorandum information
31 D DISPLAY
32 Q:$D(DIRUT)
33 ; Display any outstanding PP ESRs
34 D ESRCHK^PRSPRM
35 ; Display Summary information
36 D SUM
37 Q:$D(DIRUT)
38 ; Reconciliation Options
39 D ROPT
40 ; Prompt for Print or E-mail
41 D ASK2
42 Q:ASK2="^"!($G(POP))
43 ; Prompt for E-sig and update file
44 D ESIG
45 Q
46 ;
47MEM ; Find any memorandums that meet the begin reconciliation qualifications
48 ;
49 N ENDAT,INDX,MEM,STDAT
50 S MEM=0,INDX=1
51 F S MEM=$O(^PRST(458.7,"B",PRSIEN,MEM)) Q:'MEM D
52 . S DATA0=$G(^PRST(458.7,MEM,0)) ; Memo info
53 . S DATA4=$G(^PRST(458.7,MEM,4)) ; Termination info
54 . Q:DATA0=""
55 . S STATUS=$P(DATA0,U,6)
56 . Q:STATUS'=2 ; Recently ended memos would still be in status of 2
57 . S STDAT=$P(DATA0,U,2)
58 . S ENDAT=$P(DATA0,U,3)
59 . S TDAT=$P(DATA4,U,1)
60 . I TDAT,TDAT>DT Q ; Termination Date has yet to occur
61 . I TDAT S ENDAT=TDAT ; Set ENDAT to Termination Date
62 . Q:TDAT=""&(ENDAT>DT) ; Not Terminated and End Date has yet to occur
63 . S MEM(INDX)=MEM_"^"_STDAT_"^"_ENDAT_"^ACTIVE"
64 . S INDX=INDX+1
65 ; If no memos meet the reconciliation qualifications
66 I '$D(MEM(1)) D Q
67 . W !!,"No memorandums meet the reconciliation qualifications for the "
68 . W "selected employee."
69 . S MIEN=0
70 ; If only one memo
71 I '$D(MEM(2)) S MIEN=$P(MEM(1),U,1) Q
72 ; Display list if more than one
73 I $D(MEM(2)) D
74 . W !!,"# ",?5,"STARTS ENDS"
75 . F MEM=1:1 Q:'$D(MEM(MEM)) D
76 . . S DATA=MEM(MEM)
77 . . S Y=$P(DATA,U,2)
78 . . D DD^%DT
79 . . S START=Y
80 . . S Y=$P(DATA,U,3)
81 . . D DD^%DT
82 . . S END=Y
83 . . W !,MEM,?5,START," ",END
84 . ;
85ASK . ; Ask user to select which memorandum they want
86 . S END="",END=$O(MEM(END),-1)
87 . W !!,"Enter a number between 1 and ",END," :"
88 . R ASK:DTIME
89 . S ASK=$$UPPER^PRSRUTL(ASK)
90 . I ASK=""!(ASK="^") S MIEN=0 Q
91 . I '$D(MEM(ASK)) D G ASK
92 . . W !!,"Enter a number between 1 and ",END," or ^ to exit"
93 . S MIEN=$P(MEM(ASK),U,1)
94 . S DATA0=$G(^PRST(458.7,MIEN,0)) ; Memo info
95 . S DATA4=$G(^PRST(458.7,MIEN,4)) ; Termination info
96 Q
97 ;
98DISPLAY ; Display memorandum info to validate the correct employee was chosen
99 W:$E(IOST,1,2)="C-" @IOF
100 S SCRTTL=" PT Physician Begin Reconciliation Process",INDX=1
101 S ARRAY="^TMP($J,""PRSPBRP"","
102 D HDR^PRSPUT1(PRSIEN,SCRTTL,ARRAY,1)
103 D MEM^PRSPUT1(PRSIEN,MIEN,ARRAY)
104 D AL^PRSPUT3(PRSIEN,ARRAY)
105 D PPSUM^PRSPUT2(PRSIEN,MIEN,ARRAY)
106 S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR
107 Q
108 ;
109SUM ; Display Summary information - Screen #2
110 D INDEX^PRSPUT1 ; Get last index
111 S TEXT=""
112 D A1^PRSPUT1
113 N AHRS,AMT,COHRS,DATA0,ENDSTA,POMC,PPREM,RATE,SALARY,SPAA
114 N THW,TOTNP,TOTWP
115 S PPREM=$P($$MEMCPP^PRSPUT3(MIEN),U,2) ; Determine # PP already worked
116 S PPREM=26-PPREM ; Pay Periods REMaining
117 S DATA0=$G(^PRST(458.7,MIEN,0))
118 S AHRS=$P(DATA0,U,4) ; Agreed Hours
119 S COHRS=$P(DATA0,U,9) ; Carryover Hours
120 S COHRS=$G(COHRS,"0.00")
121 S THW=$P(DATA0,U,10) ; Total Hours Worked
122 S TOTNP=$P(DATA0,U,12) ; Total NonPay Hours
123 I TOTNP="" S TOTNP="0.00"
124 S TOTWP=$P(DATA0,U,13) ; Total Without Pay Hours
125 I TOTWP="" S TOTWP="0.00"
126 S POMC=+$P(DATA0,U,14) ; % of Memo Completed
127 S POT=+$P(DATA0,U,17) ; % Off Target
128 S TEXT=" Percent Completed: "_$J(POMC,6,2)
129 D A1^PRSPUT1 ; Screen 2, Line 3
130 S OTHRS=AHRS/26*(26-PPREM)-TOTNP-TOTWP ; Hrs that should've been worked
131 S OTHRS=THW+COHRS-OTHRS ; Off Target HouRS
132 S TEXT=" Off Target Hours: "_$J(OTHRS,6,2)
133 D A1^PRSPUT1 ; Screen 2, Line 4
134 S TEXT="Off Target Percentage: "_$J(POT,6,2)
135 D A1^PRSPUT1 ; Screen 2, Line 5
136 D A1^PRSPUT1 ; Screen 2, Line 6
137 S TEXT=" Non Pay Hours: "_$J(TOTNP,6,2)
138 D A1^PRSPUT1 ; Screen 2, Line 7
139 S TEXT=" Without Pay Hours: "_$J(TOTWP,6,2)
140 D A1^PRSPUT1 ; Screen 2, Line 8
141 S TEXT=" Carryover Hours: "_$J(COHRS,6,2)
142 D A1^PRSPUT1,A1^PRSPUT1 ; Screen 2, Line 9
143 ; Calculate amount owed
144 S SALARY=$P($G(^PRSPC(PRSIEN,0)),U,29) ; Salary
145 S SPAA=$P($G(^PRSPC(PRSIEN,"T38")),U,24) ; Special Pay Annual Amount
146 S RATE=SALARY+SPAA/2080
147 S RATE=$J(RATE,0,2)
148 S AMT=$J(OTHRS*RATE,6,2)
149 S TEXT="Estimated Gross Amount Owed "
150 S ENDSTA=$S(OTHRS>0:"Over",OTHRS<0:"Under",1:"Even")
151 S TEXT=TEXT_$S(ENDSTA="Over":"PTP",1:"VA")_": "_AMT
152 D A1^PRSPUT1 ; Screen 2, Line 10
153 S TEXT=" Ending Status: "_$J(ENDSTA,6)
154 D A1^PRSPUT1 ; Screen 2,
155 W !
156 S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR
157 Q
158 ;
159ROPT ; Reconciliation Options
160 ;
161 I $E(IOST,1,2)="C-" W @IOF
162 W $P(^PRSPC(PRSIEN,0),U,1)_" - Memorandum Summary"
163 D A1^PRSPUT1 ; Screen 2, Line 8 - Blank line
164 S TEXT="Reconciliation Options:"
165 D A1^PRSPUT1 ; Screen 2, Line 9
166 ; PTP worked less than Agreed Hours
167 ;I POT<-5.00 D Q
168 I POT<0 D Q
169 . S TEXT="Pay VA for negative balance"
170 . S MEM(1)=TEXT_U_3
171 . S TEXT="1. "_TEXT
172 . D A1^PRSPUT1 ; Screen 2, Line 10
173 ;
174 ; PTP worked more than Agreed Hours
175 ; CO policy removed I POT>5.00 D Q
176 I POT>0 D Q
177 . S TEXT="Pay Phy for positive balance"
178 . S MEM(1)=TEXT_U_5
179 . S TEXT="1. "_TEXT
180 . D A1^PRSPUT1 ; Screen 2, Line 10
181 ;
182 ; PTP worked Agreed Hours exactly
183 I POT=0 D Q
184 . S TEXT="No reconciliation needed"
185 . S MEM(1)=TEXT_U_1
186 . S TEXT="1. "_TEXT
187 . D A1^PRSPUT1 ; Screen 2, Line 10
188 ;
189 ;***************************************************************
190 ;PRS*4*93: BEGIN comment out carry over options--during testing
191 ;policy was changed to not allow ptp to carry over hours within
192 ;5% of agreement.
193 ;***************************************************************
194 ;; Within 5% of Agreed Hours
195 ;; Check for next memorandum
196 ;S OLDMIEN=MIEN
197 ;S NMIEN=+$$MIEN^PRSPUT1(PRSIEN)
198 ;S MIEN=OLDMIEN
199 ;I 'NMIEN D
200 ;. S TEXT="No current Memorandum on file. Transfer not possible."
201 ;. D A1^PRSPUT1
202 ;. S TEXT="If applicable, exit and enter a new memorandum first."
203 ;. D A1^PRSPUT1
204 ;;
205 ;; Negative Balance Options
206 ;I POT<0 D
207 ;. S TEXT="Pay VA for negative balance"
208 ;. S MEM(1)=TEXT_U_3
209 ;. S TEXT="1. "_TEXT
210 ;. D A1^PRSPUT1 ; Screen 2, Line 12
211 ;I NMIEN,POT<0 D
212 ;. S TEXT="Transfer negative balance"
213 ;. S MEM(2)=TEXT_U_2
214 ;. S TEXT="2. "_TEXT
215 ;. D A1^PRSPUT1 ; Screen 2, Line 11
216 ;;
217 ;; Postive Balance Options
218 ;I POT>0 D
219 ;. S TEXT="Pay PT Phy for positive balance"
220 ;. S MEM(1)=TEXT_U_5
221 ;. S TEXT="1. "_TEXT
222 ;. D A1^PRSPUT1 ; Screen 2, Line 12
223 ;I NMIEN,POT>0 D
224 ;. S TEXT="Transfer positive balance"
225 ;. S MEM(2)=TEXT_U_4
226 ;. S TEXT="2. "_TEXT
227 ;. D A1^PRSPUT1 ; Screen 2, Line 11
228 ;;finish the remainder of the form
229 ;D A1^PRSPUT1 ; Blank Line
230 ;S TEXT="Enter Reconciliation Option: _____"
231 ;D A1^PRSPUT1
232 ;D A1^PRSPUT1 ; Blank Line
233 ;S $P(DASH,"_",55)="_"
234 ;S TEXT="Reconciliation Comments: "_DASH
235 ;D A1^PRSPUT1 ; Reconciliation Comments Line #1
236 ;D A1^PRSPUT1 ; Blank Line
237 ;S DASH="",$P(DASH,"_",80)="_"
238 ;S TEXT=DASH
239 ;D A1^PRSPUT1 ; Reconciliation Comments Line #2
240 ;D A1^PRSPUT1 ; Blank Line
241 ;S TEXT=DASH
242 ;D A1^PRSPUT1 ; Reconciliation Comments Line #3
243 ;D A1^PRSPUT1 ; Blank Line
244 ;D A1^PRSPUT1 ; Reconciliation Comments Line #4
245 ;S DASH="",$P(DASH,"_",41)="_"
246 ;S TEXT="Signature: "_DASH
247 ;S DASH="",$P(DASH,"_",20)="_"
248 ;S TEXT=TEXT_" Date: "_DASH
249 ;D A1^PRSPUT1
250 ;**********************************
251 ;END of comment out carry over options
252 ;**********************************
253 Q
254 ;
255ASK2 ; Prompt to e-mail or print.
256 ;
257 W !!,"Would you like to use a (H)ard copy or (E)lectronic reconciliation form: "
258 R ASK2:DTIME
259 S ASK2=$$UPPER^PRSRUTL(ASK2)
260 Q:ASK2="^"
261 I "^H^E^"'[("^"_ASK2_"^") D G ASK2
262 . W !!,"Enter H or E or ^ to Quit."
263 Q
264 ;
265ESIG ; Prompt for Electronic Signature and store fields in #458.7
266 ;
267 N ESOK
268 D ^PRSAES
269 I 'ESOK K ^TMP($J,"PRSPBRP") Q
270 ;
271DEV I ASK2="H" D Q:POP
272 . K IOP,%ZIS
273 . S %ZIS("A")="Select Device: ",%ZIS="MQ"
274 . W !
275 . D ^%ZIS
276 . K %ZIS,IOP
277 . I $D(IO("Q")) D Q ; Queued
278 .. S ZTDESC="PRS PTP BEGIN RECONCILE PROC"
279 .. S ZTRTN="PRINT^PRSPBRP"
280 .. S ZTSAVE("^TMP($J,""PRSPBRP"",")=""
281 .. D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Canceled!")
282 .. K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
283 .. D HOME^%ZIS
284 . U IO
285 . D PRINT,^%ZISC
286 . K %ZIS,IOP
287 ; Update STATUS or memorandum
288 S MIEN=MIEN_",",PRSFDA(458.7,MIEN,5)=3
289 D UPDATE^DIE("","PRSFDA","MIEN"),MSG^DIALOG()
290 W !!,"Memorandum Status updated to: RECONCILIATION STARTED",!
291 K ^TMP($J,"PRSPBRP")
292 Q
293 ;
294PRINT ; Print the paper version of the Reconciliation form
295 ;
296 S INDEX=""
297 F S INDEX=$O(^TMP($J,"PRSPBRP",INDEX)) Q:'INDEX D
298 . S TEXT=^TMP($J,"PRSPBRP",INDEX)
299 . W !,TEXT
300 K ^TMP($J),TEXT
301 Q
302 ;
303KILL ; Clean up variables
304 ;
305 K AMT,ARRAY,ASK,ASK2,COHRS,D1,DASH,DATA,DATA0,DATA4,DAY,DIR,DIRUT
306 K END,ENDSTA,INDEX,INDX,MEM,MIEN,NMIEN,NPHRS,OLDMIEN,OTHRS
307 K POP,POT,PPI,PPCNT,PPREM,PRSAPGM,PRSIEN,PRSFDA,QUIT,RATE,SALARY
308 K SCRTTL,SPAA,START,STATUS,TDAT,TDATE,WPHRS,ZTSAVE,X,Y
309 K ^TMP($J,"PRSPBRP")
310 Q
Note: See TracBrowser for help on using the repository browser.