LEXXM2 ;ISL/KER - Convert Text to Mix Case (2) ;04/21/2014
;;2.0;General Lexicon Utilities;**80**;Sep 23, 1996;Build 10
;
; Global Variables
; None
;
; External References
; None
;
; Local Variables NEWed or KILLed Elsewhere
; LEXCTL,LEXNXT,LEXORG,LEXPRE,UIN Newed in LEXXM
; Y Set and returned to LEXXM
;
T2 ; 2 Characters
N XU,CHR,PRE,ORG,NXT S ORG=$G(LEXORG),PRE=$G(LEXPRE),NXT=$G(LEXNXT),UIN=$G(UIN) S XU=$$UP(X),CHR=$E(XU,1)
; Exceptions
S:$E(XU,1)?1U&($E(XU,2)?1N) Y=XU Q:$L($G(Y)) S:$E(XU,1)?1N&($E(XU,2)?1U) Y=XU Q:$L($G(Y))
I $E(XU,($L(XU)-1),$L(XU))="CC",$E(XU,($L(XU)-2))?1N S Y=$$LO(XU) Q
I XU="SO",$E(NXT,1,7)="STATED " S Y=$$LO(X) Q
S:$G(LEXCTL)["OR ROOM"!($G(LEXCTL)["OR-ROOM") Y=XU Q:$L($G(Y))
S:XU="ST"&($G(PRE)=1) Y="st" S:XU="ND"&($G(PRE)=2) Y="nd" S:XU="RD"&($G(PRE)=3) Y="rd" S:XU="TH"&(+($G(PRE))>3) Y="th" Q:$L($G(Y))
S:XU="CO"&($G(UIN)["CO-") Y=$$MX(XU) Q:$L($G(Y))
S:XU="SO"&(($G(UIN)["SO STATED")!($G(UIN)["SO DESCRIBED")) Y=$$LO(XU) Q:$L($G(Y))
S:XU="SO"&(($G(UIN)["SHOULDER ORTHOSIS")!($G(UIN)["SUPERIOR OBLIQUE")) Y=XU Q:$L($G(Y))
S:XU="HB"&(($G(UIN)["HB-C")!($G(UIN)["HB-S")!($G(UIN)["HB-D")!($G(UIN)["HB-E")) Y=$$MX(XU) Q:$L($G(Y))
S:XU="DU"&($G(UIN)["Deoxyuridine") Y="dU" Q:$L($G(Y))
S:XU="DU"&($G(UIN)["CHAT") Y=$$LO(XU) Q:$L($G(Y))
S:XU="DU"&(($G(UIN)["POSITIVE")!($G(UIN)["NEGATIVE")!($G(UIN)["ANTIGEN")!($G(UIN)["12")) Y=$$MX(XU) Q:$L($G(Y))
S:XU="DU"&(($G(UIN)["DUODENAL")!($G(UIN)["PERFORATED")!($G(UIN)["ANTIGEN")) Y=XU Q:$L($G(Y))
S:XU="RB"&(($G(UIN)["RUBIDIUM")!($G(UIN)["RETINOBLAST")) Y=$$MX(XU) Q:$L($G(Y))
S:XU="OZ"&(+($G(PRE))>0) Y=$$LO(XU) Q:$L($G(Y))
S:XU="CM"&($G(UIN)["CM-") Y=XU Q:$L($G(Y))
S:XU="IN"&(($G(UIN)["IN/S")!($G(UIN)["INDIUM")) Y=XU Q:$L($G(Y))
S:XU="MN"&($G(UIN)["BLOOD") Y=XU Q:$L($G(Y))
S:XU="RH"&(($G(UIN)'["LH")) Y="Rh" Q:$L($G(Y))
S:XU="GM"&(($G(UIN)["GM/")!($G(UIN)["GM)")!($G(UIN)["/GM")!($E($G(UIN),($L($G(UIN))-2),$L($G(UIN)))[" GM"))&(UIN'["METHYLASE") Y="gm" Q:$L($G(Y))
S:XU="FT"&($G(UIN)["FT-") Y=XU Q:$L($G(Y))
; Special Case
S:X="DA" Y="dA" S:X="DG" Y="dG" S:X="DU" Y="dU" Q:$L($G(Y))
S:X="GB" Y="gB" S:X="GH" Y="gH" S:X="KB" Y="kB" S:X="KD" Y="kD" Q:$L($G(Y))
S:X="PH" Y="pH" S:X="PX" Y="pX" Q:$L($G(Y))
S:$G(UIN)'["GC/"&(X="GC") Y="gC" Q:$L($G(Y))
S:($G(UIN)["OLIGO"!($G(UIN)["POLY"))&(X="DT") Y="dT" Q:$L($G(Y))
; Lower Case
S:$G(UIN)'["IF-"&(+$P($G(UIN),"IF ",2)'>0)&($G(UIN)'["BLOOD GROUP")&($G(UIN)'["IF(")&(X="IF") Y="if" Q:$L($G(Y))
I "^AM^AN^AS^AT^AT^BE^BY^CC^CM^DE^DO^EG^FT^IE^IN^"[("^"_XU_"^") S Y=$$LO(XU) Q
I "^IS^IT^IN^MG^MM^NO^OF^ON^OR^PM^SQ^TO^UP^W/^WO^YL^"[("^"_XU_"^") S Y=$$LO(XU) Q
I $G(UIN)["PER IU"!($E($P($G(UIN)," IU",1),$L($P($G(UIN)," IU",1)))?1N) S:X="IU" Y="iu" Q:$L($G(Y))
I ($G(UIN)["ML/")!($G(UIN)["/ML")!($G(UIN)["PER ML")!($E($P($G(UIN)," ML",1),$L($P($G(UIN)," ML",1)))?1N) S:X="ML" Y="ml" Q:$L($G(Y))
I $G(UIN)["(ML)" S:XU="ML" Y=XU Q:$L($G(Y))
S:($G(UIN)["; EA "!($G(UIN)[", EA ")!($G(UIN)["(EA ")!($G(UIN)[" EA)")!($G(UIN)[" EA ADD")!($G(UIN)[" EA SUB")!($G(UIN)[" EA 1"))&(X="EA") Y="ea" Q:$L($G(Y))
; Mixed Case
I "^ST^"[("^"_XU_"^") S Y=$$MX(XU) Q
; Upper Case
I CHR?1N!("^A^B^C^D^"[("^"_CHR_"^")) D Q:$L($G(Y))
. I "^AA^AB^AC^AD^AF^AG^AH^AI^AK^AM^AP^AR^AV^BA^BB^BC^BE^"[("^"_XU_"^") S Y=XU Q
. I "^BG^BH^BK^BL^BM^BN^BP^BR^BS^BT^BW^BX^CA^CB^CD^CE^CF^"[("^"_XU_"^") S Y=XU Q
. I "^CG^CH^CI^CK^CL^CN^CO^CP^CR^CS^CT^CV^CW^CY^DB^DC^DD^"[("^"_XU_"^") S Y=XU Q
. I "^DG^DI^DL^DM^DN^DP^DQ^DR^DS^DT^DX^"[("^"_XU_"^") S Y=XU Q
I "^E^F^G^H^I^J^K^L^M^"[("^"_CHR_"^") D Q:$L($G(Y))
. I "^EA^EB^EC^EF^EM^EN^EO^EP^ER^ES^ET^EZ^FA^FB^FD^FH^FK^"[("^"_XU_"^") S Y=XU Q
. I "^FO^FR^FU^GA^GC^GI^GL^GM^GP^GR^GS^GT^HA^HB^HC^HE^HF^"[("^"_XU_"^") S Y=XU Q
. I "^HG^HH^HI^HL^HM^HO^HP^HR^HS^HT^HU^HX^IA^IB^IC^ID^IE^"[("^"_XU_"^") S Y=XU Q
. I "^IF^IG^IH^II^IL^IM^IP^IQ^IR^IU^IV^IX^JK^KA^KO^KS^KT^LA^"[("^"_XU_"^") S Y=XU Q
. I "^LC^LD^LE^LF^LH^LL^LO^LP^LR^LS^LT^LU^LV^LY^MA^MB^MC^"[("^"_XU_"^") S Y=XU Q
. I "^MD^ME^MF^MI^MJ^MK^ML^MP^MR^MS^MT^"[("^"_XU_"^") S Y=XU Q
I "^N^O^P^Q^R^S^"[("^"_CHR_"^") D Q:$L($G(Y))
. I "^NA^NB^NC^NF^NG^NH^NK^NL^NO^NP^NR^NS^NT^OC^OD^OE^OH^"[("^"_XU_"^") S Y=XU Q
. I "^OL^OP^OT^OX^PA^PC^PD^PE^PF^PG^PI^PK^PL^PM^PN^PO^PP^"[("^"_XU_"^") S Y=XU Q
. I "^PR^PS^PT^PV^PX^PZ^QA^QT^RA^RB^RC^RF^RG^RH^RI^RN^RO^"[("^"_XU_"^") S Y=XU Q
. I "^RP^RR^RS^RT^RV^RX^SA^SB^SC^SD^SE^SF^SG^SH^SI^SK^SL^"[("^"_XU_"^") S Y=XU Q
. I "^SM^SO^SP^SR^SS^ST^SV^SW^SX^"[("^"_XU_"^") S Y=XU Q
I "^T^U^V^W^X^Y^Z^"[("^"_CHR_"^") D Q:$L($G(Y))
. I "^TA^TB^TC^TD^TF^TH^TI^TK^TL^TP^TR^TS^TT^TX^UD^UK^US^"[("^"_XU_"^") S Y=XU Q
. I "^UV^UV^VA^VC^VC^VH^VI^VI^VO^VP^VR^VS^VV^VW^VX^VZ^WB^WC^"[("^"_XU_"^") S Y=XU Q
. I "^WS^WV^XE^XH^XI^XI^XL^XM^XP^XS^XT^XU^XV^XX^XY^YM^YS^"[("^"_XU_"^") S Y=XU Q
. I "^YY^ZP^ZY^"[("^"_XU_"^") S Y=XU Q
Q
;
LO(X) ; Lower Case
Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
UP(X) ; Uppercase
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
MX(X) ; Mix Case
Q $TR($E(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
LEXXM2 ;ISL/KER - Convert Text to Mix Case (2) ;04/21/2014
+1 ;;2.0;General Lexicon Utilities;**80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; None
+5 ;
+6 ; External References
+7 ; None
+8 ;
+9 ; Local Variables NEWed or KILLed Elsewhere
+10 ; LEXCTL,LEXNXT,LEXORG,LEXPRE,UIN Newed in LEXXM
+11 ; Y Set and returned to LEXXM
+12 ;
T2 ; 2 Characters
+1 NEW XU,CHR,PRE,ORG,NXT
SET ORG=$GET(LEXORG)
SET PRE=$GET(LEXPRE)
SET NXT=$GET(LEXNXT)
SET UIN=$GET(UIN)
SET XU=$$UP(X)
SET CHR=$EXTRACT(XU,1)
+2 ; Exceptions
+3 IF $EXTRACT(XU,1)?1U&($EXTRACT(XU,2)?1N)
SET Y=XU
IF $LENGTH($GET(Y))
QUIT
IF $EXTRACT(XU,1)?1N&($EXTRACT(XU,2)?1U)
SET Y=XU
IF $LENGTH($GET(Y))
QUIT
+4 IF $EXTRACT(XU,($LENGTH(XU)-1),$LENGTH(XU))="CC"
IF $EXTRACT(XU,($LENGTH(XU)-2))?1N
SET Y=$$LO(XU)
QUIT
+5 IF XU="SO"
IF $EXTRACT(NXT,1,7)="STATED "
SET Y=$$LO(X)
QUIT
+6 IF $GET(LEXCTL)["OR ROOM"!($GET(LEXCTL)["OR-ROOM")
SET Y=XU
IF $LENGTH($GET(Y))
QUIT
+7 IF XU="ST"&($GET(PRE)=1)
SET Y="st"
IF XU="ND"&($GET(PRE)=2)
SET Y="nd"
IF XU="RD"&($GET(PRE)=3)
SET Y="rd"
IF XU="TH"&(+($GET(PRE))>3)
SET Y="th"
IF $LENGTH($GET(Y))
QUIT
+8 IF XU="CO"&($GET(UIN)["CO-")
SET Y=$$MX(XU)
IF $LENGTH($GET(Y))
QUIT
+9 IF XU="SO"&(($GET(UIN)["SO STATED")!($GET(UIN)["SO DESCRIBED"))
SET Y=$$LO(XU)
IF $LENGTH($GET(Y))
QUIT
+10 IF XU="SO"&(($GET(UIN)["SHOULDER ORTHOSIS")!($GET(UIN)["SUPERIOR OBLIQUE"))
SET Y=XU
IF $LENGTH($GET(Y))
QUIT
+11 IF XU="HB"&(($GET(UIN)["HB-C")!($GET(UIN)["HB-S")!($GET(UIN)["HB-D")!($GET(UIN)["HB-E"))
SET Y=$$MX(XU)
IF $LENGTH($GET(Y))
QUIT
+12 IF XU="DU"&($GET(UIN)["Deoxyuridine")
SET Y="dU"
IF $LENGTH($GET(Y))
QUIT
+13 IF XU="DU"&($GET(UIN)["CHAT")
SET Y=$$LO(XU)
IF $LENGTH($GET(Y))
QUIT
+14 IF XU="DU"&(($GET(UIN)["POSITIVE")!($GET(UIN)["NEGATIVE")!($GET(UIN)["ANTIGEN")!($GET(UIN)["12"))
SET Y=$$MX(XU)
IF $LENGTH($GET(Y))
QUIT
+15 IF XU="DU"&(($GET(UIN)["DUODENAL")!($GET(UIN)["PERFORATED")!($GET(UIN)["ANTIGEN"))
SET Y=XU
IF $LENGTH($GET(Y))
QUIT
+16 IF XU="RB"&(($GET(UIN)["RUBIDIUM")!($GET(UIN)["RETINOBLAST"))
SET Y=$$MX(XU)
IF $LENGTH($GET(Y))
QUIT
+17 IF XU="OZ"&(+($GET(PRE))>0)
SET Y=$$LO(XU)
IF $LENGTH($GET(Y))
QUIT
+18 IF XU="CM"&($GET(UIN)["CM-")
SET Y=XU
IF $LENGTH($GET(Y))
QUIT
+19 IF XU="IN"&(($GET(UIN)["IN/S")!($GET(UIN)["INDIUM"))
SET Y=XU
IF $LENGTH($GET(Y))
QUIT
+20 IF XU="MN"&($GET(UIN)["BLOOD")
SET Y=XU
IF $LENGTH($GET(Y))
QUIT
+21 IF XU="RH"&(($GET(UIN)'["LH"))
SET Y="Rh"
IF $LENGTH($GET(Y))
QUIT
+22 IF XU="GM"&(($GET(UIN)["GM/")!($GET(UIN)["GM)")!($GET(UIN)["/GM")!($EXTRACT($GET(UIN),($LENGTH($GET(UIN))-2),$LENGTH($GET(UIN)))[" GM"))&(UIN'["METHYLASE")
SET Y="gm"
IF $LENGTH($GET(Y))
QUIT
+23 IF XU="FT"&($GET(UIN)["FT-")
SET Y=XU
IF $LENGTH($GET(Y))
QUIT
+24 ; Special Case
+25 IF X="DA"
SET Y="dA"
IF X="DG"
SET Y="dG"
IF X="DU"
SET Y="dU"
IF $LENGTH($GET(Y))
QUIT
+26 IF X="GB"
SET Y="gB"
IF X="GH"
SET Y="gH"
IF X="KB"
SET Y="kB"
IF X="KD"
SET Y="kD"
IF $LENGTH($GET(Y))
QUIT
+27 IF X="PH"
SET Y="pH"
IF X="PX"
SET Y="pX"
IF $LENGTH($GET(Y))
QUIT
+28 IF $GET(UIN)'["GC/"&(X="GC")
SET Y="gC"
IF $LENGTH($GET(Y))
QUIT
+29 IF ($GET(UIN)["OLIGO"!($GET(UIN)["POLY"))&(X="DT")
SET Y="dT"
IF $LENGTH($GET(Y))
QUIT
+30 ; Lower Case
+31 IF $GET(UIN)'["IF-"&(+$PIECE($GET(UIN),"IF ",2)'>0)&($GET(UIN)'["BLOOD GROUP")&($GET(UIN)'["IF(")&(X="IF")
SET Y="if"
IF $LENGTH($GET(Y))
QUIT
+32 IF "^AM^AN^AS^AT^AT^BE^BY^CC^CM^DE^DO^EG^FT^IE^IN^"[("^"_XU_"^")
SET Y=$$LO(XU)
QUIT
+33 IF "^IS^IT^IN^MG^MM^NO^OF^ON^OR^PM^SQ^TO^UP^W/^WO^YL^"[("^"_XU_"^")
SET Y=$$LO(XU)
QUIT
+34 IF $GET(UIN)["PER IU"!($EXTRACT($PIECE($GET(UIN)," IU",1),$LENGTH($PIECE($GET(UIN)," IU",1)))?1N)
IF X="IU"
SET Y="iu"
IF $LENGTH($GET(Y))
QUIT
+35 IF ($GET(UIN)["ML/")!($GET(UIN)["/ML")!($GET(UIN)["PER ML")!($EXTRACT($PIECE($GET(UIN)," ML",1),$LENGTH($PIECE($GET(UIN)," ML",1)))?1N)
IF X="ML"
SET Y="ml"
IF $LENGTH($GET(Y))
QUIT
+36 IF $GET(UIN)["(ML)"
IF XU="ML"
SET Y=XU
IF $LENGTH($GET(Y))
QUIT
+37 IF ($GET(UIN)["; EA "!($GET(UIN)[", EA ")!($GET(UIN)["(EA ")!($GET(UIN)[" EA)")!($GET(UIN)[" EA ADD")!($GET(UIN)[" EA SUB")!($GET(UIN)[" EA 1"))&(X="EA")
SET Y="ea"
IF $LENGTH($GET(Y))
QUIT
+38 ; Mixed Case
+39 IF "^ST^"[("^"_XU_"^")
SET Y=$$MX(XU)
QUIT
+40 ; Upper Case
+41 IF CHR?1N!("^A^B^C^D^"[("^"_CHR_"^"))
Begin DoDot:1
+42 IF "^AA^AB^AC^AD^AF^AG^AH^AI^AK^AM^AP^AR^AV^BA^BB^BC^BE^"[("^"_XU_"^")
SET Y=XU
QUIT
+43 IF "^BG^BH^BK^BL^BM^BN^BP^BR^BS^BT^BW^BX^CA^CB^CD^CE^CF^"[("^"_XU_"^")
SET Y=XU
QUIT
+44 IF "^CG^CH^CI^CK^CL^CN^CO^CP^CR^CS^CT^CV^CW^CY^DB^DC^DD^"[("^"_XU_"^")
SET Y=XU
QUIT
+45 IF "^DG^DI^DL^DM^DN^DP^DQ^DR^DS^DT^DX^"[("^"_XU_"^")
SET Y=XU
QUIT
End DoDot:1
IF $LENGTH($GET(Y))
QUIT
+46 IF "^E^F^G^H^I^J^K^L^M^"[("^"_CHR_"^")
Begin DoDot:1
+47 IF "^EA^EB^EC^EF^EM^EN^EO^EP^ER^ES^ET^EZ^FA^FB^FD^FH^FK^"[("^"_XU_"^")
SET Y=XU
QUIT
+48 IF "^FO^FR^FU^GA^GC^GI^GL^GM^GP^GR^GS^GT^HA^HB^HC^HE^HF^"[("^"_XU_"^")
SET Y=XU
QUIT
+49 IF "^HG^HH^HI^HL^HM^HO^HP^HR^HS^HT^HU^HX^IA^IB^IC^ID^IE^"[("^"_XU_"^")
SET Y=XU
QUIT
+50 IF "^IF^IG^IH^II^IL^IM^IP^IQ^IR^IU^IV^IX^JK^KA^KO^KS^KT^LA^"[("^"_XU_"^")
SET Y=XU
QUIT
+51 IF "^LC^LD^LE^LF^LH^LL^LO^LP^LR^LS^LT^LU^LV^LY^MA^MB^MC^"[("^"_XU_"^")
SET Y=XU
QUIT
+52 IF "^MD^ME^MF^MI^MJ^MK^ML^MP^MR^MS^MT^"[("^"_XU_"^")
SET Y=XU
QUIT
End DoDot:1
IF $LENGTH($GET(Y))
QUIT
+53 IF "^N^O^P^Q^R^S^"[("^"_CHR_"^")
Begin DoDot:1
+54 IF "^NA^NB^NC^NF^NG^NH^NK^NL^NO^NP^NR^NS^NT^OC^OD^OE^OH^"[("^"_XU_"^")
SET Y=XU
QUIT
+55 IF "^OL^OP^OT^OX^PA^PC^PD^PE^PF^PG^PI^PK^PL^PM^PN^PO^PP^"[("^"_XU_"^")
SET Y=XU
QUIT
+56 IF "^PR^PS^PT^PV^PX^PZ^QA^QT^RA^RB^RC^RF^RG^RH^RI^RN^RO^"[("^"_XU_"^")
SET Y=XU
QUIT
+57 IF "^RP^RR^RS^RT^RV^RX^SA^SB^SC^SD^SE^SF^SG^SH^SI^SK^SL^"[("^"_XU_"^")
SET Y=XU
QUIT
+58 IF "^SM^SO^SP^SR^SS^ST^SV^SW^SX^"[("^"_XU_"^")
SET Y=XU
QUIT
End DoDot:1
IF $LENGTH($GET(Y))
QUIT
+59 IF "^T^U^V^W^X^Y^Z^"[("^"_CHR_"^")
Begin DoDot:1
+60 IF "^TA^TB^TC^TD^TF^TH^TI^TK^TL^TP^TR^TS^TT^TX^UD^UK^US^"[("^"_XU_"^")
SET Y=XU
QUIT
+61 IF "^UV^UV^VA^VC^VC^VH^VI^VI^VO^VP^VR^VS^VV^VW^VX^VZ^WB^WC^"[("^"_XU_"^")
SET Y=XU
QUIT
+62 IF "^WS^WV^XE^XH^XI^XI^XL^XM^XP^XS^XT^XU^XV^XX^XY^YM^YS^"[("^"_XU_"^")
SET Y=XU
QUIT
+63 IF "^YY^ZP^ZY^"[("^"_XU_"^")
SET Y=XU
QUIT
End DoDot:1
IF $LENGTH($GET(Y))
QUIT
+64 QUIT
+65 ;
LO(X) ; Lower Case
+1 QUIT $TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
UP(X) ; Uppercase
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
MX(X) ; Mix Case
+1 QUIT $TRANSLATE($EXTRACT(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$TRANSLATE($EXTRACT(X,2,$LENGTH(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
