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

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

Updated version number on all routines to be 1.7T1.
Minor fixes here and there for XINDEX errors.

File size: 8.6 KB
Line 
1BSDX08 ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 7/5/12 12:39pm
2 ;;1.7T1;BSDX;;Jul 06, 2012;Build 18
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 work. As of v 1.7, all work here has been superceded
9 ; - Refactoring of AVUPDT - never tested though.
10 ; - Refactored all of APPDEL.
11 ;
12 ; 3111125 UJO/SMH v1.5
13 ; - Added ability to remove checked in appointments. Added a couple
14 ; of units tests for that under UT2.
15 ;
16 ; 3120625 VEN/SMH v1.7
17 ; - Transactions removed. Code refactored to work w/o txns.
18 ; - Moved AVUPDT to AVUPDTCN in BSDXAPI1. BSDXAPI takes care of calling
19 ; that.
20 ;
21 ; Error Reference:
22 ; -1~BSDX08: Appt record is locked. Please contact technical support.
23 ; -2~BSDX08: Invalid Appointment ID
24 ; -3~BSDX08: Invalid Appointment ID
25 ; -4~BSDX08: Cancelled appointment does not have a Resouce ID
26 ; -5~BSDX08: Resouce ID does not exist in BSDX RESOURCE
27 ; -6~BSDX08: Invalid Hosp Location stored in Database
28 ; -7~BSDX08: Patient does not have an appointment in PIMS Clinic
29 ; -8^BSDX08: Unable to find associated PIMS appointment for this patient
30 ; -9^BSDX08: BSDXAPI returned an error: (error)
31 ; -10^BSDX08: $$BSDXCAN failed (Fileman filing error)
32 ; -100~BSDX08 Error: (Mumps Error)
33 ;
34APPDELD(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP
35 ;Entry point for debugging
36 ;D DEBUG^%Serenji("APPDEL^BSDX08(.BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)")
37 Q
38 ;
39APPDEL(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP
40 ;Called by RPC: BSDX CANCEL APPOINTMENT
41 ;Cancels existing appointment in BSDX APPOINTMENT and 44/2 subfiles
42 ;Input Parameters:
43 ; - BSDXAPTID is entry number in BSDX APPOINTMENT file
44 ; - BSDXTYP is C for clinic-cancelled and PC for patient cancelled
45 ; - BSDXCR is pointer to CANCELLATION REASON File (409.2)
46 ; - BSDXNOT is user note
47 ;
48 ; Returns error code in recordset field ERRORID. Empty string is success.
49 ; Returns Global Array. Must use this type in RPC.
50 ;
51 ; Return Array: set Return and clear array
52 S BSDXY=$NA(^BSDXTMP($J))
53 K ^BSDXTMP($J)
54 ;
55 ; Set min DUZ vars if they don't exist
56 D ^XBKVAR
57 ;
58 ; $ET
59 N $ET S $ET="G ETRAP^BSDX08"
60 ;
61 ; Counter
62 N BSDXI S BSDXI=0
63 ;
64 ; Header Node
65 S ^BSDXTMP($J,BSDXI)="T00100ERRORID"_$C(30)
66 ;
67 ; Lock BSDX node, only to synchronize access to the globals.
68 ; It's not expected that the error will ever happen as no filing
69 ; is supposed to take 5 seconds.
70 L +^BSDXAPPT(BSDXAPTID):5 I '$T D ERR(BSDXI,"-1~BSDX08: Appt record is locked. Please contact technical support.") Q
71 ;
72 ; Turn off SDAM APPT PROTOCOL BSDX Entries
73 N BSDXNOEV
74 S BSDXNOEV=1 ;Don't execute BSDX CANCEL APPOINTMENT protocol
75 ;
76 ;;;test for error inside transaction. See if %ZTER works
77 I $G(BSDXDIE1) N X S X=1/0
78 ;
79 ; Check appointment ID and whether it exists
80 I '+BSDXAPTID D ERR(BSDXI,"-2~BSDX08: Invalid Appointment ID") Q
81 I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(BSDXI,"-3~BSDX08: Invalid Appointment ID") Q
82 ;
83 ; Start Processing:
84 ; First, get data
85 N BSDXNOD S BSDXNOD=^BSDXAPPT(BSDXAPTID,0) ; BSDX Appt Node
86 N BSDXPATID S BSDXPATID=$P(BSDXNOD,U,5) ; Patient ID
87 N BSDXSTART S BSDXSTART=$P(BSDXNOD,U) ; Start Time
88 ;
89 ; Check the resource ID and whether it exists
90 N BSDXSC1 S BSDXSC1=$P(BSDXNOD,U,7) ;RESOURCEID
91 ; If the resource id doesn't exist...
92 I BSDXSC1="" D ERR(BSDXI,"-4~BSDX08: Cancelled appointment does not have a Resouce ID") QUIT
93 I '$D(^BSDXRES(BSDXSC1,0)) D ERR(BSDXI,"-5~BSDX08: Resouce ID does not exist in BSDX RESOURCE") QUIT
94 ;
95 ;
96 ; Check if PIMS will let us cancel the appointment using $$CANCELCK^BSDXAPI
97 ; Get zero node of resouce
98 N BSDXNOD S BSDXNOD=^BSDXRES(BSDXSC1,0)
99 ; Get Hosp location
100 N BSDXLOC S BSDXLOC=$P(BSDXNOD,U,4)
101 ; Error indicator
102 N BSDXERR S BSDXERR=0
103 ;
104 N BSDXC ; Array to pass to BSDXAPI
105 ;
106 I BSDXLOC D
107 . S BSDXC("PAT")=BSDXPATID
108 . S BSDXC("CLN")=BSDXLOC
109 . S BSDXC("TYP")=BSDXTYP
110 . S BSDXC("ADT")=BSDXSTART
111 . S BSDXC("CDT")=$$NOW^XLFDT()
112 . S BSDXC("NOT")=BSDXNOT
113 . S:'+$G(BSDXCR) BSDXCR=11 ;Other
114 . S BSDXC("CR")=BSDXCR
115 . S BSDXC("USR")=DUZ
116 . ;
117 . S BSDXERR=$$CANCELCK^BSDXAPI(.BSDXC) ; 0 or 1^error message
118 ; If error, quit. No need to rollback as no changes took place.
119 I BSDXERR D ERR(BSDXI,"-9~BSDX08: BSDXAPI reports that "_$P(BSDXERR,U,2)) QUIT
120 ;
121 I $G(BSDXDIE2) N X S X=1/0
122 ;
123 ; Now cancel the appointment for real
124 ; BSDXAPPT First; no need for rollback if error occured.
125 N BSDXERR S BSDXERR=$$BSDXCAN(BSDXAPTID) ; Add a cancellation date in BSDX APPOINTMENT
126 I BSDXERR D ERR(BSDXI,"$$BSDXCAN failed (Fileman filing error): "_$P(BSDXERR,U,2)) QUIT
127 ;
128 ; Then PIMS:
129 ; cancel appt in "S" nodes in file 2 and 44, then update Legacy PIMS Availability
130 ; If error happens, must rollback ^BSDXAPPT
131 I BSDXLOC D QUIT:BSDXERR
132 . S BSDXERR=$$CANCEL^BSDXAPI(.BSDXC) ; Cancel through BSDXAPI
133 . ; Rollback BSDXAPPT if error occurs
134 . I BSDXERR D ERR(BSDXI,"-9^BSDX08: BSDXAPI returned an error: "_$P(BSDXERR,U,2)),ROLLBACK(BSDXAPTID) QUIT
135 ;
136 L -^BSDXAPPT(BSDXAPTID)
137 S BSDXI=BSDXI+1
138 S ^BSDXTMP($J,BSDXI)=""_$C(30)
139 S BSDXI=BSDXI+1
140 S ^BSDXTMP($J,BSDXI)=$C(31)
141 Q
142 ;
143BSDXCAN(BSDXAPTID) ; $$; Private; Cancel BSDX APPOINTMENT entry
144 ; Input: Appt IEN in ^BSDXAPPT
145 ; Output: 0 for success and 1^Msg for failure
146 N BSDXDATE,BSDXIENS,BSDXFDA,BSDXMSG
147 S BSDXDATE=$$NOW^XLFDT()
148 S BSDXIENS=BSDXAPTID_","
149 S BSDXFDA(9002018.4,BSDXIENS,.12)=BSDXDATE
150 D FILE^DIE("","BSDXFDA","BSDXMSG")
151 I $D(BSDXMSG) Q 1_U_BSDXMSG("DIERR",1,"TEXT",1)
152 QUIT 0
153 ;
154ROLLBACK(BSDXAPTID) ; Proc; Private; Rollback cancellation
155 ; Input same as $$BSDXCAN
156 N BSDXIENS S BSDXIENS=BSDXAPTID_","
157 N BSDXFDA S BSDXFDA(9002018.4,BSDXIENS,.12)="@"
158 N BSDXMSG
159 D FILE^DIE("","BSDXFDA","BSDXMSG")
160 ;I $D(BSDXMSG) ; Not sure what to do. We are already handling an error.
161 QUIT
162 ;
163CANEVT(BSDXPAT,BSDXSTART,BSDXSC) ;EP Called by BSDX CANCEL APPOINTMENT event
164 ;when appointments cancelled via PIMS interface.
165 ;Propagates cancellation to BSDXAPPT and raises refresh event to running GUI clients
166 N BSDXFOUND,BSDXRES
167 Q:+$G(BSDXNOEV)
168 Q:'+$G(BSDXSC)
169 S BSDXFOUND=0
170 I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0)) S BSDXFOUND=$$CANEVT1(BSDXRES,BSDXSTART,BSDXPAT)
171 I BSDXFOUND D CANEVT3(BSDXRES) Q
172 I $D(^BXDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0)) S BSDXFOUND=$$CANEVT1(BSDXRES,BSDXSTART,BSDXPAT)
173 I BSDXFOUND D CANEVT3(BSDXRES)
174 Q
175 ;
176CANEVT1(BSDXRES,BSDXSTART,BSDXPAT) ;
177 ;Get appointment id in BSDXAPT
178 ;If found, call BSDXCAN(BSDXAPPT) and return 1
179 ;else return 0
180 N BSDXFOUND,BSDXAPPT
181 S BSDXFOUND=0
182 Q:'+BSDXRES BSDXFOUND
183 Q:'$D(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART)) BSDXFOUND
184 S BSDXAPPT=0 F S BSDXAPPT=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT)) Q:'+BSDXAPPT D Q:BSDXFOUND
185 . N BSDXNOD
186 . S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD=""
187 . I $P(BSDXNOD,U,5)=BSDXPAT,$P(BSDXNOD,U,12)="" S BSDXFOUND=1 Q
188 I BSDXFOUND,+$G(BSDXAPPT) D BSDXCAN(BSDXAPPT)
189 Q BSDXFOUND
190 ;
191CANEVT3(BSDXRES) ;
192 ;Call RaiseEvent to notify GUI clients
193 ;
194 N BSDXRESN
195 S BSDXRESN=$G(^BSDXRES(BSDXRES,0))
196 Q:BSDXRESN=""
197 S BSDXRESN=$P(BSDXRESN,"^")
198 ;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","")
199 D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
200 Q
201 ;
202ERR(BSDXI,BSDXERR) ;Error processing
203 ; If last line is $C(31), we are done. No more errors to send to client.
204 I ^BSDXTMP($J,$O(^BSDXTMP($J," "),-1))=$C(31) QUIT
205 S BSDXI=BSDXI+1
206 S BSDXERR=$TR(BSDXERR,"^","~")
207 S ^BSDXTMP($J,BSDXI)=BSDXERR_$C(30)
208 S BSDXI=BSDXI+1
209 S ^BSDXTMP($J,BSDXI)=$C(31)
210 L -^BSDXAPPT(BSDXAPTID)
211 QUIT
212 ;
213ETRAP ;EP Error trap entry
214 N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
215 D ^%ZTER
216 ; Roll back BSDXAPPT;
217 ; NB: What if a Mumps error happens inside fileman in BSDXAPI?
218 ; I have decided the M errors are out of scope for me to handle.
219 D:$G(BSDXAPTID) ROLLBACK(BSDXAPTID)
220 ; Log error message and send to client
221 I '$D(BSDXI) N BSDXI S BSDXI=0
222 D ERR(BSDXI,"-100~BSDX08 Error: "_$G(%ZTERZE))
223 Q:$Q 1_U_"-100~Mumps Error" Q
224 ;
225 ;;;NB: This is code that is unused in both original and port.
226 ; ; If not appt in the "S" node is found in ^SC then check associated RPMS Clinic Multiple
227 ; I BSDXSCIEN="" D I 'BSDXZ Q ;Q:BSDXZ
228 ; . S BSDXERR="BSDX08: Unable to find associated RPMS appointment for this patient. "
229 ; . S BSDXZ=1
230 ; . ; Check if there are associated RPMS clinics. (not currently used) Does the multiple exist? No, then quit
231 ; . I '$D(^BSDXRES(BSDXSC1,20)) S BSDXZ=0 QUIT
232 ; . ; Loop through the multiple. Get Location and then the ^SC "S" node IEN.
233 ; . N BSDX1 S BSDX1=0
234 ; . F S BSDX1=$O(^BSDXRES(BSDXSC1,20,BSDX1)) Q:'+BSDX1 Q:BSDXZ=0 D
235 ; . . Q:'$D(^BSDXRES(BSDXSC1,20,BSDX1,0))
236 ; . . S BSDXLOC=$P(^BSDXRES(BSDXSC1,20,BSDX1,0),U)
237 ; . . S BSDXSCIEN=$$SCIEN^BSDXAPI(BSDXPATID,BSDXLOC,BSDXSTART) I +BSDXSCIEN S BSDXZ=0 Q
Note: See TracBrowser for help on using the repository browser.