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

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

Refactoring cont.
Many changes in BSDX08. Extensive changes in BSDX31. Creation of BSDXAPI1 as continuation of BSDXAPI.
BSDXUT1 now has UTs for BSDX31. Transactions now gone from BSDX08 and BSDX31.
BSDX08 needs more tests at failure points. BSDX31 still needs analysis for transaction failure and
code for rollback points, plus tests for that.

File size: 10.6 KB
RevLine 
[1461]1BSDX08 ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 6/26/12 10:49am
[1455]2 ;;1.7T1;BSDX;;Aug 31, 2011;Build 18
[1076]3 ;
4 ; Original by HMW. New Written by Sam Habiel. Licensed under LGPL.
5 ;
6 ; Change History
7 ; 3101022 UJO/SMH v1.42
[1461]8 ; - Transaction work. As of v 1.7, all work here has been superceded
9 ; - Refactoring of AVUPDT - never tested though.
[1076]10 ; - Refactored all of APPDEL.
11 ;
[1080]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 ;
[1461]16 ; 3120625 VEN/SMH v1.7
17 ; - Transactions removed. Code refactored to work w/o txns.
18 ;
[1076]19 ; Error Reference:
20 ; -1~BSDX08: Appt record is locked. Please contact technical support.
21 ; -2~BSDX08: Invalid Appointment ID
[1007]22 ; -3~BSDX08: Invalid Appointment ID
[1076]23 ; -4~BSDX08: Cancelled appointment does not have a Resouce ID
24 ; -5~BSDX08: Resouce ID does not exist in BSDX RESOURCE
25 ; -6~BSDX08: Invalid Hosp Location stored in Database
26 ; -7~BSDX08: Patient does not have an appointment in PIMS Clinic
27 ; -8^BSDX08: Unable to find associated PIMS appointment for this patient
28 ; -9^BSDX08: BSDXAPI returned an error: (error)
[1461]29 ; -10^BSDX08: $$BSDXCAN failed (Fileman filing error)
[1076]30 ; -100~BSDX08 Error: (Mumps Error)
[614]31 ;
32APPDELD(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP
33 ;Entry point for debugging
[1452]34 ;D DEBUG^%Serenji("APPDEL^BSDX08(.BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)")
[614]35 Q
36 ;
37APPDEL(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP
[1007]38 ;Called by RPC: BSDX CANCEL APPOINTMENT
39 ;Cancels existing appointment in BSDX APPOINTMENT and 44/2 subfiles
[1080]40 ;Input Parameters:
[1007]41 ; - BSDXAPTID is entry number in BSDX APPOINTMENT file
42 ; - BSDXTYP is C for clinic-cancelled and PC for patient cancelled
43 ; - BSDXCR is pointer to CANCELLATION REASON File (409.2)
44 ; - BSDXNOT is user note
[614]45 ;
[1080]46 ; Returns error code in recordset field ERRORID. Empty string is success.
47 ; Returns Global Array. Must use this type in RPC.
[614]48 ;
[1080]49 ; Return Array: set Return and clear array
[1007]50 S BSDXY=$NA(^BSDXTMP($J))
[1080]51 K ^BSDXTMP($J)
[1007]52 ;
[1080]53 ; Set min DUZ vars if they don't exist
54 D ^XBKVAR
[1007]55 ;
[1080]56 ; $ET
57 N $ET S $ET="G ETRAP^BSDX08"
58 ;
59 ; Counter
[1007]60 N BSDXI S BSDXI=0
[1454]61 ;
[1080]62 ; Header Node
[1041]63 S ^BSDXTMP($J,BSDXI)="T00100ERRORID"_$C(30)
[1007]64 ;
[1080]65 ; Lock BSDX node, only to synchronize access to the globals.
66 ; It's not expected that the error will ever happen as no filing
67 ; is supposed to take 5 seconds.
68 L +^BSDXAPPT(BSDXAPTID):5 I '$T D ERR(BSDXI,"-1~BSDX08: Appt record is locked. Please contact technical support.") Q
[1007]69 ;
[1080]70 ; Turn off SDAM APPT PROTOCOL BSDX Entries
[614]71 N BSDXNOEV
72 S BSDXNOEV=1 ;Don't execute BSDX CANCEL APPOINTMENT protocol
73 ;
[1080]74 ;;;test for error inside transaction. See if %ZTER works
[1461]75 I $G(BSDXDIE1) N X S X=1/0
[1080]76 ;
77 ; Check appointment ID and whether it exists
78 I '+BSDXAPTID D ERR(BSDXI,"-2~BSDX08: Invalid Appointment ID") Q
[1007]79 I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(BSDXI,"-3~BSDX08: Invalid Appointment ID") Q
[1455]80 ;
[1007]81 ; Start Processing:
[1455]82 ; First, get data
[1007]83 N BSDXNOD S BSDXNOD=^BSDXAPPT(BSDXAPTID,0) ; BSDX Appt Node
84 N BSDXPATID S BSDXPATID=$P(BSDXNOD,U,5) ; Patient ID
85 N BSDXSTART S BSDXSTART=$P(BSDXNOD,U) ; Start Time
[614]86 ;
[1455]87 ; Check the resource ID and whether it exists
[1007]88 N BSDXSC1 S BSDXSC1=$P(BSDXNOD,U,7) ;RESOURCEID
[1461]89 ; If the resource id doesn't exist...
[1007]90 I BSDXSC1="" D ERR(BSDXI,"-4~BSDX08: Cancelled appointment does not have a Resouce ID") QUIT
[1080]91 I '$D(^BSDXRES(BSDXSC1,0)) D ERR(BSDXI,"-5~BSDX08: Resouce ID does not exist in BSDX RESOURCE") QUIT
[1455]92 ;
[1460]93 ;
[1461]94 ; Check if PIMS will let us cancel the appointment using $$CANCELCK^BSDXAPI
[1007]95 ; Get zero node of resouce
[1455]96 N BSDXNOD S BSDXNOD=^BSDXRES(BSDXSC1,0)
[1080]97 ; Get Hosp location
[1007]98 N BSDXLOC S BSDXLOC=$P(BSDXNOD,U,4)
[1461]99 ; Error indicator
[1080]100 N BSDXERR S BSDXERR=0
[1461]101 ;
102 N BSDXC ; Array to pass to BSDXAPI
103 ;
104 I BSDXLOC D
[1455]105 . S BSDXC("PAT")=BSDXPATID
106 . S BSDXC("CLN")=BSDXLOC
107 . S BSDXC("TYP")=BSDXTYP
108 . S BSDXC("ADT")=BSDXSTART
109 . S BSDXC("CDT")=$$NOW^XLFDT()
110 . S BSDXC("NOT")=BSDXNOT
111 . S:'+$G(BSDXCR) BSDXCR=11 ;Other
112 . S BSDXC("CR")=BSDXCR
113 . S BSDXC("USR")=DUZ
114 . ;
115 . S BSDXERR=$$CANCELCK^BSDXAPI(.BSDXC) ; 0 or 1^error message
[1461]116 ; If error, quit. No need to rollback as no changes took place.
117 I BSDXERR D ERR(BSDXI,"-9~BSDX08: BSDXAPI reports that "_$P(BSDXERR,U,2)) QUIT
118 ;
119 I $G(BSDXDIE2) N X S X=1/0
120 ;
121 ; Now cancel the appointment for real
122 ; BSDXAPPT First; no need for rollback if error occured.
123 N BSDXERR S BSDXERR=$$BSDXCAN(BSDXAPTID) ; Add a cancellation date in BSDX APPOINTMENT
124 I BSDXERR D ERR(BSDXI,"$$BSDXCAN failed (Fileman filing error): "_$P(BSDXERR,U,2)) QUIT
125 ;
126 ; Then PIMS:
127 ; cancel appt in "S" nodes in file 2 and 44, then update Legacy PIMS Availability
128 ; If error happens, must rollback ^BSDXAPPT
129 I BSDXLOC D QUIT:BSDXERR
130 . N BSDXLEN S BSDXLEN=$$APPLEN^BSDXAPI(BSDXPATID,BSDXLOC,BSDXSTART) ; appt length
131 . S BSDXERR=$$CANCEL^BSDXAPI(.BSDXC) ; Cancel through BSDXAPI
132 . ; Rollback BSDXAPPT if error occurs
133 . ; TODO: If an M error occurs in BSDXAPI, ETRAP gets called, ^BSDXTMP is
134 . ; populated, then the output of $$CANCEL is the output of ETRAP.
135 . ; Then, we see that BSDXERR is true, and we do another write,
136 . ; which deletes the information we had in ^BSDXTMP. What to do???
137 . I BSDXERR D ERR(BSDXI,"-9^BSDX08: BSDXAPI returned an error: "_$P(BSDXERR,U,2)),ROLLBACK(BSDXAPTID) QUIT
[1455]138 . ;
[1461]139 . ; Update Legacy PIMS clinic Availability ; no failure expected here.
[614]140 . D AVUPDT(BSDXLOC,BSDXSTART,BSDXLEN)
141 ;
[1455]142 ;
[1007]143 L -^BSDXAPPT(BSDXAPTID)
[614]144 S BSDXI=BSDXI+1
145 S ^BSDXTMP($J,BSDXI)=""_$C(30)
146 S BSDXI=BSDXI+1
147 S ^BSDXTMP($J,BSDXI)=$C(31)
148 Q
149 ;
[1007]150AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) ;Update Legacy PIMS Clinic availability
[614]151 ;See SDCNP0
[1007]152 N SD,S ; Start Date
[1454]153 S (SD,S)=BSDXSTART
[1080]154 N I ; Clinic IEN in 44
[614]155 S I=BSDXSCD
[1080]156 ; if day has no schedule in legacy PIMS, forget about this update.
[614]157 Q:'$D(^SC(I,"ST",SD\1,1))
[1080]158 N SL ; Clinic characteristics node (length of appt, when appts start etc)
[1007]159 S SL=^SC(I,"SL")
[1080]160 N X ; Hour Clinic Display Begins
161 S X=$P(SL,U,3)
162 N STARTDAY ; When does the day start?
163 S STARTDAY=$S($L(X):X,1:8) ; If defined, use it; otherwise, 8am
164 N SB ; ?? Who knows? Day Start - 1 divided by 100.
165 S SB=STARTDAY-1/100
166 S X=$P(SL,U,6) ; Now X is Display increments per hour
167 N HSI ; Slots per hour, try 1
168 S HSI=$S(X:X,1:4) ; if defined, use it; otherwise, 4
169 N SI ; Slots per hour, try 2
170 S SI=$S(X="":4,X<3:4,X:X,1:4) ; If slots "", or less than 3, then 4
171 N STR ; ??
172 S STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
173 N SDDIF ; Slots per hour diff??
174 S SDDIF=$S(HSI<3:8/HSI,1:2)
[1007]175 S SL=BSDXLEN ; Dammit, reusing variable; SL now Appt Length from GUI
176 S S=^SC(I,"ST",SD\1,1) ; reusing var again; S now Day Pattern from PIMS
[1080]177 N Y ; Hours since start of Date
178 S Y=SD#1-SB*100 ;SD#1=FM Time portion; -SB minus start of day; conv to hrs
179 N ST ; ??
180 ; Y#1 -> Minutes; *SI -> * Slots per hour; \.6 trunc min to hour
181 ; Y\1 -> Hours since start of day; * SI: * slots
[1454]182 S ST=Y#1*SI\.6+(Y\1*SI)
[1080]183 N SS ; how many slots are supposed to be taken by appointment
184 S SS=SL*HSI/60 ; (nb: try SL: 30 min; HSI: 4 slots)
[1007]185 N I
[1080]186 I Y'<1 D ; If Hours since start of Date is greater than 1
187 . ; loop through pattern. Tired of documenting.
188 . F I=ST+ST:SDDIF D Q:Y="" Q:SS'>0
[1454]189 . . S Y=$E(STR,$F(STR,$E(S,I+1))) Q:Y=""
[1080]190 . . S S=$E(S,1,I)_Y_$E(S,I+2,999)
[1454]191 . . S SS=SS-1
[1080]192 . . Q:SS'>0
[1007]193 S ^SC(BSDXSCD,"ST",SD\1,1)=S ; new pattern; global set
[614]194 Q
195 ;
[1461]196BSDXCAN(BSDXAPTID) ; $$; Private; Cancel BSDX APPOINTMENT entry
197 ; Input: Appt IEN in ^BSDXAPPT
198 ; Output: 0 for success and 1^Msg for failure
199 N BSDXDATE,BSDXIENS,BSDXFDA,BSDXMSG
200 S BSDXDATE=$$NOW^XLFDT()
[614]201 S BSDXIENS=BSDXAPTID_","
202 S BSDXFDA(9002018.4,BSDXIENS,.12)=BSDXDATE
203 D FILE^DIE("","BSDXFDA","BSDXMSG")
[1461]204 I $D(BSDXMSG) Q 1_U_BSDXMSG("DIERR",1,"TEXT",1)
205 QUIT 0
[614]206 ;
[1461]207ROLLBACK(BSDXAPTID) ; Proc; Private; Rollback cancellation
208 ; Input same as $$BSDXCAN
209 N BSDXIENS S BSDXIENS=BSDXAPTID_","
210 N BSDXFDA S BSDXFDA(9002018.4,BSDXIENS,.12)="@"
211 N BSDXMSG
212 D FILE^DIE("","BSDXFDA","BSDXMSG")
213 ;I $D(BSDXMSG) ; Not sure what to do. We are already handling an error.
214 QUIT
215 ;
[614]216CANEVT(BSDXPAT,BSDXSTART,BSDXSC) ;EP Called by BSDX CANCEL APPOINTMENT event
217 ;when appointments cancelled via PIMS interface.
218 ;Propagates cancellation to BSDXAPPT and raises refresh event to running GUI clients
219 N BSDXFOUND,BSDXRES
220 Q:+$G(BSDXNOEV)
221 Q:'+$G(BSDXSC)
222 S BSDXFOUND=0
223 I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0)) S BSDXFOUND=$$CANEVT1(BSDXRES,BSDXSTART,BSDXPAT)
224 I BSDXFOUND D CANEVT3(BSDXRES) Q
225 I $D(^BXDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0)) S BSDXFOUND=$$CANEVT1(BSDXRES,BSDXSTART,BSDXPAT)
226 I BSDXFOUND D CANEVT3(BSDXRES)
227 Q
228 ;
229CANEVT1(BSDXRES,BSDXSTART,BSDXPAT) ;
230 ;Get appointment id in BSDXAPT
231 ;If found, call BSDXCAN(BSDXAPPT) and return 1
232 ;else return 0
233 N BSDXFOUND,BSDXAPPT
234 S BSDXFOUND=0
235 Q:'+BSDXRES BSDXFOUND
236 Q:'$D(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART)) BSDXFOUND
237 S BSDXAPPT=0 F S BSDXAPPT=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT)) Q:'+BSDXAPPT D Q:BSDXFOUND
[1455]238 . N BSDXNOD
[614]239 . S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD=""
240 . I $P(BSDXNOD,U,5)=BSDXPAT,$P(BSDXNOD,U,12)="" S BSDXFOUND=1 Q
241 I BSDXFOUND,+$G(BSDXAPPT) D BSDXCAN(BSDXAPPT)
242 Q BSDXFOUND
243 ;
244CANEVT3(BSDXRES) ;
245 ;Call RaiseEvent to notify GUI clients
246 ;
247 N BSDXRESN
248 S BSDXRESN=$G(^BSDXRES(BSDXRES,0))
249 Q:BSDXRESN=""
250 S BSDXRESN=$P(BSDXRESN,"^")
251 ;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","")
252 D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
253 Q
254 ;
255ERR(BSDXI,BSDXERR) ;Error processing
256 S BSDXI=BSDXI+1
257 S BSDXERR=$TR(BSDXERR,"^","~")
258 S ^BSDXTMP($J,BSDXI)=BSDXERR_$C(30)
259 S BSDXI=BSDXI+1
260 S ^BSDXTMP($J,BSDXI)=$C(31)
[1007]261 L -^BSDXAPPT(BSDXAPTID)
262 QUIT
[614]263 ;
264ETRAP ;EP Error trap entry
[1007]265 N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
[1080]266 D ^%ZTER
267 S $EC="" ; Clear Error
[1461]268 ; Roll back BSDXAPPT;
269 ; TODO: What if a Mumps error happens in fileman in BSDXAPI? The Scheduling files can potentially be out of sync
270 D:$G(BSDXAPTID) ROLLBACK(BSDXAPTID)
[1007]271 ; Log error message and send to client
[1080]272 I '$D(BSDXI) N BSDXI S BSDXI=0
[1007]273 D ERR(BSDXI,"-100~BSDX08 Error: "_$G(%ZTERZE))
[1461]274 Q:$Q 1_U_"-100~Mumps Error" Q
[1080]275 ;
276 ;;;NB: This is code that is unused in both original and port.
277 ; ; If not appt in the "S" node is found in ^SC then check associated RPMS Clinic Multiple
278 ; I BSDXSCIEN="" D I 'BSDXZ Q ;Q:BSDXZ
[1007]279 ; . S BSDXERR="BSDX08: Unable to find associated RPMS appointment for this patient. "
280 ; . S BSDXZ=1
[1080]281 ; . ; Check if there are associated RPMS clinics. (not currently used) Does the multiple exist? No, then quit
[1007]282 ; . I '$D(^BSDXRES(BSDXSC1,20)) S BSDXZ=0 QUIT
[1080]283 ; . ; Loop through the multiple. Get Location and then the ^SC "S" node IEN.
[1007]284 ; . N BSDX1 S BSDX1=0
285 ; . F S BSDX1=$O(^BSDXRES(BSDXSC1,20,BSDX1)) Q:'+BSDX1 Q:BSDXZ=0 D
286 ; . . Q:'$D(^BSDXRES(BSDXSC1,20,BSDX1,0))
287 ; . . S BSDXLOC=$P(^BSDXRES(BSDXSC1,20,BSDX1,0),U)
[1080]288 ; . . S BSDXSCIEN=$$SCIEN^BSDXAPI(BSDXPATID,BSDXLOC,BSDXSTART) I +BSDXSCIEN S BSDXZ=0 Q
Note: See TracBrowser for help on using the repository browser.