LEXXM ;ISL/KER - Convert Text to Mix Case ;05/23/2017
;;2.0;General Lexicon Utilities;**80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; None
;
; External References
; $$CODEN^ICDCODE ICR 3990
; $$ICDDX^ICDCODE ICR 3990
; $$ICDOP^ICDCODE ICR 3990
; ICDD^ICDCODE ICR 3990
; $$CPT^ICPTCOD ICR 1995
; CPTD^ICPTCOD ICR 1995
; $$MOD^ICPTMOD ICR 1996
; MODD^ICPTMOD ICR 1996
; $$DT^XLFDT ICR 10103
;
Q
;
; TXT General Text
; Input X Text
; L Text Length (>19 & <80) (default $L(X))
; Output Y() Mix case diagnosis
;
; LEX Lexicon Text
; Input X Lexicon IEN
; L Text Length (>19 & <80) (default $L(X))
; Output Y() Mix case diagnosis
;
; For the Entry Points ICDDX1, ICDDX2, ICDOP1, ICDOP2, ICPT1,
; ICPT2, MOD1, and MOD2 use:
;
; Input X File IEN
; V Version date (default = TODAY)
; L Text Length (>19 & <80) (default $L(X))
; Output Y() Mix case text
;
; Patch LEX*2.0*103 re-directs the calls to LEXXMC
;
MIX(X) ; Mix Case any length
N Y S X=$G(X) D FULL(X) S X=Y
Q X
LEG(X) ; Mix Case (Legacy)
N LEG S LEG="" S X=$$MIX($G(X))
Q X
TXT(X,L) ; Convert Text to Mixed Case
N LOW,LEN K LOW,Y S Y(1)=$$CASE($TR($G(X),"""","'")),LEN=+($G(L)) K:$G(LEN)'>19 LEN K:$G(LEN)'<80 LEN D PR^LEXU(.Y,LEN)
Q
FULL(X) ; Convert Text to Mixed Case
N LOW,LEN K LOW,Y S Y=$$CASE($TR($G(X),"""","'"))
Q
LEX(X,L) ; Convert Expression to Mixed Case
K Y N I,IEN,VDT,LEN,LOW K LOW,Y S IEN=+($G(X)),LEN=+($G(L)) K:$G(LEN)'>19 LEN K:$G(LEN)'<80 LEN Q:+IEN'>0 Q:'$D(^LEX(757.01,+IEN,0))
S Y(1)=$$EXP(X) D PR^LEXU(.Y,LEN)
Q
ICDDX1(X,V,L) ; Convert ICD Diagnosis to Mixed Case
N CODE,IEN,VDT,LEN,ICDDX,LOW K LOW,Y S (CODE,IEN)=$G(X),VDT=$G(V),LEN=+($G(L)) K:$G(LEN)'>19 LEN K:$G(LEN)'<80 LEN S:VDT'?7N VDT=$$DT^XLFDT
S IEN=$P($$CODEN^ICDCODE(IEN,80),"~",1),X="",ICDDX=$P($$ICDDX^ICDCODE(+IEN,VDT,,0),"^",4) Q:'$L(ICDDX) S Y(1)=$$CASE(ICDDX) D PR^LEXU(.Y,LEN)
Q
ICDDX2(X,V,L) ; Convert ICD Diagnosis Description to Mixed Case
N CODE,I,IEN,VDT,LEN,ND,LOW K LOW,Y S (CODE,IEN)=$G(X),VDT=$G(V),LEN=+($G(L)) K:$G(LEN)'>19 LEN K:$G(LEN)'<80 LEN S:VDT'?7N VDT=$$DT^XLFDT
S IEN=$P($$CODEN^ICDCODE(IEN,80),"~",1),CODE=$P($$ICDDX^ICDCODE(+IEN,,0),"^",2) D ICDD^ICDCODE(CODE,"ND",VDT)
K Y S I=0 F S I=$O(ND(I)) Q:+I'>0 Q:$$TRIM($G(ND(I)))="" S:I>1 LOW=1 S Y(I)=$$CASE($G(ND(I))) K LOW
D PR^LEXU(.Y,LEN)
Q
ICDOP1(X,V,L) ; Convert ICD Procedure to Mixed Case
N CODE,IEN,VDT,LEN,ICDOP,LOW K LOW,Y S (CODE,IEN)=$G(X),VDT=$G(V),LEN=+($G(L)) K:$G(LEN)'>19 LEN K:$G(LEN)'<80 LEN S:VDT'?7N VDT=$$DT^XLFDT
S IEN=$P($$CODEN^ICDCODE(IEN,80.1),"~",1),X="",ICDOP=$P($$ICDOP^ICDCODE(+IEN,VDT,,0),"^",5) Q:'$L(ICDOP) S Y(1)=$$CASE(ICDOP) D PR^LEXU(.Y,LEN)
Q
ICDOP2(X,V,L) ; Convert ICD Procedure Description to Mixed Case
N CODE,I,IEN,VDT,LEN,ND,LOW K LOW,Y S (CODE,IEN)=$G(X),VDT=$G(V),LEN=+($G(L)) K:$G(LEN)'>19 LEN K:$G(LEN)'<80 LEN S:VDT'?7N VDT=$$DT^XLFDT
S IEN=$P($$CODEN^ICDCODE(IEN,80.1),"~",1),CODE=$P($$ICDOP^ICDCODE(+IEN,VDT,,0),"^",2) D ICDD^ICDCODE(CODE,"ND",VDT)
K Y S I=0 F S I=$O(ND(I)) Q:+I'>0 Q:$$TRIM($G(ND(I)))="" S:I>1 LOW=1 S Y(I)=$$CASE($G(ND(I))) K LOW
D PR^LEXU(.Y,LEN)
Q
ICPT1(X,V,L) ; Convert CPT Procedure to Mixed Case
N CODE,IEN,VDT,LEN,ICPT,LOW K LOW,Y S (CODE,IEN)=$G(X),VDT=$G(V),LEN=+($G(L)) K:$G(LEN)'>19 LEN K:$G(LEN)'<80 LEN S:VDT'?7N VDT=$$DT^XLFDT
S X="",ICPT=$$CPT^ICPTCOD(+IEN,VDT),IEN=+ICPT,CODE=$P(ICPT,"^",2),ICPT=$P(ICPT,"^",3) Q:'$L(ICPT) S Y(1)=$$CASE(ICPT) D PR^LEXU(.Y,LEN)
Q
ICPT2(X,V,L) ; Convert CPT Procedure Description to Mixed Case
N CODE,I,IEN,VDT,LEN,ND,LOW K LOW,Y S (CODE,IEN)=$G(X),VDT=$G(V),LEN=+($G(L)) K:$G(LEN)'>19 LEN K:$G(LEN)'<80 LEN S:VDT'?7N VDT=$$DT^XLFDT
S CODE=$P($$CPT^ICPTCOD(+IEN,VDT),"^",2) D CPTD^ICPTCOD(CODE,"ND",,VDT)
K Y S I=0 F S I=$O(ND(I)) Q:+I'>0 Q:$$TRIM($G(ND(I)))="" S:I>1 LOW=1 S Y(I)=$$CASE($G(ND(I))) K LOW
D PR^LEXU(.Y,LEN)
Q
MOD1(X,V,L) ; Convert CPT Modifier to Mixed Case
N CODE,IEN,VDT,LEN,MOD,LOW K LOW,Y S (CODE,IEN)=$G(X),VDT=$G(V),LEN=+($G(L))
K:$G(LEN)'>19 LEN K:$G(LEN)'<80 LEN S:VDT'?7N VDT=$$DT^XLFDT
S X="",MOD=$$MOD^ICPTMOD(IEN,"I",VDT,1) S MOD=$P(MOD,"^",3) Q:'$L(MOD) S Y(1)=$$CASE(MOD) D PR^LEXU(.Y,LEN)
Q
MOD2(X,V,L) ; Convert CPT Modifier Description to Mixed Case
N CODE,I,IEN,VDT,LEN,ND,LOW K LOW,Y S (CODE,IEN)=$G(X),VDT=$G(V),LEN=+($G(L)) K:$G(LEN)'>19 LEN K:$G(LEN)'<80 LEN S:VDT'?7N VDT=$$DT^XLFDT
S CODE=$P($$MOD^ICPTMOD(+IEN,"I",VDT,1),"^",2) D MODD^ICPTMOD(CODE,"ND",,VDT)
K Y S I=0 F S I=$O(ND(I)) Q:+I'>0 Q:$$TRIM($G(ND(I)))="" S:I>1 LOW=1 S Y(I)=$$CASE($G(ND(I))) K LOW
D PR^LEXU(.Y,LEN)
Q
;
EXP(X) ; Get Case for Expression X = IEN in 757.01
N IEN,IEN,TXT,IN S IEN=$G(X),(TXT,IN)=$G(^LEX(757.01,+IEN,0)) Q:'$L(TXT) K PAR S (TXT,X)=$$CASE(TXT) S:'$L(X) X=IN
Q X
CASE(X) ; Get Case for String X = String of Text
I '$D(LEG) S X=$$MIX^LEXXMC($G(X)) Q X
K PAR N C,CHR,CT,LEXIN,LEXCTL,LEXCHR,I,L,PH,REM,STO,STR,TRL,TXT,W,WD,UIN,OIN,LEXPRE,LEXORG,LEXNXT,LEXUSE
S OIN=$$TRIM($G(X)) S (UIN,STR)=$$UP(OIN) Q:'$L(STR) X S STR=$$SW1(STR),L=$L(STR),PAR(0)=0,(LEXIN,PAR("T",1))=STR
S TRL="" F Q:$E(STR,$L(STR))'?1P S TRL=$E(STR,$L(STR))_TRL,STR=$E(STR,1,($L(STR)-1))
S PAR("TRL")=$G(TRL) S I=0 F Q:I>L Q:'$L(STR) D Q:'$L(STR)
. S I=I+1 I I=$L(STR) D Q
. . S CT=$O(PAR(" "),-1)+1 S (STO,PAR(CT))=STR,PAR(0)=CT,STR=""
. . S PH=$G(PAR((CT-1),"C"))_$G(PAR(CT))_$G(PAR(CT,"C")),PAR(CT,"A")=PH
. . S LEXIN=$G(PAR("T",1)),LEXCTL=$G(PAR(CT,"A")),LEXCHR=$G(PAR(CT,"C"))
. . F W=1:1:$L(STO," ") D
. . . N NWD S WD=$P(STO," ",W),LEXORG=$G(PAR(CT,"W",(+($G(W))-1))),LEXPRE=$$UP(LEXORG)
. . . S LEXNXT="",NWD=$$GETC(WD),PAR(CT,"W",W)=NWD
. S C=$E(STR,I)
. I C?1P&(C'=" ") D
. . S:C="(" C=" (" S:C="[" C=" [" S:C="&" C=" &"
. . N REM,STO S CT=$O(PAR(" "),-1)+1,(STO,PAR(CT))=$E(STR,1,(I-1)),PAR(0)=CT
. . S PH=$G(PAR(CT-1,"C"))_$G(PAR(CT))_$G(PAR(CT,"C")),PAR(CT,"A")=PH
. . S LEXIN=$G(PAR("T",1)),LEXCTL=$G(PAR(CT,"A")),LEXCHR=C
. . F W=1:1:$L(STO," ") D
. . . N NWD S WD=$P(STO," ",W),LEXPRE=$$UP($G(PAR(CT,"W",(+($G(W))-1))))
. . . S NWD=$$GETC(WD),PAR(CT,"W",W)=NWD
. . S (REM,STR)=$E(STR,I+1,$L(STR)),I=0
. . F Q:$E(STR,1)'=" " S C=C_" " S (REM,STR)=$E(STR,2,$L(STR))
. . S PAR(CT,"C")=C
S TXT="",CT=0 F S CT=$O(PAR(CT)) Q:+CT'>0 D
. N STR,TR S STR="",TR=$G(PAR(CT,"C")),W=0 F S W=$O(PAR(CT,"W",W)) Q:+W'>0 S STR=STR_" "_$G(PAR(CT,"W",W))
. S STR=$$TRIM(STR)_TR,PAR(CT,"B")=STR
. S TXT=TXT_STR K PAR(CT)
S TXT=TXT_$G(PAR("TRL")),X=$$SW3(TXT) K PAR F CHR="-","+" D
. I UIN[(" "_CHR),X[CHR,X'[(" "_CHR) D
. . N TXT S TXT=$P(X,CHR,1) F I=2:1 Q:'$L($P(X,CHR,I)) S TXT=TXT_(" "_CHR)_$P(X,CHR,I)
. . S X=TXT
S X=$$FN(X),X=$$DBL(X) F CHR="~","!","@","#","$","^","&","*","_","-","+","=","|","\",";",":",",","." S X=$$TM(X,CHR)
Q X
GETC(X) ; Set to Mixed/lower/UPPER case
N LEXTAG,LEXRTN,LEXLEN,Y Q:$L($G(X))'>0 X S X=$$UP($G(X)),Y="",LEXLEN=$L(X) S:LEXLEN>12 LEXLEN=12
S LEXUSE=$$UP($$USE),LEXNXT=$$TP($$TM($P($G(UIN),LEXUSE,2,4000)))
S LEXTAG="T"_$L(X),LEXRTN="LEXXM"_$L(X)
S:$L($G(X))>9 LEXTAG="TM" S:$L($G(X))>5 LEXRTN="LEXXM6" S LEXRTN=LEXTAG_"^"_LEXRTN D @LEXRTN I $L(Y) S X=$$SW2(Y) Q X
S X=$$MX(X)
Q X
;
SW1(X) ; Switch Text (before setting case)
S X=$$SW1^LEXXMM($G(X)) Q X
SW2(X) ; Switch Text (after setting case)
S X=$$SW2^LEXXMM($G(X)) Q X
SW3(X) ; Switch Text (after assembling string)
S X=$$SW3^LEXXMM($G(X)) Q X
EW(X) ; Display Word Usage
D EW^LEXXMM($G(X)) Q
;
USE(X) ; Used
N STR,SEG,CUR S STR="",SEG=0 F S SEG=$O(PAR(SEG)) Q:+SEG'>0 D
. N WC S WC=0 F S WC=$O(PAR(SEG,"W",WC)) Q:+WC'>0 D
. . N WD S WD=$$UP($G(PAR(SEG,"W",WC)))
. . S:$E(STR,$L(STR))?1A!($E(STR,$L(STR))?1N) STR=$G(STR)_" "_WD
. . S:$E(STR,$L(STR))'?1A&($E(STR,$L(STR))'?1N) STR=$G(STR)_WD
. S:$L($G(PAR(SEG,"C"))) STR=STR_$G(PAR(SEG,"C"))
S CUR=$G(WD) I $L(CUR) D
. S:$E(STR,$L(STR))?1A!($E(STR,$L(STR))?1N) STR=$G(STR)_" "_CUR
. S:$E(STR,$L(STR))'?1A&($E(STR,$L(STR))'?1N) STR=$G(STR)_CUR
S X=$$TM(STR)
Q X
Q X
FN(X) ; Footnote Removed
S X=$G(X) Q:X'[")" X N ORG,FIR,LAS,TRM,L,NUM,OUT,REP,WTH S (OUT,ORG)=X,L=$L(X,")"),FIR=$P(X,")",1,(L-1))_")",LAS=$P(X,")",L),TRM=$$TRIM(LAS),X=ORG I TRM=LAS,$E(LAS,1)?1N,+LAS=LAS S OUT=FIR
F NUM=1:1:9 S REP=")"_NUM_" ",WTH=") " I OUT[REP S OUT=$$SWAP^LEXXMM(OUT,REP,WTH)
S X=OUT
Q X
LO(X) ; Lower Case
Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
UP(X) ; Upper Case
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
MX(X) ; Mixed 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
TP(X) ; Trim Punctuation
S X=$G(X) Q:'$L(X) X F Q:$E(X,1)'?1P S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'?1P S X=$E(X,1,($L(X)-1))
Q X
TM(X,Y) ; Trim Character Y - Default " "
S X=$G(X),Y=$G(Y) Q:$L(Y)&(X'[Y) X 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
DBL(X) ; Double Spaces
S X=$G(X) F Q:X'[" " S X=$P(X," ",1)_" "_$P(X," ",2,4000)
S X=$$TRIM(X)
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXXM 9931 printed Oct 16, 2024@18:11:04 Page 2
LEXXM ;ISL/KER - Convert Text to Mix Case ;05/23/2017
+1 ;;2.0;General Lexicon Utilities;**80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; None
+5 ;
+6 ; External References
+7 ; $$CODEN^ICDCODE ICR 3990
+8 ; $$ICDDX^ICDCODE ICR 3990
+9 ; $$ICDOP^ICDCODE ICR 3990
+10 ; ICDD^ICDCODE ICR 3990
+11 ; $$CPT^ICPTCOD ICR 1995
+12 ; CPTD^ICPTCOD ICR 1995
+13 ; $$MOD^ICPTMOD ICR 1996
+14 ; MODD^ICPTMOD ICR 1996
+15 ; $$DT^XLFDT ICR 10103
+16 ;
+17 QUIT
+18 ;
+19 ; TXT General Text
+20 ; Input X Text
+21 ; L Text Length (>19 & <80) (default $L(X))
+22 ; Output Y() Mix case diagnosis
+23 ;
+24 ; LEX Lexicon Text
+25 ; Input X Lexicon IEN
+26 ; L Text Length (>19 & <80) (default $L(X))
+27 ; Output Y() Mix case diagnosis
+28 ;
+29 ; For the Entry Points ICDDX1, ICDDX2, ICDOP1, ICDOP2, ICPT1,
+30 ; ICPT2, MOD1, and MOD2 use:
+31 ;
+32 ; Input X File IEN
+33 ; V Version date (default = TODAY)
+34 ; L Text Length (>19 & <80) (default $L(X))
+35 ; Output Y() Mix case text
+36 ;
+37 ; Patch LEX*2.0*103 re-directs the calls to LEXXMC
+38 ;
MIX(X) ; Mix Case any length
+1 NEW Y
SET X=$GET(X)
DO FULL(X)
SET X=Y
+2 QUIT X
LEG(X) ; Mix Case (Legacy)
+1 NEW LEG
SET LEG=""
SET X=$$MIX($GET(X))
+2 QUIT X
TXT(X,L) ; Convert Text to Mixed Case
+1 NEW LOW,LEN
KILL LOW,Y
SET Y(1)=$$CASE($TRANSLATE($GET(X),"""","'"))
SET LEN=+($GET(L))
if $GET(LEN)'>19
KILL LEN
if $GET(LEN)'<80
KILL LEN
DO PR^LEXU(.Y,LEN)
+2 QUIT
FULL(X) ; Convert Text to Mixed Case
+1 NEW LOW,LEN
KILL LOW,Y
SET Y=$$CASE($TRANSLATE($GET(X),"""","'"))
+2 QUIT
LEX(X,L) ; Convert Expression to Mixed Case
+1 KILL Y
NEW I,IEN,VDT,LEN,LOW
KILL LOW,Y
SET IEN=+($GET(X))
SET LEN=+($GET(L))
if $GET(LEN)'>19
KILL LEN
if $GET(LEN)'<80
KILL LEN
if +IEN'>0
QUIT
if '$DATA(^LEX(757.01,+IEN,0))
QUIT
+2 SET Y(1)=$$EXP(X)
DO PR^LEXU(.Y,LEN)
+3 QUIT
ICDDX1(X,V,L) ; Convert ICD Diagnosis to Mixed Case
+1 NEW CODE,IEN,VDT,LEN,ICDDX,LOW
KILL LOW,Y
SET (CODE,IEN)=$GET(X)
SET VDT=$GET(V)
SET LEN=+($GET(L))
if $GET(LEN)'>19
KILL LEN
if $GET(LEN)'<80
KILL LEN
if VDT'?7N
SET VDT=$$DT^XLFDT
+2 SET IEN=$PIECE($$CODEN^ICDCODE(IEN,80),"~",1)
SET X=""
SET ICDDX=$PIECE($$ICDDX^ICDCODE(+IEN,VDT,,0),"^",4)
if '$LENGTH(ICDDX)
QUIT
SET Y(1)=$$CASE(ICDDX)
DO PR^LEXU(.Y,LEN)
+3 QUIT
ICDDX2(X,V,L) ; Convert ICD Diagnosis Description to Mixed Case
+1 NEW CODE,I,IEN,VDT,LEN,ND,LOW
KILL LOW,Y
SET (CODE,IEN)=$GET(X)
SET VDT=$GET(V)
SET LEN=+($GET(L))
if $GET(LEN)'>19
KILL LEN
if $GET(LEN)'<80
KILL LEN
if VDT'?7N
SET VDT=$$DT^XLFDT
+2 SET IEN=$PIECE($$CODEN^ICDCODE(IEN,80),"~",1)
SET CODE=$PIECE($$ICDDX^ICDCODE(+IEN,,0),"^",2)
DO ICDD^ICDCODE(CODE,"ND",VDT)
+3 KILL Y
SET I=0
FOR
SET I=$ORDER(ND(I))
if +I'>0
QUIT
if $$TRIM($GET(ND(I)))=""
QUIT
if I>1
SET LOW=1
SET Y(I)=$$CASE($GET(ND(I)))
KILL LOW
+4 DO PR^LEXU(.Y,LEN)
+5 QUIT
ICDOP1(X,V,L) ; Convert ICD Procedure to Mixed Case
+1 NEW CODE,IEN,VDT,LEN,ICDOP,LOW
KILL LOW,Y
SET (CODE,IEN)=$GET(X)
SET VDT=$GET(V)
SET LEN=+($GET(L))
if $GET(LEN)'>19
KILL LEN
if $GET(LEN)'<80
KILL LEN
if VDT'?7N
SET VDT=$$DT^XLFDT
+2 SET IEN=$PIECE($$CODEN^ICDCODE(IEN,80.1),"~",1)
SET X=""
SET ICDOP=$PIECE($$ICDOP^ICDCODE(+IEN,VDT,,0),"^",5)
if '$LENGTH(ICDOP)
QUIT
SET Y(1)=$$CASE(ICDOP)
DO PR^LEXU(.Y,LEN)
+3 QUIT
ICDOP2(X,V,L) ; Convert ICD Procedure Description to Mixed Case
+1 NEW CODE,I,IEN,VDT,LEN,ND,LOW
KILL LOW,Y
SET (CODE,IEN)=$GET(X)
SET VDT=$GET(V)
SET LEN=+($GET(L))
if $GET(LEN)'>19
KILL LEN
if $GET(LEN)'<80
KILL LEN
if VDT'?7N
SET VDT=$$DT^XLFDT
+2 SET IEN=$PIECE($$CODEN^ICDCODE(IEN,80.1),"~",1)
SET CODE=$PIECE($$ICDOP^ICDCODE(+IEN,VDT,,0),"^",2)
DO ICDD^ICDCODE(CODE,"ND",VDT)
+3 KILL Y
SET I=0
FOR
SET I=$ORDER(ND(I))
if +I'>0
QUIT
if $$TRIM($GET(ND(I)))=""
QUIT
if I>1
SET LOW=1
SET Y(I)=$$CASE($GET(ND(I)))
KILL LOW
+4 DO PR^LEXU(.Y,LEN)
+5 QUIT
ICPT1(X,V,L) ; Convert CPT Procedure to Mixed Case
+1 NEW CODE,IEN,VDT,LEN,ICPT,LOW
KILL LOW,Y
SET (CODE,IEN)=$GET(X)
SET VDT=$GET(V)
SET LEN=+($GET(L))
if $GET(LEN)'>19
KILL LEN
if $GET(LEN)'<80
KILL LEN
if VDT'?7N
SET VDT=$$DT^XLFDT
+2 SET X=""
SET ICPT=$$CPT^ICPTCOD(+IEN,VDT)
SET IEN=+ICPT
SET CODE=$PIECE(ICPT,"^",2)
SET ICPT=$PIECE(ICPT,"^",3)
if '$LENGTH(ICPT)
QUIT
SET Y(1)=$$CASE(ICPT)
DO PR^LEXU(.Y,LEN)
+3 QUIT
ICPT2(X,V,L) ; Convert CPT Procedure Description to Mixed Case
+1 NEW CODE,I,IEN,VDT,LEN,ND,LOW
KILL LOW,Y
SET (CODE,IEN)=$GET(X)
SET VDT=$GET(V)
SET LEN=+($GET(L))
if $GET(LEN)'>19
KILL LEN
if $GET(LEN)'<80
KILL LEN
if VDT'?7N
SET VDT=$$DT^XLFDT
+2 SET CODE=$PIECE($$CPT^ICPTCOD(+IEN,VDT),"^",2)
DO CPTD^ICPTCOD(CODE,"ND",,VDT)
+3 KILL Y
SET I=0
FOR
SET I=$ORDER(ND(I))
if +I'>0
QUIT
if $$TRIM($GET(ND(I)))=""
QUIT
if I>1
SET LOW=1
SET Y(I)=$$CASE($GET(ND(I)))
KILL LOW
+4 DO PR^LEXU(.Y,LEN)
+5 QUIT
MOD1(X,V,L) ; Convert CPT Modifier to Mixed Case
+1 NEW CODE,IEN,VDT,LEN,MOD,LOW
KILL LOW,Y
SET (CODE,IEN)=$GET(X)
SET VDT=$GET(V)
SET LEN=+($GET(L))
+2 if $GET(LEN)'>19
KILL LEN
if $GET(LEN)'<80
KILL LEN
if VDT'?7N
SET VDT=$$DT^XLFDT
+3 SET X=""
SET MOD=$$MOD^ICPTMOD(IEN,"I",VDT,1)
SET MOD=$PIECE(MOD,"^",3)
if '$LENGTH(MOD)
QUIT
SET Y(1)=$$CASE(MOD)
DO PR^LEXU(.Y,LEN)
+4 QUIT
MOD2(X,V,L) ; Convert CPT Modifier Description to Mixed Case
+1 NEW CODE,I,IEN,VDT,LEN,ND,LOW
KILL LOW,Y
SET (CODE,IEN)=$GET(X)
SET VDT=$GET(V)
SET LEN=+($GET(L))
if $GET(LEN)'>19
KILL LEN
if $GET(LEN)'<80
KILL LEN
if VDT'?7N
SET VDT=$$DT^XLFDT
+2 SET CODE=$PIECE($$MOD^ICPTMOD(+IEN,"I",VDT,1),"^",2)
DO MODD^ICPTMOD(CODE,"ND",,VDT)
+3 KILL Y
SET I=0
FOR
SET I=$ORDER(ND(I))
if +I'>0
QUIT
if $$TRIM($GET(ND(I)))=""
QUIT
if I>1
SET LOW=1
SET Y(I)=$$CASE($GET(ND(I)))
KILL LOW
+4 DO PR^LEXU(.Y,LEN)
+5 QUIT
+6 ;
EXP(X) ; Get Case for Expression X = IEN in 757.01
+1 NEW IEN,IEN,TXT,IN
SET IEN=$GET(X)
SET (TXT,IN)=$GET(^LEX(757.01,+IEN,0))
if '$LENGTH(TXT)
QUIT
KILL PAR
SET (TXT,X)=$$CASE(TXT)
if '$LENGTH(X)
SET X=IN
+2 QUIT X
CASE(X) ; Get Case for String X = String of Text
+1 IF '$DATA(LEG)
SET X=$$MIX^LEXXMC($GET(X))
QUIT X
+2 KILL PAR
NEW C,CHR,CT,LEXIN,LEXCTL,LEXCHR,I,L,PH,REM,STO,STR,TRL,TXT,W,WD,UIN,OIN,LEXPRE,LEXORG,LEXNXT,LEXUSE
+3 SET OIN=$$TRIM($GET(X))
SET (UIN,STR)=$$UP(OIN)
if '$LENGTH(STR)
QUIT X
SET STR=$$SW1(STR)
SET L=$LENGTH(STR)
SET PAR(0)=0
SET (LEXIN,PAR("T",1))=STR
+4 SET TRL=""
FOR
if $EXTRACT(STR,$LENGTH(STR))'?1P
QUIT
SET TRL=$EXTRACT(STR,$LENGTH(STR))_TRL
SET STR=$EXTRACT(STR,1,($LENGTH(STR)-1))
+5 SET PAR("TRL")=$GET(TRL)
SET I=0
FOR
if I>L
QUIT
if '$LENGTH(STR)
QUIT
Begin DoDot:1
+6 SET I=I+1
IF I=$LENGTH(STR)
Begin DoDot:2
+7 SET CT=$ORDER(PAR(" "),-1)+1
SET (STO,PAR(CT))=STR
SET PAR(0)=CT
SET STR=""
+8 SET PH=$GET(PAR((CT-1),"C"))_$GET(PAR(CT))_$GET(PAR(CT,"C"))
SET PAR(CT,"A")=PH
+9 SET LEXIN=$GET(PAR("T",1))
SET LEXCTL=$GET(PAR(CT,"A"))
SET LEXCHR=$GET(PAR(CT,"C"))
+10 FOR W=1:1:$LENGTH(STO," ")
Begin DoDot:3
+11 NEW NWD
SET WD=$PIECE(STO," ",W)
SET LEXORG=$GET(PAR(CT,"W",(+($GET(W))-1)))
SET LEXPRE=$$UP(LEXORG)
+12 SET LEXNXT=""
SET NWD=$$GETC(WD)
SET PAR(CT,"W",W)=NWD
End DoDot:3
End DoDot:2
QUIT
+13 SET C=$EXTRACT(STR,I)
+14 IF C?1P&(C'=" ")
Begin DoDot:2
+15 if C="("
SET C=" ("
if C="["
SET C=" ["
if C="&"
SET C=" &"
+16 NEW REM,STO
SET CT=$ORDER(PAR(" "),-1)+1
SET (STO,PAR(CT))=$EXTRACT(STR,1,(I-1))
SET PAR(0)=CT
+17 SET PH=$GET(PAR(CT-1,"C"))_$GET(PAR(CT))_$GET(PAR(CT,"C"))
SET PAR(CT,"A")=PH
+18 SET LEXIN=$GET(PAR("T",1))
SET LEXCTL=$GET(PAR(CT,"A"))
SET LEXCHR=C
+19 FOR W=1:1:$LENGTH(STO," ")
Begin DoDot:3
+20 NEW NWD
SET WD=$PIECE(STO," ",W)
SET LEXPRE=$$UP($GET(PAR(CT,"W",(+($GET(W))-1))))
+21 SET NWD=$$GETC(WD)
SET PAR(CT,"W",W)=NWD
End DoDot:3
+22 SET (REM,STR)=$EXTRACT(STR,I+1,$LENGTH(STR))
SET I=0
+23 FOR
if $EXTRACT(STR,1)'=" "
QUIT
SET C=C_" "
SET (REM,STR)=$EXTRACT(STR,2,$LENGTH(STR))
+24 SET PAR(CT,"C")=C
End DoDot:2
End DoDot:1
if '$LENGTH(STR)
QUIT
+25 SET TXT=""
SET CT=0
FOR
SET CT=$ORDER(PAR(CT))
if +CT'>0
QUIT
Begin DoDot:1
+26 NEW STR,TR
SET STR=""
SET TR=$GET(PAR(CT,"C"))
SET W=0
FOR
SET W=$ORDER(PAR(CT,"W",W))
if +W'>0
QUIT
SET STR=STR_" "_$GET(PAR(CT,"W",W))
+27 SET STR=$$TRIM(STR)_TR
SET PAR(CT,"B")=STR
+28 SET TXT=TXT_STR
KILL PAR(CT)
End DoDot:1
+29 SET TXT=TXT_$GET(PAR("TRL"))
SET X=$$SW3(TXT)
KILL PAR
FOR CHR="-","+"
Begin DoDot:1
+30 IF UIN[(" "_CHR)
IF X[CHR
IF X'[(" "_CHR)
Begin DoDot:2
+31 NEW TXT
SET TXT=$PIECE(X,CHR,1)
FOR I=2:1
if '$LENGTH($PIECE(X,CHR,I))
QUIT
SET TXT=TXT_(" "_CHR)_$PIECE(X,CHR,I)
+32 SET X=TXT
End DoDot:2
End DoDot:1
+33 SET X=$$FN(X)
SET X=$$DBL(X)
FOR CHR="~","!","@","#","$","^","&","*","_","-","+","=","|","\",";",":",",","."
SET X=$$TM(X,CHR)
+34 QUIT X
GETC(X) ; Set to Mixed/lower/UPPER case
+1 NEW LEXTAG,LEXRTN,LEXLEN,Y
if $LENGTH($GET(X))'>0
QUIT X
SET X=$$UP($GET(X))
SET Y=""
SET LEXLEN=$LENGTH(X)
if LEXLEN>12
SET LEXLEN=12
+2 SET LEXUSE=$$UP($$USE)
SET LEXNXT=$$TP($$TM($PIECE($GET(UIN),LEXUSE,2,4000)))
+3 SET LEXTAG="T"_$LENGTH(X)
SET LEXRTN="LEXXM"_$LENGTH(X)
+4 if $LENGTH($GET(X))>9
SET LEXTAG="TM"
if $LENGTH($GET(X))>5
SET LEXRTN="LEXXM6"
SET LEXRTN=LEXTAG_"^"_LEXRTN
DO @LEXRTN
IF $LENGTH(Y)
SET X=$$SW2(Y)
QUIT X
+5 SET X=$$MX(X)
+6 QUIT X
+7 ;
SW1(X) ; Switch Text (before setting case)
+1 SET X=$$SW1^LEXXMM($GET(X))
QUIT X
SW2(X) ; Switch Text (after setting case)
+1 SET X=$$SW2^LEXXMM($GET(X))
QUIT X
SW3(X) ; Switch Text (after assembling string)
+1 SET X=$$SW3^LEXXMM($GET(X))
QUIT X
EW(X) ; Display Word Usage
+1 DO EW^LEXXMM($GET(X))
QUIT
+2 ;
USE(X) ; Used
+1 NEW STR,SEG,CUR
SET STR=""
SET SEG=0
FOR
SET SEG=$ORDER(PAR(SEG))
if +SEG'>0
QUIT
Begin DoDot:1
+2 NEW WC
SET WC=0
FOR
SET WC=$ORDER(PAR(SEG,"W",WC))
if +WC'>0
QUIT
Begin DoDot:2
+3 NEW WD
SET WD=$$UP($GET(PAR(SEG,"W",WC)))
+4 if $EXTRACT(STR,$LENGTH(STR))?1A!($EXTRACT(STR,$LENGTH(STR))?1N)
SET STR=$GET(STR)_" "_WD
+5 if $EXTRACT(STR,$LENGTH(STR))'?1A&($EXTRACT(STR,$LENGTH(STR))'?1N)
SET STR=$GET(STR)_WD
End DoDot:2
+6 if $LENGTH($GET(PAR(SEG,"C")))
SET STR=STR_$GET(PAR(SEG,"C"))
End DoDot:1
+7 SET CUR=$GET(WD)
IF $LENGTH(CUR)
Begin DoDot:1
+8 if $EXTRACT(STR,$LENGTH(STR))?1A!($EXTRACT(STR,$LENGTH(STR))?1N)
SET STR=$GET(STR)_" "_CUR
+9 if $EXTRACT(STR,$LENGTH(STR))'?1A&($EXTRACT(STR,$LENGTH(STR))'?1N)
SET STR=$GET(STR)_CUR
End DoDot:1
+10 SET X=$$TM(STR)
+11 QUIT X
+12 QUIT X
FN(X) ; Footnote Removed
+1 SET X=$GET(X)
if X'[")"
QUIT X
NEW ORG,FIR,LAS,TRM,L,NUM,OUT,REP,WTH
SET (OUT,ORG)=X
SET L=$LENGTH(X,")")
SET FIR=$PIECE(X,")",1,(L-1))_")"
SET LAS=$PIECE(X,")",L)
SET TRM=$$TRIM(LAS)
SET X=ORG
IF TRM=LAS
IF $EXTRACT(LAS,1)?1N
IF +LAS=LAS
SET OUT=FIR
+2 FOR NUM=1:1:9
SET REP=")"_NUM_" "
SET WTH=") "
IF OUT[REP
SET OUT=$$SWAP^LEXXMM(OUT,REP,WTH)
+3 SET X=OUT
+4 QUIT X
LO(X) ; Lower Case
+1 QUIT $TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
UP(X) ; Upper Case
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
MX(X) ; Mixed 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
TP(X) ; Trim Punctuation
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT X
FOR
if $EXTRACT(X,1)'?1P
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
if $EXTRACT(X,$LENGTH(X))'?1P
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 QUIT X
TM(X,Y) ; Trim Character Y - Default " "
+1 SET X=$GET(X)
SET Y=$GET(Y)
if $LENGTH(Y)&(X'[Y)
QUIT X
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
DBL(X) ; Double Spaces
+1 SET X=$GET(X)
FOR
if X'[" "
QUIT
SET X=$PIECE(X," ",1)_" "_$PIECE(X," ",2,4000)
+2 SET X=$$TRIM(X)
+3 QUIT X
