source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAL.m@ 1639

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

initial load of WorldVistAEHR
File size: 5.1 KB
Line 
1LEXAL ; ISL Look-up List (Global) ; 10-15-97
2 ;;2.0;LEXICON UTILITY;**6**;Sep 23, 1996;Build 1
3 ;
4 ; Add to the list
5ADDL(LEXA,LEXDS,LEXDP) ; Add
6 S LEXA=+($G(LEXA)) Q:LEXA=0 Q:'$D(^LEX(757.01,LEXA))
7 S LEXDS=$G(LEXDS),LEXDP=$G(LEXDP)
8 N LEXF,LEXT,LEXL,LEXC
9 S LEXT=$$DISP(LEXA,LEXDS,LEXDP)
10 S LEXF=$$LSTN(LEXA,"A")
11 S:'$D(^TMP("LEXFND",$J,-LEXF,LEXA)) ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
12 S ^TMP("LEXFND",$J,-LEXF,LEXA)=LEXT
13 S:+LEXF'=0 ^TMP("LEXFND",$J,0)=LEXF
14 S LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
15 Q
16ADDN(LEXA,LEXDS,LEXDP) ; Near match
17 S LEXA=+($G(LEXA)) Q:LEXA=0 Q:'$D(^LEX(757.01,LEXA))
18 N LEXR,LEXN S LEXR=LEXA Q:$D(^TMP("LEXFND",$J,-99999997,LEXA))
19 S LEXN=-99999997
20 F S LEXN=LEXN+1 Q:'$D(^TMP("LEXFND",$J,LEXN,0))
21 I $P($G(^LEX(757.01,LEXA,1)),"^",2)'=1 D Q:+LEXA=0
22 . S LEXA=+($G(^LEX(757.01,LEXA,1))),LEXA=+($G(^LEX(757,LEXA,0)))
23 S LEXDS=$G(LEXDS),LEXDP=$G(LEXDP)
24 N LEXT S LEXT=$$DISP(LEXA,LEXDS,LEXDP)
25 S:'$D(^TMP("LEXFND",$J,-LEXF,LEXA)) ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
26 S ^TMP("LEXFND",$J,LEXN,LEXA)=LEXT
27 S:LEXN<$G(^TMP("LEXFND",$J,0)) ^TMP("LEXFND",$J,0)=LEXN
28 S LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
29 Q
30ADDE(LEXA,LEXDS,LEXDP) ; Exact match
31 S LEXA=+($G(LEXA)) Q:LEXA=0 Q:'$D(^LEX(757.01,LEXA)) N LEXR,LEXT S LEXR=LEXA,LEXDS=$G(LEXDS),LEXDP=$G(LEXDP),LEXT=$$DISP(LEXA,LEXDS,LEXDP)
32 S:'$D(^TMP("LEXFND",$J,-99999999,LEXA)) ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
33 S ^TMP("LEXFND",$J,-99999999,LEXA)=LEXT,^TMP("LEXFND",$J,0)=-99999999
34 S LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
35 Q
36ADDEM(LEXA,LEXDS,LEXDP) ; Exact match Major Concept
37 S LEXA=+($G(LEXA)) Q:LEXA=0 Q:'$D(^LEX(757.01,LEXA)) N LEXR,LEXT S LEXR=LEXA Q:$P($G(^LEX(757.01,LEXA,1)),"^",2)'=1
38 S LEXDS=$G(LEXDS),LEXDP=$G(LEXDP),LEXT=$$DISP(LEXA,LEXDS,LEXDP)
39 S:'$D(^TMP("LEXFND",$J,-99999998,LEXA)) ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
40 S ^TMP("LEXFND",$J,-99999998,LEXA)=LEXT,^TMP("LEXFND",$J,0)=-99999998,LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
41 Q
42ADDC(LEXA,LEXDS,LEXDP) ; Code
43 S LEXA=+($G(LEXA)) Q:LEXA=0 Q:'$D(^LEX(757.01,LEXA))
44 S LEXDS=$G(LEXDS),LEXDP=$G(LEXDP)
45 N LEXT,LEXF,LEXC S LEXC=+($G(^LEX(757.01,LEXA,1))) Q:LEXC=0
46 S LEXF=$G(^TMP("LEXFND",$J,0)) S:+LEXF=0 LEXF=-999999
47 S LEXF=LEXF+1 S LEXT=$$DISP(LEXA,LEXDS,LEXDP)
48 S:'$D(^TMP("LEXFND",$J,-LEXF,LEXA)) ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
49 S ^TMP("LEXFND",$J,LEXF,LEXA)=LEXT
50 S ^TMP("LEXFND",$J,0)=LEXF
51 S LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
52 Q
53DISP(LEXX,LEXDS,LEXDP) ; Display Text
54 S LEXX=$G(^LEX(757.01,LEXX,0))
55 S:$L(LEXDS) LEXX=LEXX_" "_LEXDS
56 S:$L(LEXDP) LEXX=LEXX_" "_LEXDP
57 Q LEXX
58BEG ; Begin List
59 S:+($G(^TMP("LEXSCH",$J,"UNR",0)))>0&($L($G(^TMP("LEXSCH",$J,"NAR",0)))) LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0))
60 Q:'$D(^TMP("LEXFND",$J))
61 N LEXRL,LEXJ,LEXI,LEXA,LEXSTR,LEXDP
62 S LEXRL=0,LEXLL=+($G(^TMP("LEXSCH",$J,"LEN",0)))
63 S:+LEXLL=0 (LEXRL,LEXLL)=5 S LEXJ=0,LEXI=-9999999999
64 ; Hit List ^TMP("LEXHIT",$J,#)
65 F S LEXI=$O(^TMP("LEXFND",$J,LEXI)) Q:+LEXI=0 D
66 . S LEXA=0
67 . F S LEXA=$O(^TMP("LEXFND",$J,LEXI,LEXA)) Q:+LEXA=0!(LEXJ=LEXLL) D Q:+LEXA=0!(LEXJ=LEXLL)
68 . . S LEXJ=LEXJ+1,LEXDP=^TMP("LEXFND",$J,LEXI,LEXA)
69 . . S ^TMP("LEXHIT",$J,0)=LEXJ
70 . . S ^TMP("LEXHIT",$J,LEXJ)=LEXA_"^"_LEXDP
71 . . S:+($G(^TMP("LEXSCH",$J,"EXM",0)))=+LEXA ^TMP("LEXSCH",$J,"EXM",2)=LEXJ_"^"_$G(^LEX(757.01,+LEXA,0))
72 . . S:+($G(^TMP("LEXSCH",$J,"EXC",0)))=+LEXA ^TMP("LEXSCH",$J,"EXC",2)=LEXJ_"^"_$G(^LEX(757.01,+LEXA,0))
73 . . K ^TMP("LEXFND",$J,LEXI,LEXA)
74 ; List LEX("LIST")
75 I $D(^TMP("LEXSCH",$J,"NUM",0)) S LEX=+($G(^TMP("LEXSCH",$J,"NUM",0)))
76 I LEXLL>0 D
77 . N LEXI,LEXJ S (LEXJ,LEXI)=0
78 . F S LEXJ=$O(^TMP("LEXHIT",$J,LEXJ)) Q:+LEXJ=0!(+LEXI=LEXLL) D Q:+LEXI=LEXLL
79 . . S LEXI=LEXI+1,LEX("LIST",LEXI)=^TMP("LEXHIT",$J,LEXJ)
80 . . S LEX("LIST",0)=LEXI_"^"_LEXI
81 . . S (LEX("MAX"),^TMP("LEXSCH",$J,"LST",0))=LEXI
82 S ^TMP("LEXSCH",$J,"TOL",0)=0 S:$D(LEX("LIST",1)) ^TMP("LEXSCH",$J,"TOL",0)=1
83 S LEX=+($G(^TMP("LEXSCH",$J,"NUM",0)))
84 S:^TMP("LEXSCH",$J,"TOL",0)=1&(+($G(LEX))>0) LEX("MAT")=+LEX_" match"_$S(+LEX>1:"es",1:"")_" found"
85 ; Establish level of concept (1 = concept, >1= modifier) PCH 6
86 S LEX("LVL")=+($G(LEX("LVL"))) S:LEX("LVL")=0 LEX("LVL")=1
87 S:+($G(LEX("MAX")))>0 LEX("MIN")=1
88 I $L($G(^TMP("LEXSCH",$J,"EXM",2))) S LEX("EXM")=^TMP("LEXSCH",$J,"EXM",2)
89 I $L($G(^TMP("LEXSCH",$J,"EXC",2))) S LEX("EXC")=^TMP("LEXSCH",$J,"EXC",2)
90 S:+($G(^TMP("LEXSCH",$J,"UNR",0)))>0&($L($G(^TMP("LEXSCH",$J,"NAR",0)))) LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0))
91 Q:'$D(^TMP("LEXFND",$J)) K:+($G(LEXRL))>0 LEXLL
92 Q
93LSTN(LEXA,LEXM) ; List Number
94 N LEXC,LEXL,LEXF,LEXK S LEXK=0
95 S LEXC=+($G(^LEX(757.01,LEXA,1))) Q:LEXC=0 0
96 S LEXL=$L($G(^LEX(757.01,LEXA,0))) Q:LEXL=0 0
97 S LEXL=245-LEXL S:$L(LEXL)=1 LEXL="00"_LEXL
98 S:$L(LEXL)=2 LEXL="0"_LEXL S LEXL=$E(LEXL,1,3)
99 S LEXF=$O(^LEX(757.001,"B",LEXC,0))
100 S:+LEXF>0&($L($G(^LEX(757.001,+LEXF,0)))) LEXF=(+($P($G(^LEX(757.001,LEXF,0)),"^",3))+1)
101 S:+LEXF=0 LEXF=1 I +($G(LEXTKN(0)))>0 D
102 . N LEXI S LEXI=0 F S LEXI=$O(LEXTKN(LEXI)) Q:+LEXI=0 D
103 . . I $$UP^XLFSTR($G(^LEX(757.01,LEXA,0)))[LEXTKN(LEXI) S:LEXK<8 LEXK=LEXK+1
104 S LEXK=$E(LEXK,1),LEXM=LEXF_"."_LEXK_LEXL
105 Q LEXM
Note: See TracBrowser for help on using the repository browser.