source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAMD.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.7 KB
Line 
1LEXAMD ; ISL/KER Look-up Modifiers ; 05/14/2003
2 ;;2.0;LEXICON UTILITY;**6,25**;Sep 23, 1996;Build 1
3 ;
4 ; LEXX IEN file 757.01 of an expression w/Modifiers
5 ; LEXVDT Date to screen against
6 ;
7EN(LEXX,LEXVDT) ; Look-up Modifiers
8 S LEXX=+($G(LEXX)) Q:+($G(^TMP("LEXSCH",$J,"MOD",0)))=0
9 Q:+($G(LEXX))'>2 Q:'$D(^LEX(757.01,+($G(LEXX)),0))
10 Q:+($P($G(^LEX(757.01,+LEXX,1)),"^",6))=0
11 Q:'$D(^LEX(757.01,"APAR",LEXX)) N LEXXN D ARY
12 Q
13ARY ; Build Array of Modified Terms
14 N LEXLVL,LEXO,LEXI,LEXN,LEXA,LEXT,LEXDSP,LEXDES,LEXL
15 S LEXI=0,LEXXN=$G(^LEX(757.01,LEXX,0)),LEXA(0)=1
16 S LEXA(1,LEXX)=LEXXN,LEXLVL=+($G(LEX("LVL"))) S:LEXLVL=0 LEXLVL=1
17 F S LEXI=$O(^LEX(757.01,"APAR",LEXX,LEXI)) Q:+LEXI=0 D
18 . S LEXN=$G(^LEX(757.01,LEXI,1)) Q:LEXN="" S LEXT=+($P(LEXN,"^",2)) Q:LEXT'=7
19 . S LEXO=+($P(LEXN,"^",10)) S:LEXO'=0 LEXO=LEXO+1 S:LEXO=0 LEXO=99999 I $D(LEXA(LEXO)) F Q:'$D(LEXA(LEXO)) S LEXO=LEXO+1
20 . S LEXA(LEXO,LEXI)=$G(^LEX(757.01,LEXI,0)),LEXA(0)=+($G(LEXA(0)))+1
21 ; Quit if no Modified Terms Found
22 Q:+($G(LEXA(0)))'>1 S (LEXO,LEXI)=0 D FND
23 Q
24FND ; Build List of Modifiers Found (LEXFND)
25 K ^TMP("LEXSCH",$J,"EXM"),^TMP("LEXSCH",$J,"NAR"),^TMP("LEXSCH",$J,"SCH"),^TMP("LEXSCH",$J,"TOL"),^TMP("LEXSCH",$J,"NUM"),^TMP("LEXFND",$J)
26 F S LEXO=$O(LEXA(LEXO)) Q:+LEXO=0 D
27 . S LEXI=0 F S LEXI=$O(LEXA(LEXO,LEXI)) Q:+LEXI=0 D
28 . . I LEXO=1 S LEXDES=$$DES(LEXI),LEXDSP=$$SO^LEXASO(LEXI,$G(LEXSHOW),1,$G(LEXVDT))
29 . . I LEXO>1 S (LEXDES,LEXDSP)=""
30 . . S LEXT=$G(LEXA(LEXO,LEXI)) Q:'$L(LEXT)
31 . . S:$L(LEXDES) LEXT=LEXT_" "_LEXDES
32 . . S:$L(LEXDSP) LEXT=LEXT_" "_LEXDSP
33 . . S LEXN=-999999999+($G(LEXO))
34 . . S ^TMP("LEXFND",$J,LEXN,LEXI)=LEXT
35 . . S ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
36HIT ; Build HIT list
37 I $D(^TMP("LEXFND",$J)) D Q
38 . K LEX,^TMP("LEXHIT",$J) S LEX=+($G(LEXA(0))),LEX("LVL")=+($G(LEXLVL))+1 S:+LEX>0 (^TMP("LEXSCH",$J,"MAT",0),LEX("MAT"))=+LEX_" matches found for """_LEXXN_"""" D SCH,BEG,NAR
39 I '$D(^TMP("LEXFND",$J)) D NOM
40 Q
41SCH ; Search Conditions/Results
42 K ^TMP("LEXSCH",$J,"EXM") S ^TMP("LEXSCH",$J,"NAR",0)=$$UP(LEXXN),^TMP("LEXSCH",$J,"SCH",0)=$$UP(LEXXN),^TMP("LEXSCH",$J,"TOL",0)=1,^TMP("LEXSCH",$J,"NUM",0)=+($G(^TMP("LEXSCH",$J,"NUM",0)))
43 Q
44NOM ; No Modifiers
45 K LEX,^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXSCH",$J,"EXM"),^TMP("LEXSCH",$J,"NAR"),^TMP("LEXSCH",$J,"SCH"),^TMP("LEXSCH",$J,"TOL")
46 S ^TMP("LEXSCH",$J,"NUM",0)=0 S:$L($G(LEXXN)) ^TMP("LEXSCH",$J,"NAR",0)=$$UP(LEXXN) S:$L($G(LEXXN)) ^TMP("LEXSCH",$J,"SCH",0)=$$UP(LEXXN)
47 Q
48NAR ; Narrative
49 S:+($G(^TMP("LEXSCH",$J,"UNR",0)))>0&($L($G(^TMP("LEXSCH",$J,"NAR",0)))) LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0))
50 Q
51DES(LEXX) ; Get description flag
52 N LEXDES,LEXE,LEXM S LEXDES="",LEXE=+LEXX
53 S LEXM=$P($G(^LEX(757.01,+($G(LEXX)),1)),"^",1),LEXM=+($G(^LEX(757,+($G(LEXM)),0))) S:$D(^LEX(757.01,LEXM,3)) LEXDES="*" S LEXX=$G(LEXDES) Q LEXX
54BEG ; Begin List
55 S:+($G(^TMP("LEXSCH",$J,"UNR",0)))>0&($L($G(^TMP("LEXSCH",$J,"NAR",0)))) LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0))
56 Q:'$D(^TMP("LEXFND",$J))
57 N LEXRL,LEXJ,LEXI,LEXA,LEXSTR,LEXDP,LEXLL
58 S LEXRL=0,LEXLL=+($G(^TMP("LEXSCH",$J,"LEN",0)))
59 S:+LEXLL=0 (LEXRL,LEXLL)=5 S LEXJ=0,LEXI=-9999999999
60 ; Hit List ^TMP("LEXHIT",$J,#)
61 F S LEXI=$O(^TMP("LEXFND",$J,LEXI)) Q:+LEXI=0 D
62 . S LEXA=0
63 . F S LEXA=$O(^TMP("LEXFND",$J,LEXI,LEXA)) Q:+LEXA=0!(LEXJ=LEXLL) D Q:+LEXA=0!(LEXJ=LEXLL)
64 . . S LEXJ=LEXJ+1,LEXDP=^TMP("LEXFND",$J,LEXI,LEXA)
65 . . S ^TMP("LEXHIT",$J,0)=LEXJ
66 . . S ^TMP("LEXHIT",$J,LEXJ)=LEXA_"^"_LEXDP
67 . . S:+($G(^TMP("LEXSCH",$J,"EXM",0)))=+LEXA ^TMP("LEXSCH",$J,"EXM",2)=LEXJ_"^"_$G(^LEX(757.01,+LEXA,0))
68 . . S:+($G(^TMP("LEXSCH",$J,"EXC",0)))=+LEXA ^TMP("LEXSCH",$J,"EXC",2)=LEXJ_"^"_$G(^LEX(757.01,+LEXA,0))
69 . . K ^TMP("LEXFND",$J,LEXI,LEXA)
70 ; List LEX("LIST")
71 I $D(^TMP("LEXSCH",$J,"NUM",0)) S LEX=+($G(^TMP("LEXSCH",$J,"NUM",0)))
72 I LEXLL>0 D
73 . N LEXI,LEXJ S (LEXJ,LEXI)=0
74 . F S LEXJ=$O(^TMP("LEXHIT",$J,LEXJ)) Q:+LEXJ=0!(+LEXI=LEXLL) D Q:+LEXI=LEXLL
75 . . S LEXI=LEXI+1,LEX("LIST",LEXI)=^TMP("LEXHIT",$J,LEXJ)
76 . . S LEX("LIST",0)=LEXI_"^"_LEXI
77 . . S (LEX("MAX"),^TMP("LEXSCH",$J,"LST",0))=LEXI
78 S ^TMP("LEXSCH",$J,"TOL",0)=0 S:$D(LEX("LIST",1)) ^TMP("LEXSCH",$J,"TOL",0)=1
79 S LEX=+($G(^TMP("LEXSCH",$J,"NUM",0)))
80 S:^TMP("LEXSCH",$J,"TOL",0)=1&(+($G(LEX))>0) LEX("MAT")=+LEX_" match"_$S(+LEX>1:"es",1:"")_" found"
81 S:+($G(LEX("MAX")))>0 LEX("MIN")=1
82 I $L($G(^TMP("LEXSCH",$J,"EXM",2))) S LEX("EXM")=^TMP("LEXSCH",$J,"EXM",2)
83 I $L($G(^TMP("LEXSCH",$J,"EXC",2))) S LEX("EXC")=^TMP("LEXSCH",$J,"EXC",2)
84 S:+($G(^TMP("LEXSCH",$J,"UNR",0)))>0&($L($G(^TMP("LEXSCH",$J,"NAR",0)))) LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0))
85 Q:'$D(^TMP("LEXFND",$J)) K:+($G(LEXRL))>0 LEXLL
86 Q
87UP(X) Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
88CLR K X,Y,LEXLL,LEXSHOW,LEX,^TMP("LEXSCH"),^TMP("LEXHIT"),^TMP("LEXFND") Q
Note: See TracBrowser for help on using the repository browser.