source: WorldVistAEHR/trunk/r/PAID-PRS/PRSARC01.m@ 949

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

initial load of WorldVistAEHR
File size: 9.2 KB
Line 
1PRSARC01 ;WOIFO/JAH - Recess Tracking ListManger Action Protocols ;10/17/06
2 ;;4.0;PAID;**112**;Sep 21, 1995;Build 54
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 Q
5 ; ^TMP("PRSSW",$J) index of user selected weeks.
6 ; ^TMP("PRSRW",$J) index of recess weeks with hours.
7 ;
8EDITSTRT ; action protocol-edit AWS Start Date
9 ;
10 N RWREC
11 S VALMBCK="R"
12 I $G(PRSVIEW) D VWMSG^PRSARC03(1) Q
13 N OUT
14 D FULL^VALM1
15 W @IOF,!
16 ;
17 W !," WARNING: Changing the AWS start date will remove recess hours"
18 W !," that are earlier than the new AWS start date.",!
19 S OUT=$$ASK^PRSLIB00()
20 S VALMBCK="R"
21 Q:OUT
22 N PRSDTTMP
23 S PRSDTTMP=PRSDT
24 D NEWSTART^PRSARC03(.OUT,.PRSDT)
25 I OUT S PRSDT=PRSDTTMP Q
26 ;
27 S RWREC=$P(PRSFY,U,9)
28 I RWREC>0 D GETFLWKS^PRSARC03(RWREC,PRSDT)
29 S PRSRWHRS=$$GETAVHRS^PRSARC04(.FMWKS,PRSDT)
30 N FIRSTRW
31 S FIRSTRW=$O(^TMP("PRSRW",$J,0))
32 I $G(FIRSTRW)>0 S FIRSTRW=+^TMP("PRSRW",$J,FIRSTRW)
33 S VALMBG=$S($G(FIRSTRW)>3:FIRSTRW-1,1:1)
34 Q
35 ;
36SETWKHRS(OUT) ;set hrs for selected weeks
37 ;
38 N RH1,RH2,OTHERHRS,UOH,CTRH1,CTRH2,UCTH
39 S VALMBCK="R"
40 D FULL^VALM1
41 W @IOF,!
42 I '$D(^TMP("PRSSW",$J)) D Q
43 . W !,"No weeks have been selected."
44 . S OUT=$$ASK^PRSLIB00(1)
45 . S VALMBCK="R"
46 ;
47 D WHATHRS(.OUT,.RH1,.RH2,.OTHERHRS,.UOH,.CTRH1,.CTRH2,.UCTH)
48 I $G(OUT) S VALMBCK="R" Q
49 ;
50 D SETWKSLM(.OOPSWKS,RH1,RH2,OTHERHRS,UOH,CTRH1,CTRH2,UCTH)
51 ;
52 I $G(OOPSWKS)'="" S VALMSG="No tour data for the following weeks: "_$P(OOPSWKS,1,$L(OOPSWKS,",")-1)
53 ;
54 D DSELALL
55 S VALMBCK="R"
56 Q
57WHATHRS(OUT,RH1,RH2,OTHERHRS,UOH,CTRH1,CTRH2,UCTH) ;Ask user-which hours
58 ; to use.
59 ;
60 ; UCTH-use current tour hours flag
61 ; get current ToD hrs for week 1,2-ask whether to use hrs for recess.
62 ;
63 N DIR,Y,I
64 S (CTRH1,CTRH2,RH1,RH2,OTHERHRS,UOH,UCTH)=0
65 N PPI S PPI=$O(^PRST(458,999999),-1)
66 N TH D TOURHRS^PRSARC07(.TH,PPI,+PRSNURSE,"")
67 S CTRH1=TH("W1"),CTRH2=TH("W2")
68 I CTRH1>0!(CTRH2>0) D
69 . S UOH=1
70 . S OTHERHRS=$$OTHERHRS^PRSARC03(CTRH1,CTRH2,+PRSNURSE)
71 . I OTHERHRS D
72 .. S DIR("A")="Set recess to match tour hours from the timecard (Recommended)"
73 .. S DIR("?",1)=" You have selected weeks in the past that have tour hours"
74 .. S DIR("?",2)=" on the nurses' timecard that are different than the"
75 .. S DIR("?",3)=" current tour hours."
76 .. S DIR("?",4)=""
77 .. S DIR("?",5)="Current tour of duty hours are as follows:"
78 .. S DIR("?",6)=" Week 1 of pay period: "_TH("W1")
79 .. S DIR("?",7)=" Week 2 of pay period: "_TH("W2")
80 .. S I=0 F S I=$O(DIR("?",I)) Q:I'>0 W !,DIR("?",I)
81 .. S DIR("B")="YES"
82 .. S DIR(0)="Y"
83 .. D ^DIR
84 .. S (UOH,UCTH)=+Y
85 . I 'OTHERHRS!(UOH=0) D
86 .. S DIR("A")="Set recess hours to current tour of duty hours"
87 .. S DIR("?",1)="Current tour of duty hours are as follows:"
88 .. S DIR("?",2)=" Week 1 of pay period: "_TH("W1")
89 .. S DIR("?",3)=" Week 2 of pay period: "_TH("W2")
90 .. S DIR("?",4)=""
91 .. S DIR("?",5)="Choose yes to mark recess weeks with current tour of duty hours"
92 .. S DIR("?",6)="for week 1 and 2."
93 .. S DIR("?")="Enter yes or no."
94 .. S DIR("B")="YES"
95 .. S DIR(0)="Y"
96 .. S I=0 F S I=$O(DIR("?",I)) Q:I'>0 W !,DIR("?",I)
97 .. D ^DIR
98 .. S UCTH=Y
99 E D
100 . W !,"There are no tour hours in the current pay period."
101 . S UCTH=0
102 ;
103 I $D(DIRUT) Q
104 ;
105 N ODD,EVEN
106 I 'UCTH D
107 . ; return true if there are odd or even pp weeks in the selection
108 . D EVEODDWK^PRSARC03(.ODD,.EVEN)
109 . I ODD D
110 .. K DIR,Y
111 .. S DIR("B")=40
112 .. S DIR("A")="Enter recess hours for the 1st week of the pay period"
113 .. S DIR("?")="Pay period week 1 hours. Enter the recess hours for selected weeks."
114 .. S DIR(0)="N^0:72:2"
115 .. N VALID S (VALID,OUT)=0
116 .. F D Q:VALID!OUT
117 ... D ^DIR
118 ... I (+Y#.25)=0 S VALID=1
119 ... I +Y=0 S Y=""
120 ... I $D(DIRUT) S OUT=1
121 ... S RH1=Y
122 . Q:$G(OUT)
123 . I EVEN D
124 .. K DIR,Y
125 .. S DIR("B")=80-$S($G(RH1)>0:RH1,1:40)
126 .. S DIR("A")="Enter recess hours for the 2nd week of the pay period"
127 .. S DIR("?")="Pay period week 2 hours. Enter the recess hours for selected weeks."
128 .. S DIR(0)="N^0:72:2"
129 .. N VALID S (VALID,OUT)=0
130 .. F D Q:VALID!OUT
131 ... D ^DIR
132 ... I (+Y#.25)=0 S VALID=1
133 ... I +Y=0 S Y=""
134 ... I $D(DIRUT) S OUT=1
135 ... S RH2=Y
136 Q
137SETWKSLM(OOPSWKS,RH1,RH2,OTHERHRS,UOH,CTRH1,CTRH2,UCTH) ;
138 ; Set weeks RECESS HOURS in listmanager display
139 ;
140 N ITEM,LSTITEM
141 N OOPSWKS S OOPSWKS=""
142 S ITEM=0
143 F S ITEM=$O(^TMP("PRSSW",$J,ITEM)) Q:ITEM'>0 D
144 . ; Get item out of selectable items index
145 . S RH=$S(ITEM#2:$G(RH1),1:$G(RH2))
146 . I $G(OTHERHRS),$G(UOH) D
147 .. N D1,DAY,PPI,PPE S D1=$G(WKSFM(ITEM)) D PP^PRSAPPU
148 .. I $G(PPI)>0 D
149 ... K TH D TOURHRS^PRSARC07(.TH,PPI,+PRSNURSE,"")
150 ... S RH=$S(ITEM#2:TH("W1"),1:TH("W2"))
151 . I RH'>0,UCTH S RH=$S(ITEM#2:CTRH1,1:CTRH2)
152 . S LSTITEM=$G(^TMP("PRSSW",$J,ITEM))
153 . D FLDTEXT^VALM10(LSTITEM,"RECESS HOURS",$J(RH,15,2))
154 .;
155 .; set hours for selected weeks, remove from array if 0
156 .;
157 . I RH'>0 D
158 .. I UCTH S OOPSWKS=OOPSWKS_ITEM_","
159 .. K ^TMP("PRSRW",$J,ITEM)
160 . E D
161 .. S $P(^TMP("PRSRW",$J,ITEM),U,2)=RH
162 .. S $P(^TMP("PRSRW",$J,ITEM),U,3)=$G(WKSFM(ITEM))
163 .. ;S $P(^TMP("PRSRW",$J,ITEM),U,4)=REW
164 Q
165SELRWK(PR,OUT) ;PROMPT USER TO SELECT WEEKS FOR RECESS
166 ;
167 ; INPUT: PR-prompt flag are they setting recess hours or removing
168 ; recess hours
169 ; OUTPUT: OUT - user aborted or timed out
170 S VALMBCK="R"
171 I $G(PRSVIEW) D VWMSG^PRSARC03(1) Q
172 N DIR,DIRUT,LISTI,ITEM,Y
173 S OUT=1
174 ;
175 ; clear out current selections
176 ;
177 D DSELALL
178 N PRESEL
179 S PRESEL=+$P($P($G(XQORNOD(0)),U,4),"=",2)
180 I PRESEL,(PRESEL'=$P($P($G(XQORNOD(0)),U,4),"=",2))!((PRESEL'>PRSWKLST)&(PRESEL'<PRSLSTRT)) S Y=$$PARSE^PRSARC08(XQORNOD(0),PRSLSTRT,PRSWKLST)
181 I '(+$G(Y))!(+$G(Y)<PRSLSTRT)!(+$G(Y)>PRSWKLST) D
182 .S DIR(0)="L^"_PRSLSTRT_":"_PRSWKLST
183 .I $G(PR)="Z" D
184 .. S DIR("A")="Enter week numbers to set back to work weeks"
185 .E D
186 .. S DIR("A")="Enter week numbers to set to recess"
187 .;
188 .D ^DIR
189 S VALMBCK="R"
190 Q:$D(DIRUT)
191 F I=1:1:$L(Y,",") D
192 . S ITEM=+$P(Y,",",I)
193 . Q:ITEM'>0
194 . ; Get item out of selectable items index
195 . S LISTI=$G(^TMP("PRSLI",$J,ITEM))
196 .;
197 .; set selection week, recess
198 .;
199 . S $P(^TMP("PRSRW",$J,ITEM),U)=LISTI
200 . S ^TMP("PRSSW",$J,ITEM)=LISTI
201 S OUT=0
202 I "ZX"'[PR D SETWKHRS(.OUT)
203 S VALMBCK="R"
204 Q
205FLRECESS ; save recess schedule hrs to file
206 S VALMBCK="Q"
207 N SURE S SURE=0
208 ;
209 N CANADD,HASREC,OUT,CHANGE
210 S CANADD=$P(PRSNURSE,U,3)
211 S HASREC=$P(PRSFY,U,9)
212 ;
213 N DIR,Y,DIRUT
214 I $G(PRSOUT)=1 D
215 . S CHANGE=$$CHANGE^PRSARC03(HASREC)
216 . I 'HASREC!CHANGE D
217 .. S SURE=1
218 .. S DIR("A")="Changes will be lost. Are you sure you want to quit"
219 .. S DIR(0)="Y",DIR("B")="NO" D ^DIR
220 I SURE,(Y=0!$D(DIRUT)) S VALMBCK="R",PRSOUT=0 Q
221 I $G(PRSOUT)=1 S VALMBCK="Q" D:CHANGE VWMSG^PRSARC03(2) Q
222 ;
223 ;If new record add it. Nurse must be current AWS 9-month
224 ;
225 N PRSFDA,IEN,IENS,HOURS,WEEK
226 D FULL^VALM1
227 ;
228 I CANADD,'HASREC D
229 . K PRSFDA
230 . S PRSFDA(458.8,"+1,",.01)=+PRSNURSE
231 . S PRSFDA(458.8,"+1,",1)=+PRSFY
232 . S PRSFDA(458.8,"+1,",1.1)=PRSDT
233 . D UPDATE^DIE("","PRSFDA","IEN"),MSG^DIALOG()
234 . S HASREC=$G(IEN(1))
235 . S $P(PRSFY,U,9)=HASREC
236 . S $P(PRSFY,U,10)=$E(PRSDT,4,5)_"/"_$E(PRSDT,6,7)_"/"_$E(PRSDT,2,3)
237 . S $P(PRSFY,U,11)=PRSDT
238 ;
239 I HASREC D
240 .; start date changed?
241 . I $P($G(^PRST(458.8,HASREC,3)),U,2)'=PRSDT D
242 .. K PRSFDA,IENS
243 .. S IENS=HASREC_","
244 .. S PRSFDA(458.8,IENS,1.1)=PRSDT
245 .. D UPDATE^DIE("","PRSFDA","IEN"),MSG^DIALOG()
246 .. S $P(PRSFY,U,10)=$E(PRSDT,4,5)_"/"_$E(PRSDT,6,7)_"/"_$E(PRSDT,2,3)
247 .. S $P(PRSFY,U,11)=PRSDT
248 . I $$CHANGE^PRSARC03(HASREC) D
249 .. ; clean out old recess week records
250 .. N WKIEN S WKIEN=0
251 .. F S WKIEN=$O(^PRST(458.8,HASREC,1,WKIEN)) Q:WKIEN'>0 D
252 ... S IENS=WKIEN_","_HASREC_","
253 ... S PRSFDA(458.82,IENS,.01)="@"
254 .. D FILE^DIE("E","PRSFDA")
255 ..;
256 .. S WEEK=0
257 .. F S WEEK=$O(^TMP("PRSRW",$J,WEEK)) Q:WEEK'>0 D
258 ... S HOURS=$P(^TMP("PRSRW",$J,WEEK),U,2)
259 ... Q:HOURS'>0
260 ... K PRSFDA,IENS
261 ... S IENS="+1,"_HASREC_","
262 ... S PRSFDA(458.82,IENS,.01)=WEEK
263 ... S PRSFDA(458.82,IENS,1)=HOURS
264 ... S PRSFDA(458.82,IENS,2)=$G(WKSFM(WEEK))
265 ... S PRSFDA(458.82,IENS,3)=$P(^TMP("PRSRW",$J,WEEK),U,4)
266 ... D UPDATE^DIE("","PRSFDA","IENS"),MSG^DIALOG()
267 ..;
268 ..; update user edit date time
269 ..;
270 .. N %,%H,%I,X D NOW^%DTC
271 .. K PRSFDA,IENS
272 .. S IENS="+1,"_HASREC_","
273 .. S PRSFDA(458.83,IENS,.01)=%
274 .. S PRSFDA(458.83,IENS,1)=DUZ
275 .. D UPDATE^DIE("","PRSFDA","IENS"),MSG^DIALOG()
276 . S VALMSG="Changes Saved."
277 . E D
278 .. S VALMSG="Recess schedule has not changed since last save."
279 ;
280 I '$G(PRSVONLY) D
281 . W !,VALMSG
282 . S VALMBCK="Q"
283 E D
284 . S VALMBCK="R"
285 Q
286 ;
287DSELWK ;DESELECT WEEKS
288 ;
289 S VALMBCK="R"
290 I $G(PRSVIEW) D VWMSG^PRSARC03(1) Q
291 N OUT,ITEM,REW,RH,RDATA
292 S VALMBCK="R"
293 D SELRWK("Z",.OUT)
294 Q:OUT
295 ;
296 ; remove selections from recess array
297 S (ITEM,RH)=0
298 F S ITEM=$O(^TMP("PRSSW",$J,ITEM)) Q:ITEM'>0 D
299 . S LSTITEM=$G(^TMP("PRSSW",$J,ITEM))
300 . D FLDTEXT^VALM10(LSTITEM,"RECESS HOURS","")
301 . S RDATA=^TMP("PRSRW",$J,ITEM)
302 . I $P(RDATA,U,5)'>0 D
303 .. K ^TMP("PRSRW",$J,ITEM)
304 . E D
305 .. S $P(^TMP("PRSRW",$J,ITEM),U,2)=""
306 ;
307 D DSELALL
308 S VALMBCK="R"
309 Q
310DSELALL ; procedure removes items from selected items index w/no effect
311 ; on ListMan display.
312 ;
313 N ITEM,LISTI
314 S ITEM=0
315 F S ITEM=$O(^TMP("PRSSW",$J,ITEM)) Q:ITEM'>0 D
316 . S LISTI=$G(^TMP("PRSSW",$J,ITEM))
317 . K ^TMP("PRSSW",$J,ITEM)
318 Q
Note: See TracBrowser for help on using the repository browser.