source: FOIAVistA/trunk/r/CLINICAL_PROCEDURES-MD/MDPS1.m@ 1607

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

initial load of FOIAVistA 6/30/08 version
File size: 9.5 KB
Line 
1MDPS1 ; HOIFO/NCA - CP/Medicine Report Generator ;5/18/04 09:48
2 ;;1.0;CLINICAL PROCEDURES;**2,10,13**;Apr 01, 2004;Build 19
3 ; Integration Agreements:
4 ; IA# 2693 [Subscription] TIU Extractions.
5 ; IA# 2926 [Subscription] Calls to GMRCGUIA.
6 ; IA# 2944 [Subscription] Calls to TIUSRVR1.
7 ; IA# 3067 [Private] Read fields in Consult file (#123) w/FM
8 ; IA# 4110 [Subscription] Read access field #50 Associated Results in
9 ; Consult file (#123) w/FM
10 ; IA# 4230 [Subscription] Document MDPS1 calls.
11 ; IA# 4231 [Subscription] Document CKP^GMTSUP usage.
12 ; IA# 4792 [Private] CANDO^TIUSRVA call
13 ; IA# 10104 [Supported] Routine XLFSTR calls
14 ;
15 ; Pre-existing local variables
16 ; DFN,GMTS1,GMTS2,GMTSNDM,GMTSNPG,GMTSQIT
17 ;
18EN1(MDGLO,MDDFN,MDSDT,MDEDT,MDMAX,MDPSC,MDALL) ; Return the List of Completed Studies
19 ; Input: MDGLO - Return Global Array (Required)
20 ; MDDFN - Patient DFN (Required)
21 ; MDSDT - Start Date in FM Internal Format (Optional)
22 ; MDEDT - End Date in FM Internal Format (Optional)
23 ; MDMAX - Number of studies to return (Optional)
24 ; MDPSC - Procedure Summary Code (Optional)
25 ; MDALL - Return the all text reports with
26 ; the procedures list (Optional)
27 ; (Returns all studies for Patient, if no MDSDT, MDEDT,and MDMAX.)
28 ;
29 I '$G(MDDFN)!('$D(MDGLO)) Q
30 I $G(MDGLO)="" S MDGLO=$NA(^TMP("MDHSP",$J))
31 N MDARR,MDCODE,MDCON,MDCTR,MDDTE,MDLP,MDLP1,MDPLST,MDPROC,MDSTAT,MDT,MDTIUER,MDX,Y
32 S (MDIMG,MDCTR)=0,(MDCODE,MDDTE,MDTIUER)="",MDC=$G(MDPSC)
33 K ^TMP("MDPLST",$J) S MDPLST=$NA(^TMP("MDPLST",$J))
34 ;
35 ; If not converted call old medicine gather routine
36 D:$G(MDC)="" GP^MDPS4(MDDFN,MDSDT,MDEDT)
37 I '$G(MDSDT),'$G(MDEDT) D EN^MDARP3(MDDFN,MDC)
38 E D EN^MCARPS3(MDDFN,MDC,MDSDT,MDEDT)
39 ;
40 ; Get CP procedures
41 D GET702(.MDGLO,MDDFN,MDC,MDSDT,MDEDT,$S(+$G(MDMAX):MDMAX,1:999))
42 K ^TMP("MDPLST",$J)
43 Q
44 ;
45GET702(MDGLO,MDDFN,MDC,MDSDT,MDEDT,MDMAX) ; Gather the new 702 entries
46 S MDLP="" F S MDLP=$O(^MDD(702,"B",MDDFN,MDLP)) Q:MDLP<1 D
47 .S MDX=$G(^MDD(702,MDLP,0)) Q:$P(MDX,"^",9)'=3
48 .S MDPROC=$$GET1^DIQ(702,MDLP_",",.04,"E") Q:MDPROC=""
49 .Q:'$P(MDX,U,6)
50 .K ^TMP("MDTIUST",$J) S MDTIUER=""
51 .D EXTRACT^TIULQ($P(MDX,U,6),"^TMP(""MDTIUST"",$J)",MDTIUER,".01;.05;70201;70202") Q:+MDTIUER
52 .S MDCODE=$G(^TMP("MDTIUST",$J,$P(MDX,U,6),70201,"E"))
53 .S:MDCODE'="" MDCODE=$$UP^XLFSTR(MDCODE)
54 .I $G(MDC)'="" Q:MDCODE'=$G(MDC)
55 .S MDDTE=$G(^TMP("MDTIUST",$J,$P(MDX,U,6),70202,"I"))
56 .S MDSTAT=$G(^TMP("MDTIUST",$J,$P(MDX,U,6),.05,"E"))
57 .S:'MDDTE MDDTE=$$GET1^DIQ(702,MDLP_",",.02,"I")
58 .K ^TMP("MDTIUST",$J)
59 .S MDCON=$P(MDX,U,5)
60 .I +$G(MDSDT) Q:MDDTE<+$G(MDSDT)
61 .I +$G(MDEDT) Q:MDDTE>+$G(MDEDT)
62 .I MDCON D Q:MDSTAT'="COMPLETE"&(MDSTAT'="PARTIAL RESULTS")
63 ..S MDSTAT=$$GET1^DIQ(123,MDCON_",",8,"E")
64 ..I MDSTAT="" S MDSTAT=$$GET1^DIQ(123,MDCON_",",8,"I") S:+MDSTAT MDSTAT=$$GET1^DIQ(100.01,MDSTAT_",",.01,"E")
65 ..Q
66 .S Y=MDDTE X ^DD("DD")
67 .I MDCON Q:$G(MDARR(MDCON))'="" S MDARR(MDCON)=MDCON
68 .S:$G(^TMP("MDPLST",$J,(9999999.9999-MDDTE),MDPROC_"~"_MDLP))="" ^(MDPROC_"~"_MDLP)=MDPROC_"^"_MDLP_"^"_"PR702"_"^"_"MDPS1"_"^^"_Y_"^"_MDCODE_"^^^^"_MDPROC_"^^"_MDCON_"^"_+$P(MDX,U,6)
69 .Q
70 S MDCTR=0
71 S MDLP="" F S MDLP=$O(^TMP("MDPLST",$J,MDLP)) Q:MDLP="" S MDLP1="" F S MDLP1=$O(^TMP("MDPLST",$J,MDLP,MDLP1)) Q:MDLP1="" S MDX=$G(^(MDLP1)) D
72 .I +$G(MDMAX) Q:MDCTR=MDMAX
73 .S MDCTR=MDCTR+1,@MDGLO@(MDCTR)=$G(MDX)
74 K MDARR
75 I +$G(MDALL) K ^TMP("MDPTXT",$J) S MDLP=0 F S MDLP=$O(@MDGLO@(MDLP)) Q:MDLP<1 S MDX1=$G(@MDGLO@(MDLP)) D
76 .S MCARGDA=+$P(MDX1,U,2),MCPRO=$P(MDX1,U,11),MCARPPS=$P(MDX1,U,3,4)
77 .S MCARGRTN=$P(MDX1,U,5),MDT="RD"
78 .D @MCARPPS
79 K MCARGDA,MCARGRTN,MCPRO,MCARPPS
80 Q
81CPA ; Abnormal Report - Health Summary Component
82 N MDHR,MDHSG,MDHDR,MDHFLG,MDLIM,MDTS1,MDTS2,MDX1
83 Q:'$G(DFN) Q:'$G(GMTS1) Q:'$G(GMTS2)
84 K ^TMP("MDHSP",$J) S MDHFLG=1
85 S MDHSG=$NA(^TMP("MDHSP",$J)) D SET^MDPS2
86 D EN1(.MDHSG,DFN,MDTS1,MDTS2,MDLIM,"ABNORMAL")
87 I '$D(^TMP("MDHSP",$J)) D CKP^GMTSUP Q:$D(GMTSQIT) W !,"No Procedure Data for the patient." Q
88 S MDHR=0 F S MDHR=$O(^TMP("MDHSP",$J,MDHR)) Q:MDHR<1 S MDX1=$G(^(MDHR)) D
89 .D HSHDR^MDPS2
90 .S MCARGDA=+$P(MDX1,U,2),MCARPPS=$P(MDX1,U,3,4),MCPRO=$P(MDX1,U,11)
91 .S MCARGRTN=$P(MDX1,U,5),MDT="RD",MDHDR=1
92 .D @MCARPPS Q
93 K ^TMP("MDHSP",$J),MCARGRTN,MCPRO,MCARPPS
94 Q
95CPB ; Brief Report - Health Summary Component
96 N MDHR,MDHSG,MDLIM,MDTS1,MDTS2,MDX1
97 Q:'$G(DFN) Q:'$G(GMTS1) Q:'$G(GMTS2)
98 K ^TMP("MDHSP",$J)
99 S MDHSG=$NA(^TMP("MDHSP",$J)) D SET^MDPS2
100 D EN1(.MDHSG,DFN,MDTS1,MDTS2,MDLIM)
101 I '$D(^TMP("MDHSP",$J)) D CKP^GMTSUP Q:$D(GMTSQIT) W !,"No Procedure Data for the patient." Q
102 D HDR^MDPS2
103 S MDHR=0 F S MDHR=$O(^TMP("MDHSP",$J,MDHR)) Q:MDHR<1 S MDX1=$G(^(MDHR)) D
104 .D CKP^GMTSUP Q:$D(GMTSQIT)
105 .W !,$S(+$P(MDX1,U,13):$J($P(MDX1,U,13),9),1:""),?12,$E($P(MDX1,U,1),1,30),?44,$P(MDX1,U,6),?67,$P(MDX1,U,7)
106 .Q
107 K ^TMP("MDHSP",$J)
108 Q
109CPC ; Full Caption Report - Health Summary Component
110 S MDT1="CD"
111CPF ; Full Report - Health Summary Component
112 N MDHR,MDHSG,MDHDR,MDHFLG,MDLIM,MDT,MDTS1,MDTS2,MDX1
113 Q:'$G(DFN) Q:'$G(GMTS1) Q:'$G(GMTS2)
114 K ^TMP("MDHSP",$J) S MDHFLG=1
115 S MDHSG=$NA(^TMP("MDHSP",$J)) D SET^MDPS2
116 D EN1(.MDHSG,DFN,MDTS1,MDTS2,MDLIM)
117 I '$D(^TMP("MDHSP",$J)) D CKP^GMTSUP Q:$D(GMTSQIT) W !,"No Procedure Data for the patient." Q
118 S MDHR=0 F S MDHR=$O(^TMP("MDHSP",$J,MDHR)) Q:MDHR<1 S MDX1=$G(^(MDHR)) D
119 .D HSHDR^MDPS2
120 .S MCARGDA=+$P(MDX1,U,2),MCPRO=$P(MDX1,U,11),MCARPPS=$P(MDX1,U,3,4)
121 .S MCARGRTN=$P(MDX1,U,5),MDT=$S($G(MDT1)="":"RD",1:"CD"),MDHDR=1
122 .D @MCARPPS Q
123 K ^TMP("MDHSP",$J),MCARGDA,MCARGRTN,MCPRO,MCARPPS,MDT1
124 Q
125CPS ; One Line Summary Report
126 N MDHR,MDHSG,MDLIM,MDTS1,MDTS2,MDX1
127 Q:'$G(DFN) Q:'$G(GMTS1) Q:'$G(GMTS2)
128 K ^TMP("MDHSP",$J)
129 S MDHSG=$NA(^TMP("MDHSP",$J)) D SET^MDPS2
130 D EN1(.MDHSG,DFN,MDTS1,MDTS2,MDLIM)
131 I '$D(^TMP("MDHSP",$J)) D CKP^GMTSUP Q:$D(GMTSQIT) W !,"No Procedure Data for the patient." Q
132 S MDHR=0 F S MDHR=$O(^TMP("MDHSP",$J,MDHR)) Q:MDHR<1 S MDX1=$G(^(MDHR)) D
133 .D HSHDR^MDPS2
134 K ^TMP("MDHSP",$J)
135 Q
136PR702 ; Return the Result Text for File 702 records
137 Q:'$G(MCARGDA)
138 N FFF,MDCLIN,MDCON,MDIMG,MDMCG,MDMED,MDREC,MDPRILV,MDPTR,MDSTUDY,MDTIU,MDX4,PATID,MDRPG,RESULTS
139 I '$G(MDALL) K ^TMP("MDPTXT",$J)
140 S MDIMG=0,$P(FFF,"-",80)="",MDRPG=0
141 S MDSTUDY=+$G(MCARGDA)
142 S MDTIU=$$GET1^DIQ(702,MDSTUDY_",",.06,"I")
143 S MDCON=$$GET1^DIQ(702,MDSTUDY_",",.05,"I")
144 Q:'MDTIU
145 I +$P($G(^MDD(702,MDSTUDY,.1,0)),U,4)>0 S MDIMG=1
146 S (MDPRILV,RESULTS)="",MDCLIN=0
147 D CANDO^TIUSRVA(.MDPRILV,+MDTIU,"VIEW")
148 I +MDPRILV<1 S ^TMP("MDPTXT",$J,MCARGDA,MCPRO,1)=$P(MDPRILV,U,2) D NXT Q
149 I 'MDCON D TGET^TIUSRVR1(.RESULTS,+MDTIU) M ^TMP("MDPTXT",$J,MCARGDA,MCPRO)=@RESULTS K ^TMP("TIUVIEW",$J) Q:+$G(MDALL) D NXT Q
150 I MDCON D Q:+$G(MDMED)
151 .S MDG=$NA(^TMP("MDPTXT",$J,MCARGDA,MCPRO))
152 .S MDMED=$$CHKMED^MDPS3(MDCON)
153 .I MDMED D GETARY(.MDG,MDCON) Q:+$G(MDALL) Q:+$G(MDRDV) D NXT Q
154 .K ^TMP("MDGMRC",$J) S RESULTS=$NA(^TMP("MDGMRC",$J))
155 .D RT^GMRCGUIA(MDCON,.RESULTS)
156 .D SETLINE(.MDG,.RESULTS)
157NXT Q:+$G(MDALL) Q:+$G(MDRDV)
158 I $D(ORHFS) U IO G PRINT
159 G PRINT
160PR690 ; Return the Result text for File 690 Medicine report record
161 Q:'$G(MCARGDA)
162 N MDSTUDY,RESULTS,MDTMP,PATID
163 I '$G(MDALL) K ^TMP("MDPTXT",$J)
164 S MDSTUDY=+$G(MCARGDA)
165 S MDG=$NA(^TMP("MDPTXT",$J,MCARGDA,MCPRO))
166 S MDTMP="",MDTMP=+$O(^MCAR(697.2,"B",MCPRO,MDTMP))
167 S MDTMP=$G(^MCAR(697.2,+MDTMP,0)) Q:MDTMP=""
168 S MDF=$P(MDTMP,U,2),MDF=$P(MDF,"(",2),MDR=+MCARGDA,MDPR=MCPRO,PATID=DFN S:$G(MDT)="" MDT="RD"
169 D GETDATA^MDPS2(.MDG,DFN,MDPR,MDF,MDR,MDT,$S(+$G(MDHDR):MDHDR,1:0))
170 Q:+$G(MDALL) Q:+$G(MDRDV)
171 I $D(ORHFS) U IO G PRINT
172PRINT ; Print the text for Display
173 N MDRE S MDREC=$NA(^TMP("MDPTXT",$J)),MDRPG=1,MDRE=+$P(MDREC,",",2)
174 W:'$G(MDHFLG) @IOF,!!
175 F S MDREC=$Q(@MDREC) Q:MDREC="" Q:$QS(MDREC,1)'="MDPTXT" D
176 .Q:$QS(MDREC,2)'=MDRE
177 .I +$G(MDHFLG) D CKP^GMTSUP Q:$D(GMTSQIT)
178 .I '$G(MDHFLG)&($Y>(IOSL-6)!($Y<1)) W @IOF D HDR^MDPS3
179 .W !,$G(@MDREC)
180 .Q
181 I +$G(MDIMG) D
182 .I +$G(MDHFLG) D CKP^GMTSUP Q:$D(GMTSQIT)
183 .W ! I +$G(MDHFLG) D CKP^GMTSUP Q:$D(GMTSQIT)
184 .W !,"NOTE: Images are associated with this procedure."
185 .I +$G(MDHFLG) D CKP^GMTSUP Q:$D(GMTSQIT)
186 .W !," Please use Imaging Display to view the images."
187 .Q
188 K MCPRO,MCARPPS,MCARGRTN,^TMP("MDPTXT",$J)
189 Q
190GETARY(MDG,MDCON) ; Get the Medicine Result
191 N MDCK,MDCX,MDX4,MDGL
192 K ^TMP("MDREST",$J) S MDGL=$NA(^TMP("MDREST",$J))
193 D GETS^DIQ(123,MDCON_",","50*","I","MDCX")
194 S MDCK="" F S MDCK=$O(MDCX(123.03,MDCK)) Q:MDCK<1 S MDX4=$G(MDCX(123.03,MDCK,.01,"I")) D
195 .I MDX4["MCAR" D Q
196 ..S MDR=+MDX4,MDF=+$P(MDX4,"(",2),PATID=DFN S:$G(MDT)="" MDT="RD"
197 ..Q:MDX4="" S MCPRO=$$PRO^MDPS3(MDX4),MDPR=MCPRO
198 ..D GETDATA^MDPS2(.MDGL,DFN,MDPR,MDF,MDR,MDT,$S(+$G(MDHDR):1,1:0))
199 ..D SETLINE(.MDG,.MDGL) K ^TMP("MDREST",$J)
200 ..Q
201 .I MDX4["TIU" D Q
202 ..S RESULTS="" D TGET^TIUSRVR1(.RESULTS,+MDX4)
203 ..D SETLINE(.MDG,.RESULTS) K ^TMP("TIUVIEW",$J)
204 ..S MDCLIN=MDCLIN+1,@MDG@(MDCLIN,0)=FFF
205 ..Q
206 Q
207SETLINE(MDG,MDGL) ; Set Global Lines
208 N MDCK1,MDX3,MDSC,MDNAME,MDTITL,MDDTM
209 D NOW^%DTC S X=% D DTIME^MCARP S MDDTM=$$FMTE^XLFDT(X,2) K %
210 I $G(MCPRO)'="" S MDNAME=$O(^MCAR(697.2,"B",MCPRO,0)) D
211 .I MDNAME S MDTITL=$P($G(^MCAR(697.2,+MDNAME,0)),"^",8)
212 .I $G(MDTITL)="" S MDNAME=$O(^MDS(702.01,"B",MCPRO,0)) S:MDNAME MDTITL=$P($G(^MDS(702.01,+MDNAME,0)),U)
213 S MDCK1=MDGL,MDSC=$QS(MDCK1,1),MDRPG=MDRPG+1
214 I '$G(MDHDR) D
215 .Q:MDSC="MDREST"
216 .S MDCLIN=MDCLIN+1,@MDG@(MDCLIN,0)="Pg. "_MDRPG_$J(" ",25)_$$HOSP^MDPS2(DFN)_$J(" ",25)_MDDTM
217 .I $G(MDTITL)'="" S MDCLIN=MDCLIN+1,@MDG@(MDCLIN,0)=$J(" ",25)_MDTITL
218 .S MDCLIN=MDCLIN+1,@MDG@(MDCLIN,0)=$$DEMO^MDPS2(DFN)
219 .S MDCLIN=MDCLIN+1,@MDG@(MDCLIN,0)=FFF
220 F S MDCK1=$Q(@MDCK1) Q:MDCK1="" Q:$QS(MDCK1,1)'=MDSC Q:$QS(MDGL,2)'=$QS(MDCK1,2) S MDCLIN=MDCLIN+1,@MDG@(MDCLIN,0)=$G(@MDCK1)
221 Q
Note: See TracBrowser for help on using the repository browser.