LEXAS6 ;ISL/KER - Look-up Check Input (TRIM,EXP,TP,SCH) ;04/21/2014
;;2.0;LEXICON UTILITY;**41,80**;Sep 23, 1996;Build 1
;
TRIM(LEXX) ; Trim string
;
; LEXOK Flag - string is OK
; LEXF Frequency
; LEXI Incremental counter
; LEXT Temporary string
; LEXX Return string
;
N LEXI,LEXOK,LEXT,LEXF S LEXF=1,LEXOK=0,LEXT=LEXX
F Q:$E(LEXX,1)'=" " S LEXX=$E(LEXX,2,$L(LEXX))
F LEXI=$L(LEXX):-1:1 Q:LEXOK D Q:LEXOK
. S LEXT=$E(LEXT,1,($L(LEXT)-1))
. I $L(LEXT)<3 S LEXOK=1 Q
. I $D(^LEX(757.01,"ASL",LEXT)) S LEXF=$O(^LEX(757.01,"ASL",LEXT,0)) I +(LEXF)>1 S LEXOK=1
S LEXX=LEXT
Q LEXX
;
EXP3(LEXX) ; Expand string up to 3 characters
N LEXT S LEXT=LEXX
S LEXT=$$EXP(LEXT)
I $L(LEXT)-$L(LEXX)'>3 S LEXX=LEXT
Q LEXX
EXP(LEXX) ; Expand string
;
; LEXF String found
; LEXC Control string
; LEXCK Check for string
; LEXI Character position
; LEXLTR Letter at character position
; LEXNT Altered tolken
; LEXOK Flag - 1 quit 0 keep checking
; LEXOKL Flag - 1 add letter 0 do not add letter
; LEXX Return expanded string
;
Q:$D(^LEX(757.01,"AWRD",LEXX)) LEXX
N LEXF,LEXC,LEXCK,LEXI,LEXLTR,LEXNT,LEXOK,LEXOKL
S (LEXF,LEXC)=LEXX,LEXOK=0
S LEXNT=$O(^LEX(757.01,"ASL",$$SCH(LEXF)))
F LEXI=1:1:63 Q:LEXOK D Q:LEXOK!(LEXNT'[LEXC)
. Q:LEXI'>$L(LEXC)
. S LEXNT=$O(^LEX(757.01,"ASL",LEXNT)) Q:LEXNT=LEXF
. S LEXLTR=$E(LEXNT,LEXI) Q:LEXLTR=""
. S LEXOKL=1,LEXCK=$$SCH(LEXNT)
. F S LEXCK=$O(^LEX(757.01,"ASL",LEXCK)) Q:LEXCK=""!('LEXOKL) D
. . I $E(LEXCK,LEXI)'="",$E(LEXCK,LEXI)'=LEXLTR S LEXOKL=0 Q
. . I LEXCK'[LEXC,$E(LEXCK,LEXI)'=LEXLTR S LEXCK="~~~~~~~~~~~" Q
. S:LEXOKL LEXF=LEXF_LEXLTR S:'LEXOKL LEXOK=1
. S:$D(^LEX(757.01,"AWRD",LEXF)) LEXOK=1
S LEXX=LEXF Q LEXX
;
TP(LEXX) ; Transposed letters
;
; LEXF Tolken found
; LEXO Original tolken
; LEXN Concatenated tolken
; LEXT Temporary tolken
; LEXI Character position
; LEXX Return string
;
N LEXO,LEXN,LEXI,LEXF,LEXT S (LEXF,LEXN)="",LEXO=LEXX
F LEXI=2:1:$L(LEXX) Q:LEXF'="" D Q:LEXF'=""
. S LEXN=$E(LEXX,1,(LEXI-1))_$E(LEXX,(LEXI+1))_$E(LEXX,LEXI)_$E(LEXX,(LEXI+2),$L(LEXX))
. I $D(^LEX(757.01,"ASL",LEXN)) S LEXF=LEXN
. S LEXT=$$ONE^LEXAS2(LEXN)
. I $L(LEXT)=$L(LEXN),$D(^LEX(757.01,"ASL",LEXT)) S LEXF=LEXT
S:LEXF'="" LEXX=LEXF
S:LEXF="" LEXX=LEXO
Q LEXX
SCH(LEXX) ; Create $O variable
;
; LEXX Return $O variable
;
S LEXX=$E(LEXX,1,($L(LEXX)-1))_$C($A($E(LEXX,$L(LEXX)))-1)_"~"
Q LEXX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXAS6 2531 printed Oct 16, 2024@18:07:55 Page 2
LEXAS6 ;ISL/KER - Look-up Check Input (TRIM,EXP,TP,SCH) ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**41,80**;Sep 23, 1996;Build 1
+2 ;
TRIM(LEXX) ; Trim string
+1 ;
+2 ; LEXOK Flag - string is OK
+3 ; LEXF Frequency
+4 ; LEXI Incremental counter
+5 ; LEXT Temporary string
+6 ; LEXX Return string
+7 ;
+8 NEW LEXI,LEXOK,LEXT,LEXF
SET LEXF=1
SET LEXOK=0
SET LEXT=LEXX
+9 FOR
if $EXTRACT(LEXX,1)'=" "
QUIT
SET LEXX=$EXTRACT(LEXX,2,$LENGTH(LEXX))
+10 FOR LEXI=$LENGTH(LEXX):-1:1
if LEXOK
QUIT
Begin DoDot:1
+11 SET LEXT=$EXTRACT(LEXT,1,($LENGTH(LEXT)-1))
+12 IF $LENGTH(LEXT)<3
SET LEXOK=1
QUIT
+13 IF $DATA(^LEX(757.01,"ASL",LEXT))
SET LEXF=$ORDER(^LEX(757.01,"ASL",LEXT,0))
IF +(LEXF)>1
SET LEXOK=1
End DoDot:1
if LEXOK
QUIT
+14 SET LEXX=LEXT
+15 QUIT LEXX
+16 ;
EXP3(LEXX) ; Expand string up to 3 characters
+1 NEW LEXT
SET LEXT=LEXX
+2 SET LEXT=$$EXP(LEXT)
+3 IF $LENGTH(LEXT)-$LENGTH(LEXX)'>3
SET LEXX=LEXT
+4 QUIT LEXX
EXP(LEXX) ; Expand string
+1 ;
+2 ; LEXF String found
+3 ; LEXC Control string
+4 ; LEXCK Check for string
+5 ; LEXI Character position
+6 ; LEXLTR Letter at character position
+7 ; LEXNT Altered tolken
+8 ; LEXOK Flag - 1 quit 0 keep checking
+9 ; LEXOKL Flag - 1 add letter 0 do not add letter
+10 ; LEXX Return expanded string
+11 ;
+12 if $DATA(^LEX(757.01,"AWRD",LEXX))
QUIT LEXX
+13 NEW LEXF,LEXC,LEXCK,LEXI,LEXLTR,LEXNT,LEXOK,LEXOKL
+14 SET (LEXF,LEXC)=LEXX
SET LEXOK=0
+15 SET LEXNT=$ORDER(^LEX(757.01,"ASL",$$SCH(LEXF)))
+16 FOR LEXI=1:1:63
if LEXOK
QUIT
Begin DoDot:1
+17 if LEXI'>$LENGTH(LEXC)
QUIT
+18 SET LEXNT=$ORDER(^LEX(757.01,"ASL",LEXNT))
if LEXNT=LEXF
QUIT
+19 SET LEXLTR=$EXTRACT(LEXNT,LEXI)
if LEXLTR=""
QUIT
+20 SET LEXOKL=1
SET LEXCK=$$SCH(LEXNT)
+21 FOR
SET LEXCK=$ORDER(^LEX(757.01,"ASL",LEXCK))
if LEXCK=""!('LEXOKL)
QUIT
Begin DoDot:2
+22 IF $EXTRACT(LEXCK,LEXI)'=""
IF $EXTRACT(LEXCK,LEXI)'=LEXLTR
SET LEXOKL=0
QUIT
+23 IF LEXCK'[LEXC
IF $EXTRACT(LEXCK,LEXI)'=LEXLTR
SET LEXCK="~~~~~~~~~~~"
QUIT
End DoDot:2
+24 if LEXOKL
SET LEXF=LEXF_LEXLTR
if 'LEXOKL
SET LEXOK=1
+25 if $DATA(^LEX(757.01,"AWRD",LEXF))
SET LEXOK=1
End DoDot:1
if LEXOK!(LEXNT'[LEXC)
QUIT
+26 SET LEXX=LEXF
QUIT LEXX
+27 ;
TP(LEXX) ; Transposed letters
+1 ;
+2 ; LEXF Tolken found
+3 ; LEXO Original tolken
+4 ; LEXN Concatenated tolken
+5 ; LEXT Temporary tolken
+6 ; LEXI Character position
+7 ; LEXX Return string
+8 ;
+9 NEW LEXO,LEXN,LEXI,LEXF,LEXT
SET (LEXF,LEXN)=""
SET LEXO=LEXX
+10 FOR LEXI=2:1:$LENGTH(LEXX)
if LEXF'=""
QUIT
Begin DoDot:1
+11 SET LEXN=$EXTRACT(LEXX,1,(LEXI-1))_$EXTRACT(LEXX,(LEXI+1))_$EXTRACT(LEXX,LEXI)_$EXTRACT(LEXX,(LEXI+2),$LENGTH(LEXX))
+12 IF $DATA(^LEX(757.01,"ASL",LEXN))
SET LEXF=LEXN
+13 SET LEXT=$$ONE^LEXAS2(LEXN)
+14 IF $LENGTH(LEXT)=$LENGTH(LEXN)
IF $DATA(^LEX(757.01,"ASL",LEXT))
SET LEXF=LEXT
End DoDot:1
if LEXF'=""
QUIT
+15 if LEXF'=""
SET LEXX=LEXF
+16 if LEXF=""
SET LEXX=LEXO
+17 QUIT LEXX
SCH(LEXX) ; Create $O variable
+1 ;
+2 ; LEXX Return $O variable
+3 ;
+4 SET LEXX=$EXTRACT(LEXX,1,($LENGTH(LEXX)-1))_$CHAR($ASCII($EXTRACT(LEXX,$LENGTH(LEXX)))-1)_"~"
+5 QUIT LEXX
