source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXA.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: 6.4 KB
Line 
1LEXA ; ISA/FJF/KER-Look-up (Silent) ; 09/06/2006
2 ;;2.0;LEXICON UTILITY;**3,4,6,19,25,36,38,43**;Sep 23, 1996;Build 1
3 ;
4 ; External References
5 ; DBIA 10104 $$UP^XLFSTR
6 ; DBIA 10103 $$DT^XLFDT
7 ; DBIA 10060 ^VA(200,
8 ; DBIA 10016 ^DIM
9 ;
10 ; Look-up D LOOK^LEXA(LEXX,LEXAP,LEXLL,LEXSUB,lexvdt)
11 ;
12 ; LEXX User Input
13 ; LEXAP Application
14 ; LEXLL Selection List Length
15 ; LEXSUB Mode/Subset (file 757.2)
16 ; LEXVDT Date to use for retrieving/displaying codes
17 ;
18 ; 1. Search parameters ^TMP("LEXSCH",$J,PAR)=VALUE
19 ; 2. Expressions found ^TMP("LEXFND",$J,FQ,IEN)=DT
20 ; 3. Review List ^TMP("LEXHITS",$J,#)=IEN^DT
21 ; 4. Display List LEX("LIST",#)
22 ;
23 ; LEX("LIST",0)=LAST^TOTAL
24 ; LEX("LIST",#)=IEN^DT
25 ;
26LOOK(LEXX,LEXAP,LEXLL,LEXSUB,LEXVDT) ; Search for LEXX
27 I $G(LEXVDT)="" S LEXVDT=$$DT^XLFDT
28 I $L($G(^TMP("LEXSCH",$J,"VDT",0))) S LEXVDT=^TMP("LEXSCH",$J,"VDT",0)
29 K DIERR,LEX
30 K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J)
31 K ^TMP("LEXSCH",$J,"EXC"),^TMP("LEXSCH",$J,"EXM")
32 K:+$G(^TMP("LEXSCH",$J,"ADF",0))=0 ^TMP("LEXSCH",$J)
33 I $D(DIC(0)) D
34 .S:DIC(0)["L" DIC(0)=$P(DIC(0),"L",1)_$P(DIC(0),"L",2)
35 .S:DIC(0)["I" DIC(0)=$P(DIC(0),"I",1)_$P(DIC(0),"I",2)
36 S LEXQ=1,LEXX=$G(LEXX)
37 I LEXX=""!(LEXX["^") D EN^LEXAR("^",$G(LEXVDT)) K LEXAP D EXIT Q
38 S LEXAP=$$UP^XLFSTR($G(LEXAP))
39 S LEXLL=+$G(LEXLL)
40 S LEXSUB=$G(LEXSUB)
41 S ^TMP("LEXSCH",$J,"APP",0)=+$$AP^LEXDFN2($G(LEXAP))
42 S:^TMP("LEXSCH",$J,"APP",0)=0 ^TMP("LEXSCH",$J,"APP",0)=1
43 S:LEXSUB="" LEXSUB=^TMP("LEXSCH",$J,"APP",0)
44 S:$L($G(DIC("S"))) ^TMP("LEXSCH",$J,"FIL",0)=DIC("S")
45 S:LEXLL=0 LEXLL=5
46 S ^TMP("LEXSCH",$J,"LEN",0)=LEXLL
47X ; Search for X
48 I '$L($G(LEXX)) D D EXIT Q
49 .S LEX("ERR",0)=$G(LEX("ERR",0))+1
50 .S LEX("ERR",LEX("ERR",0))="User input LEXX missing or invalid"
51APP ; Application
52 I +$G(^TMP("LEXSCH",$J,"APP",0))=0!('$D(^LEXT(757.2,+$G(^TMP("LEXSCH",$J,"APP",0)),0))) D D EXIT Q
53 .S LEX("ERR",0)=$G(LEX("ERR",0))+1
54 .S LEX("ERR",LEX("ERR",0))="Calling application identification LEXAP missing or invalid"
55USR ; User
56 I +$G(DUZ)=0!('$D(^VA(200,+$G(DUZ),0))) D D EXIT Q
57 .S LEX("ERR",0)=$G(LEX("ERR",0))+1
58 .S LEX("ERR",LEX("ERR",0))="User identification DUZ missing or invalid"
59 N LEXFND,LEXISCD
60 S (LEXFND,LEXISCD)=0
61 S ^TMP("LEXSCH",$J,"USR",0)=+$G(DUZ)
62 S ^TMP("LEXSCH",$J,"NAR",0)=LEXX
63 S ^TMP("LEXSCH",$J,"SCH",0)=$$UP^XLFSTR(LEXX)
64DEF ; Defaults CONFIG^LEXSET
65 N LEXFIL,LEXDSP,LEXFILR S:$L($G(DIC("S"))) LEXFIL=DIC("S")
66 I '$L($G(LEXFIL)),$L($G(^TMP("LEXSCH",$J,"FIL",0))) S LEXFIL=^TMP("LEXSCH",$J,"FIL",0)
67 N LEXNS,LEXSS
68 S LEXNS=$$NS^LEXDFN2(LEXAP)
69 S LEXSS=$$MD^LEXDFN2(LEXSUB)
70 I +$G(^TMP("LEXSCH",$J,"ADF",0))=0 D CONFIG^LEXSET(LEXNS,LEXSS,$G(LEXVDT))
71 I '$L($G(LEXFIL)),$L($G(^TMP("LEXSCH",$J,"FIL",0))) S LEXFIL=^TMP("LEXSCH",$J,"FIL",0)
72 S:$L($G(LEXFIL)) LEXFIL=$$FIL(LEXFIL)
73 S LEXFIL=$G(LEXFIL)
74 K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J)
75 D MAN
76 I $D(LEX("ERR")) D EXIT Q
77 D SETUP^LEXAM($G(^TMP("LEXSCH",$J,"VOC",0)))
78 I $D(LEX("ERR")) D EXIT Q
79LK ; Look-up
80IEN ; Look-up by IEN ADDL^LEXAL PCH 4
81 I ^TMP("LEXSCH",$J,"NAR",0)?1"`"1N.N D I $D(LEX("LIST")) D EXIT Q
82 .N LEXE,LEXUN
83 .S LEXE=+$E(^TMP("LEXSCH",$J,"NAR",0),2,$L(^TMP("LEXSCH",$J,"NAR",0))) Q:LEXE=0
84 .S LEXUN=+$G(^TMP("LEXSCH",$J,"UNR",0))
85 .Q:'$D(^LEX(757.01,LEXE,0))
86 .D ADDL^LEXAL(LEXE,$$DES^LEXASC(LEXE),$$SO^LEXASO(LEXE,$G(^TMP("LEXSCH",$J,"DIS",0)),1,$G(LEXVDT)))
87 .I $D(^TMP("LEXFND",$J)) D BEG^LEXAL
88 .I LEXUN>0,$L($G(^TMP("LEXSCH",$J,"NAR",0))) S LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0))
89 .I LEXUN>0,$L($G(^LEX(757.01,+$G(LEXE),0))) S LEX("NAR")=$G(^LEX(757.01,+$G(LEXE),0))
90SCT ; Look-up by Shortcuts EN^LEXASC
91 I +$G(^TMP("LEXSCH",$J,"SCT",0)),$D(^LEX(757.41,^TMP("LEXSCH",$J,"SCT",0))) D
92 .S LEXFND=$$EN^LEXASC(^TMP("LEXSCH",$J,"SCH",0),^TMP("LEXSCH",$J,"SCT",0),$G(LEXVDT))
93 I +LEXFND D EXIT Q
94CODE ; Look-up by Code EN^LEXABC
95 S LEXFND=$$EN^LEXABC(^TMP("LEXSCH",$J,"SCH",0),$G(LEXVDT))
96 I +LEXFND D EXIT Q
97 I +LEXFND'>0,+($G(LEXISCD))>0 D EXIT Q
98 ; if code is found but it is inactive
99 ;I +$P(LEXFND,"^",2)'=-1 S LEX=0 D EXIT Q
100EXACT ; Look-up Exact Match EN^LEXAB
101 S LEXFND=$$EN^LEXAB(^TMP("LEXSCH",$J,"SCH",0),$G(LEXVDT))
102 K:+LEXFND=0 ^TMP("LEXFND",$J)
103 K ^TMP("LEXHIT",$J)
104KEYWRD ; Look-up by word EN^LEXALK
105 D EN^LEXALK
106EXIT ; Clean-up and quit
107 K LEXQ,LEXDICS,LEXFIL,LEXFILR,LEXDSP,LEXSHOW,LEXSHCT,LEXSUB
108 K LEXOVR,LEXUN,LEXLKFL,LEXLKGL,LEXLKIX,LEXLKSH,LEXTKNS,LEXTKN
109 K LEXI
110 D:$D(LEX("ERR")) CLN
111 I $D(LEX),+$G(LEX)=0,'$D(LEX("LIST")),$L($G(LEXX)) D
112 .N LEXC,LEXF,LEXV
113 .S LEXC=1
114 .S LEXF=$G(^TMP("LEXSCH",$J,"FIL",0))
115 .S LEXV=$G(^TMP("LEXSCH",$J,"VOC",0))
116 .D:+$G(^TMP("LEXSCH",$J,"UNR",0))>0 EN^LEXAR(LEXX,$G(LEXVDT))
117 .S LEX("NAR")=LEXX
118 .S LEX=0
119 .S LEX("HLP",LEXC)=" A suitable term could not be found based on user input"
120 .S:LEXF="I 1" LEXF=""
121 .I $L(LEXF)!(LEXV'="WRD") D
122 ..S LEX("HLP",LEXC)=$G(LEX("HLP",LEXC))_" and "
123 ..S LEXC=LEXC+1
124 ..S LEX("HLP",LEXC)=" current user defaults"
125 ..S LEX("HLP",0)=LEXC
126 .S LEX("HLP",LEXC)=$G(LEX("HLP",LEXC))_"."
127 Q
128CLN ; Clean
129 K LEXQ,LEXTKNS,LEXTKN,LEXI
130 K ^TMP("LEXSCH",$J),^TMP("LEXHIT",$J),^TMP("LEXFND",$J)
131 Q
132CLR ; Clear all (FOR TESTING ONLY)
133 K LEX,LEXQ,LEXTKNS,LEXTKN,LEXI
134 K ^TMP("LEXSCH"),^TMP("LEXHIT"),^TMP("LEXFND")
135 Q
136MAN ; Mandatory variables
137 N LEXERR
138 F LEXERR="SCH","VOC","APP","USR" D
139 .I '$L($G(^TMP("LEXSCH",$J,LEXERR,0))) D
140 ..S LEX("ERR",0)=$G(LEX("ERR",0))+1
141 ..S LEX("ERR",LEX("ERR",0))="Mandatory variable ^TMP(""LEXSCH"",$J,"""_LEXERR_""",0) missing or invalid"
142 Q
143FIL(X) ; Validate Filter
144 S X=$G(X) N DIC
145 Q:'$L(X) X
146 D ^DIM
147 S:'$D(X) X=""
148 Q X
149 ;
150 ; D INFO^LEXA(IEN,DATE)
151 ;
152 ; IEN Internal Entry Number in file 757.01
153 ; DATE Optional - retrieves codes active on a specified date
154 ;
155 ; Returns array LEX("SEL") or null
156 ;
157 ; LEX("SEL","EXP") Expressions Concepts/Synonyms/Variants
158 ; LEX("SEL","SIG") Expression definition
159 ; LEX("SEL","SRC") Classification Codes
160 ; LEX("SEL"."STY") Semantic Class/Semantic Types
161 ; LEX("SEL","VAS") VA Classification Sources
162 ;
163INFO(X,LEXVDT) ; Get Information about a Term
164 K LEX("SEL") S X=+$G(X) Q:X=0 Q:'$D(^LEX(757.01,X,0))
165 N LEXD S LEXD=$G(LEXVDT) S:+LEXD'>0 LEXD=$$DT^XLFDT
166 N LEXVDT S LEXVDT=LEXD D SET^LEXAR4(X,LEXVDT)
167 Q
Note: See TracBrowser for help on using the repository browser.