source: cprs/branches/tmg-cprs/m_files/TMGSDAU.m@ 1742

Last change on this file since 1742 was 796, checked in by Kevin Toppenberg, 14 years ago

Initial upload

File size: 16.0 KB
RevLine 
[796]1TMGSDAU ;TMG/kst/Schedule Availability Utilities ;1/06/09
2 ;;1.0;TMG-LIB;**1**;12/08/08
3 ;
4 ;"TMG SCHEDULING AVAILIBILITY UTILITIES
5 ;"Kevin Toppenberg MD
6 ;"GNU General Public License (GPL) applies
7 ;"12/22/08
8 ;
9 ;"NOTE: Much of this code originated from SDB*.m (heavily modified!)
10 ;"
11 ;"=======================================================================
12 ;" API -- Public Functions.
13 ;"=======================================================================
14 ;"FRSH7ST(TMGIEN,TMG1DATE,TMGMSG) -- Refresh 7 weeks of "ST" nodes, starting at given date.
15 ;"ENSUR1ST(TMGIEN,TMG1DATE,TMGMSG) -- Ensure a "ST" node exists for a given date.
16 ;"FORCE1ST(TMGIEN,TMG1DATE,TMGMSG) -- make/remake a "ST" node for a given date.
17 ;"PAT4DAY(TMGIEN,TMG1DATE,TMGARR,TMGMSG) -- return a pattern appropriate for placing in "ST" for date.
18 ;"FIX1ST(TMGIEN,TMG1DATE,TMGMSG) -- set slot numbers to match existing appts.
19 ;"DEC1SLOT(TMGIEN,APPT,TMGMSG) -- decrement the availability number for a slot at a given time
20 ;"SLTINDEX(TMGIEN,APPT,SAVARR) -- return INDEX in "ST" PATTERN node for given appt slot time
21 ;"SPECPAT(TMGIEN,DATE,AVAILSTR) -- Add header to AvailStr
22 ;
23 ;"=======================================================================
24 ;"Dependancies
25 ;"=======================================================================
26 ;"=======================================================================
27 ;
28FRSH7ST(TMGIEN,TMG1DATE,TMGMSG)
29 ;"Purpose: To Refresh 7 weeks of "ST" nodes, starting at given date.
30 ;" (All on same day of week.)
31 ;" It will copy from LIMDTate nodes if needed, and then check for
32 ;" any existing appts on that date, and add them if needed.
33 ;" NOTE: if the "ST" node already exists, it Will be remade.
34 ;"Input: TMGIEN -- IEN in file 44 to work on
35 ;" TMG1DATE -- the date to start refreshing ST on
36 ;" TMGMSG -- PASS BY REFERENCE, an OUT PARAMETER. Format:
37 ;" TMGMSG=line count of error messages
38 ;" TMGMSG(1)=ErrMsg
39 ;" TMGMSG(2)=ErrMsg etc..
40 ;"Globally-scoped vars used: ...
41 ;"Result: 1 = Success or
42 ;" 0 = Intermediate success
43 ;" -1 = error
44 ;
45 NEW TMGRESULT SET TMGRESULT=1
46 LOCK +^SC(TMGIEN,"ST"):10
47 ELSE DO GOTO FR7DONE
48 . SET TMGMSG=+$GET(TMGMSG)+1
49 . SET TMGMSG(TMGMSG)="Unable to get lock on ^SC("_TMGIEN_",""ST"",)."
50 . SET TMGRESULT=-1
51 NEW COUNT,DATE
52 SET DATE=TMG1DATE
53 FOR COUNT=1:1:7 DO QUIT:(TMGRESULT'=1)
54 . KILL ^SC(TMGIEN,"ST",DATE)
55 . SET TMGRESULT=$$FORCE1ST(TMGIEN,DATE,.TMGMSG)
56 . SET DATE=$$ADD2DATE^TMGAVLS1(DATE,7)
57 LOCK -^SC(TMGIEN,"ST")
58FR7DONE ;
59 QUIT TMGRESULT
60 ;
61 ;
62ENSUR1ST(TMGIEN,TMG1DATE,TMGMSG)
63 ;"Purpose: To Ensure a "ST" node exists for a given date.
64 ;" It will copy from LIMDTate nodes if needed, and then check for
65 ;" any existing appts on that date, and add them if needed.
66 ;" NOTE: if the "ST" node already exists, it will NOT be remade.
67 ;"Input: TMGIEN -- IEN in file 44 to work on
68 ;" TMG1DATE -- the date to force ST for. Don't pass by reference
69 ;" TMGMSG -- PASS BY REFERENCE, an OUT PARAMETER. Format:
70 ;" TMGMSG=line count of error messages
71 ;" TMGMSG(1)=ErrMsg
72 ;" TMGMSG(2)=ErrMsg etc..
73 ;"Globally-scoped vars used: ...
74 ;"Result: 1 = Success or
75 ;" 0 = Intermediate success
76 ;" -1 = error
77 ;
78 NEW TMGRESULT SET TMGRESULT=1
79 SET TMG1DATE=$GET(TMG1DATE)\1
80 LOCK +^SC(TMGIEN,"ST",TMG1DATE):10
81 ELSE DO GOTO E1STDONE
82 . SET TMGMSG=+$GET(TMGMSG)+1
83 . SET TMGMSG(TMGMSG)="Unable to get lock on ^SC("_TMGIEN_",""ST"","_TMG1DATE_")."
84 . SET TMGRESULT=-1
85 IF $DATA(^SC(TMGIEN,"ST",TMG1DATE))=0 DO
86 . SET TMGRESULT=$$FORCE1ST(TMGIEN,TMG1DATE,.TMGMSG)
87 LOCK -^SC(TMGIEN,"ST",TMG1DATE)
88E1STDONE ;
89 QUIT TMGRESULT
90 ;
91 ;
92FORCE1ST(TMGIEN,TMG1DATE,TMGMSG)
93 ;"Purpose: To make/remake a "ST" node for a given date.
94 ;" It will copy from LIMDTate nodes if needed, and then check for
95 ;" any existing appts on that date, and add them if needed.
96 ;" NOTE: if the "ST" node already exists, it WILL be remade.
97 ;"Input: TMGIEN -- IEN in file 44 to work on
98 ;" TMG1DATE -- the date to force ST for.
99 ;" TMGMSG -- PASS BY REFERENCE, an OUT PARAMETER. Format:
100 ;" TMGMSG=line count of error messages
101 ;" TMGMSG(1)=ErrMsg
102 ;" TMGMSG(2)=ErrMsg etc..
103 ;"Globally-scoped vars used: ...
104 ;"Result: 1 = Success or
105 ;" 0 = Intermediate success
106 ;" -1 = error
107 ;
108 NEW TMGRESULT,TMGARR
109 NEW DATE SET DATE=TMG1DATE\1
110 LOCK +^SC(TMGIEN,"ST",DATE):10
111 ELSE DO GOTO M1STDONE
112 . SET TMGMSG=+$GET(TMGMSG)+1
113 . SET TMGMSG(TMGMSG)="Unable to get lock on ^SC("_TMGIEN_",""ST"","_DATE_")."
114 . SET TMGRESULT=-1
115 SET TMGRESULT=$$PAT4DAY(TMGIEN,TMG1DATE,.TMGARR,.TMGMSG)
116 IF TMGRESULT'=1 GOTO M1STDONE
117 KILL ^SC(TMGIEN,"ST",DATE)
118 MERGE ^SC(TMGIEN,"ST",DATE)=TMGARR
119 IF $$FIX1ST(TMGIEN,TMG1DATE,.TMGMSG)=-1 SET TMGRESULT=0
120 LOCK -^SC(TMGIEN,"ST",TMG1DATE)
121M1STDONE ;
122 QUIT TMGRESULT
123 ;
124 ;
125PAT4DAY(TMGIEN,TMG1DATE,TMGARR,TMGMSG)
126 ;"Purpose: To return a pattern appropriate for placing in "ST" for date.
127 ;"Input: TMGIEN -- IEN in file 44 to work on
128 ;" TMG1DATE -- the date to work on.
129 ;" TMGARR -- PASS BY REFERENCE. An OUT PARAMETER. Prior results killed.
130 ;" This is an array that may be merged with ^SC(TMGIEN,"ST",DATE)
131 ;" TMGMSG -- PASS BY REFERENCE, an OUT PARAMETER. Format:
132 ;" TMGMSG=line count of error messages
133 ;" TMGMSG(1)=ErrMsg
134 ;" TMGMSG(2)=ErrMsg etc..
135 ;"Globally-scoped vars used: ...
136 ;"Result: 1 = Success or
137 ;" -1 = error
138 ;
139 KILL TMGARR
140 NEW TMGRESULT SET TMGRESULT=-1 ;"default to failure
141 NEW TMGSLNOD SET TMGSLNOD=$GET(^SC(TMGIEN,"SL")) ;"^SC(IEN,"SL", SL node
142 NEW TMGSOH SET TMGSOH=($PIECE(TMGSLNOD,"^",8)="Y") ;"SOH=Schedule On Holidays.
143 NEW DATE SET DATE=TMG1DATE\1 ;"strip minutes
144 NEW DOW SET DOW=$$DOW^XLFDT(DATE,1)#7
145 ;
146 IF $DATA(^HOLIDAY(DATE))&('TMGSOH) DO GOTO P4DDONE
147 . SET TMGMSG=+$GET(TMGMSG)+1
148 . SET TMGMSG(TMGMSG)=$$EXTDAT^TMGAVLS1(DATE)_" is a holiday, and Location settings don't allow scheduling."
149 ;
150 IF $DATA(^SC(TMGIEN,"OST",DATE,1)) DO
151 . MERGE TMGARR=^SC(TMGIEN,"OST",DATE)
152 . SET TMGARR(9)=TMGIEN
153 . SET TMGRESULT=1
154 ;
155 ;"IF '$DATA(^SC(TMGIEN,"ST",DATE,1)) DO ;"Copy from TEMPLATE for this day, date
156 IF TMGRESULT'=1 DO ;"Copy from TEMPLATE for this day, date
157 . NEW STR
158 . NEW LIMDT SET LIMDT=+$ORDER(^SC(TMGIEN,"T"_DOW,DATE)) ;"Tx entries are LIMIT dated...
159 . IF LIMDT'>0 QUIT
160 . NEW TEMPL SET TEMPL=$GET(^SC(TMGIEN,"T"_DOW,LIMDT,1))
161 . IF TEMPL="" QUIT
162 . SET STR=$$SPECPAT(TMGIEN,DATE,TEMPL) ;"Return string like this: MO 05 | [2 2 2 2|2 2 2 2]
163 . SET TMGARR(1)=STR
164 . SET TMGARR(0)=DATE
165 . SET TMGRESULT=1
166 ;
167 IF TMGRESULT=-1 DO
168 . SET TMGMSG=+$GET(TMGMSG)+1
169 . SET TMGMSG(TMGMSG)="NO TEMPLATE; Unable to find a slot pattern defined for "_$$EXTDAT^TMGSDAU1(DATE)
170 ;
171P4DDONE ;
172 QUIT TMGRESULT
173 ;
174 ;
175FIX1ST(TMGIEN,TMG1DATE,TMGMSG)
176 ;"Purpose: To set slot numbers to match existing appts.
177 ;"IMPORTANT NOTICE: This should *only* be called after a fresh template pattern
178 ;" has been copied into the ST node. This is because this function
179 ;" will decrease availability count for slots based on existing appts.
180 ;" If this has already been done, then calling this again will result
181 ;" in the availability count being reduced AGAIN--making it appear
182 ;" that the slot is being used, when it actually is NOT.
183 ;"Input: TMGIEN -- IEN in file 44 to work on
184 ;" TMG1DATE -- the date to fix ST for.
185 ;" TMGMSG -- PASS BY REFERENCE, an OUT PARAMETER. Format:
186 ;" TMGMSG=line count of error messages
187 ;" TMGMSG(1)=ErrMsg
188 ;" TMGMSG(2)=ErrMsg etc..
189 ;"Globally-scoped vars used: TMGIEN
190 ;"Result: 1 = Success or
191 ;" -1 = error
192 ;
193 NEW TMGRESULT SET TMGRESULT=1
194 NEW APPT SET APPT=TMG1DATE\1 ;"All appts should have time, by trimming time, will sort before actual appts
195 FOR SET APPT=$ORDER(^SC(TMGIEN,"S",APPT)) QUIT:(APPT\1'=TMG1DATE\1)!(TMGRESULT=-1) DO ;"Only check same day
196 . IF $$NONAPPT(TMGIEN,APPT) QUIT
197 . SET TMGRESULT=$$DEC1SLOT(TMGIEN,APPT,.TMGMSG)
198F1STDONE ;
199 QUIT TMGRESULT
200 ;
201 ;
202DEC1SLOT(TMGIEN,APPT,TMGMSG)
203 ;"Purpose: To decrement the availability number for a slot at a given time
204 ;"Input: TMGIEN -- IEN in file 44 to work on
205 ;" APPT -- A FMDateTime number to indicate date & time of appt.
206 ;" TMGMSG -- PASS BY REFERENCE, an OUT PARAMETER. Format:
207 ;" TMGMSG=line count of error messages
208 ;" TMGMSG(1)=ErrMsg
209 ;" TMGMSG(2)=ErrMsg etc..
210 ;"Globally-scoped vars used: TMGIEN
211 ;"Result: 1 = Success or
212 ;" -1 = error
213 ;
214 NEW TMGRESULT SET TMGRESULT=1 ;"default to success
215 NEW DATE SET DATE=APPT\1
216 LOCK +^SC(TMGIEN,"ST",DATE):10 ;"Prevent interferance from any other process.
217 ELSE DO GOTO D1SDONE
218 . SET TMGMSG=+$GET(TMGMSG)+1
219 . SET TMGMSG(TMGMSG)="Unable to get lock on ^SC("_TMGIEN_",""ST"","_DATE_")."
220 . SET TMGRESULT=-1
221 NEW STR SET STR=$GET(^SC(TMGIEN,"ST",DATE,1))
222 IF STR="" DO GOTO D1SUL
223 . SET TMGMSG=+$GET(TMGMSG)+1
224 . SET TMGMSG(TMGMSG)="Can't find a PATTERN entry for "_$$EXTDAT^TMGAVLS1(DATE)_", so can't decrease slot availability."
225 . SET TMGRESULT=-1
226 ;
227 NEW INDX SET INDX=$$SLTINDEX(TMGIEN,APPT)
228 ;"G X:(I<1!'$F(S,"["))&(S'["CAN")
229 ;"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
230 ;
231 NEW CODES SET CODES="{}&%?#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
232 FOR QUIT:(INDX'>$LENGTH(STR))!($LENGTH(STR)'<IOM) SET STR=STR_" "
233 ;
234 ;"Note: I am not sure what SDDIF or SS is here, and trials runs only went through once, will will not loop
235 ;"FOR INDX=(SLOTINDX*2):SDDIF:SS-SDDIF DO QUIT:(TMGRESULT=-1)
236 DO
237 . NEW TEMP,DECCHR
238 . SET TEMP=$EXTRACT(STR,INDX)
239 . IF TEMP="" SET TEMP=" "
240 . SET DECCHR=$EXTRACT(CODES,$FIND(CODES,TEMP)-2) ;"Return char occuring just before TEMP value in STR
241 . IF (STR["CAN")!((TEMP="X")&($DATA(^SC(TMGIEN,"ST",DATE,"CAN")))) DO QUIT
242 . . SET TMGMSG=+$GET(TMGMSG)+1
243 . . SET TMGMSG(TMGMSG)="Can't alter slots within a CANCELLED time period.!"
244 . . SET TMGRESULT=-1
245 . IF DECCHR="" DO QUIT
246 . . SET TMGMSG=+$GET(TMGMSG)+1
247 . . SET TMGMSG(TMGMSG)="Error in DEC1SLOT^TMGAVLG: DECCHR=''"
248 . . SET TMGRESULT=-1
249 . ;"IF (DECCHR'?1NL)&(SM<6) SET SM=6 ;"Look for DECCHR as number or lowercase letter
250 . SET TEMP=$EXTRACT(STR,INDX+1,999)
251 . IF TEMP="" SET TEMP=" "
252 . SET STR=$EXTRACT(STR,1,INDX-1)_DECCHR_TEMP
253 ;
254 SET ^SC(TMGIEN,"ST",DATE,1)=STR ;"Store new pattern.
255D1SUL LOCK -^SC(TMGIEN,"ST",DATE) ;"Release lock
256D1SDONE ;
257 QUIT TMGRESULT
258 ;
259 ;
260SLTINDEX(TMGIEN,APPT,SAVARR)
261 ;"Purpose: To return INDEX in "ST" PATTERN node for given appt slot time
262 ;"Input: TMGIEN -- IEN in file 44
263 ;" APPT -- FMDateTime of appointment
264 ;" SAVARR -- PASS BY REFERANCE. A save array, so that prior lookups can be reused. Format:
265 ;" SAVARR(DateTime)=Index
266 ;" SAVARR(DateTime)=Index
267 ;" SAVARR("T",STR,MilitaryTime)=Index
268 ;" SAVARR("T",STR,MilitaryTime)=Index
269 ;"Globally-scoped vars used: TMGIEN
270 ;"Result: Returns 0 if problem
271 ;" Otherwise returns index value for accessing character in "ST",1) node.
272 ;
273 NEW TMGRESULT SET TMGRESULT=0
274 IF $DATA(SAVARR(APPT)) DO GOTO SLIDONE ;"Use prior lookup if possible
275 . SET TMGRESULT=+$GET(SAVARR(APPT))
276 NEW DATE SET DATE=APPT\1
277 NEW MILTIME SET MILTIME=(APPT#1)*1000
278 NEW STR SET STR=$GET(^SC(TMGIEN,"ST",DATE,1))
279 IF STR="" SET TMGRESULT=0 GOTO SLIDONE
280 SET STR=$PIECE(STR,"|",2,25)
281 IF $DATA(SAVARR("T",STR,MILTIME)) DO GOTO SLIDONE
282 . SET TMGRESULT=+$GET(SAVARR("T",STR,MILTIME))
283 ;
284 NEW TMGSPH SET TMGSPH=+$P($GET(^SC(TMGIEN,"SL")),"^",6) ;"SL;6 = DISPLAY INCS PER HOUR (Slots per Hr)
285 IF TMGSPH'>0 SET TMGSPH=4 ;"Default to 4 slots/hr
286 NEW STARTDAY SET STARTDAY=+$P($GET(^SC(TMGIEN,"SL")),"^",3) ;"SL;3=HR CLINIC DISPLAY BEGINS
287 NEW SB SET SB=(STARTDAY-1)/100 ;"Eg 8 am --> .07
288 ;
289 ;"Convert Hrs.Min --> fractional hours. e.g. 1:30 --> 1.5; 3.45 --> 3.75
290 NEW HROFFSET SET HROFFSET=((APPT#1)-SB)*100 ;"HROFFSET=Num of Hrs (i.e. hrs.min 1.3=1 hr, 30 min) **past** display start time (i.e. 7am)
291 ;"Note: SB is usually 1 hr before true display start time. I.e. .07 for start time of 8 am
292 ;" I think this is to allow for the header info (e.g. 'SUN 04 |')
293 NEW MINOFFST SET MINOFFST=HROFFSET#1 ;"Get just minutes part, e.g. 0.3 (i.e. 30 minutes)
294 SET HROFFSET=HROFFSET\1 ;"Get just hrs part
295 SET MINOFFST=MINOFFST/0.6 ;"integer divide (i.e round output) by 0.6, e.g. 1.2/0.6 --> 2. Note, 0.6 here means 60 minutes
296 ;"SET MINOFFST=MINOFFST*TMGSPH ;"multiply by slots/hr, e.g. 4 --> 0.3 * 4 = 1.2 (i.e. 120 minutes)
297 NEW SLOTINDX SET SLOTINDX=(HROFFSET+MINOFFST)*TMGSPH ;"Add number of hrs past display start time * slots/hr --> slot index #
298 ;
299 SET TMGRESULT=(SLOTINDX*2)+1 ;"x2 because of spaces etc between character values, and 1st slot begins 1 character after '|'
300 ;
301 SET SAVARR(APPT)=TMGRESULT
302 SET SAVARR("T",STR,MILTIME)=TMGRESULT
303SLIDONE ;
304 QUIT TMGRESULT
305 ;
306 ;
307SPECPAT(TMGIEN,DATE,AVAILSTR)
308 ;"Purpose: Return string like this: MO 05 | [2 2 2 2|2 2 2 2]
309 ;" ... given the original pattern string ('AvailStr'), e.g. ' [2 2 2 2|2 2 2 2]'
310 NEW DOW SET DOW=$$DOW^XLFDT(DATE,1) ;"DOW=Day of Week (0-6)
311 NEW TMGSPH SET TMGSPH=+$P($GET(^SC(TMGIEN,"SL")),"^",6) ;"SL;6 = DISPLAY INCS PER HOUR (Slots per Hr)
312 IF TMGSPH'>0 SET TMGSPH=4 ;"Default to 4 slots/hr
313 NEW SI SET SI=+TMGSPH
314 IF (SI=0)!(SI=1)!(SI=2) SET SI=4
315 NEW SM
316 SET SM=$P("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "
317 SET SM=SM_$EXTRACT(DATE,6,7)_$J("",SI+SI-6)
318 SET SM=SM_AVAILSTR_$J("",64-$LENGTH(AVAILSTR))
319 QUIT SM
320 ;
321 ;
322NONAPPT(TMGIEN,APPT)
323 ;"Purpose: To see if appointment is inactivated (i.e. a Non-Appt)
324 ;"Input: TMGIEN -- IEN in file 44
325 ;" APPT -- FMDateTime of appointment
326 ;"Result: 0 if appt is active, 1 if cancelled etc.
327 NEW TMGRESULT SET TMGRESULT=1 ;"Default to cancelled.
328 NEW DFN SET DFN=+$PIECE($GET(^SC(TMGIEN,"S",APPT,1,1,0)),"^",1) ;"Patient IEN
329 IF DFN'>0 SET TMGRESULT=-1 GOTO NADONE
330 NEW STATUS SET STATUS=$PIECE($GET(^DPT(DFN,"S",APPT,0)),"^",2) ;"Status field
331 IF STATUS="" SET TMGRESULT=0
332NADONE QUIT TMGRESULT
333 ;
334 ;
Note: See TracBrowser for help on using the repository browser.