source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXDG.m@ 619

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

initial load of WorldVistAEHR
File size: 7.2 KB
RevLine 
[613]1PXRMEXDG ;SLC/PJH - Reminder Dialog Exchange index build ;05/16/2007
2 ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
3 ;
4 ;=====================================================================
5DIALOG(RIEN,DLIST,FLIST,OLIST,TLIST,SPONLIST) ;
6 ;
7 ;Routine to get dialog details for a given reminder
8 ;
9 ;Called as DIALOG^PXRMEXDG(RIEN,.DLIST,.FLIST)
10 ;
11 ;RIEN - Reminder IEN
12 ;DLIST - List of dialogs (components first)
13 ;FLIST - Finding list used by PXRMEXPR
14 ;OLIST - List of embedded TIU objects
15 ;TLIST - List of embedded TIU templates
16 ;
17 ;Initialize
18 K DLIST
19 N DARRAY,DCNT,DIALOG,DIEN,FCNT,FINDING,OCNT,RCNT,RESULT,TEMP
20 ;Check if reminder exists
21 Q:'$D(^PXD(811.9,RIEN,0))
22 ;Get dialog ien from reminder definition
23 S DIEN=$P($G(^PXD(811.9,RIEN,51)),U) Q:'DIEN
24 ;Check dialog pointer is valid
25 Q:'$D(^PXRMD(801.41,DIEN))
26 ;Dialog and Finding count
27 S DCNT=0,FCNT=0,RCNT=0,TCNT=0
28 ;Get details
29 D GETSPON^PXRMEXPR(801.41,DIEN,.SPONLIST)
30 D DGET(DIEN,.SPONLIST)
31 ;
32 ;Now build the dialog list (components first)
33 S DCNT="",OCNT=0
34 F S DCNT=$O(DARRAY(DCNT),-1) Q:'DCNT D
35 .;Ignore dialogs previously encountered
36 .S DIEN=DARRAY(DCNT) Q:$D(DIALOG(DIEN))
37 .;Save dialog in output array
38 .S OCNT=OCNT+1,DIALOG(DIEN)="",TEMP("DIALOG",OCNT)=DIEN
39 ;
40 ;Save the dialog and result details to DLIST
41 N CNT,COUNT,DTYP
42 S COUNT=0
43 F DTYP="RESULT ELEMENT" D
44 .S CNT=0 F S CNT=$O(TEMP(DTYP,CNT)) Q:CNT'>0 D
45 ..S DIEN=$G(TEMP(DTYP,CNT)) Q:DIEN'>0
46 ..S COUNT=COUNT+1,DLIST("DIALOG",COUNT,DIEN)=""
47 ;
48 F DTYP="RESULT" D
49 .S CNT=0 F S CNT=$O(TEMP(DTYP,CNT)) Q:CNT'>0 D
50 ..S DIEN=$G(TEMP(DTYP,CNT)) Q:DIEN'>0
51 ..S COUNT=COUNT+1,DLIST("DIALOG",COUNT,DIEN)=""
52 ;
53 ;F DTYP="RESULT","DIALOG" D
54 F DTYP="DIALOG" D
55 .F CNT=1:1 S DIEN=$G(TEMP(DTYP,CNT)) Q:'DIEN D
56 ..S COUNT=COUNT+1,DLIST("DIALOG",COUNT,DIEN)=""
57 ;
58 I COUNT>0 S DLIST("DIALOG")=801.41
59 ;
60 ;Add Dialog Findings to FLIST if not aready present
61 N DIC,DO,IEN,FNAME,FNUM,SUB
62 S SUB=0
63 F S SUB=$O(TEMP("FINDING",SUB)) Q:'SUB D
64 .S IEN=$P(TEMP("FINDING",SUB),";"),DIC=U_$P(TEMP("FINDING",SUB),";",2)
65 .K DO D DO^DIC1
66 .S FNUM=+DO(2),FNAME=$P(DO,U) I ('FNUM)!(FNAME="") Q
67 .;Check if present in FLIST
68 .I $D(FLIST(FNAME,"F",IEN)) Q
69 .;Otherwise add to list
70 .S:'$D(FLIST(FNAME)) FLIST(FNAME)=FNUM S FLIST(FNAME,"F",IEN)=""
71 .;Add the Health Factor category to FLIST
72 .I FNAME="HEALTH FACTORS" D
73 ..N HFCAT
74 ..S HFCAT=$P($G(^AUTTHF(IEN,0)),U,3) S:HFCAT FLIST(FNAME,"C",HFCAT)=""
75 ;
76 ;Store any TIU components
77 N GLOB,DIEN,CNT
78 ;Set global for search
79 S GLOB="^PXRMD(801.41,"
80 ;Search through all component dialogs
81 S CNT=0
82 F S CNT=$O(DLIST("DIALOG",CNT)) Q:'CNT D
83 .S DIEN=$O(DLIST("DIALOG",CNT,"")) Q:'DIEN
84 .;Search Dialog Text for TIU Objects and Templates
85 .D TIUSRCH(GLOB,DIEN,25,.OLIST,.TLIST)
86 .;Search P/N Text for TIU Objects and Templates
87 .D TIUSRCH(GLOB,DIEN,35,.OLIST,.TLIST)
88 ;
89 Q
90 ;
91 ;Get the dialog components
92 ;-------------------------
93DGET(D0,SPONLIST) ;Save dialog ien
94 N D1
95 I $G(D0)=83
96 I $G(^PXRMD(801.41,D0,49))'="",$P(^PXRMD(801.41,D0,49),U,3)>0 D
97 .S D1=$P($G(^PXRMD(801.41,D0,49)),U,3) D DGET1(D0,.SPONLIST) D DGET1(D1,.SPONLIST)
98 E D DGET1(D0,.SPONLIST)
99 Q
100DGET1(D0,SPONLIST) ;
101 S DCNT=DCNT+1,DARRAY(DCNT)=D0
102 ;And details (except for reminder dialog)
103 I DCNT>1 D
104 .D GETSPON^PXRMEXPR(801.41,D0,.SPONLIST)
105 .;Finding items
106 .D DFIND(D0)
107 .;Additional Finding Items
108 .D DFINDA(D0)
109 .;Result groups
110 .D DRESULT(D0)
111 ;
112 ;Dialog components
113 N DCOMP,DCOMP1,DDATA,DSUB
114 S DSUB=0
115 F S DSUB=$O(^PXRMD(801.41,D0,10,DSUB)) Q:'DSUB D
116 .;Get any component dialogs
117 .S DCOMP=$P($G(^PXRMD(801.41,D0,10,DSUB,0)),U,2) Q:'DCOMP
118 .;If component exists get sub-components
119 .S DDATA=$G(^PXRMD(801.41,DCOMP,0)) Q:DDATA=""
120 .;Exclude national PXRM prompts
121 .I +$G(PXRMINST)=0,$E(DDATA,1,4)="PXRM",$P($G(^PXRMD(801.41,DCOMP,100)),U)="N" Q
122 .;Sub-components
123 .D DGET(DCOMP,.SPONLIST)
124 .;I $G(DCOMP1)'="" D DGET(DCOMP1) S DCOMP1=""
125 Q
126 ;
127 ;Build list of finding items
128 ;---------------------------
129DFIND(DIEN) ;
130 N FIND,FIEN,FGLOB,FNAM
131 ;Finding Item
132 S FIND=$P($G(^PXRMD(801.41,DIEN,1)),U,5)
133 ;If a finding item exists check and save
134LOOP ;
135 I FIND]"" D
136 .;Finding item defined
137 .S FIEN=$P(FIND,";"),FGLOB=$P(FIND,";",2) Q:'FIEN Q:FGLOB=""
138 .;And finding item exists
139 .Q:'$D(@(U_FGLOB_FIEN_",0)"))
140 .;Finding name
141 .S FNAM=$P($G(@(U_FGLOB_FIEN_",0)")),U) S:FNAM="" FNAM="???"
142 .;And not previously saved
143 .I '$D(FINDING(FIND)) D
144 ..S FCNT=FCNT+1,FINDING(FIND)="",TEMP("FINDING",FCNT)=FIND
145 I $G(^PXRMD(801.41,DIEN,49))'="",$P(^PXRMD(801.41,DIEN,49),U)>0 D
146 .S FIND=$P(^PXRMD(801.41,DIEN,49),U)
147 .I $D(FLIST("REMINDER TERM","F",FIND)) Q
148 .I '$D(FLIST("REMINDER TERM")) S FLIST("REMINDER TERM")="811.5"
149 .S FLIST("REMINDER TERM","F",FIND)=""
150 .D GETTFIND^PXRMEXPR(.FLIST)
151 Q
152 ;
153 ;Build list of additional findings
154 ;---------------------------------
155DFINDA(DIEN) ;
156 N FIND,FIEN,FGLOB,FNAM,FSUB
157 S FSUB=0
158 F S FSUB=$O(^PXRMD(801.41,DIEN,3,FSUB)) Q:'FSUB D
159 .;Additional Finding Item
160 .S FIND=$P($G(^PXRMD(801.41,DIEN,3,FSUB,0)),U)
161 .;If a finding item exists check and save
162 .I FIND]"" D
163 ..;Finding item defined
164 ..S FIEN=$P(FIND,";"),FGLOB=$P(FIND,";",2) Q:'FIEN Q:FGLOB=""
165 ..;And finding item exists
166 ..Q:'$D(@(U_FGLOB_FIEN_",0)"))
167 ..;Finding name
168 ..S FNAM=$P($G(@(U_FGLOB_FIEN_",0)")),U) S:FNAM="" FNAM="???"
169 ..;And not previously saved
170 ..I '$D(FINDING(FIND)) D
171 ...S FCNT=FCNT+1,FINDING(FIND)="",TEMP("FINDING",FCNT)=FIND
172 Q
173 ;
174 ;Build list of result groups
175 ;---------------------------
176DRESULT(DIEN) ;
177 N CNT,RIEN,RECNT,RGCNT
178 ;Result Group/Element pointer
179 S RECNT=$O(TEMP("RESULT ELEMENT",""),-1)
180 S RGCNT=$O(TEMP("RESULT",""),-1)
181 S CNT=0
182 F S CNT=$O(^PXRMD(801.41,DIEN,51,CNT)) Q:CNT'>0 D
183 .S RIEN=$P($G(^PXRMD(801.41,DIEN,51,CNT,0)),U) Q:RIEN'>0
184 .;S RIEN=$P($G(^PXRMD(801.41,DIEN,0)),U,15) Q:'RIEN Q:$D(RESULT(RIEN))
185 .;Result group compoments
186 .N DSUB,REIEN
187 .S DSUB=0
188 .F S DSUB=$O(^PXRMD(801.41,RIEN,10,DSUB)) Q:'DSUB D
189 ..;Get result element
190 ..S REIEN=$P($G(^PXRMD(801.41,RIEN,10,DSUB,0)),U,2) Q:'REIEN
191 ..Q:'$D(^PXRMD(801.41,REIEN,0))
192 ..;If element exists get save it
193 ..S RECNT=RECNT+1,TEMP("RESULT ELEMENT",RECNT)=REIEN
194 ..;S RCNT=RCNT+1,OUTPUT("RESULT",RCNT)=REIEN
195 .;
196 .;Save result group
197 .S RGCNT=RGCNT+1,TEMP("RESULT",RGCNT)=RIEN
198 .;S RCNT=RCNT+1,RESULT(RIEN)="",TEMP("RESULT",RCNT)=RIEN
199 Q
200 ;
201 ;Extract TIU Objects/Templates from any WP text
202 ;----------------------------------------------
203TIUSRCH(GLOB,IEN,NODE,OLIST,TLIST) ;
204 N OCNT,TCNT,TEXT
205 ;Add to existing arrays
206 S OCNT=+$O(OLIST(""),-1),TCNT=+$O(TLIST(""),-1),SUB=0
207 ;Scan WP fields
208 F S SUB=$O(@(GLOB_IEN_","_NODE_","_SUB_")")) Q:'SUB D
209 .;Get individual line
210 .S TEXT=$G(@(GLOB_IEN_","_NODE_","_SUB_",0)")) Q:TEXT=""
211 .;Most text lines will have no TIU link so ignore them
212 .I (TEXT'["|")&(TEXT'["{FLD:") Q
213 .;Templates are in format {FLD:fldname} (only applies to dialogs)
214 .I GLOB[801.41 D TIUXTR("{FLD:","}",TEXT,.TLIST,.TCNT)
215 .;Objects are in format |Objectname|
216 .D TIUXTR("|","|",TEXT,.OLIST,.OCNT)
217 Q
218 ;
219TIUXTR(SRCH,SRCH1,TEXT,OUTPUT,CNT) ;
220 N EXIST,IC,TXT,ONAME
221 S TXT=TEXT
222 F D Q:TXT'[SRCH
223 .S TXT=$E(TXT,$F(TXT,SRCH),$L(TXT)) Q:TXT'[SRCH1
224 .S ONAME=$P(TXT,SRCH1) Q:ONAME=""
225 .;Check if already selected
226 .S EXIST=0,IC=0
227 .F S IC=$O(OUTPUT(IC)) Q:'IC Q:EXIST D
228 ..I $G(OUTPUT(IC))=ONAME S EXIST=1
229 .;Save array of object/template names
230 .I 'EXIST S CNT=CNT+1,OUTPUT(CNT)=ONAME
231 Q
Note: See TracBrowser for help on using the repository browser.