LEXXMC ;ISL/KER - Convert Text to Mix Case ;10/10/2017
;;2.0;Lexicon Utility;**103,114**;Sep 23, 1996;Build 1
;
; Global Variables
; ^LEX(757.07 SACC 1.3
;
; External References
; None
;
; Replaces Integrated Control Registration #5781 $$MIX^LEXXM(X)
; (released in LEX*2.0*80, Jun 17, 2014) which converts UPPERCASE
; to Mix Case Text.
;
; Old API New API
; $$MIX^LEXXM(X) $$MIX^LEXXMC(X)
; Hard Coded Rules Database of Rules
; Extremely hard to update Update in Quarterly patch
; Rules in LEXXM* Rules in ^LEX(757.07)
;
; The old API $$MIX^LEXXM will be re-directed to $$MIX^LEXXMC
;
MIX(TEXT) ; Mixed Case Expression
;
; Input
;
; TEXT Text, any case (Required)
;
; Output
;
; $$MIX Text, Mixed Case
;
N AAA,ABR,AFTER,AR,ARRAY,ARY,ASC,BEFORE,C,CAS,CC,CCTR,CH,CHR,COND,CT,CTL,CUR,DIFF,EXEC,EXP,FULL,HA,HN,I,L,LD,LEX,LEX2
N LEXR1,LEXR2,LEXT,LEXW,ND,NPT,NXT,OIEN,ORG,OUT,P1,P2,PC,PPT,PRE,PS,PSN,REP,RP,RUL,RULE,S,SPC,ST,TA,TC,TEST,TIEN,TK
N TKN,TOKEN,TR,TRUE,TXT,UEX,WI,WIT,WT,X,Y K:$D(TOKEN) RULE,FULL Q:'$L($G(TEXT)) ""
S TEXT=$$DBLS($TR($G(TEXT),"""","'")),TEXT=$$CTL($G(TEXT)),TEXT=$$SPELL(TEXT),(ORG,EXP)=$$IEEG($G(TEXT))
I '$L($G(EXP)) S TEXT=ORG Q $TR(TEXT,"""","'")
; Save Before Expression
S BEFORE=ORG,UEX=$$UP(ORG)
; Parse
K TA D PR(EXP,.TA)
; Loop through Words
S TC=0 F S TC=$O(TA(TC)) Q:+TC'>0 D
. N CUR,CTL,PRE,NXT,PPT,NPT,TIEN,TRUE S TRUE=0
. ; Current Word
. S CUR=$G(TA(TC)),CTL=$$UP(CUR) Q:'$L(CTL)
. ; Previous Word
. S PRE=$G(TA((TC-1)))
. ; Next Word
. S NXT=$G(TA((TC+1)))
. ; Previous Punctuation
. S PPT=$O(TA((TC-1),"B"," "),-1)
. S PPT=$S(+PPT>0:$G(TA((TC-1),"B",+PPT)),1:"")
. ; Special condition for the letter S and ' or (
. S:CTL="S" PPT=$G(TA((TC-1),"B",1))
. ; Next Punctuation
. S NPT=$G(TA(TC,"B",1))
. ; Token IEN
. S TIEN=$O(^LEX(757.07,"B",CTL,0))
. ; Token not found, use mask/mix case
. I '$D(^LEX(757.07,"B",CTL))!(TIEN'>0) D Q
. . D TOK S:+($G(TRUE))>0&($L($G(OUT))) TA(TC)=OUT S:+($G(TRUE))'>0 TA(TC)=$$MX(CUR)
. D DSP1
. I +($G(TRUE))'>0,+($G(TIEN))>0 D
. . ; Loop through Rules
. . N AAA,OIEN,OUT S OUT=CUR
. . S (OIEN,TRUE)=0 F S OIEN=$O(^LEX(757.07,TIEN,1,OIEN)) Q:OIEN'>0 Q:TRUE>0 D Q:TRUE>0
. . . Q:+($G(TRUE))>0 N COND,CCTR,CAS,SPC S CCTR=0
. . . S CAS=$P($G(^LEX(757.07,+TIEN,1,+OIEN,0)),"^",2)
. . . S SPC=$P($G(^LEX(757.07,+TIEN,1,+OIEN,0)),"^",3)
. . . S:$G(CAS)="S" TA(TC,"S")=""
. . . ; 1st Condition - Based on Expression
. . . D EXP Q:+($G(TRUE))>0
. . . ; 2nd Condition - Based on Previous Word
. . . D PRE Q:+($G(TRUE))>0
. . . ; 3rd Condition - Based on Next Word
. . . D NXT Q:+($G(TRUE))>0
. . . ; No Conditions
. . . D NON Q:+($G(TRUE))>0
. . . ; Token
. . . D TOK Q:+($G(TRUE))>0
. . ; Default Mix Case
. . S:TRUE'>0&(OUT=CUR) OUT=$$MX(CUR)
. . D DSP4("END")
. . S TA(TC)=OUT
; Special Conditions - Pre-Assmebly
D PREA
; Assemble After Expression
D ASEM,DSP2
S TEXT=$G(AFTER) S:'$L(TEXT) TEXT=ORG S TEXT=$$PS(TEXT)
Q $TR(TEXT,"""","'")
;
EXP ; Expression Rules
;
; Example: If an expression contains the words "OPERATING
; ROOM" then the word "OR" will be in uppercase.
Q:'$L($G(CUR)) Q:'$L($G(CAS)) Q:'$L($G(SPC)) Q:+($G(TIEN))'>0 Q:+($G(OIEN))'>0 Q:'$L($G(EXP))
N COND S COND=$G(^LEX(757.07,+($G(TIEN)),1,+($G(OIEN)),1)) S:$L(COND) CCTR=+($G(CCTR))+1
I $L($G(EXP)),$L(COND) D Q:+($G(TRUE))>0
. N EXEC,X S X=$$UP($G(EXP)) X COND S TRUE=$T
. I +($G(TRUE))>0 S OUT=$$CAS($G(CUR),$G(CAS),$G(SPC))
. D DSP3("EXP")
Q
;
PRE ; Previous Word Rules
;
; Example: If the previous word is numeric or "PER"
; then the word "OZ" will be in lower case.
Q:'$L($G(CUR)) Q:'$L($G(CAS)) Q:'$L($G(SPC)) Q:+($G(TIEN))'>0 Q:+($G(OIEN))'>0 Q:'$L(($G(PRE)_$G(PPT)))
N COND S COND=$G(^LEX(757.07,+($G(TIEN)),1,+($G(OIEN)),2)) S:$L(COND) CCTR=+($G(CCTR))+1
I $L($G(PRE)),$L(COND) D Q:TRUE>0
. N EXEC,X S X=$$UP($G(PRE)) X COND S TRUE=$T
. I +($G(TRUE))>0 S OUT=$$CAS($G(CUR),$G(CAS),$G(SPC))
. D DSP3("PRE")
I $L($G(PPT)),$L(COND) D Q:TRUE>0
. N EXEC,X S X=$G(PPT) X COND S TRUE=$T
. I +($G(TRUE))>0 S OUT=$$CAS($G(CUR),$G(CAS),$G(SPC))
. D DSP3("PPT")
Q
;
NXT ; Next Word Rules
;
; Example: If the next word contains "POSITIVE" or
; "NEGATIVE" then the word "ABL" will be
; in uppercase.
Q:'$L($G(CUR)) Q:'$L($G(CAS)) Q:'$L($G(SPC)) Q:+($G(TIEN))'>0 Q:+($G(OIEN))'>0
N COND S COND=$G(^LEX(757.07,+($G(TIEN)),1,+($G(OIEN)),3)) S:$L(COND) CCTR=+($G(CCTR))+1
Q:'$L(($G(NXT)_$G(NPT))) I $L($G(NXT)),$L(COND) D Q:TRUE>0
. N EXEC,X S X=$$UP($G(NXT)) X COND S TRUE=$T
. I +($G(TRUE))>0 S OUT=$$CAS($G(CUR),$G(CAS),$G(SPC))
. D DSP3("NXT")
I $L($G(NPT)),$L(COND) D Q:TRUE>0
. N EXEC,X S X=$G(NPT) X COND S TRUE=$T
. I +($G(TRUE))>0 S OUT=$$CAS($G(CUR),$G(CAS),$G(SPC))
. D DSP3("NPT")
Q
;
NON ; No Rules (default)
;
; Example: If the rules for the expression, the previous
; word and the next word fail (false) and there
; is a default case value then that case will
; be used.
;
; U UPPERCASE COPD
; L lower case between
; M Mixed Case Diabetes
; S Special Case IgE
Q:+($G(TRUE))>0 Q:+($G(CCTR))>0 Q:'$L($G(CUR)) Q:'$L($G(CAS)) Q:'$L($G(SPC))
N EXEC S OUT=$$CAS($G(CUR),$G(CAS),$G(SPC))
S TRUE=1 D DSP3("NON")
Q
;
TOK ; Token/Word Rules
;
; Examples: If a word is an ordinal number (1st, 2nd, etc.)
; then the word will be in lower case.
;
; If a word is alpha numeric then the word will
; be in upper case.
;
; If a word is preceded or followed by a dash "-"
; then the word will be upper case.
Q:+($G(TRUE))>0 Q:'$L($G(CUR))
N AAA,CAS,COND,OIEN,SPC,TIEN,HA,HN,CH S (HA,HN)=0,AAA=$$RP("*",$L(CUR)) Q:AAA'["*"
F CH=1:1:$L(CUR) S:$E(CUR,CH)?1A HA=1 S:$E(CUR,CH)?1N HN=1
S TIEN=$O(^LEX(757.07,"B",AAA,0)) I TIEN'>0,HA>0,HN>0 S OUT=$$UP(CUR),TRUE=1 Q
Q:TIEN'>0 S (TRUE,OIEN)=0
F S OIEN=$O(^LEX(757.07,TIEN,1,OIEN)) Q:+OIEN'>0 Q:TRUE>0 D Q:TRUE>0
. N COND,CAS,EXEC,SPC S CAS=$P($G(^LEX(757.07,+TIEN,1,+OIEN,0)),"^",2),SPC=$P($G(^LEX(757.07,+TIEN,1,+OIEN,0)),"^",3)
. S COND=$G(^LEX(757.07,+TIEN,1,+OIEN,1)),X=$$UP(CUR)
. I $L(COND) X COND S TRUE=$T
. I TRUE>0 S OUT=$$CAS(CUR,CAS,SPC)
. D DSP3("TOK")
Q
; Displays used for testing Case Rules
DSP1 ; Display Components
Q:'$D(TEST) Q:$D(TOKEN) Q:$D(ARRAY) Q:'$D(FULL)
W !!,"CUR: ",$G(CUR),!,"PRE: ",$G(PRE),!,"NXT: ",$G(NXT),!,"PPT: ",$G(PPT),!,"NPT: ",$G(NPT) N FULL,DIFF,ARRAY
Q
DSP2 ; Display Changes (Differences)
Q:'$D(TEST) N EXEC I $D(FULL),$D(ARRAY) D
. N AR S AR="TA(0)" F S AR=$Q(@AR) Q:'$L(AR)!($E(AR,1,2)'="TA") W AR,"=",@AR,!
I '$D(DIFF),'$D(ARRAY) W !!,"Before: ",BEFORE,!,"After: ",AFTER
I $D(DIFF),'$D(ARRAY),BEFORE'=AFTER W !!,"Before: ",BEFORE,!,"After: ",AFTER
W:$D(ARRAY) !,AFTER N ARRAY,DIFF,FULL,TEST
Q
DSP3(X) ; Display Conditions #1
Q:'$D(TEST) Q:'$D(RULE) Q:$D(TOKEN)
W !!,"X: ",$G(X),!,"CUR: ",$G(CUR),!,"CAS: ",$G(CAS),!,"SPC: ",$G(SPC),!,"TRUE: ",$G(PPT),!,"OUT: ",$G(OUT),!
N TEST,RULE,TOKEN
Q
DSP4(X) ; Display Conditions #2
Q:'$D(TEST) Q:'$D(RULE) Q:$D(TOKEN) W !!,"X: ",$G(X),!,"TRUE: ",$G(PPT),!,"OUT: ",$G(OUT),!
N TEST,RULE,TOKEN
Q
;
; Spelling
SPELL(X) ; Known Spelling Errors
F Y="Pe-ripheral^Peripheral","us-ing^using","Intralu-minal^Intraluminal","Ap-proach^Approach","Endo-scopic^Endoscopic" S:$$SP(X,Y)>0 X=$$SW(X,Y)
F Y="Technolo-gy^Technology","CR (E)St^CREST","CR(E)St^CREST" S:$$SP(X,Y)>0 X=$$SW(X,Y)
Q X
SP(X,Y) ; Contains Spelling Error
Q:'$L($G(X)) 0 S Y=$P($G(Y),"^",1) Q:'$L($G(Y)) 0
Q:$$UP^XLFSTR(X)[$$UP^XLFSTR(Y) 1
Q 0
SW(X,Y) ; Swap Spelling
N TXT,RP,WT S TXT=$G(X),RP=$G(Y),WT=$P(RP,"^",2),RP=$P(RP,"^",1) S X=TXT Q:'$L(RP) X Q:'$L(WT) X
S RP=$$UP^XLFSTR($E(RP,1))_$$LOW^XLFSTR($E(RP,2,$L(RP))) S WT=$$UP^XLFSTR($E(WT,1))_$$LOW^XLFSTR($E(WT,2,$L(WT)))
F Q:TXT'[RP S TXT=$P(TXT,RP,1)_WT_$P(TXT,RP,2,4000)
S RP=$$UP^XLFSTR(RP),WT=$$UP^XLFSTR(WT) F Q:TXT'[RP S TXT=$P(TXT,RP,1)_WT_$P(TXT,RP,2,4000)
S RP=$$LOW^XLFSTR(RP),WT=$$LOW^XLFSTR(WT) F Q:TXT'[RP S TXT=$P(TXT,RP,1)_WT_$P(TXT,RP,2,4000)
S X=TXT
Q X
;
; Assembly
PREA ; Pre-assembly
N Y,TC S TC=0 F S TC=$O(TA(TC)) Q:+TC'>0 D
. I $$UP($G(TA(TC)))="PRE" S:$G(TA(TC,"B",1))="-"&($E($G(TA((TC+1))),1)?1U) TA(TC)=$$MX($G(TA(TC)))
Q:'$L($G(UEX)) F Y="ACTINIUM^Actinium","ALUMINUM^Aluminum","ANTIMONY^Antimony","ARSENIC^Arsenic","BARIUM^Barium","BERYLLIUM^Beryllium","BISMUTH^Bismuth" D:UEX[$P(Y,"^",1) PRES(Y)
F Y="BROMINE^Bromine","BUDESONIDE^Budesonide","CADMIUM^Cadmium","CALCIUM^Calcium","CARBON^Carbon","CESIUM^Cesium","CHLORINE^Chlorine" D:UEX[$P(Y,"^",1) PRES(Y)
F Y="CHROMIUM^Chromium","COBALT^Cobalt","COPPER^Copper","GALLIUM^Gallium","GERMANIUM^Germanium","HAFNIUM^Hafnium","INDIUM^Indium" D:UEX[$P(Y,"^",1) PRES(Y)
F Y="IODINE^Iodine","IRIDIUM^Iridium","KRYPTON^Krypton","LEAD^Lead","LUTETIUM^Lutetium","MANGANESE^Manganese","MERCURY^Mercury","NICKEL^Nickel" D:UEX[$P(Y,"^",1) PRES(Y)
F Y="OSMIUM^Osmium","OXYGEN^Oxygen","PLATINUM^Platinum","POTASSIUM^Potassium","RADON^Radon","RHODIUM^Rhodium","RUBIDIUM^Rubidium","RUTHENIUM^Ruthenium" D:UEX[$P(Y,"^",1) PRES(Y)
F Y="SELENIUM^Selenium","SILICON^Silicon","SILVER^Silver","SODIUM^Sodium","STRONTIUM^Strontium","SULFUR^Sulfur","TANTALUM^Tantalum","THALLIUM^Thallium" D:UEX[$P(Y,"^",1) PRES(Y)
F Y="THORIUM^Thorium","TITANIUM^Titanium","TUNGSTEN^Tungsten","URANIUM^Uranium","VANADIUM^Vanadium","XENON^Xenon","YTTRIUM^Yttrium","ZIRCONIUM^Zirconium" D:UEX[$P(Y,"^",1) PRES(Y)
Q
PRES(X) ; Pre-assembly Swap text
N RP,WI,TC S RP=$P($G(X),"^",1),WI=$P($G(X),"^",2) Q:'$L(RP) S TC=0 F S TC=$O(TA(TC)) Q:+TC'>0 D
. N X S X=$G(TA(TC)) Q:X'[RP Q:$L(X)'>3 F Q:X'[RP S X=$P(X,RP,1)_WI_$P(X,RP,2,4000)
. S TA(TC)=X
Q
ASEM ; Final Assembly
S AFTER="" S TC=0 F S TC=$O(TA(TC)) Q:+TC'>0 D
. S AFTER=AFTER_$G(TA(TC))
. N CC S CC=0 F S CC=$O(TA(TC,"B",CC)) Q:+CC'>0 D
. . S AFTER=AFTER_$G(TA(TC,"B",CC))
S:'$D(TA(1,"S")) AFTER=$$UP($E(AFTER,1))_$E(AFTER,2,$L(AFTER))
F Y="CR (E)St^CR(E)ST","CR (E)ST^CREST","CR(E)ST^CREST"," ^ ","Vertebra (E)^Vertebra(e)" I AFTER[$P(Y,"^",1) D
. N RP,WI S RP=$P($G(Y),"^",1),WI=$P($G(Y),"^",2) Q:'$L(RP)
. F Q:AFTER'[RP S AFTER=$P(AFTER,RP,1)_WI_$P(AFTER,RP,2,4000)
I $E(AFTER,$L(AFTER))="a",$E(AFTER,($L(AFTER)-1))=" " D
. S AFTER=$E(AFTER,1,($L(AFTER)-2))_" A"
Q
;
; Miscellaneous
IEEG(X) ; I.E. and E.G.
S X=$G(X) N TK F TK="IE^ie","I.E.^ie","I.E^ie","I.e.^ie","I.e^ie","i.e.^ie","i.e^ie","E.G.^eg","E.G^eg","E.g.^eg","E.g^eg","e.g.^eg","e.g^eg" D
. N RP,WI S RP=$P(TK,"^",1),WI=$P(TK,"^",2) F Q:X'[RP S X=$P(X,RP,1)_WI_$P(X,RP,2,4000)
Q X
AABR(X) ; Abbreviation
N TIEN,OIEN,ABR,TKN S TIEN=+($G(X)),ABR="",OIEN=0
S TKN=$P($G(^LEX(757.07,+TIEN,0)),"^",1) Q:$E(TKN,1)="*" 0 Q:$E(TKN,1)?1N 0 Q:$L(TKN)'>1 0
F S OIEN=$O(^LEX(757.07,+TIEN,1,OIEN)) Q:+OIEN'>0 D
. N ND,CAS,RUL S ND=$G(^LEX(757.07,+TIEN,1,+OIEN,0)),CAS=$P(ND,"^",2) Q:CAS="L"
. S RUL=$G(^LEX(757.07,+TIEN,1,+OIEN,1)) Q:$L(RUL)
. S RUL=$G(^LEX(757.07,+TIEN,1,+OIEN,2)) Q:$L(RUL)
. S RUL=$G(^LEX(757.07,+TIEN,1,+OIEN,3)) Q:$L(RUL)
. S ABR=ABR_CAS
S X=0 S:ABR["U"!(ABR["S") X=1
Q X
PR(X,ARY) ; Parse Expression into Tokens
N CTL,EXP,CUR,PRE,TC,CT,OUT,P1,ST,P2,PC S EXP=$G(X) K ARY
S CTL="^ ^!^@^#^$^%^^^&^*^(^)^_^+^-^=^{^}^|^[^]^\^:^""^;^'^<^>^?^,^.^/^"
S (CUR,PRE)="",TC=1,CT=0,(OUT,P1,ST,P2)="" F PC=1:1:$L(EXP) D
. N CHR S (CUR,CHR)=$E(EXP,PC)
. I CTL'[("^"_CHR_"^") D Q
. . S ARY(+TC)=$G(ARY(+TC))_CHR S PRE=CUR
. I CTL[("^"_CHR_"^") D Q
. . N CC,NXT S CC=$O(ARY(+TC,"B"," "),-1)+1
. . S ARY(+TC,"B",CC)=CHR
. . S NXT=$E(EXP,(PC+1))
. . I $L(NXT),CTL'[("^"_NXT_"^") S TC=TC+1
. . S PRE=CUR
S TC=0 F S TC=$O(ARY(TC)) Q:+TC'>0 D
. N TKN S TKN=$G(ARY(TC)) S:$L(TKN) ARY(TC,"O")=TKN
Q
;
CAS(X,Y,S) ; Case
S X=$G(X),Y=$G(Y),S=$G(S)
S:Y="L" X=$$LO(X) S:Y="U" X=$$UP(X) S:Y="M" X=$$MX(X) S:Y="S" X=S
Q X
MX(X) ; Mix Case
Q $$UP($E($G(X),1))_$$LO($E($G(X),2,$L($G(X))))
PS(X) ; Period Space
S X=$G(X) Q:$D(A5ALEX) X I X[". " F I=1:1:($L(X,". ")-1) D
. N LD,TR,PS S PS=". ",LD=$P(X,PS,1,I),TR=$$TM($P(X,PS,(I+1),$L(X)))
. S X=LD_". "_$$UP($E($G(TR),1))_$E($G(TR),2,$L($G(TR)))
N A5ALEX
Q X
UP(X) ; Uppercase
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
LO(X) ; Lower Case
Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
TM(X,Y) ; Trim Character Y - Default " "
S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" " F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
Q X
RP(X,Y) ; Repeat
N C,L S C=$G(X),L=+($G(Y)) Q:$L(C)*L>245 "" S X="",$P(X,C,$G(L)+1)=""
Q X
CTL(X) ; Remove/Replace Control Characters
S X=$G(X) Q:'$L(X) "" N OUT,PSN,CHR,ASC,REP,WIT
; Curved Apostrophe
F CHR=145,146 S REP=$C(CHR),WIT="'" S X=$$CTLR(X,REP,WIT)
; Accented letter e
F CHR=130,136,137,138 S REP=$C(CHR),WIT="e" S X=$$CTLR(X,REP,WIT)
; Accented letter c
F CHR=128,135 S REP=$C(CHR),WIT="c" S X=$$CTLR(X,REP,WIT)
; Accented letter u
F CHR=129,151,163 S REP=$C(CHR),WIT="u" S X=$$CTLR(X,REP,WIT)
; Accented letter a
F CHR=131,132,133,134,143,145,160,166 S REP=$C(CHR),WIT="a" S X=$$CTLR(X,REP,WIT)
; Accented letter i
F CHR=139,140,141 S REP=$C(CHR),WIT="i" S X=$$CTLR(X,REP,WIT)
; Accented letter o
F CHR=147,148,149,153,162 S REP=$C(CHR),WIT="o" S X=$$CTLR(X,REP,WIT)
; En dash
S REP=$C(150),WIT="o" S X=$$CTLR(X,REP,WIT)
; Inverted exclamation mark
S REP=$C(161),WIT="a" S X=$$CTLR(X,REP,WIT)
; Currency sign
S REP=$C(164),WIT="a" S X=$$CTLR(X,REP,WIT)
; Section Sing (double S)
S REP=$C(167),WIT="c" S X=$$CTLR(X,REP,WIT)
; Spacing diaeresis - umlaut
S REP=$C(168),WIT="e" S X=$$CTLR(X,REP,WIT)
; Copyright sign
S REP=$C(169),WIT="e" S X=$$CTLR(X,REP,WIT)
; Left double angle quotes
S REP=$C(171),WIT="e" S X=$$CTLR(X,REP,WIT)
; Pilcrow sign - paragraph sign
S REP=$C(182),WIT="o" S X=$$CTLR(X,REP,WIT)
; Spacing cedilla
S REP=$C(184),WIT="o" S X=$$CTLR(X,REP,WIT)
; One Fourth Fraction
S REP=$C(188),WIT="u" S X=$$CTLR(X,REP,WIT)
; Small letter a with circumflex
S REP=$C(226),WIT="o" S X=$$CTLR(X,REP,WIT)
; HTML En Dash
S REP=$C(8211),WIT="o" S X=$$CTLR(X,REP,WIT)
; Extended ASCII Vowels
S REP=$C(142),WIT="Z" S X=$$CTLR(X,REP,WIT)
S REP=$C(156),WIT="oe" S X=$$CTLR(X,REP,WIT)
S REP=$C(158),WIT="z" S X=$$CTLR(X,REP,WIT)
S REP=$C(159),WIT="Y" S X=$$CTLR(X,REP,WIT)
F CHR=192,193,194,195,196,197 S REP=$C(CHR),WIT="A" S X=$$CTLR(X,REP,WIT)
S REP=$C(198),WIT="AE" S X=$$CTLR(X,REP,WIT)
S REP=$C(199),WIT="C" S X=$$CTLR(X,REP,WIT)
F CHR=200,201,202,203 S REP=$C(CHR),WIT="E" S X=$$CTLR(X,REP,WIT)
F CHR=204,205,206,207 S REP=$C(CHR),WIT="I" S X=$$CTLR(X,REP,WIT)
S REP=$C(208),WIT="ETH" S X=$$CTLR(X,REP,WIT)
S REP=$C(209),WIT="N" S X=$$CTLR(X,REP,WIT)
F CHR=210,211,212,213,214,216 S REP=$C(CHR),WIT="O" S X=$$CTLR(X,REP,WIT)
F CHR=217,218,219,220 S REP=$C(CHR),WIT="U" S X=$$CTLR(X,REP,WIT)
S REP=$C(221),WIT="Y" S X=$$CTLR(X,REP,WIT)
F CHR=154,223 S REP=$C(CHR),WIT="s" S X=$$CTLR(X,REP,WIT)
F CHR=224,225,226,227,228,229 S REP=$C(CHR),WIT="a" S X=$$CTLR(X,REP,WIT)
S REP=$C(230),WIT="ae" S X=$$CTLR(X,REP,WIT)
S REP=$C(231),WIT="c" S X=$$CTLR(X,REP,WIT)
F CHR=232,233,234,235 S REP=$C(CHR),WIT="e" S X=$$CTLR(X,REP,WIT)
F CHR=236,237,238,239 S REP=$C(CHR),WIT="i" S X=$$CTLR(X,REP,WIT)
S REP=$C(240),WIT="eth" S X=$$CTLR(X,REP,WIT)
S REP=$C(241),WIT="n" S X=$$CTLR(X,REP,WIT)
F CHR=242,243,244,245,246,248 S REP=$C(CHR),WIT="o" S X=$$CTLR(X,REP,WIT)
F CHR=249,250,251,252 S REP=$C(CHR),WIT="u" S X=$$CTLR(X,REP,WIT)
F CHR=253,255 S REP=$C(CHR),WIT="y" S X=$$CTLR(X,REP,WIT)
; All others (remove)
S OUT="" F PSN=1:1:$L(X) S CHR=$E(X,PSN),ASC=$A(CHR) S:ASC>31&(ASC<127) OUT=OUT_CHR
; Uppercase leading character
S X=$$UP^XLFSTR($E(OUT,1))_$E(OUT,2,$L(OUT))
Q X
DBLS(X) ; Double Space/Special Characters
S X=$G(X) Q:(X'[" ")&(X'["^") X
F S X=$P(X," ",1)_" "_$P(X," ",2,300) Q:X'[" "
F S X=$P(X,"^",1)_" "_$P(X,"^",2,300) Q:X'["^"
F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
Q X
CTLR(LEX,X,Y) ; Control Character Replace
N LEXT,LEXR1,LEXR2,LEX2,LEXW S LEXT=$G(LEX) Q:'$L(LEXT) "" S LEXR1=$G(X) S X=LEXT Q:'$L(LEXR1) X Q:LEXT'[LEXR1 X
S LEXW=$G(Y),LEXR2=$C(195)_LEXR1
I LEXT[LEXR2 F Q:LEXT'[LEXR2 S LEXT=$P(LEXT,LEXR2,1)_LEXW_$P(LEXT,LEXR2,2,4000)
I LEXT[LEXR1 F Q:LEXT'[LEXR1 S LEXT=$P(LEXT,LEXR1,1)_LEXW_$P(LEXT,LEXR1,2,4000)
S X=LEXT
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXXMC 17372 printed Nov 22, 2024@17:20:35 Page 2
LEXXMC ;ISL/KER - Convert Text to Mix Case ;10/10/2017
+1 ;;2.0;Lexicon Utility;**103,114**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.07 SACC 1.3
+5 ;
+6 ; External References
+7 ; None
+8 ;
+9 ; Replaces Integrated Control Registration #5781 $$MIX^LEXXM(X)
+10 ; (released in LEX*2.0*80, Jun 17, 2014) which converts UPPERCASE
+11 ; to Mix Case Text.
+12 ;
+13 ; Old API New API
+14 ; $$MIX^LEXXM(X) $$MIX^LEXXMC(X)
+15 ; Hard Coded Rules Database of Rules
+16 ; Extremely hard to update Update in Quarterly patch
+17 ; Rules in LEXXM* Rules in ^LEX(757.07)
+18 ;
+19 ; The old API $$MIX^LEXXM will be re-directed to $$MIX^LEXXMC
+20 ;
MIX(TEXT) ; Mixed Case Expression
+1 ;
+2 ; Input
+3 ;
+4 ; TEXT Text, any case (Required)
+5 ;
+6 ; Output
+7 ;
+8 ; $$MIX Text, Mixed Case
+9 ;
+10 NEW AAA,ABR,AFTER,AR,ARRAY,ARY,ASC,BEFORE,C,CAS,CC,CCTR,CH,CHR,COND,CT,CTL,CUR,DIFF,EXEC,EXP,FULL,HA,HN,I,L,LD,LEX,LEX2
+11 NEW LEXR1,LEXR2,LEXT,LEXW,ND,NPT,NXT,OIEN,ORG,OUT,P1,P2,PC,PPT,PRE,PS,PSN,REP,RP,RUL,RULE,S,SPC,ST,TA,TC,TEST,TIEN,TK
+12 NEW TKN,TOKEN,TR,TRUE,TXT,UEX,WI,WIT,WT,X,Y
if $DATA(TOKEN)
KILL RULE,FULL
if '$LENGTH($GET(TEXT))
QUIT ""
+13 SET TEXT=$$DBLS($TRANSLATE($GET(TEXT),"""","'"))
SET TEXT=$$CTL($GET(TEXT))
SET TEXT=$$SPELL(TEXT)
SET (ORG,EXP)=$$IEEG($GET(TEXT))
+14 IF '$LENGTH($GET(EXP))
SET TEXT=ORG
QUIT $TRANSLATE(TEXT,"""","'")
+15 ; Save Before Expression
+16 SET BEFORE=ORG
SET UEX=$$UP(ORG)
+17 ; Parse
+18 KILL TA
DO PR(EXP,.TA)
+19 ; Loop through Words
+20 SET TC=0
FOR
SET TC=$ORDER(TA(TC))
if +TC'>0
QUIT
Begin DoDot:1
+21 NEW CUR,CTL,PRE,NXT,PPT,NPT,TIEN,TRUE
SET TRUE=0
+22 ; Current Word
+23 SET CUR=$GET(TA(TC))
SET CTL=$$UP(CUR)
if '$LENGTH(CTL)
QUIT
+24 ; Previous Word
+25 SET PRE=$GET(TA((TC-1)))
+26 ; Next Word
+27 SET NXT=$GET(TA((TC+1)))
+28 ; Previous Punctuation
+29 SET PPT=$ORDER(TA((TC-1),"B"," "),-1)
+30 SET PPT=$SELECT(+PPT>0:$GET(TA((TC-1),"B",+PPT)),1:"")
+31 ; Special condition for the letter S and ' or (
+32 if CTL="S"
SET PPT=$GET(TA((TC-1),"B",1))
+33 ; Next Punctuation
+34 SET NPT=$GET(TA(TC,"B",1))
+35 ; Token IEN
+36 SET TIEN=$ORDER(^LEX(757.07,"B",CTL,0))
+37 ; Token not found, use mask/mix case
+38 IF '$DATA(^LEX(757.07,"B",CTL))!(TIEN'>0)
Begin DoDot:2
+39 DO TOK
if +($GET(TRUE))>0&($LENGTH($GET(OUT)))
SET TA(TC)=OUT
if +($GET(TRUE))'>0
SET TA(TC)=$$MX(CUR)
End DoDot:2
QUIT
+40 DO DSP1
+41 IF +($GET(TRUE))'>0
IF +($GET(TIEN))>0
Begin DoDot:2
+42 ; Loop through Rules
+43 NEW AAA,OIEN,OUT
SET OUT=CUR
+44 SET (OIEN,TRUE)=0
FOR
SET OIEN=$ORDER(^LEX(757.07,TIEN,1,OIEN))
if OIEN'>0
QUIT
if TRUE>0
QUIT
Begin DoDot:3
+45 if +($GET(TRUE))>0
QUIT
NEW COND,CCTR,CAS,SPC
SET CCTR=0
+46 SET CAS=$PIECE($GET(^LEX(757.07,+TIEN,1,+OIEN,0)),"^",2)
+47 SET SPC=$PIECE($GET(^LEX(757.07,+TIEN,1,+OIEN,0)),"^",3)
+48 if $GET(CAS)="S"
SET TA(TC,"S")=""
+49 ; 1st Condition - Based on Expression
+50 DO EXP
if +($GET(TRUE))>0
QUIT
+51 ; 2nd Condition - Based on Previous Word
+52 DO PRE
if +($GET(TRUE))>0
QUIT
+53 ; 3rd Condition - Based on Next Word
+54 DO NXT
if +($GET(TRUE))>0
QUIT
+55 ; No Conditions
+56 DO NON
if +($GET(TRUE))>0
QUIT
+57 ; Token
+58 DO TOK
if +($GET(TRUE))>0
QUIT
End DoDot:3
if TRUE>0
QUIT
+59 ; Default Mix Case
+60 if TRUE'>0&(OUT=CUR)
SET OUT=$$MX(CUR)
+61 DO DSP4("END")
+62 SET TA(TC)=OUT
End DoDot:2
End DoDot:1
+63 ; Special Conditions - Pre-Assmebly
+64 DO PREA
+65 ; Assemble After Expression
+66 DO ASEM
DO DSP2
+67 SET TEXT=$GET(AFTER)
if '$LENGTH(TEXT)
SET TEXT=ORG
SET TEXT=$$PS(TEXT)
+68 QUIT $TRANSLATE(TEXT,"""","'")
+69 ;
EXP ; Expression Rules
+1 ;
+2 ; Example: If an expression contains the words "OPERATING
+3 ; ROOM" then the word "OR" will be in uppercase.
+4 if '$LENGTH($GET(CUR))
QUIT
if '$LENGTH($GET(CAS))
QUIT
if '$LENGTH($GET(SPC))
QUIT
if +($GET(TIEN))'>0
QUIT
if +($GET(OIEN))'>0
QUIT
if '$LENGTH($GET(EXP))
QUIT
+5 NEW COND
SET COND=$GET(^LEX(757.07,+($GET(TIEN)),1,+($GET(OIEN)),1))
if $LENGTH(COND)
SET CCTR=+($GET(CCTR))+1
+6 IF $LENGTH($GET(EXP))
IF $LENGTH(COND)
Begin DoDot:1
+7 NEW EXEC,X
SET X=$$UP($GET(EXP))
XECUTE COND
SET TRUE=$TEST
+8 IF +($GET(TRUE))>0
SET OUT=$$CAS($GET(CUR),$GET(CAS),$GET(SPC))
+9 DO DSP3("EXP")
End DoDot:1
if +($GET(TRUE))>0
QUIT
+10 QUIT
+11 ;
PRE ; Previous Word Rules
+1 ;
+2 ; Example: If the previous word is numeric or "PER"
+3 ; then the word "OZ" will be in lower case.
+4 if '$LENGTH($GET(CUR))
QUIT
if '$LENGTH($GET(CAS))
QUIT
if '$LENGTH($GET(SPC))
QUIT
if +($GET(TIEN))'>0
QUIT
if +($GET(OIEN))'>0
QUIT
if '$LENGTH(($GET(PRE)_$GET(PPT)))
QUIT
+5 NEW COND
SET COND=$GET(^LEX(757.07,+($GET(TIEN)),1,+($GET(OIEN)),2))
if $LENGTH(COND)
SET CCTR=+($GET(CCTR))+1
+6 IF $LENGTH($GET(PRE))
IF $LENGTH(COND)
Begin DoDot:1
+7 NEW EXEC,X
SET X=$$UP($GET(PRE))
XECUTE COND
SET TRUE=$TEST
+8 IF +($GET(TRUE))>0
SET OUT=$$CAS($GET(CUR),$GET(CAS),$GET(SPC))
+9 DO DSP3("PRE")
End DoDot:1
if TRUE>0
QUIT
+10 IF $LENGTH($GET(PPT))
IF $LENGTH(COND)
Begin DoDot:1
+11 NEW EXEC,X
SET X=$GET(PPT)
XECUTE COND
SET TRUE=$TEST
+12 IF +($GET(TRUE))>0
SET OUT=$$CAS($GET(CUR),$GET(CAS),$GET(SPC))
+13 DO DSP3("PPT")
End DoDot:1
if TRUE>0
QUIT
+14 QUIT
+15 ;
NXT ; Next Word Rules
+1 ;
+2 ; Example: If the next word contains "POSITIVE" or
+3 ; "NEGATIVE" then the word "ABL" will be
+4 ; in uppercase.
+5 if '$LENGTH($GET(CUR))
QUIT
if '$LENGTH($GET(CAS))
QUIT
if '$LENGTH($GET(SPC))
QUIT
if +($GET(TIEN))'>0
QUIT
if +($GET(OIEN))'>0
QUIT
+6 NEW COND
SET COND=$GET(^LEX(757.07,+($GET(TIEN)),1,+($GET(OIEN)),3))
if $LENGTH(COND)
SET CCTR=+($GET(CCTR))+1
+7 if '$LENGTH(($GET(NXT)_$GET(NPT)))
QUIT
IF $LENGTH($GET(NXT))
IF $LENGTH(COND)
Begin DoDot:1
+8 NEW EXEC,X
SET X=$$UP($GET(NXT))
XECUTE COND
SET TRUE=$TEST
+9 IF +($GET(TRUE))>0
SET OUT=$$CAS($GET(CUR),$GET(CAS),$GET(SPC))
+10 DO DSP3("NXT")
End DoDot:1
if TRUE>0
QUIT
+11 IF $LENGTH($GET(NPT))
IF $LENGTH(COND)
Begin DoDot:1
+12 NEW EXEC,X
SET X=$GET(NPT)
XECUTE COND
SET TRUE=$TEST
+13 IF +($GET(TRUE))>0
SET OUT=$$CAS($GET(CUR),$GET(CAS),$GET(SPC))
+14 DO DSP3("NPT")
End DoDot:1
if TRUE>0
QUIT
+15 QUIT
+16 ;
NON ; No Rules (default)
+1 ;
+2 ; Example: If the rules for the expression, the previous
+3 ; word and the next word fail (false) and there
+4 ; is a default case value then that case will
+5 ; be used.
+6 ;
+7 ; U UPPERCASE COPD
+8 ; L lower case between
+9 ; M Mixed Case Diabetes
+10 ; S Special Case IgE
+11 if +($GET(TRUE))>0
QUIT
if +($GET(CCTR))>0
QUIT
if '$LENGTH($GET(CUR))
QUIT
if '$LENGTH($GET(CAS))
QUIT
if '$LENGTH($GET(SPC))
QUIT
+12 NEW EXEC
SET OUT=$$CAS($GET(CUR),$GET(CAS),$GET(SPC))
+13 SET TRUE=1
DO DSP3("NON")
+14 QUIT
+15 ;
TOK ; Token/Word Rules
+1 ;
+2 ; Examples: If a word is an ordinal number (1st, 2nd, etc.)
+3 ; then the word will be in lower case.
+4 ;
+5 ; If a word is alpha numeric then the word will
+6 ; be in upper case.
+7 ;
+8 ; If a word is preceded or followed by a dash "-"
+9 ; then the word will be upper case.
+10 if +($GET(TRUE))>0
QUIT
if '$LENGTH($GET(CUR))
QUIT
+11 NEW AAA,CAS,COND,OIEN,SPC,TIEN,HA,HN,CH
SET (HA,HN)=0
SET AAA=$$RP("*",$LENGTH(CUR))
if AAA'["*"
QUIT
+12 FOR CH=1:1:$LENGTH(CUR)
if $EXTRACT(CUR,CH)?1A
SET HA=1
if $EXTRACT(CUR,CH)?1N
SET HN=1
+13 SET TIEN=$ORDER(^LEX(757.07,"B",AAA,0))
IF TIEN'>0
IF HA>0
IF HN>0
SET OUT=$$UP(CUR)
SET TRUE=1
QUIT
+14 if TIEN'>0
QUIT
SET (TRUE,OIEN)=0
+15 FOR
SET OIEN=$ORDER(^LEX(757.07,TIEN,1,OIEN))
if +OIEN'>0
QUIT
if TRUE>0
QUIT
Begin DoDot:1
+16 NEW COND,CAS,EXEC,SPC
SET CAS=$PIECE($GET(^LEX(757.07,+TIEN,1,+OIEN,0)),"^",2)
SET SPC=$PIECE($GET(^LEX(757.07,+TIEN,1,+OIEN,0)),"^",3)
+17 SET COND=$GET(^LEX(757.07,+TIEN,1,+OIEN,1))
SET X=$$UP(CUR)
+18 IF $LENGTH(COND)
XECUTE COND
SET TRUE=$TEST
+19 IF TRUE>0
SET OUT=$$CAS(CUR,CAS,SPC)
+20 DO DSP3("TOK")
End DoDot:1
if TRUE>0
QUIT
+21 QUIT
+22 ; Displays used for testing Case Rules
DSP1 ; Display Components
+1 if '$DATA(TEST)
QUIT
if $DATA(TOKEN)
QUIT
if $DATA(ARRAY)
QUIT
if '$DATA(FULL)
QUIT
+2 WRITE !!,"CUR: ",$GET(CUR),!,"PRE: ",$GET(PRE),!,"NXT: ",$GET(NXT),!,"PPT: ",$GET(PPT),!,"NPT: ",$GET(NPT)
NEW FULL,DIFF,ARRAY
+3 QUIT
DSP2 ; Display Changes (Differences)
+1 if '$DATA(TEST)
QUIT
NEW EXEC
IF $DATA(FULL)
IF $DATA(ARRAY)
Begin DoDot:1
+2 NEW AR
SET AR="TA(0)"
FOR
SET AR=$QUERY(@AR)
if '$LENGTH(AR)!($EXTRACT(AR,1,2)'="TA")
QUIT
WRITE AR,"=",@AR,!
End DoDot:1
+3 IF '$DATA(DIFF)
IF '$DATA(ARRAY)
WRITE !!,"Before: ",BEFORE,!,"After: ",AFTER
+4 IF $DATA(DIFF)
IF '$DATA(ARRAY)
IF BEFORE'=AFTER
WRITE !!,"Before: ",BEFORE,!,"After: ",AFTER
+5 if $DATA(ARRAY)
WRITE !,AFTER
NEW ARRAY,DIFF,FULL,TEST
+6 QUIT
DSP3(X) ; Display Conditions #1
+1 if '$DATA(TEST)
QUIT
if '$DATA(RULE)
QUIT
if $DATA(TOKEN)
QUIT
+2 WRITE !!,"X: ",$GET(X),!,"CUR: ",$GET(CUR),!,"CAS: ",$GET(CAS),!,"SPC: ",$GET(SPC),!,"TRUE: ",$GET(PPT),!,"OUT: ",$GET(OUT),!
+3 NEW TEST,RULE,TOKEN
+4 QUIT
DSP4(X) ; Display Conditions #2
+1 if '$DATA(TEST)
QUIT
if '$DATA(RULE)
QUIT
if $DATA(TOKEN)
QUIT
WRITE !!,"X: ",$GET(X),!,"TRUE: ",$GET(PPT),!,"OUT: ",$GET(OUT),!
+2 NEW TEST,RULE,TOKEN
+3 QUIT
+4 ;
+5 ; Spelling
SPELL(X) ; Known Spelling Errors
+1 FOR Y="Pe-ripheral^Peripheral","us-ing^using","Intralu-minal^Intraluminal","Ap-proach^Approach","Endo-scopic^Endoscopic"
if $$SP(X,Y)>0
SET X=$$SW(X,Y)
+2 FOR Y="Technolo-gy^Technology","CR (E)St^CREST","CR(E)St^CREST"
if $$SP(X,Y)>0
SET X=$$SW(X,Y)
+3 QUIT X
SP(X,Y) ; Contains Spelling Error
+1 if '$LENGTH($GET(X))
QUIT 0
SET Y=$PIECE($GET(Y),"^",1)
if '$LENGTH($GET(Y))
QUIT 0
+2 if $$UP^XLFSTR(X)[$$UP^XLFSTR(Y)
QUIT 1
+3 QUIT 0
SW(X,Y) ; Swap Spelling
+1 NEW TXT,RP,WT
SET TXT=$GET(X)
SET RP=$GET(Y)
SET WT=$PIECE(RP,"^",2)
SET RP=$PIECE(RP,"^",1)
SET X=TXT
if '$LENGTH(RP)
QUIT X
if '$LENGTH(WT)
QUIT X
+2 SET RP=$$UP^XLFSTR($EXTRACT(RP,1))_$$LOW^XLFSTR($EXTRACT(RP,2,$LENGTH(RP)))
SET WT=$$UP^XLFSTR($EXTRACT(WT,1))_$$LOW^XLFSTR($EXTRACT(WT,2,$LENGTH(WT)))
+3 FOR
if TXT'[RP
QUIT
SET TXT=$PIECE(TXT,RP,1)_WT_$PIECE(TXT,RP,2,4000)
+4 SET RP=$$UP^XLFSTR(RP)
SET WT=$$UP^XLFSTR(WT)
FOR
if TXT'[RP
QUIT
SET TXT=$PIECE(TXT,RP,1)_WT_$PIECE(TXT,RP,2,4000)
+5 SET RP=$$LOW^XLFSTR(RP)
SET WT=$$LOW^XLFSTR(WT)
FOR
if TXT'[RP
QUIT
SET TXT=$PIECE(TXT,RP,1)_WT_$PIECE(TXT,RP,2,4000)
+6 SET X=TXT
+7 QUIT X
+8 ;
+9 ; Assembly
PREA ; Pre-assembly
+1 NEW Y,TC
SET TC=0
FOR
SET TC=$ORDER(TA(TC))
if +TC'>0
QUIT
Begin DoDot:1
+2 IF $$UP($GET(TA(TC)))="PRE"
if $GET(TA(TC,"B",1))="-"&($EXTRACT($GET(TA((TC+1))),1)?1U)
SET TA(TC)=$$MX($GET(TA(TC)))
End DoDot:1
+3 if '$LENGTH($GET(UEX))
QUIT
FOR Y="ACTINIUM^Actinium","ALUMINUM^Aluminum","ANTIMONY^Antimony","ARSENIC^Arsenic","BARIUM^Barium","BERYLLIUM^Beryllium","BISMUTH^Bismuth"
if UEX[$PIECE(Y,"^",1)
DO PRES(Y)
+4 FOR Y="BROMINE^Bromine","BUDESONIDE^Budesonide","CADMIUM^Cadmium","CALCIUM^Calcium","CARBON^Carbon","CESIUM^Cesium","CHLORINE^Chlorine"
if UEX[$PIECE(Y,"^",1)
DO PRES(Y)
+5 FOR Y="CHROMIUM^Chromium","COBALT^Cobalt","COPPER^Copper","GALLIUM^Gallium","GERMANIUM^Germanium","HAFNIUM^Hafnium","INDIUM^Indium"
if UEX[$PIECE(Y,"^",1)
DO PRES(Y)
+6 FOR Y="IODINE^Iodine","IRIDIUM^Iridium","KRYPTON^Krypton","LEAD^Lead","LUTETIUM^Lutetium","MANGANESE^Manganese","MERCURY^Mercury","NICKEL^Nickel"
if UEX[$PIECE(Y,"^",1)
DO PRES(Y)
+7 FOR Y="OSMIUM^Osmium","OXYGEN^Oxygen","PLATINUM^Platinum","POTASSIUM^Potassium","RADON^Radon","RHODIUM^Rhodium","RUBIDIUM^Rubidium","RUTHENIUM^Ruthenium"
if UEX[$PIECE(Y,"^",1)
DO PRES(Y)
+8 FOR Y="SELENIUM^Selenium","SILICON^Silicon","SILVER^Silver","SODIUM^Sodium","STRONTIUM^Strontium","SULFUR^Sulfur","TANTALUM^Tantalum","THALLIUM^Thallium"
if UEX[$PIECE(Y,"^",1)
DO PRES(Y)
+9 FOR Y="THORIUM^Thorium","TITANIUM^Titanium","TUNGSTEN^Tungsten","URANIUM^Uranium","VANADIUM^Vanadium","XENON^Xenon","YTTRIUM^Yttrium","ZIRCONIUM^Zirconium"
if UEX[$PIECE(Y,"^",1)
DO PRES(Y)
+10 QUIT
PRES(X) ; Pre-assembly Swap text
+1 NEW RP,WI,TC
SET RP=$PIECE($GET(X),"^",1)
SET WI=$PIECE($GET(X),"^",2)
if '$LENGTH(RP)
QUIT
SET TC=0
FOR
SET TC=$ORDER(TA(TC))
if +TC'>0
QUIT
Begin DoDot:1
+2 NEW X
SET X=$GET(TA(TC))
if X'[RP
QUIT
if $LENGTH(X)'>3
QUIT
FOR
if X'[RP
QUIT
SET X=$PIECE(X,RP,1)_WI_$PIECE(X,RP,2,4000)
+3 SET TA(TC)=X
End DoDot:1
+4 QUIT
ASEM ; Final Assembly
+1 SET AFTER=""
SET TC=0
FOR
SET TC=$ORDER(TA(TC))
if +TC'>0
QUIT
Begin DoDot:1
+2 SET AFTER=AFTER_$GET(TA(TC))
+3 NEW CC
SET CC=0
FOR
SET CC=$ORDER(TA(TC,"B",CC))
if +CC'>0
QUIT
Begin DoDot:2
+4 SET AFTER=AFTER_$GET(TA(TC,"B",CC))
End DoDot:2
End DoDot:1
+5 if '$DATA(TA(1,"S"))
SET AFTER=$$UP($EXTRACT(AFTER,1))_$EXTRACT(AFTER,2,$LENGTH(AFTER))
+6 FOR Y="CR (E)St^CR(E)ST","CR (E)ST^CREST","CR(E)ST^CREST"," ^ ","Vertebra (E)^Vertebra(e)"
IF AFTER[$PIECE(Y,"^",1)
Begin DoDot:1
+7 NEW RP,WI
SET RP=$PIECE($GET(Y),"^",1)
SET WI=$PIECE($GET(Y),"^",2)
if '$LENGTH(RP)
QUIT
+8 FOR
if AFTER'[RP
QUIT
SET AFTER=$PIECE(AFTER,RP,1)_WI_$PIECE(AFTER,RP,2,4000)
End DoDot:1
+9 IF $EXTRACT(AFTER,$LENGTH(AFTER))="a"
IF $EXTRACT(AFTER,($LENGTH(AFTER)-1))=" "
Begin DoDot:1
+10 SET AFTER=$EXTRACT(AFTER,1,($LENGTH(AFTER)-2))_" A"
End DoDot:1
+11 QUIT
+12 ;
+13 ; Miscellaneous
IEEG(X) ; I.E. and E.G.
+1 SET X=$GET(X)
NEW TK
FOR TK="IE^ie","I.E.^ie","I.E^ie","I.e.^ie","I.e^ie","i.e.^ie","i.e^ie","E.G.^eg","E.G^eg","E.g.^eg","E.g^eg","e.g.^eg","e.g^eg"
Begin DoDot:1
+2 NEW RP,WI
SET RP=$PIECE(TK,"^",1)
SET WI=$PIECE(TK,"^",2)
FOR
if X'[RP
QUIT
SET X=$PIECE(X,RP,1)_WI_$PIECE(X,RP,2,4000)
End DoDot:1
+3 QUIT X
AABR(X) ; Abbreviation
+1 NEW TIEN,OIEN,ABR,TKN
SET TIEN=+($GET(X))
SET ABR=""
SET OIEN=0
+2 SET TKN=$PIECE($GET(^LEX(757.07,+TIEN,0)),"^",1)
if $EXTRACT(TKN,1)="*"
QUIT 0
if $EXTRACT(TKN,1)?1N
QUIT 0
if $LENGTH(TKN)'>1
QUIT 0
+3 FOR
SET OIEN=$ORDER(^LEX(757.07,+TIEN,1,OIEN))
if +OIEN'>0
QUIT
Begin DoDot:1
+4 NEW ND,CAS,RUL
SET ND=$GET(^LEX(757.07,+TIEN,1,+OIEN,0))
SET CAS=$PIECE(ND,"^",2)
if CAS="L"
QUIT
+5 SET RUL=$GET(^LEX(757.07,+TIEN,1,+OIEN,1))
if $LENGTH(RUL)
QUIT
+6 SET RUL=$GET(^LEX(757.07,+TIEN,1,+OIEN,2))
if $LENGTH(RUL)
QUIT
+7 SET RUL=$GET(^LEX(757.07,+TIEN,1,+OIEN,3))
if $LENGTH(RUL)
QUIT
+8 SET ABR=ABR_CAS
End DoDot:1
+9 SET X=0
if ABR["U"!(ABR["S")
SET X=1
+10 QUIT X
PR(X,ARY) ; Parse Expression into Tokens
+1 NEW CTL,EXP,CUR,PRE,TC,CT,OUT,P1,ST,P2,PC
SET EXP=$GET(X)
KILL ARY
+2 SET CTL="^ ^!^@^#^$^%^^^&^*^(^)^_^+^-^=^{^}^|^[^]^\^:^""^;^'^<^>^?^,^.^/^"
+3 SET (CUR,PRE)=""
SET TC=1
SET CT=0
SET (OUT,P1,ST,P2)=""
FOR PC=1:1:$LENGTH(EXP)
Begin DoDot:1
+4 NEW CHR
SET (CUR,CHR)=$EXTRACT(EXP,PC)
+5 IF CTL'[("^"_CHR_"^")
Begin DoDot:2
+6 SET ARY(+TC)=$GET(ARY(+TC))_CHR
SET PRE=CUR
End DoDot:2
QUIT
+7 IF CTL[("^"_CHR_"^")
Begin DoDot:2
+8 NEW CC,NXT
SET CC=$ORDER(ARY(+TC,"B"," "),-1)+1
+9 SET ARY(+TC,"B",CC)=CHR
+10 SET NXT=$EXTRACT(EXP,(PC+1))
+11 IF $LENGTH(NXT)
IF CTL'[("^"_NXT_"^")
SET TC=TC+1
+12 SET PRE=CUR
End DoDot:2
QUIT
End DoDot:1
+13 SET TC=0
FOR
SET TC=$ORDER(ARY(TC))
if +TC'>0
QUIT
Begin DoDot:1
+14 NEW TKN
SET TKN=$GET(ARY(TC))
if $LENGTH(TKN)
SET ARY(TC,"O")=TKN
End DoDot:1
+15 QUIT
+16 ;
CAS(X,Y,S) ; Case
+1 SET X=$GET(X)
SET Y=$GET(Y)
SET S=$GET(S)
+2 if Y="L"
SET X=$$LO(X)
if Y="U"
SET X=$$UP(X)
if Y="M"
SET X=$$MX(X)
if Y="S"
SET X=S
+3 QUIT X
MX(X) ; Mix Case
+1 QUIT $$UP($EXTRACT($GET(X),1))_$$LO($EXTRACT($GET(X),2,$LENGTH($GET(X))))
PS(X) ; Period Space
+1 SET X=$GET(X)
if $DATA(A5ALEX)
QUIT X
IF X[". "
FOR I=1:1:($LENGTH(X,". ")-1)
Begin DoDot:1
+2 NEW LD,TR,PS
SET PS=". "
SET LD=$PIECE(X,PS,1,I)
SET TR=$$TM($PIECE(X,PS,(I+1),$LENGTH(X)))
+3 SET X=LD_". "_$$UP($EXTRACT($GET(TR),1))_$EXTRACT($GET(TR),2,$LENGTH($GET(TR)))
End DoDot:1
+4 NEW A5ALEX
+5 QUIT X
UP(X) ; Uppercase
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
LO(X) ; Lower Case
+1 QUIT $TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
TM(X,Y) ; Trim Character Y - Default " "
+1 SET X=$GET(X)
if X=""
QUIT X
SET Y=$GET(Y)
if '$LENGTH(Y)
SET Y=" "
FOR
if $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
if $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 QUIT X
RP(X,Y) ; Repeat
+1 NEW C,L
SET C=$GET(X)
SET L=+($GET(Y))
if $LENGTH(C)*L>245
QUIT ""
SET X=""
SET $PIECE(X,C,$GET(L)+1)=""
+2 QUIT X
CTL(X) ; Remove/Replace Control Characters
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT ""
NEW OUT,PSN,CHR,ASC,REP,WIT
+2 ; Curved Apostrophe
+3 FOR CHR=145,146
SET REP=$CHAR(CHR)
SET WIT="'"
SET X=$$CTLR(X,REP,WIT)
+4 ; Accented letter e
+5 FOR CHR=130,136,137,138
SET REP=$CHAR(CHR)
SET WIT="e"
SET X=$$CTLR(X,REP,WIT)
+6 ; Accented letter c
+7 FOR CHR=128,135
SET REP=$CHAR(CHR)
SET WIT="c"
SET X=$$CTLR(X,REP,WIT)
+8 ; Accented letter u
+9 FOR CHR=129,151,163
SET REP=$CHAR(CHR)
SET WIT="u"
SET X=$$CTLR(X,REP,WIT)
+10 ; Accented letter a
+11 FOR CHR=131,132,133,134,143,145,160,166
SET REP=$CHAR(CHR)
SET WIT="a"
SET X=$$CTLR(X,REP,WIT)
+12 ; Accented letter i
+13 FOR CHR=139,140,141
SET REP=$CHAR(CHR)
SET WIT="i"
SET X=$$CTLR(X,REP,WIT)
+14 ; Accented letter o
+15 FOR CHR=147,148,149,153,162
SET REP=$CHAR(CHR)
SET WIT="o"
SET X=$$CTLR(X,REP,WIT)
+16 ; En dash
+17 SET REP=$CHAR(150)
SET WIT="o"
SET X=$$CTLR(X,REP,WIT)
+18 ; Inverted exclamation mark
+19 SET REP=$CHAR(161)
SET WIT="a"
SET X=$$CTLR(X,REP,WIT)
+20 ; Currency sign
+21 SET REP=$CHAR(164)
SET WIT="a"
SET X=$$CTLR(X,REP,WIT)
+22 ; Section Sing (double S)
+23 SET REP=$CHAR(167)
SET WIT="c"
SET X=$$CTLR(X,REP,WIT)
+24 ; Spacing diaeresis - umlaut
+25 SET REP=$CHAR(168)
SET WIT="e"
SET X=$$CTLR(X,REP,WIT)
+26 ; Copyright sign
+27 SET REP=$CHAR(169)
SET WIT="e"
SET X=$$CTLR(X,REP,WIT)
+28 ; Left double angle quotes
+29 SET REP=$CHAR(171)
SET WIT="e"
SET X=$$CTLR(X,REP,WIT)
+30 ; Pilcrow sign - paragraph sign
+31 SET REP=$CHAR(182)
SET WIT="o"
SET X=$$CTLR(X,REP,WIT)
+32 ; Spacing cedilla
+33 SET REP=$CHAR(184)
SET WIT="o"
SET X=$$CTLR(X,REP,WIT)
+34 ; One Fourth Fraction
+35 SET REP=$CHAR(188)
SET WIT="u"
SET X=$$CTLR(X,REP,WIT)
+36 ; Small letter a with circumflex
+37 SET REP=$CHAR(226)
SET WIT="o"
SET X=$$CTLR(X,REP,WIT)
+38 ; HTML En Dash
+39 SET REP=$CHAR(8211)
SET WIT="o"
SET X=$$CTLR(X,REP,WIT)
+40 ; Extended ASCII Vowels
+41 SET REP=$CHAR(142)
SET WIT="Z"
SET X=$$CTLR(X,REP,WIT)
+42 SET REP=$CHAR(156)
SET WIT="oe"
SET X=$$CTLR(X,REP,WIT)
+43 SET REP=$CHAR(158)
SET WIT="z"
SET X=$$CTLR(X,REP,WIT)
+44 SET REP=$CHAR(159)
SET WIT="Y"
SET X=$$CTLR(X,REP,WIT)
+45 FOR CHR=192,193,194,195,196,197
SET REP=$CHAR(CHR)
SET WIT="A"
SET X=$$CTLR(X,REP,WIT)
+46 SET REP=$CHAR(198)
SET WIT="AE"
SET X=$$CTLR(X,REP,WIT)
+47 SET REP=$CHAR(199)
SET WIT="C"
SET X=$$CTLR(X,REP,WIT)
+48 FOR CHR=200,201,202,203
SET REP=$CHAR(CHR)
SET WIT="E"
SET X=$$CTLR(X,REP,WIT)
+49 FOR CHR=204,205,206,207
SET REP=$CHAR(CHR)
SET WIT="I"
SET X=$$CTLR(X,REP,WIT)
+50 SET REP=$CHAR(208)
SET WIT="ETH"
SET X=$$CTLR(X,REP,WIT)
+51 SET REP=$CHAR(209)
SET WIT="N"
SET X=$$CTLR(X,REP,WIT)
+52 FOR CHR=210,211,212,213,214,216
SET REP=$CHAR(CHR)
SET WIT="O"
SET X=$$CTLR(X,REP,WIT)
+53 FOR CHR=217,218,219,220
SET REP=$CHAR(CHR)
SET WIT="U"
SET X=$$CTLR(X,REP,WIT)
+54 SET REP=$CHAR(221)
SET WIT="Y"
SET X=$$CTLR(X,REP,WIT)
+55 FOR CHR=154,223
SET REP=$CHAR(CHR)
SET WIT="s"
SET X=$$CTLR(X,REP,WIT)
+56 FOR CHR=224,225,226,227,228,229
SET REP=$CHAR(CHR)
SET WIT="a"
SET X=$$CTLR(X,REP,WIT)
+57 SET REP=$CHAR(230)
SET WIT="ae"
SET X=$$CTLR(X,REP,WIT)
+58 SET REP=$CHAR(231)
SET WIT="c"
SET X=$$CTLR(X,REP,WIT)
+59 FOR CHR=232,233,234,235
SET REP=$CHAR(CHR)
SET WIT="e"
SET X=$$CTLR(X,REP,WIT)
+60 FOR CHR=236,237,238,239
SET REP=$CHAR(CHR)
SET WIT="i"
SET X=$$CTLR(X,REP,WIT)
+61 SET REP=$CHAR(240)
SET WIT="eth"
SET X=$$CTLR(X,REP,WIT)
+62 SET REP=$CHAR(241)
SET WIT="n"
SET X=$$CTLR(X,REP,WIT)
+63 FOR CHR=242,243,244,245,246,248
SET REP=$CHAR(CHR)
SET WIT="o"
SET X=$$CTLR(X,REP,WIT)
+64 FOR CHR=249,250,251,252
SET REP=$CHAR(CHR)
SET WIT="u"
SET X=$$CTLR(X,REP,WIT)
+65 FOR CHR=253,255
SET REP=$CHAR(CHR)
SET WIT="y"
SET X=$$CTLR(X,REP,WIT)
+66 ; All others (remove)
+67 SET OUT=""
FOR PSN=1:1:$LENGTH(X)
SET CHR=$EXTRACT(X,PSN)
SET ASC=$ASCII(CHR)
if ASC>31&(ASC<127)
SET OUT=OUT_CHR
+68 ; Uppercase leading character
+69 SET X=$$UP^XLFSTR($EXTRACT(OUT,1))_$EXTRACT(OUT,2,$LENGTH(OUT))
+70 QUIT X
DBLS(X) ; Double Space/Special Characters
+1 SET X=$GET(X)
if (X'[" ")&(X'["^")
QUIT X
+2 FOR
SET X=$PIECE(X," ",1)_" "_$PIECE(X," ",2,300)
if X'[" "
QUIT
+3 FOR
SET X=$PIECE(X,"^",1)_" "_$PIECE(X,"^",2,300)
if X'["^"
QUIT
+4 FOR
if $EXTRACT(X,1)'=" "
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+5 FOR
if $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+6 QUIT X
CTLR(LEX,X,Y) ; Control Character Replace
+1 NEW LEXT,LEXR1,LEXR2,LEX2,LEXW
SET LEXT=$GET(LEX)
if '$LENGTH(LEXT)
QUIT ""
SET LEXR1=$GET(X)
SET X=LEXT
if '$LENGTH(LEXR1)
QUIT X
if LEXT'[LEXR1
QUIT X
+2 SET LEXW=$GET(Y)
SET LEXR2=$CHAR(195)_LEXR1
+3 IF LEXT[LEXR2
FOR
if LEXT'[LEXR2
QUIT
SET LEXT=$PIECE(LEXT,LEXR2,1)_LEXW_$PIECE(LEXT,LEXR2,2,4000)
+4 IF LEXT[LEXR1
FOR
if LEXT'[LEXR1
QUIT
SET LEXT=$PIECE(LEXT,LEXR1,1)_LEXW_$PIECE(LEXT,LEXR1,2,4000)
+5 SET X=LEXT
+6 QUIT X
