- 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 Jan 18, 2025@03:08:08 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