TMGSHORT ;TMG/kst/Code to Shorten Names ;03/25/06 ;;1.0;TMG-LIB;**1**;12/23/06 ;" SHORTEN NAMES code ;"Kevin Toppenberg MD ;"GNU General Public License (GPL) applies ;"12-23-2006 ;"======================================================================= ;" API -- Public Functions. ;"======================================================================= ;"ShortNetName(GenericName,TradeName,Strength,Units,MaxLen) ;"$$ShortenArray(Names,Dividers,MaxLen,AllowCut) -- core menus for shortening name ;"$$PShortName(Name,Length,AskUser) -- shorten the drug smartly, using abbreviations ;"$$ShortName(Name,Length,AskUser,DivStr) -- shorten the drug smartly, using abbreviations ;"$$Short2Name(Name,Div1,Div2,.Words,.Dividers) -- Shorten a name to shortest form possible ;"$$Short1Name(Name,MaxLen,Div1,Div2,Words,Dividers) -- An interactive editing of one name ;"$$Cut1Name(Name,MaxLen,Div1,Div2,Words,Dividers) -- A non-interactive cut of one name ;"======================================================================= ;" Private Functions. ;"======================================================================= ;"$$ReadJoin(JoinNum,Len,Words,Dividers) -- read out a phrase of joined words, Len words long ;"SetJoin(JoinNum,Len,Words,Dividers) -- reform the Word and Dividers arrays such that ;" words are joined together. E.g. #1='One' #2='Minute' ==> #1='One Minute' ;"SubDivArray(Words,Dividers,Div1,Div2) -- check and handle if words in Words array need subdivision ;"PackArrays(pNames,pDividers) -- pack the arrays, after items had been deleted. ;"CompArray(Names,Dividers) -- reconstruct the resulting sentence from words in array. ;"AutoShortenArray(.Names,.Dividers,MaxLen,Div1,Div2) -- automatically shorten the words in the array ;"$$CutName(.Names,.Dividers,MaxLen) -- return a non-interactive shortened ('cut') name ;"======================================================================= ;"======================================================================= ShortNetName(GenericName,TradeName,Strength,Units,MaxLen,AllowCut) ;"Purpose: to create a shortened name from parts, not longer than MaxLen ;"Input: GenericName -- Generic portion of name ;" TradeName -- Tradename portion of name ;" Strength -- OPTIONAL Strength portion of name ;" Units -- OPTIONAL units portion of name ;" MaxLen -- the maximum length ;" AllowCut -- OPTIONAL If 1 then name may be cut off with ... to reach target length ;" and user will not be asked for input ;" If 2 then name wil be shortened as far as possible, but it ;" wil not be cut off ;"Result: Returns new shortened name, or "^" for user abort new result,temp set GenericName=$get(GenericName) set TradeName=$get(TradeName) set Strength=$get(Strength) set Units=$get(Units) set MaxLen=$get(MaxLen,16) set AllowCut=$get(AllowCut,0) new Names,Dividers new unitsIdx,GenericIdx set GenericIdx=0,unitsIdx=0 ;"sometimes 'Trade Name' is actually an expanded form of the Generic name ;"e.g. ACETAZOLAMIDE (ACETAZOLAMIDE CAP USP) 250 ;"In these cases I will delete the duplication SNN0 if $extract(TradeName,1,$length(GenericName))=GenericName set GenericName="" if (TradeName="")!(GenericName="") do . new i set i=0 . if TradeName'="" set i=i+1,Names(i)=TradeName,Dividers(i)=" " . if GenericName'="" set i=i+1,Names(i)=GenericName,Dividers(i)=" ",GenericIdx=i . ;"set Names(i)=TradeName,Dividers(i)=" ",i=i+1 . if Strength'="" set i=i+1,Names(i)=Strength,Dividers(i)=" " . if Units'="" set i=i+1,Names(i)=Units,unitsIdx=i,Dividers(i)="" . set Names("MAXNODE")=i,Dividers("MAXNODE")=i else do . new i set i=0 . set i=i+1,Names(i)=TradeName,Dividers(i)=" (" . set i=i+1,Names(i)=GenericName,GenericIdx=i,Dividers(i)=") " . ;"set i=i+1,Names(i)=GenericName,GenericIdx=i,Dividers(i)=" (" ;changed 10-30-07 . ;"set i=i+1,Names(i)=TradeName,Dividers(i)=") " . if Strength'="" set i=i+1,Names(i)=Strength,Dividers(i)=" " . if Units'="" set i=i+1,Names(i)=Units,unitsIdx=i,Dividers(i)="" . set Names("MAXNODE")=i,Dividers("MAXNODE")=i for i=1:1:Names("MAXNODE")-1 do ;"don't cleave units (e.g. MG/ML) . set:(i>1) Names(i)=$translate(Names(i),"/","|") do SubDivArray(.Names,.Dividers," ","/") set result=$$ShortenArray(.Names,.Dividers,MaxLen,AllowCut) if result=0 kill Names,Dividers goto SNN0 ;"honor requested retry ;"If shortening required "...", see if removing parts of name allow goal. if (AllowCut=1)&(result["...") do SNN1 . ;"try removing units first . kill Names(unitsIdx),Dividers(unitsIdx) . do PackArrays("Names","Dividers") . set result=$$ShortenArray(.Names,.Dividers,MaxLen,AllowCut) . if result'["..." quit . if GenericIdx'=0 do . . kill Names(GenericIdx) . . if Dividers(GenericIdx)=" (" set Dividers(GenericIdx+1)=" " . . kill Dividers(GenericIdx) . . do PackArrays("Names","Dividers") . . set result=$$ShortenArray(.Names,.Dividers,MaxLen,AllowCut) . if result'["..." quit . ;"more later... ? SNNDone set result=$$Trim^TMGSTUTL(result) if $extract(result,1,1)="(" do ;"Input transform doesn't allow first chart to be '(' . ;"NOTE: I should write better code to change only the LAST ) to "", i.e. not cut out ALL ()'s . set result=$translate(result,"(","") . set result=$translate(result,")","") if (result[")")&(result'["(") set result=$translate(result,")","") set result=$translate(result,"|","/") quit result ShortenArray(Names,Dividers,MaxLen,AllowCut) ;"Purpose: shorten name ;"Input: Names -- PASS BY REFERENCE. An array containing the words ;" Dividers -- PASS BY REFERENCE. An array containing the bits between words ;" MaxLen -- OPTIONAL. Default=1. The length that words must fit within ;" AllowCut -- OPTIONAL. Default=0. Set 1 if automatic shortening is allowed. ;" If 1, MaxLen value SHOULD BE supplied ;" If 2 then name wil be shortened as far as possible, but it ;" wil not be cut off. User will not be asked. ;"Result: returns the shortened name, or "^" for abort, or 0 for requested retry. new result set result="" set MaxLen=$get(MaxLen,1) set AllowCut=$get(AllowCut,0) new UserAsked set UserAsked=0 new StartOver set StartOver=0 new OrigName set OrigName=$$CompArray(.Names,.Dividers) ;"First try a non-interactive shortening set result=$$AutoShortenArray(.Names,.Dividers,MaxLen,"/"," ") if (AllowCut'=1)&(result["...") goto SNA0 if $length(result)'>MaxLen goto SNA1Done SNA0 if AllowCut=1 set result=$$CutName(.Names,.Dividers,MaxLen) goto SNA1Done if AllowCut=2 set result=$$CompArray(.Names,.Dividers) goto SNA1Done SNA1 if result=0 goto SNA2Done ;"requesting retry. set result=$$Trim^TMGSTUTL($$CompArray(.Names,.Dividers)) if $length(result)'>MaxLen goto SNA1Done write OrigName,"-->",! write "Current Name:",! write result,! if MaxLen>1 do . new tempS set tempS="Shorten to ---> |" . for i=1:1:MaxLen-$length(tempS) write " " . write tempS . for i=1:1:$length(result)-MaxLen write "x" . write ! write "-----------------------",! for i=1:1:Names("MAXNODE") do . if $get(Names(i))="" quit . write i,". ",Names(i) . new temp set temp=$$GetAbvr^TMGABV(Names(i),0) . if (temp'="")&(temp'=Names(i)) write " (<-- Quick Fix: ",temp,")" . write ! write "-----------------------",! write " # (or #-#) -- Shorten name(s) Q# (or #-#) -- Use Quick FiX",! write " S# -- Sub-edit name T -- Free text for ALL",! write " S?# -- Sub-edit name (ask for divider character)",! write " Sx# -- Sub-edit name (use any character (i.e. replace 'x') as divider)",! write " J# -- Join word # to word #+1 F# -- Fix erroneous abbrev",! write " D# (or D#-#) -- Delete # X# -- Kill Quick Fix",! write " ! -- toggle debug mode ",$select(($get(TMGDBABV)=1):"OFF",1:"ON"),! write " C -- cut to: ",$$CutName(.Names,.Dividers,MaxLen),! ;"write " ^^ -- Abort",! write "(^ to quit, ^^ to abort): ^//" set UserAsked=1 read temp:$get(DTIME,3600),! set temp=$$UP^XLFSTR(temp) if temp="" set temp="^" do goto SNA1Done . set result=$$CompArray(.Names,.Dividers) if temp="^^" set result="^" goto SNA2Done if temp="C" set AllowCut=1 goto SNA0 if "S"[$extract(temp,1) do . new num1,s . new nodeDiv set nodeDiv=" " . set s=$extract(temp,2) . if +s'=s do quit:(nodeDiv="^") . . if s="?" do quit:(nodeDiv="^") . . . write "Enter character that divides words (e.g. '/' ',' '|' ';' ' ' etc.)",! . . . read "Divider character? ' '// ",nodeDiv,! . . . if nodeDiv="" set nodeDiv=" " . . else set nodeDiv=s . . set num1=+$extract(temp,3,99) . else set num1=+$extract(temp,2,99) . if num1=0 read "Enter NUMBER of name to edit: ",num1:$get(DTIME,3600),! . set num1=+num1 . if (num1'>0)!(num1>Names("MAXNODE")) quit . new temp set temp=$$Short1Name(Names(num1),$length(Names(num1))-1,nodeDiv) . if (temp="^")!(temp="")!(temp=Names(num1)) quit . do Write^TMGABV(Names(num1),temp,,1) ;"1=> confirm . set Names(num1)=temp if temp="T" do goto SNA1Done TX1 . write "Enter text for ENTIRE name (combining all shown parts) (^ to abort):",! . read "> ",input:$get(DTIME,3600),! . if input="^" quit . ;"kill Words,Dividers . kill Names,Dividers . ;"set Words(1)=input,Words("MAXNODE")=1,Dividers(1)="" . set Names(1)=input,Names("MAXNODE")=1,Dividers(1)="" if "J"[$extract(temp,1) do . new JoinNum . set JoinNum=+$extract(temp,2,99) . if JoinNum'>0 read "Enter # to join: ",JoinNum:$get(DTIME,3600),! . if +JoinNum'>0 quit . ;"if JoinNum=Words("MAXNODE") do quit . if JoinNum=Names("MAXNODE") do quit . . write "Enter the # of the FIRST word to be joined.",! JL1 . ;"do SetJoin(JoinNum,2,.Words,.Dividers) . do SetJoin(JoinNum,2,.Names,.Dividers) if (temp="D")!(temp?1"D".N)!(temp?1"D".N1"-".N) do goto SNA1 JL2 . new delNum,delNum2,i . set temp=$extract(temp,2,99) . ;"if Words("MAXNODE")=1 set delNum=1,delNum2=1 . if $get(Names("MAXNODE"))=1 set delNum=1,delNum2=1 . else do . . set delNum=+$piece(temp,"-",1) . . set delNum2=+$piece(temp,"-",2) . . if delNum20 quit . . read "Enter # (or #-#) to delete: ",temp:$get(DTIME,3600),! . . set delNum=+$piece(temp,"-",1) . . set delNum2=+$piece(temp,"-",2) . . if delNum20 kill Words(i),Dividers(i) . . if +i>0 kill Names(i),Dividers(i) . ;"do PackArrays("Words","Dividers") . do PackArrays("Names","Dividers") if "X"[$extract(temp,1) do . new delNum . ;"if Words("MAXNODE")=1 set delNum=1 . if Names("MAXNODE")=1 set delNum=1 . else do . . set delNum=+$extract(temp,2,99) . . if delNum>0 quit . . read "Enter # of Quick Fix to delete: ",delNum:$get(DTIME,3600),! . ;"if +delNum>0 do Del^TMGABV(Words(delNum)) . if +delNum>0 do Del^TMGABV(Names(delNum)) if (temp?.N)!(temp?.N1"-".N) do goto SNA1 . new num1,num2 . set num1=+$piece(temp,"-",1) . set num2=+$piece(temp,"-",2) . if num2=0 set num2=num1 . new tempS set tempS="" . for i=num1:1:num2 set tempS=tempS_Names(i)_" " . set tempS=$$Trim^TMGSTUTL(tempS) . set tempS=$$GetAbvr^TMGABV(tempS,1) . for i=num1+1:1:num2 kill Names(i) . for i=num1:1:(num2-1) kill Dividers(i) . set Names(num1)=tempS . do PackArrays("Names","Dividers") if (temp="Q")!(temp?1"Q".N)!(temp?1"Q".N1"-".N) do goto SNA1 . new num1,num2 . set num1=+$extract(temp,2,99) . if num1=0 do quit:(+num1=0) . . read "Enter NUMBER(S) of Quick Fix to use: ",temp:$get(DTIME,3600),! . . set num1=+$piece(temp,"-",1) . . set num2=+$piece(temp,"-",2) . if +$get(num2)=0 set num2=num1 . for i=num1:1:num2 do . . set Names(i)=$$GetAbvr^TMGABV(Names(i),0) if (temp="F")!(temp?1"F"1N) do goto SNA1 . new num1 set num1=+$extract(temp,2,99) . if num1=0 do quit:(+num1=0) . . read "Enter NUMBER of abbreviation to fix: ",temp:$get(DTIME,3600),! . . set num1=+temp . new s set s=$$Fix^TMGABV(Names(num1),OrigName) . if s=0 set result=0 quit ;"signal retry . set Names(num1)=s . if Names(num1)="" do . . kill Names(num1) . . ;"do PackArrays("Words","Dividers") . . do PackArrays("Names","Dividers") if (temp="!") do goto SNA1 JL5 . if $get(TMGDBABV)=1 kill TMGDBABV . else set TMGDBABV=1 . set result=0 ;"signal request for retry. goto SNA1 SNA1Done set result=$$Trim^TMGSTUTL(result) SNA2Done if (UserAsked=1)&(+result'=0) write "Using: ",result,! quit result ReadJoin(JoinNum,Len,Words,Dividers) ;"Purpose: To read out a phrase of joined words, Len words long ;"Input: JoinNum -- the index in Words where joining begins ;" Len -- the length to return. e.g. 2 --> two words joined ;" Words -- PASS BY REFERENCE. Array holding words ;" Dividers -- PASS BY REFERENCE. Array holding dividers between words ;"Results: returns string of joined words new result set result="" if (JoinNum+Len-1)>Words("MAXNODE") goto RJDone set result=$get(Words(JoinNum)) new i for i=JoinNum:1:(JoinNum+Len-2) do . set result=result_Dividers(i)_$get(Words(i+1)) RJDone quit result SetJoin(JoinNum,Len,Words,Dividers) ;"Purpose: To reform the Word and Dividers arrays such that words are ;" joined together. E.g. #1='One' #2='Minute' ==> #1='One Minute' ;"Input: JoinNum -- the index in Words where joining begins ;" Len -- the length to return. e.g. 2 --> two words joined ;" Words -- PASS BY REFERENCE. Array holding words ;" Dividers -- PASS BY REFERENCE. Array holding dividers between words ;"Results: None new temp set temp=$$ReadJoin^TMGSHORT(JoinNum,Len,.Words,.Dividers) new i for i=JoinNum:1:(JoinNum+Len-1) do . if i'=JoinNum kill Words(i) . if i'=(JoinNum+Len-1) kill Dividers(i) set Words(JoinNum)=temp do PackArrays("Words","Dividers") quit Short1Name(Name,MaxLen,Div1,Div2,Words,Dividers) ;"Purpose: An interactive editing of one name ;"Input: Name -- the name (string) to shorten. ;" MaxLen -- OPTIONAL. The Max length of the string. ;" Div1 -- OPTIONAL. The first character used to separate words. Default is " " ;" Div2 -- OPTIONAL. The second character used to separate words. Default is "/" ;" Words -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER. Returns Name divided up into words ;" Dividers -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER. Returns dividers between words ;"Results: returns shortened name, or "^" for user abort set Div1=$get(Div1," ") set Div2=$get(Div2) S1N0 do CleaveToArray^TMGSTUTL(Name,Div1,.Words) for i=1:1:Words("MAXNODE") set Dividers(i)=Div1 set Dividers(Words("MAXNODE"))="" if Div2'="" do SubDivArray(.Words,.Dividers,Div1,Div2) set result=$$ShortenArray^TMGSHORT(.Words,.Dividers,MaxLen,0) if result=0 kill Words,Dividers goto S1N0 quit result Cut1Name(Name,MaxLen,Div1,Div2,Words,Dividers) ;"Purpose: A non-interactive cut of one name ;"Input: Name -- the name (string) to shorten. ;" MaxLen -- The length of the string to cut to. ;" Div1 -- OPTIONAL. The first character used to separate words. Default is " " ;" Div2 -- OPTIONAL. The second character used to separate words. Default is "/" ;" Words -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER. Returns Name divided up into words ;" Dividers -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER. Returns dividers between words ;"Results: returns cut name set Div1=$get(Div1," ") set Div2=$get(Div2) do CleaveToArray^TMGSTUTL(Name,Div1,.Words) for i=1:1:Words("MAXNODE") set Dividers(i)=Div1 set Dividers(Words("MAXNODE"))="" if Div2'="" do SubDivArray(.Words,.Dividers,Div1,Div2) set result=$$CutName(.Words,.Dividers,MaxLen) quit result Short2Name(Name,Div1,Div2,Words,Dividers,Category) ;"Purpose: Shorten a name, using abbreviations etc. to shortest form possible ;" Will separate name into individual words, separated by spaces ;" and try to abbreviate each one. ;"Input: Name -- name to shorten ;" Div1 -- OPTIONAL. The first character used to separate words. Default is " " ;" Div2 -- OPTIONAL. The second character used to separate words. Default is "/" ;" Words -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER. Returns Name divided up into words ;" Dividers -- OPTIONAL. PASS BY REFERENCE, an OUT PARAMETER. Returns dividers between words ;" Category -- OPTIONAL. a category to look for phrases in ;"Result: returns a shortened form of name ;"Note: no testing of length done. ;"Note: this function is NOT interactive with the user ;"Note: This functions should be called repetatively,using the output from ;" the last run as the input for the next run, until there is not further ;" change, to get the best results. new temp,result,i set result="" if $get(Name)="" goto SN2Don2 set result=$$GetAbvr^TMGABV(Name,0) if (result'="")&(result'=Name) goto SN2Done set Div1=$get(Div1," ") if Div1="" set Div1="@@@@" set Div2=$get(Div2,"/") if Div2="" set Div2="@@@@" kill Words,Dividers do CleaveToArray^TMGSTUTL(Name,Div1,.Words) for i=1:1:Words("MAXNODE") set Dividers(i)=Div1 set Dividers(Words("MAXNODE"))="" ;"//kt added 10/27/06 ;"Note: This purposefully does not keep rechecking for ever shortening ;" Abreviations (or abrv of abrv's) so that the calling function ;" can concat the results from this onto others and determine a ;" total length, and then recall if needed. new count set count=Words("MAXNODE") for i=1:1:count do . new temp,temp2 . if Words(i)[Div2 set temp=$$Short2Name(Words(i),Div2) . else set temp=$$GetAbvr^TMGABV(Words(i),0) . set Words(i)=temp ;"Now look for double word matches set Category=$get(Category,0) SNL0 for i=1:1:count do . new temp,temp2 . set temp=$$ReadJoin^TMGSHORT(i,2,.Words,.Dividers) . set temp2=$$GetAbvr^TMGABV(temp,Category) . if (temp2'="")&(temp'=temp2) do SNL1 . . ;"write "Found double word match: ",temp,"-->",temp2,! . . do SetJoin^TMGSHORT(i,2,.Words,.Dividers) . . set Words(i)=temp2 . . ;"zwr Words(*) . . set i=0,count=Words("MAXNODE") set result=$$CompArray(.Words,.Dividers) SN2Done set result=$$Trim^TMGSTUTL(result) if (Name'=result) do Write^TMGABV(Name,result) SN2Don2 quit result SubDivArray(Words,Dividers,Div1,Div2) ;"Purpose: To see if any words in Words array needs to be subdivided, ;" and to handle if needed. ;"Input: Words -- PASS BY REFERENCE. Array of words ;" Dividers -- PASS BY REFERENCE. Array of dividing parts ;" Div1 -- the first division character, e.g. "/" or " " ;" Div2 -- the second division character, e.g. " " or "/" ;"Results: none new i for i=1:1:Words("MAXNODE") do . if Words(i)[Div2 do . . new tempWords,j . . do CleaveToArray^TMGSTUTL(Words(i),Div2,.tempWords) . . for j=1:1:tempWords("MAXNODE") do . . . set Words(+(i_"."_j))=tempWords(j) . . . if j'=tempWords("MAXNODE") set Dividers(+(i_"."_j))=Div2 . . . else set Dividers(+(i_"."_j))=Div1 . . kill Words(i),Dividers(i) do PackArrays("Words","Dividers") quit PackArrays(pNames,pDividers) ;"Purpose: to pack the arrays, after items had been deleted. ;"Input: Names -- PASS BY NAME. Array of words ;" Dividers -- PASS BY NAME. Array of dividing parts ;"Result: none do ListPack^TMGMISC(pNames) do ListPack^TMGMISC(pDividers) set @pNames@("MAXNODE")=$$ListCt^TMGMISC(pNames) set @pDividers@("MAXNODE")=$$ListCt^TMGMISC(pDividers) quit CompArray(Names,Dividers) ;"Purpose: to reconstruct the resulting sentence from words in array. ;"Input: Names -- PASS BY REFERENCE. Array of words ;" Dividers -- PASS BY REFERENCE. Array of dividing parts ;"Result: returns the compiled result new result,j set result="" for j=1:1:Names("MAXNODE") do . set result=result_Names(j) . if Names(j)'="" set result=result_Dividers(j) quit result AutoShortenArray(Names,Dividers,MaxLen,Div1,Div2) ;"Purpose: To automatically shorten the words in the array ;"Input: Names -- PASS BY REFERENCE. Array of words ;" Dividers -- PASS BY REFERENCE. Array of dividing parts ;" Div1 -- the first division character, e.g. "/" or " " ;" Div2 -- the second division character, e.g. " " or "/" new result,newName,changeMade set result="" new temp set temp=$$CompArray(.Names,.Dividers) set result=$$GetAbvr^TMGABV(temp,0) if result="^" set result="" do Del^TMGABV(temp) if (result'="")&($length(result)'>MaxLen) goto ASADone for do quit:(changeMade=0)!($length(result)'>MaxLen) . set changeMade=0 . for i=1:1:Names("MAXNODE") do . . set newName=$$Short2Name(Names(i),.Div1,.Div2) . . ;"there was a loop where a name was repeatitively being replace with longer names --> crash . . if (newName'=Names(i))&($length(newName)<$length(Names(i))) do . . . set Names(i)=newName . . . set changeMade=1 . set result=$$CompArray(.Names,.Dividers) ASADone quit result CutName(Names,Dividers,MaxLen) ;"Purpose: To return a non-interactive shortened ('cut') name ;"Input: Names - PASS BY REFERENCE. As created in ShortNetName ;" This is an array with the various words in the name ;" Dividers -- PASS BY REFERENCE As created in ShortNetName ;" This is an array with the spaces or punctiation separating words ;" MaxLen -- The target length for result ;"Result: returns the shortened name new partA,partB,Max,i,lenA new result set Max=$get(Names("MAXNODE")) if Max'>3 do goto CutDone . set result=$$CompArray(.Names,.Dividers) . set result=$extract(result,1,MaxLen) set partB=$get(Dividers(Max-3)) for i=Max-2:1:Max do . set partB=partB_Names(i) . if Names(i)'="" set partB=partB_Dividers(i) set partB=$$Trim^TMGSTUTL(partB) set partA="" for i=1:1:Max-3 set partA=partA_Names(i) set:(i<(Max-3))&(Names(i)'="") partA=partA_Dividers(i) new allowedALen set allowedALen=MaxLen-$length(partB) set lenA=$length(partA) if lenA>allowedALen do . set allowedALen=allowedALen-4 . if lenA=0 set partA="" quit . if (allowedALen/lenA)<0.4 set partA="" quit . if allowedALen<4 set partA="" quit . set partA=$extract(partA,1,allowedALen)_"... " set result=$$Trim^TMGSTUTL(partA_partB) if $length(result)>MaxLen do . if partA="" do . . set partB="" ;"$get(Dividers(Max-2)) . . for i=Max-1:1:Max do . . . set partB=partB_Names(i) . . . if Names(i)'="" set partB=partB_Dividers(i) . . set partB=$$Trim^TMGSTUTL(partB) . . set partA=Names(Max-2) . . new allowedALen set allowedALen=MaxLen-$length(partB)-4 . . set partA=$extract(partA,1,allowedALen)_"... " . . set result=partA_partB . else set result=$extract(result,1,MaxLen) CutDone quit result PShortName(Name,Length,AskUser) ;"Purpose: To shorten the drug smartly, using abbreviations ;" This function differs from ShortName (see below) because it smartly ;" 'P'icks whether to use '/' or ' ' as a divider str. ;"Input: Name -- the drug name to shorten ;" Expected format is that found in file 50.6 field .01, ;" i.e. INGREDIENT/INGREDIENT/INGREDIENT... ;" Length -- The desired string length ;" AskUser -- OPTIONAL. Default=0. ;" If 1 then user is asked to supply abreviations if needed. ;" If 2 then name is shortened as much as possible, but it ;" might be longer than Length, it is not cut, and user is ;" not asked. ;"Result : returns shortened name, "^" for abort. new DivStr,result if $length(Name,"/")>2 set DivStr="/" else set DivStr=" " set result=$$ShortName(.Name,.Length,.AskUser,DivStr) quit result ShortName(Name,Length,AskUser,DivStr) ;"Purpose: To shorten the drug smartly, using abbreviations ;"Input: Name -- the drug name to shorten ;" Expected format is that found in file 50.6 field .01, ;" i.e. INGREDIENT/INGREDIENT/INGREDIENT... ;" Length -- The desired string length ;" AskUser -- OPTIONAL. Default=0. ;" If 1 then user is asked to supply abreviations if needed. ;" If 2 then name is shortened as much as possible, but it ;" might be longer than Length, it is not cut, and user is ;" not asked. ;" DivStr -- the divider that separates parts. Default="/" ;"Result : returns shortened name, "^" for abort. new temp,Words,Dividers set AskUser=$get(AskUser,0) set DivStr=$get(DivStr,"/") if Name="" set temp="^" goto SNDone set temp=$$Read^TMGABV(Name,Length) if (temp'="")&($length(temp)'>Length) goto SNDone ;"Note: $$ShortName does NOT check length new oldTemp,done set temp=Name,done=0 for do quit:done!($length(temp)'>Length) . set oldTemp=temp . set temp=$$Short2Name(temp,DivStr,"",.Words,.Dividers,Length) . if temp=oldTemp set done=1 quit . if ($length(temp)'>Length) set done=1 ;"don't quit yet . if (temp["...")&(AskUser=1) write !,"Remove '...' from name",! set done=0 if (($length(temp)>Length)&(AskUser=1)) do SNm0 . new killthis set killthis=0 . write "IEN 50.6=",$get(IEN50d6,"?")," IEN 50.606=",$get(IEN50d606,"?") . write " Dose=",$get(Dose,"?")," IEN 50=",$get(IEN50,"?"),! . write Name,! SNm1 . set temp=$$Short1Name(temp,Length,DivStr,"",.Words,.Dividers) . if (temp'="")&(temp'="^")&(temp'=Name) do . . do Write^TMGABV(Name,temp,Length,(AskUser=1)) . write ! if ($length(temp)>Length)&(AskUser'=2) do . if ($data(Words)=0)!($data(Dividers)=0) do quit . . set temp=$extract(temp,1,Length) . set temp=$$CutName(.Words,.Dividers,Length) SNDone if $extract(temp,1)="/" set temp=$extract(temp,2,Length) quit temp