source: WorldVistAEHR/trunk/r/PAID-PRS/PRSPSAP2.m@ 1789

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

initial load of WorldVistAEHR
File size: 8.4 KB
Line 
1PRSPSAP2 ;WOIFO/JAH - Supervisor Approve-update pt phys timecard ;7/26/05
2 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 Q
5TRANSACT ; TRANSfer ACTions to the database
6 ; loop thru temp and update the time card and the ESR day stats
7 N ACT,PRSIEN,PPI,PRSD
8 S PRSIEN=""
9 F S PRSIEN=$O(^TMP($J,"PRSPSAP",PRSIEN)) Q:PRSIEN'>0 D
10 . S PPI=0
11 . F S PPI=$O(^TMP($J,"PRSPSAP",PRSIEN,PPI)) Q:PPI'>0 D
12 .. S PRSD=0
13 .. F S PRSD=$O(^TMP($J,"PRSPSAP",PRSIEN,PPI,PRSD)) Q:PRSD'>0 D
14 ... S ACT=$G(^TMP($J,"PRSPSAP",PRSIEN,PPI,PRSD,1))
15 ...; Ignore ESR days that the superV skipped or bypassed.
16 ... Q:(ACT="")!(ACT="B")
17 ...;
18 ...; set ESR day status to resubmit and add remarks
19 ... I ACT="R" D
20 .... S REM=$G(^TMP($J,"PRSPSAP",PRSIEN,PPI,PRSD,2))
21 .... D UPESR(PRSIEN,PPI,PRSD,ACT,REM)
22 ... E D
23 ....; try to update the timecard and the ESR
24 .... N CAN S (CAN("CB"),CAN("AE"))=0
25 .... D UPTCARD(.CAN,PRSIEN,PPI,PRSD)
26 .... I CAN("AE") D UPESR(PRSIEN,PPI,PRSD,ACT,"")
27 .... I CAN("CB") D PTP^PRSASR1(PRSIEN,PPI)
28 Q
29UPESR(PRSIEN,PPI,PRSD,ACT,REM) ; update ESR with either Resubmit OR Approve
30 N PRSFDA,IENS
31 ;
32 ; update ESR status and display any filing errors
33 ;
34 S IENS=PRSD_","_PRSIEN_","_PPI_","
35 S PRSFDA(458.02,IENS,146)=$S(ACT="A":"APPROVED",1:"RESUBMIT")
36 I $G(REM)'="" S PRSFDA(458.02,IENS,148)=REM
37 D FILE^DIE("E","PRSFDA")
38 D MSG^DIALOG()
39 Q
40 ;
41UPTCARD(CAN,PRSIEN,PPI,PRSD) ; UPDATE A TIME CARD
42 ; WITH ESR LEAVE EXCEPTIONS AND HOLIDAY X
43 ; Return CAN by reference.
44 ; CAN("AE") "CAN APPROVE ESR" is set to true if the ESR can be
45 ; approved. i.e. timecard status is T-timekeep or there's
46 ; no affect on the timecard
47 ; CAN("CB") "CAN CALL BANK" is set to true when a call should be
48 ; made to the hours bank API (PTP^PRSASR1).
49 ; Calling routines must consider the order in which
50 ; to APPROVE ESR and CALL HOURS BANK since the API
51 ; PTP^PRSASR, will only count hrs with an approved status.
52 ;
53 ;458.02 (DAY MULTIPLE)
54 ; FIELD: 10 TOUR LAST POSTED BY^P200
55 ; identifies last person to post a tour for employee
56 ; 101 POSTING STATUS^S^T:TIMEKEEPER POSTED;
57 ; P:PAYROLL REVIEWED;X:TRANSMITTED;
58 ; 102 TIMEKEEPER POSTING^P200'^VA(200,
59 ; 103 TK DATE/TIME ENTERED^DATE
60 ; 104 POSTING TYPE^S^1:WORKED ENTIRE TOUR;
61 ; 2:ABSENT ENTIRE TOUR;3:IRREGULAR TOUR;
62 N TCN,ESRN,POST,PSTDT,POSTER,PTYPE
63 N TCSTAT,DYSTAT,DUMB,POSTYPE,TOD,EARY,ERRORS
64 S (CAN("CB"),CAN("AE"))=0
65 ;get the raw posting from the ESR
66 S ESRN=$G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,5))
67 ; day signed on ESR with no work OR get the work segments
68 I $P(ESRN,U)'="" S ESRN=$$GETAPTM(ESRN)
69 ;get the timecard node
70 S TCN=$G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,2))
71 S POST=$G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,10))
72 S PSTDT=$P(POST,U)
73 S DYSTAT=$P(POST,U,2)
74 S POSTER=$P(POST,U,3)
75 S POSTYPE=$P(POST,U,4)
76 ; if the timecard is still with timekeep it can be updated.
77 S TCSTAT=$$TCSTAT(PPI,PRSIEN)
78 I TCSTAT="T" D
79 . S CAN("AE")=1,CAN("CB")=0
80 . D EDTCARD(PPI,PRSIEN,PRSD,ESRN)
81 E D
82 . ;if timecard is in a payroll or transmit we can check
83 . ; for any affect to TimeCard from the ESR. If none
84 .; we can update the ESR to approved and we should make a
85 .; a call to the hours bank after ESR is set to apporved
86 .; the hours bank and quit
87 .; otherwise we have to either return timecard or do corrcted timecard
88 .;
89 .; If timecard has no postings and ESR has no exceptions
90 .; the ESR can be approved since no change to timecard is necessary
91 . I ESRN=""&(TCN="") S (CAN("AE"),CAN("CB"))=1 Q
92 .;
93 .; if ESR matches Timecard, update ESR no Timecard update necessary
94 . D CMPESRTC^PRSPSAP3(.ERRORS,.EARY,"","",PPI,PRSIEN,PRSD)
95 . I ERRORS=0 S (CAN("AE"),CAN("CB"))=1 Q
96 . I "^P^X^"["^"_TCSTAT_"^" S (CAN("AE"),CAN("CB"))=0 D Q
97 .. D CANTPOST^PRSPSAP3(.EARY,TCSTAT,PPI,PRSIEN,PRSD,ESRN)
98 .. S DUMB=$$ASK^PRSLIB00(1)
99 Q
100EDTCARD(PPI,PRSIEN,PRSD,ESRN) ; edit the timecard
101 ;
102 N EDTSTR,CLEAR,POSTTIME,PRSFDA,IENS
103 ;
104 ; if there's no work, no leave or only RG then ptp gets credit for
105 ; entire day, otherwise we have some exceptions. If the physician
106 ; used leave the entire day then don't post meal and set ptype=2
107 ;
108 S CLEAR=$$CLRTCDY^PRSPSAPU(PPI,PRSIEN,PRSD,5)
109 S PTYPE=$S($P(ESRN,U)="":1,1:3)
110 I PTYPE=3 D
111 . I $$ABSENT(ESRN,PPI,PRSIEN,PRSD) S PTYPE=2
112 . S TCN=$$ESR2TC(ESRN,PTYPE)
113 .; update the timecard with a global set
114 . S ^PRST(458,PPI,"E",PRSIEN,"D",PRSD,2)=TCN
115 ;
116 ; update timecard status
117 N %,X,%I,%H D NOW^%DTC S POSTTIME=%
118 ;
119 ; update timecard status and display any filing errors
120 ;
121 S IENS=PRSD_","_PRSIEN_","_PPI_","
122 S PRSFDA(458.02,IENS,101)="T"
123 S PRSFDA(458.02,IENS,102)=DUZ
124 S PRSFDA(458.02,IENS,103)=POSTTIME
125 S PRSFDA(458.02,IENS,104)=PTYPE
126 D FILE^DIE("","PRSFDA")
127 D MSG^DIALOG()
128 Q
129 ;
130ESR2TC(ESRN,PT) ;CONVERT ESR DATA TO TIMECARD FORMAT
131 ;
132 N ESR2TC,TCS,I,TSEG,ST,EN,TT,RE,ML,TCN
133 ;
134 S TCN=""
135 F I=1:5:31 D
136 . S TSEG=$P(ESRN,U,I,I+4)
137 . S ST=$P(TSEG,U)
138 . Q:ST=""
139 . S EN=$P(TSEG,U,2)
140 . S TT=$P(TSEG,U,3)
141 . S RE=$P(TSEG,U,4)
142 . S ML=$P(TSEG,U,5)
143 .; if meal posted remove it from leave end time
144 . I (PT=3)&(ML>0) S EN=$$ENDML(EN,ML)
145 . S:$G(TCN)'="" TCN=TCN_"^"
146 . S TCS=ST_U_EN_U_TT_U_RE
147 . S TCN=TCN_TCS
148 ; REMOVE A TRAILING UPARROW GENERATED BY NULL REMARKS CODE
149 I $E(TCN,$L(TCN))=U S TCN=$E(TCN,1,$L(TCN)-1)
150 Q TCN
151 ;
152 ;
153ABSENT(ESRN,PPI,PRSIEN,PRSD) ;return true if the ESR posting matches all
154 ; the tour start and stop times and uses only one type of leave and
155 ; the meal matches the tours meal.
156 ; i.e. ESR posting equivalent to absent entire tour question.
157 ;
158 N TR1,TR2,TR1ML,TR2ML,TRMEAL,LASTTT,MULTITT,NODE0,RETURN,TCT
159 N TCS,I,TSEG,ST,EN,TT,ML,TCTOUR,ESRTOUR
160 ;
161 S (ESRTOUR,LASTTT)="",(MULTITT,ML,RETURN)=0
162 F I=1:5:31 D
163 . S TSEG=$P(ESRN,U,I,I+4)
164 . S ST=$P(TSEG,U)
165 . Q:ST=""
166 . S EN=$P(TSEG,U,2)
167 . S TT=$P(TSEG,U,3)
168 . I LASTTT="" D
169 .. S LASTTT=TT
170 . E D
171 .. I LASTTT'=TT S MULTITT=1
172 . S ML=ML+$P(TSEG,U,5)
173 . S:$G(ESRTOUR)'="" ESRTOUR=ESRTOUR_"^"
174 . S TCS=ST_U_EN
175 . S ESRTOUR=ESRTOUR_TCS
176 ; REMOVE A TRAILING UPARROW GENERATED BY NULL REMARKS CODE
177 I $E(ESRTOUR,$L(ESRTOUR))=U S ESRTOUR=$E(ESRTOUR,1,$L(ESRTOUR)-1)
178 ;
179 ;
180 S TCT=$G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,1))
181 S NODE0=$G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0))
182 S (TR1ML,TR2ML)=0
183 S TR1=$P(NODE0,U,2) I TR1>0 S TR1ML=$P($G(^PRST(457.1,TR1,0)),U,3)
184 S TR2=$P(NODE0,U,15) I TR2>0 S TR2ML=$P($G(^PRST(457.1,TR2,0)),U,3)
185 S TRMEAL=TR1ML+TR2ML
186 S TCTOUR=""
187 F I=1:3:31 D
188 . S TSEG=$P(TCT,U,I,I+4)
189 . S ST=$P(TSEG,U)
190 . Q:ST=""
191 . S EN=$P(TSEG,U,2)
192 . S:$G(TCTOUR)'="" TCTOUR=TCTOUR_"^"
193 . S TCS=ST_U_EN
194 . S TCTOUR=TCTOUR_TCS
195 I (TCTOUR=ESRTOUR)&('MULTITT)&(TRMEAL=ML) S RETURN=1
196 Q RETURN
197 ;
198ENDML(END,MEAL) ;GET AN END TIME AND DEDUCT THE MEAL FROM IT
199 ;
200 N X
201 ; quit if we aint gots a good enought end time.
202 Q:($G(END)'?2N.P.2N.A)&(END'="MID")&(END'="NOON") $G(END)
203 S END=$$TWENTY4^PRSPESR2(END)
204 S END=$E(END,1,2)_":"_$E(END,3,4)
205 S END=$$MEALCUT(END,MEAL)
206 ; Convert back to form stored in 458 start stop times
207 S X=END D ^PRSATIM S END=X
208 Q END
209 ;
210MEALCUT(HHMM,MEAL) ;Subtract meal time from the end time
211 ; (subtract a 15 minute increment from length of time
212 ; in hh:mm format, i.e. hh:mm - mm
213 ;
214 N X,Y,DECR,OBJ,I,HH,MM
215 S MM=$P(HHMM,":",2) ; get minutes
216 ; quit minutes or meal not quarter hours
217 Q:(MM#15'=0&(+MM)!((MEAL#15)'=0&(+MEAL))) HHMM
218 ; get hours
219 S HH=$P(HHMM,":")
220 ;
221 ; convert segment minutes and meal to a digit.
222 ;
223 S X=MM D MEALIN^PRSPESR2 S OBJ=X
224 S X=$G(MEAL) D MEALIN^PRSPESR2 S DECR=X
225 I OBJ=0 S OBJ=4
226 F I=1:1:DECR D
227 . I OBJ=4 D
228 .. I +HH=0 D
229 ... S HH=23
230 .. E D
231 ... S HH="0"_(+HH-1) S HH=$E(HH,$L(HH)-1,$L(HH))
232 . S OBJ=$S(OBJ=4:3,OBJ=3:2,OBJ=2:1,OBJ=1:4)
233 S MM=$S(OBJ=1:15,OBJ=2:30,OBJ=3:45,1:"00")
234 ;
235 Q HH_MM
236 ;
237TCSTAT(PPI,PRSIEN) ; get timecard status
238 Q:(PPI'>0)!(PRSIEN'>0) 0
239 Q $P($G(^PRST(458,PPI,"E",PRSIEN,0)),U,2)
240 ;
241GETAPTM(WORK) ; return the work node with only the time that should
242 ; be posted to a PTP's timecard
243 ; INPUT: WORK : ESR work node
244 ; RETURN ESRN : ESR node with only time applicable to PTP's
245 ;
246 N I,TSEG
247 S TCN=""
248 F I=1:5:31 D
249 . S TSEG=$P(WORK,U,I,I+4)
250 . S TT=$P(TSEG,U,3)
251 . Q:TSEG="^^^^"!("^HX^AL^AA^DL^ML^RL^SL^CB^AD^WP^TR^TV^"'[(U_TT_U))
252 . S TCN=TCN_TSEG_"^"
253 Q TCN
254 ;
255 ;
Note: See TracBrowser for help on using the repository browser.