source: Scheduling/trunk/m/BSDX07.m@ 1451

Last change on this file since 1451 was 1451, checked in by Sam Habiel, 12 years ago

removed transactions from BSDX07... still more work to be done though
File size: 16.2 KB
Line 
1BSDX07 ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 6/19/12 5:34pm
2 ;;1.7T1;BSDX;;Aug 31, 2011;Build 18
3 ; Licensed under LGPL
4 ;
5 ; Change Log:
6 ; UJO/SMH
7 ; v1.3 July 13 2010 - Add support i18n - Dates input as FM dates, not US.
8 ; v1.42 Oct 22 2010 - Transaction now restartable by providing arguments
9 ; thanks to Rick Marshall and Zach Gonzalez at Oroville.
10 ; v1.42 Oct 30 2010 - Extensive refactoring.
11 ; v1.5 Mar 15 2011 - End time does not have to have time anymore.
12 ; It could be midnight of the next day
13 ; v1.6 Apr 11 2011 - Support for Scheduling Radiology Exams...
14 ;
15 ; Error Reference:
16 ; -1: Patient Record is locked. This means something is wrong!!!!
17 ; -2: Start Time is not a valid Fileman date
18 ; -3: End Time is not a valid Fileman date
19 ; v1.5:obsolete::-4: End Time does not have time inside of it.
20 ; -5: BSDXPATID is not numeric
21 ; -6: Patient Does not exist in ^DPT
22 ; -7: Resource Name does not exist in B index of BSDX RESOURCE
23 ; -8: Resouce doesn't exist in ^BSDXRES
24 ; -9: Couldn't add appointment to BSDX APPOINTMENT
25 ; -10: Couldn't add appointment to files 2 and/or 44
26 ; -100: Mumps Error
27 ;
28APPADDD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID) ;EP
29 ;Entry point for debugging
30 ; D DEBUG^%Serenji("APPADD^BSDX07(.BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)")
31 Q
32 ;
33UT ; Unit Tests - Assumes you have Patients with DFNs 1,2 and 3
34 ; Set-up - Create Clinics
35 N RESNAM S RESNAM="UTCLINIC"
36 N HLRESIENS ; holds output of UTCR^BSDX35 - HL IEN^Resource IEN
37 D
38 . N $ET S $ET="D ^%ZTER B"
39 . S HLRESIENS=$$UTCR^BSDX35(RESNAM)
40 . I HLRESIENS<0 S $EC=",U1," ; not supposed to happen
41 ;
42 N HLIEN,RESIEN
43 S HLIEN=$P(HLRESIENS,U)
44 S RESIEN=$P(HLRESIENS,U,2)
45 ;
46 ; Get start and end times
47 N TIMES S TIMES=$$TIMES^BSDX35 ; appt time^end time
48 N APPTTIME S APPTTIME=$P(TIMES,U)
49 N ENDTIME S ENDTIME=$P(TIMES,U,2)
50 ;
51 N ZZZ,DFN
52 ; Test for normality:
53 S DFN=3
54 D APPADD(.ZZZ,APPTTIME,ENDTIME,DFN,RESNAM,30,"Sam's Note",1)
55 ; Does Appt exist?
56 N APPID S APPID=+$P(^BSDXTMP($J,1),U)
57 I 'APPID W "Error Making Appt-1" QUIT
58 I +^BSDXAPPT(APPID,0)'=APPTTIME W "Error Making Appt-2"
59 I '$D(^DPT(DFN,"S",APPTTIME)) W "Error Making Appt-3"
60 I '$$SCIEN^BSDXAPI(DFN,HLIEN,APPTTIME) W "Error Making Appt-4"
61 ;
62 ; Do it again for a different patient
63 S DFN=2
64 D APPADD(.ZZZ,APPTTIME,ENDTIME,DFN,RESNAM,30,"Sam's Note",1)
65 N APPID S APPID=+$P(^BSDXTMP($J,1),U)
66 I 'APPID W "Error Making Appt-5" QUIT
67 I +^BSDXAPPT(APPID,0)'=APPTTIME W "Error Making Appt-6"
68 I '$D(^DPT(DFN,"S",APPTTIME)) W "Error Making Appt-7"
69 I '$$SCIEN^BSDXAPI(DFN,HLIEN,APPTTIME) W "Error Making Appt-8"
70 ;
71 ; Again for a different patient (4)
72 S DFN=4
73 D APPADD(.ZZZ,APPTTIME,ENDTIME,DFN,RESNAM,30,"Sam's Note",1)
74 N APPID S APPID=+$P(^BSDXTMP($J,1),U)
75 I 'APPID W "Error Making Appt-9" QUIT
76 I +^BSDXAPPT(APPID,0)'=APPTTIME W "Error Making Appt-10"
77 I '$D(^DPT(DFN,"S",APPTTIME)) W "Error Making Appt-11"
78 I '$$SCIEN^BSDXAPI(DFN,HLIEN,APPTTIME) W "Error Making Appt-12"
79 ;
80 ; Delete appointment set for Patient 4 (made above)
81 N BSDX,DFN
82 S DFN=4
83 S BSDX("PAT")=DFN
84 S BSDX("CLN")=HLIEN
85 S BSDX("ADT")=APPTTIME
86 D BSDXDEL^BSDX07(APPID)
87 S %=$$UNMAKE^BSDXAPI(.BSDX)
88 I +$G(^BSDXAPPT(APPID,0)) W "Error in deleting appointment-1",!
89 I $D(^DPT(DFN,"S",APPTTIME)) W "Error in deleting appointment-2",!
90 I $$SCIEN^BSDXAPI(DFN,HLIEN,APPTTIME) W "Error in deleting appointment-3",!
91 ;
92 ; Delete appointment set for Patient 1 (not made)... needs to not crash
93 D
94 . N $ET S $ET="D ^%ZTER S $EC="""" W ""Failure to del non-existent appt"",!"
95 . D BSDXDEL^BSDX07(9999999)
96 . N BSDX
97 . S BSDX("PAT")=1
98 . S BSDX("CLN")=HLIEN
99 . S BSDX("ADT")=APPTTIME
100 . S %=$$UNMAKE^BSDXAPI(.BSDX)
101 ;
102 ; Test for bad start date
103 D APPADD(.ZZZ,2100123,3100123.3,2,RESNAM,30,"Sam's Note",1)
104 I +$P(^BSDXTMP($J,1),U,2)'=-2 W "Error in -2",!
105 ; Test for bad end date
106 D APPADD(.ZZZ,3100123,2100123.3,2,RESNAM,30,"Sam's Note",1)
107 I +$P(^BSDXTMP($J,1),U,2)'=-3 W "Error in -3",!
108 ; Test for end date without time - obsolete
109 ; D APPADD(.ZZZ,3100123.1,3100123,2,RESNAM,30,"Sam's Note",1)
110 ; I +$P(^BSDXTMP($J,1),U,2)'=-4 W "Error in -4",!
111 ; Test for mumps error
112 S BSDXDIE=1
113 D APPADD(.ZZZ,APPTTIME,ENDTIME,1,RESNAM,30,"Sam's Note",1)
114 I +$P(^BSDXTMP($J,1),U,2)'=-100 W "Error in -100: M Error",!
115 K BSDXDIE
116 ; Test for TRESTART -- retired in v 1.7
117 ; S BSDXRESTART=1
118 ; D APPADD(.ZZZ,APPTTIME,ENDTIME,3,RESNAM,30,"Sam's Note",1)
119 ; I +$P(^BSDXTMP($J,1),U,2)'=0&(+$P(^BSDXTMP($J,1),U,2)'=-10) W "Error in TRESTART",!
120 ; K BSDXRESTART
121 ; Test for non-numeric patient
122 D APPADD(.ZZZ,APPTTIME,ENDTIME,"CAT,DOG",RESNAM,30,"Sam's Note",1)
123 I +$P(^BSDXTMP($J,1),U,2)'=-5 W "Error in -5",!
124 ; Test for a non-existent patient
125 D APPADD(.ZZZ,APPTTIME,ENDTIME,8989898989,RESNAM,30,"Sam's Note",1)
126 I +$P(^BSDXTMP($J,1),U,2)'=-6 W "Error in -6",!
127 ; Test for a non-existent resource name
128 D APPADD(.ZZZ,APPTTIME,ENDTIME,3,"lkajsflkjsadf",30,"Sam's Note",1)
129 I +$P(^BSDXTMP($J,1),U,2)'=-7 W "Error in -7",!
130 ; Test for corrupted resource
131 ; Can't test for -8 since it requires DB corruption
132 ; Test for inability to add appointment to BSDX Appointment (-9)
133 ; Also requires something wrong in the DB
134 ; Test for inability to add appointment to 2,44
135 ; Test by creating a duplicate appointment
136 ; Get start and end times
137 N TIMES S TIMES=$$TIMES^BSDX35 ; appt time^end time
138 N APPTTIME S APPTTIME=$P(TIMES,U)
139 N ENDTIME S ENDTIME=$P(TIMES,U,2)
140 D APPADD(.ZZZ,APPTTIME,ENDTIME,3,RESNAM,30,"Sam's Note",1)
141 D APPADD(.ZZZ,APPTTIME,ENDTIME,3,RESNAM,30,"Sam's Note",1)
142 I +$P(^BSDXTMP($J,1),U,2)'=-10 W "Error in -10",!
143 QUIT
144 ;
145APPADD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXRADEXAM) ;EP
146 ;
147 ;Called by RPC: BSDX ADD NEW APPOINTMENT
148 ;
149 ;Add new appointment to 3 files
150 ; - BSDX APPOINTMENT
151 ; - Hosp Location Appointment SubSubfile if Resource is linked to clinic
152 ; - Patient Appointment Subfile if Resource is linked to clinic
153 ;
154 ;Paramters:
155 ;BSDXY: Global Return (RPC must be set to Global Array)
156 ;BSDXSTART: FM Start Date
157 ;BSDXEND: FM End Date
158 ;BSDXPATID: Patient DFN
159 ;BSDXRES is ResourceName in BSDX RESOURCE file (not IEN)
160 ;BSDXLEN is the appointment duration in minutes
161 ;BSDXNOTE is the Appiontment Note
162 ;BSDXATID is used for 2 purposes:
163 ; if BSDXATID = "WALKIN" then BSDAPI is called to create a walkin appt.
164 ; if BSDXATID = a number, then it is the access type id (used for rebooking)
165 ;BSDXRADEXAM is used to store the Radiology Exam to which this appointment is tied to (optional)
166 ;
167 ;Return:
168 ; ADO.net Recordset having fields:
169 ; AppointmentID and ErrorNumber
170 ;
171 ;Test lines:
172 ;BSDX ADD NEW APPOINTMENT^3091122.0930^3091122.1000^370^Dr Office^30^EXAM^WALKIN
173 ;
174 ; Deal with optional arguments
175 S BSDXRADEXAM=$G(BSDXRADEXAM)
176 ;
177 ; Return Array; set Return and clear array
178 S BSDXY=$NA(^BSDXTMP($J))
179 K ^BSDXTMP($J)
180 ;
181 ; $ET
182 N $ET S $ET="G ETRAP^BSDX07"
183 ;
184 ; Counter
185 N BSDXI S BSDXI=0
186 ;
187 ; Lock BSDX node, only to synchronize access to the globals.
188 ; It's not expected that the error will ever happen as no filing
189 ; is supposed to take 5 seconds.
190 L +^BSDXAPPT(BSDXPATID):5 I '$T D ERR(BSDXI,"-1~Patient record is locked. Please contact technical support.") Q
191 ;
192 ; Header Node
193 S ^BSDXTMP($J,BSDXI)="I00020APPOINTMENTID^T00100ERRORID"_$C(30)
194 ;
195 ; Turn off SDAM APPT PROTOCOL BSDX Entries
196 N BSDXNOEV
197 S BSDXNOEV=1 ;Don't execute BSDX ADD APPOINTMENT protocol
198 ;
199 ; Set Error Message to be empty
200 N BSDXERR S BSDXERR=0
201 ;
202 ;;;test for error inside transaction. See if %ZTER works
203 I $G(BSDXDIE) S X=1/0
204 ;;;test
205 ;
206 ; -- Start and End Date Processing --
207 ; If C# sends the dates with extra zeros, remove them
208 S BSDXSTART=+BSDXSTART,BSDXEND=+BSDXEND
209 ; Are the dates valid? Must be FM Dates > than 2010
210 I BSDXSTART'>3100000 D ERR(BSDXI,"-2~BSDX07 Error: Invalid Start Time") Q
211 I BSDXEND'>3100000 D ERR(BSDXI,"-3~BSDX07 Error: Invalid End Time") Q
212 ;
213 ;; If Ending date doesn't have a time, this is an error --rm 1.5
214 ; I $L(BSDXEND,".")=1 D ERR(BSDXI,"-4~BSDX07 Error: Invalid End Time") Q
215 ;
216 ; If the Start Date is greater than the end date, swap dates
217 N BSDXTMP
218 I BSDXSTART>BSDXEND S BSDXTMP=BSDXEND,BSDXEND=BSDXSTART,BSDXSTART=BSDXTMP
219 ;
220 ; Check if the patient exists:
221 ; - DFN valid number?
222 ; - Valid Patient in file 2?
223 I '+BSDXPATID D ERR(BSDXI,"-5~BSDX07 Error: Invalid Patient ID") Q
224 I '$D(^DPT(BSDXPATID,0)) D ERR(BSDXI,"-6~BSDX07 Error: Invalid Patient ID") Q
225 ;
226 ;Validate Resource entry
227 I '$D(^BSDXRES("B",BSDXRES)) D ERR(BSDXI,"-7~BSDX07 Error: Invalid Resource ID") Q
228 N BSDXRESD ; Resource IEN
229 S BSDXRESD=$O(^BSDXRES("B",BSDXRES,0))
230 N BSDXRNOD ; Resouce zero node
231 S BSDXRNOD=$G(^BSDXRES(BSDXRESD,0))
232 I BSDXRNOD="" D ERR(BSDXI,"-8~BSDX07 Error: invalid Resource entry.") Q
233 ;
234 ; Walk-in (Unscheduled) Appointment?
235 N BSDXWKIN S BSDXWKIN=0
236 I BSDXATID="WALKIN" S BSDXWKIN=1
237 ; Reset Access Type ID if it doesn't say "WALKIN" and isn't a number
238 I BSDXATID'?.N&(BSDXATID'="WALKIN") S BSDXATID=""
239 ;
240 ; Now, check if PIMS has any issues with us making the appt using MAKECK
241 N BSDXSCD S BSDXSCD=$P(BSDXRNOD,U,4) ; Hosp Location IEN
242 N BSDXERR ; Variable to hold value of $$MAKE and $$MAKECK
243 N BSDXC ; Array to send to MAKE and MAKECK APIs
244 ; Only if we have a valid Hosp Location
245 I +BSDXSCD,$D(^SC(BSDXSCD,0)) D
246 . S BSDXC("PAT")=BSDXPATID
247 . S BSDXC("CLN")=BSDXSCD
248 . S BSDXC("TYP")=3 ;3 for scheduled appts, 4 for walkins
249 . S:BSDXWKIN BSDXC("TYP")=4
250 . S BSDXC("ADT")=BSDXSTART
251 . S BSDXC("LEN")=BSDXLEN
252 . S BSDXC("OI")=$E($G(BSDXNOTE),1,150) ;File 44 has 150 character limit on OTHER field
253 . S BSDXC("OI")=$TR(BSDXC("OI"),";"," ") ;No semicolons allowed by MAKE^BSDXAPI
254 . S BSDXC("OI")=$$STRIP(BSDXC("OI")) ;Strip control characters from note
255 . S BSDXC("USR")=DUZ
256 . S BSDXERR=$$MAKECK^BSDXAPI(.BSDXC)
257 I +BSDXERR D ERR(BSDXI,"-10~BSDX07 Error: MAKECK^BSDXAPI returned error code: "_BSDXERR) Q ; no need for roll back
258 ;
259 ; Done with all checks, let's make appointment in BSDX APPOINTMENT
260 N BSDXAPPTID
261 S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID,BSDXRADEXAM)
262 I 'BSDXAPPTID D ERR(BSDXI,"-9~BSDX07 Error: Unable to add appointment to BSDX APPOINTMENT file.") Q ; no roll back needed! No appts made.
263 I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE) ; TODO: check for error and rollback
264 ;
265 ; Only if we have a valid Hosp Loc can we make an appointment in 2/44
266 ; Use BSDXC array from before.
267 ; NB: $$MAKE itself calls $$MAKECK to check again for being okay.
268 I +BSDXSCD,$D(^SC(BSDXSCD,0)) D I +BSDXERR D ERR(BSDXI,"-10~BSDX07 Error: MAKE^BSDXAPI returned error code: "_BSDXERR),ROLLBACK(BSDXAPPTID,.BSDXC) Q
269 . S BSDXERR=$$MAKE^BSDXAPI(.BSDXC)
270 . Q:BSDXERR
271 . ;Update RPMS Clinic availability
272 . D AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN)
273 ;
274 ;Return Recordset
275 L -^BSDXAPPT(BSDXPATID)
276 S BSDXI=BSDXI+1
277 S ^BSDXTMP($J,BSDXI)=BSDXAPPTID_"^"_$C(30)
278 S BSDXI=BSDXI+1
279 S ^BSDXTMP($J,BSDXI)=$C(31)
280 Q
281STRIP(BSDXZ) ;Replace control characters with spaces
282 N BSDXI
283 F BSDXI=1:1:$L(BSDXZ) I (32>$A($E(BSDXZ,BSDXI))) S BSDXZ=$E(BSDXZ,1,BSDXI-1)_" "_$E(BSDXZ,BSDXI+1,999)
284 Q BSDXZ
285 ;
286BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID,BSDXRADEXAM) ;ADD BSDX APPOINTMENT ENTRY
287 ;Returns ien in BSDXAPPT or 0 if failed
288 ;Create entry in BSDX APPOINTMENT
289 N BSDXAPPTID
290 S BSDXFDA(9002018.4,"+1,",.01)=BSDXSTART
291 S BSDXFDA(9002018.4,"+1,",.02)=BSDXEND
292 S BSDXFDA(9002018.4,"+1,",.05)=BSDXPATID
293 S BSDXFDA(9002018.4,"+1,",.07)=BSDXRESD
294 S BSDXFDA(9002018.4,"+1,",.08)=$G(DUZ)
295 S BSDXFDA(9002018.4,"+1,",.09)=$$NOW^XLFDT
296 S:BSDXATID="WALKIN" BSDXFDA(9002018.4,"+1,",.13)="y"
297 S:BSDXATID?.N BSDXFDA(9002018.4,"+1,",.06)=BSDXATID
298 S BSDXFDA(9002018.4,"+1,",.14)=$G(BSDXRADEXAM)
299 N BSDXIEN,BSDXMSG
300 D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
301 S BSDXAPPTID=+$G(BSDXIEN(1))
302 Q BSDXAPPTID
303 ;
304BSDXWP(BSDXAPPTID,BSDXNOTE) ;
305 ;Add WP field
306 N BSDXMSG
307 I BSDXNOTE]"" S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE=""
308 I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0)
309 I $D(BSDXNOTE(.5)) D
310 . D WP^DIE(9002018.4,BSDXAPPTID_",",1,"","BSDXNOTE","BSDXMSG")
311 Q
312 ;
313ADDEVT(BSDXPATID,BSDXSTART,BSDXSC,BSDXSCDA) ;EP
314 ;Called by BSDX ADD APPOINTMENT protocol
315 ;BSDXSC=IEN of clinic in ^SC
316 ;BSDXSCDA=IEN for ^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA). Use to get Length & Note
317 ;
318 N BSDXNOD,BSDXLEN,BSDXAPPTID,BSDXNODP,BSDXWKIN,BSDXRES
319 Q:+$G(BSDXNOEV)
320 I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0))
321 E I $D(^BSDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0))
322 Q:'+$G(BSDXRES)
323 S BSDXNOD=$G(^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA,0))
324 Q:BSDXNOD=""
325 S BSDXNODP=$G(^DPT(BSDXPATID,"S",BSDXSTART,0))
326 S BSDXWKIN=""
327 S:$P(BSDXNODP,U,7)=4 BSDXWKIN="WALKIN" ;Purpose of Visit field of DPT Appointment subfile
328 S BSDXLEN=$P(BSDXNOD,U,2)
329 Q:'+BSDXLEN
330 S BSDXEND=$$FMADD^XLFDT(BSDXSTART,0,0,BSDXLEN,0)
331 S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXWKIN)
332 Q:'+BSDXAPPTID
333 S BSDXNOTE=$P(BSDXNOD,U,4)
334 I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE)
335 D ADDEVT3(BSDXRES)
336 Q
337 ;
338ADDEVT3(BSDXRES) ;
339 ;Call RaiseEvent to notify GUI clients
340 N BSDXRESN
341 S BSDXRESN=$G(^BSDXRES(BSDXRES,0))
342 Q:BSDXRESN=""
343 S BSDXRESN=$P(BSDXRESN,"^")
344 ;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","")
345 D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
346 Q
347 ;
348ERR(BSDXI,BSDXERR) ;Error processing
349 S BSDXI=BSDXI+1
350 S BSDXERR=$TR(BSDXERR,"^","~")
351 S ^BSDXTMP($J,BSDXI)="0^"_BSDXERR_$C(30)
352 S BSDXI=BSDXI+1
353 S ^BSDXTMP($J,BSDXI)=$C(31)
354 L -^BSDXAPPT(BSDXPATID)
355 Q
356 ;
357ROLLBACK(BSDXAPPTID,BSDXC) ; Private EP; Roll back appointment set
358 ; DO NOT USE except as an emergency measure - only if unforseen error occurs
359 ; Input:
360 ; Appointment ID to remove from ^BSDXAPPT
361 ; BSDXC array (see array format in $$MAKE^BSDXAPI)
362 D BSDXDEL^BSDX07(BSDXAPPTID)
363 S:$D(BSDXC) %=$$UNMAKE^BSDXAPI(.BSDXC) ; rtn value always 0
364 QUIT
365 ;
366BSDXDEL(BSDXAPPTID) ;Private EP ; Deletes appointment BSDXAPPTID from ^BSDXAPPT
367 ; DO NOT USE except in emergencies to roll back an appointment set
368 N DA,DIK
369 S DIK="^BSDXAPPT(",DA=BSDXAPPTID
370 D ^DIK
371 Q
372 ;
373ETRAP ;EP Error trap entry
374 N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
375 D ^%ZTER
376 S $EC="" ; Clear Error
377 ; Log error message and send to client
378 I '$D(BSDXI) N BSDXI S BSDXI=0
379 D ERR(BSDXI,"-100~BSDX07 Error: "_$G(%ZTERZE))
380 Q
381 ;
382DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
383 ;
384DOW S %=$E(X,1,3),Y=$E(X,4,5),Y=Y>2&'(%#4)+$E("144025036146",Y)
385 F %=%:-1:281 S Y=%#4=1+1+Y
386 S Y=$E(X,6,7)+Y#7
387 Q
388 ;
389AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) ;Update RPMS Clinic availability
390 ;SEE SDM1
391 N Y,DFN
392 N SL,STARTDAY,X,SC,SB,HSI,SI,STR,SDDIF,SDMAX,SDDATE,SDDMAX,SDSDATE,CCXN,MXOK,COV,SDPROG
393 N X1,SDEDT,X2,SD,SM,SS,S,SDLOCK,ST,I
394 S Y=BSDXSCD,DFN=BSDXPATID
395 S SL=$G(^SC(+Y,"SL")),X=$P(SL,U,3),STARTDAY=$S($L(X):X,1:8),SC=Y,SB=STARTDAY-1/100,X=$P(SL,U,6),HSI=$S(X=1:X,X:X,1:4),SI=$S(X="":4,X<3:4,X:X,1:4),STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz",SDDIF=$S(HSI<3:8/HSI,1:2) K Y
396 ;Determine maximum days for scheduling
397 S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365
398 S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
399 S SDDATE=BSDXSTART
400 S SDSDATE=SDDATE,SDDATE=SDDATE\1
4011 ;L Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC
402 Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC
403 S X1=DT,SDEDT=365 S:$D(^SC(SC,"SDP")) SDEDT=$P(^SC(SC,"SDP"),"^",2)
404 S X2=SDEDT D C^%DTC S SDEDT=X
405 S Y=BSDXSTART
406EN1 S (X,SD)=Y,SM=0 D DOW
407S I '$D(^SC(SC,"ST",$P(SD,"."),1)) S SS=+$O(^SC(+SC,"T"_Y,SD)) Q:SS'>0 Q:^(SS,1)="" S ^SC(+SC,"ST",$P(SD,"."),1)=$E($P($T(DAY),U,Y+2),1,2)_" "_$E(SD,6,7)_$J("",SI+SI-6)_^(1),^(0)=$P(SD,".")
408 S S=BSDXLEN
409 ;Check if BSDXLEN evenly divisible by appointment length
410 S RPMSL=$P(SL,U)
411 I BSDXLEN<RPMSL S BSDXLEN=RPMSL
412 I BSDXLEN#RPMSL'=0 D
413 . S BSDXINC=BSDXLEN\RPMSL
414 . S BSDXINC=BSDXINC+1
415 . S BSDXLEN=RPMSL*BSDXINC
416 S SL=S_U_$P(SL,U,2,99)
417SC S SDLOCK=$S('$D(SDLOCK):1,1:SDLOCK+1) Q:SDLOCK>9
418 L +^SC(SC,"ST",$P(SD,"."),1):5 G:'$T SC
419 S SDLOCK=0,S=^SC(SC,"ST",$P(SD,"."),1)
420 S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST
421 I (I<1!'$F(S,"["))&(S'["CAN") L -^SC(SC,"ST",$P(SD,"."),1) Q
422 I SM<7 S %=$F(S,"[",SS-1) S:'%!($P(SL,"^",6)<3) %=999 I $F(S,"]",SS)'<%!(SDDIF=2&$E(S,ST+ST+1,SS-1)["[") S SM=7
423 ;
424SP I ST+ST>$L(S),$L(S)<80 S S=S_" " G SP
425 S SDNOT=1
426 S ABORT=0
427 F I=ST+ST:SDDIF:SS-SDDIF D Q:ABORT
428 . S ST=$E(S,I+1) S:ST="" ST=" "
429 . S Y=$E(STR,$F(STR,ST)-2)
430 . I S["CAN"!(ST="X"&($D(^SC(+SC,"ST",$P(SD,"."),"CAN")))) S ABORT=1 Q
431 . I Y="" S ABORT=1 Q
432 . S:Y'?1NL&(SM<6) SM=6 S ST=$E(S,I+2,999) S:ST="" ST=" " S S=$E(S,1,I)_Y_ST
433 . Q
434 S ^SC(SC,"ST",$P(SD,"."),1)=S
435 L -^SC(SC,"ST",$P(SD,"."),1)
436 Q
Note: See TracBrowser for help on using the repository browser.