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 Dec 13, 2024@02:07:14 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
