source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXA1.m@ 623

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

initial load of WorldVistAEHR

File size: 6.3 KB
Line 
1LEXA1 ; ISA/CJE-Lexicon Look-up (Loud) ; 02/02/2006
2 ;;2.0;LEXICON UTILITY;**3,4,6,11,15,38**;Sep 23, 1996;Build 1
3 ; CJE; Force quit when user enters '^' at search prompt.
4 ; JPK; Display code attached to a selected term
5 ;
6EN ; Initialize
7 D:$D(XRTL) T0^%ZOSV K LEX S LEXQ=0
8 I $D(LEXVDT) I $L($G(^TMP("LEXSCH",$J,"VDT",0))) S LEXVDT=^TMP("LEXSCH",$J,"VDT",0)
9 I '$D(LEXVDT) I $L($G(^TMP("LEXSCH",$J,"VDT",0))) N LEXVDT S LEXVDT=^TMP("LEXSCH",$J,"VDT",0)
10 ;-------------------------------------------------------------
11 ;
12 ;
13 ; LEXSUB Special variable from version 1.0 specifying the
14 ; vocabulary subset to use during the search. It is
15 ; a three character mnemonic taken from the Subset
16 ; Definition file #757.2. The default is "WRD"
17 ;
18 S:'$L($G(LEXSUB)) LEXSUB="WRD"
19 ;
20 ; LEXAP Special variable from version 1.0 specifying the
21 ; application using the Lexicon. It is a pointer
22 ; value to the Subset Definition file #757.2.
23 ; The default is 1 (Lexicon)
24 ;
25 S:'$L($G(LEXAP))&($L($G(^TMP("LEXSCH",$J,"APP",0)))) LEXAP=^TMP("LEXSCH",$J,"APP",0)
26 S:'$L($G(LEXAP)) LEXAP=1
27 ;
28 ; LEXLL Special variable (new) specifying the length of the
29 ; displayable list the user is to select from. Default
30 ; is 5 (display 5 at a time until the entire list has
31 ; been reviewed)
32 ;
33 S:'$L($G(LEXLL)) LEXLL=5
34 ;
35 ; Check the DIC variables new LEXUR "user response"
36 N LEXDICA,LEXDICB D CHK N LEXUR
37 ;
38 ; Save the value of X if "Ask" is not specified in DIC(0)
39 ;
40 I DIC(0)'["A",$L($G(X)) S LEXSAVE=X K X
41 ;
42 ; Save the prompt
43 ;
44 I $L($G(DIC("A"))) S LEXDICA=DIC("A")
45 ;
46 ; Continue to lookup until the dialog with the application
47 ; ends. If there is nothing to lookup (X="") or an uparrow
48 ; is detected, the Lexicon shuts down killing LEX.
49 ;
50 F D LK Q:'$D(LEX)!($D(LEX("SEL")))
51 ;
52 G EXIT
53 ;-------------------------------------------------------------
54LK ; Start Look-up
55 ; X not provided
56 D:'$D(LEXSAVE) ASK
57 ; X provided
58 S:$D(LEXSAVE) X=LEXSAVE K LEXSAVE
59 ; X was null with a default provided
60 S:$D(DIC("B"))&($G(X)="") X=DIC("B")
61 ; Lookup X
62 ;W:$L(X)&(X'["^")&($E(X,1)'=" ") !,"Searching for ",X ; PCH 4 - Do not display X
63 D LOOK^LEXA(X,LEXAP,LEXLL) K DIC("B")
64 ;
65 ;--------------------------------------------------------------------
66NOTFND ; PCH 3
67 ;
68 ; If X was not found
69 ;
70 ; Write "??"
71 ;
72 ; If the calling application uses Unresolved Narratives
73 ; Prompt to "accept or reject" the narrative
74 ; If no selection is made continue the search
75 ;
76 ; If the calling application does not use Unresolved Narratives
77 ; Display help
78 ; Re-prompt
79 ; Continue search
80 ;
81 I '$D(LEX("LIST")),+($G(LEX))=0,$L(X),X'["^",$E(X,1)'=" " D I '$D(LEX("SEL")) K LEX S LEX=0 Q
82 . K DIC("B"),LEX("SEL")
83 . I +($G(^TMP("LEXSCH",$J,"UNR",0)))=0 W " ??" D:$D(LEX("HLP")) DH^LEXA3 W ! Q
84 . I +($G(^TMP("LEXSCH",$J,"UNR",0)))=1 W " ??" D EN^LEXA4 W !
85 ;
86 ;--------------------------------------------------------------------
87FOUND ; PCH 3
88 ;
89 ; If X was found
90 ;
91 ; Begin user selection
92 ;
93 ; Continue to display the list until the dialog with the
94 ; user is terminated. The dialog with the user is
95 ; considered to be terminated if:
96 ;
97 ; the selection list does not exist '$D(LEX("LIST"))
98 ;
99 ; or the user has made a selection $D(LEX("SEL")
100 ;
101 I $D(LEX("LIST")) F Q:+($G(LEX))=0 D SELECT^LEXA2
102 Q:$D(LEX("SEL"))
103 I '$L($G(LEX)) K LEX Q ;PCH 6 quit if LEX=""
104 I $L($G(LEX)),'$D(LEX("SEL")),$D(^TMP("LEXSCH",$J)) D
105 . D EN^LEXA4 S:'$D(LEX("SEL")) LEX=0 ; PCH 6 rebuild list if no SEL
106 ;
107 Q
108EXIT ; Kill variables
109 S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV
110 S:$L($G(LEXDICA)) DIC("A")=LEXDICA S:$L($G(LEXDICB)) DIC("B")=LEXDICB
111 ; Set Y, Y(0,0) Y(1) from LEX("SEL")
112 S:'$D(LEX("SEL","EXP",1)) Y=-1 K Y(1)
113 I $D(LEX("SEL","EXP",1)) S Y=LEX("SEL","EXP",1) D Y1,SSBR S:DIC(0)["Z" Y(0)=^LEX(757.01,+(LEX("SEL","EXP",1)),0),Y(0,0)=$P(^LEX(757.01,+(LEX("SEL","EXP",1)),0),"^",1)
114 K LEX,LEXSUB,LEXAP,LEXLL
115 K ^TMP("LEXSCH",$J),^TMP("LEXFND",$J),^TMP("LEXHIT",$J)
116 Q
117Y1 ; ICD in Y(1) and CPT in Y(81)
118 N LEXVAS S LEXVAS=0,Y(1)=""
119 F S LEXVAS=$O(LEX("SEL","VAS","B",80,LEXVAS)) Q:+LEXVAS=0!(Y(1)'="") D
120 . S Y(1)=$P($G(LEX("SEL","VAS",LEXVAS)),"^",3)
121 S LEXVAS=0,Y(81)="" F S LEXVAS=$O(LEX("SEL","VAS","B",81,LEXVAS)) Q:+LEXVAS=0!(Y(81)'="") D
122 . S Y(81)=$P($G(LEX("SEL","VAS",LEXVAS)),"^",3)
123 K:Y(1)="" Y(1) K:Y(81)="" Y(81)
124 I $D(Y(1)) D
125 .W !!,">>> Code : "
126 .I $D(IOINHI)&($D(IOINORM)) W IOINHI,Y(1),IOINORM,! Q
127 .W Y(1),!
128 Q
129ASK ; Get user input
130 N DIR,DIRUT,DIROUT S:$L($G(LEXDICA)) DIC("A")=LEXDICA
131 S DIR("A")=DIC("A") W:'$L($G(X))&('$L($G(LEXDICB))) !
132 I '$L($G(X)),$L($G(LEXDICB)) S DIR("B")=LEXDICB
133 S DIR("?")=" "_$$SQ^LEXHLP ; PCH 11
134 S DIR("??")="^D INPHLP^LEXA1" N Y S DIR(0)="FAO^0:245" K X
135 D ^DIR
136 K DIC("B") D:$E(X,1)=" " RSBR
137 W:$E(X,1)'=" " ! ; PCH 4
138 F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
139 W:$D(DTOUT) !,"Try later.",!
140 ; If '^' typed or read timed out, set X="" to force quit.
141 I $D(DTOUT)!(X="^") S X=""
142 S:X[U DUOUT=1 K DIRUT,DIROUT Q
143INPHLP ; Look-up help PCH 11
144 N X S X="" S:$L($G(DIR("?"))) X=$G(DIR("?")) S:'$L(X) X=" "_$$SQ^LEXHLP
145 W:$L(X) !!,X,!
146 W !," Best results occur using one to three full or partial words without"
147 W !," a suffix (i.e., ""DIABETES"",""DIAB MELL"",""DIAB MELL INSUL"") or"
148 W !," a classification code (ICD, CPT, HCPCS, etc)"
149 Q
150CLR K ^TMP("LEXSCH",$J),^TMP("LEXHIT",$J),^TMP("LEXFND",$J) Q
151CHK ; Check Fileman look-up variables
152 K DIC("DR"),DIC("P"),DIC("V"),DLAYGO,DINUM
153 S:$L($G(X)) LEXSAVE=X S:$L($G(DIC("B"))) LEXDICB=DIC("B") K DIC("B")
154 I $L($G(DIC(0))) D
155 . F Q:DIC(0)'["L" S DIC(0)=$P(DIC(0),"L",1)_$P(DIC(0),"L",2)
156 . F Q:DIC(0)'["I" S DIC(0)=$P(DIC(0),"I",1)_$P(DIC(0),"I",2)
157 S:'$L($G(DIC(0))) DIC(0)="QEAMF" S:'$L($G(DIC)) DIC="^LEX(757.01,"
158 S:DIC(0)'["F" DIC(0)=DIC(0)_"F" S:'$L($G(DIC("A"))) DIC("A")="Enter Term/Concept: "
159 S LEXDICA=DIC("A")
160 Q
161SSBR ; Store data for Space Bar Return
162 ; PCH 3 discontinue saving unresolved narrative
163 Q:'$L($G(DUZ)) Q:+($G(DUZ))=0 Q:'$L($G(DIC)) Q:$G(DIC)'["757.01,"
164 Q:$G(DIC(0))'["F" Q:+($G(Y))'>2 Q:$E($G(X),1)=" " S ^DISV(DUZ,DIC)=+($G(Y))
165 Q
166RSBR ; Retrieve onSpace Bar Return
167 ; PCH 3 discontinue retrieving unresolved narrative
168 Q:'$L($G(DUZ)) Q:$G(DIC)'="^LEX(757.01," Q:$G(DIC(0))'["F"
169 Q:$E($G(X),1)'=" " S:+($G(^DISV(DUZ,DIC)))>2 X=@(DIC_+($G(^DISV(DUZ,DIC)))_",0)")
170 Q
Note: See TracBrowser for help on using the repository browser.