source: FOIAVistA/trunk/r/PAID-PRS/PRSPUT3.m@ 649

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

initial load of FOIAVistA 6/30/08 version
File size: 9.1 KB
Line 
1PRSPUT3 ;WOIFO/MGD,JAH - PART TIME PHYSICIAN UTILITIES #1 ;03/23/07
2 ;;4.0;PAID;**93,112**;Sep 21, 1995;Build 54
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;Utilities for Part Time Physician patch PRS*4.0*93.
6 ;
7PTP(PRSIEN) ;Check for potential PTP (has a memo on file)
8 ; input PRSIEN = employee IEN (file 450)
9 ; result = 1 or 0, true (1) if employee has any memos on file
10 Q $S($O(^PRST(458.7,"B",PRSIEN,0)):1,1:0)
11 ;
12 ;-----------------------------------------------------------------------
13 ; Display PTP AL info
14 ; Input: PRSIEN - IEN of PT Physician
15 ; ARRAY - Array where leave info is stored. (Optional) If not
16 ; specified, no array is created.
17 ; INDEX - Index to start array. (optional) set to 1 if not spec
18 ; Output: 2 line summary-current AL bal, fut reqs and potential loss.
19 ;-----------------------------------------------------------------------
20AL(PRSIEN,ARRAY,INDEX) ;
21 Q:'PRSIEN
22 I $G(INDEX)="",($G(ARRAY)'="") D INDEX^PRSPUT1
23 N AINC,ALBAL,ALTBL,APALHRS,EOLYD,LVG,TEXT,X,X1,X2,Y,MAYLOSE,LDPINV
24 ;
25 ; Max Carryover
26 S MAXOVER=240
27 ;
28 ; current AL bal
29 S ALBAL=$P($G(^PRSPC(PRSIEN,"ANNUAL")),U,3)
30 ;
31 ; last day of curr leave yr
32 S EOLYD=$$GETLDOYR()
33 ;
34 ; last day proc from 459 & inverse
35 S LDP=$P($G(^PRST(458,$O(^PRST(458,"AB",$O(^PRST(459,"AB",""),-1),0)),1)),U,14)
36 S LDPINV=9999999-LDP
37 ;
38 ; future al approved (ranges from LastDayProcessed459-EndOfLeaveYear)
39 ; This is an estimate since we count all hrs for reqs that begin in
40 ; the current yr but cross into next
41 S APALHRS=$$GETAPALH(PRSIEN,LDPINV,EOLYD)
42 ;
43 ; accrual from last pp proc to EOY
44 S ACCRUAL=$$GETACCRU(PRSIEN,EOLYD,LDP)
45 ;
46 ; potential loss
47 S MAYLOSE=$$GETLOSE(APALHRS,ALBAL,ACCRUAL,MAXOVER)
48 ;
49 ; Display
50 S TEXT=""
51 D A1^PRSPUT1 ; Blank line
52 S TEXT="AL Bal: "_$J(ALBAL,6,2)
53 S $E(TEXT,17)="",TEXT=TEXT_"Approved future AL thru Leave Year: "
54 S TEXT=TEXT_$J(APALHRS,6,2)
55 S $E(TEXT,60)="",TEXT=TEXT_"Max carryover: "_MAXOVER
56 D A1^PRSPUT1 ; Line #1
57 S Y=EOLYD
58 D DD^%DT
59 S TEXT="Potential AL hours to be lost by "_Y_" excluding Approved AL: "
60 S TEXT=TEXT_MAYLOSE
61 D A1^PRSPUT1 ; Line #2
62 K INDEX
63 Q
64 ;
65GETACCRU(PRSIEN,EOLYD,LDP) ; Calculate AL accrucal from last day of
66 ; pp processed in 459 (LDP) to end of leave year (EOLYD)
67 ;
68 N CO,LVG,NH,DB,AINC,X1,X2,INC
69 ;
70 S C0=$G(^PRSPC(PRSIEN,0)),LVG=$P(C0,"^",15),NH=+$P(C0,"^",16)
71 S DB=$P(C0,"^",10),AINC=""
72 Q:LVG'?1N!("123"'[LVG) 0
73 I LVG=1 D ; Leave Group 1
74 . S AINC=$S(DB=1:4,1:NH+AINC/20\1)
75 I LVG=2 D ; Leave Group 2
76 . S AINC=$S(DB=1:6,1:NH+AINC/13\1)
77 I LVG=3 D ; Leave Group 3
78 . S AINC=$S(DB=1:8,1:NH+AINC/10\1)
79 S X1=EOLYD,X2=LDP
80 D ^%DTC
81 S INC=X+13\14*AINC
82 Q INC
83 ;
84GETLOSE(APALHRS,ALBAL,ACCRUAL,MAXOVER) ; Calculate potential hours to be lost
85 N ALTBL
86 S ALTBL=ALBAL+ACCRUAL-MAXOVER-APALHRS
87 Q $S(ALTBL<0:0,1:ALTBL)
88 ;
89GETLDOYR() ; Calculate last day of the last pp of current year (EOLY)
90 N X,I,X1,X2,NEXTYR,PRSYRDT
91 S PRSYRDT=$P($T(DAT^PRSAPPU),";;",2)
92 F I=1:1 S NEXTYR=$P(PRSYRDT,",",I) Q:NEXTYR>DT!(NEXTYR="")
93 I NEXTYR="" Q DT
94 S X1=NEXTYR,X2=-1
95 D C^%DTC
96 Q X
97 ;
98GETAPALH(PRSIEN,PPPIN,EOLYD) ; Approved AL hrs
99 ;
100 N APALHRS,EOLYDINV,LREND,LRIEN,LRSTRT,LRDATA
101 ;
102 S APALHRS=0 ; COUNTER-APproved Annual Leave HouR
103 S EOLYDINV=9999999-EOLYD
104 ;
105 ; use inverse dt to loop chrono from future requests to recent ones
106 ; Quit when end date hits last proc pp. Don't include canceled & other
107 ; leave type reqs from AD index.
108 ;
109 S LREND=0
110 F S LREND=$O(^PRST(458.1,"AD",PRSIEN,LREND)) Q:(LREND'>0)!(LREND>PPPIN) D
111 . S LRIEN=0
112 . F S LRIEN=$O(^PRST(458.1,"AD",PRSIEN,LREND,LRIEN)) Q:LRIEN'>0 D
113 . . S LRSTRT=^PRST(458.1,"AD",PRSIEN,LREND,LRIEN)
114 . . S LRSTRT=9999999-LRSTRT
115 . . ;
116 . . ; skip if lv doesn't start in range-last pp proc to EOLY
117 . . Q:LRSTRT'<PPPIN!(LRSTRT'>EOLYDINV)
118 . . ; skip if not AL or App
119 . . S LRDATA=$G(^PRST(458.1,LRIEN,0))
120 . . Q:$P(LRDATA,U,7)'="AL"!($P(LRDATA,U,9)'="A")
121 . . S APALHRS=APALHRS+$P(LRDATA,U,15)
122 Q APALHRS
123 ;
124 ;-----------------------------------------------------------------------
125 ; Utility updates ESR Status and autopost any holidays
126 ;
127 ; Input:
128 ; PPI - The internal entry number of the PP
129 ; PRSIEN - The internal entry number of the PT Phy
130 ; DAY - (optional) If passed in the specific date (1-14) that
131 ; needs to be updated. If a specific date is not
132 ; passed in all 14 days will be reviewed and updated
133 ; as necessary.
134 ;
135 ; HOL and PDT need to be set by calling ^PRSAPPH prior to making this
136 ; call.
137 ;
138ESRUPDT(PPI,PRSIEN,DAY) ;
139 ;
140 N END,HTOUR,IENS,MT,PRSFDA,START,STATUS,STOP,TOUR
141 S DAY=$G(DAY,"")
142 S START=$S(DAY:DAY,1:1)
143 S END=$S(DAY:DAY,1:14)
144 F DAY=START:1:END D
145 . S TOUR=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,0)),U,2)
146 . S STATUS=$S(TOUR>1:1,1:6)
147 . S IENS=DAY_","_PRSIEN_","_PPI_","
148 . K PRSFDA
149 . S PRSFDA(458.02,IENS,146)=STATUS
150 . I $D(HOL($P(PDT,U,DAY))) D
151 . . S HTOUR=$G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,1))
152 . . Q:HTOUR=""
153 . . S MT=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,0)),U,2)
154 . . S MT=$P($G(^PRST(457.1,MT,0)),U,3)
155 . . F I=0:1:6 Q:$P(HTOUR,U,(3*I)+1)="" D
156 . . . S START=$P(HTOUR,U,(3*I)+1),STOP=$P(HTOUR,U,(3*I)+2)
157 . . . S PRSFDA(458.02,IENS,110+(5*I))=START
158 . . . S PRSFDA(458.02,IENS,111+(5*I))=STOP
159 . . . S PRSFDA(458.02,IENS,112+(5*I))="HX"
160 . . S PRSFDA(458.02,IENS,146)=4 ; ESR DAILY STATUS = SIGNED
161 . . S PRSFDA(458.02,IENS,101)="" ; Reset timecard status to unposted.
162 . . S PRSFDA(458.02,IENS,114)=MT ; Meal time for 1st segment
163 . . S PRSFDA(458.02,IENS,147)=$$NOW^XLFDT() ; Date/Time stamp
164 . . S PRSFDA(458.02,IENS,149)=4 ; ESR Signed by Holiday
165 . D UPDATE^DIE("","PRSFDA","IENS"),MSG^DIALOG()
166 Q
167 ;
168MEMCPP(MIEN) ; Memo Certified PP
169 ; This utility determine the last certified PP and the number of
170 ; certified PPs for a given memo.
171 ; input
172 ; MIEN - internal entry number of a memo in file 458.7
173 ; returns a string value
174 ; = last certified PP (external value)^number of certified PPs
175 ; example "05-01^3"
176 ;
177 N LASTPP,MPPIEN,PPC,PRSX
178 I '$G(MIEN) Q "^"
179 ;
180 S LASTPP="" ; last PP
181 S PPC=0 ; pp counter
182 ; loop thru PPs in memo
183 S MPPIEN=0 F S MPPIEN=$O(^PRST(458.7,MIEN,9,MPPIEN)) Q:'MPPIEN D
184 . S PRSX=$G(^PRST(458.7,MIEN,9,MPPIEN,0))
185 . Q:$P(PRSX,U,2)="" ; REG HOURS is null so PP never certified
186 . S LASTPP=$P(PRSX,U,1)
187 . S PPC=PPC+1
188 ;
189 Q LASTPP_"^"_PPC
190 ;
191PP8BAMT(PPAMT,PPI,PRSIEN) ; array TIMEAMTS passed by reference
192 ; subscripted w/ types of time CODE and type of time activity
193 ; from PRS8VW2 table. This routine sets each node of TIMEAMTS array
194 ; to the total hours (week one and two) in the pp
195 ; for that type of time activity.
196 ;
197 ; SAMPLE CALL:
198 ; S TAMTS("WP","Leave Without Pay")="" D PP8BTOT(.TAMTS,PPI,PRSIEN)
199 ;
200 ; SAMPLE RETURN ARRAY
201 ; TAMTS("WP","Leave Without Pay")=12.5
202 ;
203 N TT,STR8B,TC,TA,WK1CD,WK2CD,AMT1,AMT2
204 S STR8B=$$GET8B(PPI,PRSIEN)
205 S TC=""
206 F S TC=$O(PPAMT(TC)) Q:TC="" D
207 . S TA=""
208 . F S TA=$O(PPAMT(TC,TA)) Q:TA="" D
209 .. S WK1CD=$$WKTT(TC,TA,1)
210 .. S WK2CD=$$WKTT(TC,TA,2)
211 .. S AMT1=$$EXTR8BT(STR8B,WK1CD)
212 .. S AMT2=$$EXTR8BT(STR8B,WK2CD)
213 .. S PPAMT(TC,TA)=AMT1+AMT2
214 Q
215GET8B(PPI,PRSIEN) ; get 8b from 5 node unless corrected timecard
216 ; has been done then we need to recompute 8B
217 N S8B
218 I $$CORRECT(PPI,PRSIEN) D
219 . N DFN,PY,VAL
220 .; new variables used BY callers to this API because the decomp
221 .; kills everything in its path.
222 . N QT,PP,%,C0,CNT,CT,D,DAY,HDR,I,K,MEAL,SSN,ST,TT,TYP,X,X1,Y,Y1,Z,ML,Z0,Z1
223 . S DFN=PRSIEN
224 . S PY=PPI
225 . D ONE^PRS8
226 . S S8B=$E($G(VAL),33,999)
227 E D
228 . S S8B=$E($G(^PRST(458,PPI,"E",PRSIEN,5)),33,999)
229 Q S8B
230CORRECT(PPI,PRSIEN) ; return true if any corrected timecards exist for
231 ;this emp's pp that were approved by the final level supr apprl
232 N CORRECT,STATUS,TCD
233 S CORRECT=0
234 Q:($G(PPI)'>0)!($G(PRSIEN)'>0)
235 S TCD=0
236 F S TCD=$O(^PRST(458,PPI,"E",PRSIEN,"X",TCD)) Q:TCD'>0!(CORRECT) D
237 . S STATUS=$P($G(^PRST(458,PPI,"E",PRSIEN,"X",TCD,0)),U,5)
238 . I STATUS="P"!(STATUS="S") S CORRECT=1
239 Q CORRECT
240EXTR8BT(S,T) ; EXTRACT THE 8B TYPE OF TIME FROM THE STUB AND RETURN THE
241 ; AMOUNT OF TIME FROM WEEK ONE AND TWO FOR THIS TYPE OF TIME
242 ; INPUT: S-8B STUB
243 ; T-TYPE OF TIME TO FIND ^ LENGTH OF DATA IN 8B
244 N AMT,LEN,POS,QH,HRS
245 S AMT="0.0"
246 S POS=$F(S,$P(T,U))
247 I POS D
248 . S LEN=$P(T,U,2)
249 . S AMT=$E(S,POS,POS-1+LEN)
250 . S HRS=+$E(AMT,1,LEN-1)
251 . S QH=+$E(AMT,LEN,LEN)
252 . S QH=$S(QH=1:".25",QH=2:".5",QH=3:".75",1:".0")
253 . S AMT=HRS_QH
254 Q AMT
255 ;
256WKTT(T,TA,WK) ; GET 8B STRING TIMECODE FOR WEEK ONE OR TWO AND LENGTH OF
257 ; THE DATA IN THE 8B STRING
258 ; Input:
259 ; T- type of time code from file 457.3
260 ; TA-time activity from the table in PRS8VW2 (e.g. Leave Without Pay)
261 ; WK-1 or 2 for the desired timecode week
262 ;
263 S WK=$S($G(WK)=2:2,1:1)
264 Q:$G(T)=""
265 N TCH1,TTEXT,CHKLN,I,FOUND,E,TTABLE,CHUNK,TABLEI,WKTTCODE
266 S FOUND=0
267 ;
268 S TCH1=$E(T,1,1)
269 D E2^PRS8VW
270 S CHKLN=$P($T(@(TCH1)+0^PRS8VW2),";;",2)
271 F I=1:1:$L(CHKLN,"^") D Q:FOUND
272 . S CHUNK=$P(CHKLN,U,I)
273 . S TABLEI=$P(CHUNK,":",2)
274 . S WKTTCODE=TCH1_$P(CHUNK,":")
275 . S TTABLE=$P($T(TYP+TABLEI^PRS8VW2),";;",2)
276 . I TTABLE=TA,$F(E(WK),WKTTCODE) D
277 .. S FOUND=1
278 ..; When found in PRS8VW2 table return code and length
279 .. S WKTTCODE=WKTTCODE_U_$P(CHUNK,":",3)
280 I 'FOUND S WKTTCODE=0
281 Q WKTTCODE
Note: See TracBrowser for help on using the repository browser.