LEXXM4 ;ISL/KER - Convert Text to Mix Case (4) ;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,LEXIN,LEXNXT,LEXPRE,LEXUSE Newed in LEXXM
; Y set and returned to LEXXM
;
T4 ; 4 Characters
N XU,CHR,NUM,TRL,PRE,UIN,NXT,USE,P1,P2 S PRE=$G(LEXPRE),NXT=$G(LEXNXT),USE=$G(LEXUSE),UIN=$G(UIN),XU=$$UP(X),CHR=$E(XU,1)
; Exceptions
S P1=$E(XU,1,($L(XU)-2)),P2=$E(XU,($L(XU)-1),$L(XU)) I "^CC^ML^GM^"[("^"_P2_"^"),$E(P1,$L(P1))?1N S Y=$$LO(XU) Q
S NUM=$E(XU,1,2),TRL=$E(XU,3,4) I +NUM=NUM,((TRL="TH")!(TRL="ST")!(TRL="RD")) S Y=$$LO(XU) Q:$L($G(Y))
S:$E(XU,1)?1U&($E(XU,4)?1N) Y=XU Q:$L($G(Y)) S:$E(XU,1)?1N&($E(XU,4)?1U) Y=XU Q:$L($G(Y))
I "SIZE"=XU&(PRE="ANY") S Y=$$LO(X) Q
I XU="MESA",$G(LEXCTL)["(MESA)" S Y=XU Q
S:XU="TRAM"&((UIN["TRANSVERSE")!(UIN["BREAST")) Y=XU Q:$L($G(Y))
S:XU="OPEN"&((UIN["OPEN HEART")) Y=$$MX(XU) Q:$L($G(Y))
S:XU="DRIL"&(UIN["DISTAL REVASCULARIZATION")&(UIN["INTERVAL LIGATION") Y=$$UP(XU) Q:$L($G(Y))
S:XU="TRAM"&((UIN["PROTEIN")!(UIN["GENE")!(UIN["ENDOPLASMIC RETICULUM"))&(UIN'["ACCIDENT")&(UIN'["VEHICLE") Y="TraM" Q:$L($G(Y))
S:XU="TIPS"&($G(LEXIN)["(TIPS)") Y=XU S:XU="TIPS"&($G(LEXCTL)["(TIPS") Y=XU S:XU="TIPS"&($G(LEXCTL)["TIPS)") Y=XU Q:$L($G(Y))
; Special Case
S:XU="APOA" Y="ApoA" S:XU="BBVI" Y="BbvI" S:XU="BPTH" Y="bPTH" Q:$L($G(Y))
S:XU="BSUE" Y="BsuE" S:XU="PCO2" Y="pCO2" S:XU="CGMP" Y="cGMP" Q:$L($G(Y))
S:XU="COTE" Y="CotE" S:XU="DATP" Y="dATP" S:XU="DCMP" Y="dCMP" Q:$L($G(Y))
S:XU="DCTP" Y="dCTP" S:XU="DGMP" Y="dGMP" S:XU="DGTP" Y="dGTP" Q:$L($G(Y))
S:XU="DSBA" Y="dsbA" S:XU="DTDP" Y="dTDP" S:XU="DTTP" Y="dTTP" Q:$L($G(Y))
S:XU="DUMP" Y="dUMP" S:XU="DURD" Y="dUrd" S:XU="DUTP" Y="dUTP" Q:$L($G(Y))
S:XU="ECAI" Y="EcaI" S:XU="ECOK" Y="EcoK" S:XU="ERBB" Y="erbB" Q:$L($G(Y))
S:XU="FELV" Y="FeLV" S:XU="FMET" Y="fMet" S:XU="GNRH" Y="GnRH" Q:$L($G(Y))
S:XU="GPII" Y="gpII" S:XU="HARG" Y="hArg" S:XU="HELA" Y="HeLa" Q:$L($G(Y))
S:XU="HGRF" Y="hGRF" S:XU="HHAI" Y="HhaI" S:XU="HPAI" Y="HpaI" Q:$L($G(Y))
S:XU="HPTH" Y="hPTH" S:XU="KPNI" Y="KpnI" S:XU="MCRB" Y="McrB" Q:$L($G(Y))
S:XU="MESH" Y="MeSH" S:XU="MRNA" Y="mRNA" S:XU="NHET" Y="NHEt" Q:$L($G(Y))
S:XU="NHME" Y="NHMe" S:XU="OBZL" Y="OBzl" S:XU="OTBU" Y="OtBu" Q:$L($G(Y))
S:XU="PGLU" Y="pGlu" S:XU="PSTI" Y="PstI" S:XU="REGA" Y="regA" Q:$L($G(Y))
S:XU="RRNA" Y="rRNA" S:XU="SCEI" Y="SceI" S:XU="TAQI" Y="TaqI" Q:$L($G(Y))
S:XU="TRFA" Y="TrfA" S:XU="TRKA" Y="trkA" S:XU="TRKB" Y="trkB" Q:$L($G(Y))
S:XU="TRNA" Y="tRNA" Q:$L($G(Y))
; Lower Case
I "LESS"=XU&($E(NXT,1,4)="THAN") S Y=$$LO(X) Q
I "^ALSO^AREA^BEEN^BEST^DONE^DTMN^EACH^EVEN^FIVE^FOUR^FROM^"[("^"_XU_"^") S Y=$$LO(X) Q
I "^HAVE^HERE^HOUR^INTO^IT'S^KIND^LATE^LEFT^LESS^LIKE^LOST^"[("^"_XU_"^") S Y=$$LO(X) Q
I "^MANY^MERE^MORE^MOST^MUST^NINE^NOTE^ONLY^OPEN^OURS^OVER^"[("^"_XU_"^") S Y=$$LO(X) Q
I "^PART^PLUS^SAME^SEEN^SITE^SOME^SUCH^SURE^TAKE^THAN^THAN^"[("^"_XU_"^") S Y=$$LO(X) Q
I "^THAT^THEN^THEY^THIS^THUS^UPON^USED^WERE^WHAT^WHEN^WHOM^"[("^"_XU_"^") S Y=$$LO(X) Q
I "^WITH^"[("^"_XU_"^") S Y=$$LO(X) Q
; Mixed Case
I "^BATH^CITH^CITY^EAST^ERIE^FORT^HOME^IOWA^IRON^JUAN^JULY^"[("^"_XU_"^") S Y=$$MX(X) Q
I "^JUNE^KELL^LAKE^LOMA^LONG^LYON^PALM^PALO^PARK^RENO^ROCK^"[("^"_XU_"^") S Y=$$MX(X) Q
I "^SALT^SIDE^TYPE^WACO^WEST^YORK^"[("^"_XU_"^") S Y=$$MX(X) Q
; Uppercase
I CHR?1N!("^A^B^C^D^E^F^"[("^"_CHR_"^")) D Q:$L($G(Y))
. I "^A1B5^A1BG^A4A7^A4A8^A6K7^ABL1^AICD^ABSV^ACKQ^ACTH^AIDS^AJCC^"[("^"_XU_"^") S Y=XU Q
. I "^ALLA^AML1^ANCA^ANIT^ARPP^ASHD^ASPE^ATLV^BADR^BCL2^BDEM^"[("^"_XU_"^") S Y=XU Q
. I "^BMIC^BMWD^BPDE^BPDE^BUSI^CABG^CAP1^CAP2^CAPD^CBFB^CCPD^"[("^"_XU_"^") S Y=XU Q
. I "^CD34^CENP^CGRP^CHCT^COOH^COPD^CORF^CPAP^CPAP^CPEP^CPRS^"[("^"_XU_"^") S Y=XU Q
. I "^CPT1^CPT2^CRNA^CROS^DENT^DEXA^DGGE^DGHI^DGPW^DGY1^DGY3^"[("^"_XU_"^") S Y=XU Q
. I "^DGYA^DGYB^DGYC^DGYD^DGYF^DGYG^DGYJ^DGYK^DGYL^DGYN^DGYO^"[("^"_XU_"^") S Y=XU Q
. I "^DGYP^DGYQ^DGYR^DGYS^DGYU^DGYV^DGYW^DGYX^DGYZ^DHEA^DIPK^"[("^"_XU_"^") S Y=XU Q
. I "^DMAC^DMBA^DMBA^DMSO^DOPS^DSAP^DSIP^DTAP^DTPA^DVBA^DVBC^"[("^"_XU_"^") S Y=XU Q
. I "^DVBQ^DVBT^DVBU^DVBW^DVBX^DVBY^EADT^EBNA^EBUS^ECMO^EDTA^"[("^"_XU_"^") S Y=XU Q
. I "^EEOA^EEOP^ENXE^ENXF^ENXG^ENXI^ENXJ^ENXK^ERCC^ERCP^ERCP^"[("^"_XU_"^") S Y=XU Q
. I "^ESRD^ESRD^ESWL^ETV1^ETV6^FANA^FBAA^FEV1^FITC^FKBP^FLI1^"[("^"_XU_"^") S Y=XU Q
. I "^FP22^"[("^"_XU_"^") S Y=XU Q
I "^G^H^I^J^K^L^"[("^"_CHR_"^") D Q:$L($G(Y))
. I "^GABA^GATA^GECD^GECP^GECS^GERD^GHRH^GJB2^GLUT^GMAA^GMD1^"[("^"_XU_"^") S Y=XU Q
. I "^GMN1^GMN2^GMN3^GMN4^GMN5^GMPL^GMPT^GMRA^GMRC^GMRD^GMRE^"[("^"_XU_"^") S Y=XU Q
. I "^GMRG^GMRP^GMRQ^GMRR^GMRS^GMRV^GMRY^GP22^GRSA^GYKI^HBHC^"[("^"_XU_"^") S Y=XU Q
. I "^HBIG^HCFA^HCMV^HCO2^HETE^HIAA^HIDA^HISA^HLPC^HMSN^HPLC^"[("^"_XU_"^") S Y=XU Q
. I "^HPSA^HSAN^HTLV^IADL^IBDE^IBDP^IBQL^IBQY^IBY3^IBY4^IBY5^"[("^"_XU_"^") S Y=XU Q
. I "^IBY6^IBY7^IBY8^IBY9^IBYA^IBYB^IBYC^IBYD^IBYE^IBYF^IBYG^"[("^"_XU_"^") S Y=XU Q
. I "^IBYH^IBYK^IBYL^IBYN^ICPT^IDDM^IGIV^IIIA^IIIA^IIIB^IIIC^"[("^"_XU_"^") S Y=XU Q
. I "^IIID^IIIE^IMRT^INTP^IPPB^IPPB^ISUP^KAFO^LATS^LBRN^LBRT^"[("^"_XU_"^") S Y=XU Q
. I "^LBRY^LEXX^LHRH^LR00^LR01^LR03^LRAR^LRLS^LTCH^LVEF^"[("^"_XU_"^") S Y=XU Q
I "^M^N^O^P^Q^"[("^"_CHR_"^") D Q:$L($G(Y))
. I "^MAGE^MAGI^MCAD^MCXX^MEDA^MEDB^MEDC^MEDF^MESA^MESH^MHPE^"[("^"_XU_"^") S Y=XU Q
. I "^MIBB^MLH1^MLH1^MLH2^MLH3^MLH4^MLH5^MLVP^MMPI^MMRV^MPTP^"[("^"_XU_"^") S Y=XU Q
. I "^MPTP^MPTP^MQSA^MRCP^MRSA^MSH1^MSH2^MSH3^MSH4^MSH5^MSH6^"[("^"_XU_"^") S Y=XU Q
. I "^MSLT^MTLU^MYCN^NADH^NADP^NAPS^NARP^NBDC^NETT^NETT^NGFI^"[("^"_XU_"^") S Y=XU Q
. I "^NIST^NMES^NRDC^NSCL^NURA^NURC^NURE^NURQ^NURX^OERR^OHCS^"[("^"_XU_"^") S Y=XU Q
. I "^ONCO^PABA^PAPP^PAPS^PAX3^PAX7^PDAC^PICC^PLA1^PLA2^PLA3^"[("^"_XU_"^") S Y=XU Q
. I "^PMMA^POMC^PORP^PRCA^PRCP^PRMQ^PRPF^PRSX^PRX0^PRX1^PRX8^"[("^"_XU_"^") S Y=XU Q
. I "^PRXB^PRXC^PRXE^PRXF^PRXG^PRXI^PRXJ^PRXK^PRXP^PRYA^PRYB^"[("^"_XU_"^") S Y=XU Q
. I "^PRYC^PRYD^PRYF^PRYH^PRYJ^PRYL^PRYN^PRYP^PSA1^PSAP^PSD1^"[("^"_XU_"^") S Y=XU Q
. I "^PSGW^PSIV^PSJ1^PSJ4^PSOA^PSOB^PSOC^PSOD^PSOE^PSOG^PSOH^"[("^"_XU_"^") S Y=XU Q
. I "^PSOJ^PSOL^PSOY^PSW1^PSXC^PTCA^PTEN^PTSD^PUVA^PUVB^QAN1^"[("^"_XU_"^") S Y=XU Q
. I "^QAR1^QAR2^QARF^QARY^"[("^"_XU_"^") S Y=XU Q
I "^R^S^T^U^V^W^X^Y^Z^"[("^"_CHR_"^") D Q:$L($G(Y))
. I "^RAAA^RAAB^RAAC^RAAE^RAAF^RARA^RAST^RMPC^RMPF^RMPJ^RMPR^RMPT^"[("^"_XU_"^") S Y=XU Q
. I "^RTEM^RTYB^RTYC^RTYD^RVEF^RXIV^RXOP^RXUD^SARS^SACH^SBCE^SCAD^"[("^"_XU_"^") S Y=XU Q
. I "^SCL1^SCL2^SDHB^SDHD^SDYA^SDYM^SDYN^SDYP^SEXA^SGOT^SGPT^"[("^"_XU_"^") S Y=XU Q
. I "^SHBG^SIRS^SISI^SMAR^SNAP^SOWA^SOWC^SOWK^SRIF^SRIH^SROA^"[("^"_XU_"^") S Y=XU Q
. I "^SRRS^SRRT^SSCP^SSX1^SSX2^TAPA^TATA^TCDD^TCDD^TCF3^TDAP^"[("^"_XU_"^") S Y=XU Q
. I "^TENS^TFE3^THBR^TIMP^TIUJ^TIUW^TIUX^TLSO^TLSO^TORP^TP53^"[("^"_XU_"^") S Y=XU Q
. I "^UDPG^UMLS^VALM^VAPR^VDDR^VEEM^VIIA^VIII^VLDL^VRSA^VSIT^"[("^"_XU_"^") S Y=XU Q
. I "^WHFO^WMMT^XIII^XQOR^XUFI^XVII^XXII^YS01^ZIFT^"[("^"_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")
LD(X) ; Leading Character
Q $TR($E(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$E(X,2,$L(X))
TRIM(X) ; Trim Spaces
S X=$G(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
LEXXM4 ;ISL/KER - Convert Text to Mix Case (4) ;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,LEXIN,LEXNXT,LEXPRE,LEXUSE Newed in LEXXM
+11 ; Y set and returned to LEXXM
+12 ;
T4 ; 4 Characters
+1 NEW XU,CHR,NUM,TRL,PRE,UIN,NXT,USE,P1,P2
SET PRE=$GET(LEXPRE)
SET NXT=$GET(LEXNXT)
SET USE=$GET(LEXUSE)
SET UIN=$GET(UIN)
SET XU=$$UP(X)
SET CHR=$EXTRACT(XU,1)
+2 ; Exceptions
+3 SET P1=$EXTRACT(XU,1,($LENGTH(XU)-2))
SET P2=$EXTRACT(XU,($LENGTH(XU)-1),$LENGTH(XU))
IF "^CC^ML^GM^"[("^"_P2_"^")
IF $EXTRACT(P1,$LENGTH(P1))?1N
SET Y=$$LO(XU)
QUIT
+4 SET NUM=$EXTRACT(XU,1,2)
SET TRL=$EXTRACT(XU,3,4)
IF +NUM=NUM
IF ((TRL="TH")!(TRL="ST")!(TRL="RD"))
SET Y=$$LO(XU)
IF $LENGTH($GET(Y))
QUIT
+5 IF $EXTRACT(XU,1)?1U&($EXTRACT(XU,4)?1N)
SET Y=XU
IF $LENGTH($GET(Y))
QUIT
IF $EXTRACT(XU,1)?1N&($EXTRACT(XU,4)?1U)
SET Y=XU
IF $LENGTH($GET(Y))
QUIT
+6 IF "SIZE"=XU&(PRE="ANY")
SET Y=$$LO(X)
QUIT
+7 IF XU="MESA"
IF $GET(LEXCTL)["(MESA)"
SET Y=XU
QUIT
+8 IF XU="TRAM"&((UIN["TRANSVERSE")!(UIN["BREAST"))
SET Y=XU
IF $LENGTH($GET(Y))
QUIT
+9 IF XU="OPEN"&((UIN["OPEN HEART"))
SET Y=$$MX(XU)
IF $LENGTH($GET(Y))
QUIT
+10 IF XU="DRIL"&(UIN["DISTAL REVASCULARIZATION")&(UIN["INTERVAL LIGATION")
SET Y=$$UP(XU)
IF $LENGTH($GET(Y))
QUIT
+11 IF XU="TRAM"&((UIN["PROTEIN")!(UIN["GENE")!(UIN["ENDOPLASMIC RETICULUM"))&(UIN'["ACCIDENT")&(UIN'["VEHICLE")
SET Y="TraM"
IF $LENGTH($GET(Y))
QUIT
+12 IF XU="TIPS"&($GET(LEXIN)["(TIPS)")
SET Y=XU
IF XU="TIPS"&($GET(LEXCTL)["(TIPS")
SET Y=XU
IF XU="TIPS"&($GET(LEXCTL)["TIPS)")
SET Y=XU
IF $LENGTH($GET(Y))
QUIT
+13 ; Special Case
+14 IF XU="APOA"
SET Y="ApoA"
IF XU="BBVI"
SET Y="BbvI"
IF XU="BPTH"
SET Y="bPTH"
IF $LENGTH($GET(Y))
QUIT
+15 IF XU="BSUE"
SET Y="BsuE"
IF XU="PCO2"
SET Y="pCO2"
IF XU="CGMP"
SET Y="cGMP"
IF $LENGTH($GET(Y))
QUIT
+16 IF XU="COTE"
SET Y="CotE"
IF XU="DATP"
SET Y="dATP"
IF XU="DCMP"
SET Y="dCMP"
IF $LENGTH($GET(Y))
QUIT
+17 IF XU="DCTP"
SET Y="dCTP"
IF XU="DGMP"
SET Y="dGMP"
IF XU="DGTP"
SET Y="dGTP"
IF $LENGTH($GET(Y))
QUIT
+18 IF XU="DSBA"
SET Y="dsbA"
IF XU="DTDP"
SET Y="dTDP"
IF XU="DTTP"
SET Y="dTTP"
IF $LENGTH($GET(Y))
QUIT
+19 IF XU="DUMP"
SET Y="dUMP"
IF XU="DURD"
SET Y="dUrd"
IF XU="DUTP"
SET Y="dUTP"
IF $LENGTH($GET(Y))
QUIT
+20 IF XU="ECAI"
SET Y="EcaI"
IF XU="ECOK"
SET Y="EcoK"
IF XU="ERBB"
SET Y="erbB"
IF $LENGTH($GET(Y))
QUIT
+21 IF XU="FELV"
SET Y="FeLV"
IF XU="FMET"
SET Y="fMet"
IF XU="GNRH"
SET Y="GnRH"
IF $LENGTH($GET(Y))
QUIT
+22 IF XU="GPII"
SET Y="gpII"
IF XU="HARG"
SET Y="hArg"
IF XU="HELA"
SET Y="HeLa"
IF $LENGTH($GET(Y))
QUIT
+23 IF XU="HGRF"
SET Y="hGRF"
IF XU="HHAI"
SET Y="HhaI"
IF XU="HPAI"
SET Y="HpaI"
IF $LENGTH($GET(Y))
QUIT
+24 IF XU="HPTH"
SET Y="hPTH"
IF XU="KPNI"
SET Y="KpnI"
IF XU="MCRB"
SET Y="McrB"
IF $LENGTH($GET(Y))
QUIT
+25 IF XU="MESH"
SET Y="MeSH"
IF XU="MRNA"
SET Y="mRNA"
IF XU="NHET"
SET Y="NHEt"
IF $LENGTH($GET(Y))
QUIT
+26 IF XU="NHME"
SET Y="NHMe"
IF XU="OBZL"
SET Y="OBzl"
IF XU="OTBU"
SET Y="OtBu"
IF $LENGTH($GET(Y))
QUIT
+27 IF XU="PGLU"
SET Y="pGlu"
IF XU="PSTI"
SET Y="PstI"
IF XU="REGA"
SET Y="regA"
IF $LENGTH($GET(Y))
QUIT
+28 IF XU="RRNA"
SET Y="rRNA"
IF XU="SCEI"
SET Y="SceI"
IF XU="TAQI"
SET Y="TaqI"
IF $LENGTH($GET(Y))
QUIT
+29 IF XU="TRFA"
SET Y="TrfA"
IF XU="TRKA"
SET Y="trkA"
IF XU="TRKB"
SET Y="trkB"
IF $LENGTH($GET(Y))
QUIT
+30 IF XU="TRNA"
SET Y="tRNA"
IF $LENGTH($GET(Y))
QUIT
+31 ; Lower Case
+32 IF "LESS"=XU&($EXTRACT(NXT,1,4)="THAN")
SET Y=$$LO(X)
QUIT
+33 IF "^ALSO^AREA^BEEN^BEST^DONE^DTMN^EACH^EVEN^FIVE^FOUR^FROM^"[("^"_XU_"^")
SET Y=$$LO(X)
QUIT
+34 IF "^HAVE^HERE^HOUR^INTO^IT'S^KIND^LATE^LEFT^LESS^LIKE^LOST^"[("^"_XU_"^")
SET Y=$$LO(X)
QUIT
+35 IF "^MANY^MERE^MORE^MOST^MUST^NINE^NOTE^ONLY^OPEN^OURS^OVER^"[("^"_XU_"^")
SET Y=$$LO(X)
QUIT
+36 IF "^PART^PLUS^SAME^SEEN^SITE^SOME^SUCH^SURE^TAKE^THAN^THAN^"[("^"_XU_"^")
SET Y=$$LO(X)
QUIT
+37 IF "^THAT^THEN^THEY^THIS^THUS^UPON^USED^WERE^WHAT^WHEN^WHOM^"[("^"_XU_"^")
SET Y=$$LO(X)
QUIT
+38 IF "^WITH^"[("^"_XU_"^")
SET Y=$$LO(X)
QUIT
+39 ; Mixed Case
+40 IF "^BATH^CITH^CITY^EAST^ERIE^FORT^HOME^IOWA^IRON^JUAN^JULY^"[("^"_XU_"^")
SET Y=$$MX(X)
QUIT
+41 IF "^JUNE^KELL^LAKE^LOMA^LONG^LYON^PALM^PALO^PARK^RENO^ROCK^"[("^"_XU_"^")
SET Y=$$MX(X)
QUIT
+42 IF "^SALT^SIDE^TYPE^WACO^WEST^YORK^"[("^"_XU_"^")
SET Y=$$MX(X)
QUIT
+43 ; Uppercase
+44 IF CHR?1N!("^A^B^C^D^E^F^"[("^"_CHR_"^"))
Begin DoDot:1
+45 IF "^A1B5^A1BG^A4A7^A4A8^A6K7^ABL1^AICD^ABSV^ACKQ^ACTH^AIDS^AJCC^"[("^"_XU_"^")
SET Y=XU
QUIT
+46 IF "^ALLA^AML1^ANCA^ANIT^ARPP^ASHD^ASPE^ATLV^BADR^BCL2^BDEM^"[("^"_XU_"^")
SET Y=XU
QUIT
+47 IF "^BMIC^BMWD^BPDE^BPDE^BUSI^CABG^CAP1^CAP2^CAPD^CBFB^CCPD^"[("^"_XU_"^")
SET Y=XU
QUIT
+48 IF "^CD34^CENP^CGRP^CHCT^COOH^COPD^CORF^CPAP^CPAP^CPEP^CPRS^"[("^"_XU_"^")
SET Y=XU
QUIT
+49 IF "^CPT1^CPT2^CRNA^CROS^DENT^DEXA^DGGE^DGHI^DGPW^DGY1^DGY3^"[("^"_XU_"^")
SET Y=XU
QUIT
+50 IF "^DGYA^DGYB^DGYC^DGYD^DGYF^DGYG^DGYJ^DGYK^DGYL^DGYN^DGYO^"[("^"_XU_"^")
SET Y=XU
QUIT
+51 IF "^DGYP^DGYQ^DGYR^DGYS^DGYU^DGYV^DGYW^DGYX^DGYZ^DHEA^DIPK^"[("^"_XU_"^")
SET Y=XU
QUIT
+52 IF "^DMAC^DMBA^DMBA^DMSO^DOPS^DSAP^DSIP^DTAP^DTPA^DVBA^DVBC^"[("^"_XU_"^")
SET Y=XU
QUIT
+53 IF "^DVBQ^DVBT^DVBU^DVBW^DVBX^DVBY^EADT^EBNA^EBUS^ECMO^EDTA^"[("^"_XU_"^")
SET Y=XU
QUIT
+54 IF "^EEOA^EEOP^ENXE^ENXF^ENXG^ENXI^ENXJ^ENXK^ERCC^ERCP^ERCP^"[("^"_XU_"^")
SET Y=XU
QUIT
+55 IF "^ESRD^ESRD^ESWL^ETV1^ETV6^FANA^FBAA^FEV1^FITC^FKBP^FLI1^"[("^"_XU_"^")
SET Y=XU
QUIT
+56 IF "^FP22^"[("^"_XU_"^")
SET Y=XU
QUIT
End DoDot:1
IF $LENGTH($GET(Y))
QUIT
+57 IF "^G^H^I^J^K^L^"[("^"_CHR_"^")
Begin DoDot:1
+58 IF "^GABA^GATA^GECD^GECP^GECS^GERD^GHRH^GJB2^GLUT^GMAA^GMD1^"[("^"_XU_"^")
SET Y=XU
QUIT
+59 IF "^GMN1^GMN2^GMN3^GMN4^GMN5^GMPL^GMPT^GMRA^GMRC^GMRD^GMRE^"[("^"_XU_"^")
SET Y=XU
QUIT
+60 IF "^GMRG^GMRP^GMRQ^GMRR^GMRS^GMRV^GMRY^GP22^GRSA^GYKI^HBHC^"[("^"_XU_"^")
SET Y=XU
QUIT
+61 IF "^HBIG^HCFA^HCMV^HCO2^HETE^HIAA^HIDA^HISA^HLPC^HMSN^HPLC^"[("^"_XU_"^")
SET Y=XU
QUIT
+62 IF "^HPSA^HSAN^HTLV^IADL^IBDE^IBDP^IBQL^IBQY^IBY3^IBY4^IBY5^"[("^"_XU_"^")
SET Y=XU
QUIT
+63 IF "^IBY6^IBY7^IBY8^IBY9^IBYA^IBYB^IBYC^IBYD^IBYE^IBYF^IBYG^"[("^"_XU_"^")
SET Y=XU
QUIT
+64 IF "^IBYH^IBYK^IBYL^IBYN^ICPT^IDDM^IGIV^IIIA^IIIA^IIIB^IIIC^"[("^"_XU_"^")
SET Y=XU
QUIT
+65 IF "^IIID^IIIE^IMRT^INTP^IPPB^IPPB^ISUP^KAFO^LATS^LBRN^LBRT^"[("^"_XU_"^")
SET Y=XU
QUIT
+66 IF "^LBRY^LEXX^LHRH^LR00^LR01^LR03^LRAR^LRLS^LTCH^LVEF^"[("^"_XU_"^")
SET Y=XU
QUIT
End DoDot:1
IF $LENGTH($GET(Y))
QUIT
+67 IF "^M^N^O^P^Q^"[("^"_CHR_"^")
Begin DoDot:1
+68 IF "^MAGE^MAGI^MCAD^MCXX^MEDA^MEDB^MEDC^MEDF^MESA^MESH^MHPE^"[("^"_XU_"^")
SET Y=XU
QUIT
+69 IF "^MIBB^MLH1^MLH1^MLH2^MLH3^MLH4^MLH5^MLVP^MMPI^MMRV^MPTP^"[("^"_XU_"^")
SET Y=XU
QUIT
+70 IF "^MPTP^MPTP^MQSA^MRCP^MRSA^MSH1^MSH2^MSH3^MSH4^MSH5^MSH6^"[("^"_XU_"^")
SET Y=XU
QUIT
+71 IF "^MSLT^MTLU^MYCN^NADH^NADP^NAPS^NARP^NBDC^NETT^NETT^NGFI^"[("^"_XU_"^")
SET Y=XU
QUIT
+72 IF "^NIST^NMES^NRDC^NSCL^NURA^NURC^NURE^NURQ^NURX^OERR^OHCS^"[("^"_XU_"^")
SET Y=XU
QUIT
+73 IF "^ONCO^PABA^PAPP^PAPS^PAX3^PAX7^PDAC^PICC^PLA1^PLA2^PLA3^"[("^"_XU_"^")
SET Y=XU
QUIT
+74 IF "^PMMA^POMC^PORP^PRCA^PRCP^PRMQ^PRPF^PRSX^PRX0^PRX1^PRX8^"[("^"_XU_"^")
SET Y=XU
QUIT
+75 IF "^PRXB^PRXC^PRXE^PRXF^PRXG^PRXI^PRXJ^PRXK^PRXP^PRYA^PRYB^"[("^"_XU_"^")
SET Y=XU
QUIT
+76 IF "^PRYC^PRYD^PRYF^PRYH^PRYJ^PRYL^PRYN^PRYP^PSA1^PSAP^PSD1^"[("^"_XU_"^")
SET Y=XU
QUIT
+77 IF "^PSGW^PSIV^PSJ1^PSJ4^PSOA^PSOB^PSOC^PSOD^PSOE^PSOG^PSOH^"[("^"_XU_"^")
SET Y=XU
QUIT
+78 IF "^PSOJ^PSOL^PSOY^PSW1^PSXC^PTCA^PTEN^PTSD^PUVA^PUVB^QAN1^"[("^"_XU_"^")
SET Y=XU
QUIT
+79 IF "^QAR1^QAR2^QARF^QARY^"[("^"_XU_"^")
SET Y=XU
QUIT
End DoDot:1
IF $LENGTH($GET(Y))
QUIT
+80 IF "^R^S^T^U^V^W^X^Y^Z^"[("^"_CHR_"^")
Begin DoDot:1
+81 IF "^RAAA^RAAB^RAAC^RAAE^RAAF^RARA^RAST^RMPC^RMPF^RMPJ^RMPR^RMPT^"[("^"_XU_"^")
SET Y=XU
QUIT
+82 IF "^RTEM^RTYB^RTYC^RTYD^RVEF^RXIV^RXOP^RXUD^SARS^SACH^SBCE^SCAD^"[("^"_XU_"^")
SET Y=XU
QUIT
+83 IF "^SCL1^SCL2^SDHB^SDHD^SDYA^SDYM^SDYN^SDYP^SEXA^SGOT^SGPT^"[("^"_XU_"^")
SET Y=XU
QUIT
+84 IF "^SHBG^SIRS^SISI^SMAR^SNAP^SOWA^SOWC^SOWK^SRIF^SRIH^SROA^"[("^"_XU_"^")
SET Y=XU
QUIT
+85 IF "^SRRS^SRRT^SSCP^SSX1^SSX2^TAPA^TATA^TCDD^TCDD^TCF3^TDAP^"[("^"_XU_"^")
SET Y=XU
QUIT
+86 IF "^TENS^TFE3^THBR^TIMP^TIUJ^TIUW^TIUX^TLSO^TLSO^TORP^TP53^"[("^"_XU_"^")
SET Y=XU
QUIT
+87 IF "^UDPG^UMLS^VALM^VAPR^VDDR^VEEM^VIIA^VIII^VLDL^VRSA^VSIT^"[("^"_XU_"^")
SET Y=XU
QUIT
+88 IF "^WHFO^WMMT^XIII^XQOR^XUFI^XVII^XXII^YS01^ZIFT^"[("^"_XU_"^")
SET Y=XU
QUIT
End DoDot:1
IF $LENGTH($GET(Y))
QUIT
+89 QUIT
+90 ;
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")
LD(X) ; Leading Character
+1 QUIT $TRANSLATE($EXTRACT(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$EXTRACT(X,2,$LENGTH(X))
TRIM(X) ; Trim Spaces
+1 SET X=$GET(X)
FOR
IF $EXTRACT(X,1)'=" "
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
IF $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 QUIT X
