TMGABV ;TMG/kst/Abbreviation code ; 03/25/06 ;;1.0;TMG-LIB;**1**;12/23/05 ;" ABBREVIATION code ;"Kevin Toppenberg MD ;"GNU General Public License (GPL) applies ;"12-23-2006 ;"======================================================================= ;" API -- Public Functions. ;"======================================================================= ;"$$Read(OrigName,LenCat,DefValue) ;"Write(OrigName,ShortName,LenCat,AskConfirm) ;"Del(OrigName,LenCat,AskConfirm) ;"GetAbvr(Name,AskUser,UseSR) ;"Fix(ShortName) -- provides a way to fix erroneous abbreviations. ;"ShowDiff -- scan and show changes. This is not very useful (a testing function) ;"ScanDel(Text) -- scan for text and allow deletions. ;"======================================================================= ;" Private Functions. ;"======================================================================= ;"CheckDel(longName,DiffArray,DiffStr,lenCat) ;"Fix1(ShortName) -- provide a way to fix erroneous abbreviations. ;"ShowLinks(ShortName,LenCat,array) -- show a chain of abbreviations. ;"GetDiff(longName,LenCat) -- for longName, return what changes for it's abbreviation ;"GetDiffStr(longName,shortName) -- given longName and it's shortname abbreviation, return what changes ;"ScanAbvs(xstr,showProgress) -- scan abbreviations and execute code ;"======================================================================= ;"======================================================================= Read(OrigName,LenCat,DefValue) ;"Purpose: To read from the ABBREV array and return an abbreviation ;"Input: OrigName -- the name to look up ;" LenCat -- OPTIONAL. If specified, then results returned from that category ;" if LenCat="ALL" then all categories are scanned until some value found. ;" DefValue -- OPTIONAL. If specified, a default value if not found ;"Results: Returns the found abbreviation, or "" if not found set DefValue=$get(DefValue) new result set result=DefValue if $get(OrigName)="" goto RdDone if $get(LenCat)'="" do . if LenCat="ALL" do . . set result=$get(^TMG("ABBREV",OrigName),DefValue) quit:(result'="") . . set LenCat="" . . for set LenCat=$order(^TMG("ABBREV",LenCat),-1) quit:(+LenCat'=LenCat)!(result'="") do . . . set result=$get(^TMG("ABBREV",LenCat,OrigName),DefValue) . else do . . set result=$get(^TMG("ABBREV",LenCat,OrigName),DefValue) else do . set result=$get(^TMG("ABBREV",OrigName),DefValue) RdDone if result'="" do . if ($get(TMGDBABV)=1)&(result'=OrigName) do . . write OrigName,"-->",!,result," OK" . . new % set %=1 do YN^DICN write ! . . if %=1 quit . . set result="" . . if %=-1 quit . . if %=2 do Del(OrigNameName,.LenCat,1) quit result Write(OrigName,ShortName,LenCat,AskConfirm) ;"Purpose: To provide a unified writer for ABBREV array ;"Input: OrigName -- the longer name that the abbreviation will stand for ;" ShortName -- the shorter abbreviation of OrigName ;" LenCat -- OPTIONAL -- If supplied, then abbreviation will be stored in this category ;" AskConfirm -- OPTIONAL -- if 1 then user asked to confirm save. ;"results: none ;"Note: Assigning a NULL ShortName is not currently allowed. if $get(OrigName)="" goto WtDone if $get(ShortName)="" goto WtDone set AskConfirm=$get(AskConfirm,0) if $$Read(OrigName,.LenCat)=ShortName goto WtDone ;"Skip write if already there new % set %=1 if AskConfirm=1 do W1 . write "[",OrigName,"] --> [",ShortName,"]",! . write "Save for future use" . do YN^DICN write ! if %'=1 goto WtDone if $get(LenCat)'="" do . set ^TMG("ABBREV",LenCat,OrigName)=ShortName . set ^TMG("ABBREV",LenCat,"XREF",ShortName)=OrigName else do . set ^TMG("ABBREV",OrigName)=ShortName . set ^TMG("ABBREV","XREF",ShortName)=OrigName WtDone quit Del(OrigName,LenCat,AskConfirm) ;"Purpose: To delete a value from the ABBREV array ;"Input: OrigName -- the name to look up ;" LenCat -- OPTIONAL. If specified, then category to delete from ;" AskConfirm -- OPTIONAL -- if 1 then user asked to confirm save. ;"Results: none if $get(OrigName)="" goto DelDone set AskConfirm=$get(AskConfirm,0) new CurValue if $get(LenCat)'="" set CurValue=$get(^TMG("ABBREV",LenCat,OrigName)) else set CurValue=$get(^TMG("ABBREV",OrigName)) new % set %=1 if AskConfirm=1 do . write "[",OrigName,"] -->",!,"[",CurValue,"]",! . write "OK to DELETE" do YN^DICN write ! if %'=1 goto DelDone if $get(LenCat)'="" do . kill ^TMG("ABBREV",LenCat,OrigName) . kill ^TMG("ABBREV",LenCat,"XREF",CurValue) else do . kill ^TMG("ABBREV",OrigName) . kill ^TMG("ABBREV","XREF",CurValue) if AskConfirm'=1 goto DelDone ;"Now see if this same problem needs to be fixed in other abbreviations. new tempS set tempS=$$GetDiffStr(OrigName,CurValue) new DiffArray,count set count=1 write "That association had the following difference(s):",! for quit:(tempS'["^") do . new OneDiff set OneDiff=$piece(tempS,"^",1) . set DiffArray(count)=OneDiff,count=count+1 . write " ",$piece(OneDiff,">",1)," --> ",$piece(OneDiff,">",2),! . set tempS=tempS=$piece(tempS,"^",3,999) set DiffArray("MAXNODE")=$$ListCt^TMGMISC("DiffArray") set %=1 write "Delete all other abbreviations that have these difference(s)" do YN^DICN write ! if %'=1 goto DelDone Del1 new xstr set xstr="do CheckDel(longName,.DiffArray,DiffStr,lenCat)" do ScanAbvs(xstr,1) DelDone quit CheckDel(longName,DiffArray,DiffStr,lenCat) ;"Purpose: this is a callback function for a ScanAbvs run ;" it will be called for each abbreviation ;"Input: DiffArray -- PASS BY REFERENCE. Format: ;" DiffArray(1)="Long1>short1" ;" DiffArray(2)="Long2>short2" ;" DiffArray(3)="Long3>short3" ;" DiffArray("MAXNODE")=3 ;" DiffStr -- a difference string, as created by $$GetDiff ;" lenCat -- the category that eval is from, or "" if none new shouldDel set shouldDel=1 new i for i=1:1:+$get(DiffArray("MAXNODE")) do quit:(shouldDel=0) . set shouldDel=DiffStr[DiffArray(i) if shouldDel=1 do Del(longName,lenCat,0) quit GetAbvr(Name,AskUser,UseSR) ;"Purpose: To get an abbreviation for one word ;"Input: Name -- name to shorten ;" AskUser -- if 1, then user will be asked to supply abbreviations ;" UseSR -- OPTIONAL, default=0. If 0, then ^DIR won't be used ;"Note: The name returned here may be longer than desired, no testing of length done. ;"Results: Returns abreviated name, or original name if not found, or "" if deleted set UseSR=$get(UseSR,0) new result,Y set result=$get(Name) if Name="" goto GADone if $get(AskUser)=1 do . write "Enter a shorter form of '"_Name_"' (^ to delete)",! . if UseSR do . . new DIR . . set DIR(0)="F" . . set DIR("A")="New Name" . . set DIR("B")=result . . do ^DIR write ! . else do . . read "New Name: ",Y:($get(DTIME,3600)),! . if Y="^" do quit . . write "Delete word from name" . . new % set %=1 do YN^DICN write ! . . if %=1 set result="" . if Y'=result do . . do Write(Name,Y,,1) ;"1=> confirm save . . set result=Y else do . set result=$$Read(Name,,Name) . if result="^" set result="" do Del(Name) . if result="" quit . if ($get(TMGDBABV)=1)&(result'=Name) do . . write Name,"-->",!,result,!," OK" . . new % set %=1 do YN^DICN write ! . . if %=1 quit . . if %=-1 set result="" quit . . if %=2 do . . . write "Delete abbreviation" do YN^DICN write ! . . . if %=1 do Del(Name) set result="" GADone quit result Fix(ShortName,Context) ;"Purpose: To provide a way to fix erroneous abbreviations. ;"Input: ShortName -- the abbreviation to fix. ;" Context -- OPTIONAL. The sentence ShortName is found in. ;"Result: Returns new name after fixing mislinked abbreviations, ;" or 0 for requested retry new Menu,Option set Context=$get(Context) new result set result="" FL1 if Context="" goto FL2 set Menu(0)="Pick Which to Fix" set Menu(1)=ShortName set Menu(2)=Context write # set Option=$$Menu^TMGUSRIF(.Menu,"^") if Option="^" goto FixDone FL2 if (Option=1)!(Context="") do goto:(Context'="") FL1 goto FixDone . set ShortName=$$Fix1(ShortName) . if ShortName'="" set result=ShortName if (Option=2) do goto FixDone . new temp set temp=$$Fix1(Context) . set result=0 if (Option="^") goto FixDone goto FL1 FixDone quit result Fix1(ShortName) ;"Purpose: To provide a way to fix erroneous abbreviations. ;"Input: ShortName -- the abbreviation to fix. ;"Result: Returns new name after fixing mislinked abbreviations. new array,Option new Name,LenCat new result set result="" new max Fix1Loop kill array do ShowLinks(ShortName,,.array) ;"Return Format ;" array(x)=ShortName <-- LongerName[TAB]LongerName^LenCat set max=+$get(array("MAX")) kill array("MAX") set array(0)="Pick item to DELETE" write # set Option=$$Menu^TMGUSRIF(.array,"^") if Option="^" goto Fix1Done set Name=$piece(Option,"^",1) set LenCat=$piece(Option,"^",2) do Del(Name,LenCat,1) goto Fix1Loop Fix1Done new s set s=$get(array(max)) set s=$piece(s,$char(9),2) set s=$piece(s,"^",1) set result=s quit result ShowLinks(ShortName,LenCat,array) ;"Purpose: To show a chain of abbreviations. ;"Input: ShortName -- the abbreviation to check. ;" LenCat -- the category to look in ;" Array -- PASS BY REFERENCE. an OUT PARAMETER. Format ;" array("MAX")=maxCount (e.g. 2) ;" array(1)=ShortName <-- LongerName[TAB]LongerName^LenCat ;" array(2)=ShortName <-- LongerName[TAB]LongerName^LenCat new i set i="" new max set max=$get(array("MAX"),0) new value set value="" if $get(LenCat)="" do . for set i=$order(^TMG("ABBREV",i)) quit:(+i'>0) do . . do ShowLinks(ShortName,i,.array) . set value=$get(^TMG("ABBREV","XREF",ShortName)) else do . set value=$get(^TMG("ABBREV",LenCat,"XREF",ShortName)) if value'="" do . set max=max+1 . write max,". ",ShortName," <-- ",value,! . set array(max)=ShortName_" <-- "_value_$char(9)_value_"^"_$get(LenCat) . set array("MAX")=max . do ShowLinks(value,.LenCat,.array) quit GetDiff(longName,LenCat) ;"Purpose: for a given longName, return what changes for it's abbreviation ;"Input: longName -- the original name to search for ;" LenCat -- OPTIONAL. Default is "ALL" ;"Results: returns difference between longName and its abbreviation, or "" if none. ;"Results: DiffLong1>DiffShort1^pos1>pos2^DiffLong2>DiffShort2^pos1>pos2^... new result set result="" set LenCat=$get(LenCat,"ALL") new shortName set shortName=$$Read(longName,LenCat) if shortName'="" set result=$$GetDiffStr(longName,shortName) quit result GetDiffStr(longName,shortName) ;"Purpose: for a given longName and it's shortname abbreviation, ;" return what changes for it's abbreviation ;"Results: returns difference between longName and shortName, or "" if none. ;"Results: DiffLong1>DiffShort1^pos1>pos2^DiffLong2>DiffShort2^pos1>pos2^... new DiffStr set DiffStr="" ;"if $get(shortName)="" goto GDSDone new longWords,shortWords new DivCh set DivCh=" " if $length(longName,"/")>3 set DivCh="/" do CleaveToArray^TMGSTUTL(longName,DivCh,.longWords) do CleaveToArray^TMGSTUTL(shortName,DivCh,.shortWords) new temp,i set temp=$$DiffWords^TMGSTUTL(.longWords,.shortWords) for do quit:(temp="") . new origS,destNum . set origS=$piece(temp,"^",1) . set temp=$piece(temp,"^",3,999) . if DiffStr'="" set DiffStr=DiffStr_"^" . set DiffStr=DiffStr_origS GDSDone quit DiffStr ScanAbvs(xstr,showProgress) ;"Purpose: scan abbreviations and execute code ;"Input: xstr -- OPTIONAL. m code to execute for each entry.ยด ;" showProgress -- OPTIONAL. if 1, progress bar is shown. ;"Note: The following variables will be defined, for use in xstr: ;" longName,shortName,DiffStr,lenCat new longName,shortName,lenCat,DiffStr set longName="",lenCat="" new Itr ;"for set longName=$order(^TMG("ABBREV",longName),-1) quit:(+longName>0) do set longName=$$ItrAInit^TMGITR($name(^TMG("ABBREV")),.Itr,-1) if $get(showProgress)=1 do PrepProgress^TMGITR(.Itr,20,1,"longName") if longName'="" for do quit:(+$$ItrANext^TMGITR(.Itr,.longName,-1)>0)!(longName="") . new shortName . set shortName=$get(^TMG("ABBREV",longName)) . set DiffStr=$$GetDiffStr(longName,shortName) . if xstr'="" xecute xstr set lenCat=0 for set lenCat=$order(^TMG("ABBREV",lenCat)) quit:(+lenCat'=lenCat) do . if $get(showProgress)=1 write ! . ;"set longName="" . ;"for set longName=$order(^TMG("ABBREV",lenCat,longName),-1) quit:(+longName>0)!(longName="") do . set longName=$$ItrAInit^TMGITR($name(^TMG("ABBREV",lenCat)),.Itr,-1) . if $get(showProgress)=1 do PrepProgress^TMGITR(.Itr,20,1,"longName") . if longName'="" for do quit:(+$$ItrANext^TMGITR(.Itr,.longName,-1)>0)!(longName="") . . new shortName set shortName=$get(^TMG("ABBREV",longName)) . . set DiffStr=$$GetDiffStr(longName,shortName) . . if xstr'="" xecute xstr quit ShowDiff ;"Purpose: scan and show changes new xstr set xstr="write longName,"" --> ["",DiffStr,""] "",shortName,!" do ScanAbvs(xstr,1) quit ScanDel(Text) ;"Purpose: scan for text and allow deletions. new xstr set xstr="if DiffStr[Text do Del(longName,,1)" do ScanAbvs(xstr) quit