Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEXXM

LEXXM.m

Go to the documentation of this file. 
  1. LEXXM ;ISL/KER - Convert Text to Mix Case ;05/23/2017
  1.  ;;2.0;General Lexicon Utilities;**80,103**;Sep 23, 1996;Build 2
  1.  ;               
  1.  ; Global Variables
  1.  ;    None
  1.  ;               
  1.  ; External References
  1.  ;    $$CODEN^ICDCODE     ICR   3990
  1.  ;    $$ICDDX^ICDCODE     ICR   3990
  1.  ;    $$ICDOP^ICDCODE     ICR   3990
  1.  ;    ICDD^ICDCODE        ICR   3990
  1.  ;    $$CPT^ICPTCOD       ICR   1995
  1.  ;    CPTD^ICPTCOD        ICR   1995
  1.  ;    $$MOD^ICPTMOD       ICR   1996
  1.  ;    MODD^ICPTMOD        ICR   1996
  1.  ;    $$DT^XLFDT          ICR  10103
  1.  ;               
  1.  Q
  1.  ;                
  1.  ; TXT                  General Text
  1.  ;       Input    X     Text
  1.  ;                L     Text Length (>19 & <80) (default $L(X))
  1.  ;       Output   Y()   Mix case diagnosis
  1.  ;               
  1.  ; LEX                  Lexicon Text
  1.  ;       Input    X     Lexicon IEN
  1.  ;                L     Text Length (>19 & <80) (default $L(X))
  1.  ;       Output   Y()   Mix case diagnosis
  1.  ;               
  1.  ; For the Entry Points ICDDX1, ICDDX2, ICDOP1, ICDOP2, ICPT1,
  1.  ; ICPT2, MOD1, and MOD2 use:
  1.  ;                   
  1.  ;       Input    X     File IEN
  1.  ;                V     Version date (default = TODAY)
  1.  ;                L     Text Length (>19 & <80) (default $L(X))
  1.  ;       Output   Y()   Mix case text
  1.  ;                          
  1.  ; Patch LEX*2.0*103 re-directs the calls to LEXXMC
  1.  ; 
  1. MIX(X) ; Mix Case any length
  1.  N Y S X=$G(X) D FULL(X) S X=Y
  1.  Q X
  1. LEG(X) ; Mix Case (Legacy)
  1.  N LEG S LEG="" S X=$$MIX($G(X))
  1.  Q X
  1. TXT(X,L) ; Convert Text to Mixed Case
  1.  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)
  1.  Q
  1. FULL(X) ; Convert Text to Mixed Case
  1.  N LOW,LEN K LOW,Y S Y=$$CASE($TR($G(X),"""","'"))
  1.  Q
  1. LEX(X,L) ; Convert Expression to Mixed Case
  1.  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))
  1.  S Y(1)=$$EXP(X) D PR^LEXU(.Y,LEN)
  1.  Q
  1. ICDDX1(X,V,L) ; Convert ICD Diagnosis to Mixed Case
  1.  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
  1.  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)
  1.  Q
  1. ICDDX2(X,V,L) ; Convert ICD Diagnosis Description to Mixed Case
  1.  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
  1.  S IEN=$P($$CODEN^ICDCODE(IEN,80),"~",1),CODE=$P($$ICDDX^ICDCODE(+IEN,,0),"^",2) D ICDD^ICDCODE(CODE,"ND",VDT)
  1.  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
  1.  D PR^LEXU(.Y,LEN)
  1.  Q
  1. ICDOP1(X,V,L) ; Convert ICD Procedure to Mixed Case
  1.  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
  1.  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)
  1.  Q
  1. ICDOP2(X,V,L) ; Convert ICD Procedure Description to Mixed Case
  1.  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
  1.  S IEN=$P($$CODEN^ICDCODE(IEN,80.1),"~",1),CODE=$P($$ICDOP^ICDCODE(+IEN,VDT,,0),"^",2) D ICDD^ICDCODE(CODE,"ND",VDT)
  1.  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
  1.  D PR^LEXU(.Y,LEN)
  1.  Q
  1. ICPT1(X,V,L) ; Convert CPT Procedure to Mixed Case
  1.  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
  1.  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)
  1.  Q
  1. ICPT2(X,V,L) ; Convert CPT Procedure Description to Mixed Case
  1.  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
  1.  S CODE=$P($$CPT^ICPTCOD(+IEN,VDT),"^",2) D CPTD^ICPTCOD(CODE,"ND",,VDT)
  1.  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
  1.  D PR^LEXU(.Y,LEN)
  1.  Q
  1. MOD1(X,V,L) ; Convert CPT Modifier to Mixed Case
  1.  N CODE,IEN,VDT,LEN,MOD,LOW K LOW,Y S (CODE,IEN)=$G(X),VDT=$G(V),LEN=+($G(L))
  1.  K:$G(LEN)'>19 LEN K:$G(LEN)'<80 LEN S:VDT'?7N VDT=$$DT^XLFDT
  1.  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)
  1.  Q
  1. MOD2(X,V,L) ; Convert CPT Modifier Description to Mixed Case
  1.  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
  1.  S CODE=$P($$MOD^ICPTMOD(+IEN,"I",VDT,1),"^",2) D MODD^ICPTMOD(CODE,"ND",,VDT)
  1.  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
  1.  D PR^LEXU(.Y,LEN)
  1.  Q
  1.  ;             
  1. EXP(X) ; Get Case for Expression            X = IEN in 757.01
  1.  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
  1.  Q X
  1. CASE(X) ; Get Case for String                X = String of Text
  1.  I '$D(LEG) S X=$$MIX^LEXXMC($G(X)) Q X
  1.  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
  1.  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
  1.  S TRL="" F  Q:$E(STR,$L(STR))'?1P  S TRL=$E(STR,$L(STR))_TRL,STR=$E(STR,1,($L(STR)-1))
  1.  S PAR("TRL")=$G(TRL) S I=0 F  Q:I>L  Q:'$L(STR)  D  Q:'$L(STR)
  1.  . S I=I+1 I I=$L(STR) D  Q
  1.  . . S CT=$O(PAR(" "),-1)+1 S (STO,PAR(CT))=STR,PAR(0)=CT,STR=""
  1.  . . S PH=$G(PAR((CT-1),"C"))_$G(PAR(CT))_$G(PAR(CT,"C")),PAR(CT,"A")=PH
  1.  . . S LEXIN=$G(PAR("T",1)),LEXCTL=$G(PAR(CT,"A")),LEXCHR=$G(PAR(CT,"C"))
  1.  . . F W=1:1:$L(STO," ") D
  1.  . . . N NWD S WD=$P(STO," ",W),LEXORG=$G(PAR(CT,"W",(+($G(W))-1))),LEXPRE=$$UP(LEXORG)
  1.  . . . S LEXNXT="",NWD=$$GETC(WD),PAR(CT,"W",W)=NWD
  1.  . S C=$E(STR,I)
  1.  . I C?1P&(C'=" ") D
  1.  . . S:C="(" C=" (" S:C="[" C=" [" S:C="&" C=" &"
  1.  . . N REM,STO S CT=$O(PAR(" "),-1)+1,(STO,PAR(CT))=$E(STR,1,(I-1)),PAR(0)=CT
  1.  . . S PH=$G(PAR(CT-1,"C"))_$G(PAR(CT))_$G(PAR(CT,"C")),PAR(CT,"A")=PH
  1.  . . S LEXIN=$G(PAR("T",1)),LEXCTL=$G(PAR(CT,"A")),LEXCHR=C
  1.  . . F W=1:1:$L(STO," ") D
  1.  . . . N NWD S WD=$P(STO," ",W),LEXPRE=$$UP($G(PAR(CT,"W",(+($G(W))-1))))
  1.  . . . S NWD=$$GETC(WD),PAR(CT,"W",W)=NWD
  1.  . . S (REM,STR)=$E(STR,I+1,$L(STR)),I=0
  1.  . . F  Q:$E(STR,1)'=" "  S C=C_" " S (REM,STR)=$E(STR,2,$L(STR))
  1.  . . S PAR(CT,"C")=C
  1.  S TXT="",CT=0 F  S CT=$O(PAR(CT)) Q:+CT'>0  D
  1.  . 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))
  1.  . S STR=$$TRIM(STR)_TR,PAR(CT,"B")=STR
  1.  . S TXT=TXT_STR K PAR(CT)
  1.  S TXT=TXT_$G(PAR("TRL")),X=$$SW3(TXT) K PAR F CHR="-","+" D
  1.  . I UIN[(" "_CHR),X[CHR,X'[(" "_CHR) D
  1.  . . 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)
  1.  . . S X=TXT
  1.  S X=$$FN(X),X=$$DBL(X) F CHR="~","!","@","#","$","^","&","*","_","-","+","=","|","\",";",":",",","." S X=$$TM(X,CHR)
  1.  Q X
  1. GETC(X) ; Set to Mixed/lower/UPPER case
  1.  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
  1.  S LEXUSE=$$UP($$USE),LEXNXT=$$TP($$TM($P($G(UIN),LEXUSE,2,4000)))
  1.  S LEXTAG="T"_$L(X),LEXRTN="LEXXM"_$L(X)
  1.  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
  1.  S X=$$MX(X)
  1.  Q X
  1.  ;             
  1. SW1(X) ; Switch Text (before setting case)
  1.  S X=$$SW1^LEXXMM($G(X)) Q X
  1. SW2(X) ; Switch Text (after setting case)
  1.  S X=$$SW2^LEXXMM($G(X)) Q X
  1. SW3(X) ; Switch Text (after assembling string)
  1.  S X=$$SW3^LEXXMM($G(X)) Q X
  1. EW(X) ; Display Word Usage
  1.  D EW^LEXXMM($G(X)) Q
  1.  ;             
  1. USE(X) ; Used
  1.  N STR,SEG,CUR S STR="",SEG=0 F  S SEG=$O(PAR(SEG)) Q:+SEG'>0  D
  1.  . N WC S WC=0  F  S WC=$O(PAR(SEG,"W",WC)) Q:+WC'>0  D
  1.  . . N WD S WD=$$UP($G(PAR(SEG,"W",WC)))
  1.  . . S:$E(STR,$L(STR))?1A!($E(STR,$L(STR))?1N) STR=$G(STR)_" "_WD
  1.  . . S:$E(STR,$L(STR))'?1A&($E(STR,$L(STR))'?1N) STR=$G(STR)_WD
  1.  . S:$L($G(PAR(SEG,"C"))) STR=STR_$G(PAR(SEG,"C"))
  1.  S CUR=$G(WD) I $L(CUR) D
  1.  . S:$E(STR,$L(STR))?1A!($E(STR,$L(STR))?1N) STR=$G(STR)_" "_CUR
  1.  . S:$E(STR,$L(STR))'?1A&($E(STR,$L(STR))'?1N) STR=$G(STR)_CUR
  1.  S X=$$TM(STR)
  1.  Q X
  1.  Q X
  1. FN(X) ; Footnote Removed
  1.  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
  1.  F NUM=1:1:9 S REP=")"_NUM_" ",WTH=") " I OUT[REP S OUT=$$SWAP^LEXXMM(OUT,REP,WTH)
  1.  S X=OUT
  1.  Q X
  1. LO(X) ; Lower Case
  1.  Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
  1. UP(X) ; Upper Case
  1.  Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. MX(X) ; Mixed Case
  1.  Q $TR($E(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
  1. LD(X) ; Leading Character
  1.  Q $TR($E(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$E(X,2,$L(X))
  1. TRIM(X) ; Trim Spaces
  1.  S X=$G(X) F  Q:$E(X,1)'=" "  S X=$E(X,2,$L(X))
  1.  F  Q:$E(X,$L(X))'=" "  S X=$E(X,1,($L(X)-1))
  1.  Q X
  1. TP(X) ; Trim Punctuation
  1.  S X=$G(X) Q:'$L(X) X  F  Q:$E(X,1)'?1P  S X=$E(X,2,$L(X))
  1.  F  Q:$E(X,$L(X))'?1P  S X=$E(X,1,($L(X)-1))
  1.  Q X
  1. TM(X,Y) ; Trim Character Y - Default " "
  1.  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))
  1.  F  Q:$E(X,$L(X))'=Y  S X=$E(X,1,($L(X)-1))
  1.  Q X
  1. DBL(X) ; Double Spaces
  1.  S X=$G(X) F  Q:X'["  "  S X=$P(X,"  ",1)_" "_$P(X,"  ",2,4000)
  1.  S X=$$TRIM(X)
  1.  Q X