source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAS6.m@ 701

Last change on this file since 701 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.4 KB
Line 
1LEXAS6 ; ISL Look-up Check Input (TRIM,EXP,TP,SCH); 09-23-96
2 ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
3 ;
4TRIM(LEXX) ; Trim string
5 ;
6 ; LEXOK Flag - string is OK
7 ; LEXF Frequency
8 ; LEXI Incremental counter
9 ; LEXT Temporary string
10 ; LEXX Return string
11 ;
12 N LEXI,LEXOK,LEXT,LEXF S LEXF=1,LEXOK=0,LEXT=LEXX
13 F Q:$E(LEXX,1)'=" " S LEXX=$E(LEXX,2,$L(LEXX))
14 F LEXI=$L(LEXX):-1:1 Q:LEXOK D Q:LEXOK
15 . S LEXT=$E(LEXT,1,($L(LEXT)-1))
16 . I $L(LEXT)<3 S LEXOK=1 Q
17 . I $D(^LEX(757.01,"ASL",LEXT)) S LEXF=$O(^LEX(757.01,"ASL",LEXT,0)) I +(LEXF)>1 S LEXOK=1
18 S LEXX=LEXT
19 Q LEXX
20 ;
21EXP3(LEXX) ; Expand string up to 3 characters
22 N LEXT S LEXT=LEXX
23 S LEXT=$$EXP(LEXT)
24 I $L(LEXT)-$L(LEXX)'>3 S LEXX=LEXT
25 Q LEXX
26EXP(LEXX) ; Expand string
27 ;
28 ; LEXF String found
29 ; LEXC Control string
30 ; LEXCK Check for string
31 ; LEXI Character position
32 ; LEXLTR Letter at character position
33 ; LEXNT Altered tolken
34 ; LEXOK Flag - 1 quit 0 keep checking
35 ; LEXOKL Flag - 1 add letter 0 do not add letter
36 ; LEXX Return expanded string
37 ;
38 Q:$D(^LEX(757.01,"AWRD",LEXX)) LEXX
39 N LEXF,LEXC,LEXCK,LEXI,LEXLTR,LEXNT,LEXOK,LEXOKL
40 S (LEXF,LEXC)=LEXX,LEXOK=0
41 S LEXNT=$O(^LEX(757.01,"ASL",$$SCH(LEXF)))
42 F LEXI=1:1:63 Q:LEXOK D Q:LEXOK!(LEXNT'[LEXC)
43 . Q:LEXI'>$L(LEXC)
44 . S LEXNT=$O(^LEX(757.01,"ASL",LEXNT)) Q:LEXNT=LEXF
45 . S LEXLTR=$E(LEXNT,LEXI) Q:LEXLTR=""
46 . S LEXOKL=1,LEXCK=$$SCH(LEXNT)
47 . F S LEXCK=$O(^LEX(757.01,"ASL",LEXCK)) Q:LEXCK=""!('LEXOKL) D
48 . . I $E(LEXCK,LEXI)'="",$E(LEXCK,LEXI)'=LEXLTR S LEXOKL=0 Q
49 . . I LEXCK'[LEXC,$E(LEXCK,LEXI)'=LEXLTR S LEXCK="ZZZZ" Q
50 . S:LEXOKL LEXF=LEXF_LEXLTR S:'LEXOKL LEXOK=1
51 . S:$D(^LEX(757.01,"AWRD",LEXF)) LEXOK=1
52 S LEXX=LEXF Q LEXX
53 ;
54TP(LEXX) ; Transposed letters
55 ;
56 ; LEXF Tolken found
57 ; LEXO Original tolken
58 ; LEXN Concatenated tolken
59 ; LEXT Temporary tolken
60 ; LEXI Character position
61 ; LEXX Return string
62 ;
63 N LEXO,LEXN,LEXI,LEXF,LEXT S (LEXF,LEXN)="",LEXO=LEXX
64 F LEXI=2:1:$L(LEXX) Q:LEXF'="" D Q:LEXF'=""
65 . S LEXN=$E(LEXX,1,(LEXI-1))_$E(LEXX,(LEXI+1))_$E(LEXX,LEXI)_$E(LEXX,(LEXI+2),$L(LEXX))
66 . I $D(^LEX(757.01,"ASL",LEXN)) S LEXF=LEXN
67 . S LEXT=$$ONE^LEXAS2(LEXN)
68 . I $L(LEXT)=$L(LEXN),$D(^LEX(757.01,"ASL",LEXT)) S LEXF=LEXT
69 S:LEXF'="" LEXX=LEXF
70 S:LEXF="" LEXX=LEXO
71 Q LEXX
72SCH(LEXX) ; Create $O variable
73 ;
74 ; LEXX Return $O variable
75 ;
76 S LEXX=$E(LEXX,1,($L(LEXX)-1))_$C($A($E(LEXX,$L(LEXX)))-1)_"~"
77 Q LEXX
Note: See TracBrowser for help on using the repository browser.