- LEXAS ;ISL/KER - Look-up Check Input ;04/21/2014
- ;;2.0;LEXICON UTILITY;**4,80**;Sep 23, 1996;Build 10
- ;
- 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
- LEXAS ;ISL/KER - Look-up Check Input ;04/21/2014
- +1 ;;2.0;LEXICON UTILITY;**4,80**;Sep 23, 1996;Build 10
- +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