source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDBL2.m@ 1259

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

initial load of WorldVistAEHR

File size: 7.7 KB
Line 
1PXRMDBL2 ; SLC/PJH - Reminder Dialog Generation. ;05/08/2000
2 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
3 ;
4 ;Process individual finding
5 ;--------------------------
6FIND(DATA) ;
7 ;Determine finding type
8 S FGLOB=$P($P(DATA,U),";",2) Q:FGLOB=""
9 S FITEM=$P(DATA,";") Q:FITEM=""
10 S FTYP=$G(DEF1(FGLOB)) Q:FTYP=""
11 ;Get resolution item (same as finding item)
12 S RESN=$P(DATA,U)
13 ;Mental Health Test
14 I FTYP="MH" Q:'$$MHOK^PXRMDBL3(FITEM)
15 ;Check if an entry exists in the finding item dialog file
16 I $D(^PXRMD(801.43,"AC",RESN)) D Q:DIEN
17 .S DIEN=$$OK(RESN) Q:'DIEN
18 .;Create entry in array used to build reminder dialog
19 .S CNT=CNT+1,ARRAY(CNT)=801.43_U_DIEN
20 .W !!,CNT,?5,"Finding item dialog "_$$FNAM(RESN)
21 ;
22 ;Determine names/text for non-taxonomy/orderable item findings
23 I (FTYP'="TX")&(FTYP'="OI") D
24 .I FTYP="ED" S INAME=$$NAME(FGLOB,FITEM,4)
25 .I FTYP="VM" S INAME=$$NAME(FGLOB,FITEM,1)
26 .I (FTYP'="ED")&(FTYP'="VM") S INAME=$$NAME(FGLOB,FITEM,2)
27 .;Dialog item name root
28 .S DNAME=FTYP_" "_INAME
29 .;Create array entry for each resolution defined in #801.45
30 .D RESOL(FTYP,0)
31 ;
32 ;Determine names/text for orderable item findings
33 I FTYP="OI" D
34 .S INAME=$$NAME(FGLOB,FITEM,1)
35 .;Dialog item name root
36 .S DNAME=FTYP_" "_INAME
37 .;Create array entry
38 .D RESOL(FTYP,0)
39 ;
40 ;Determine names/text for taxonomy findings
41 I FTYP="TX" S INAME=$$NAME(FGLOB,FITEM,2) D TAXON
42 Q
43 ;
44 ;Get Finding Item name
45 ;---------------------
46FNAM(FIND) ;
47 N DATA,NAME,NODE
48 S NAME="Unknown"
49 S NODE=$O(^PXRMD(801.43,"AC",FIND,"")) Q:'NODE NAME
50 S DATA=$G(^PXRMD(801.43,NODE,0)) Q:DATA="" NAME
51 I $P(DATA,U)'="" S NAME=$P(DATA,U)
52 S GLOB=$P($P(FIND,U),";",2) S:GLOB]"" NAME=$G(DEF1(GLOB))_" - "_NAME
53 Q NAME
54 ;
55 ;additional prompts in 801.45
56 ;----------------------------
57FPROMPT(FNODE,RSUB,CNT,ARRAY) ;
58 ;Get all additional fields for this resolution type
59 N ACNT,ASUB,ATXT,DNODE,RDATA,REXC,ROVR,RREQ,RSNL
60 S ASUB=0,ACNT=0
61 F S ASUB=$O(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB)) Q:'ASUB D
62 .S RDATA=$G(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB,0)) Q:RDATA=""
63 .;Ignore if disabled
64 .I $P(RDATA,U,3)=1 Q
65 .S DNODE=$P(RDATA,U) Q:DNODE=""
66 .S ATXT=$P($G(^PXRMD(801.41,DNODE,0)),U) Q:ATXT=""
67 .S REXC=$P(RDATA,U,7),RSNL=$P(RDATA,U,6)
68 .S ROVR=$P(RDATA,U,5),RREQ=$P(RDATA,U,2)
69 .;S ATXT=$TR(ATXT,UPPER,LOWER)
70 .S ACNT=ACNT+1
71 .S ARRAY(CNT,ACNT)=DNODE_U_ROVR_U_RSNL_U_REXC_U_RREQ
72 Q
73 ;
74 ;Health Factor Resolutions
75 ;-------------------------
76HF(RNODE) ;
77 ;Defined in #801.95
78 I $D(^PXRMD(801.95,$P(RESN,";"),1,"B",RNODE)) Q 1
79 ;Check for local statuses if this is a national code (restricted edit)
80 N FOUND,LSUB S FOUND=0,LSUB=""
81 I $P($G(^PXRMD(801.9,RNODE,0)),U,6)=1 D
82 .F S LSUB=$O(^PXRMD(801.9,RNODE,10,"B",LSUB)) Q:'LSUB D Q:FOUND
83 ..S:$D(^PXRMD(801.95,$P(RESN,";"),1,"B",LSUB)) FOUND=1
84 Q FOUND
85 ;
86 ;Returns item name
87 ;-----------------
88NAME(FGLOB,FITEM,POSN) ;
89 N NAME
90 S FGLOB=U_FGLOB_FITEM_",0)"
91 S NAME=$P($G(@FGLOB),U,POSN)
92 I NAME]"" D
93 .I FGLOB["ICD9(" S NAME=$P($$ICDDX^ICDCODE(FITEM,""),U,2)
94 .I FGLOB["ICPT(" S NAME=$P($$CPT^ICPTCOD(FITEM,""),U,2)_" "_$TR(NAME,LOWER,UPPER)
95 .;I FGLOB["ICD9(" S NAME=NAME_" ("_$P($G(@FGLOB),U)_")"
96 .;I FGLOB["ICPT(" S NAME=$P($G(@FGLOB),U)_" "_$TR(NAME,LOWER,UPPER)
97 I NAME="" S NAME=$P($G(@FGLOB),U)
98 I NAME="" S NAME=FITEM
99 Q NAME
100 ;
101 ;Checks if an enabled finding item dialog exists
102 ;-----------------------------------------------
103OK(FIND) ;
104 N DATA,DIEN,DTYP,NODE
105 S NODE=$O(^PXRMD(801.43,"AC",FIND,"")) Q:'NODE 0
106 S DATA=$G(^PXRMD(801.43,NODE,0)) Q:DATA="" 0
107 ;Ignore disabled entries
108 I $P(DATA,U,3) Q 0
109 ;Ignore finding item dialogs no longer valid
110 S DIEN=$P(DATA,U,4) Q:DIEN="" 0
111 S DATA=$G(^PXRMD(801.41,DIEN,0)) Q:DATA="" 0
112 ;Ignore disabled dialogs
113 I $P(DATA,U,3)=1 Q 0
114 ;Return dialog ien
115 Q DIEN
116 ;
117 ;Create array for each resolution status
118 ;---------------------------------------
119RESOL(TYP,TAX) ;
120 ; Predefined fields :
121 ; PNAME - text used in prompt
122 ; DNAME - text used in dialog item name
123 ; RESN - finding item
124 ;
125 ; Taxonomies TYP=CPT or POV and TAX=1 or 0
126 ; Others TAX=0 (ie: 1 prompt per code)
127 ;
128 ;Get parameter file node for this finding type
129 S FNODE=$O(^PXRMD(801.45,"B",TYP,"")) Q:FNODE=""
130 ;Get each resolution type for this finding type
131 S RSUB=0
132 F S RSUB=$O(^PXRMD(801.45,FNODE,1,RSUB)) Q:'RSUB D
133 .;Check if resolution type is disabled
134 .I $P($G(^PXRMD(801.45,FNODE,1,RSUB,0)),U,2)=1 Q
135 .;Construct name for this resolution type
136 .S RNODE=$P($G(^PXRMD(801.45,FNODE,1,RSUB,0)),U),RNAME=""
137 .I RNODE S RNAME=$P($G(^PXRMD(801.9,RNODE,0)),U,2)
138 .I RNAME="" S RNAME=$P($G(^PXRMD(801.9,RNODE,0)),U)
139 .;Validate resolution
140 .I TYP="HF" Q:'$$HF(RNODE)
141 .W !
142 .;Create arrays
143 .S CNT=CNT+1
144 .;Convert dialog item name to UC
145 .S DNAME=$TR(DNAME,LOWER,UPPER)
146 .;Truncate the item name - without finesse
147 .S DSHORT=DNAME_" "_RNAME
148 .I $L(DSHORT)>63 S DSHORT=$E(DNAME,1,53)_" "_$E(RNAME,1,9)
149 .;Dialog item name,resolution status and finding item
150 .I TYP'="OI" S ARRAY(CNT)=DSHORT_U_RNODE_U_RESN_U
151 .;For orderable items the finding field is empty
152 .I TYP="OI" S ARRAY(CNT)=DSHORT_U_RNODE_U_U_$P(RESN,";")
153 .;Append prefix and suffix if NOT a condensed taxonomy
154 .S PNAME=INAME
155 .I 'TAX D
156 ..;Prefix text
157 ..S RPRE=$G(^PXRMD(801.45,FNODE,1,RSUB,3)) I RPRE]"" S RPRE=RPRE_" "
158 ..;Suffix text
159 ..S RSUF=$G(^PXRMD(801.45,FNODE,1,RSUB,4))
160 ..I (RSUF]"")&($E(RSUF)'=".") S RSUF=" "_RSUF
161 ..;Prompt text
162 ..S PNAME=RPRE_$TR(INAME,UPPER,LOWER)_RSUF
163 ..;Convert first character
164 ..S $E(PNAME)=$TR($E(PNAME),LOWER,UPPER)
165 .;Prompt text
166 .S WPTXT(CNT,1)=PNAME
167 .;test
168 .W !,CNT,?5,WPTXT(CNT,1)
169 .;Additional prompts from general finding parameters
170 .D FPROMPT(FNODE,RSUB,CNT,.ARRAY)
171 Q
172 ;
173 ;Taxonomy Dialog in #801.2
174 ;-------------------------
175TAXON ;
176 S TDPAR=$G(^PXD(811.2,FITEM,"SDZ")),TDTXT="",TDHTXT=""
177 S TPPAR=$G(^PXD(811.2,FITEM,"SDZ")),TPTXT="",TPHTXT=""
178 S TDMOD=$P(TDPAR,U,1),TPMOD=$P(TPPAR,U,1)
179 ;Check what type of taxonomy codes exist
180 S TDX=$O(^PXD(811.2,FITEM,80,0))
181 S TPR=$O(^PXD(811.2,FITEM,81,0))
182 ;
183 ;If taxonomy is to be presented as checkbox(s)
184 I ('TDMOD)!('TPMOD) D
185 .S DNAME=FTYP_" "_INAME
186 .;Create arrays
187 .S CNT=CNT+1
188 .;Convert dialog item name to UC
189 .S DNAME=$TR(DNAME,LOWER,UPPER)
190 .;Truncate the item name - without finesse
191 .S DSHORT=DNAME
192 .I $L(DSHORT)>40 S DSHORT=$E(DNAME,1,40)
193 .;Dialog item name and finding item
194 .S ARRAY(CNT)=DSHORT_U_U_RESN
195 .;Prompt text
196 .S WPTXT(CNT,1)=INAME
197 .W !!,CNT,?5,WPTXT(CNT,1)
198 ;
199 ;Individual Diagnoses
200 I TDX,TDMOD D
201 .N NLINES,CODE,OUTPUT
202 .S TSEQ=0,TTYP="POV"
203 .F S TSEQ=$O(^PXD(811.2,FITEM,"SDX","B",TSEQ)) Q:'TSEQ D
204 ..S TSUB=$O(^PXD(811.2,FITEM,"SDX","B",TSEQ,"")) Q:'TSUB
205 ..S DATA=$G(^PXD(811.2,FITEM,"SDX",TSUB,0)) Q:DATA=""
206 ..S TITEM=$P(DATA,U) Q:'TITEM
207 ..;Ignore if disabled
208 ..Q:$P(DATA,U,3)=1
209 ..;Resolution becomes the diagnosis
210 ..S RESN=TITEM_";ICD9("
211 ..;Take prompt from user defined text
212 ..S INAME=$P(DATA,U,2)
213 ..;Otherwise use name of diagnosis
214 ..S CODE=$$ICDDX^ICDCODE(TITEM,"")
215 ..S NLINES=$$ICDD^ICDCODE($G(CODE),"OUTPUT","")
216 ..S INAME=$G(OUTPUT(1))
217 ..I INAME="" S FGLOB="ICD9(",INAME=$$NAME(FGLOB,TITEM,3)
218 ..;Dialog Item name root
219 ..S DNAME="POV "_INAME
220 ..;Create array entry for each resolution defined in #801.45
221 ..D RESOL(TTYP,0)
222 ;
223 ;Individual Procedures
224 I TPR,TPMOD D
225 .S TSEQ=0,TTYP="CPT"
226 .F S TSEQ=$O(^PXD(811.2,FITEM,"SPR","B",TSEQ)) Q:'TSEQ D
227 ..S TSUB=$O(^PXD(811.2,FITEM,"SPR","B",TSEQ,"")) Q:'TSUB
228 ..S DATA=$G(^PXD(811.2,FITEM,"SPR",TSUB,0)) Q:DATA=""
229 ..S TITEM=$P(DATA,U) Q:'TITEM
230 ..;Ignore if disabled
231 ..Q:$P(DATA,U,3)=1
232 ..;Resolution becomes the procedure
233 ..S RESN=TITEM_";ICPT("
234 ..;Take prompt from user defined text
235 ..S INAME=$P(DATA,U,2)
236 ..;Otherwise use name of procedure
237 ..I INAME="" S FGLOB="ICPT(",INAME=$$NAME(FGLOB,TITEM,2)
238 ..;Dialog Item name root
239 ..S DNAME="CPT "_INAME
240 ..;Create array entry for each resolution defined in #801.45
241 ..D RESOL(TTYP,0)
242 Q
Note: See TracBrowser for help on using the repository browser.