- LEXAS7 ;ISL/KER - Look-up Check Input (LC,TC) ;04/21/2014
- ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
- ;
- LC(LEXX) ; Leading characters
- ;
- ; LEXX Return string
- ; LEXL Letter
- ; LEXG Group of letters
- ; LEXI Incremental counter
- ; LEXT Temporary tolken
- ; LEXOK Flag - found tolken
- ; LEXS Swap character
- ; LEXA Add character
- ;
- N LEXT
- S LEXT=$$LCS(LEXX) I LEXT'=LEXX,$D(^LEX(757.01,"ASL",LEXT)) S LEXX=LEXT Q LEXT
- I $L(LEXT)'>5 Q LEXX
- S LEXT=$$LCR(LEXX) I $D(^LEX(757.01,"AWRD",LEXT)) S LEXX=LEXT Q LEXX
- I $L(LEXT)'>4 Q LEXX
- S LEXT=$$LCR(LEXX) I $D(^LEX(757.01,"AWRD",LEXT)) S LEXX=LEXT Q LEXX
- Q LEXX
- ;
- LCS(LEXX) ; Swap
- N LEXI,LEXF,LEXL,LEXG,LEXOK,LEXS,LEXA S LEXOK=0
- S LEXF=$$FIRST(LEXX),LEXS=$$SECOND(LEXX)
- I $D(^LEX(757.01,"ASL",LEXS)) S LEXX=LEXS Q LEXX
- I $D(^LEX(757.01,"ASL",LEXF)) S LEXX=LEXF Q LEXX
- S LEXF=$$FIRST(LEXS)
- I $D(^LEX(757.01,"ASL",LEXF)) S LEXX=LEXF Q LEXX
- Q LEXX
- LCR(LEXX) ; Remove/Shift
- N LEXT
- S LEXX=$E(LEXX,2,$L(LEXX))
- S LEXT=$$SHIFT^LEXAS3(LEXX)
- I $D(^LEX(757.01,"ASL",LEXT)) S LEXX=LEXT Q LEXX
- Q LEXX
- SECOND(LEXX) ; Second letter (Swap)
- N LEXL,LEXG,LEXOK,LEXI,LEXA,LEXS
- S LEXL=$E(LEXX,2),LEXG=$$GRP(LEXL),LEXOK=0
- F LEXI=1:1:$L(LEXG) D Q:LEXOK
- . S LEXS=$E(LEXX,1)_$E(LEXG,LEXI)_$E(LEXX,3,$L(LEXX))
- . I $D(^LEX(757.01,"ASL",LEXS)) S LEXX=LEXS,LEXOK=1 Q
- . S LEXS=$$TP^LEXAS6(LEXS)
- . I $D(^LEX(757.01,"ASL",LEXS)),$L(LEXS)=$L(LEXX) S LEXX=LEXS,LEXOK=1 Q
- . S LEXS=$$ONE^LEXAS2(LEXS) Q:LEXS=""
- . I $D(^LEX(757.01,"ASL",LEXS)),$L(LEXS)=$L(LEXX) S LEXX=LEXS,LEXOK=1 Q
- Q:LEXOK LEXX
- ; Second letter (Add)
- S LEXOK=0 F LEXI=65:1:90 D Q:LEXOK
- . S LEXA=$E(LEXX,1)_$C(LEXI)_$E(LEXX,2,$L(LEXX))
- . I $D(^LEX(757.01,"ASL",LEXA)) S LEXX=LEXA,LEXOK=1 Q
- Q LEXX
- ;
- FIRST(LEXX) ; First letter (Swap)
- N LEXL,LEXG,LEXOK,LEXI,LEXA,LEXS
- S LEXL=$E(LEXX,1),LEXG=$$GRP(LEXL),LEXOK=0
- F LEXI=1:1:$L(LEXG) D Q:LEXOK
- . S LEXS=$E(LEXG,LEXI)_$E(LEXX,2,$L(LEXX))
- . I $D(^LEX(757.01,"ASL",LEXS)) S LEXX=LEXS,LEXOK=1 Q
- . S LEXS=$$LF(LEXS)
- . I $D(^LEX(757.01,"ASL",LEXS)) S LEXX=LEXS,LEXOK=1 Q
- Q:LEXOK LEXX
- ;
- ; First letter (Add)
- S LEXOK=0 F LEXI=65:1:90 D Q:LEXOK
- . S LEXA=$C(LEXI)_LEXX
- . I $D(^LEX(757.01,"ASL",LEXA)) S LEXX=LEXA,LEXOK=1 Q
- Q LEXX
- LF(LEXX) ;
- Q:$L($G(LEXX))'>7 LEXX
- N LEXN,LEXC,LEXT,LEXF,LEXO,LEXOK
- S (LEXN,LEXC)=$E(LEXX,1,4) Q:'$D(^LEX(757.01,"ASL",LEXN)) LEXX
- S LEXT=$P(LEXX,LEXN,2) Q:$L(LEXT)<4 LEXX
- S LEXOK=0,LEXO=$$SCH^LEXAS6(LEXN)
- S LEXT=$E(LEXT,($L(LEXT)-6),$L(LEXT))
- F S LEXO=$O(^LEX(757.01,"AWRD",LEXO)) Q:LEXO=""!(LEXO'[LEXC)!(LEXOK) D
- . S LEXF=$E(LEXO,($L(LEXO)-($L(LEXT)-1)),$L(LEXO))
- . I LEXF=LEXT S LEXT=LEXO,LEXOK=1
- I LEXOK S LEXX=LEXT
- Q LEXX
- TC(LEXX) ; Trailing character
- Q:$L(LEXX)<6 LEXX
- N LEXC,LEXT,LEXLC,LEXO,LEXOK,LEXCL
- S LEXCL=$L(LEXX),LEXC=$$TRIM^LEXAS6(LEXX),LEXC=$E(LEXC,1,($L(LEXC)-1))
- S LEXLC=$E(LEXX,$L(LEXX)),LEXO=$$SCH^LEXAS6(LEXC),LEXOK=0,LEXT=""
- ;
- F S LEXO=$O(^LEX(757.01,"AWRD",LEXO)) Q:LEXO=""!(LEXO'[LEXC)!(LEXOK) D
- . Q:$E(LEXO,$L(LEXO))'=LEXLC
- . ; Exact
- . I $E(LEXO,LEXCL)=LEXLC S LEXT=LEXO,LEXOK=1 Q
- . ; 1 Less
- . I $E(LEXO,(LEXCL-1))=LEXLC S LEXT=LEXO,LEXOK=1 Q
- I LEXT'="",LEXOK S LEXX=LEXT
- Q LEXX
- ;
- GRP(LEXX) ; Letter groups (off the home row QWERTY)
- N LEXG S LEXG=LEXX
- S:LEXX="A" LEXG="QZOWSX" S:LEXX="B" LEXG="VGHNF"
- S:LEXX="C" LEXG="XDVFS" S:LEXX="D" LEXG="ECXRFSWV"
- S:LEXX="E" LEXG="RWIDFS" S:LEXX="F" LEXG="GBVDRCET"
- S:LEXX="G" LEXG="FBTVRHYN" S:LEXX="H" LEXG="JGNYBUMT"
- S:LEXX="I" LEXG="UOYEKJL" S:LEXX="J" LEXG="HNKUMYI"
- S:LEXX="K" LEXG="IJLMOU" S:LEXX="L" LEXG="OKPI"
- S:LEXX="M" LEXG="NJKH" S:LEXX="N" LEXG="MBJH"
- S:LEXX="O" LEXG="LIPAK" S:LEXX="P" LEXG="OL"
- S:LEXX="Q" LEXG="AWS" S:LEXX="R" LEXG="TEGFD"
- S:LEXX="S" LEXG="XWADZE" S:LEXX="T" LEXG="RGFYH"
- S:LEXX="U" LEXG="YHIJK" S:LEXX="V" LEXG="CBFDG"
- S:LEXX="W" LEXG="QESAD" S:LEXX="X" LEXG="ZSACD"
- S:LEXX="Y" LEXG="UHIJGT" S:LEXX="Z" LEXG="ASX"
- S:LEXG'=LEXX LEXX=LEXG
- Q LEXX
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXAS7 4024 printed Mar 13, 2025@21:11:44 Page 2
- LEXAS7 ;ISL/KER - Look-up Check Input (LC,TC) ;04/21/2014
- +1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
- +2 ;
- LC(LEXX) ; Leading characters
- +1 ;
- +2 ; LEXX Return string
- +3 ; LEXL Letter
- +4 ; LEXG Group of letters
- +5 ; LEXI Incremental counter
- +6 ; LEXT Temporary tolken
- +7 ; LEXOK Flag - found tolken
- +8 ; LEXS Swap character
- +9 ; LEXA Add character
- +10 ;
- +11 NEW LEXT
- +12 SET LEXT=$$LCS(LEXX)
- IF LEXT'=LEXX
- IF $DATA(^LEX(757.01,"ASL",LEXT))
- SET LEXX=LEXT
- QUIT LEXT
- +13 IF $LENGTH(LEXT)'>5
- QUIT LEXX
- +14 SET LEXT=$$LCR(LEXX)
- IF $DATA(^LEX(757.01,"AWRD",LEXT))
- SET LEXX=LEXT
- QUIT LEXX
- +15 IF $LENGTH(LEXT)'>4
- QUIT LEXX
- +16 SET LEXT=$$LCR(LEXX)
- IF $DATA(^LEX(757.01,"AWRD",LEXT))
- SET LEXX=LEXT
- QUIT LEXX
- +17 QUIT LEXX
- +18 ;
- LCS(LEXX) ; Swap
- +1 NEW LEXI,LEXF,LEXL,LEXG,LEXOK,LEXS,LEXA
- SET LEXOK=0
- +2 SET LEXF=$$FIRST(LEXX)
- SET LEXS=$$SECOND(LEXX)
- +3 IF $DATA(^LEX(757.01,"ASL",LEXS))
- SET LEXX=LEXS
- QUIT LEXX
- +4 IF $DATA(^LEX(757.01,"ASL",LEXF))
- SET LEXX=LEXF
- QUIT LEXX
- +5 SET LEXF=$$FIRST(LEXS)
- +6 IF $DATA(^LEX(757.01,"ASL",LEXF))
- SET LEXX=LEXF
- QUIT LEXX
- +7 QUIT LEXX
- LCR(LEXX) ; Remove/Shift
- +1 NEW LEXT
- +2 SET LEXX=$EXTRACT(LEXX,2,$LENGTH(LEXX))
- +3 SET LEXT=$$SHIFT^LEXAS3(LEXX)
- +4 IF $DATA(^LEX(757.01,"ASL",LEXT))
- SET LEXX=LEXT
- QUIT LEXX
- +5 QUIT LEXX
- SECOND(LEXX) ; Second letter (Swap)
- +1 NEW LEXL,LEXG,LEXOK,LEXI,LEXA,LEXS
- +2 SET LEXL=$EXTRACT(LEXX,2)
- SET LEXG=$$GRP(LEXL)
- SET LEXOK=0
- +3 FOR LEXI=1:1:$LENGTH(LEXG)
- Begin DoDot:1
- +4 SET LEXS=$EXTRACT(LEXX,1)_$EXTRACT(LEXG,LEXI)_$EXTRACT(LEXX,3,$LENGTH(LEXX))
- +5 IF $DATA(^LEX(757.01,"ASL",LEXS))
- SET LEXX=LEXS
- SET LEXOK=1
- QUIT
- +6 SET LEXS=$$TP^LEXAS6(LEXS)
- +7 IF $DATA(^LEX(757.01,"ASL",LEXS))
- IF $LENGTH(LEXS)=$LENGTH(LEXX)
- SET LEXX=LEXS
- SET LEXOK=1
- QUIT
- +8 SET LEXS=$$ONE^LEXAS2(LEXS)
- if LEXS=""
- QUIT
- +9 IF $DATA(^LEX(757.01,"ASL",LEXS))
- IF $LENGTH(LEXS)=$LENGTH(LEXX)
- SET LEXX=LEXS
- SET LEXOK=1
- QUIT
- End DoDot:1
- if LEXOK
- QUIT
- +10 if LEXOK
- QUIT LEXX
- +11 ; Second letter (Add)
- +12 SET LEXOK=0
- FOR LEXI=65:1:90
- Begin DoDot:1
- +13 SET LEXA=$EXTRACT(LEXX,1)_$CHAR(LEXI)_$EXTRACT(LEXX,2,$LENGTH(LEXX))
- +14 IF $DATA(^LEX(757.01,"ASL",LEXA))
- SET LEXX=LEXA
- SET LEXOK=1
- QUIT
- End DoDot:1
- if LEXOK
- QUIT
- +15 QUIT LEXX
- +16 ;
- FIRST(LEXX) ; First letter (Swap)
- +1 NEW LEXL,LEXG,LEXOK,LEXI,LEXA,LEXS
- +2 SET LEXL=$EXTRACT(LEXX,1)
- SET LEXG=$$GRP(LEXL)
- SET LEXOK=0
- +3 FOR LEXI=1:1:$LENGTH(LEXG)
- Begin DoDot:1
- +4 SET LEXS=$EXTRACT(LEXG,LEXI)_$EXTRACT(LEXX,2,$LENGTH(LEXX))
- +5 IF $DATA(^LEX(757.01,"ASL",LEXS))
- SET LEXX=LEXS
- SET LEXOK=1
- QUIT
- +6 SET LEXS=$$LF(LEXS)
- +7 IF $DATA(^LEX(757.01,"ASL",LEXS))
- SET LEXX=LEXS
- SET LEXOK=1
- QUIT
- End DoDot:1
- if LEXOK
- QUIT
- +8 if LEXOK
- QUIT LEXX
- +9 ;
- +10 ; First letter (Add)
- +11 SET LEXOK=0
- FOR LEXI=65:1:90
- Begin DoDot:1
- +12 SET LEXA=$CHAR(LEXI)_LEXX
- +13 IF $DATA(^LEX(757.01,"ASL",LEXA))
- SET LEXX=LEXA
- SET LEXOK=1
- QUIT
- End DoDot:1
- if LEXOK
- QUIT
- +14 QUIT LEXX
- LF(LEXX) ;
- +1 if $LENGTH($GET(LEXX))'>7
- QUIT LEXX
- +2 NEW LEXN,LEXC,LEXT,LEXF,LEXO,LEXOK
- +3 SET (LEXN,LEXC)=$EXTRACT(LEXX,1,4)
- if '$DATA(^LEX(757.01,"ASL",LEXN))
- QUIT LEXX
- +4 SET LEXT=$PIECE(LEXX,LEXN,2)
- if $LENGTH(LEXT)<4
- QUIT LEXX
- +5 SET LEXOK=0
- SET LEXO=$$SCH^LEXAS6(LEXN)
- +6 SET LEXT=$EXTRACT(LEXT,($LENGTH(LEXT)-6),$LENGTH(LEXT))
- +7 FOR
- SET LEXO=$ORDER(^LEX(757.01,"AWRD",LEXO))
- if LEXO=""!(LEXO'[LEXC)!(LEXOK)
- QUIT
- Begin DoDot:1
- +8 SET LEXF=$EXTRACT(LEXO,($LENGTH(LEXO)-($LENGTH(LEXT)-1)),$LENGTH(LEXO))
- +9 IF LEXF=LEXT
- SET LEXT=LEXO
- SET LEXOK=1
- End DoDot:1
- +10 IF LEXOK
- SET LEXX=LEXT
- +11 QUIT LEXX
- TC(LEXX) ; Trailing character
- +1 if $LENGTH(LEXX)<6
- QUIT LEXX
- +2 NEW LEXC,LEXT,LEXLC,LEXO,LEXOK,LEXCL
- +3 SET LEXCL=$LENGTH(LEXX)
- SET LEXC=$$TRIM^LEXAS6(LEXX)
- SET LEXC=$EXTRACT(LEXC,1,($LENGTH(LEXC)-1))
- +4 SET LEXLC=$EXTRACT(LEXX,$LENGTH(LEXX))
- SET LEXO=$$SCH^LEXAS6(LEXC)
- SET LEXOK=0
- SET LEXT=""
- +5 ;
- +6 FOR
- SET LEXO=$ORDER(^LEX(757.01,"AWRD",LEXO))
- if LEXO=""!(LEXO'[LEXC)!(LEXOK)
- QUIT
- Begin DoDot:1
- +7 if $EXTRACT(LEXO,$LENGTH(LEXO))'=LEXLC
- QUIT
- +8 ; Exact
- +9 IF $EXTRACT(LEXO,LEXCL)=LEXLC
- SET LEXT=LEXO
- SET LEXOK=1
- QUIT
- +10 ; 1 Less
- +11 IF $EXTRACT(LEXO,(LEXCL-1))=LEXLC
- SET LEXT=LEXO
- SET LEXOK=1
- QUIT
- End DoDot:1
- +12 IF LEXT'=""
- IF LEXOK
- SET LEXX=LEXT
- +13 QUIT LEXX
- +14 ;
- GRP(LEXX) ; Letter groups (off the home row QWERTY)
- +1 NEW LEXG
- SET LEXG=LEXX
- +2 if LEXX="A"
- SET LEXG="QZOWSX"
- if LEXX="B"
- SET LEXG="VGHNF"
- +3 if LEXX="C"
- SET LEXG="XDVFS"
- if LEXX="D"
- SET LEXG="ECXRFSWV"
- +4 if LEXX="E"
- SET LEXG="RWIDFS"
- if LEXX="F"
- SET LEXG="GBVDRCET"
- +5 if LEXX="G"
- SET LEXG="FBTVRHYN"
- if LEXX="H"
- SET LEXG="JGNYBUMT"
- +6 if LEXX="I"
- SET LEXG="UOYEKJL"
- if LEXX="J"
- SET LEXG="HNKUMYI"
- +7 if LEXX="K"
- SET LEXG="IJLMOU"
- if LEXX="L"
- SET LEXG="OKPI"
- +8 if LEXX="M"
- SET LEXG="NJKH"
- if LEXX="N"
- SET LEXG="MBJH"
- +9 if LEXX="O"
- SET LEXG="LIPAK"
- if LEXX="P"
- SET LEXG="OL"
- +10 if LEXX="Q"
- SET LEXG="AWS"
- if LEXX="R"
- SET LEXG="TEGFD"
- +11 if LEXX="S"
- SET LEXG="XWADZE"
- if LEXX="T"
- SET LEXG="RGFYH"
- +12 if LEXX="U"
- SET LEXG="YHIJK"
- if LEXX="V"
- SET LEXG="CBFDG"
- +13 if LEXX="W"
- SET LEXG="QESAD"
- if LEXX="X"
- SET LEXG="ZSACD"
- +14 if LEXX="Y"
- SET LEXG="UHIJGT"
- if LEXX="Z"
- SET LEXG="ASX"
- +15 if LEXG'=LEXX
- SET LEXX=LEXG
- +16 QUIT LEXX
- +17 QUIT
