source: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLLA.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1PXRMDLLA ;SLC/PJH - REMINDER DIALOG LOADER ;11/08/2007
2 ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
3 ;
4FREC(DFIEN,DFTYP) ;Build type 3 record
5 N CSARRAY,CSCNT
6 ;Dialog type/text and resolution
7 S DNAM=$$NAME(DFIEN,DFTYP)
8 D CODE^PXRMDLLB(DFIEN,DFTYP,.CSARRAY)
9 I $D(CSARRAY)>0 D Q
10 . S CSCNT="" F S CSCNT=$O(CSARRAY(CSCNT)) Q:CSCNT="" D
11 . . S OCNT=OCNT+1
12 . . S ORY(OCNT)=3_U_DITEM_U_U_DPCE_U_DEXC_U_DFIEN_U_$G(CSARRAY(CSCNT))_U_DNAM_U_U_DVIT
13 ;Translate vitals ien to PCE code - This will need a DBIA
14 S DCOD=""
15 I DPCE="VIT" D
16 .S DFIEN=$$GET1^DIQ(120.51,DFIEN,7,"E")
17 .;Vitals Caption
18 .S DVIT=$P($G(^PXRMD(801.41,DITEM,2)),U,4)
19 I DFTYP]"" D
20 .S OCNT=OCNT+1
21 .S ORY(OCNT)=3_U_DITEM_U_U_DPCE_U_DEXC_U_DFIEN_U_$G(DCOD)_U_DNAM_U_U_DVIT
22 .;Get order type for orderable items
23 .;DBIA #3110
24 .S:DPCE="Q" $P(ORY(OCNT),U,11)=$P($G(^ORD(101.41,DFIEN,0)),U,4)
25 .;If mental health check if a GAF score and if MH test is required
26 .I DPCE="MH",DFIEN D
27 ..;DBIA #5044
28 ..I $P($G(^YTT(601.71,DFIEN,0)),U)="GAF" S $P(ORY(OCNT),U,12)=1
29 ..;Check to see if the MH test is required
30 ..S $P(ORY(OCNT),U,13)=+$P($G(^PXRMD(801.41,DITEM,0)),U,18)
31 ..I $P(ORY(OCNT),U,13)=2,$$PATCH^XPDUTL("OR*3.0*243")=0 S $P(ORY(OCNT),U,13)=1
32 Q
33 ;
34GUI(IEN) ;Work out prompt type for PCE
35 Q:IEN="" ""
36 N SUB S SUB=$P($G(^PXRMD(801.41,IEN,46)),U)
37 Q:'SUB ""
38 Q $P($G(^PXRMD(801.42,SUB,0)),U)
39 ;
40LOAD(DITEM,DCUR,DTTYP) ;Load dialog questions into array
41 N DARRAY,DCOD,DEXC,DFIND,DFIEN,DFTYP,DNAM,DPCE,DRES,DSEQ,DSUB,DTYP,OCNT
42 N DVIT,NODE,CNT,IDENT
43 ;DBIA #3110 OR(101.41
44 ;
45 ;Build list of PCE codes
46 S DARRAY("AUTTEDT(")="PED"
47 S DARRAY("AUTTEXAM(")="XAM"
48 S DARRAY("AUTTHF(")="HF"
49 S DARRAY("AUTTIMM(")="IMM"
50 S DARRAY("AUTTSK(")="SK"
51 ;
52 S DARRAY("GMRD(120.51,")="VIT"
53 S DARRAY("ORD(101.41,")="Q"
54 S DARRAY("YTT(601.71,")="MH"
55 ;
56 S DARRAY("ICD9(")="POV"
57 S DARRAY("ICPT(")="CPT"
58 S DARRAY("WV(790.404,")="WH"
59 S DARRAY("WV(790.1,")="WHR"
60 ;
61 S DARRAY("PXD(811.2,")="T"
62 ;
63 ;Get the dialog element
64 S OCNT=0
65 N TERMNODE,TERMSTAT,TERMOUT
66 S DTYP=$P($G(^PXRMD(801.41,DITEM,0)),U,4)
67 ;Finding detail
68 S DRES=$P($G(^PXRMD(801.41,DITEM,1)),U,3)
69 S DFIND=$P($G(^PXRMD(801.41,DITEM,1)),U,5)
70 ;check for WH finding
71 I $P($G(^PXRMD(801.41,DITEM,0)),U,16)["WHR" S DFIND=$G(WHFIND)
72 ;
73 S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2)
74 S DPCE="",DVIT="" I DFTYP'="" S DPCE=$G(DARRAY(DFTYP))
75 ;Exclude from P/N
76 S DEXC=$P($G(^PXRMD(801.41,DITEM,2)),U,3)
77 ;
78 ;Non taxonomy codes (3 - finding record)
79 I DPCE'="T" D FREC(DFIEN,DFTYP)
80 ;
81 ;Taxonomy codes need expanding (3 - finding record)
82 I DPCE="T" D EXP^PXRMDLLB(DFIEN,DCUR,DTTYP)
83 ;
84 ;Prompt details (4 - prompt records)
85 N ARRAY,DTITLE,DREQ,DSEQ,DSSEQ,DSUB,DTYP
86 ;If not a taxonomy get prompts from dialog file
87 I DPCE'="T" D PROTH(DITEM)
88 ;Check for MST findings
89 I (DPCE'="T"),(DFTYP]"") D MST^PXRMDLLB(DFTYP,DFIEN)
90 ;If taxonomy use finding parameters (CPT/POV)
91 I DPCE="T" D
92 .;Quit if finding type not passed
93 .Q:DTTYP=""
94 .N RSUB,FNODE
95 .;Get parameter file node for this finding type
96 .S FNODE=$O(^PXRMD(801.45,"B",DTTYP,"")) Q:FNODE=""
97 .;Derive resolution from line ien 1=done 2=done elsewhere
98 .S RSUB=DCUR+1 I (RSUB<1)!(RSUB>2) Q
99 .;Get details from 811.5
100 .D PRTAX(FNODE,RSUB)
101 ;Return array of type 4 records
102 S DSEQ=""
103 F S DSEQ=$O(ARRAY(DSEQ)) Q:'DSEQ D
104 .S OCNT=OCNT+1
105 .S ORY(OCNT)=4_U_DITEM_U_DSEQ_U_ARRAY(DSEQ)
106 .S DSSEQ=""
107 .F S DSSEQ=$O(ARRAY(DSEQ,DSSEQ)) Q:'DSSEQ D
108 ..S OCNT=OCNT+1
109 ..S ORY(OCNT)=4_U_DITEM_U_DSEQ_"."_DSSEQ_U_ARRAY(DSEQ,DSSEQ)
110 ;
111 ;Get progress note text if defined
112 I DPCE'="T" D:'DEXC PTXT(DITEM)
113 ;Additional findings
114 N FASUB
115 S FASUB=0
116 F S FASUB=$O(^PXRMD(801.41,DITEM,3,FASUB)) Q:'FASUB D
117 .S DFIND=$P($G(^PXRMD(801.41,DITEM,3,FASUB,0)),U)
118 .S DFIEN=$P(DFIND,";"),DFTYP=$P(DFIND,";",2) Q:DFTYP="" Q:DFIEN=""
119 .S DVIT="",DPCE=$G(DARRAY(DFTYP))
120 .I DPCE'="" D FREC(DFIEN,DFTYP)
121 Q
122 ;
123 ;
124 ;Returns item name
125NAME(DFIEN,DFTYP) ;
126 Q:DFTYP="" ""
127 Q:DFIEN="" ""
128 N NAME,FGLOB,POSN
129 ;DBIA #4108
130 I DFTYP="WV(790.404," S NAME=$P($G(^WV(790.404,DFIEN,0)),U) Q:NAME]"" NAME
131 I DFTYP="WV(790.1," S NAME=$G(WHNAME) K WHNAME Q:NAME]"" NAME
132 S POSN=2
133 S:DFTYP["AUTT" POSN=1 S:DFTYP["AUTTEDT" POSN=4 S:DFTYP["ICD" POSN=3
134 S FGLOB=U_DFTYP_DFIEN_",0)",NAME=$P($G(@FGLOB),U,POSN)
135 I (POSN>1),NAME="" S NAME=$P($G(@FGLOB),U)
136 I NAME="" S NAME=DFIEN
137 Q NAME
138 ;
139PROTH(IEN) ; Additional prompts defined in 801.41
140 N DDATA,DDEF,DIEN,DEXC,DGUI,DNAME,DOVR,DREQ,DSEQ,DSNL,DSUB,DFTEXT
141 N DTXT,DTYP,PRINT
142 S DSEQ=0
143 F S DSEQ=$O(^PXRMD(801.41,IEN,10,"B",DSEQ)) Q:'DSEQ D
144 .;Get prompts in sequence
145 .S DSUB=$O(^PXRMD(801.41,IEN,10,"B",DSEQ,"")) Q:'DSUB
146 .;Prompt ien
147 .S DIEN=$P($G(^PXRMD(801.41,IEN,10,DSUB,0)),U,2) Q:'DIEN
148 .;Ignore disabled components, and those that are not prompts
149 .Q:($P($G(^PXRMD(801.41,DIEN,0)),U,3)]"")!("PF"'[$P($G(^(0)),U,4))
150 .;Set defaults to null
151 .S DDEF="",DEXC="",DREQ="",DSNL=""
152 .;Prompt name and GUI process (quit if null)
153 .S DNAME=$P($G(^PXRMD(801.41,DIEN,0)),U),DGUI=$$GUI(DIEN)
154 .I $G(DGUI)="WH_NOT_PURP" D
155 ..S PRINT=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I")
156 .;Type Prompt or Forced
157 .S DTYP=$P($G(^PXRMD(801.41,DIEN,0)),U,4)
158 .I "PF"[DTYP D
159 ..;Required/Prompt caption
160 ..S DDATA=$G(^PXRMD(801.41,DIEN,2)),DTXT=$P(DDATA,U,4)
161 ..;Default value or forced value
162 ..S:DTYP="P" DDEF=$P(DDATA,U) S:DTYP="F" DDEF=$P(DDATA,U,2)
163 ..;Override caption/start new line/exclude PN from dialog file
164 ..S DDATA=$G(^PXRMD(801.41,IEN,10,DSUB,0)),DREQ=$P(DDATA,U,9)
165 ..S DOVR=$P(DDATA,U,6),DSNL=$P(DDATA,U,7),DEXC=$P(DDATA,U,8)
166 ..S DNAME=DTXT I DOVR]"" S DNAME=DOVR
167 ..;Convert date to fileman format
168 ..I DGUI="VST_DATE",DDEF["T" S DDEF=$$DT^XLFDT()
169 .S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_$G(DFTEXT)_U_$G(PRINT)
170 .;the following section add a comment prompt to the WH review of result
171 .;section of the reminder dialog
172 .I DGUI="WH_PAP_RESULT",DFTYP="WV(790.1,",DTYP="P" D
173 ..N WHCNT,WHFLAG,WHNUM,WHLOOP
174 ..S WHNUM=DSEQ+1,WHLOOP=0
175 ..F WHLOOP=0 D
176 ...S (WHCNT,WHFLAG)=0
177 ...F S WHCNT=$O(^PXRMD(801.41,IEN,10,"B",WHCNT)) Q:'WHCNT!(WHFLAG=1) D
178 ....I WHCNT=WHNUM S WHFLAG=1,WHNUM=WHNUM+1
179 ...I WHFLAG=0 S WHLOOP=1
180 ..S ARRAY(WHNUM)="COM"_U_U_U_"P"_U_"Comment:"_U_U_U
181 .;Additional checkboxes
182 .I DGUI="COM",DIEN>1 D
183 ..N DSSEQ,DSUB,DTEXT
184 ..S DSSEQ=0
185 ..F S DSSEQ=$O(^PXRMD(801.41,DIEN,45,"B",DSSEQ)) Q:'DSSEQ D
186 ...S DSUB=$O(^PXRMD(801.41,DIEN,45,"B",DSSEQ,"")) Q:'DSUB
187 ...S DTEXT=$P($G(^PXRMD(801.41,DIEN,45,DSUB,0)),U,2) Q:DTEXT=""
188 ...S ARRAY(DSEQ,DSSEQ)=U_DEXC_U_DDEF_U_DTYP_U_DTEXT_U_DSNL_U_DREQ
189 Q
190 ;
191PRTAX(FNODE,RSUB) ;Get all additional fields for this resolution type
192 N ACNT,ASUB
193 N DDATA,DDEF,DEXC,DGUI,DNAME,DREQ,DSEQ,DSUB,DTYP,PRINT
194 S ASUB=0,DSEQ=0
195 F S ASUB=$O(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB)) Q:'ASUB D
196 .S DDATA=$G(^PXRMD(801.45,FNODE,1,RSUB,5,ASUB,0)) Q:DDATA=""
197 .;Ignore if disabled
198 .I $P(DDATA,U,3)=1 Q
199 .S DSUB=$P(DDATA,U) Q:DDATA=""
200 .S DSEQ=DSEQ+1
201 .;Set defaults to null
202 .S DDEF="",DEXC="",DREQ="",DSNL=""
203 .;Prompt name and GUI process (quit if null)
204 .S DNAME=$P($G(^PXRMD(801.41,DSUB,0)),U),DGUI=$$GUI(DSUB)
205 .I $G(DGUI)="WH_NOT_PURP" D
206 ..S PRINT=$$GET^XPAR($G(DUZ)_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS","PXRM WH PRINT NOW",1,"I")
207 .;Type Prompt or Forced
208 .S DTYP=$P($G(^PXRMD(801.41,DSUB,0)),U,4)
209 .I DTYP="P" D
210 ..S DREQ=$P(DDATA,U,2),DTXT=$P($G(^PXRMD(801.41,DSUB,2)),U,4)
211 ..;Override caption/start new line/exclude from PN from finding type
212 ..S DOVR=$P(DDATA,U,5),DSNL=$P(DDATA,U,6),DEXC=$P(DDATA,U,7)
213 ..S DNAME=DTXT I DOVR]"" S DNAME=DOVR
214 ..;Required/Prompt caption
215 ..S DDATA=$G(^PXRMD(801.41,DSUB,2))
216 .S ARRAY(DSEQ)=DGUI_U_DEXC_U_DDEF_U_DTYP_U_DNAME_U_DSNL_U_DREQ_U_U_$G(PRINT)
217 Q
218 ;
219PTXT(ITEM) ;Get progress note (WP) text for type 6 records
220 N ARRAY,LAST,NULL,SUB,TEXT,TXTCNT
221 S SUB=0
222 F S SUB=$O(^PXRMD(801.41,ITEM,35,SUB)) Q:'SUB D
223 .S ARRAY(SUB)=$G(^PXRMD(801.41,ITEM,35,SUB,0))
224 S SUB=0,LAST=0 F S SUB=$O(ARRAY(SUB)) Q:'SUB D
225 .S TEXT=$G(ARRAY(SUB))
226 .S NULL=0 I (TEXT="")!($E(TEXT)=" ") S NULL=1
227 .I LAST,'NULL S TEXT="<br>"_TEXT
228 .S TEXT=$$STRREP^PXRMUTIL(TEXT,"\\","<br>")
229 .S LAST=0 I NULL S TEXT="<br>"_TEXT,LAST=1
230 .S OCNT=OCNT+1,ORY(OCNT)=6_U_ITEM_U_U_TEXT
231 Q
232 ;
233TOK(TIEN,TYPE) ;Check if selectable codes exist
234 N DATA,FOUND,SUB
235 S FOUND=0,SUB=0
236 F S SUB=$O(^PXD(811.2,TIEN,TYPE,SUB)) Q:'SUB D Q:FOUND
237 .S DATA=$G(^PXD(811.2,TIEN,TYPE,SUB,0)) Q:DATA=""
238 .;Ignore disabled codes
239 .I '$P(DATA,U,3) S FOUND=1
240 Q FOUND
Note: See TracBrowser for help on using the repository browser.