TMGIMPORT ;TMG/kst/Code for importing from legacy MEDIC PMS ;03/25/06 ;;1.0;TMG-LIB;**1**;11/01/04 ;"Custom functions for importing data from legacy MEDIC system ImportLabels ;"Purpose: To import a file with patient name, DOB etc, and ;"register all these patients ; ;"This is an example entry: ;"------------------------ ;"ADAM R JONES ;"123 JONESS CREEK RD ;"GREENEVILLE TN 37743 ;"423 666 6666 423 666 6667 ;" 123456 05151971M 040302 new TMGDEBUG set TMGDEBUG=0 ;"Note: user could change this at runtime... new DBIndent set DBIndent=0 new PriorErrorFound set PriorErrorFound=0 new cGUI set cGUI="GUI" new cCHUI set cCHUI="CHUI" new cRoll set cRoll="Roll-n-Scroll" new DModes new cDialog set cDialog="UseDialog" set DModes(0)="x" set DModes(1)=cGUI set DModes(2)=cCHUI set DModes(3)=cRoll set DModes(4)="x" new cTrue set cTrue=1 new cFalse set cFalse=0 new cdbNone set cdbNone=0 new cdbToScrn set cdbToScrn=1 new cdbToFile set cdbToFile=2 new cdbToTail set cdbToTail=3 new cdbAbort set cdbAbort=-1 new cOKToCont set cOKToCont=1 new cAbort set cAbort=0 new cName set cName="01. NAME" new cDOB set cDOB="02. DOB" new cSex set cSex="03. SEX" new cStrAddr set cStrAddr="04. STREET ADDRESS" new cCity set cCity="05. CITY" new cState set cState="06. STATE" new cZip set cZip="07. ZIP" new cPhone1 set cPhone1="08. PHONE-1" new cPhone2 set cPhone2="09. PHONE-2" new cDateReg set cDateReg="10. DATE REGISTERED" new cChartNum set cChartNum="11. CHARTNUM" new Filename new DebugFPath new DebugFName new DebugFile new LabelArray,PLabelArray new FileHandle new UserPath,UserFName new result new FileSpec new line set line="" do DebugEntry^TMGDEBUG(.DBIndent,"Main Run") ;"A local code login function. if $$XUP^TMGXUP()=0 do goto RunDone . do ShowError^TMGDEBUG(.PriorErrorFound,"Error setting up a user privilages for configuration.") ;"------------------------------------------------------------------------------------ if ($data(DispMode)#10=0)!($get(DispMode)>3)!($get(DispMode)<1) do . set DispMode=$$GetDispMode() set DispMode=DModes(DispMode) if DispMode="x" goto RunDone set DispMode(cDialog)=(DispMode'=cRoll) if ($data(DebugMode)#10=0)!($get(DebugMode)<0)!($get(DebugMode)>3)!(($get(DebugMode)=1)&(DispMode'=cGUI)) do . set TMGDEBUG=$$GetDebugMode^TMGDEBUG(cdbNone) else do . set TMGDEBUG=DebugMode if TMGDEBUG=cdbAbort goto RunDone do . new DefPath set DefPath="/tmp/" . new DefName set DefName="M_Import_DebugLog.tmp" . new DefFName set DefFName=DefPath_DefName . do OpenLogFile^TMGDEBUG(DefPath,DefName) . if TMGDEBUG=cdbToTail do . . set result=$$Tail^TMGXDLG(DefFName,0,0,0) ;"------------------------------------------------------------------------------------ if ($data(UserPath)#10=0)!($data(UserFName)#10=0) do . set result=$$GetFName(.UserPath,.UserFName) . if result=cAbort do PopupBox^TMGUSRIF(" No file selected.","Come back again soon!") else do . set result=cOKToCont if (result=cAbort)!($data(UserPath)=0)!($data(UserFName)=0) goto RunDone set Filename=UserPath_"/"_UserFName ;"------------------------------------------------------------------------------------ ;new Array new InFile,RecNum,EOF new counter set counter=0 write "Please be patient...",!,! set InFile=Filename open InFile:readonly:2 else do goto QLoad . do ShowError^TMGDEBUG(.PriorErrorFound,"Error opening file: ",UserPath_"/"_UserFName) for RecNum=1:1 do quit:EOF . ;"set EOF=$$GetRecord(.Array,RecNum) . set EOF=$$GetRecord(.Array,1) . set ArrayP=$name(Array(1)) . do ParseRecord(ArrayP,.Parsed) . if $$ScreenParsed(.Parsed)=cOKToCont do . . if $$FileParsed(.Parsed)=cOKToCont do . . . write "." . . else do . . . write "!" . else write "X" . set counter=counter+1 . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Counter=",counter) . if counter=80 do . . ;"write @IOF . . write !,RecNum," records processed so far.",! . . set counter=0 . ;"write "hit key.." . read *KeyPress:0 . if KeyPress=27 set EOF=1 . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"End of loop. EOF=",EOF) close InFile write !,!,RecNum," Records processed.",!,! goto RunDone RunDone write "Goodbye",!,! if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"Main Run") quit GetFName(Path,Filename) ;"Purpose: Interact with user to get path and filename ;"Input: Path--should be passed by reference, used to pass back result ;" Filename--should be passed by reference, used to pass back result ;"Output: Results passed in Path and Filename ;" Function will result in 0 if user 'cancelled', 1 otherwise new result set result=cAbort new FullNamePath new PathNode set Path="/" set Filename="" if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetFName") if DispMode=cRoll goto GFNRoll if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Calling $$FileSel()") set FullNamePath=$$FileSel^TMGXDLG("Please select script to process . . .","~/MedicLabels") if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Results=",FullNamePath) if FullNamePath="" goto GFNDone ;"result=cAbort still --> cancelled. ;"Separate path from filename GFNL1 if '(FullNamePath["/") set Filename=FullNamePath goto GFNL2 set PathNode=$piece(FullNamePath,"/",1) set Path=Path_PathNode_"/" set $piece(FullNamePath,"/",1)="" set FullNamePath=$extract(FullNamePath,2,255) goto GFNL1 GFNL2 set result=cOKToCont goto GFNDone GFNRoll new DefFName set DefFName="MedicLabels" new DefPath set DefPath="/home/kdt0p" ;"write !,"------------------------------------------",! write ! write "Enter filename with path:",! write " ['^'] = Abort",! write " [Enter] = '",DefPath,"/",DefFName,"'",! write "> " read Filename:240 write ! if Filename="^" goto GFNDone if Filename="" do . set Filename=DefFName . set Path=DefPath . write "Using default: ",Path,"/",Filename,!,!,! set result=cOKToCont GFNDone if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetFName") quit result GetDispMode() ;"Purpose: To determine with form of input user wants ;"Results: 1=GUI,2=CHUI,3=RollNScroll,0=abort new Input new result set result=cAbort new Default set Default=3 if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetDispMode") write "Select interface option:",! write " 0. Quit. (Goodbye!)",! write " 1. Linux X graphics/ 'GUI' (Recommended)",! write " 2. Text graphics / 'CHUI' (Incomplete)",! write " 3. Line-by-Line / 'Roll-and-scroll'",! write "Enter option number ("_Default_"): " read Input,! if Input="" do . ;"write "Defaulting to: ",Default,! . set Input=Default else if +Input>4 do . set Input=Default set result=+Input if (Input=1)!(Input=2) do . do SetupConsts^TMGXDLG() . do SetGUI^TMGXDLG(Input=1) ;"if Input=2 do goto GIMDone ;". do SetupConsts^TMGXDLG() ;". do SetGUI^TMGXDLG(0) GIMDone if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Display mode set at: ",result) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetDispMode") quit result LogSkipped use OutFile GetRecord(Array,RecNum) ;"Purpose: ;" if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetRecord") new done,i new BlankLine set BlankLine="" new Parsed,ArrayP use InFile for i=1:1:6 do quit:($zeof) . if line="" read line . set Array(RecNum,i)=line . set line="" . if $zeof quit . ;"read BlankLine ;"read and discard blank line . ;"if BlankLine'="" set line=BlankLine ;"for do quit:($zeof)!(line'="") ;". read line ;". set line=$$Trim^TMGSTUTL(line) use 0 QLoad if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetRecord") quit $zeof ParseRecord(ArrayP,Parsed) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ParseRecord") new s,s1,s2 new NameArray new MaxNode,i kill Parsed ;"temp new tempDEBUG set tempDEBUG=$get(TMGDEBUG) set TMGDEBUG=0 set s=$get(@ArrayP@(1)) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Init Name Line=",s) if s'="" do . new Suffix set Suffix="" . do CleaveToArray^TMGSTUTL(s," ",.NameArray,1) . if $get(NameArray(1))="BABY" quit . set MaxNode=+$get(NameArray("MAXNODE")) . if MaxNode'>0 do quit . . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Error after CleaveToArray. Here is NameArray:") . . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("NameArray") . if (NameArray(MaxNode)="JR")!(NameArray(MaxNode)="SR") do . . set Suffix=NameArray(MaxNode) . . kill NameArray(MaxNode) . . set MaxNode=MaxNode-1 . set s1=NameArray(MaxNode)_"," . for i=1:1:MaxNode-1 do . . set s1=s1_NameArray(i)_" " . set s1=s1_Suffix . set s1=$$Trim^TMGSTUTL(s1) . if $extract(s1,1,2)="ZZ" set s1="" ;"DROP ZZ NAMES . if (s1'["0")&(s1'["1")&(s1'["2")&(s1'["3")&(s1'["4")&(s1'["5")&(s1'["6")&(s1'["7")&(s1'["8")&(s1'["9") do . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"final Name Line=",s1) . . if s1'="" set Parsed(cName)=s1 set s=$get(@ArrayP@(2)) set s2=$$Trim^TMGSTUTL(s) if $length(s2)>34 set s2=$extract(s2,1,34) if $length(s2)<3 set s2="" if s2'="" set Parsed(cStrAddr)=s2 set s=$get(@ArrayP@(3)) set s1=$extract(s,1,16) set s2=$$Trim^TMGSTUTL(s1) if s2'="" set Parsed(cCity)=s2 set s1=$extract(s,17,18) set s2=$$Trim^TMGSTUTL(s1) if $length(s2)'=2 set s2="" if s2'="" set Parsed(cState)=s2 set s1=$extract(s,19,256) set s2=$$Trim^TMGSTUTL(s1) if s2'="" set Parsed(cZip)=s2 set s=$get(@ArrayP@(4)) set s2=$$Trim^TMGSTUTL($extract(s,1,12)) if s2="000 000 0000" set s2="" if s2'="" set Parsed(cPhone1)=s2 set s2=$$Trim^TMGSTUTL($extract(s,16,27)) if s2="000 000 0000" set s2="" if s2'="" set Parsed(cPhone2)=s2 set s=$get(@ArrayP@(5)) set s1=$extract(s,1,10) set s2=$$Trim^TMGSTUTL(s1) set s2=$translate(s2,"DPWCI\*","") ;"Clean off alpha characters -- not needed. if $extract(s2,1,2)="ZZ" set s2="" if s2'="" set Parsed(cChartNum)=s2 set s1=$extract(s,11,18) set s1=$$FixDate(s1) if s1'="" set Parsed(cDOB)=s1 set s1=$extract(s,19,19) if (s1'="M")&(s1'="F") do . set s1="M" ;"NOTE, I AM SETTING ALL UNKNOWN SEX's TO MALE if s1'="" set Parsed(cSex)=s1 set s1=$extract(s,21,26) set s1=$$FixDate(s1) if s1'="" set Parsed(cDateReg)=s1 ;"temp set TMGDEBUG=tempDEBUG if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"ParseRecord") quit FixDate(Date) new Month,Day,Year new result set result="" set Date=$$Trim^TMGSTUTL(Date) set Month=$$Trim^TMGSTUTL($extract(Date,1,2)) if +Month>0 do . set result=Month . set Day=$$Trim^TMGSTUTL($extract(Date,3,4)) . if +Day>0 do . . set result=result_"/"_Day . . set Year=$$Trim^TMGSTUTL($extract(Date,5,8)) . . if +Year>0 do . . . set result=result_"/"_Year quit result ScreenParsed(Parsed) ;"Purpose: Screen record. If not appropriate for filing, then ;" Parsed(*) is emptied ;"Result: 0 if Parsed is ok to file, 1 if killed if $get(Parsed(cName))="" do goto SPKill . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"No name found!") if $get(Parsed(cChartNum))="" do goto SPKill . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"No chart number found!") if $get(Parsed(cDOB))="" do goto SPKill . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"No DOB found!") quit cOKToCont SPKill if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Killing Parsed. Here it is first...") if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Parsed") kill Parsed quit cAbort FileParsed(Parsed) if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"FileParsed") new cOKToCont set cOKToCont=1 new cAbort set cAbort=0 new cFile set cFile="FILE" new cEntries set cEntries="Entries" new cMatchThis set cMatchThis="MATCHTHIS" ;"MatchThis" new result set result=cOKToCont new Data ;"The Data array will be filed with data. (An example) ;" Data(0,cFile)="1234.1" <-- "NEW PERSON" Note conversion ;" Data(0,cFile,cGlobal)="^DIC(200)" <-- note, NOT "^DIC(200," ;" Data(0,cRecNum)=2 <-- only if user-specified. ;" Data(0,cEntries)=1 ;" Data(1,".01")="MyData1" ;" Data(1,".01",cMatchValue)="MyData1" ;" Data(1,".01",cFlags)=any flags given (only present if user specified) ;" Data(1,".02")="Bill" ;" Data(1,".02",cMatchValue)="John" ;" Data(1,".03")="MyData3" ;" Data(1,".04")="MyData4" ;" Data(1,".06")="MyData5" <-- note "NAME" was converted to ".06" ;" Data(1,".07",0,cEntries)=2 <-- "ITEM" converted to ".07" ;" Data(1,".07",0,cParentIENS)=",10033," ;" Data(1,".07",1,".01")="SubEntry1" ;" Data(1,".07",1,".02")="SE1" ;" Data(1,".07",1,".03")="'Some Info'" ;" Data(1,".07",2,".01")="SubEntry2" ;" Data(1,".07",2,".02")="SE2" ;" Data(1,".07",2,".04",0,cEntries)=1 ;"TEXT converted to .04 ;" Data(1,".07",2,".04",0,cParentIENS)=",3,10033," ;" Data(1,".07",2,".04",1,".01")="JD" ;" Data(1,".07",2,".04",1,".02")="DOE,JOHN" if $get(Parsed(cName))="" do goto UploadDone . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"No name found!") . set result=cAbort set Data(0,cFile)=2 ;"file 2=PATIENT file set Data(0,cEntries)=1 if $data(Parsed(cName)) do . set Data(1,.01)=Parsed(cName) . set Data(1,.01,cMatchThis)=1 if $data(Parsed(cSex)) set Data(1,.02)=Parsed(cSex) if $data(Parsed(cDOB)) set Data(1,.03)=Parsed(cDOB) ;"if $data(Parsed(cDateReg)) set Data(1,.097)=Parsed(cDateReg) ;".097 = DATE ENTERED INTO FILE if $data(Parsed(cStrAddr)) set Data(1,.111)=Parsed(cStrAddr) ;".111 = STREED ADDRESS [LINE 1] if $data(Parsed(cZip)) set Data(1,.1112)=Parsed(cZip) ;".1112 = ZIP+4 if $data(Parsed(cCity)) set Data(1,.114)=Parsed(cCity) if $data(Parsed(cState)) set Data(1,.115)=Parsed(cState) if $data(Parsed(cPhone1)) set Data(1,.131)=Parsed(cPhone1) ;".131 = PHONE NUMBER [RESIDENCE] if $data(Parsed(cPhone2)) set Data(1,.132)=Parsed(cPhone2) ;".132 = PHONE NUMBER [WORK] if $data(Parsed(cChartNum)) set Data(1,22700)=Parsed(cChartNum);"22700 = MEDIC ACCOUNT NUMBER new result new tempDebug set tempDebug=TMGDEBUG set TMGDEBUG=0 ;"DISALLOW DEBUG OF UPLOAD -- TOO MUCH INFORMATION! set result=$$UploadData^TMGDBAPI(.Data) set TMGDEBUG=tempDebug if result=cAbort do . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Error uploading record") . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Data") UploadDone if result=cAbort do . if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"This record not uploaded") . if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Parsed") if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"FileParsed") quit result ;"===================================================================================== Purge ;"ENTRY POINT... ;"Purge: Purge duplicate records new index new CurPt new Count set Count=0 new Inc set Inc=0 kill ^TMP("TMG","DUPLICATE") set ^TMP("TMG","DUPLICATE","NEXT")=1 write !,!,"Starting to check for duplicate entries.",!,! set index=$order(^DPT(0)) for do quit:index="" . set CurPt=$piece($get(^DPT(index,0)),"^",1) . set index=$order(^DPT(index)) . set Count=Count+1 . set Inc=Inc+1 . if Inc>999 do . . write !,Count," records processed so far. (",Count/69758*100,"%)",! . . set Inc=0 . if CurPt="" quit . ;"write "Considering ",CurPt,! . write "." . new lname,fname,PtName . set lname=$piece(CurPt,",",1) . set fname=$piece(CurPt,",",2) . set fname=$extract(fname,1,3) ;"only check first 3 letters of first name . set PtName=lname_","_fname . ;"-------- . new Matches,TMGMsg . new FileNumber,IENS,Fields,Flags,MatchValue,ScreenCode . set FileNumber=2 . set IENS="" . set Fields="@;.01;.02;.03;.09;22700" . set Flags="" . set MatchValue=PtName . set ScreenCode="" . ;"Call FIND^DIC . ;"FILE,IENS,FIELDS,FLAGS,VALUE,NUMBER,INDEXES,SCREEN,IDENTIFIER,TARGET_ROOT,MSG_ROOTS . do FIND^DIC(FileNumber,$get(IENS),Fields,Flags,MatchValue,"*",,ScreenCode,,"Matches","TMGMsg") . ;"====================================================== . if $data(Matches("DILIST",0))'=0 do . . new NumMatches set NumMatches=$piece(Matches("DILIST",0),"^",1) . . if NumMatches>1 do . . . if $$DoComp(.Matches)>0 do . . . . ;"write "*** Multiple entries found!",! . read *KeyPress:0 . if KeyPress=27 do quit:index="" . . new Answer . . write ! . . read "Do yu want to quit (y/n)?",Answer . . if Answer="y" set index="" . . write !,! zwr ^TMP("TMG","DUPLICATE",*) quit DoComp(Matches) ;"Purpose: to find duplicate entries ;"result 0=no duplicates, 1=duplicate 2=exact match found (and killed) new index1,index2 new result set result=0 new MaxCount set MaxCount=$piece(Matches("DILIST",0),"^",1) for index1=1:1:(MaxCount-1) do quit:(result>0) . new A . merge A=Matches("DILIST","ID",index1) . set A("IEN")=Matches("DILIST",2,index1) . for index2=index1+1:1:MaxCount do quit:(result>0) . . new B . . merge B=Matches("DILIST","ID",index2) . . set B("IEN")=Matches("DILIST",2,index2) . . set result=$$CompRecs(.A,.B) . . if result>0 do . . . ;"write !,"Duplicate found.",! . . . new NextI set NextI=^TMP("TMG","DUPLICATE","NEXT") . . . merge ^TMP("TMG","DUPLICATE",NextI,"A")=A . . . merge ^TMP("TMG","DUPLICATE",NextI,"B")=B . . . set ^TMP("TMG","DUPLICATE","NEXT")=NextI+1 . . . if result=1 do . . . . new KeepRec set KeepRec=$$WhichToKeep(.A,.B) . . . . if KeepRec=1 do MergeAIntoB(B("IEN"),A("IEN")) ;"Keep A & Kill B, . . . . if KeepRec=2 do MergeAIntoB(A("IEN"),B("IEN")) ;"Keep B & Kill A, . . . . if KeepRec=3 do . . . . . do KillRec(B("IEN")) . . . . . do KillRec(A("IEN")) . . . . else write "?",KeepRec . . . if result=2 do ;"exact match . . . . do KillRec(B("IEN")) quit result WhichToKeep(A,B) ;"Purpose: Decide if to keep A or B ;"ONLY LOOKS AT NAME ;"Result: 0=Keep both ;" 1=Keep A & Kill B, ;" 2=Keep B & Kill A, ;" 3=Kill both, new NameA,NameB set NameA=$get(A(.01)) set NameB=$get(B(.01)) new lenA,lenB set lenA=$length(NameA) set lenB=$length(NameB) new result set result=0 if NameA["ZZ" set result=2 ;"(Kill A) if NameB["ZZ" do . if result=2 set result=3 ;"Kill (A & B) . else set result=2 ;"(Kill A) if result>0 goto WTKDone new aIEN,bIEN set aIEN=$get(A("IEN")) set bIEN=$get(B("IEN")) ;"Because record A or B might have already been killed as part of another set, ;" Don't kill either if one already deleted. if $data(^TMP("TMG","KILLED",aIEN))>0 set result=3 W "%" goto WTKDone ;"no killing if $data(^TMP("TMG","KILLED",bIEN))>0 set result=3 W "%" goto WTKDone ;"no killing new AMainName,AInitial new BMainName,BInitial set AMainName=$piece(NameA," ",1) set BMainName=$piece(NameB," ",1) set AInitial=$piece(NameA," ",2) set BInitial=$piece(NameB," ",2) if (lenA>lenB)&($extract(NameA,1,lenB)=NameB) set result=1 ;"kill B else if (lenB>lenA)&($extract(NameB,1,lenA)=NameA) set result=2 ;"kill A else if NameA=NameB do . set result=1 else if (AMainName=BMainName)&($length(AInitial)=1)&($length(BInitial)=1) do . ;"Names only differ by a one letter middle initial. . ;"Arbitrarily kill B . set result=1 else do . new Answer . write !,"Which record to KILL?",! . write "a --> Kill: ",NameA,! . write "b --> Kill: ",NameB,! . write "x. --> Kill ",NameA,", but remember as ALIAS for ",NameB,! . write "y. --> Kill ",NameB,", but remember as ALIAS for ",NameA,! . write "^ --> KEEP BOTH",! . read Answer . if Answer="x" do AddAlias(NameA,bIEN) set Answer="a" . if Answer="y" do AddAlias(NameB,aIEN) set Answer="b" . if Answer="a" set result=2 . if Answer="b" set result=1 WTKDone ;"if result=0 do ;". zwr A(*) ;". zwr B(*) ;". new temp ;". read "Hit Enter",temp quit result AddAlias(AName,IEN) ;"Put Alias Name into record IEN new SubFNum set SubFNum=2.01 ;"Field 1 (alias) in File 2 new TMGFDA,TMGMsg if $get(AName)'="" do . set TMGFDA(SubFNum,"?+1,"_IEN_",",.01)=AName . do UPDATE^DIE("EK","TMGFDA","TMGMsg") . if $data(TMGMsg("DILIST")) zwr TMGMsg(*) . set ^TMP("TMG","ALIAS-ADDED",IEN)=AName quit MergeAIntoB(DelRecN,SaveRecN) ;"Put Chat number from record to be deleted into Saved record ;" THEN delete the deletable record new ChartNum new TMGFDA new SubFNum set SubFNum=2.227005 ;"Field 22700.5 in File 2 set ChartNum=$piece($get(^DPT(DelRecN,"TMG")),"^",1) if +ChartNum>0 do . set TMGFDA(SubFNum,"?+1,"_SaveRecN_",",.01)=ChartNum . do UPDATE^DIE("EK","TMGFDA","TMGMsg") . if $data(TMGMsg("DILIST")) zwr TMGMsg(*) do KillRec(DelRecN) quit KillRec(IEN) new TMGFDA write "#[",IEN,"]" merge ^TMP("TMG","KILLED",IEN)=^DPT(IEN) set TMGFDA(2,IEN_",",.01)="@" do FILE^DIE("EK","TMGFDA","TMGMsg") write "#" if $data(TMGMsg("DILIST")) write !,! zwr TMGMsg(*) quit CompRecs(A,B) new result set result=0 if $get(A(.03))=$get(B(.03)) do . if $get(A(.02))=$get(B(.02)) do . . set result=1 . . if $get(A(.01))=$get(B(.01)) do . . . if $get(A(.09))=$get(B(.09)) do . . . . set result=2 ;"exact match quit result FixFName(CurPt) new lname,fname,PtName set lname=$piece(CurPt,",",1) set fname=$piece(CurPt,",",2) new name set name=$$FixName(.lname,.fname) quit name FixName(lname,fname) ;"Purpose: change III,ALLEN J BROWN to BROWN,ALLEN J III ;"Results: returns BROWN,ALLEN J III new NameArray new MaxNode new Suffix set Suffix=lname new i,s set s=fname set fname="" do CleaveToArray^TMGSTUTL(s," ",.NameArray,1) set MaxNode=+$get(NameArray("MAXNODE")) if MaxNode=0 goto FixDone set lname=NameArray(MaxNode) for i=1:1:MaxNode-1 do . set fname=fname_NameArray(i)_" " set fname=fname_Suffix new result set result=lname_","_fname FixDone quit result FixAllNames ;"ENTRY POINT... ;"Purge: To change all names that erroneously have a last name of "SR","JR","III","II" new index new PtName,index ;new Matches,TMGMsg new FileNumber,IENS,Fields,Flags,MatchValue,ScreenCode set FileNumber=2 set IENS="" set Fields="@;.01;.02;.03;.09;22700" set Flags="" set ScreenCode="" for PtName="JR,","SR,","III,","II" do . write "Looking for patients with a last name of: ",PtName,! . set MatchValue=PtName . ;"Call FIND^DIC . ;"FILE,IENS,FIELDS,FLAGS,VALUE,NUMBER,INDEXES,SCREEN,IDENTIFIER,TARGET_ROOT,MSG_ROOTS . do FIND^DIC(FileNumber,IENS,Fields,Flags,MatchValue,"*",,ScreenCode,,"Matches","TMGMsg") . ;"====================================================== . if $data(Matches("DILIST",0))'=0 do . . ;"write "Here are the names found:",! . . ;"zwr Matches("DILIST",*) . . new NumMatches set NumMatches=$piece(Matches("DILIST",0),"^",1) . . write "Found "_NumMatches_" matches.",! . . if NumMatches>1 for index=1:1:NumMatches do . . . write "index=",index,! . . . new IEN set IEN=Matches("DILIST",2,index) . . . write "IEN=",IEN,! . . . new OldName set OldName=$piece($get(^DPT(IEN,0)),"^",1) . . . write "OldName=",OldName,! . . . new NewName set NewName=$$FixFName(OldName) . . . new IENS set IENS=IEN_"," . . . write "Changing "_OldName_" to "_NewName,! . . . ;new TMGFDA . . . set TMGFDA(FileNumber,IENS,.01)=NewName . . . kill TMGMsg . . . write "Calling FILE^DIE",! . . . write "TMGFDA:",! . . . zwr TMGFDA(*) . . . do FILE^DIE("EK","TMGFDA","TMGMsg") . . . write "Done Calling FILE^DIE",! . . . if $data(TMGMsg) zwr TMGMsg(*) write !,!,!,"Done!",! quit