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

Last change on this file since 1105 was 1105, checked in by Sam Habiel, 13 years ago

Minor mods to BSDX07 to accept an End Date at midnight
File size: 14.2 KB
Line 
1BSDX07 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 3/15/11 11:50am
2 ;;1.5V2;BSDX;;Mar 03, 2011
3 ;
4 ; Change Log:
5 ; UJO/SMH
6 ; v1.3 July 13 2010 - Add support i18n - Dates input as FM dates, not US.
7 ; v1.42 Oct 22 2010 - Transaction now restartable by providing arguments
8 ; thanks to Rick Marshall and Zach Gonzalez at Oroville.
9 ; v1.42 Oct 30 2010 - Extensive refactoring.
10 ; v1.5 Mar 15 2011 - End time does not have to have time anymore.
11 ; It could be midnight of the next day
12 ;
13 ; Error Reference:
14 ; -1: Patient Record is locked. This means something is wrong!!!!
15 ; -2: Start Time is not a valid Fileman date
16 ; -3: End Time is not a valid Fileman date
17 ; v1.5:obsolete::-4: End Time does not have time inside of it.
18 ; -5: BSDXPATID is not numeric
19 ; -6: Patient Does not exist in ^DPT
20 ; -7: Resource Name does not exist in B index of BSDX RESOURCE
21 ; -8: Resouce doesn't exist in ^BSDXRES
22 ; -9: Couldn't add appointment to BSDX APPOINTMENT
23 ; -10: Couldn't add appointment to files 2 and/or 44
24 ; -100: Mumps Error
25
26APPADDD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID) ;EP
27 ;Entry point for debugging
28 D DEBUG^%Serenji("APPADD^BSDX07(.BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)")
29 Q
30 ;
31UT ; Unit Tests
32 N ZZZ
33 ; Test for bad start date
34 D APPADD(.ZZZ,2100123,3100123.3,2,"Dr Office",30,"Sam's Note",1)
35 I +$P(^BSDXTMP($J,1),U,2)'=-2 W "Error in -2",!
36 ; Test for bad end date
37 D APPADD(.ZZZ,3100123,2100123.3,2,"Dr Office",30,"Sam's Note",1)
38 I +$P(^BSDXTMP($J,1),U,2)'=-3 W "Error in -3",!
39 ; Test for end date without time
40 D APPADD(.ZZZ,3100123.1,3100123,2,"Dr Office",30,"Sam's Note",1)
41 I +$P(^BSDXTMP($J,1),U,2)'=-4 W "Error in -4",!
42 ; Test for mumps error
43 S bsdxdie=1
44 D APPADD(.ZZZ,3100123.09,3100123.093,2,"Dr Office",30,"Sam's Note",1)
45 I +$P(^BSDXTMP($J,1),U,2)'=-100 W "Error in -100: M Error",!
46 K bsdxdie
47 ; Test for TRESTART
48 s bsdxrestart=1
49 D APPADD(.ZZZ,3100123.09,3100123.093,3,"Dr Office",30,"Sam's Note",1)
50 I +$P(^BSDXTMP($J,1),U,2)'=0&(+$P(^BSDXTMP($J,1),U,2)'=-10) W "Error in TRESTART",!
51 k bsdxrestart
52 ; Test for non-numeric patient
53 D APPADD(.ZZZ,3100123.09,3100123.093,"CAT,DOG","Dr Office",30,"Sam's Note",1)
54 I +$P(^BSDXTMP($J,1),U,2)'=-5 W "Error in -5",!
55 ; Test for a non-existent patient
56 D APPADD(.ZZZ,3100123.09,3100123.093,8989898989,"Dr Office",30,"Sam's Note",1)
57 I +$P(^BSDXTMP($J,1),U,2)'=-6 W "Error in -6",!
58 ; Test for a non-existent resource name
59 D APPADD(.ZZZ,3100123.09,3100123.093,3,"lkajsflkjsadf",30,"Sam's Note",1)
60 I +$P(^BSDXTMP($J,1),U,2)'=-7 W "Error in -7",!
61 ; Test for corrupted resource
62 ; Can't test for -8 since it requires DB corruption
63 ; Test for inability to add appointment to BSDX Appointment
64 ; Also requires something wrong in the DB
65 ; Test for inability to add appointment to 2,44
66 ; Test by creating a duplicate appointment
67 D APPADD(.ZZZ,3100123.09,3100123.093,3,"Dr Office",30,"Sam's Note",1)
68 D APPADD(.ZZZ,3100123.09,3100123.093,3,"Dr Office",30,"Sam's Note",1)
69 I +$P(^BSDXTMP($J,1),U,2)'=-10 W "Error in -10",!
70 ; Test for normality:
71 D APPADD(.ZZZ,3110123.09,3110123.093,3,"Dr Office",30,"Sam's Note",1)
72 ; Does Appt exist?
73 N APPID S APPID=+$P(^BSDXTMP($J,1),U)
74 I 'APPID W "Error Making Appt-1" QUIT
75 I +^BSDXAPPT(APPID,0)'=3110123.09 W "Error Making Appt-2"
76 I '$D(^DPT(3,"S",3110123.09)) W "Error Making Appt-3"
77 I '$D(^SC(2,"S",3110123.09)) W "Error Making Appt-4"
78 QUIT
79 ;
80APPADD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID) ;EP
81 ;Called by RPC: BSDX ADD NEW APPOINTMENT
82 ;
83 ;Add new appointment to 3 files
84 ; - BSDX APPOINTMENT
85 ; - Hosp Location Appointment SubSubfile if Resource is linked to clinic
86 ; - Patient Appointment Subfile if Resource is linked to clinic
87 ;
88 ;Paramters:
89 ;BSDXY: Global Return (RPC must be set to Global Array)
90 ;BSDXSTART: FM Start Date
91 ;BSDXEND: FM End Date
92 ;BSDXPATID: Patient DFN
93 ;BSDXRES is ResourceName in BSDX RESOURCE file (not IEN)
94 ;BSDXLEN is the appointment duration in minutes
95 ;BSDXNOTE is the Appiontment Note
96 ;BSDXATID is used for 2 purposes:
97 ; if BSDXATID = "WALKIN" then BSDAPI is called to create a walkin appt.
98 ; if BSDXATID = a number, then it is the access type id (used for rebooking)
99 ;
100 ;Return:
101 ; ADO.net Recordset having fields:
102 ; AppointmentID and ErrorNumber
103 ;
104 ;Test lines:
105 ;BSDX ADD NEW APPOINTMENT^3091122.0930^3091122.1000^370^Dr Office^30^EXAM^WALKIN
106 ;
107 ; Return Array; set Return and clear array
108 S BSDXY=$NA(^BSDXTMP($J))
109 K ^BSDXTMP($J)
110 ; $ET
111 N $ET S $ET="G ETRAP^BSDX07"
112 ; Counter
113 N BSDXI S BSDXI=0
114 ; Lock BSDX node, only to synchronize access to the globals.
115 ; It's not expected that the error will ever happen as no filing
116 ; is supposed to take 5 seconds.
117 L +^BSDXAPPT(BSDXPATID):5 I '$T D ERR(BSDXI,"-1~Patient record is locked. Please contact technical support.") Q
118 ; Header Node
119 S ^BSDXTMP($J,BSDXI)="I00020APPOINTMENTID^T00100ERRORID"_$C(30)
120 ;Restartable Transaction; restore paramters when starting.
121 ; (Params restored are what's passed here + BSDXI)
122 TSTART (BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXI):T="BSDX ADD NEW APPOINTMENT^BSDX07"
123 ;
124 ; Turn off SDAM APPT PROTOCOL BSDX Entries
125 N BSDXNOEV
126 S BSDXNOEV=1 ;Don't execute BSDX ADD APPOINTMENT protocol
127 ;
128 ; Set Error Message to be empty
129 N BSDXERR S BSDXERR=0
130 ;
131 ;;;test for error inside transaction. See if %ZTER works
132 I $G(bsdxdie) S X=1/0
133 ;;;test
134 ;;;test for TRESTART
135 I $G(bsdxrestart) K bsdxrestart TRESTART
136 ;;;test
137 ;
138 ; -- Start and End Date Processing --
139 ; If C# sends the dates with extra zeros, remove them
140 S BSDXSTART=+BSDXSTART,BSDXEND=+BSDXEND
141 ; Are the dates valid? Must be FM Dates > than 2010
142 I BSDXSTART'>3100000 D ERR(BSDXI,"-2~BSDX07 Error: Invalid Start Time") Q
143 I BSDXEND'>3100000 D ERR(BSDXI,"-3~BSDX07 Error: Invalid End Time") Q
144 ;
145 ;; If Ending date doesn't have a time, this is an error --rm 1.5
146 ; I $L(BSDXEND,".")=1 D ERR(BSDXI,"-4~BSDX07 Error: Invalid End Time") Q
147 ;
148 ; If the Start Date is greater than the end date, swap dates
149 N BSDXTMP
150 I BSDXSTART>BSDXEND S BSDXTMP=BSDXEND,BSDXEND=BSDXSTART,BSDXSTART=BSDXTMP
151 ;
152 ; Check if the patient exists:
153 ; - DFN valid number?
154 ; - Valid Patient in file 2?
155 I '+BSDXPATID D ERR(BSDXI,"-5~BSDX07 Error: Invalid Patient ID") Q
156 I '$D(^DPT(BSDXPATID,0)) D ERR(BSDXI,"-6~BSDX07 Error: Invalid Patient ID") Q
157 ;
158 ;Validate Resource entry
159 I '$D(^BSDXRES("B",BSDXRES)) D ERR(BSDXI,"-7~BSDX07 Error: Invalid Resource ID") Q
160 N BSDXRESD ; Resource IEN
161 S BSDXRESD=$O(^BSDXRES("B",BSDXRES,0))
162 N BSDXRNOD ; Resouce zero node
163 S BSDXRNOD=$G(^BSDXRES(BSDXRESD,0))
164 I BSDXRNOD="" D ERR(BSDXI,"-8~BSDX07 Error: invalid Resource entry.") Q
165 ;
166 ; Walk-in (Unscheduled) Appointment?
167 N BSDXWKIN S BSDXWKIN=0
168 I BSDXATID="WALKIN" S BSDXWKIN=1
169 ; Reset Access Type ID if it doesn't say "WALKIN" and isn't a number
170 I BSDXATID'?.N&(BSDXATID'="WALKIN") S BSDXATID=""
171 ;
172 ; Done with all checks, let's make appointment in BSDX APPOINTMENT
173 N BSDXAPPTID
174 S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID)
175 I 'BSDXAPPTID D ERR(BSDXI,"-9~BSDX07 Error: Unable to add appointment to BSDX APPOINTMENT file.") Q
176 I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE)
177 ;
178 ; Then Create Subfiles in 2/44 Appointment
179 N BSDXSCD S BSDXSCD=$P(BSDXRNOD,U,4) ; Hosp Location IEN
180 ; Only if we have a valid Hosp Loc can we make an appointment
181 I +BSDXSCD,$D(^SC(BSDXSCD,0)) D I +BSDXERR D ERR(BSDXI,"-10~BSDX07 Error: MAKE^BSDXAPI returned error code: "_BSDXERR) Q
182 . N BSDXC
183 . S BSDXC("PAT")=BSDXPATID
184 . S BSDXC("CLN")=BSDXSCD
185 . S BSDXC("TYP")=3 ;3 for scheduled appts, 4 for walkins
186 . S:BSDXWKIN BSDXC("TYP")=4
187 . S BSDXC("ADT")=BSDXSTART
188 . S BSDXC("LEN")=BSDXLEN
189 . S BSDXC("OI")=$E($G(BSDXNOTE),1,150) ;File 44 has 150 character limit on OTHER field
190 . S BSDXC("OI")=$TR(BSDXC("OI"),";"," ") ;No semicolons allowed by MAKE^BSDXAPI
191 . S BSDXC("OI")=$$STRIP(BSDXC("OI")) ;Strip control characters from note
192 . S BSDXC("USR")=DUZ
193 . S BSDXERR=$$MAKE^BSDXAPI(.BSDXC)
194 . Q:BSDXERR
195 . ;Update RPMS Clinic availability
196 . D AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN)
197 . Q
198 ;
199 ;Return Recordset
200 TCOMMIT
201 L -^BSDXAPPT(BSDXPATID)
202 S BSDXI=BSDXI+1
203 S ^BSDXTMP($J,BSDXI)=BSDXAPPTID_"^"_$C(30)
204 S BSDXI=BSDXI+1
205 S ^BSDXTMP($J,BSDXI)=$C(31)
206 Q
207BSDXDEL(BSDXAPPTID) ;Deletes appointment BSDXAPPTID from BSDXAPPOINTMETN
208 N DA,DIK
209 S DIK="^BSDXAPPT(",DA=BSDXAPPTID
210 D ^DIK
211 Q
212 ;
213STRIP(BSDXZ) ;Replace control characters with spaces
214 N BSDXI
215 F BSDXI=1:1:$L(BSDXZ) I (32>$A($E(BSDXZ,BSDXI))) S BSDXZ=$E(BSDXZ,1,BSDXI-1)_" "_$E(BSDXZ,BSDXI+1,999)
216 Q BSDXZ
217 ;
218BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID) ;ADD BSDX APPOINTMENT ENTRY
219 ;Returns ien in BSDXAPPT or 0 if failed
220 ;Create entry in BSDX APPOINTMENT
221 N BSDXAPPTID
222 S BSDXFDA(9002018.4,"+1,",.01)=BSDXSTART
223 S BSDXFDA(9002018.4,"+1,",.02)=BSDXEND
224 S BSDXFDA(9002018.4,"+1,",.05)=BSDXPATID
225 S BSDXFDA(9002018.4,"+1,",.07)=BSDXRESD
226 S BSDXFDA(9002018.4,"+1,",.08)=$G(DUZ)
227 S BSDXFDA(9002018.4,"+1,",.09)=$$NOW^XLFDT
228 S:BSDXATID="WALKIN" BSDXFDA(9002018.4,"+1,",.13)="y"
229 S:BSDXATID?.N BSDXFDA(9002018.4,"+1,",.06)=BSDXATID
230 N BSDXIEN,BSDXMSG
231 D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
232 S BSDXAPPTID=+$G(BSDXIEN(1))
233 Q BSDXAPPTID
234 ;
235BSDXWP(BSDXAPPTID,BSDXNOTE) ;
236 ;Add WP field
237 I BSDXNOTE]"" S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE=""
238 I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0)
239 I $D(BSDXNOTE(.5)) D
240 . D WP^DIE(9002018.4,BSDXAPPTID_",",1,"","BSDXNOTE","BSDXMSG")
241 Q
242 ;
243ADDEVT(BSDXPATID,BSDXSTART,BSDXSC,BSDXSCDA) ;EP
244 ;Called by BSDX ADD APPOINTMENT protocol
245 ;BSDXSC=IEN of clinic in ^SC
246 ;BSDXSCDA=IEN for ^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA). Use to get Length & Note
247 ;
248 N BSDXNOD,BSDXLEN,BSDXAPPTID,BSDXNODP,BSDXWKIN,BSDXRES
249 Q:+$G(BSDXNOEV)
250 I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0))
251 E I $D(^BSDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0))
252 Q:'+$G(BSDXRES)
253 S BSDXNOD=$G(^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA,0))
254 Q:BSDXNOD=""
255 S BSDXNODP=$G(^DPT(BSDXPATID,"S",BSDXSTART,0))
256 S BSDXWKIN=""
257 S:$P(BSDXNODP,U,7)=4 BSDXWKIN="WALKIN" ;Purpose of Visit field of DPT Appointment subfile
258 S BSDXLEN=$P(BSDXNOD,U,2)
259 Q:'+BSDXLEN
260 S BSDXEND=$$FMADD^XLFDT(BSDXSTART,0,0,BSDXLEN,0)
261 S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXWKIN)
262 Q:'+BSDXAPPTID
263 S BSDXNOTE=$P(BSDXNOD,U,4)
264 I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE)
265 D ADDEVT3(BSDXRES)
266 Q
267 ;
268ADDEVT3(BSDXRES) ;
269 ;Call RaiseEvent to notify GUI clients
270 N BSDXRESN
271 S BSDXRESN=$G(^BSDXRES(BSDXRES,0))
272 Q:BSDXRESN=""
273 S BSDXRESN=$P(BSDXRESN,"^")
274 ;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","")
275 D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
276 Q
277 ;
278ERR(BSDXI,BSDXERR) ;Error processing
279 S BSDXI=BSDXI+1
280 S BSDXERR=$TR(BSDXERR,"^","~")
281 I $TL>0 TROLLBACK
282 S ^BSDXTMP($J,BSDXI)="0^"_BSDXERR_$C(30)
283 S BSDXI=BSDXI+1
284 S ^BSDXTMP($J,BSDXI)=$C(31)
285 L -^BSDXAPPT(BSDXPATID)
286 Q
287 ;
288ETRAP ;EP Error trap entry
289 N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
290 ; Rollback, otherwise ^XTER will be empty from future rollback
291 I $TL>0 TROLLBACK
292 D ^%ZTER
293 S $EC="" ; Clear Error
294 ; Log error message and send to client
295 I '$D(BSDXI) N BSDXI S BSDXI=0
296 D ERR(BSDXI,"-100~BSDX07 Error: "_$G(%ZTERZE))
297 Q
298 ;
299DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
300 ;
301DOW S %=$E(X,1,3),Y=$E(X,4,5),Y=Y>2&'(%#4)+$E("144025036146",Y)
302 F %=%:-1:281 S Y=%#4=1+1+Y
303 S Y=$E(X,6,7)+Y#7
304 Q
305 ;
306AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) ;Update RPMS Clinic availability
307 ;SEE SDM1
308 N Y,DFN
309 N SL,STARTDAY,X,SC,SB,HSI,SI,STR,SDDIF,SDMAX,SDDATE,SDDMAX,SDSDATE,CCXN,MXOK,COV,SDPROG
310 N X1,SDEDT,X2,SD,SM,SS,S,SDLOCK,ST,I
311 S Y=BSDXSCD,DFN=BSDXPATID
312 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
313 ;Determine maximum days for scheduling
314 S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365
315 S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
316 S SDDATE=BSDXSTART
317 S SDSDATE=SDDATE,SDDATE=SDDATE\1
3181 ;L Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC
319 Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC
320 S X1=DT,SDEDT=365 S:$D(^SC(SC,"SDP")) SDEDT=$P(^SC(SC,"SDP"),"^",2)
321 S X2=SDEDT D C^%DTC S SDEDT=X
322 S Y=BSDXSTART
323EN1 S (X,SD)=Y,SM=0 D DOW
324S 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,".")
325 S S=BSDXLEN
326 ;Check if BSDXLEN evenly divisible by appointment length
327 S RPMSL=$P(SL,U)
328 I BSDXLEN<RPMSL S BSDXLEN=RPMSL
329 I BSDXLEN#RPMSL'=0 D
330 . S BSDXINC=BSDXLEN\RPMSL
331 . S BSDXINC=BSDXINC+1
332 . S BSDXLEN=RPMSL*BSDXINC
333 S SL=S_U_$P(SL,U,2,99)
334SC S SDLOCK=$S('$D(SDLOCK):1,1:SDLOCK+1) Q:SDLOCK>9
335 L +^SC(SC,"ST",$P(SD,"."),1):5 G:'$T SC
336 S SDLOCK=0,S=^SC(SC,"ST",$P(SD,"."),1)
337 S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST
338 I (I<1!'$F(S,"["))&(S'["CAN") L -^SC(SC,"ST",$P(SD,"."),1) Q
339 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
340 ;
341SP I ST+ST>$L(S),$L(S)<80 S S=S_" " G SP
342 S SDNOT=1
343 S ABORT=0
344 F I=ST+ST:SDDIF:SS-SDDIF D Q:ABORT
345 . S ST=$E(S,I+1) S:ST="" ST=" "
346 . S Y=$E(STR,$F(STR,ST)-2)
347 . I S["CAN"!(ST="X"&($D(^SC(+SC,"ST",$P(SD,"."),"CAN")))) S ABORT=1 Q
348 . I Y="" S ABORT=1 Q
349 . 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
350 . Q
351 S ^SC(SC,"ST",$P(SD,"."),1)=S
352 L -^SC(SC,"ST",$P(SD,"."),1)
353 Q
Note: See TracBrowser for help on using the repository browser.