LEXXM1 ;ISL/KER - Convert Text to Mix Case (1) ;12/19/2014
;;2.0;General Lexicon Utilities;**80,86**;Sep 23, 1996;Build 1
;
; Global Variables
; None
;
; External References
; None
;
; Local Variables NEWed or KILLed Elsewhere
; LEXNXT,LEXUSE
;
T1 ; 1 Character
N XU,CHR,PRE,LEXPRE,UIN,NXT,USE S PRE=$G(LEXPRE),UIN=$G(UIN),NXT=$G(LEXNXT),USE=$G(LEXUSE) S XU=$$UP(X),CHR=$E(XU,1)
S:XU="W"&(($G(UIN)["W/WO")!($G(UIN)["W/")) Y=$$LO(XU) Q:$L($G(Y))
; Special Case "A"
S Y="" I XU="A",$E(NXT,1,7)["SINGLE" S Y=$$LO(XU) Q
I $D(UIN),"^A^"[("^"_XU_"^"),(" "_UIN_" ")[(" "_XU_" ") D Q:$L($G(Y))
. N UP S Y=XU Q:UIN[" A OR V " Q:UIN[" T AND A " Q:UIN[" A & E" Q:UIN[" A OR B" Q:UIN["O>HM< A" S UP=$$UPA(XU,PRE,UIN) S:+UP'>0 Y=$$LO(XU)
; Special Case W/O
I "^O^W^"[("^"_XU_"^")&(UIN["W/O") S Y=$$LO(XU) Q
I "^G^"[("^"_XU_"^")&(+($G(PRE))>0) S Y=$$LO(XU) Q
; Uppercase
I "^B^C^D^E^F^G^H^I^J^K^L^M^N^O^P^Q^R^S^T^U^V^X^Y^Z^"[("^"_XU_"^") S Y=XU Q
Q
;
UPA(X,Y,Z) ; Check if "A" is Uppercase A
N CHR,FIR,OK,PRE,UP,W,XU
S XU=$G(X),PRE=$G(Y),UIN=$G(Z),FIR=$A($E(PRE,1))
S OK=1 Q:UIN[" A OR V " 1 Q:UIN[" T and A " 1 Q:UIN[" A & E" 1 Q:UIN[" A OR B" 1 Q:UIN["O>HM< A" 1 Q:PRE="&" 1
S OK=0 I FIR<66 F W="ACETYLGLUCOSAMINIDASE","ACETYLHEXOSAMINIDASE","ACTIONS","ACTIVIN","ACYLCOENZYME","AKIYAMI","ALDOLASE","AMINOPEPTIDASE" S:PRE=W OK=1
Q:OK=1 1 I FIR<66 F W="AMPHOTERICIN","AMYLOID","ANOPHELES","ANTI","ANTIBODY","ANTIGEN","APHTHOVIRUS","APOLIPOPROTEIN","APOLIPOPROTEINS","ARYLSULFATASE" S:PRE=W OK=1
Q:OK=1 1 I FIR<68 F W="ATTRIBUTE","ATTRIBUTES","AUXIN","AZURE","BACITRACIN","BIOVAR","BISPHENOL","BOTULINIUM","BOTULINUM","CARBOMYCIN","CARBOXYPEPTIDASE" S:PRE=W OK=1
Q:OK=1 1 I FIR>66,FIR<68 F W="CARMOISINE","CAROTID","CATEGORY","CHROMOGRANIN","CHYMOTRYPSIN","CICLOSPORIN","CLASS","CLINIC","CLUSTER","COBALAMIN","COENZYME" S:PRE=W OK=1
Q:OK=1 1 I FIR>66,FIR<70 F W="COMPOUND","CON","CONCANAVALIN","CORONARY","COXSACKIE","COXSACKIEVIRUS","CYCLOSPORIN","DIPEPTIDASE","DNASE","DOUBLE","ENTEROTOXIN" S:PRE=W OK=1
Q:OK=1 1 I FIR>68,FIR<72 F W="ENZYMES","EQUIZOLE","FEEDS","FIBRINOPEPTIDE","FIBRINOPEPTIDES","FORMULA","GALACTOSIDASE","GELATINASE","GENUS","GLYCOPHORIN","GP" S:PRE=W OK=1
Q:OK=1 1 I FIR>70,FIR<73 F W="GRADE","GRANZYME","GROUP","HAEMOGLOBIN","HAEMOPHILIA","HB","HEMOGLOBIN","HEMOPHILIA","HEP","HEPATITIS","HEXOSAMINIDASE","HLA","HPFH" S:PRE=W OK=1
Q:OK=1 1 I FIR>71,FIR<74 F W="HYPERVITAMINOSIS","HYPOGLYCIN","HYPOVITAMINOSIS","I","II","III","IMMUNOGLOBULIN","INDEX","INFLUENZA","INFLUENZAE","INFLUENZAVIRUS" S:PRE=W OK=1
Q:OK=1 1 I FIR>72,FIR<78 F W="INHIBIN","IV","JEC","LANTADENE","LASALOCID","LEFT","LEPROMIN","LEUKOTRIENE","LEVEL","LIPOPROTEIN","LOCUS","MED","MENINGITIDIS" S:PRE=W OK=1
Q:OK=1 1 I FIR>76,FIR<80 F W="MENINGITIS","MEPRIN","MOENOMYCIN","MORQUIO","NEOVITAMIN","NEUROKININ","NUTRITION","OLEOVITAMIN","OLIGOPEPTIDASE","ORBITAL","OXIDASE" S:PRE=W OK=1
Q:OK=1 1 I FIR>79,FIR<81 F W="PADIMATE","PARATYPHI","PARATYPHOID","PEPSIN","PHOSPHOLIPASE","POLYSACCHARIDE","PRECURSORS","PROTEIN","PROTEINASE","PROTEINS" S:PRE=W OK=1
Q:OK=1 1 I FIR>79,FIR<84 F W="PROTOVERATRINE","PUMILIOTOXIN","RASTELLI","RH","RHINITIS","RIGHT","RUTTER","SCILLAREN","SCYTALIDOPEPSIN","SEROTYPE","SOLVENT" S:PRE=W OK=1
Q:OK=1 1 I FIR>82,FIR<85 F W="SOMATOMEDIN","SPECIES","STAGE","STREPTOGRISIN","SUBGROUP","SUBSCALE","SUBUNIT","SULFATASE","SULFATE","SULPHATASE","T","TARIFF" S:PRE=W OK=1
Q:OK=1 1 I FIR>83,FIR<91 F W="TOXIN","TRIPLE","TYPE","TYPING","ULTRAVIOLET","VALUES","VENOMBIN","VIRUS","VITAMIN","WEAK" S:PRE=W OK=1
S X=OK
Q X
;
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")
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))
N LEXNXT,LEXUSE
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXXM1 4216 printed Oct 16, 2024@18:11:05 Page 2
LEXXM1 ;ISL/KER - Convert Text to Mix Case (1) ;12/19/2014
+1 ;;2.0;General Lexicon Utilities;**80,86**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; None
+5 ;
+6 ; External References
+7 ; None
+8 ;
+9 ; Local Variables NEWed or KILLed Elsewhere
+10 ; LEXNXT,LEXUSE
+11 ;
T1 ; 1 Character
+1 NEW XU,CHR,PRE,LEXPRE,UIN,NXT,USE
SET PRE=$GET(LEXPRE)
SET UIN=$GET(UIN)
SET NXT=$GET(LEXNXT)
SET USE=$GET(LEXUSE)
SET XU=$$UP(X)
SET CHR=$EXTRACT(XU,1)
+2 if XU="W"&(($GET(UIN)["W/WO")!($GET(UIN)["W/"))
SET Y=$$LO(XU)
if $LENGTH($GET(Y))
QUIT
+3 ; Special Case "A"
+4 SET Y=""
IF XU="A"
IF $EXTRACT(NXT,1,7)["SINGLE"
SET Y=$$LO(XU)
QUIT
+5 IF $DATA(UIN)
IF "^A^"[("^"_XU_"^")
IF (" "_UIN_" ")[(" "_XU_" ")
Begin DoDot:1
+6 NEW UP
SET Y=XU
if UIN[" A OR V "
QUIT
if UIN[" T AND A "
QUIT
if UIN[" A & E"
QUIT
if UIN[" A OR B"
QUIT
if UIN["O>HM< A"
QUIT
SET UP=$$UPA(XU,PRE,UIN)
if +UP'>0
SET Y=$$LO(XU)
End DoDot:1
if $LENGTH($GET(Y))
QUIT
+7 ; Special Case W/O
+8 IF "^O^W^"[("^"_XU_"^")&(UIN["W/O")
SET Y=$$LO(XU)
QUIT
+9 IF "^G^"[("^"_XU_"^")&(+($GET(PRE))>0)
SET Y=$$LO(XU)
QUIT
+10 ; Uppercase
+11 IF "^B^C^D^E^F^G^H^I^J^K^L^M^N^O^P^Q^R^S^T^U^V^X^Y^Z^"[("^"_XU_"^")
SET Y=XU
QUIT
+12 QUIT
+13 ;
UPA(X,Y,Z) ; Check if "A" is Uppercase A
+1 NEW CHR,FIR,OK,PRE,UP,W,XU
+2 SET XU=$GET(X)
SET PRE=$GET(Y)
SET UIN=$GET(Z)
SET FIR=$ASCII($EXTRACT(PRE,1))
+3 SET OK=1
if UIN[" A OR V "
QUIT 1
if UIN[" T and A "
QUIT 1
if UIN[" A & E"
QUIT 1
if UIN[" A OR B"
QUIT 1
if UIN["O>HM< A"
QUIT 1
if PRE="&"
QUIT 1
+4 SET OK=0
IF FIR<66
FOR W="ACETYLGLUCOSAMINIDASE","ACETYLHEXOSAMINIDASE","ACTIONS","ACTIVIN","ACYLCOENZYME","AKIYAMI","ALDOLASE","AMINOPEPTIDASE"
if PRE=W
SET OK=1
+5 if OK=1
QUIT 1
IF FIR<66
FOR W="AMPHOTERICIN","AMYLOID","ANOPHELES","ANTI","ANTIBODY","ANTIGEN","APHTHOVIRUS","APOLIPOPROTEIN","APOLIPOPROTEINS","ARYLSULFATASE"
if PRE=W
SET OK=1
+6 if OK=1
QUIT 1
IF FIR<68
FOR W="ATTRIBUTE","ATTRIBUTES","AUXIN","AZURE","BACITRACIN","BIOVAR","BISPHENOL","BOTULINIUM","BOTULINUM","CARBOMYCIN","CARBOXYPEPTIDASE"
if PRE=W
SET OK=1
+7 if OK=1
QUIT 1
IF FIR>66
IF FIR<68
FOR W="CARMOISINE","CAROTID","CATEGORY","CHROMOGRANIN","CHYMOTRYPSIN","CICLOSPORIN","CLASS","CLINIC","CLUSTER","COBALAMIN","COENZYME"
if PRE=W
SET OK=1
+8 if OK=1
QUIT 1
IF FIR>66
IF FIR<70
FOR W="COMPOUND","CON","CONCANAVALIN","CORONARY","COXSACKIE","COXSACKIEVIRUS","CYCLOSPORIN","DIPEPTIDASE","DNASE","DOUBLE","ENTEROTOXIN"
if PRE=W
SET OK=1
+9 if OK=1
QUIT 1
IF FIR>68
IF FIR<72
FOR W="ENZYMES","EQUIZOLE","FEEDS","FIBRINOPEPTIDE","FIBRINOPEPTIDES","FORMULA","GALACTOSIDASE","GELATINASE","GENUS","GLYCOPHORIN","GP"
if PRE=W
SET OK=1
+10 if OK=1
QUIT 1
IF FIR>70
IF FIR<73
FOR W="GRADE","GRANZYME","GROUP","HAEMOGLOBIN","HAEMOPHILIA","HB","HEMOGLOBIN","HEMOPHILIA","HEP","HEPATITIS","HEXOSAMINIDASE","HLA","HPFH"
if PRE=W
SET OK=1
+11 if OK=1
QUIT 1
IF FIR>71
IF FIR<74
FOR W="HYPERVITAMINOSIS","HYPOGLYCIN","HYPOVITAMINOSIS","I","II","III","IMMUNOGLOBULIN","INDEX","INFLUENZA","INFLUENZAE","INFLUENZAVIRUS"
if PRE=W
SET OK=1
+12 if OK=1
QUIT 1
IF FIR>72
IF FIR<78
FOR W="INHIBIN","IV","JEC","LANTADENE","LASALOCID","LEFT","LEPROMIN","LEUKOTRIENE","LEVEL","LIPOPROTEIN","LOCUS","MED","MENINGITIDIS"
if PRE=W
SET OK=1
+13 if OK=1
QUIT 1
IF FIR>76
IF FIR<80
FOR W="MENINGITIS","MEPRIN","MOENOMYCIN","MORQUIO","NEOVITAMIN","NEUROKININ","NUTRITION","OLEOVITAMIN","OLIGOPEPTIDASE","ORBITAL","OXIDASE"
if PRE=W
SET OK=1
+14 if OK=1
QUIT 1
IF FIR>79
IF FIR<81
FOR W="PADIMATE","PARATYPHI","PARATYPHOID","PEPSIN","PHOSPHOLIPASE","POLYSACCHARIDE","PRECURSORS","PROTEIN","PROTEINASE","PROTEINS"
if PRE=W
SET OK=1
+15 if OK=1
QUIT 1
IF FIR>79
IF FIR<84
FOR W="PROTOVERATRINE","PUMILIOTOXIN","RASTELLI","RH","RHINITIS","RIGHT","RUTTER","SCILLAREN","SCYTALIDOPEPSIN","SEROTYPE","SOLVENT"
if PRE=W
SET OK=1
+16 if OK=1
QUIT 1
IF FIR>82
IF FIR<85
FOR W="SOMATOMEDIN","SPECIES","STAGE","STREPTOGRISIN","SUBGROUP","SUBSCALE","SUBUNIT","SULFATASE","SULFATE","SULPHATASE","T","TARIFF"
if PRE=W
SET OK=1
+17 if OK=1
QUIT 1
IF FIR>83
IF FIR<91
FOR W="TOXIN","TRIPLE","TYPE","TYPING","ULTRAVIOLET","VALUES","VENOMBIN","VIRUS","VITAMIN","WEAK"
if PRE=W
SET OK=1
+18 SET X=OK
+19 QUIT X
+20 ;
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")
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 NEW LEXNXT,LEXUSE
+4 QUIT X
