source: cprs/branches/tmg-cprs/m_files/TMGTIUOJ.m@ 1099

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

Initial upload
File size: 39.4 KB
RevLine 
[796]1TMGTIUOJ ;TMG/kst-Text objects for use in CPRS ;03/25/06
2 ;;1.0;TMG-LIB;**1**;03/12/09
3
4 ;"TMG text objects
5 ;"
6 ;"These are bits of code that return text to be included in progress notes etc.
7 ;"They are called when the user puts text like this in a note:
8 ;" ... Mrs. Jone's vitals today are |VITALS|, measured in the office...
9 ;" 'VITALS' would be a TIU TEXT OBJECT, managed through menu option TIUFJ CREATE OBJECTS MGR
10
11 ;"---------------------------------------------------------------------------
12 ;"PUBLIC FUNCTIONS
13 ;"---------------------------------------------------------------------------
14
15 ;"$$VITALS(DFN,.TIU)
16 ;"$$NICENAME(DFN)
17 ;"$$FNAME(DFN)
18 ;"$$MNAME(DFN)
19 ;"$$LNAME(DFN)
20 ;"$$PHONENUM(DFN)
21 ;"$$GETTABLX(DFN,LABEL)
22 ;"$$WTTREND(DFN,.TIU) return text showing patient's trend in change of weight.
23 ;"$$WTDELTA(DFN,.TIU) return text showing patient's change in weight.
24 ;"$$GETTABL1(DFN,LABEL) -- return a table from prior notes.
25 ;"$$GETTABLX(DFN,LABEL) -- return a table compiled from prior notes.
26
27 ;"---------------------------------------------------------------------------
28 ;"PRIVATE FUNCTIONS
29 ;"---------------------------------------------------------------------------
30 ;"FormatVitals(result,s,Label,CurDT,NoteDT)
31 ;"RemoveDT(S,DT)
32 ;"RemoveTime(DT)
33 ;"DateDelta(RefDT,DT)
34 ;"FormatHeight(HtS,PtAge) remove centimeters from patient's height for adults
35 ;"TMGVISDT(TIU) Return a string for date of visit
36 ;"GetLast2(Array,NTLast,Last) Returns last 2 values in array (as created by GetPriorVital)
37 ;"GetPriorVital(DFN,Date,Vital,Array) retrieve a list of prior vital entries for a patient
38
39 ;"GetNotesList(DFN,List,IncDays)
40 ;"ExtractSpecial(IEN8925,StartMarkerS,EndMarkerS,Array)
41 ;"MergeInto(partArray,masterArray)
42 ;"GetSpecial(DFN,StartMarkerS,EndMarkerS,Months,Array,Mode)
43
44 ;"Array2Str(Array) convert Array (as created by GetSpecial) into one long string
45 ;"AddIfAbsent(Array,Key,Pivot,Value) add one (empty) entry, if a value for this doesn't already exist.
46 ;"StubRecommendations(DFN,Array,Label) add stubs for recommended studies to Array
47
48 ;"---------------------------------------------------------------------------
49 ;"---------------------------------------------------------------------------
50
51VITALS(DFN,TIU)
52 ;"Purpose: Return a composite Vitals string like this:
53 ;" T: 98.6 BP: 112/78 R: 17 P: 68 Wt.: 190 Ht.: 76
54 ;"Input: DFN -- the patient's unique ID (record#)
55 ;" TIU -- this is an array created by TIU system that
56 ;" contains information about the document being
57 ;" edited/created. I believe it has this structure:
58 ;" TIU("VSTR") = LOC;VDT;VTYP
59 ;" TIU("VISIT") = Visit File IFN^date?
60 ;" TIU("LOC")
61 ;" TIU("VLOC")
62 ;" TIU("STOP") = mark to defer workload
63 ;" TIU("TYPE")=1^title DA^title Name i.e.: 1^128^OFFICE VISIT^OFFICE VISIT
64 ;" TIU("SVC")=service, e.g. "FAMILY PRACTICE"
65 ;" TIU("EDT")=TIUEDT^DateStr = event begin time: FMDate^DateStr
66 ;" TIU("LDT")=TIULDT^DateStr = event end time: FMDate^DateStr
67 ;" TIU("VSTR")=LOC;VDT;VTYP e.g. "x;x;OFFICE VISIT"
68 ;" TIU("VISIT")=Visit File IFN
69 ;" TIU("LOC")=TIULOC
70 ;" TIU("VLOC")=TIULOC
71 ;" TIU("STOP")=0 ;"0=FALSE, don't worry about stop codes.
72 ;"Output: returns result
73
74 new result set result=""
75 new CurDT set CurDT=""
76 new NoteDT set NoteDT=""
77
78 new PtAge
79 do
80 . new IENS,TMGARRAY
81 . set IENS=$get(DFN)_","
82 . do GETS^DIQ(2,IENS,.033,"TMGARRAY") ;".033 is computed patient age
83 . set PtAge=+$get(TMGARRAY(2,IENS,.033)) ;"will return 0 if not found
84
85 new Wt,Ht
86 set NoteDT=$$VISDATE^TIULO1(.TIU) ;"Get date of current note (in MM/DD/YY HR:MIN)
87 set NoteDT=$piece(NoteDT," ",1) ;"Drop time
88 set CurDT=NoteDT
89
90 ;"set result="Resp="_$$RESP^TIULO(+$get(DFN))_", "
91 ;"set result="Pulse="_$$PULSE^TIULO(+$get(DFN))_", "
92
93 do FormatVitals(.result,$$TEMP^TIULO(+$get(DFN)),"T",.CurDT,.NoteDT)
94 do FormatVitals(.result,$$BP^TIULO(+$get(DFN)),"BP",.CurDT,.NoteDT)
95 do FormatVitals(.result,$$RESP^TIULO(+$get(DFN)),"R",.CurDT,.NoteDT)
96 do FormatVitals(.result,$$PULSE^TIULO(+$get(DFN)),"P",.CurDT,.NoteDT)
97 set Wt=$$WEIGHT^TIULO(+$get(DFN))
98 set Ht=$$HEIGHT^TIULO(+$get(DFN))
99 set Ht=$$FormatHeight(Ht,.PtAge)
100 do FormatVitals(.result,Wt,"Wt",.CurDT,.NoteDT,1)
101 if (Wt'="")&(Ht'="") set result=result_$char(10)_$char(9)
102 do FormatVitals(.result,Ht,"Ht",.CurDT,.NoteDT,1)
103 ;"set result=result_";" ;temp!!
104
105 ;"Now calculate BMI if Wt & Ht available
106 ;" BMI=kg/meters^2
107 if (Wt'="")&(Ht'="") do
108 . new sWt,sHt
109 . new nWt,nHt,s1,BMI
110 . set sWt=$$RemoveDT(Wt)
111 . set sHt=$$RemoveDT(Ht)
112 . set s1=$piece(sWt,"[",2) ;"convert '200 lb [91.2 kg]' --> '91.2 kg]'
113 . set nWt=+$piece(s1," ",1) ;"convert '91.2 kg]' --> 91.2
114 . set s1=$piece(sHt,"[",2) ;"convert '56 in [130 cm]' --> '130 cm]'
115 . set nHt=+$piece(s1," ",1) ;"convert '130 cm]' --> 130
116 . set nHt=nHt/100 ;"convert centimeters to meters
117 . if nHt>0 do
118 . . new tempBMI,iBMI,Digit
119 . . new MSqr set MSqr=(nHt*nHt)
120 . . set tempBMI=(nWt/MSqr)
121 . . set Digit=(((tempBMI-(tempBMI\1))*10)\1)/10
122 . . set BMI=(tempBMI\1)+Digit
123 . . do FormatVitals(.result,BMI,"BMI",.CurDT)
124 . . if BMI<18.5 do
125 . . . set result=result_" (<18.5 = ""UNDER-WT"")"
126 . . else if BMI<25.01 do
127 . . . set result=result_" (18.5-25 = ""HEALTHY"")"
128 . . else if BMI<30.01 do
129 . . . set result=result_" (25-30 = ""OVER-WT"")"
130 . . else if BMI<40.01 do
131 . . . set result=result_" (30-40 = ""OBESE"")"
132 . . else do
133 . . . set result=result_" (>40 = ""VERY OBESE"")"
134 . . new idealLb1,idealLb2
135 . . set idealLb1=((18.5*MSqr)*2.2)\1
136 . . set idealLb2=((25*MSqr)*2.2)\1
137 . . set result=result_$char(10)_$char(9)_"(Ideal Wt="_idealLb1_"-"_idealLb2_" lbs"
138 . . if Wt>idealLb2 set result=result_"; "_(Wt-idealLb2)_" lbs over weight)"
139 . . else if Wt<idealLb1 set result=result_"; "_(idealLb1-Wt)_" lbs under weight)"
140 . . else set result=result_")"
141 . . new WtDelta set WtDelta=$$WTDELTA(DFN,.TIU)
142 . . set result=result_$char(10)_$char(9)_WtDelta
143
144 if result="" do
145 . set result="[See vital-signs documented in paper chart]"
146
147 quit result
148
149
150FormatVitals(result,s,Label,CurDT,NoteDT,ForceShow)
151 ;"Purpose: To remove redundant text in formating Vitals
152 ;"Input: result -- PASS BY REFERENCE .. the cumulative string
153 ;" s -- the string value result to add
154 ;" Label -- the text label
155 ;" CurDT -- the last DT string shown
156 ;" NoteDT -- [optional] DT string of date of note
157 ;" If provided, then the date of the vital sign must equal NoteDT, or
158 ;" "" is returned (Unless ForceShow=1)
159 ;" ForceShow -- [optional] 1: Will force a return result, if otherwise wouldn't be shown
160 ;"Results: none (changes are passed back in result)
161
162 set result=$get(result)
163 ;"if $data(NoteDT)&($get(NoteDT)'=$get(CurDT))&($get(ForceShow)'=1) goto FVDone
164 if $get(s)'="" do
165 . ;"set result=result_"s="_s_",CurDT="_$get(CurDT)_",NoteDT="_$get(NoteDT)_" "
166 . new DT set DT=""
167 . new Delta
168 . set s=$$RemoveDT(s,.DT)
169 . set DT=$$RemoveTime(DT)
170 . set Delta=$$DateDelta(.NoteDT,.DT)
171 . ;"set result=result_"Delta="_Delta_" "
172 . if (Delta'<0) do
173 . . if (Delta>0)&($get(NoteDT)'="")&($get(ForceShow)'=1) quit ;"If NoteDT specified, don't allow delta>0
174 . . if (result'="")&($extract(result,$length(result))'=$char(9)) set result=result_", "
175 . . set CurDT=DT
176 . . if (Delta>0)&(DT'="") set result=result_"("_DT_") "
177 . . set result=result_Label_" "_s
178FVDone
179 quit
180
181
182RemoveDT(S,DT)
183 ;"Purpose: to remove a date-Time string, and return in DT
184 ;" i.e. turn this:
185 ;" 127/56 (12/25/04 16:50)
186 ;" into these:
187 ;" '127/56' and '12/25/04 16:50'
188 ;"Input: S -- a string as above
189 ;" DT -- [Optional] an OUT parameter... must PASS BY REFERENCE
190 ;"result: returns input string with (date-time) removed
191 ;" Date-Time is returned in DT if passed by reference.
192
193 new result set result=$get(S)
194 if result="" goto RDTDone
195
196 set result=$piece(S,"(",1)
197 set result=$$Trim^TMGSTUTL(.result)
198 set DT=$piece(S,"(",2)
199 set DT=$piece(DT,")",1)
200 set DT=$$Trim^TMGSTUTL(.DT)
201
202 quit result
203
204
205RDTDone
206 quit result
207
208RemoveTime(DT)
209 ;"Purpose: to remove the time from a date/time string
210 ;"Input: DT -- the date/time string, i.e. '2/24/05 16:50'
211 ;"result: returns just the date, i.e. '2/25/05'
212
213 new result
214
215 set result=$piece(DT," ",1)
216
217 quit result
218
219
220FormatHeight(HtS,PtAge)
221 ;"Purpose: to remove centimeters from patient's height for adults
222 ;"Input: Ht, a height string, e.g. '74 in [154 cm]'
223 ;" PtAge, patient's age in years
224 ;"Result: returns patient height, with [154 cm] removed, if age > 16
225
226 new result set result=$get(HtS)
227
228 if $get(PtAge)'<16 do
229 . set result=$piece(HtS,"[",1)
230
231 quit result
232
233
234DateDelta(RefDT,DT)
235 ;"Purpose: To determine the number of days between DT and now
236 ;" i.e. How many days DT was before RefDT.
237 ;"Input:RefDT -- a reference/baseline date/time string
238 ;" if not supplied, Current date/time used as default.
239 ;" DT -- a date/time string (i.e. '12/25/04 16:50')
240 ;"Result: Return number of days between DT and RefDT
241 ;" Positive numbers used when DT occured before current date
242 ;" i.e. result=RefDT-DT
243
244 new iNowDT,iRefDT,iDT ;internal format of dates
245 new result set result=0
246
247 ;"write "DT='",DT,"'",!
248 ;"set iDT=$$IDATE^TIULC(.DT) ;"Convert date into internal
249 ;"write "iDT=",iDT,!
250 set X=DT do ^%DT set iDT=Y ;"Convert date into internal
251 if $get(RefDT)="" set iRefDT=$$DT^XLFDT
252 else set X=RefDT do ^%DT set iRefDT=Y ;"Convert date into internal
253 ;"write "iDT=",iDT,!
254 ;"set iNowDT=$$DT^XLFDT
255 ;"write "iNowDT=",iNowDT,!
256 ;"set result=$$FMDIFF^XLFDT(iNowDT,iDT)
257 set result=$$FMDIFF^XLFDT(iRefDT,iDT)
258
259 quit result
260
261
262
263TMGVISDT(TIU) ; Visit date
264 ;"Purpose: Return a string for date of visit
265 ;"Note: This is based on the function VISDATE^TIULO1(TIU)
266 ;" However, that function seemed to return the appointment date associated
267 ;" with a note, rather than the specified date of the note
268 ;" Also, this will return date only--not time.
269 ;"Input: TIU -- this is an array created by TIU system that
270 ;" contains information about the document being
271 ;" edited/created. I believe it has this this structure:
272 ;" TIU("VSTR") = LOC;VDT;VTYP
273 ;" TIU("VISIT") = Visit File IFN^date?
274 ;" TIU("LOC")
275 ;" TIU("VLOC")
276 ;" TIU("STOP") = mark to defer workload
277 ;" TIU("TYPE")=1^title DA^title Name i.e.: 1^128^OFFICE VISIT^OFFICE VISIT
278 ;" TIU("SVC")=service, e.g. "FAMILY PRACTICE"
279 ;" TIU("EDT")=TIUEDT^DateStr = event begin time: FMDate^DateStr
280 ;" TIU("LDT")=TIULDT^DateStr = event end time: FMDate^DateStr
281 ;" TIU("VSTR")=LOC;VDT;VTYP e.g. "x;x;OFFICE VISIT"
282 ;" TIU("VISIT")=Visit File IFN
283 ;" TIU("LOC")=TIULOC
284 ;" TIU("VLOC")=TIULOC
285 ;" TIU("STOP")=0 ;"0=FALSE, don't worry about stop codes.
286 ;"Output: returns result
287
288 N TIUX,TIUY
289 new result
290
291 ;set result="VISIT="_$get(TIU("VISIT"))_" "
292 ;set result=result_"VSTR="_$get(TIU("VSTR"))_" "
293 ;set result=result_"EDT="_$get(TIU("EDT"))_" "
294 ;set result=result_"LDT="_$get(TIU("LDT"))_" "
295
296 if $get(TIU("VISIT"))'="" do
297 . set result=$piece(TIU("VISIT"),U,2)
298 else if $get(TIU("VSTR"))'="" do
299 . set result=$piece(TIU("VSTR"),";",2)
300 else do
301 . set result="(Visit Date Unknown)"
302
303 if +result>0 do
304 . set result=$$DATE^TIULS(result,"MM/DD/YY HR:MIN")
305 . set result=$piece(result," ",1) ;"cut off time.
306
307VDDone quit result
308
309
310FNAME(DFN)
311 ;"Purpose: Return Patient's first name
312 ;"Input: DFN -- the patient's unique ID (record#)
313 ;"Output: returns result
314 new name
315
316 set name=$piece($get(^DPT(DFN,0)),"^",1)
317 set name=$piece(name,",",2)
318 set name=$piece(name," ",1)
319 set name=$$CapWords^TMGSTUTL(name)
320
321 quit name
322
323
324MNAME(DFN)
325 ;"Purpose: Return Patient's middle name(s)
326 ;"Input: DFN -- the patient's unique ID (record#)
327 ;"Output: returns result
328 new name
329
330 set name=$piece($get(^DPT(DFN,0)),"^",1)
331 set name=$piece(name,",",2)
332 set name=$piece(name," ",2,100)
333 set name=$$CapWords^TMGSTUTL(name)
334
335 quit name
336
337
338LNAME(DFN)
339 ;"Purpose: Return Patient's last name
340 ;"Input: DFN -- the patient's unique ID (record#)
341 ;"Output: returns result
342
343 new name
344
345 set name=$piece($get(^DPT(DFN,0)),"^",1)
346 set name=$piece(name,",",1)
347 set name=$$CapWords^TMGSTUTL(name)
348
349 quit name
350
351
352NICENAME(DFN)
353 ;"Purpose: Return Patient's name format: Firstname Middlename Lastname
354 ;" only the first letter of each name capitalized.
355 ;"Input: DFN -- the patient's unique ID (record#)
356 ;"Output: returns result
357
358 new name
359
360 set name=$piece($get(^DPT(DFN,0)),"^",1)
361 set name=$piece(name,",",2)_" "_$piece(name,",",1) ;"put first name first
362 set name=$$CapWords^TMGSTUTL(name)
363
364 quit name
365
366
367PHONENUM(DFN)
368 ;"Purpose: to return the patient's phone number
369 ;"Input: DFN -- the patient's unique ID (record#)
370 ;"Output: returns result
371
372 new result set result=""
373 if +$get(DFN)=0 goto PNDone
374
375 set result=$$GET1^DIQ(2,DFN_",",.131)
376
377 set result=$translate(result," ","")
378 if $length(result)=10 do
379 . new temp set temp=result
380 . set result="("_$extract(result,1,3)_") "_$extract(result,4,6)_"-"_$extract(result,7,10)
381
382 if $length(result)=7 do
383 . new temp set temp=result
384 . set result=$extract(result,1,3)_"-"_$extract(result,4,7)
385
386PNDone
387 quit result
388
389
390 ;"-------------------------------------------------------------
391 ;"-------------------------------------------------------------
392WTTREND(DFN,TIU)
393 ;"Purpose: return text showing patient's trend in change of weight.
394 ;" e.g. 215 <== 212 <== 256 <== 278
395 ;"Input: DFN=the Patient's IEN in file #2
396 ;" TIU=PASS BY REFERENCE. Should be an Array of TIU note info
397 ;" See documentation in VITALS(DFN,TIU)
398 ;"Results: Returns string describing changes in weight.
399
400 new result set result=""
401 new Date set Date=$get(TIU("EDT"))
402 if +Date'>0 do
403 . set result="(No wts available)"
404 . goto WTTRDone
405
406 new Array
407 do GetPriorVital(.DFN,Date,"WEIGHT",.Array)
408
409 new Date set Date=""
410 for set Date=$order(Array(Date),-1) quit:(+Date'>0) do
411 . if result'="" set result=result_" <== "
412 . set result=result_$order(Array(Date,""))
413
414 set result="Wt trend: "_result
415
416WTTRDone quit result
417
418
419WTDELTA(DFN,TIU)
420 ;"Purpose: return text showing patient's change in weight.
421 ;"Input: DFN=the Patient's IEN in file #2
422 ;" TIU=PASS BY REFERENCE. Should be an Array of TIU note info
423 ;" See documentation in VITALS(DFN,TIU)
424 ;"Results: Returns string describing change in weight.
425
426 new result set result="Weight "
427 new delta
428 new Date set Date=$get(TIU("EDT")) ;"Episode date
429 if +Date'>0 do goto WTDDone
430 . set result=result_"change: ?"
431
432 new Array
433 do GetPriorVital(.DFN,Date,"WEIGHT",.Array)
434
435 new NTLast,Last
436 do GetLast2(.Array,.NTLast,.Last)
437 set Last=+Last
438 set NTLast=+NTLast
439 set delta=Last-NTLast
440 if delta>0 set result=result_"up "_delta_" lbs. "
441 else if delta<0 set result=result_"down "_-delta_" lbs. "
442 else do
443 . if Last=0 set result=result_"change: ?" quit
444 . set result=result_"unchanged. "
445
446 if (Last>0)&(NTLast>0) do
447 . set result=result_"("_Last_" <== "_NTLast_" prior wt)"
448
449WTDDone quit result
450
451
452GetLast2(Array,NTLast,Last)
453 ;"Purpose: Returns last 2 values in array (as created by GetPriorVital)
454 ;"Input: Array -- PASS BY REFERENCE. Array as created by GetPriorVital
455 ;" Array(FMDate,Value)=""
456 ;" Array(FMDate,Value)=""
457 ;" NTLast --PASS BY REFERENCE, an OUT PARAMETER.
458 ;" Next-To-Last value in array list (sorted by ascending date)
459 ;" Last -- PASS BY REFERENCE, an OUT PARAMETER.
460 ;" Last value in array list (sorted by ascending date)
461 ;"Results: None
462
463 new NTLastDate,LastDate
464 set LastDate=""
465 set LastDate=$order(Array(""),-1)
466 set Last=$order(Array(LastDate,""))
467
468 set NTLastDate=$order(Array(LastDate),-1)
469 set NTLast=$order(Array(NTLastDate,""))
470
471 quit
472
473
474GetPriorVital(DFN,Date,Vital,Array)
475 ;"Purpose: To retrieve a list of prior vital entries for a patient
476 ;" Note: entries up to *AND INCLUDING* the current day will be retrieved
477 ;"Input: DFN: the IEN of the patient, in file #2 (PATIENT)
478 ;" Date: Date (in FM format) of the current event. Entries up to
479 ;" AND INCLUDING this date will be retrieved.
480 ;" Vital: Vital to retrieve, GMRV VITAL TYPE file (#120.51)
481 ;" Must be .01 value of a valid record
482 ;" E.g. "ABDOMINAL GIRTH","BLOOD PRESSURE","HEIGHT", etc.
483 ;" Array: PASS BY REFERENCE, an OUT PARAMETER. Prior values killed. Format as below.
484 ;"Output: Array is filled as follows:
485 ;" Array(FMDate,Value)=""
486 ;" Array(FMDate,Value)=""
487 ;" Or array will be empty if no values found.
488 ;"Result: None
489
490 if +$get(DFN)=0 goto GPVDone
491 if +$get(Date)=0 goto GPVDone
492 if $get(Vital)="" goto GPVDone
493 new VitalTIEN
494 set VitalTIEN=+$order(^GMRD(120.51,"B",Vital,""))
495 if VitalTIEN'>0 goto GPVDone
496 kill Array
497
498 new IEN set IEN=""
499 new X,X1,X2,%Y
500 for set IEN=$order(^GMR(120.5,"C",DFN,IEN)) quit:(+IEN'>0) do
501 . new s set s=$get(^GMR(120.5,IEN,0))
502 . if +$piece(s,"^",3)'=VitalTIEN quit
503 . set X1=Date
504 . set X2=+$piece(s,"^",1)
505 . do ^%DTC ;"date delta
506 . if %Y'=1 quit ;"data unworkable
507 . if X>-1 set Array(+$piece(s,"^",1),+$piece(s,"^",8))=""
508
509GPVDone quit
510
511 ;"-------------------------------------------------------------
512 ;"-------------------------------------------------------------
513
514GetNotesList(DFN,List,IncDays)
515 ;"Purpose: Return a list of notes for patient in given time span
516 ;"Input: DFN -- IEN in PATIENT file (the patient record number)
517 ;" List -- PASS BY REFERENCE, an OUT PARAMETER. (Format below)
518 ;" IncDays -- Number of DAYS to search in.
519 ;" E.g. 4 --> get notes from last 4 days
520 ;"Output: List format:
521 ;" List(FMTimeOfNote,IEN8925)=""
522 ;" List(FMTimeOfNote,IEN8925)=""
523 ;" List(FMTimeOfNote,IEN8925)=""
524 ;" If no notes found, then array is left blank. Prior entries KILLED
525 ;"Results: none
526
527 kill List
528 set DFN=+$get(DFN)
529 if DFN'>0 goto GNLDone
530 set IncDays=+$get(IncDays)
531 new temp,i
532 merge temp=^TIU(8925,"C",DFN)
533 set IEN=""
534 for set IEN=$order(temp(IEN)) quit:(IEN="") do
535 . new X,X1,X2,%Y,StartDate
536 . do NOW^%DTC set X1=X
537 . set StartDate=$piece($get(^TIU(8925,IEN,0)),"^",7)
538 . set X2=StartDate
539 . do ^%DTC ;"calculate X=X1-X2. Returns #days between
540 . if X>IncDays quit
541 . set List(StartDate,IEN)=""
542
543GNLDone quit
544
545IsHTML(IEN8925)
546 ;"Purpose: to specify if the text held in the REPORT TEXT field is HTML markup
547 ;"Input: IEN8925 -- record number in file 8925
548 ;"Results: 1 if HTML markup, 0 otherwise.
549 ;"Note: This is not a perfect test. Also, will fail if tag is not uppercase
550 ;
551 new result set result=0
552 new Done set Done=0
553 new line set line=0
554 for set line=$order(^TIU(8925,IEN8925,"TEXT",line)) quit:(line="")!Done do
555 . new lineS set lineS=$get(^TIU(8925,IEN8925,"TEXT",line,0))
556 . if (lineS["<!DOCTYPE HTML")!(lineS["<HTML>") set Done=1,result=1 quit
557 quit result
558
559HTML2TXT(Array)
560 ;"Purpose: text a WP array that is HTML formatted, and strip <P>, and
561 ;" return in a format of 1 line per array node.
562 ;"Input: Array -- PASS BY REFERENCE. This array will be altered.
563 ;"Results: none
564 ;"NOTE: This conversion causes some loss of HTML tags, so a round trip
565 ;" conversion back to HTML would fail.
566
567 new outArray,outI
568 set outI=1
569
570 ;"Clear out confusing non-breaking spaces.
571 new spec
572 set spec("&nbsp;")=" "
573 set spec("&lt;")="<"
574 set spec("&gt;")=">"
575 set spec("&amp;")="&"
576 set spec("&quot;")=""""
577 new line set line=0
578 for set line=$order(Array(line)) quit:(line="") do
579 . new lineS set lineS=$get(Array(line,0))
580 . set Array(line,0)=$$REPLACE^XLFSTR(lineS,.spec)
581
582 new s2 set s2=""
583 new line set line=0
584 for set line=$order(Array(line)) quit:(line="") do
585 . new lineS set lineS=s2_$get(Array(line,0))
586 . set s2=""
587 . for do quit:(lineS'["<")
588 . . if (lineS["<P>")&($piece(lineS,"<P>",1)'["<BR>") do quit
589 . . . set outArray(outI,0)=$piece(lineS,"<P>",1)
590 . . . set outI=outI+1
591 . . . set outArray(outI,0)="" ;"Add blank line to create paragraph break.
592 . . . set outI=outI+1
593 . . . set lineS=$piece(lineS,"<P>",2,999)
594 . . if (lineS["</P>")&($piece(lineS,"</P>",1)'["<BR>") do quit
595 . . . set outArray(outI,0)=$piece(lineS,"</P>",1)
596 . . . set outI=outI+1
597 . . . set outArray(outI,0)="" ;"Add blank line to create paragraph break.
598 . . . set outI=outI+1
599 . . . set lineS=$piece(lineS,"</P>",2,999)
600 . . if (lineS["</LI>")&($piece(lineS,"</LI>",1)'["<BR>") do quit
601 . . . set outArray(outI,0)=$piece(lineS,"</LI>",1) ;" _"</LI>"
602 . . . set outI=outI+1
603 . . . set outArray(outI,0)="" ;"Add blank line to create paragraph break.
604 . . . set outI=outI+1
605 . . . set lineS=$piece(lineS,"</LI>",2,999)
606 . . if lineS["<BR>" do quit
607 . . . set outArray(outI,0)=$piece(lineS,"<BR>",1)
608 . . . set outI=outI+1
609 . . . set lineS=$piece(lineS,"<BR>",2,999)
610 . . set s2=lineS,lineS=""
611 . set s2=s2_lineS
612 if s2'="" do
613 . set outArray(outI,0)=s2
614 . set outI=outI+1
615
616 kill Array
617 merge Array=outArray
618 quit
619
620
621ExtractSpecial(IEN8925,StartMarkerS,EndMarkerS,Array)
622 ;"Purpose: To scan the REPORT TEXT field in given document and return
623 ;" paragraph of text that is started by StartMarkerS, and ended by EndMarkerS.
624 ;" I.E. Search for a line that contains MarkerS. Return that line and
625 ;" all following lines until line found with EndMarkerS, or
626 ;" end of text.
627 ;"Input: IEN8925 -- IEN in file 8925 (TIU DOCUMENT)
628 ;" StartMarkerS -- the string to search for that indicates start of block
629 ;" EndMarkerS -- the string to search for that indicates the end of block.
630 ;" NOTE: if EndMarkerS="BLANK_LINE", then search is
631 ;" ended when a blank line is encountered.
632 ;" Array -- PASS BY REFERENCE, an OUT PARAMETER. Prior values killed.
633 ;" Format: Array(0)=MaxLineCount
634 ;" Array(1)="Text line 1"
635 ;" Array(2)="Text line 2" ...
636 ;"Result: 1 if data found, otherwise 0
637
638 new result set result=0
639 kill Array
640 set IEN8925=+$get(IEN8925)
641 if IEN8925'>0 goto ESDone
642 if $data(^TIU(8925,IEN8925,"TEXT"))'>0 goto ESDone
643 if $get(StartMarkerS)="" goto ESDone
644 if $get(EndMarkerS)="" goto ESDone
645 new ref set ref=$name(^TIU(8925,IEN8925,"TEXT"))
646 new tempArray
647 if $$IsHTML(IEN8925) do
648 . merge tempArray=^TIU(8925,IEN8925,"TEXT")
649 . do HTML2TXT(.tempArray)
650 . set ref="tempArray"
651 new line,i,BlockFound,Done
652 set line=0,i=0,BlockFound=0,Done=0
653 for set line=$order(@ref@(line)) quit:(line="")!Done do
654 . new lineS set lineS=$get(@ref@(line,0))
655 . if (BlockFound=0) do quit ;"don't include header line with output
656 . . if lineS[StartMarkerS set BlockFound=1
657 . if (BlockFound=1) do
658 . . set i=i+1,Array(0)=i
659 . . new s2 set s2=$$Trim^TMGSTUTL(lineS," ")
660 . . set s2=$$Trim^TMGSTUTL(s2,$char(9))
661 . . set Array(i)=lineS
662 . . if s2="" set Array(i)=s2
663 . . set result=1
664 . . if (EndMarkerS="BLANK_LINE")&(s2="") set BlockFound=0,Done=1 quit
665 . . if lineS[EndMarkerS set BlockFound=0,Done=1 quit ;"include line with END marker
666
667ESDone quit result
668
669
670MergeInto(partArray,masterArray)
671 ;"Purpose: to combine partArray into MasterArray.
672 ;"Input: partArray -- PASS BY REFERENCE
673 ;" masterArray -- PASS BY REFERENCE
674 ;"Note: Arrays are combine in a 'transparent' manner such that newer entries
675 ;" will overwrite older entries only for identical values. For example:
676 ;" -- BLOCK -- <--- MasterArray
677 ;" TSH = 1.56
678 ;" LDL = 140
679 ;" -- END BLOCK --
680 ;"
681 ;" -- BLOCK -- <--- partArray
682 ;" LDL = 150
683 ;" -- END BLOCK --
684 ;"
685 ;" The above two blocks will result in this final array
686 ;" -- BLOCK --
687 ;" TSH = 1.56
688 ;" LDL = 150 <--- this value overwrote older entry
689 ;" -- END BLOCK --
690 ;"
691 ;" In this mode, only data that is in a LABEL <--> VALUE format
692 ;" will be checked for newer vs older entries. All other
693 ;" lines will simply be included in one large summation block.
694 ;" And the allowed format for LABEL <--> VALUE will be:
695 ;" Label = value or
696 ;" Label : value
697 ;"
698 ;"Output: MasterArray will be filled as follows:
699 ;" Array("text line")=""
700 ;" Array("text line")=""
701 ;" Array("KEY-VALUE",KeyName)=Value
702 ;" Array("KEY-VALUE",KeyName,"LINE")=original line
703
704 new lineNum set lineNum=0
705 for set lineNum=$order(tempArray(lineNum)) quit:(+lineNum'>0) do
706 . new line set line=$get(tempArray(lineNum))
707 . if (line["=")!(line[":") do
708 . . new key,shortKey,value,pivot
709 . . if line["=" set pivot="="
710 . . else set pivot=":"
711 . . set key=$piece(line,pivot,1)
712 . . set shortKey=$$UP^XLFSTR($$Trim^TMGSTUTL(key))
713 . . set value=$piece(line,pivot,2,999)
714 . . set Array("KEY-VALUE",shortKey)=value
715 . . set Array("KEY-VALUE",shortKey,"LINE")=line
716 . else do
717 . . if line="" quit
718 . . set Array(line)=""
719
720 quit
721
722
723GetSpecial(DFN,StartMarkerS,EndMarkerS,Months,Array,Mode)
724 ;"Purpose: to return a block of text from notes for patient, starting with
725 ;" StartMarkerS, and ending with EndMarkerS, searching backwards
726 ;" within time period of 'Months'.
727 ;"Input: DFN -- IEN of patient in PATIENT file.
728 ;" StartMarkerS -- the string to search for that indicates start of block
729 ;" EndMarkerS -- the string to search for that indicates the end of block.
730 ;" NOTE: if EndMarkerS="BLANK_LINE", then search is
731 ;" ended when a blank line is encountered.
732 ;" Months -- Number of Months to search in.
733 ;" E.g. 4 --> search in notes from last 4 months
734 ;" Array -- PASS BY REFERENCE. an OUT PARAMETER. Old values killed. Format below
735 ;" Mode: operation mode. As follows:
736 ;" 1 = return only block from most recent match
737 ;" 2 = compile all.
738 ;" In this mode, the search is carried out from oldest to most
739 ;" recent, and newer blocks overlay older ones in a 'transparent'
740 ;" manner such that newer entries will overwrite older entries
741 ;" only for identical values. For example:
742 ;" -- BLOCK -- <--- from date 1/1/1980
743 ;" TSH = 1.56
744 ;" LDL = 140
745 ;" -- END BLOCK --
746 ;"
747 ;" -- BLOCK -- <--- from date 2/1/1980
748 ;" LDL = 150
749 ;" -- END BLOCK --
750 ;"
751 ;" The above two blocks will result in this final block
752 ;" -- BLOCK --
753 ;" TSH = 1.56
754 ;" LDL = 150 <--- this value overwrote older entry
755 ;" -- END BLOCK --
756 ;"
757 ;" In this mode, only data that is in a LABEL <--> VALUE format
758 ;" will be checked for newer vs older entries. All other
759 ;" lines will simply be included in one large summation block.
760 ;" And the allowed format for LABEL <--> VALUE will be:
761 ;" Label = value or
762 ;" Label : value
763 ;"
764 ;"Output: Array will be filled as follows:
765 ;" Array("text line")=""
766 ;" Array("text line")=""
767 ;" Array("KEY-VALUE",KeyName)=Value
768 ;" Array("KEY-VALUE",KeyName,"LINE")=original line
769
770 ;"Results: none
771
772 new NotesList
773 kill Array
774 set DFN=+$get(DFN)
775 if DFN'>0 goto GSDone
776
777 new IncDays set IncDays=+$get(Months)*30
778 do GetNotesList(DFN,.NotesList,IncDays)
779
780 new direction set direction=1
781 if Mode=1 set direction=-1
782 new Done set Done=0
783 new StartTime set StartTime=""
784 for set StartTime=$order(NotesList(StartTime),direction) quit:(StartTime="")!Done do
785 . new IEN8925 set IEN8925=""
786 . for set IEN8925=$order(NotesList(StartTime,IEN8925),direction) quit:(+IEN8925'>0)!Done do
787 . . new tempArray
788 . . if $$ExtractSpecial(IEN8925,.StartMarkerS,.EndMarkerS,.tempArray)=1 do
789 . . . do MergeInto(.tempArray,.Array)
790 . . . if Mode=1 set Done=1
791
792GSDone
793 quit
794
795
796Array2Str(Array)
797 ;"Purpose: to convert Array (as created by GetSpecial) into one long string
798 ;"Input: Array. Format as follows:
799 ;" Array("text line")=""
800 ;" Array("text line")=""
801 ;" Array("KEY-VALUE",KeyName)=Value
802 ;" Array("KEY-VALUE",KeyName,"LINE")=original line
803
804 new result set result=""
805 new keyName set keyName=""
806
807 ;"First, put in key-value lines
808 for set keyName=$order(Array("KEY-VALUE",keyName)) quit:(keyName="") do
809 . new line
810 . set line=$get(Array("KEY-VALUE",keyName,"LINE"))
811 . if result'="" set result=result_$char(13)_$char(10)
812 . set result=result_line
813 kill Array("KEY-VALUE")
814
815 ;"Next, put standard lines
816 new line set line=""
817 for set line=$order(Array(line)) quit:(line="") do
818 . if result'="" set result=result_$char(13)_$char(10)
819 . set result=result_line
820
821 quit result
822
823
824AddIfAbsent(Array,Key,Pivot,Value)
825 ;"Purpose: to add one (empty) entry, if a value for this doesn't already exist.
826 ;"Input: Array. Format as follows:
827 ;" Array("text line")=""
828 ;" Array("text line")=""
829 ;" Array("KEY-VALUE",KeyName)=Value
830 ;" Array("KEY-VALUE",KeyName,"LINE")=original line
831 ;" Key -- the name of the study
832 ;" Pivot -- ":", or "=" OPTIONAL. Default = ":"
833 ;" Value -- the description of the needed value. OPTIONAL.
834 ;" default value = '<no data>'
835
836 set Pivot=$get(Pivot,":")
837 set Value=$get(Value,"<no data>")
838 if $get(Key)="" goto AIADone
839 new UpKey set UpKey=$$UP^XLFSTR(Key)
840 if $data(Array("KEY-VALUE",UpKey))>0 goto AIADone
841
842 set Array("KEY-VALUE",UpKey)=$get(Value)
843 new line set line=" "_$get(Key)_" "_$get(Pivot)_" "_$get(Value)
844 set Array("KEY-VALUE",UpKey,"LINE")=line
845
846AIADone
847 quit
848
849
850StubRecommendations(DFN,Array,Label)
851 ;"Purpose: to add stubs for recommended studies to Array
852
853 ;"Get age from DFN
854 if +$get(DFN)=0 goto SRDone
855 new Age set Age=+$$GET1^DIQ(2,DFN,.033)
856 new Sex set Sex=$$GET1^DIQ(2,DFN,.02)
857
858 if Label="[STUDIES]" do
859 . if (Sex="FEMALE") do
860 . . if (Age>39) do AddIfAbsent(.Array,"Mammogram")
861 . . if (Age>59) do AddIfAbsent(.Array,"Bone Density")
862 . . if (Age>18) do AddIfAbsent(.Array,"Pap")
863 . . if (Age>8)&(Age<27) do AddIfAbsent(.Array,"Gardasil",":","#1 <no data>; #2 <no data>; #3 <no data> ")
864 . if (Sex="MALE")&(Age>49) do AddIfAbsent(.Array,"PSA")
865 . if Age>64 do AddIfAbsent(.Array,"Pneumovax")
866 . do AddIfAbsent(.Array,"Flu Vaccine")
867 . if (Age>18) do AddIfAbsent(.Array,"Advance Directives")
868 . ;"if (Age>49) do AddIfAbsent(.Array,"Td")
869 . if (Age>59) do AddIfAbsent(.Array,"Zostavax")
870 . if (Age>1)&(Age<19) do AddIfAbsent(.Array,"MMR",":","#1 <no data>; #2 <no data>")
871 . if (Age>0)&(Age<21) do AddIfAbsent(.Array,"Hep B",":","#1 <no data>; #2 <no data>; #3 <no data> ")
872 . if (Age>1)&(Age<19) do AddIfAbsent(.Array,"Hep A",":","#1 <no data>; #2 <no data>")
873 . if (Age>1)&(Age<21) do AddIfAbsent(.Array,"Varivax",":","#1 <no data>; #2 <no data>")
874 . if (Age>10)&(Age<65) do AddIfAbsent(.Array,"TdaP / Td")
875 . if (Age>10)&(Age<23) do AddIfAbsent(.Array,"MCV4 (Menactra)")
876 . if (Age>50) do AddIfAbsent(.Array,"Colonoscopy")
877 else if Label="[DIABETIC STUDIES]" do
878 . do AddIfAbsent(.Array,"HgbA1c","=")
879 . do AddIfAbsent(.Array,"Diabetic Eye Exam")
880 . do AddIfAbsent(.Array,"Urine Microalbumin")
881 . do AddIfAbsent(.Array,"Diabetic Foot Exam")
882 . do AddIfAbsent(.Array,"EKG")
883 . do AddIfAbsent(.Array,"Regimen")
884 else if Label="[LIPIDS]" do
885 . do AddIfAbsent(.Array,"Total Cholesterol","=")
886 . do AddIfAbsent(.Array,"LDL Cholesterol","=")
887 . do AddIfAbsent(.Array,"HDL Cholesterol","=")
888 . do AddIfAbsent(.Array,"Triglycerides","=")
889 . do AddIfAbsent(.Array,"Date of last lipid panel")
890 . do AddIfAbsent(.Array,"LDL Goal")
891 . do AddIfAbsent(.Array,"Liver Enzymes")
892 . do AddIfAbsent(.Array,"Regimen")
893 else if Label="[SOCIAL]" do
894 . do AddIfAbsent(.Array,"Tobacco")
895 . do AddIfAbsent(.Array,"EtOH")
896 else if Label="[THYROID]" do
897 . do AddIfAbsent(.Array,"Date of last study")
898 . do AddIfAbsent(.Array,"TSH","=")
899 . do AddIfAbsent(.Array,"Regimen")
900 else if Label="[HYPERTENSION]" do
901 . do AddIfAbsent(.Array,"Date of last electrolytes")
902 . do AddIfAbsent(.Array,"EKG")
903 . do AddIfAbsent(.Array,"Med-1")
904 else if Label="[ANEMIA]" do
905 . do AddIfAbsent(.Array,"Hgb")
906 . do AddIfAbsent(.Array,"Serum Fe")
907 . do AddIfAbsent(.Array,"TIBC")
908 . do AddIfAbsent(.Array,"B12")
909 . do AddIfAbsent(.Array,"Folate")
910 . do AddIfAbsent(.Array,"Workup")
911 else if Label="[ASTHMA]" do
912 . do AddIfAbsent(.Array,"Peak Flow Personal Best")
913 . do AddIfAbsent(.Array,"Meds")
914 . do AddIfAbsent(.Array,"Rescue Inhaler Freq")
915 . do AddIfAbsent(.Array,"Pneumovax")
916 . do AddIfAbsent(.Array,"Triggers")
917 . do AddIfAbsent(.Array,"Smoker")
918 . do AddIfAbsent(.Array,"Nocturnal Symptoms")
919 else if Label="[COPD]" do
920 . do AddIfAbsent(.Array,"Meds")
921 . do AddIfAbsent(.Array,"Rescue Inhaler Freq")
922 . do AddIfAbsent(.Array,"Pneumovax")
923 . do AddIfAbsent(.Array,"Pulmonologist")
924 . do AddIfAbsent(.Array,"Home O2")
925 . do AddIfAbsent(.Array,"PFT Testing")
926 . do AddIfAbsent(.Array,"Tobacco Cessation Counselling")
927 else if Label="[OSTEOPENIA/OSTEOPOROSIS]" do
928 . do AddIfAbsent(.Array,"Bone Density")
929 . do AddIfAbsent(.Array,"T-Score Spine/Hips")
930 . do AddIfAbsent(.Array,"Regimen")
931 . do AddIfAbsent(.Array,"Advised Calcium ~1500 mg & Vit-D 1000-2000 IU")
932
933SRDone
934 quit
935
936GETTABL1(DFN,LABEL)
937 ;"Purpose: A call point for TIU objects, to return a table comprised from 1 prior table.
938 ;"NOTE: This type of table just gets the *LAST* table found (not a compilation)
939GT1 new Array,result set result=""
940 if $get(LABEL)="" goto GT1Done
941 set result=" -- "_LABEL_" ---------"_$CHAR(13)_$CHAR(10)
942 do GetSpecial(DFN,LABEL,"BLANK_LINE",48,.Array,1) ;"mode 1 = only last table; 2=compile
943 do StubRecommendations(.DFN,.Array,LABEL)
944 set result=result_$$Array2Str(.Array)
945GT1Done
946 quit result
947
948
949GETTABLX(DFN,LABEL)
950 ;"Purpose: A call point for TIU objects, to return a table comprised from prior notes.
951 ;"NOTE: This compiles a table from all prior matching tables in date range.
952
953 goto GT1 ;"<-- Hack to force TableX to really be a Table1 type table.
954
955 new Array,result set result=""
956 if $get(LABEL)="" goto GTXDone
957 set result=" -- "_LABEL_" ---------"_$CHAR(13)_$CHAR(10)
958 do GetSpecial(DFN,LABEL,"BLANK_LINE",13,.Array,2) ;"mode 1 = only last table; 2=compile
959 do StubRecommendations(.DFN,.Array,LABEL)
960 set result=result_$$Array2Str(.Array)
961GTXDone
962 quit result
963
Note: See TracBrowser for help on using the repository browser.