source: Scheduling/trunk/m/BSDX08.m@ 1256

Last change on this file since 1256 was 1187, checked in by Sam Habiel, 14 years ago

Changes to BSDX01 to prevent Scheduled,dc'ed,completed radiology appointments from being cancelled. Updated files to T2.
File size: 13.1 KB
Line 
1BSDX08 ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 4/28/11 10:17am
2 ;;1.6T2;BSDX;;May 16, 2011
3 ;
4 ; Original by HMW. New Written by Sam Habiel. Licensed under LGPL.
5 ;
6 ; Change History
7 ; 3101022 UJO/SMH v1.42
8 ; - Transaction now restartable. Thanks to
9 ; --> Zach Gonzalez and Rick Marshall for fix.
10 ; - Extra TROLLBACK in Lock Statement when lock fails.
11 ; --> Removed--Rollback is already in ERR tag.
12 ; - Added new statements to old SD code in AVUPDT to obviate
13 ; --> need to restore variables in transaction
14 ; - Refactored this chunk of code. Don't really know whether it
15 ; --> worked in the first place. Waiting for bug report to know.
16 ; - Refactored all of APPDEL.
17 ;
18 ; 3111125 UJO/SMH v1.5
19 ; - Added ability to remove checked in appointments. Added a couple
20 ; of units tests for that under UT2.
21 ; - Minor reformatting because of how KIDS adds tabs.
22 ;
23 ; Error Reference:
24 ; -1~BSDX08: Appt record is locked. Please contact technical support.
25 ; -2~BSDX08: Invalid Appointment ID
26 ; -3~BSDX08: Invalid Appointment ID
27 ; -4~BSDX08: Cancelled appointment does not have a Resouce ID
28 ; -5~BSDX08: Resouce ID does not exist in BSDX RESOURCE
29 ; -6~BSDX08: Invalid Hosp Location stored in Database
30 ; -7~BSDX08: Patient does not have an appointment in PIMS Clinic
31 ; -8^BSDX08: Unable to find associated PIMS appointment for this patient
32 ; -9^BSDX08: BSDXAPI returned an error: (error)
33 ; -100~BSDX08 Error: (Mumps Error)
34 ;
35APPDELD(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP
36 ;Entry point for debugging
37 D DEBUG^%Serenji("APPDEL^BSDX08(.BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)")
38 Q
39 ;
40UT ; Unit Tests
41 ; Test 1: Make normal appointment and cancel it. See if every thing works
42 N ZZZ
43 D APPADD^BSDX07(.ZZZ,3110123.2,3110123.3,4,"Dr Office",10,"Sam's Note",1)
44 S APPID=+$P(^BSDXTMP($J,1),U)
45 D APPDEL^BSDX08(.ZZZ,APPID,"PC",1,"Sam's Cancel Note")
46 I $P(^BSDXAPPT(APPID,0),U,12)'>0 W "Error in Cancellation-1"
47 I $O(^SC(2,"S",3110123.2,1,0))]"" W "Error in Cancellation-2"
48 I $P(^DPT(4,"S",3110123.2,0),U,2)'="PC" W "Error in Cancellation-3"
49 I ^DPT(4,"S",3110123.2,"R")'="Sam's Cancel Note" W "Error in Cancellation-4"
50 ;
51 ; Test 2: Check for -1
52 ; Make appt
53 D APPADD^BSDX07(.ZZZ,3110125.2,3110125.3,4,"Dr Office",10,"Sam's Note",1)
54 ; Lock the node in another job
55 S APPID=+$P(^BSDXTMP($J,1),U)
56 ; W "Lock ^BSDXAPPT("_APPID_") in another session. You have 10 seconds." H 10
57 D APPDEL^BSDX08(.ZZZ,APPID,"PC",1,"Sam's Cancel Note")
58 ;
59 ; Test 3: Check for -100
60 S bsdxdie=1
61 D APPADD^BSDX07(.ZZZ,3110126.2,3110126.3,4,"Dr Office",10,"Sam's Note",1)
62 S APPID=+$P(^BSDXTMP($J,1),U)
63 D APPDEL^BSDX08(.ZZZ,APPID,"PC",1,"Reasons")
64 I $P(^BSDXTMP($J,1),"~")'=-100 W "Error in -100",!
65 K bsdxdie
66 ;
67 ; Test 4: Restartable transaction
68 S bsdxrestart=1
69 D APPADD^BSDX07(.ZZZ,3110128.2,3110128.3,4,"Dr Office",10,"Sam's Note",1)
70 S APPID=+$P(^BSDXTMP($J,1),U)
71 D APPDEL^BSDX08(.ZZZ,APPID,"PC",1,"Reasons")
72 I $P(^DPT(4,"S",3110128.2,0),U,2)'="PC" W "Error in Restartable Transaction",!
73 ;
74 ; Test 5: for invalid Appointment ID (-2 and -3)
75 D APPDEL^BSDX08(.ZZZ,0,"PC",1,"Reasons")
76 I $P(^BSDXTMP($J,1),"~")'=-2 W "Error in -2",!
77 D APPDEL^BSDX08(.ZZZ,999999,"PC",1,"Reasons")
78 I $P(^BSDXTMP($J,1),"~")'=-3 W "Error in -3",!
79UT2 ; More unit Tests
80 ;
81 ; Test 6: for Cancelling walkin and checked-in appointments
82 S BSDXSTART=$E($$NOW^XLFDT,1,12),BSDXEND=BSDXSTART+.0001
83 D APPADD^BSDX07(.ZZZ,BSDXSTART,BSDXEND,4,"Dr Office",10,"Sam's Note",1) ; Add appt
84 S APPID=+$P(^BSDXTMP($J,1),U)
85 I APPID=0 W "Error in test 6",!
86 D CHECKIN^BSDX25(.ZZZ,APPID,$$NOW^XLFDT) ; check-in
87 D APPDEL^BSDX08(.ZZZ,APPID,"PC",10,"Cancel Note") ; Delete appt
88 I $P(^BSDXTMP($J,1),$C(30))'="" W "Error in test 6",!
89 ;
90 ; Test 7: for cancelling walkin and checked-in appointments
91 S BSDXSTART=$E($$NOW^XLFDT,1,12)+.0001,BSDXEND=BSDXSTART+.0001
92 D APPADD^BSDX07(.ZZZ,BSDXSTART,BSDXEND,4,"Dr Office",10,"Sam's Note",1) ; Add appt
93 S APPID=+$P(^BSDXTMP($J,1),U)
94 I APPID=0 W "Error in test 6",!
95 D CHECKIN^BSDX25(.ZZZ,APPID,$$NOW^XLFDT) ; Checkin
96 S BSDXRES=$O(^BSDXRES("B","Dr Office",""))
97 S BSDXCLN=$P(^BSDXRES(BSDXRES,0),U,4)
98 S BSDXRESULT=$$RMCI^BSDXAPI(4,BSDXCLN,BSDXSTART) ; remove checkin
99 D APPDEL^BSDX08(.ZZZ,APPID,"PC",10,"Cancel Note") ; delete appt
100 I $P(^BSDXTMP($J,1),$C(30))'="" W "Error in test 6",!
101 QUIT
102APPDEL(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP
103 ;Called by RPC: BSDX CANCEL APPOINTMENT
104 ;Cancels existing appointment in BSDX APPOINTMENT and 44/2 subfiles
105 ;Input Parameters:
106 ; - BSDXAPTID is entry number in BSDX APPOINTMENT file
107 ; - BSDXTYP is C for clinic-cancelled and PC for patient cancelled
108 ; - BSDXCR is pointer to CANCELLATION REASON File (409.2)
109 ; - BSDXNOT is user note
110 ;
111 ; Returns error code in recordset field ERRORID. Empty string is success.
112 ; Returns Global Array. Must use this type in RPC.
113 ;
114 ; Return Array: set Return and clear array
115 S BSDXY=$NA(^BSDXTMP($J))
116 K ^BSDXTMP($J)
117 ;
118 ; Set min DUZ vars if they don't exist
119 D ^XBKVAR
120 ;
121 ; $ET
122 N $ET S $ET="G ETRAP^BSDX08"
123 ;
124 ; Counter
125 N BSDXI S BSDXI=0
126 ; Header Node
127 S ^BSDXTMP($J,BSDXI)="T00100ERRORID"_$C(30)
128 ;
129 ; Lock BSDX node, only to synchronize access to the globals.
130 ; It's not expected that the error will ever happen as no filing
131 ; is supposed to take 5 seconds.
132 L +^BSDXAPPT(BSDXAPTID):5 I '$T D ERR(BSDXI,"-1~BSDX08: Appt record is locked. Please contact technical support.") Q
133 ;
134 ;Restartable Transaction; restore paramters when starting.
135 ; (Params restored are what's passed here + BSDXI)
136 TSTART (BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT,BSDXI):T="BSDX CANCEL APPOINTEMENT^BSDX08"
137 ;
138 ; Turn off SDAM APPT PROTOCOL BSDX Entries
139 N BSDXNOEV
140 S BSDXNOEV=1 ;Don't execute BSDX CANCEL APPOINTMENT protocol
141 ;
142 ;;;test for error inside transaction. See if %ZTER works
143 I $G(bsdxdie) S X=1/0
144 ;;;test
145 ;;;test for TRESTART
146 I $G(bsdxrestart) K bsdxrestart TRESTART
147 ;;;test
148 ;
149 ; Check appointment ID and whether it exists
150 I '+BSDXAPTID D ERR(BSDXI,"-2~BSDX08: Invalid Appointment ID") Q
151 I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(BSDXI,"-3~BSDX08: Invalid Appointment ID") Q
152 ;
153 ; Start Processing:
154 ; First, add cancellation date to appt entry in BSDX APPOINTMENT
155 N BSDXNOD S BSDXNOD=^BSDXAPPT(BSDXAPTID,0) ; BSDX Appt Node
156 N BSDXPATID S BSDXPATID=$P(BSDXNOD,U,5) ; Patient ID
157 N BSDXSTART S BSDXSTART=$P(BSDXNOD,U) ; Start Time
158 D BSDXCAN(BSDXAPTID) ; Add a cancellation date in BSDX APPOINTMENT
159 ;
160 ; Second, cancel appt in "S" nodes in file 2 and 44, then update Legacy PIMS Availability
161 N BSDXSC1 S BSDXSC1=$P(BSDXNOD,U,7) ;RESOURCEID
162 ; If the resouce id doesn't exist...
163 I BSDXSC1="" D ERR(BSDXI,"-4~BSDX08: Cancelled appointment does not have a Resouce ID") QUIT
164 I '$D(^BSDXRES(BSDXSC1,0)) D ERR(BSDXI,"-5~BSDX08: Resouce ID does not exist in BSDX RESOURCE") QUIT
165 ; Get zero node of resouce
166 S BSDXNOD=^BSDXRES(BSDXSC1,0)
167 ; Get Hosp location
168 N BSDXLOC S BSDXLOC=$P(BSDXNOD,U,4)
169 ; Error indicator for Hosp Location filing for getting out of routine
170 N BSDXERR S BSDXERR=0
171 ; Only file in 2/44 if there is an associated hospital location
172 I BSDXLOC D QUIT:BSDXERR
173 . I '$D(^SC(BSDXLOC,0)) S BSDXERR=1 D ERR(BSDXI,"-6~BSDX08: Invalid Hosp Location stored in Database") QUIT
174 . ; Get the IEN of the appointment in the "S" node of ^SC
175 . N BSDXSCIEN
176 . S BSDXSCIEN=$$SCIEN^BSDXAPI(BSDXPATID,BSDXLOC,BSDXSTART)
177 . I BSDXSCIEN="" S BSDXERR=1 D ERR(BSDXI,"-7~BSDX08: Patient does not have an appointment in PIMS Clinic") QUIT
178 . ; Get the appointment node
179 . S BSDXNOD=$G(^SC(BSDXLOC,"S",BSDXSTART,1,BSDXSCIEN,0))
180 . I BSDXNOD="" S BSDXERR=1 D ERR(BSDXI,"-8^BSDX08: Unable to find associated PIMS appointment for this patient") QUIT
181 . N BSDXLEN S BSDXLEN=$P(BSDXNOD,U,2)
182 . ; Cancel through BSDXAPI
183 . N BSDXZ
184 . D APCAN(.BSDXZ,BSDXLOC,BSDXPATID,BSDXSTART)
185 . I +BSDXZ>0 S BSDXERR=1 D ERR(BSDXI,"-9^BSDX08: BSDXAPI returned an error: "_$P(BSDXZ,U,2)) QUIT
186 . ; Update Legacy PIMS clinic Availability
187 . D AVUPDT(BSDXLOC,BSDXSTART,BSDXLEN)
188 ;
189 TCOMMIT
190 L -^BSDXAPPT(BSDXAPTID)
191 S BSDXI=BSDXI+1
192 S ^BSDXTMP($J,BSDXI)=""_$C(30)
193 S BSDXI=BSDXI+1
194 S ^BSDXTMP($J,BSDXI)=$C(31)
195 Q
196 ;
197AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) ;Update Legacy PIMS Clinic availability
198 ;See SDCNP0
199 N SD,S ; Start Date
200 S (SD,S)=BSDXSTART
201 N I ; Clinic IEN in 44
202 S I=BSDXSCD
203 ; if day has no schedule in legacy PIMS, forget about this update.
204 Q:'$D(^SC(I,"ST",SD\1,1))
205 N SL ; Clinic characteristics node (length of appt, when appts start etc)
206 S SL=^SC(I,"SL")
207 N X ; Hour Clinic Display Begins
208 S X=$P(SL,U,3)
209 N STARTDAY ; When does the day start?
210 S STARTDAY=$S($L(X):X,1:8) ; If defined, use it; otherwise, 8am
211 N SB ; ?? Who knows? Day Start - 1 divided by 100.
212 S SB=STARTDAY-1/100
213 S X=$P(SL,U,6) ; Now X is Display increments per hour
214 N HSI ; Slots per hour, try 1
215 S HSI=$S(X:X,1:4) ; if defined, use it; otherwise, 4
216 N SI ; Slots per hour, try 2
217 S SI=$S(X="":4,X<3:4,X:X,1:4) ; If slots "", or less than 3, then 4
218 N STR ; ??
219 S STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
220 N SDDIF ; Slots per hour diff??
221 S SDDIF=$S(HSI<3:8/HSI,1:2)
222 S SL=BSDXLEN ; Dammit, reusing variable; SL now Appt Length from GUI
223 S S=^SC(I,"ST",SD\1,1) ; reusing var again; S now Day Pattern from PIMS
224 N Y ; Hours since start of Date
225 S Y=SD#1-SB*100 ;SD#1=FM Time portion; -SB minus start of day; conv to hrs
226 N ST ; ??
227 ; Y#1 -> Minutes; *SI -> * Slots per hour; \.6 trunc min to hour
228 ; Y\1 -> Hours since start of day; * SI: * slots
229 S ST=Y#1*SI\.6+(Y\1*SI)
230 N SS ; how many slots are supposed to be taken by appointment
231 S SS=SL*HSI/60 ; (nb: try SL: 30 min; HSI: 4 slots)
232 N I
233 I Y'<1 D ; If Hours since start of Date is greater than 1
234 . ; loop through pattern. Tired of documenting.
235 . F I=ST+ST:SDDIF D Q:Y="" Q:SS'>0
236 . . S Y=$E(STR,$F(STR,$E(S,I+1))) Q:Y=""
237 . . S S=$E(S,1,I)_Y_$E(S,I+2,999)
238 . . S SS=SS-1
239 . . Q:SS'>0
240 S ^SC(BSDXSCD,"ST",SD\1,1)=S ; new pattern; global set
241 Q
242 ;
243APCAN(BSDXZ,BSDXLOC,BSDXDFN,BSDXSD) ;
244 ;Cancel appointment for patient BSDXDFN in clinic BSDXSC1
245 ;at time BSDXSD
246 N BSDXC,%H
247 S BSDXC("PAT")=BSDXPATID
248 S BSDXC("CLN")=BSDXLOC
249 S BSDXC("TYP")=BSDXTYP
250 S BSDXC("ADT")=BSDXSD
251 S %H=$H D YMD^%DTC
252 S BSDXC("CDT")=X+%
253 S BSDXC("NOT")=BSDXNOT
254 S:'+$G(BSDXCR) BSDXCR=11 ;Other
255 S BSDXC("CR")=BSDXCR
256 S BSDXC("USR")=DUZ
257 ;
258 S BSDXZ=$$CANCEL^BSDXAPI(.BSDXC)
259 Q
260 ;
261BSDXCAN(BSDXAPTID) ;
262 ;Cancel BSDX APPOINTMENT entry
263 N %DT,X,BSDXDATE,Y,BSDXIENS,BSDXFDA,BSDXMSG
264 S %DT="XT",X="NOW" D ^%DT ; X ^DD("DD")
265 S BSDXDATE=Y
266 S BSDXIENS=BSDXAPTID_","
267 S BSDXFDA(9002018.4,BSDXIENS,.12)=BSDXDATE
268 K BSDXMSG
269 D FILE^DIE("","BSDXFDA","BSDXMSG")
270 Q
271 ;
272CANEVT(BSDXPAT,BSDXSTART,BSDXSC) ;EP Called by BSDX CANCEL APPOINTMENT event
273 ;when appointments cancelled via PIMS interface.
274 ;Propagates cancellation to BSDXAPPT and raises refresh event to running GUI clients
275 N BSDXFOUND,BSDXRES
276 Q:+$G(BSDXNOEV)
277 Q:'+$G(BSDXSC)
278 S BSDXFOUND=0
279 I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0)) S BSDXFOUND=$$CANEVT1(BSDXRES,BSDXSTART,BSDXPAT)
280 I BSDXFOUND D CANEVT3(BSDXRES) Q
281 I $D(^BXDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0)) S BSDXFOUND=$$CANEVT1(BSDXRES,BSDXSTART,BSDXPAT)
282 I BSDXFOUND D CANEVT3(BSDXRES)
283 Q
284 ;
285CANEVT1(BSDXRES,BSDXSTART,BSDXPAT) ;
286 ;Get appointment id in BSDXAPT
287 ;If found, call BSDXCAN(BSDXAPPT) and return 1
288 ;else return 0
289 N BSDXFOUND,BSDXAPPT
290 S BSDXFOUND=0
291 Q:'+BSDXRES BSDXFOUND
292 Q:'$D(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART)) BSDXFOUND
293 S BSDXAPPT=0 F S BSDXAPPT=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT)) Q:'+BSDXAPPT D Q:BSDXFOUND
294 . S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD=""
295 . I $P(BSDXNOD,U,5)=BSDXPAT,$P(BSDXNOD,U,12)="" S BSDXFOUND=1 Q
296 I BSDXFOUND,+$G(BSDXAPPT) D BSDXCAN(BSDXAPPT)
297 Q BSDXFOUND
298 ;
299CANEVT3(BSDXRES) ;
300 ;Call RaiseEvent to notify GUI clients
301 ;
302 N BSDXRESN
303 S BSDXRESN=$G(^BSDXRES(BSDXRES,0))
304 Q:BSDXRESN=""
305 S BSDXRESN=$P(BSDXRESN,"^")
306 ;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","")
307 D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
308 Q
309 ;
310ERR(BSDXI,BSDXERR) ;Error processing
311 S BSDXI=BSDXI+1
312 S BSDXERR=$TR(BSDXERR,"^","~")
313 I $TL>0 TROLLBACK
314 S ^BSDXTMP($J,BSDXI)=BSDXERR_$C(30)
315 S BSDXI=BSDXI+1
316 S ^BSDXTMP($J,BSDXI)=$C(31)
317 L -^BSDXAPPT(BSDXAPTID)
318 QUIT
319 ;
320ETRAP ;EP Error trap entry
321 N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
322 ; Rollback, otherwise ^XTER will be empty from future rollback
323 I $TL>0 TROLLBACK
324 D ^%ZTER
325 S $EC="" ; Clear Error
326 ; Log error message and send to client
327 I '$D(BSDXI) N BSDXI S BSDXI=0
328 D ERR(BSDXI,"-100~BSDX08 Error: "_$G(%ZTERZE))
329 QUIT
330 ;
331 ;;;NB: This is code that is unused in both original and port.
332 ; ; If not appt in the "S" node is found in ^SC then check associated RPMS Clinic Multiple
333 ; I BSDXSCIEN="" D I 'BSDXZ Q ;Q:BSDXZ
334 ; . S BSDXERR="BSDX08: Unable to find associated RPMS appointment for this patient. "
335 ; . S BSDXZ=1
336 ; . ; Check if there are associated RPMS clinics. (not currently used) Does the multiple exist? No, then quit
337 ; . I '$D(^BSDXRES(BSDXSC1,20)) S BSDXZ=0 QUIT
338 ; . ; Loop through the multiple. Get Location and then the ^SC "S" node IEN.
339 ; . N BSDX1 S BSDX1=0
340 ; . F S BSDX1=$O(^BSDXRES(BSDXSC1,20,BSDX1)) Q:'+BSDX1 Q:BSDXZ=0 D
341 ; . . Q:'$D(^BSDXRES(BSDXSC1,20,BSDX1,0))
342 ; . . S BSDXLOC=$P(^BSDXRES(BSDXSC1,20,BSDX1,0),U)
343 ; . . S BSDXSCIEN=$$SCIEN^BSDXAPI(BSDXPATID,BSDXLOC,BSDXSTART) I +BSDXSCIEN S BSDXZ=0 Q
Note: See TracBrowser for help on using the repository browser.