source: WorldVistAEHR/trunk/r/PAID-PRS/PRSPRM.m@ 1710

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

initial load of WorldVistAEHR
File size: 6.0 KB
RevLine 
[613]1PRSPRM ;WOIFO/MGD - PTP RECONCILE MEMORANDUM ;04/20/05
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 complete the reconciliation
6 ; process for a memorandum that has expired or been terminated.
7 ;
8 Q
9 ;
10MAIN ; Main Driver
11 ;
12 K ^TMP($J,"PRSPRM")
13 ; Prompt for Part Time Physician
14 D PTP
15 I Y'>0 D KILL^PRSPRM1 Q
16 S PRSIEN=+Y
17 ; Find any memorandums that meet the reconciliation qualifications
18 S QUIT=""
19 D MEM
20 I 'MIEN D KILL^PRSPRM1 Q
21 I QUIT D KILL^PRSPRM1 Q
22 ; Display employee and memorandum information
23 D DISPLAY
24 I $D(DIRUT) D KILL^PRSPRM1 Q
25 ; Verify that all daily ESRs are completed
26 D ESRCHK
27 I QUIT D KILL^PRSPRM1 Q
28 ; Display Summary information
29 D SUM^PRSPBRP
30 I $D(DIRUT) D KILL^PRSPRM1 Q
31 ; Display Reconciliation Options
32 D ROPT^PRSPBRP
33 ; Check for Reconciliation choice entered electronically
34 D PTPCHK^PRSPRM1
35 ; Prompt HR for Reconciliation Choice
36 D HRRC^PRSPRM1
37 I RO="^" D KILL^PRSPRM1 Q
38 ; Prompt for PTP Reconciliation Comments if Paper form was used
39 D PTPRCOM^PRSPRM1
40 I X="^" D KILL^PRSPRM1 Q
41 ; Prompt to transfer balance to current memorandum
42 D TRNS^PRSPRM1
43 I QUIT D KILL^PRSPRM1 Q
44 ; Prompt HR for any final reconciliation comments
45 D HRCOM^PRSPRM1
46 I X="^" D KILL^PRSPRM1 Q
47 ; Prompt HR is they want to print the form for the Chief of Staff
48 S QUIT=0
49 D PRT^PRSPRM1
50 I QUIT D KILL^PRSPRM1 Q
51 ; Prompt for E-sig and update file
52 D ESIG^PRSPRM1,KILL^PRSPRM1
53 Q
54 ;
55PTP ; Prompt for Part Time Physician
56 ;
57 W !
58 S DIC="^PRSPC(",DIC(0)="AEMQZ",DIC("A")="Select EMPLOYEE: "
59 S DIC("S")="I $D(^PRST(458.7,""B"",+Y))"
60 D ^DIC K DIC
61 S PRSIEN=+Y
62 Q
63 ;
64MEM ; Find any memorandums that meet the reconciliation qualifications
65 ;
66 N ENDAT,MEM,STDAT
67 S MEM=0,INDX=1
68 F S MEM=$O(^PRST(458.7,"B",PRSIEN,MEM)) Q:'MEM D
69 . D MEMDAT(MEM,.STATUS,.STDAT,.ENDAT,.TDAT)
70 . Q:STATUS'=3 ; Memos that have begun reconciliation have status = 3
71 . I $G(TDAT)>DT Q ; Termination Date has yet to occur
72 . Q:TDAT<1&(ENDAT>DT) ; Not Terminated and End Date has yet to occur
73 . S MEM(INDX)=MEM_"^"_STDAT_"^"_ENDAT_"^"_TDAT_"^"_"Reconciliation Started"
74 . S INDX=INDX+1
75 ; If no memos meet the reconciliation qualifications
76 I '$D(MEM(1)) D Q
77 . W !!,"No memorandums meet the reconciliation qualifications for the "
78 . W "selected employee."
79 . S MIEN=0
80 ; If only one memo
81 I '$D(MEM(2)) S MIEN=$P(MEM(1),U,1) Q
82 ; Display list if more than one
83 I $D(MEM(2)) D
84 . S MIEN=0
85 . W !!," # ",?5,"STARTS",?20,"ENDS",?35,"TERMINATION DATE"
86 . F MEM=1:1 Q:'$D(MEM(MEM)) D
87 . . S DATA=MEM(MEM)
88 . . S Y=$P(DATA,U,2)
89 . . D DD^%DT
90 . . S START=Y
91 . . S Y=$P(DATA,U,3)
92 . . D DD^%DT
93 . . S END=Y
94 . . S Y=$P(DATA,U,4)
95 . . I Y'="" D
96 . . . D DD^%DT
97 . . . S TDAT=Y
98 . . W !,MEM,?5,START,?20,END,?35,TDAT
99 . ;
100ASK . ; Ask user to select which memorandum they want
101 . S END="",END=$O(MEM(END),-1)
102 . W !!,"Enter a number between 1 and ",END," :"
103 . R ASK:DTIME
104 . S ASK=$$UPPER^PRSRUTL(ASK)
105 . Q:ASK=""!(ASK="^")
106 . I '$D(MEM(ASK)) D G ASK
107 . . W !!,"Enter a number between 1 and ",END," or ^ to exit"
108 . S MIEN=$P(MEM(ASK),U,1)
109 . S DATA0=$G(^PRST(458.7,MIEN,0)) ; Memo info
110 . S DATA4=$G(^PRST(458.7,MIEN,4)) ; Termination info
111 Q
112 ;
113MEMDAT(MEM,MST,MSD,MED,MTD) ;
114 ;RETURN MST- memo start date
115 ; MSD- memo stop date
116 ; MED- memo termination date
117 N DATA0,DATA4
118 S DATA0=$G(^PRST(458.7,MEM,0)) ; Memo info
119 S DATA4=$G(^PRST(458.7,MEM,4)) ; Termination info
120 S MST=$P(DATA0,U,6)
121 S MSD=$P(DATA0,U,2)
122 S MED=$P(DATA0,U,3)
123 S MTD=$P(DATA4,U,1)
124 Q
125DISPLAY ; Display memorandum info to validate the correct employee was chosen
126 W:$E(IOST,1,2)="C-" @IOF
127 S SCRTTL=" PT Physician Reconcile Memorandum"
128 S ARRAY="^TMP($J,""PRSPRM"","
129 D HDR^PRSPUT1(PRSIEN,SCRTTL,ARRAY,1)
130 D MEM^PRSPUT1(PRSIEN,MIEN,ARRAY)
131 D AL^PRSPUT3(PRSIEN,ARRAY)
132 D PPSUM^PRSPUT2(PRSIEN,MIEN,ARRAY)
133 S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR
134 Q
135 ;
136ESRCHK ; Check for any incomplete ESR within the memoranda.
137 ;
138 N PPDATA,TPPI
139 D INDEX^PRSPUT1 ; Get last index
140 W:$E(IOST,1,2)="C-" @IOF
141 W $P(^PRSPC(PRSIEN,0),U,1)_" - Memorandum Summary"
142 S QUIT=0
143 S TPPI=""
144 I TDAT'="" D
145 . S DATA4=$G(^PRST(458.7,MIEN,4))
146 . Q:'+DATA4
147 . S TPPI=+$G(^PRST(458,"AD",$P(DATA4,U,1)))
148 F I=1:1:26 D
149 . S PPDATA=$G(^PRST(458.7,MIEN,9,I,0))
150 . S PPE=$P(PPDATA,U,1)
151 . Q:PPE=""
152 . S PPI=$O(^PRST(458,"B",PPE,0))
153 . Q:'PPI
154 . Q:PPI>TPPI ; Quit if PP is after termination PP
155 . F DAY=1:1:14 D Q:QUIT
156 . . S ESRSTAT=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7)),U,1)
157 . . I ESRSTAT<5 S ^TMP($J,"RG",PPE)=""
158 . ; Check for NP in Pay Period
159 . I $P(PPDATA,U,3) S ^TMP($J,"NP",PPE)=$P(PPDATA,U,3)
160 . ; Check for WP in Pay Period
161 . I $P(PPDATA,U,4) S ^TMP($J,"WP",PPE)=$P(PPDATA,U,4)
162 I $D(^TMP($J,"RG"))=10 D
163 . S TEXT="The following Pay Periods have days with incomplete daily ESRs: "
164 . D A1^PRSPUT1
165 . S (PPE,PPEX)="",PPCNT=0
166 . F S PPE=$O(^TMP($J,"RG",PPE)) Q:PPE="" D
167 . . S PPEX=$S(PPEX="":PPE,1:PPEX_", "_PPE)
168 . . S PPCNT=PPCNT+1
169 . . I PPCNT>10 D
170 . . . S TEXT=PPEX,PPCNT=0,PPEX=""
171 . . . D A1^PRSPUT1
172 . I PPCNT>0 D
173 . . S TEXT=PPEX
174 . . D A1^PRSPUT1
175 . S TEXT=""
176 . D A1^PRSPUT1
177 . S TEXT="These will have to be completed before the memorandum can be reconciled."
178 . D A1^PRSPUT1,A1^PRSPUT1
179 ;
180NP ; Check for Non-Pay hours
181 I $D(^TMP($J,"NP"))=10 D
182 . S TEXT="The following Pay Periods have Non-Pay hours:"
183 . D A1^PRSPUT1
184 . S PPE="",PPCNT=0,PPEX=""
185 . F S PPE=$O(^TMP($J,"NP",PPE)) Q:'PPE D
186 . . S PPEX1=PPE_" - "_^TMP($J,"NP",PPE),$E(PPEX1,15)=""
187 . . S PPEX=PPEX_PPEX1
188 . . S PPCNT=PPCNT+1
189 . . I PPCNT>4 D
190 . . . S TEXT=PPEX,PPCNT=0,PPEX=""
191 . . . D A1^PRSPUT1
192 . I PPCNT>0 D
193 . . S TEXT=PPEX
194 . . D A1^PRSPUT1
195 ;
196 ; Check for Without-Pay hours
197WP I $D(^TMP($J,"WP"))=10 D
198 . S TEXT="The following Pay Periods have Without-Pay hours:"
199 . D A1^PRSPUT1
200 . S PPE="",PPCNT=0,PPEX=""
201 . F S PPE=$O(^TMP($J,"WP",PPE)) Q:'PPE D
202 . . S PPEX1=PPE_" - "_^TMP($J,"WP",PPE),$E(PPEX1,15)=""
203 . . S PPEX=PPEX_PPEX1
204 . . S PPCNT=PPCNT+1
205 . . I PPCNT>4 D
206 . . . S TEXT=PPEX,PPCNT=0,PPEX=""
207 . . . D A1^PRSPUT1
208 . I PPCNT>0 D
209 . . S TEXT=PPEX
210 . . D A1^PRSPUT1
211 K ^TMP($J,"RG"),^TMP($J,"NP"),^TMP($J,"WP")
212 Q
Note: See TracBrowser for help on using the repository browser.