source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAS7.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: 3.8 KB
Line 
1LEXAS7 ; ISL Look-up Check Input (LC,TC) ; 09-23-96
2 ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
3 ;
4LC(LEXX) ; Leading characters
5 ;
6 ; LEXX Return string
7 ; LEXL Letter
8 ; LEXG Group of letters
9 ; LEXI Incremental counter
10 ; LEXT Temporary tolken
11 ; LEXOK Flag - found tolken
12 ; LEXS Swap character
13 ; LEXA Add character
14 ;
15 N LEXT
16 S LEXT=$$LCS(LEXX) I LEXT'=LEXX,$D(^LEX(757.01,"ASL",LEXT)) S LEXX=LEXT Q LEXT
17 I $L(LEXT)'>5 Q LEXX
18 S LEXT=$$LCR(LEXX) I $D(^LEX(757.01,"AWRD",LEXT)) S LEXX=LEXT Q LEXX
19 I $L(LEXT)'>4 Q LEXX
20 S LEXT=$$LCR(LEXX) I $D(^LEX(757.01,"AWRD",LEXT)) S LEXX=LEXT Q LEXX
21 Q LEXX
22 ;
23LCS(LEXX) ; Swap
24 N LEXI,LEXF,LEXL,LEXG,LEXOK,LEXS,LEXA S LEXOK=0
25 S LEXF=$$FIRST(LEXX),LEXS=$$SECOND(LEXX)
26 I $D(^LEX(757.01,"ASL",LEXS)) S LEXX=LEXS Q LEXX
27 I $D(^LEX(757.01,"ASL",LEXF)) S LEXX=LEXF Q LEXX
28 S LEXF=$$FIRST(LEXS)
29 I $D(^LEX(757.01,"ASL",LEXF)) S LEXX=LEXF Q LEXX
30 Q LEXX
31LCR(LEXX) ; Remove/Shift
32 N LEXT
33 S LEXX=$E(LEXX,2,$L(LEXX))
34 S LEXT=$$SHIFT^LEXAS3(LEXX)
35 I $D(^LEX(757.01,"ASL",LEXT)) S LEXX=LEXT Q LEXX
36 Q LEXX
37SECOND(LEXX) ; Second letter (Swap)
38 N LEXL,LEXG,LEXOK,LEXI,LEXA,LEXS
39 S LEXL=$E(LEXX,2),LEXG=$$GRP(LEXL),LEXOK=0
40 F LEXI=1:1:$L(LEXG) D Q:LEXOK
41 . S LEXS=$E(LEXX,1)_$E(LEXG,LEXI)_$E(LEXX,3,$L(LEXX))
42 . I $D(^LEX(757.01,"ASL",LEXS)) S LEXX=LEXS,LEXOK=1 Q
43 . S LEXS=$$TP^LEXAS6(LEXS)
44 . I $D(^LEX(757.01,"ASL",LEXS)),$L(LEXS)=$L(LEXX) S LEXX=LEXS,LEXOK=1 Q
45 . S LEXS=$$ONE^LEXAS2(LEXS) Q:LEXS=""
46 . I $D(^LEX(757.01,"ASL",LEXS)),$L(LEXS)=$L(LEXX) S LEXX=LEXS,LEXOK=1 Q
47 Q:LEXOK LEXX
48 ; Second letter (Add)
49 S LEXOK=0 F LEXI=65:1:90 D Q:LEXOK
50 . S LEXA=$E(LEXX,1)_$C(LEXI)_$E(LEXX,2,$L(LEXX))
51 . I $D(^LEX(757.01,"ASL",LEXA)) S LEXX=LEXA,LEXOK=1 Q
52 Q LEXX
53 ;
54FIRST(LEXX) ; First letter (Swap)
55 N LEXL,LEXG,LEXOK,LEXI,LEXA,LEXS
56 S LEXL=$E(LEXX,1),LEXG=$$GRP(LEXL),LEXOK=0
57 F LEXI=1:1:$L(LEXG) D Q:LEXOK
58 . S LEXS=$E(LEXG,LEXI)_$E(LEXX,2,$L(LEXX))
59 . I $D(^LEX(757.01,"ASL",LEXS)) S LEXX=LEXS,LEXOK=1 Q
60 . S LEXS=$$LF(LEXS)
61 . I $D(^LEX(757.01,"ASL",LEXS)) S LEXX=LEXS,LEXOK=1 Q
62 Q:LEXOK LEXX
63 ;
64 ; First letter (Add)
65 S LEXOK=0 F LEXI=65:1:90 D Q:LEXOK
66 . S LEXA=$C(LEXI)_LEXX
67 . I $D(^LEX(757.01,"ASL",LEXA)) S LEXX=LEXA,LEXOK=1 Q
68 Q LEXX
69LF(LEXX) ;
70 Q:$L($G(LEXX))'>7 LEXX
71 N LEXN,LEXC,LEXT,LEXF,LEXO,LEXOK
72 S (LEXN,LEXC)=$E(LEXX,1,4) Q:'$D(^LEX(757.01,"ASL",LEXN)) LEXX
73 S LEXT=$P(LEXX,LEXN,2) Q:$L(LEXT)<4 LEXX
74 S LEXOK=0,LEXO=$$SCH^LEXAS6(LEXN)
75 S LEXT=$E(LEXT,($L(LEXT)-6),$L(LEXT))
76 F S LEXO=$O(^LEX(757.01,"AWRD",LEXO)) Q:LEXO=""!(LEXO'[LEXC)!(LEXOK) D
77 . S LEXF=$E(LEXO,($L(LEXO)-($L(LEXT)-1)),$L(LEXO))
78 . I LEXF=LEXT S LEXT=LEXO,LEXOK=1
79 I LEXOK S LEXX=LEXT
80 Q LEXX
81TC(LEXX) ; Trailing character
82 Q:$L(LEXX)<6 LEXX
83 N LEXC,LEXT,LEXLC,LEXO,LEXOK,LEXCL
84 S LEXCL=$L(LEXX),LEXC=$$TRIM^LEXAS6(LEXX),LEXC=$E(LEXC,1,($L(LEXC)-1))
85 S LEXLC=$E(LEXX,$L(LEXX)),LEXO=$$SCH^LEXAS6(LEXC),LEXOK=0,LEXT=""
86 ;
87 F S LEXO=$O(^LEX(757.01,"AWRD",LEXO)) Q:LEXO=""!(LEXO'[LEXC)!(LEXOK) D
88 . Q:$E(LEXO,$L(LEXO))'=LEXLC
89 . ; Exact
90 . I $E(LEXO,LEXCL)=LEXLC S LEXT=LEXO,LEXOK=1 Q
91 . ; 1 Less
92 . I $E(LEXO,(LEXCL-1))=LEXLC S LEXT=LEXO,LEXOK=1 Q
93 I LEXT'="",LEXOK S LEXX=LEXT
94 Q LEXX
95 ;
96GRP(LEXX) ; Letter groups (off the home row QWERTY)
97 N LEXG S LEXG=LEXX
98 S:LEXX="A" LEXG="QZOWSX" S:LEXX="B" LEXG="VGHNF"
99 S:LEXX="C" LEXG="XDVFS" S:LEXX="D" LEXG="ECXRFSWV"
100 S:LEXX="E" LEXG="RWIDFS" S:LEXX="F" LEXG="GBVDRCET"
101 S:LEXX="G" LEXG="FBTVRHYN" S:LEXX="H" LEXG="JGNYBUMT"
102 S:LEXX="I" LEXG="UOYEKJL" S:LEXX="J" LEXG="HNKUMYI"
103 S:LEXX="K" LEXG="IJLMOU" S:LEXX="L" LEXG="OKPI"
104 S:LEXX="M" LEXG="NJKH" S:LEXX="N" LEXG="MBJH"
105 S:LEXX="O" LEXG="LIPAK" S:LEXX="P" LEXG="OL"
106 S:LEXX="Q" LEXG="AWS" S:LEXX="R" LEXG="TEGFD"
107 S:LEXX="S" LEXG="XWADZE" S:LEXX="T" LEXG="RGFYH"
108 S:LEXX="U" LEXG="YHIJK" S:LEXX="V" LEXG="CBFDG"
109 S:LEXX="W" LEXG="QESAD" S:LEXX="X" LEXG="ZSACD"
110 S:LEXX="Y" LEXG="UHIJGT" S:LEXX="Z" LEXG="ASX"
111 S:LEXG'=LEXX LEXX=LEXG
112 Q LEXX
113 Q
Note: See TracBrowser for help on using the repository browser.