source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LREPIRP.m@ 1354

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1LREPIRP ;DALOI/CKA-EMERGING PATHOGENS VERIFICATION REPORT ;9/30/03
2 ;;5.2;LAB SERVICE;**132,157,175,260,281,320**;Sep 27, 1994
3 ; Reference to ^ORD(101 supported by IA #872
4 Q
5REPORT ;
6 D NOW^%DTC S LRDATE=%
7 S LRSP=" "
8 S (LRPV1CNT,LRDG1CNT,LROBRCNT,LROBXCNT,LRNTECNT,LRDSPCNT,LRZXECNT,LRTOTCNT)=0
9 S MSGCNT=1,HLFS=HL("FS")
10 ;SORT DATA FOR REPORT
11RPT S LRI=0
12 F S LRI=$O(^TMP("LREPIREP",$J,LRI)) Q:'LRI S LRTMP=^(LRI),SEG=$P(LRTMP,HLFS,1) I $L($T(@SEG)) D
13PID .;PATIENT INFO
14 .I SEG="PID" D
15 ..S DFN=$P($P(LRTMP,HLFS,4),"~")
16 ..S ^TMP($J,"TMP",DFN,"PID")=LRTMP
17PV1 .;PATIENT VISIT ENCOUNTER
18 .I SEG="PV1" D
19 ..S (LRDG1CNT,LROBRCNT,LROBXCNT,LRNTECNT,LRDSPCNT,LRZXECNT)=0
20 ..S LRPV1CNT=LRPV1CNT+1
21 ..S ^TMP($J,"TMP",DFN,"PID","PV1",LRPV1CNT)=LRTMP
22DG1 .;DIAGNOSES
23 .I SEG="DG1" D
24 ..S LRDG1CNT=LRDG1CNT+1
25 ..S ^TMP($J,"TMP",DFN,"PID","PV1",LRPV1CNT,"DG1",LRDG1CNT)=LRTMP
26OBR .;OBSERVATION REPORTING
27 .I SEG="OBR" D
28 ..S LROBXCNT=0
29 ..S LROBRCNT=LROBRCNT+1
30 ..S ^TMP($J,"TMP",DFN,"PID","PV1",LRPV1CNT,"NTE",LRNTECNT,"OBR",LROBRCNT)=LRTMP
31OBX .;RESULTS
32 .I SEG="OBX" D
33 ..S LROBXCNT=LROBXCNT+1
34 ..S ^TMP($J,"TMP",DFN,"PID","PV1",LRPV1CNT,"NTE",LRNTECNT,"OBR",LROBRCNT,"OBX",LROBXCNT)=LRTMP
35 .I SEG="NTE",$D(DFN),$P($P(LRTMP,HLFS,3),LRCS,1)>0 D
36 ..S LROBRCNT=0
37 ..S LRNTECNT=LRNTECNT+1
38 ..S ^TMP($J,"TMP",DFN,"PID","PV1",LRPV1CNT,"NTE",LRNTECNT)=LRTMP
39ZXE .;ZXE
40 .I SEG="ZXE" D
41 ..S LRZXECNT=LRZXECNT+1
42 ..S ^TMP($J,"TMP",DFN,"PID","PV1",LRPV1CNT,"ZXE",LRZXECNT)=LRTMP
43DSP .;DSP
44 .I SEG="DSP" D
45 ..S LRDSPCNT=LRDSPCNT+1
46 ..S ^TMP($J,"TMP",DFN,"PID","PV1",LRPV1CNT,"DSP",LRDSPCNT)=LRTMP
47TOTALS .;SAVE TOTALS IN NTE
48 .I SEG="NTE"&($P($P(LRTMP,HLFS,3),LRCS)="T") S LRDONE=0 D
49 ..F LRNUM=1:1:7 I $P($P($P(LRTMP,HLFS,3),LRCS,3),"-")=LRNUM D
50 ...S ^XTMP("LREPIREP"_LRDATE,"HEPTOT",LRNUM)=$P($P(LRTMP,HLFS,3),LRCS,4)
51 ...S LRDONE=1
52 ..Q:LRDONE
53 ..S LRTOTCNT=LRTOTCNT+1
54 ..S ^XTMP("LREPIREP"_LRDATE,"TOTAL1",LRTOTCNT)=LRTMP
55 K LRDONE
56RESORT ;SAVE DATA BY NTE IN ^XTMP
57 S X1=DT,X2=180,LRUPDNUM=0 D C^%DTC
58 S ^XTMP("LREPIREP"_LRDATE,0)=X_"^"_DT_"^EPI Verification Report^"_$S($D(DUZ):DUZ,1:"UNKNOWN")
59 S DFN=0,LRCNT=1,LRZXECNT=1,LRDSPCNT=1
60 F S DFN=$O(^TMP($J,"TMP",DFN)) Q:'DFN D
61 .S LRPV1=0,LRDSP=0,LRZXE=0
62 .F S LRPV1=$O(^TMP($J,"TMP",DFN,"PID","PV1",LRPV1)) Q:'LRPV1 S LRPV1N=^(LRPV1) D
63 ..S LRTMP=^TMP($J,"TMP",DFN,"PID")
64 ..S LRNAME=$P(LRTMP,HLFS,6),SSN=$E($P(LRTMP,HLFS,20),6,9),LRADMDT=$$CDT^LREPIRP2($P(LRPV1N,HLFS,45)),LRDISDT=$$CDT^LREPIRP2($P(LRPV1N,HLFS,46))
65 ..S TYPE=$P(LRPV1N,HLFS,3),TYPE=$S(TYPE="U":"U",TYPE="I":"Inpatient",1:"Outpatient")
66 ..I TYPE="U" D
67 ...S ^XTMP("LREPIREP"_LRDATE,"UPDATES",LRUPDNUM)=LRNAME_$E(LRSP,1,25-$L(LRNAME))_SSN_" "_LRADMDT_$E(LRSP,1,18-$L(LRADMDT))_LRDISDT
68 ...S LRUPDNUM=LRUPDNUM+1
69 ..F S LRDSP=$O(^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"DSP",LRDSP)) Q:'LRDSP S LRDSPN=^(LRDSP) D S LRDSPCNT=1
70 ...S ^XTMP("LREPIREP"_LRDATE,"DSP",$P($P(LRDSPN,HLFS,4),LRCS,2),DFN,LRDSPCNT)=SSN_" "_LRNAME_$E(LRSP,1,25-$L(LRNAME))_TYPE_" "_$$CDT^LREPIRP2($P($P(LRDSPN,HLFS,4),LRCS))
71 ...S LRDSPCNT=LRDSPCNT+1
72 ..F S LRZXE=$O(^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"ZXE",LRZXE)) Q:'LRZXE S LRZXEN=^(LRZXE) D S LRZXECNT=LRZXECNT+1
73 ...S ^XTMP("LREPIREP"_LRDATE,"ZXE",$P($P(LRZXEN,HLFS,3),LRCS),DFN,LRZXECNT)=SSN_" "_LRNAME_$E(LRSP,1,25-$L(LRNAME))_TYPE_" "_$$CDT^LREPIRP2($P(LRZXEN,HLFS,6))
74 ...S LRZXECNT=LRZXECNT+1
75 ..S LRNTE=0
76 ..F S LRNTE=$O(^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"NTE",LRNTE)) Q:'LRNTE D
77 ...S LRTYPE=$P($P(^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"NTE",LRNTE),HLFS,3),LRCS,1)
78 ...F LRNUM1=1,3,4,5,6,8,10,18,19,20,21,22,23 D:LRTYPE=LRNUM1
79 ....S LRTMP=^TMP($J,"TMP",DFN,"PID")
80 ....D PID^LREPIRP2
81 ....S LRTMP=^TMP($J,"TMP",DFN,"PID","PV1",LRPV1)
82 ....D PV1^LREPIRP2
83 ....S LROBR=0
84 ....F S LROBR=$O(^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"NTE",LRNTE,"OBR",LROBR)) Q:'LROBR D
85 .....S LRTMP=^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"NTE",LRNTE,"OBR",LROBR)
86 .....D OBR^LREPIRP2
87 .....S LROBX=0
88 .....F S LROBX=$O(^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"NTE",LRNTE,"OBR",LROBR,"OBX",LROBX)) Q:'LROBX D
89 ......S LRTMP=^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"NTE",LRNTE,"OBR",LROBR,"OBX",LROBX)
90 ......D OBX^LREPIRP2
91 ...F LRNUM1=11,12,13,14 D:LRTYPE=LRNUM1
92 ....S LRTMP=^TMP($J,"TMP",DFN,"PID")
93 ....D PID^LREPIRP2
94 ....S LRTMP=^TMP($J,"TMP",DFN,"PID","PV1",LRPV1)
95 ....D PV1^LREPIRP2
96 ....S LRDG1=0
97 ....F S LRDG1=$O(^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"NTE",LRNTE,"DG1",LRDG1)) Q:'LRDG1 D
98 .....S LRTMP=^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"NTE",LRNTE,"DG1",LRDG1)
99 .....D DG1^LREPIRP3
100 ...F LRNUM1=7,9 D:LRTYPE=LRNUM1
101 ....S LRTMP=^TMP($J,"TMP",DFN,"PID")
102 ....D PID^LREPIRP2
103 ....S LRTMP=^TMP($J,"TMP",DFN,"PID","PV1",LRPV1)
104 ....D PV1^LREPIRP2
105 ....S LRDG1=0
106 ....F S LRDG1=$O(^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"NTE",LRNTE,"DG1",LRDG1)) Q:'LRDG1 D
107 .....S LRTMP=^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"NTE",LRNTE,"DG1",LRDG1)
108 .....D DG1^LREPIRP3
109 ....S LROBR=0
110 ....F S LROBR=$O(^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"NTE",LRNTE,"OBR",LROBR)) Q:'LROBR D
111 .....S LRTMP=^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"NTE",LRNTE,"OBR",LROBR)
112 .....D OBR^LREPIRP2
113 .....S LROBX=0
114 .....F S LROBX=$O(^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"NTE",LRNTE,"OBR",LROBR,"OBX",LROBX)) Q:'LROBX D
115 ......S LRTMP=^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"NTE",LRNTE,"OBR",LROBR,"OBX",LROBX)
116 ......D OBX^LREPIRP2
117 ...F LRNUM1=2,15,16,17 D:LRTYPE=LRNUM1
118 ....S LROBR=0
119 ....F S LROBR=$O(^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"NTE",LRNTE,"OBR",LROBR)) Q:'LROBR D
120 .....S LRTMP=^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"NTE",LRNTE,"OBR",LROBR)
121 .....S LRACCDT=$$CDT($P(LRTMP,HLFS,8))
122 .....S LROBX=0
123 .....F S LROBX=$O(^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"NTE",LRNTE,"OBR",LROBR,"OBX",LROBX)) Q:'LROBX D
124 ......S LRTMP=^TMP($J,"TMP",DFN,"PID","PV1",LRPV1,"NTE",LRNTE,"OBR",LROBR,"OBX",LROBX)
125 ......D OBX^LREPIRP4 S LRACCDT=""
126 D HDG^LREPIRP3,HDGS^LREPIRP6
127CALTOT ;CALCULATE TOTALS
128 ;SAVE IN ^XTMP("LREPIREP"_LRDATE,"TOTAL",LRPATH)=# of Occurrences^# of persons with occurrences
129 S (LRPATH,LRDFN,LRPV1,LROBR,LRPATHCT,LRPERCNT)=0
130 F LRPATH=1,3:1:14,18:1:23 D S ^XTMP("LREPIREP"_LRDATE,"TOTAL",LRPATH)=LRPATHCT_U_LRPERCNT,LRPATHCT=0,LRPERCNT=0,LRDFN=0
131 .F S LRDFN=$O(^TMP($J,"TMP",LRDFN)) Q:LRDFN="" D
132 ..S LRPV1=0,LRPV1NUM=1
133 ..F S LRPV1=$O(^TMP($J,"TMP",LRDFN,"PID","PV1",LRPV1)) Q:LRPV1="" D
134 ...S LRNTE=0
135 ...F S LRNTE=$O(^TMP($J,"TMP",LRDFN,"PID","PV1",LRPV1,"NTE",LRNTE)) Q:LRNTE="" D
136 ....S LRTYPE=$P($P(^TMP($J,"TMP",LRDFN,"PID","PV1",LRPV1,"NTE",LRNTE),HLFS,3),LRCS,1)
137 ....Q:LRTYPE'=LRPATH
138 ....I LRPV1NUM=1 S LRPERCNT=LRPERCNT+1
139 ....S LRPATHCT=LRPATHCT+1
140 ....S LRPV1NUM=LRPV1NUM+1
141 S (LRPATH,LRDFN,LRPATHCT,LRPERCNT)=0
142 F LRPATH=2,15,16,17 D S ^XTMP("LREPIREP"_LRDATE,"TOTAL",LRPATH)=LRPATHCT_U_LRPERCNT,LRPATHCT=0,LRPERCNT=0,LRDFN=0
143 .F S LRDFN=$O(^XTMP("LREPIREP"_LRDATE,LRPATH,LRDFN)) Q:LRDFN="HDG"!(LRDFN="") D
144 ..S LRPERCNT=LRPERCNT+1,LRCNT=0
145 ..F S LRCNT=$O(^XTMP("LREPIREP"_LRDATE,LRPATH,LRDFN,LRCNT)) Q:LRCNT="" D
146 ...S LRPATHCT=LRPATHCT+1
147 S ^XTMP("LREPIREP"_LRDATE,"DONE")=1
148MMMSG I $D(LRPREV) D
149 .S MSG="This report represents a second pass at aquiring data for the EPI from"
150 .S ^TMP($J,"MSG",MSGCNT)=MSG,MSGCNT=MSGCNT+1,MSG=""
151 .S MSG="the prior month on Mycobacterium tuberculosis due to the extended"
152 .S ^TMP($J,"MSG",MSGCNT)=MSG,MSGCNT=MSGCNT+1,MSG=""
153 .S MSG="period of time that may be expected with accessioning, growth, and"
154 .S ^TMP($J,"MSG",MSGCNT)=MSG,MSGCNT=MSGCNT+1,MSG=""
155 .S MSG="finally reporting of results. Since this is designed to aquire only"
156 .S ^TMP($J,"MSG",MSGCNT)=MSG,MSGCNT=MSGCNT+1,MSG=""
157 .S MSG="the remaining Mycobacterium tuberculosis data from the prior month,"
158 .S ^TMP($J,"MSG",MSGCNT)=MSG,MSGCNT=MSGCNT+1,MSG=""
159 .S MSG="most of the numbers present for this report will be zero. The"
160 .S ^TMP($J,"MSG",MSGCNT)=MSG,MSGCNT=MSGCNT+1,MSG=""
161 .S MSG="accompanying Summary Verification Report for the current month should"
162 .S ^TMP($J,"MSG",MSGCNT)=MSG,MSGCNT=MSGCNT+1,MSG=""
163 .S MSG="contain more complete number counts on the other EPI pathogens and"
164 .S ^TMP($J,"MSG",MSGCNT)=MSG,MSGCNT=MSGCNT+1,MSG=""
165 .S MSG="data items for this current month."
166 .S ^TMP($J,"MSG",MSGCNT)=MSG,MSGCNT=MSGCNT+1,MSG=""
167 D MSH
168 S LRPROT=0,LRPROT=$O(^ORD(101,"B","LREPI",LRPROT))
169 S LRMGP=$P($G(^LAB(69.4,LRPROT,0)),U,2)
170 I +LRMGP'>0 W !,"NO MAILGROUP TO SEND MESSAGE!" G EXIT
171 S LRMGPN=$$GET1^DIQ(69.4,LRPROT,1)
172 S XMSUB="EPI Summary Verification Report"
173 I $D(LRPREV) S XMSUB=XMSUB_" for prior month -TB only"
174 S XMDUZ="POSTMASTER"
175 S XMY("G."_LRMGPN)="" ;$P(^XMB(3.8,LRMGP,0),U,1))=""
176 S XMTEXT="^TMP("_$J_",""MSG"","
177 D ^XMD
178 K LRMGP,LRMGPN
179 K ISITE
180EXIT K LRACCDT,LRDSPN,LRSP,LRPREV,LRZXEN,XMDUZ,XMSUB,XMTEXT,XMY Q
181MSH ;
182 D SUMHD1^LREPIRP1
183 D SUMMARY^LREPIRP5
184 D NOTE1^LREPIRP1
185 D SUMHD3^LREPIRP1
186 D PRTHEP^LREPIRP5
187 D NOTE2^LREPIRP1
188 D PRTTOT^LREPIRP5
189 D NOTE3^LREPIRP1
190 Q
191NTE ;NOTE AND COMMENTS
192 ;D NTE^LREPIRP4
193 S TYPE=$P($P(LRHL7,HLFS,3),LRCS,1),MSG=""
194 I TYPE="T" D
195 .S MSG="TOTAL "_$P($P(LRHL7,HLFS,3),LRCS,2)_" "
196 .S MSG=MSG_$P($P(LRHL7,HLFS,3),LRCS,3)_" "_$P($P(LRHL7,HLFS,3),LRCS,4)
197 I +TYPE>0 D
198 .;S:$G(^TMP($J,"MSG",(MSGCNT-1)))'="" ^TMP($J,"MSG",MSGCNT)="",MSGCNT=MSGCNT+1
199 .S MSG="********* "_TYPE_" "_$P($P(LRHL7,HLFS,3),LRCS,2)_" *********"
200 K TYPE
201 Q
202CDT(DATE) ;CONVERTS THE DATE AND TIME
203 S X=$E(DATE,5,6)_"-"_$E(DATE,7,8)_"-"_$E(DATE,1,4)
204 S:$E(DATE,9,12)'="" X=X_"@"_$E(DATE,9,12)
205 S:X="--" X=""
206 Q X
207PROCESS ;THIS IS THE HL7 PROCESSING ROUTINE ENTRY POINT TO PREVENT HL7 ERRORS
208 Q
Note: See TracBrowser for help on using the repository browser.