source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXALK.m@ 1800

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

initial load of WorldVistAEHR
File size: 4.9 KB
RevLine 
[613]1LEXALK ; ISL/KER Look-up by Words ; 05/14/2003
2 ;;2.0;LEXICON UTILITY;**2,3,6,25**;Sep 23, 1996;Build 1
3 ;
4 ; External References
5 ; DBIA 10103 $$DT^XLFDT
6 ; DBIA 1571 ^LEX(
7 ;
8 ; Special Lookup variables
9 ;
10 ; LEXSUB Vocabulary
11 ; LEXSHCT Shortcuts
12 ; LEXDICS Screen - DIC("S") Format
13 ; LEXSHOW Displayable codes
14 ; LEXLKFL File Number
15 ; LEXLKGL Global Root
16 ; LEXLKMD Use Modifiers
17 ; LEXLKIX Index to use during lookup
18 ; LEXLKSH User Input (Search String)
19 ; LEXTKN( Tolkens in order of frequency of use
20 ; LEXTKNS( Tolkens in order of entry
21 ;
22EN ; Look-up user input
23 N LEXSUB,LEXSHCT,LEXDICS,LEXSHOW,LEXLKFL,LEXLKGL,LEXLKMD
24 N LEXLKIX,LEXLKSH,LEXVDT S LEXVDT=$$DT^XLFDT
25 S LEXLKSH=$G(^TMP("LEXSCH",$J,"SCH",0)) I $L(LEXLKSH)<2 D Q
26 . S LEX("ERR",0)=+($G(LEX("ERR",0)))+1,LEX("ERR",LEX("ERR",0))="User input missing or invalid"
27 S LEXSUB=$G(^TMP("LEXSCH",$J,"VOC",0)) S:LEXSUB="" LEXSUB="WRD"
28 S LEXLKMD=+($G(^TMP("LEXSCH",$J,"MOD",0)))
29 S LEXLKIX=$G(^TMP("LEXSCH",$J,"IDX",0)) S:LEXLKIX="" LEXLKIX="AWRD"
30 S LEXLKFL=$G(^TMP("LEXSCH",$J,"FLN",0)) I LEXLKFL'["757." D Q
31 . S LEX("ERR",0)=+($G(LEX("ERR",0)))+1,LEX("ERR",LEX("ERR",0))="File number missing or invalid"
32 S LEXLKGL=$G(^TMP("LEXSCH",$J,"GBL",0)) I LEXLKGL'["LEX(757." D Q
33 . S LEX("ERR",0)=+($G(LEX("ERR",0)))+1,LEX("ERR",LEX("ERR",0))="Global location missing or invalid"
34 S LEXSHOW=$G(^TMP("LEXSCH",$J,"DIS",0))
35 D TOLKEN^LEXAM(LEXLKSH)
36 N LEXOK,LEXDES,LEXDSP,LEXT,LEXO,LEXI,LEXE,LEXM,LEXME
37 N LEXSS Q:$G(LEXLKFL)'["757."
38 S LEXSS="" I $D(LEXTKNS(0)) D
39 . N LEXI F LEXI=1:1:LEXTKNS(0) S LEXSS=LEXSS_" "_LEXTKNS(LEXI)
40 . S LEXSS=$E(LEXSS,2,$L(LEXSS))
41 S ^TMP("LEXSCH",$J,"SCH",0)=$G(LEXSS)
42 S LEXT=$G(LEXTKN(1)),LEXO=$$SCH(LEXT)
43 I $G(LEXSHCT)="",$G(LEXTKN(0))=1,$D(^LEX(LEXLKFL,LEXLKIX,LEXT)) D G END
44 . D EXACT
45 . I +($O(^LEX(757.01,"ASL",LEXT,0)))>500 Q
46 . D TOLKEN
47 D TOLKEN
48END ; End look-up by word
49 I $D(^TMP("LEXFND",$J)) D BEG^LEXAL
50 I '$D(^TMP("LEXFND",$J)) D
51 . K LEX,^TMP("LEXFND",$J),^TMP("LEXHIT",$J) S LEX=0
52 S:+($G(^TMP("LEXSCH",$J,"UNR",0)))>0&($L($G(^TMP("LEXSCH",$J,"NAR",0)))) LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0))
53 Q
54EXACT ; Main loop throuth TOLKENS that equal LEXT
55 F S LEXO=$O(^LEX(LEXLKFL,LEXLKIX,LEXO)) Q:LEXO'=LEXT D IEN
56 Q
57TOLKEN ; Main loop though TOLKENS containing LEXT
58 F S LEXO=$O(^LEX(LEXLKFL,LEXLKIX,LEXO)) Q:LEXO'[LEXT!(LEXO="") D IEN
59 Q
60IEN ; Loop throuth Internal Entry Numbers
61 S LEXI=0
62 F S LEXI=$O(^LEX(LEXLKFL,LEXLKIX,LEXO,LEXI)) Q:+LEXI=0 D CHK
63 Q
64CHK ; Check each tolken
65 N LEXOK,LEXO S LEXE=LEXI,LEXOK=1
66 S:LEXLKGL'["757.01" LEXE=+($G(^LEX(LEXLKFL,LEXI,0))) Q:LEXE=0
67 ; Filter
68 S LEXFILR=$$EN^LEXAFIL($G(LEXFIL),LEXE) Q:LEXFILR=0
69 ; Deactivated
70 Q:+($P($G(^LEX(757.01,LEXE,1)),"^",5))=1
71 ; Expression has Modifiers
72 N LEXEMOD S LEXEMOD=+($P($G(^LEX(757.01,LEXE,1)),"^",6))
73 S LEXM=+($G(^LEX(757.01,LEXE,1)))
74 S LEXME=+($G(^LEX(757,LEXM,0)))
75 ; Check not exact match
76 I $L($G(^TMP("LEXSCH",$J,"EXM",0))),+(^TMP("LEXSCH",$J,"EXM",0))=LEXE Q
77 I $L($G(^TMP("LEXSCH",$J,"EXC",0))),+(^TMP("LEXSCH",$J,"EXC",0))=LEXE Q
78 ; Check tolkens
79 S LEXOK=1 D CHKTKNS(LEXE)
80 ; If the expression failed the search, and the expression has
81 ; modifiers then check the modifiers
82 D:+LEXOK=0&(+($G(LEXEMOD))>0)&(+($G(LEXTKN(0)))>1) CHKMOD^LEXAMD2
83 Q:'LEXOK
84 ; Description (*)
85 S LEXDES=$$DES^LEXASC(LEXE)
86 ; Display of codes
87 S LEXDSP=$$SO^LEXASO(LEXE,$G(LEXSHOW),1,$G(LEXVDT))
88 D ADDL^LEXAL(LEXE,LEXDES,LEXDSP)
89 Q
90CHKTKNS(LEXE) ; Check tolkens
91 N LEXM S LEXM=+($G(^LEX(757.01,LEXE,1))) Q:LEXM=0
92 N LEXI,LEXOE,LEXC S LEXOE=LEXE,LEXI=1
93 F S LEXI=$O(LEXTKN(LEXI)) Q:+LEXI=0!('LEXOK) D Q:'LEXOK
94 . N LEXT,LEXE S LEXT=LEXTKN(LEXI),LEXE=0,LEXOK=0
95 . S LEXC=$$UP(^LEX(757.01,LEXOE,0))
96 . I LEXC[(" "_LEXT) S LEXOK=1 Q
97 . I LEXC[("-"_LEXT) S LEXOK=1 Q
98 . I LEXC[("("_LEXT) S LEXOK=1 Q
99 . I LEXC[("/"_LEXT) S LEXOK=1 Q
100 . I $E(LEXC,1,$L(LEXT))=LEXT S LEXOK=1 Q
101 . I $L(LEXT),$D(^LEX(757.01,LEXOE,5,"B",LEXT)) S LEXOK=1 Q
102 . I $L(LEXT),$E($O(^LEX(757.01,LEXOE,5,"B",($E(LEXT,1,($L(LEXT)-1))_$C($A($E(LEXT,$L(LEXT)))-1)_"~"))),1,$L(LEXT))=LEXT S LEXOK=1 Q
103 . F S LEXE=$O(^LEX(757.01,"AMC",LEXM,LEXE)) Q:+LEXE=0!(LEXOK) D Q:LEXOK
104 . . Q:+($P($G(^LEX(757.01,LEXE,1)),"^",2))>3
105 . . S LEXC=$$UP(^LEX(757.01,LEXE,0))
106 . . I LEXC[(" "_LEXT) S LEXOK=1 Q
107 . . I LEXC[("-"_LEXT) S LEXOK=1 Q
108 . . I LEXC[("("_LEXT) S LEXOK=1 Q
109 . . I LEXC[("/"_LEXT) S LEXOK=1 Q
110 . . I $E(LEXC,1,$L(LEXT))=LEXT S LEXOK=1 Q
111 Q
112DES(LEXX) ; Get description flag
113 N LEXDES,LEXE,LEXM S LEXDES="",LEXE=+LEXX
114 S LEXM=$P($G(^LEX(757.01,+($G(LEXX)),1)),"^",1)
115 S LEXM=+($G(^LEX(757,+($G(LEXM)),0)))
116 S:$D(^LEX(757.01,LEXM,3)) LEXDES="*"
117 S LEXX=$G(LEXDES) Q LEXX
118SCH(LEXX) ; Search for LEXX a $Orderable variable
119 S LEXX=$E(LEXX,1,($L(LEXX)-1))_$C($A($E(LEXX,$L(LEXX)))-1)_"~" Q LEXX
120 Q
121UP(X) ; Uppercase
122 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Note: See TracBrowser for help on using the repository browser.