LEXAS ;ISL/KER - Look-up Check Input ;04/21/2014
;;2.0;LEXICON UTILITY;**4,80**;Sep 23, 1996;Build 1
;
SPL(LEXX) ; Check word
S LEXX=$G(LEXX) Q:LEXX="" LEXX
Q:$L(LEXX)<6&(LEXX["/") LEXX ; PCH 4 - Quit if LEXX=XX/XX
N LEXFQ,LEXFQT,LEXT S LEXFQ=0,LEXFQT=""
S LEXT=$$DBL^LEXAS4(LEXX) D COMP(LEXX,LEXT)
S LEXT=$$REM^LEXAS4(LEXX) D COMP(LEXX,LEXT)
S LEXT=$$LC^LEXAS7(LEXX) D COMP(LEXX,LEXT)
S LEXT=$$TP^LEXAS6(LEXX) D COMP(LEXX,LEXT)
S LEXT=$$ONE^LEXAS2(LEXX) D COMP(LEXX,LEXT)
S LEXT=$$SHIFT^LEXAS3(LEXX) D COMP(LEXX,LEXT)
S LEXT=$$SPLIT^LEXAS5(LEXX) D COMP(LEXX,LEXT)
S LEXT=$$TRIM^LEXAS6(LEXX) D COMP(LEXX,LEXT)
S LEXT=$$TC^LEXAS7(LEXX) D COMP(LEXX,LEXT)
S:LEXFQT'="" LEXX=LEXFQT
Q LEXX
COMP(LEXKN,LEXF) ; Compare words
Q:'$L($G(LEXF)) N LEXOTKN,LEXCLEN,LEXLEN,LEXI,LEXC,LEXDIF
S LEXOTKN=LEXF,LEXCLEN=$L(LEXKN)+$L(LEXF) S:LEXF["^" LEXCLEN=LEXCLEN-1 S LEXC=0
S:LEXF'["^"&(+($$W(LEXF))) LEXC=1
S:LEXF["^" LEXF=$TR(LEXF,"^"," ")
S:$L(LEXKN)>$L(LEXF) LEXLEN=$L(LEXKN)-$L(LEXF) S:$L(LEXF)>$L(LEXKN) LEXLEN=$L(LEXF)-$L(LEXKN)
S:$L(LEXF)=$L(LEXKN) LEXLEN=0 S LEXCLEN=LEXCLEN-LEXLEN
I LEXKN'=LEXF D
. I LEXOTKN'["^" S LEXC=LEXC+$$CNT(LEXKN,LEXF)
. I LEXOTKN["^" D
. . S LEXC=LEXC+$$CNT($P(LEXOTKN,"^",2),$E(LEXKN,(($L(LEXKN)-$L($P(LEXOTKN,"^",2)))+1),$L(LEXKN)))
. . S LEXC=LEXC+($$CNT($P(LEXOTKN,"^",1),$E(LEXKN,1,$L($P(LEXOTKN,"^",1)))))
N LEXMUL S LEXMUL=LEXCLEN*LEXC
I LEXOTKN'["^",$D(^LEX(757.01,"AWRD",LEXOTKN)) S LEXMUL=LEXMUL*2
I LEXOTKN["^",$D(^LEX(757.01,"AWRD",$P(LEXOTKN,"^",2))) S LEXMUL=LEXMUL*2
S LEXMUL=0 I LEXC>0,LEXCLEN>0 S LEXMUL=LEXCLEN/LEXC
S LEXDIF=0 S:LEXMUL'=0 LEXDIF=LEXCLEN+LEXC
I LEXDIF>LEXFQ S LEXFQ=LEXDIF,LEXFQT=LEXOTKN
Q
CNT(LEXX,LEXY) ; Count characters
N LEXC,LEXL,LEXI,LEXU S LEXC=0
F LEXI=1:1:$L(LEXY) D
. S LEXL=$E(LEXY,LEXI) Q:$D(LEXU(LEXL)) S:$E(LEXX,LEXI)=$E(LEXY,LEXI) LEXC=LEXC+1
. I $L(LEXY)<$L(LEXX) S:$E(LEXX,(LEXI+1))=$E(LEXY,LEXI) LEXC=LEXC+1
. I $L(LEXY)>$L(LEXX) S:$E(LEXX,(LEXI-1))=$E(LEXY,LEXI) LEXC=LEXC+1
. S LEXU(LEXL)=""
K LEXU S LEXX=LEXC Q LEXX
Q
W(LEXX) ; Is LEXX a word
Q:'$L($G(LEXX)) 0
I $D(^LEX(757.01,"AWRD",LEXX)) Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXAS 2176 printed Dec 13, 2024@02:07:08 Page 2
LEXAS ;ISL/KER - Look-up Check Input ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**4,80**;Sep 23, 1996;Build 1
+2 ;
SPL(LEXX) ; Check word
+1 SET LEXX=$GET(LEXX)
if LEXX=""
QUIT LEXX
+2 ; PCH 4 - Quit if LEXX=XX/XX
if $LENGTH(LEXX)<6&(LEXX["/")
QUIT LEXX
+3 NEW LEXFQ,LEXFQT,LEXT
SET LEXFQ=0
SET LEXFQT=""
+4 SET LEXT=$$DBL^LEXAS4(LEXX)
DO COMP(LEXX,LEXT)
+5 SET LEXT=$$REM^LEXAS4(LEXX)
DO COMP(LEXX,LEXT)
+6 SET LEXT=$$LC^LEXAS7(LEXX)
DO COMP(LEXX,LEXT)
+7 SET LEXT=$$TP^LEXAS6(LEXX)
DO COMP(LEXX,LEXT)
+8 SET LEXT=$$ONE^LEXAS2(LEXX)
DO COMP(LEXX,LEXT)
+9 SET LEXT=$$SHIFT^LEXAS3(LEXX)
DO COMP(LEXX,LEXT)
+10 SET LEXT=$$SPLIT^LEXAS5(LEXX)
DO COMP(LEXX,LEXT)
+11 SET LEXT=$$TRIM^LEXAS6(LEXX)
DO COMP(LEXX,LEXT)
+12 SET LEXT=$$TC^LEXAS7(LEXX)
DO COMP(LEXX,LEXT)
+13 if LEXFQT'=""
SET LEXX=LEXFQT
+14 QUIT LEXX
COMP(LEXKN,LEXF) ; Compare words
+1 if '$LENGTH($GET(LEXF))
QUIT
NEW LEXOTKN,LEXCLEN,LEXLEN,LEXI,LEXC,LEXDIF
+2 SET LEXOTKN=LEXF
SET LEXCLEN=$LENGTH(LEXKN)+$LENGTH(LEXF)
if LEXF["^"
SET LEXCLEN=LEXCLEN-1
SET LEXC=0
+3 if LEXF'["^"&(+($$W(LEXF)))
SET LEXC=1
+4 if LEXF["^"
SET LEXF=$TRANSLATE(LEXF,"^"," ")
+5 if $LENGTH(LEXKN)>$LENGTH(LEXF)
SET LEXLEN=$LENGTH(LEXKN)-$LENGTH(LEXF)
if $LENGTH(LEXF)>$LENGTH(LEXKN)
SET LEXLEN=$LENGTH(LEXF)-$LENGTH(LEXKN)
+6 if $LENGTH(LEXF)=$LENGTH(LEXKN)
SET LEXLEN=0
SET LEXCLEN=LEXCLEN-LEXLEN
+7 IF LEXKN'=LEXF
Begin DoDot:1
+8 IF LEXOTKN'["^"
SET LEXC=LEXC+$$CNT(LEXKN,LEXF)
+9 IF LEXOTKN["^"
Begin DoDot:2
+10 SET LEXC=LEXC+$$CNT($PIECE(LEXOTKN,"^",2),$EXTRACT(LEXKN,(($LENGTH(LEXKN)-$LENGTH($PIECE(LEXOTKN,"^",2)))+1),$LENGTH(LEXKN)))
+11 SET LEXC=LEXC+($$CNT($PIECE(LEXOTKN,"^",1),$EXTRACT(LEXKN,1,$LENGTH($PIECE(LEXOTKN,"^",1)))))
End DoDot:2
End DoDot:1
+12 NEW LEXMUL
SET LEXMUL=LEXCLEN*LEXC
+13 IF LEXOTKN'["^"
IF $DATA(^LEX(757.01,"AWRD",LEXOTKN))
SET LEXMUL=LEXMUL*2
+14 IF LEXOTKN["^"
IF $DATA(^LEX(757.01,"AWRD",$PIECE(LEXOTKN,"^",2)))
SET LEXMUL=LEXMUL*2
+15 SET LEXMUL=0
IF LEXC>0
IF LEXCLEN>0
SET LEXMUL=LEXCLEN/LEXC
+16 SET LEXDIF=0
if LEXMUL'=0
SET LEXDIF=LEXCLEN+LEXC
+17 IF LEXDIF>LEXFQ
SET LEXFQ=LEXDIF
SET LEXFQT=LEXOTKN
+18 QUIT
CNT(LEXX,LEXY) ; Count characters
+1 NEW LEXC,LEXL,LEXI,LEXU
SET LEXC=0
+2 FOR LEXI=1:1:$LENGTH(LEXY)
Begin DoDot:1
+3 SET LEXL=$EXTRACT(LEXY,LEXI)
if $DATA(LEXU(LEXL))
QUIT
if $EXTRACT(LEXX,LEXI)=$EXTRACT(LEXY,LEXI)
SET LEXC=LEXC+1
+4 IF $LENGTH(LEXY)<$LENGTH(LEXX)
if $EXTRACT(LEXX,(LEXI+1))=$EXTRACT(LEXY,LEXI)
SET LEXC=LEXC+1
+5 IF $LENGTH(LEXY)>$LENGTH(LEXX)
if $EXTRACT(LEXX,(LEXI-1))=$EXTRACT(LEXY,LEXI)
SET LEXC=LEXC+1
+6 SET LEXU(LEXL)=""
End DoDot:1
+7 KILL LEXU
SET LEXX=LEXC
QUIT LEXX
+8 QUIT
W(LEXX) ; Is LEXX a word
+1 if '$LENGTH($GET(LEXX))
QUIT 0
+2 IF $DATA(^LEX(757.01,"AWRD",LEXX))
QUIT 1
+3 QUIT 0
