source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMREDF.m@ 1553

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

initial load of FOIAVistA 6/30/08 version

File size: 9.0 KB
Line 
1PXRMREDF ; SLC/PJH - Edit PXRM reminder findings. ;01/09/2007
2 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
3 ;
4 ; Called by PXRMREDT which newes and initialized DEF, DEF1, DEF2.
5 ;
6SET S:'$D(^PXD(811.9,DA,20,0)) ^PXD(811.9,DA,20,0)="^811.902V" Q
7 ;Display ALL findings
8 ;
9 ;--------------------
10DSPALL(TYPE,NODE,DA,LIST) ;
11 N FIRST,SUB,SUB1,SUB2
12 S FIRST=1,SUB="",SUB1="",SUB2=""
13 F S SUB=$O(LIST(SUB)) Q:SUB="" D
14 .S SUB1=0
15 .F S SUB1=$O(LIST(SUB,SUB1)) Q:SUB1="" D
16 ..S SUB2=0 F S SUB2=$O(LIST(SUB,SUB1,SUB2)) Q:SUB2="" D
17 ...I FIRST S FIRST=0 W !!,"Choose from:",!
18 ...W SUB
19 ...W ?5,SUB1,?65,"Finding #: "_SUB2,!
20 I FIRST,TYPE="D" W !!,"Reminder has no findings",!
21 I FIRST,TYPE="T" W !!,"Reminder Term has no findings",!
22 ;Update
23 D LIST^PXRMREDT(NODE,DA,.LIST)
24 Q
25 ;
26 ;Edit individual FINDING entry
27 ;-----------------------------
28FEDIT(IEN) ;
29 N CFIEN,DA,DIC,DIE,DR,ETYPE,GLOB
30 N STATUS,TERMSTAT,TIEN,TERMTYPE,VF,WPIEN,Y
31 S DA(1)=IEN
32 S DIC="^PXD(811.9,"_IEN_",20,"
33 I $P(^PXD(811.9,IEN,100),U)="N",$G(PXRMINST)'=1 S DIC(0)="QEA"
34 E S DIC(0)="QEAL"
35 S DIC("A")="Select FINDING: "
36 S DIC("P")="811.902V"
37 D ^DIC I Y=-1 S DTOUT=1 Q
38 S DIE=DIC K DIC
39 S DIE("NO^")="OUTOK"
40 S DA=+Y,GLOB=$P($P(Y,U,2),";",2) Q:GLOB=""
41 S TYPE=$G(DEF1(GLOB))
42 S SDA(2)=DA(1),SDA(1)=DA
43 ;Save term IEN
44 S STATUS=0
45 I TYPE="CF" S CFIEN=$P($P(Y,U,2),";",1) D
46 .I $D(^PXRMD(811.4,CFIEN,1))>0 D
47 ..W !!,"Computed Finding Description:" S WPIEN=0
48 ..F S WPIEN=$O(^PXRMD(811.4,CFIEN,1,WPIEN)) Q:+WPIEN'>0 D
49 ...W !,$G(^PXRMD(811.4,CFIEN,1,WPIEN,0))
50 .E W !!,"No description defined for this computed finding"
51 I TYPE="MH" D WARN^PXRMMH
52 I TYPE="RT" S TIEN=$P($P(Y,U,2),";",1)
53 ;Finding record fields
54 W !!,"Editing Finding Number: "_$G(DA)
55 S DR=".01;3;I X=""0Y"" S Y=6;1;2;6;7;8;9;12;17"
56 ;Taxonomy - use inactive problems
57 I TYPE="TX" D
58 .S TERMSTAT=$$TAXNODE^PXRMSTA1($P($P(Y,U,2),";"),"H")
59 .I TERMSTAT="P" S DR=DR_";10" Q
60 .I TERMSTAT'=0 S DR=DR_";10",STATUS=1
61 I TYPE="RT" D
62 .S TERMTYPE=$$TERMTYPE(TIEN)
63 .I TERMTYPE["H" S DR=DR_";11"
64 ;Health Factor - within category rank
65 I TYPE="HF" S DR=DR_";11"
66 ;If V file INCLUDE VISIT DATA
67 S VF=$S(TYPE="ED":1,TYPE="EX":1,TYPE="HF":1,TYPE="IM":1,TYPE="ST":1,TYPE="TX":1,1:0)
68 I TYPE="RT",$P(TERMTYPE,U,2)="VF" S VF=1
69 I VF S DR=DR_";28"
70 ;
71 ;Mental Health - scale
72 I TYPE="MH" S DR=DR_";13"
73 ;Radiology procedure.
74 I TYPE="RP" S STATUS=1
75 ;Orderable Item
76 I TYPE="OI" S DR=DR_";27",STATUS=1
77 ;Rx Type
78 I (TYPE="DC")!(TYPE="DG")!(TYPE="DR") S DR=DR_";16;27",STATUS=1
79 ;Condition
80 S DR=DR_";14;15;18"
81 I TYPE="CF" S DR=DR_";26"
82 ;Found/not found text
83 S DR=DR_";4;5"
84 ;
85 I TYPE="RT" D
86 . I TERMTYPE["D" S DR=DR_";16;27",STATUS=1
87 . I TERMTYPE["O" S DR=DR_";27",STATUS=1
88 . I TERMTYPE["R" S STATUS=1
89 . I TERMTYPE["T" S STATUS=1
90 .I TERMTYPE[2 D
91 .. N MSG
92 .. S MSG(1)="Cannot set a status since the term contains multiple types of findings"
93 .. S MSG(2)="Edit the status field at the term level for each finding" H 2
94 .. D EN^DDIOL(.MSG)
95 ;Edit finding record
96 D ^DIE
97 S $P(^PXD(811.9,IEN,20,0),U,3)=0
98 I $D(Y) S DTOUT=1 Q
99 ;Check if deleted
100 I '$D(DA) Q
101 I STATUS=1,$D(Y)=0 D STATUS^PXRMSTA1(.DA,"D")
102 ;
103 S ETYPE=$P(^PXD(811.9,IEN,20,SDA(1),0),U,1)
104 ;Option to edit term findings
105 I $P(ETYPE,";",2)="PXRMD(811.5," D
106 . S TIEN=$P(ETYPE,";",1)
107 . D TMAP(IEN,TIEN)
108 Q
109 ;
110 ;Edit individual function finding entry
111 ;-----------------------------
112FFEDIT(IEN) ;
113 N DA,DIC,DIE,DR,Y
114 S DA(1)=IEN
115 S DIC="^PXD(811.9,"_IEN_",25,"
116 S DIC(0)="QEAL"
117 S DIC("A")="Select FUNCTION FINDING: "
118 D ^DIC
119 I Y=-1 S DTOUT=1 Q
120 S DIE=DIC K DIC
121 S DA=+Y
122 ;Finding record fields
123 S DR=".01;3"
124 ;Edit finding record
125 D ^DIE
126 I $D(Y) S DTOUT=1 Q
127 I '$D(DA) Q
128 ;If the function string is null don't do the rest of the fields.
129 I $G(^PXD(811.9,IEN,25,DA,3))="" Q
130 S DR="1;2;11;12;15;I X=""0Y"" S Y=16;13;14;16"
131 D ^DIE
132 I $D(Y) S DTOUT=1 Q
133 I '$D(DA) Q
134 ;Check if deleted
135 Q
136 ;
137 ;Edit Reminder Function Findings
138 ;----------------------
139FFIND ;
140 N DTOUT,DUOUT
141 F D Q:$D(DUOUT)!$D(DTOUT)
142 .D FFEDIT(DA) I $D(DUOUT)!$D(DTOUT) Q
143 K DUOUT,DTOUT
144 Q
145 ;
146 ;Edit Reminder Findings
147 ;----------------------
148FIND(LIST) ;
149 N DTOUT,DUOUT,NODE,SDA
150 D SET ; Check if node defined
151 S NODE="^PXD(811.9)"
152 F D Q:$D(DUOUT)!$D(DTOUT)
153 .;Display list of existing reminder findings
154 .W !!,"Reminder Definition Findings"
155 .D DSPALL("D",NODE,DA,.LIST)
156 .;Edit findings
157 .D FEDIT(DA) I $D(DUOUT)!$D(DTOUT) D LIST^PXRMREDT(NODE,DA,.LIST) Q
158 .;Update list with finding changes
159 .D LIST^PXRMREDT(NODE,DA,.LIST)
160 Q
161 ;
162 ;General help text routine
163 ;-------------------------
164HELP(CALL) ;
165 N HTEXT
166 N DIWF,DIWL,DIWR,IC
167 S DIWF="C70",DIWL=0,DIWR=70
168 ;
169 I CALL=1 D
170 .S HTEXT(1)="Select the type of finding you wish to change or add."
171 .S HTEXT(2)="Type '?' for a list of the available finding types."
172 I CALL=2 D
173 .S HTEXT(1)="Select section of the reminder you wish to edit or 'All'"
174 .S HTEXT(2)="to step through all sections of the reminder definition."
175 I CALL=3 D
176 .S HTEXT(1)="Select 'Y' to edit the findings mapped to this term"
177 .S HTEXT(2)="or 'N' to return to select another reminder finding."
178 ;
179 K ^UTILITY($J,"W")
180 S IC=""
181 F S IC=$O(HTEXT(IC)) Q:IC="" D
182 . S X=HTEXT(IC)
183 . D ^DIWP
184 W !
185 S IC=0
186 F S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC="" D
187 . W !,^UTILITY($J,"W",0,IC,0)
188 K ^UTILITY($J,"W")
189 W !
190 Q
191 ;
192 ;Display TERM findings
193 ;--------------------
194TDSP(DA) ;
195 N FIRST,SUB,TLST S FIRST=1,SUB="",SUB1=""
196 ;Build list of term findings
197 D TLST(.TLST,DA)
198 ;Display list
199 F S SUB=$O(TLST(SUB)) Q:SUB="" D
200 .S SUB1=0
201 .F S SUB1=$O(TLST(SUB,SUB1)) Q:SUB1="" D
202 ..I FIRST S FIRST=0 W !!,"Reminder Term Findings:",!!
203 ..W SUB
204 ..W ?8,SUB1,!
205 I FIRST W !!,"Term has no mapped findings",!!
206 Q
207 ;
208 ;List Reminders using this term
209 ;------------------------------
210TERMS(TIEN,RIEN) ;
211 ;RIEN will be the reminder ien if called from reminder edit
212 ;or zero if called from term edit
213 N ARRAY,FIND,IEN,SUB,TCNT,RNAME
214 ;Scan all reminders in file #811.9
215 S IEN=0,FIND="PXRMD(811.5,",TCNT=0
216 F S IEN=$O(^PXD(811.9,IEN)) Q:'IEN D
217 .;Exclude current reminder called in reminder edit
218 .I RIEN,IEN=RIEN Q
219 .;Check the term findings
220 .I '$D(^PXD(811.9,IEN,20,"E",FIND,TIEN)) Q
221 .;Add to reminder array
222 .S RNAME=$P($G(^PXD(811.9,IEN,0)),U)
223 .I RNAME="" S RNAME=IEN
224 .I '$D(ARRAY(RNAME)) S TCNT=TCNT+1
225 .S ARRAY(RNAME)=""
226 ;
227 ;Display list of reminders using the term
228 I TCNT D
229 .N TXT
230 .S TXT="This Reminder Term is" S:RIEN TXT=TXT_" also"
231 .S TXT=TXT_" used by the following Reminder Definition"
232 .I TCNT>1 S TXT=TXT_"s"
233 .W !!,TXT_":"
234 .S RNAME="" F S RNAME=$O(ARRAY(RNAME)) Q:RNAME="" W !," ",RNAME
235 Q
236 ;
237 ;------------------------------
238 ;Check term for finding item to edit status item
239TERMTYPE(TIEN) ;
240 N DRUG,FOUND,HF,ORD,OTHER,RAD,RESULT,TAX,TYPE,VF
241 S (DRUG,FOUND,HF,ORD,OTHER,RAD,RESULT,TAX,VF)=0
242 S TYPE="" F S TYPE=$O(^PXRMD(811.5,TIEN,20,"B",TYPE)) Q:TYPE="" D
243 . I TYPE["AUTTEDT(" S (OTHER,VF)=1 Q
244 . I TYPE["AUTTHF(" S (HF,OTHER,VF)=1 Q
245 . I TYPE["AUTTIMM(" S (OTHER,VF)=1 Q
246 . I TYPE["AUTTSK(" S (OTHER,VF)=1 Q
247 . I TYPE["ORD" S (ORD,FOUND)=1 Q
248 . I TYPE["PS" S (DRUG,FOUND)=1 Q
249 . I TYPE["PXD(811.2" S (FOUND,TAX,VF)=1 Q
250 . I TYPE["RAMIS" S (FOUND,RAD)=1 Q
251 . S OTHER=1
252 I RAD=1,ORD=0,TAX=0,DRUG=0,OTHER=0 S RESULT="R"
253 I RAD=0,ORD=1,TAX=0,DRUG=0,OTHER=0 S RESULT="O"
254 I RAD=0,ORD=0,TAX=1,DRUG=0,OTHER=0 S RESULT="T"
255 I RAD=0,ORD=0,TAX=0,DRUG=1,OTHER=0 S RESULT="D"
256 I OTHER=1 S RESULT=1 I FOUND=1 S RESULT=2
257 I RESULT="T" S RESULT=$$TAXTYPE^PXRMSTA1(TIEN,"")
258 I HF=1 S RESULT="H"_RESULT
259 I VF=1 S RESULT=RESULT_U_"VF"
260 Q RESULT
261 ;
262 ;Build list of mapped findings for term
263 ;--------------------------------------
264TLST(ARRAY,DA) ;
265 N TYPE,DATA,GLOB,IEN,NAME,NODE,SUB
266 ;Clear passed arrays
267 K ARRAY
268 ;Build cross reference global to file number
269 ;Get each finding
270 S SUB=0 F S SUB=$O(^PXRMD(811.5,DA,20,SUB)) Q:'SUB D
271 .S DATA=$G(^PXRMD(811.5,DA,20,SUB,0)) I DATA="" Q
272 .;Determine global and global ien
273 .S NODE=$P(DATA,U),GLOB=$P(NODE,";",2),IEN=$P(NODE,";")
274 .;Ignore null entries
275 .I (GLOB="")!(IEN="") Q
276 .;Work out the file type
277 .S TYPE=$G(DEF1(GLOB)) Q:TYPE=""
278 .S NAME=$P($G(@(U_GLOB_IEN_",0)")),U)
279 .S ARRAY(TYPE,NAME)=""
280 Q
281 ;
282 ;Map Term findings
283 ;-----------------
284TMAP(RIEN,TIEN) ;
285 N TOPT,TNAM
286 ;Display any other reminders using this term
287 D TERMS(TIEN,RIEN)
288 ;Term name
289 S TNAM=$P($G(^PXRMD(811.5,TIEN,0)),U)
290 ;Give option to edit mapped findings (Y/N)
291 D TMASK(.TOPT,TNAM) Q:$D(DUOUT)!($D(DTOUT))
292 ;Edit term findings
293 I TOPT="Y" D TRMED(TIEN)
294 Q
295 ;
296 ;Option to edit term findings
297 ;----------------------------
298TMASK(YESNO,TNAM) ;
299 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
300 S DIR(0)="YA0"
301 S DIR("A")="Do you want to edit mapped findings for "_TNAM_": "
302 S (DIR("B"),YESNO)="N"
303 S DIR("?")="Enter Y or N. For detailed help type ??"
304 S DIR("??")=U_"D HELP^PXRMREDF(3)"
305 W !
306 D ^DIR K DIR
307 I $D(DIROUT)!$D(DIRUT) Q
308 I $D(DTOUT)!$D(DUOUT) Q
309 S YESNO=$E(Y(0))
310 Q
311 ;
312 ;Term edit
313 ;---------
314TRMED(DA) ;
315 N CS1,CS2,DIC,DLAYGO,DTOUT,DUOUT,Y
316 K DLAYGO,DTOUT,DUOUT,Y
317 ;Display term findings
318 D TDSP(DA)
319 ;Initialize change history
320 S CS1=$$FILE^PXRMEXCS(811.5,DA)
321 ;Edit term findings
322 S DIC="^PXRMD(811.5,"
323 D EDIT^PXRMTMED(DIC,DA)
324 ;Update change history
325 S CS2=$$FILE^PXRMEXCS(811.5,DA)
326 I CS2=0 Q
327 I CS2'=CS1 D SEHIST^PXRMUTIL(811.5,DIC,DA)
328 Q
329 ;
Note: See TracBrowser for help on using the repository browser.