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

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

Initial upload

File size: 27.0 KB
RevLine 
[796]1TMGIMPORT ;TMG/kst/Code for importing from legacy MEDIC PMS ;03/25/06
2 ;;1.0;TMG-LIB;**1**;11/01/04
3
4;"Custom functions for importing data from legacy MEDIC system
5
6ImportLabels
7 ;"Purpose: To import a file with patient name, DOB etc, and
8 ;"register all these patients
9 ;
10 ;"This is an example entry:
11 ;"------------------------
12 ;"ADAM R JONES
13 ;"123 JONESS CREEK RD
14 ;"GREENEVILLE TN 37743
15 ;"423 666 6666 423 666 6667
16 ;" 123456 05151971M 040302
17
18
19
20 new TMGDEBUG set TMGDEBUG=0 ;"Note: user could change this at runtime...
21 new DBIndent set DBIndent=0
22 new PriorErrorFound set PriorErrorFound=0
23
24 new cGUI set cGUI="GUI"
25 new cCHUI set cCHUI="CHUI"
26 new cRoll set cRoll="Roll-n-Scroll"
27 new DModes
28 new cDialog set cDialog="UseDialog"
29 set DModes(0)="x"
30 set DModes(1)=cGUI
31 set DModes(2)=cCHUI
32 set DModes(3)=cRoll
33 set DModes(4)="x"
34
35 new cTrue set cTrue=1
36 new cFalse set cFalse=0
37 new cdbNone set cdbNone=0
38 new cdbToScrn set cdbToScrn=1
39 new cdbToFile set cdbToFile=2
40 new cdbToTail set cdbToTail=3
41
42 new cdbAbort set cdbAbort=-1
43 new cOKToCont set cOKToCont=1
44 new cAbort set cAbort=0
45
46 new cName set cName="01. NAME"
47 new cDOB set cDOB="02. DOB"
48 new cSex set cSex="03. SEX"
49 new cStrAddr set cStrAddr="04. STREET ADDRESS"
50 new cCity set cCity="05. CITY"
51 new cState set cState="06. STATE"
52 new cZip set cZip="07. ZIP"
53 new cPhone1 set cPhone1="08. PHONE-1"
54 new cPhone2 set cPhone2="09. PHONE-2"
55 new cDateReg set cDateReg="10. DATE REGISTERED"
56 new cChartNum set cChartNum="11. CHARTNUM"
57
58 new Filename
59 new DebugFPath
60 new DebugFName
61 new DebugFile
62 new LabelArray,PLabelArray
63 new FileHandle
64 new UserPath,UserFName
65
66 new result
67 new FileSpec
68
69 new line set line=""
70
71 do DebugEntry^TMGDEBUG(.DBIndent,"Main Run")
72
73 ;"A local code login function.
74 if $$XUP^TMGXUP()=0 do goto RunDone
75 . do ShowError^TMGDEBUG(.PriorErrorFound,"Error setting up a user privilages for configuration.")
76
77 ;"------------------------------------------------------------------------------------
78 if ($data(DispMode)#10=0)!($get(DispMode)>3)!($get(DispMode)<1) do
79 . set DispMode=$$GetDispMode()
80 set DispMode=DModes(DispMode)
81 if DispMode="x" goto RunDone
82 set DispMode(cDialog)=(DispMode'=cRoll)
83 if ($data(DebugMode)#10=0)!($get(DebugMode)<0)!($get(DebugMode)>3)!(($get(DebugMode)=1)&(DispMode'=cGUI)) do
84 . set TMGDEBUG=$$GetDebugMode^TMGDEBUG(cdbNone)
85 else do
86 . set TMGDEBUG=DebugMode
87 if TMGDEBUG=cdbAbort goto RunDone
88
89 do
90 . new DefPath set DefPath="/tmp/"
91 . new DefName set DefName="M_Import_DebugLog.tmp"
92 . new DefFName set DefFName=DefPath_DefName
93 . do OpenLogFile^TMGDEBUG(DefPath,DefName)
94 . if TMGDEBUG=cdbToTail do
95 . . set result=$$Tail^TMGXDLG(DefFName,0,0,0)
96
97 ;"------------------------------------------------------------------------------------
98 if ($data(UserPath)#10=0)!($data(UserFName)#10=0) do
99 . set result=$$GetFName(.UserPath,.UserFName)
100 . if result=cAbort do PopupBox^TMGUSRIF("<!> No file selected.","Come back again soon!")
101 else do
102 . set result=cOKToCont
103 if (result=cAbort)!($data(UserPath)=0)!($data(UserFName)=0) goto RunDone
104 set Filename=UserPath_"/"_UserFName
105 ;"------------------------------------------------------------------------------------
106
107 ;new Array
108 new InFile,RecNum,EOF
109 new counter set counter=0
110
111 write "Please be patient...",!,!
112
113 set InFile=Filename
114 open InFile:readonly:2
115 else do goto QLoad
116 . do ShowError^TMGDEBUG(.PriorErrorFound,"Error opening file: ",UserPath_"/"_UserFName)
117
118 for RecNum=1:1 do quit:EOF
119 . ;"set EOF=$$GetRecord(.Array,RecNum)
120 . set EOF=$$GetRecord(.Array,1)
121 . set ArrayP=$name(Array(1))
122 . do ParseRecord(ArrayP,.Parsed)
123 . if $$ScreenParsed(.Parsed)=cOKToCont do
124 . . if $$FileParsed(.Parsed)=cOKToCont do
125 . . . write "."
126 . . else do
127 . . . write "!"
128 . else write "X"
129 . set counter=counter+1
130 . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Counter=",counter)
131 . if counter=80 do
132 . . ;"write @IOF
133 . . write !,RecNum," records processed so far.",!
134 . . set counter=0
135 . ;"write "hit key.."
136 . read *KeyPress:0
137 . if KeyPress=27 set EOF=1
138 . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"End of loop. EOF=",EOF)
139
140 close InFile
141
142 write !,!,RecNum," Records processed.",!,!
143
144 goto RunDone
145
146RunDone
147 write "Goodbye",!,!
148
149 if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"Main Run")
150
151 quit
152
153
154
155
156GetFName(Path,Filename)
157 ;"Purpose: Interact with user to get path and filename
158 ;"Input: Path--should be passed by reference, used to pass back result
159 ;" Filename--should be passed by reference, used to pass back result
160 ;"Output: Results passed in Path and Filename
161 ;" Function will result in 0 if user 'cancelled', 1 otherwise
162
163 new result set result=cAbort
164 new FullNamePath
165 new PathNode
166 set Path="/"
167 set Filename=""
168
169 if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetFName")
170
171 if DispMode=cRoll goto GFNRoll
172
173 if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Calling $$FileSel()")
174 set FullNamePath=$$FileSel^TMGXDLG("Please select script to process . . .","~/MedicLabels")
175 if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Results=",FullNamePath)
176 if FullNamePath="" goto GFNDone ;"result=cAbort still --> cancelled.
177
178 ;"Separate path from filename
179GFNL1
180 if '(FullNamePath["/") set Filename=FullNamePath goto GFNL2
181 set PathNode=$piece(FullNamePath,"/",1)
182 set Path=Path_PathNode_"/"
183 set $piece(FullNamePath,"/",1)=""
184 set FullNamePath=$extract(FullNamePath,2,255)
185 goto GFNL1
186GFNL2
187 set result=cOKToCont
188 goto GFNDone
189
190GFNRoll
191 new DefFName set DefFName="MedicLabels"
192 new DefPath set DefPath="/home/kdt0p"
193 ;"write !,"------------------------------------------",!
194 write !
195 write "Enter filename with path:",!
196 write " ['^'] = Abort",!
197 write " [Enter] = '",DefPath,"/",DefFName,"'",!
198 write "> "
199 read Filename:240
200 write !
201 if Filename="^" goto GFNDone
202 if Filename="" do
203 . set Filename=DefFName
204 . set Path=DefPath
205 . write "Using default: ",Path,"/",Filename,!,!,!
206 set result=cOKToCont
207
208GFNDone
209 if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetFName")
210 quit result
211
212
213
214
215
216GetDispMode()
217 ;"Purpose: To determine with form of input user wants
218 ;"Results: 1=GUI,2=CHUI,3=RollNScroll,0=abort
219 new Input
220 new result set result=cAbort
221 new Default set Default=3
222
223 if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetDispMode")
224
225 write "Select interface option:",!
226 write " 0. Quit. (Goodbye!)",!
227 write " 1. Linux X graphics/ 'GUI' (Recommended)",!
228 write " 2. Text graphics / 'CHUI' (Incomplete)",!
229 write " 3. Line-by-Line / 'Roll-and-scroll'",!
230
231 write "Enter option number ("_Default_"): "
232 read Input,!
233 if Input="" do
234 . ;"write "Defaulting to: ",Default,!
235 . set Input=Default
236 else if +Input>4 do
237 . set Input=Default
238
239 set result=+Input
240 if (Input=1)!(Input=2) do
241 . do SetupConsts^TMGXDLG()
242 . do SetGUI^TMGXDLG(Input=1)
243 ;"if Input=2 do goto GIMDone
244 ;". do SetupConsts^TMGXDLG()
245 ;". do SetGUI^TMGXDLG(0)
246
247GIMDone
248 if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Display mode set at: ",result)
249 if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetDispMode")
250 quit result
251
252
253LogSkipped
254
255 use OutFile
256
257
258
259GetRecord(Array,RecNum)
260 ;"Purpose:
261 ;"
262
263 if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetRecord")
264
265 new done,i
266 new BlankLine set BlankLine=""
267 new Parsed,ArrayP
268
269 use InFile
270
271 for i=1:1:6 do quit:($zeof)
272 . if line="" read line
273 . set Array(RecNum,i)=line
274 . set line=""
275 . if $zeof quit
276 . ;"read BlankLine ;"read and discard blank line
277 . ;"if BlankLine'="" set line=BlankLine
278
279 ;"for do quit:($zeof)!(line'="")
280 ;". read line
281 ;". set line=$$Trim^TMGSTUTL(line)
282
283 use 0
284
285QLoad
286 if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetRecord")
287 quit $zeof
288
289
290
291ParseRecord(ArrayP,Parsed)
292
293 if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ParseRecord")
294
295 new s,s1,s2
296 new NameArray
297 new MaxNode,i
298
299 kill Parsed
300
301 ;"temp
302 new tempDEBUG set tempDEBUG=$get(TMGDEBUG)
303 set TMGDEBUG=0
304
305 set s=$get(@ArrayP@(1))
306 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Init Name Line=",s)
307 if s'="" do
308 . new Suffix set Suffix=""
309 . do CleaveToArray^TMGSTUTL(s," ",.NameArray,1)
310 . if $get(NameArray(1))="BABY" quit
311 . set MaxNode=+$get(NameArray("MAXNODE"))
312 . if MaxNode'>0 do quit
313 . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Error after CleaveToArray. Here is NameArray:")
314 . . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("NameArray")
315 . if (NameArray(MaxNode)="JR")!(NameArray(MaxNode)="SR") do
316 . . set Suffix=NameArray(MaxNode)
317 . . kill NameArray(MaxNode)
318 . . set MaxNode=MaxNode-1
319 . set s1=NameArray(MaxNode)_","
320 . for i=1:1:MaxNode-1 do
321 . . set s1=s1_NameArray(i)_" "
322 . set s1=s1_Suffix
323 . set s1=$$Trim^TMGSTUTL(s1)
324 . if $extract(s1,1,2)="ZZ" set s1="" ;"DROP ZZ NAMES
325 . if (s1'["0")&(s1'["1")&(s1'["2")&(s1'["3")&(s1'["4")&(s1'["5")&(s1'["6")&(s1'["7")&(s1'["8")&(s1'["9") do
326 . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"final Name Line=",s1)
327 . . if s1'="" set Parsed(cName)=s1
328
329 set s=$get(@ArrayP@(2))
330 set s2=$$Trim^TMGSTUTL(s)
331 if $length(s2)>34 set s2=$extract(s2,1,34)
332 if $length(s2)<3 set s2=""
333 if s2'="" set Parsed(cStrAddr)=s2
334
335 set s=$get(@ArrayP@(3))
336 set s1=$extract(s,1,16)
337 set s2=$$Trim^TMGSTUTL(s1)
338 if s2'="" set Parsed(cCity)=s2
339
340 set s1=$extract(s,17,18)
341 set s2=$$Trim^TMGSTUTL(s1)
342 if $length(s2)'=2 set s2=""
343 if s2'="" set Parsed(cState)=s2
344
345 set s1=$extract(s,19,256)
346 set s2=$$Trim^TMGSTUTL(s1)
347 if s2'="" set Parsed(cZip)=s2
348
349 set s=$get(@ArrayP@(4))
350 set s2=$$Trim^TMGSTUTL($extract(s,1,12))
351 if s2="000 000 0000" set s2=""
352 if s2'="" set Parsed(cPhone1)=s2
353 set s2=$$Trim^TMGSTUTL($extract(s,16,27))
354 if s2="000 000 0000" set s2=""
355 if s2'="" set Parsed(cPhone2)=s2
356
357 set s=$get(@ArrayP@(5))
358 set s1=$extract(s,1,10)
359 set s2=$$Trim^TMGSTUTL(s1)
360 set s2=$translate(s2,"DPWCI\*","") ;"Clean off alpha characters -- not needed.
361 if $extract(s2,1,2)="ZZ" set s2=""
362 if s2'="" set Parsed(cChartNum)=s2
363
364 set s1=$extract(s,11,18)
365 set s1=$$FixDate(s1)
366 if s1'="" set Parsed(cDOB)=s1
367
368 set s1=$extract(s,19,19)
369 if (s1'="M")&(s1'="F") do
370 . set s1="M" ;"NOTE, I AM SETTING ALL UNKNOWN SEX's TO MALE
371 if s1'="" set Parsed(cSex)=s1
372
373 set s1=$extract(s,21,26)
374 set s1=$$FixDate(s1)
375 if s1'="" set Parsed(cDateReg)=s1
376
377 ;"temp
378 set TMGDEBUG=tempDEBUG
379
380 if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"ParseRecord")
381
382 quit
383
384
385FixDate(Date)
386
387 new Month,Day,Year
388 new result set result=""
389
390 set Date=$$Trim^TMGSTUTL(Date)
391 set Month=$$Trim^TMGSTUTL($extract(Date,1,2))
392 if +Month>0 do
393 . set result=Month
394 . set Day=$$Trim^TMGSTUTL($extract(Date,3,4))
395 . if +Day>0 do
396 . . set result=result_"/"_Day
397 . . set Year=$$Trim^TMGSTUTL($extract(Date,5,8))
398 . . if +Year>0 do
399 . . . set result=result_"/"_Year
400
401 quit result
402
403
404ScreenParsed(Parsed)
405 ;"Purpose: Screen record. If not appropriate for filing, then
406 ;" Parsed(*) is emptied
407 ;"Result: 0 if Parsed is ok to file, 1 if killed
408
409 if $get(Parsed(cName))="" do goto SPKill
410 . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"No name found!")
411 if $get(Parsed(cChartNum))="" do goto SPKill
412 . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"No chart number found!")
413 if $get(Parsed(cDOB))="" do goto SPKill
414 . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"No DOB found!")
415
416 quit cOKToCont
417
418SPKill
419 if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Killing Parsed. Here it is first...")
420 if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Parsed")
421 kill Parsed
422 quit cAbort
423
424
425
426FileParsed(Parsed)
427
428 if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"FileParsed")
429
430 new cOKToCont set cOKToCont=1
431 new cAbort set cAbort=0
432 new cFile set cFile="FILE"
433 new cEntries set cEntries="Entries"
434 new cMatchThis set cMatchThis="MATCHTHIS" ;"MatchThis"
435
436 new result set result=cOKToCont
437 new Data
438
439 ;"The Data array will be filed with data. (An example)
440 ;" Data(0,cFile)="1234.1" <-- "NEW PERSON" Note conversion
441 ;" Data(0,cFile,cGlobal)="^DIC(200)" <-- note, NOT "^DIC(200,"
442 ;" Data(0,cRecNum)=2 <-- only if user-specified.
443 ;" Data(0,cEntries)=1
444 ;" Data(1,".01")="MyData1"
445 ;" Data(1,".01",cMatchValue)="MyData1"
446 ;" Data(1,".01",cFlags)=any flags given (only present if user specified)
447 ;" Data(1,".02")="Bill"
448 ;" Data(1,".02",cMatchValue)="John"
449 ;" Data(1,".03")="MyData3"
450 ;" Data(1,".04")="MyData4"
451 ;" Data(1,".06")="MyData5" <-- note "NAME" was converted to ".06"
452 ;" Data(1,".07",0,cEntries)=2 <-- "ITEM" converted to ".07"
453 ;" Data(1,".07",0,cParentIENS)=",10033,"
454 ;" Data(1,".07",1,".01")="SubEntry1"
455 ;" Data(1,".07",1,".02")="SE1"
456 ;" Data(1,".07",1,".03")="'Some Info'"
457 ;" Data(1,".07",2,".01")="SubEntry2"
458 ;" Data(1,".07",2,".02")="SE2"
459 ;" Data(1,".07",2,".04",0,cEntries)=1 ;"TEXT converted to .04
460 ;" Data(1,".07",2,".04",0,cParentIENS)=",3,10033,"
461 ;" Data(1,".07",2,".04",1,".01")="JD"
462 ;" Data(1,".07",2,".04",1,".02")="DOE,JOHN"
463
464
465 if $get(Parsed(cName))="" do goto UploadDone
466 . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"No name found!")
467 . set result=cAbort
468
469 set Data(0,cFile)=2 ;"file 2=PATIENT file
470 set Data(0,cEntries)=1
471 if $data(Parsed(cName)) do
472 . set Data(1,.01)=Parsed(cName)
473 . set Data(1,.01,cMatchThis)=1
474 if $data(Parsed(cSex)) set Data(1,.02)=Parsed(cSex)
475 if $data(Parsed(cDOB)) set Data(1,.03)=Parsed(cDOB)
476 ;"if $data(Parsed(cDateReg)) set Data(1,.097)=Parsed(cDateReg) ;".097 = DATE ENTERED INTO FILE
477 if $data(Parsed(cStrAddr)) set Data(1,.111)=Parsed(cStrAddr) ;".111 = STREED ADDRESS [LINE 1]
478 if $data(Parsed(cZip)) set Data(1,.1112)=Parsed(cZip) ;".1112 = ZIP+4
479 if $data(Parsed(cCity)) set Data(1,.114)=Parsed(cCity)
480 if $data(Parsed(cState)) set Data(1,.115)=Parsed(cState)
481 if $data(Parsed(cPhone1)) set Data(1,.131)=Parsed(cPhone1) ;".131 = PHONE NUMBER [RESIDENCE]
482 if $data(Parsed(cPhone2)) set Data(1,.132)=Parsed(cPhone2) ;".132 = PHONE NUMBER [WORK]
483 if $data(Parsed(cChartNum)) set Data(1,22700)=Parsed(cChartNum);"22700 = MEDIC ACCOUNT NUMBER
484
485
486 new result
487
488 new tempDebug set tempDebug=TMGDEBUG
489 set TMGDEBUG=0 ;"DISALLOW DEBUG OF UPLOAD -- TOO MUCH INFORMATION!
490 set result=$$UploadData^TMGDBAPI(.Data)
491 set TMGDEBUG=tempDebug
492
493 if result=cAbort do
494 . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Error uploading record")
495 . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Data")
496
497UploadDone
498
499 if result=cAbort do
500 . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"This record not uploaded")
501 . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Parsed")
502
503 if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"FileParsed")
504
505 quit result
506
507
508 ;"=====================================================================================
509
510Purge
511 ;"ENTRY POINT...
512 ;"Purge: Purge duplicate records
513 new index
514 new CurPt
515 new Count set Count=0
516 new Inc set Inc=0
517
518 kill ^TMP("TMG","DUPLICATE")
519 set ^TMP("TMG","DUPLICATE","NEXT")=1
520
521 write !,!,"Starting to check for duplicate entries.",!,!
522 set index=$order(^DPT(0))
523
524 for do quit:index=""
525 . set CurPt=$piece($get(^DPT(index,0)),"^",1)
526 . set index=$order(^DPT(index))
527 . set Count=Count+1
528 . set Inc=Inc+1
529 . if Inc>999 do
530 . . write !,Count," records processed so far. (",Count/69758*100,"%)",!
531 . . set Inc=0
532 . if CurPt="" quit
533 . ;"write "Considering ",CurPt,!
534 . write "."
535 . new lname,fname,PtName
536 . set lname=$piece(CurPt,",",1)
537 . set fname=$piece(CurPt,",",2)
538 . set fname=$extract(fname,1,3) ;"only check first 3 letters of first name
539 . set PtName=lname_","_fname
540 . ;"--------
541 . new Matches,TMGMsg
542 . new FileNumber,IENS,Fields,Flags,MatchValue,ScreenCode
543 . set FileNumber=2
544 . set IENS=""
545 . set Fields="@;.01;.02;.03;.09;22700"
546 . set Flags=""
547 . set MatchValue=PtName
548 . set ScreenCode=""
549 . ;"Call FIND^DIC
550 . ;"FILE,IENS,FIELDS,FLAGS,VALUE,NUMBER,INDEXES,SCREEN,IDENTIFIER,TARGET_ROOT,MSG_ROOTS
551 . do FIND^DIC(FileNumber,$get(IENS),Fields,Flags,MatchValue,"*",,ScreenCode,,"Matches","TMGMsg")
552 . ;"======================================================
553 . if $data(Matches("DILIST",0))'=0 do
554 . . new NumMatches set NumMatches=$piece(Matches("DILIST",0),"^",1)
555 . . if NumMatches>1 do
556 . . . if $$DoComp(.Matches)>0 do
557 . . . . ;"write "*** Multiple entries found!",!
558 . read *KeyPress:0
559 . if KeyPress=27 do quit:index=""
560 . . new Answer
561 . . write !
562 . . read "Do yu want to quit (y/n)?",Answer
563 . . if Answer="y" set index=""
564 . . write !,!
565
566 zwr ^TMP("TMG","DUPLICATE",*)
567
568 quit
569
570DoComp(Matches)
571 ;"Purpose: to find duplicate entries
572 ;"result 0=no duplicates, 1=duplicate 2=exact match found (and killed)
573
574 new index1,index2
575 new result set result=0
576
577 new MaxCount set MaxCount=$piece(Matches("DILIST",0),"^",1)
578 for index1=1:1:(MaxCount-1) do quit:(result>0)
579 . new A
580 . merge A=Matches("DILIST","ID",index1)
581 . set A("IEN")=Matches("DILIST",2,index1)
582 . for index2=index1+1:1:MaxCount do quit:(result>0)
583 . . new B
584 . . merge B=Matches("DILIST","ID",index2)
585 . . set B("IEN")=Matches("DILIST",2,index2)
586 . . set result=$$CompRecs(.A,.B)
587 . . if result>0 do
588 . . . ;"write !,"Duplicate found.",!
589 . . . new NextI set NextI=^TMP("TMG","DUPLICATE","NEXT")
590 . . . merge ^TMP("TMG","DUPLICATE",NextI,"A")=A
591 . . . merge ^TMP("TMG","DUPLICATE",NextI,"B")=B
592 . . . set ^TMP("TMG","DUPLICATE","NEXT")=NextI+1
593 . . . if result=1 do
594 . . . . new KeepRec set KeepRec=$$WhichToKeep(.A,.B)
595 . . . . if KeepRec=1 do MergeAIntoB(B("IEN"),A("IEN")) ;"Keep A & Kill B,
596 . . . . if KeepRec=2 do MergeAIntoB(A("IEN"),B("IEN")) ;"Keep B & Kill A,
597 . . . . if KeepRec=3 do
598 . . . . . do KillRec(B("IEN"))
599 . . . . . do KillRec(A("IEN"))
600 . . . . else write "?",KeepRec
601 . . . if result=2 do ;"exact match
602 . . . . do KillRec(B("IEN"))
603
604 quit result
605
606
607WhichToKeep(A,B)
608 ;"Purpose: Decide if to keep A or B
609 ;"ONLY LOOKS AT NAME
610 ;"Result: 0=Keep both
611 ;" 1=Keep A & Kill B,
612 ;" 2=Keep B & Kill A,
613 ;" 3=Kill both,
614
615 new NameA,NameB
616 set NameA=$get(A(.01))
617 set NameB=$get(B(.01))
618 new lenA,lenB
619 set lenA=$length(NameA)
620 set lenB=$length(NameB)
621 new result set result=0
622
623 if NameA["ZZ" set result=2 ;"(Kill A)
624 if NameB["ZZ" do
625 . if result=2 set result=3 ;"Kill (A & B)
626 . else set result=2 ;"(Kill A)
627 if result>0 goto WTKDone
628
629 new aIEN,bIEN
630 set aIEN=$get(A("IEN"))
631 set bIEN=$get(B("IEN"))
632
633 ;"Because record A or B might have already been killed as part of another set,
634 ;" Don't kill either if one already deleted.
635 if $data(^TMP("TMG","KILLED",aIEN))>0 set result=3 W "%" goto WTKDone ;"no killing
636 if $data(^TMP("TMG","KILLED",bIEN))>0 set result=3 W "%" goto WTKDone ;"no killing
637
638 new AMainName,AInitial
639 new BMainName,BInitial
640 set AMainName=$piece(NameA," ",1)
641 set BMainName=$piece(NameB," ",1)
642 set AInitial=$piece(NameA," ",2)
643 set BInitial=$piece(NameB," ",2)
644
645 if (lenA>lenB)&($extract(NameA,1,lenB)=NameB) set result=1 ;"kill B
646 else if (lenB>lenA)&($extract(NameB,1,lenA)=NameA) set result=2 ;"kill A
647 else if NameA=NameB do
648 . set result=1
649 else if (AMainName=BMainName)&($length(AInitial)=1)&($length(BInitial)=1) do
650 . ;"Names only differ by a one letter middle initial.
651 . ;"Arbitrarily kill B
652 . set result=1
653 else do
654 . new Answer
655 . write !,"Which record to KILL?",!
656 . write "a --> Kill: ",NameA,!
657 . write "b --> Kill: ",NameB,!
658 . write "x. --> Kill ",NameA,", but remember as ALIAS for ",NameB,!
659 . write "y. --> Kill ",NameB,", but remember as ALIAS for ",NameA,!
660 . write "^ --> KEEP BOTH",!
661 . read Answer
662 . if Answer="x" do AddAlias(NameA,bIEN) set Answer="a"
663 . if Answer="y" do AddAlias(NameB,aIEN) set Answer="b"
664 . if Answer="a" set result=2
665 . if Answer="b" set result=1
666
667WTKDone
668 ;"if result=0 do
669 ;". zwr A(*)
670 ;". zwr B(*)
671 ;". new temp
672 ;". read "Hit Enter",temp
673 quit result
674
675
676AddAlias(AName,IEN)
677 ;"Put Alias Name into record IEN
678 new SubFNum set SubFNum=2.01 ;"Field 1 (alias) in File 2
679
680 new TMGFDA,TMGMsg
681
682 if $get(AName)'="" do
683 . set TMGFDA(SubFNum,"?+1,"_IEN_",",.01)=AName
684 . do UPDATE^DIE("EK","TMGFDA","TMGMsg")
685 . if $data(TMGMsg("DILIST")) zwr TMGMsg(*)
686 . set ^TMP("TMG","ALIAS-ADDED",IEN)=AName
687 quit
688
689
690MergeAIntoB(DelRecN,SaveRecN)
691 ;"Put Chat number from record to be deleted into Saved record
692 ;" THEN delete the deletable record
693 new ChartNum
694 new TMGFDA
695 new SubFNum set SubFNum=2.227005 ;"Field 22700.5 in File 2
696
697 set ChartNum=$piece($get(^DPT(DelRecN,"TMG")),"^",1)
698
699 if +ChartNum>0 do
700 . set TMGFDA(SubFNum,"?+1,"_SaveRecN_",",.01)=ChartNum
701 . do UPDATE^DIE("EK","TMGFDA","TMGMsg")
702 . if $data(TMGMsg("DILIST")) zwr TMGMsg(*)
703
704 do KillRec(DelRecN)
705
706 quit
707
708
709
710KillRec(IEN)
711 new TMGFDA
712 write "#[",IEN,"]"
713 merge ^TMP("TMG","KILLED",IEN)=^DPT(IEN)
714
715 set TMGFDA(2,IEN_",",.01)="@"
716 do FILE^DIE("EK","TMGFDA","TMGMsg")
717 write "#"
718 if $data(TMGMsg("DILIST")) write !,! zwr TMGMsg(*)
719 quit
720
721
722CompRecs(A,B)
723 new result set result=0
724
725 if $get(A(.03))=$get(B(.03)) do
726 . if $get(A(.02))=$get(B(.02)) do
727 . . set result=1
728 . . if $get(A(.01))=$get(B(.01)) do
729 . . . if $get(A(.09))=$get(B(.09)) do
730 . . . . set result=2 ;"exact match
731
732
733 quit result
734
735
736FixFName(CurPt)
737
738 new lname,fname,PtName
739 set lname=$piece(CurPt,",",1)
740 set fname=$piece(CurPt,",",2)
741 new name set name=$$FixName(.lname,.fname)
742
743 quit name
744
745
746FixName(lname,fname)
747 ;"Purpose: change III,ALLEN J BROWN to BROWN,ALLEN J III
748 ;"Results: returns BROWN,ALLEN J III
749 new NameArray
750 new MaxNode
751 new Suffix set Suffix=lname
752 new i,s
753
754 set s=fname set fname=""
755 do CleaveToArray^TMGSTUTL(s," ",.NameArray,1)
756 set MaxNode=+$get(NameArray("MAXNODE"))
757 if MaxNode=0 goto FixDone
758 set lname=NameArray(MaxNode)
759 for i=1:1:MaxNode-1 do
760 . set fname=fname_NameArray(i)_" "
761 set fname=fname_Suffix
762
763 new result
764 set result=lname_","_fname
765
766FixDone
767 quit result
768
769
770
771FixAllNames
772 ;"ENTRY POINT...
773 ;"Purge: To change all names that erroneously have a last name of "SR","JR","III","II"
774 new index
775 new PtName,index
776
777 ;new Matches,TMGMsg
778 new FileNumber,IENS,Fields,Flags,MatchValue,ScreenCode
779 set FileNumber=2
780 set IENS=""
781 set Fields="@;.01;.02;.03;.09;22700"
782 set Flags=""
783 set ScreenCode=""
784
785 for PtName="JR,","SR,","III,","II" do
786 . write "Looking for patients with a last name of: ",PtName,!
787 . set MatchValue=PtName
788 . ;"Call FIND^DIC
789 . ;"FILE,IENS,FIELDS,FLAGS,VALUE,NUMBER,INDEXES,SCREEN,IDENTIFIER,TARGET_ROOT,MSG_ROOTS
790 . do FIND^DIC(FileNumber,IENS,Fields,Flags,MatchValue,"*",,ScreenCode,,"Matches","TMGMsg")
791 . ;"======================================================
792 . if $data(Matches("DILIST",0))'=0 do
793 . . ;"write "Here are the names found:",!
794 . . ;"zwr Matches("DILIST",*)
795 . . new NumMatches set NumMatches=$piece(Matches("DILIST",0),"^",1)
796 . . write "Found "_NumMatches_" matches.",!
797 . . if NumMatches>1 for index=1:1:NumMatches do
798 . . . write "index=",index,!
799 . . . new IEN set IEN=Matches("DILIST",2,index)
800 . . . write "IEN=",IEN,!
801 . . . new OldName set OldName=$piece($get(^DPT(IEN,0)),"^",1)
802 . . . write "OldName=",OldName,!
803 . . . new NewName set NewName=$$FixFName(OldName)
804 . . . new IENS set IENS=IEN_","
805 . . . write "Changing "_OldName_" to "_NewName,!
806 . . . ;new TMGFDA
807 . . . set TMGFDA(FileNumber,IENS,.01)=NewName
808 . . . kill TMGMsg
809 . . . write "Calling FILE^DIE",!
810 . . . write "TMGFDA:",!
811 . . . zwr TMGFDA(*)
812 . . . do FILE^DIE("EK","TMGFDA","TMGMsg")
813 . . . write "Done Calling FILE^DIE",!
814 . . . if $data(TMGMsg) zwr TMGMsg(*)
815
816 write !,!,!,"Done!",!
817
818 quit
819
Note: See TracBrowser for help on using the repository browser.