Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEXAS6

LEXAS6.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. TRIM(LEXX) ; Trim string
  1. ;
  1. ; LEXOK Flag - string is OK
  1. ; LEXF Frequency
  1. ; LEXI Incremental counter
  1. ; LEXT Temporary string
  1. ; LEXX Return string
  1. ;
  1. N LEXI,LEXOK,LEXT,LEXF S LEXF=1,LEXOK=0,LEXT=LEXX
  1. F Q:$E(LEXX,1)'=" " S LEXX=$E(LEXX,2,$L(LEXX))
  1. F LEXI=$L(LEXX):-1:1 Q:LEXOK D Q:LEXOK
  1. . S LEXT=$E(LEXT,1,($L(LEXT)-1))
  1. . I $L(LEXT)<3 S LEXOK=1 Q
  1. . I $D(^LEX(757.01,"ASL",LEXT)) S LEXF=$O(^LEX(757.01,"ASL",LEXT,0)) I +(LEXF)>1 S LEXOK=1
  1. S LEXX=LEXT
  1. Q LEXX
  1. ;
  1. EXP3(LEXX) ; Expand string up to 3 characters
  1. N LEXT S LEXT=LEXX
  1. S LEXT=$$EXP(LEXT)
  1. I $L(LEXT)-$L(LEXX)'>3 S LEXX=LEXT
  1. Q LEXX
  1. EXP(LEXX) ; Expand string
  1. ;
  1. ; LEXF String found
  1. ; LEXC Control string
  1. ; LEXCK Check for string
  1. ; LEXI Character position
  1. ; LEXLTR Letter at character position
  1. ; LEXNT Altered tolken
  1. ; LEXOK Flag - 1 quit 0 keep checking
  1. ; LEXOKL Flag - 1 add letter 0 do not add letter
  1. ; LEXX Return expanded string
  1. ;
  1. Q:$D(^LEX(757.01,"AWRD",LEXX)) LEXX
  1. N LEXF,LEXC,LEXCK,LEXI,LEXLTR,LEXNT,LEXOK,LEXOKL
  1. S (LEXF,LEXC)=LEXX,LEXOK=0
  1. S LEXNT=$O(^LEX(757.01,"ASL",$$SCH(LEXF)))
  1. F LEXI=1:1:63 Q:LEXOK D Q:LEXOK!(LEXNT'[LEXC)
  1. . Q:LEXI'>$L(LEXC)
  1. . S LEXNT=$O(^LEX(757.01,"ASL",LEXNT)) Q:LEXNT=LEXF
  1. . S LEXLTR=$E(LEXNT,LEXI) Q:LEXLTR=""
  1. . S LEXOKL=1,LEXCK=$$SCH(LEXNT)
  1. . F S LEXCK=$O(^LEX(757.01,"ASL",LEXCK)) Q:LEXCK=""!('LEXOKL) D
  1. . . I $E(LEXCK,LEXI)'="",$E(LEXCK,LEXI)'=LEXLTR S LEXOKL=0 Q
  1. . . I LEXCK'[LEXC,$E(LEXCK,LEXI)'=LEXLTR S LEXCK="~~~~~~~~~~~" Q
  1. . S:LEXOKL LEXF=LEXF_LEXLTR S:'LEXOKL LEXOK=1
  1. . S:$D(^LEX(757.01,"AWRD",LEXF)) LEXOK=1
  1. S LEXX=LEXF Q LEXX
  1. ;
  1. TP(LEXX) ; Transposed letters
  1. ;
  1. ; LEXF Tolken found
  1. ; LEXO Original tolken
  1. ; LEXN Concatenated tolken
  1. ; LEXT Temporary tolken
  1. ; LEXI Character position
  1. ; LEXX Return string
  1. ;
  1. N LEXO,LEXN,LEXI,LEXF,LEXT S (LEXF,LEXN)="",LEXO=LEXX
  1. F LEXI=2:1:$L(LEXX) Q:LEXF'="" D Q:LEXF'=""
  1. . S LEXN=$E(LEXX,1,(LEXI-1))_$E(LEXX,(LEXI+1))_$E(LEXX,LEXI)_$E(LEXX,(LEXI+2),$L(LEXX))
  1. . I $D(^LEX(757.01,"ASL",LEXN)) S LEXF=LEXN
  1. . S LEXT=$$ONE^LEXAS2(LEXN)
  1. . I $L(LEXT)=$L(LEXN),$D(^LEX(757.01,"ASL",LEXT)) S LEXF=LEXT
  1. S:LEXF'="" LEXX=LEXF
  1. S:LEXF="" LEXX=LEXO
  1. Q LEXX
  1. SCH(LEXX) ; Create $O variable
  1. ;
  1. ; LEXX Return $O variable
  1. ;
  1. S LEXX=$E(LEXX,1,($L(LEXX)-1))_$C($A($E(LEXX,$L(LEXX)))-1)_"~"
  1. Q LEXX