source: WorldVistAEHR/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORHL17.m@ 1801

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

initial load of WorldVistAEHR

File size: 5.7 KB
Line 
1RORHL17 ;HOIFO/BH,SG - HL7 PROBLEM LIST: OBR,OBX ; 1/23/06 2:22pm
2 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
3 ;
4 ; This routine uses the following IAs:
5 ;
6 ; #2308 Access to PROBLEM file #9000011 (controlled)
7 ; #2644 $$MOD^GMPLUTL3 (controlled)
8 ; #3990 $$CODEC^ICDCODE (supported)
9 ; #4743 GET^GMPLWP (controlled)
10 ;
11 Q
12 ;
13 ;***** SEARCHES FOR Problem List DATA
14 ;
15 ; RORDFN IEN of the patient in the PATIENT file (#2)
16 ;
17 ; .DXDTS Reference to a local variable where the
18 ; data extraction time frames are stored.
19 ;
20 ; Return Values:
21 ; <0 Error code
22 ; 0 Ok
23 ; >0 Non-fatal error(s)
24 ;
25 ;
26EN1(RORDFN,DXDTS) ;
27 N CS,DFN,GMRVSTR,IDX,PROBIEN,RC,RORARR,RORBUF,RORENDT,RORMSG,RORSTDT,RORTMP,TMP
28 S (ERRCNT,RC)=0
29 D ECH^RORHL7(.CS)
30 S RORTMP=$$ALLOC^RORTMP()
31 ;
32 S IDX=0
33 F S IDX=$O(DXDTS(16,IDX)) Q:IDX'>0 D Q:RC<0
34 . S RORSTDT=$P(DXDTS(16,IDX),U),RORENDT=$P(DXDTS(16,IDX),U,2)
35 . ;--- Check to see is any problems have been entered/modified
36 . ;--- during the data extraction time frame
37 . S MDATE=$$MOD^GMPLUTL3(RORDFN)
38 . Q:(MDATE<RORSTDT)!(MDATE'<RORENDT)
39 . ;--- Find newly entered problems or modified problems
40 . S PROBIEN=""
41 . F S PROBIEN=$O(^AUPNPROB("AC",RORDFN,PROBIEN)) Q:'PROBIEN D
42 . . S TMP=$$LOAD(.RORARR,PROBIEN) Q:TMP="S"
43 . . S:TMP>0 ERRCNT=ERRCNT+TMP
44 . . ;---
45 . . S TMP=$$OBR(.RORARR)
46 . . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
47 . . S TMP=$$OBX(.RORARR)
48 . . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
49 ;
50 D FREE^RORTMP(RORTMP)
51 Q $S(RC<0:RC,1:ERRCNT)
52 ;
53 ;***** VALIDATES THE DATE
54CHECK(DATE) ;
55 Q:DATE'>0 ""
56 Q:$E(DATE,1,3)>$E(DT,1,3) ""
57 S:$E(DATE,4,5)="00" $E(DATE,4,5)="01"
58 S:$E(DATE,6,7)="00" $E(DATE,6,7)="01"
59 Q $$FM2HL^RORHL7(DATE)
60 ;
61 ;I $E(DATE,1,2)="20",$E(DATE,3,4)>$E(DT,2,3) Q ""
62 ;
63 ;*****
64LOAD(RORARR,PROBIEN) ;
65 N CNT,ERRCNT,IENS,MDATE,NOTE,REC,REC1,SUB3,SUB5,STAT
66 K RORARR,@RORTMP S ERRCNT=0
67 ;
68 S REC=$G(^AUPNPROB(PROBIEN,0))
69 S REC1=$G(^AUPNPROB(PROBIEN,1))
70 S MDATE=$P(REC,U,3)
71 Q:(MDATE<RORSTDT)!(MDATE'<RORENDT) "S"
72 ;
73 S RORARR("OBR","FACIL")=$P(REC,U,6)
74 S RORARR("OBR","NMBR")=$P(REC,U,7)
75 S RORARR("OBR","COND")=$P(REC1,U,2)
76 S RORARR("OBR","DE")=$$FMTHL7^XLFDT($P(REC,U,8))
77 S RORARR("OBR","DOO")=$$CHECK($P(REC,U,13))
78 S RORARR("OBR","DR")=$$CHECK($P(REC1,U,7))
79 ;
80 S DIAG=$$CODEC^ICDCODE(+$P(REC,U))
81 S:DIAG<0 DIAG=""
82 ;
83 S RORARR("OBR","DIAG")=DIAG
84 S RORARR("OBR","DR")=$$FMTHL7^XLFDT($P(REC1,U,9))
85 S RORARR("OBR","RP")=$P(REC1,U,4)
86 S RORARR("OBR","DLM")=$$FMTHL7^XLFDT(MDATE)
87 S RORARR("OBR","ST")=$P(REC,U,12)
88 ;
89 S RORARR("OBX","PR")=$$GET1^DIQ(9000011,PROBIEN,.05,"E")
90 S RORARR("OBX","PROB")=$$GET1^DIQ(9000011,PROBIEN,1.01,"E")
91 ;
92 I $D(ROREXT("PATCH","GMPL*2*30")) D
93 . D GET^GMPLWP(RORTMP,PROBIEN)
94 E I $D(^AUPNPROB(PROBIEN,11))>1 D
95 . S SUB3=0,CNT=0
96 . F S SUB3=$O(^AUPNPROB(PROBIEN,11,SUB3)) Q:'SUB3 D
97 . . S SUB5=0
98 . . F S SUB5=$O(^AUPNPROB(PROBIEN,11,SUB3,11,SUB5)) Q:'SUB5 D
99 . . . S IENS=SUB5_","_SUB3_","_PROBIEN_","
100 . . . S NOTE=$$GET1^DIQ(9000011.1111,IENS,.03,,,"RORMSG")
101 . . . S CNT=CNT+1,@RORTMP@(CNT)=NOTE
102 ;
103 Q ERRCNT
104 ;
105 ;***** PROBLEM LIST OBR SEGMENT BUILDER
106 ;
107 ; Return Values:
108 ; <0 Error code
109 ; 0 Ok
110 ; >0 Non-fatal error(s)
111 ;
112OBR(RORARR) ;
113 N CLASS,CS,ERRCNT,PRV,RC,RORMSG,RORSEG,TMP,TMP1
114 S (ERRCNT,RC)=0
115 D ECH^RORHL7(.CS)
116 ;
117 ;--- Initialize the segment
118 S RORSEG(0)="OBR"
119 ;
120 ;--- OBR-3 - Filler Order Number
121 S RORSEG(3)=RORARR("OBR","FACIL")_RORARR("OBR","NMBR")
122 ;
123 ;--- OBR-4 - Problem List CPT Code
124 S RORSEG(4)="90125"_CS_"HOSPITAL CARE,NEW, INTERMED."_CS_"C4"
125 ;
126 ;--- OBR-6 - Requested Date/time (Date Entered)
127 S RORSEG(6)=RORARR("OBR","DE")
128 ;
129 ;--- OBR-7 - Observation Date/Time (Date Appeared)
130 S RORSEG(7)=RORARR("OBR","DOO")
131 ;
132 ;--- OBR-8 - Observation End Date/Time (Date Resolved/Inactivated)
133 S RORSEG(8)=RORARR("OBR","DR")
134 ;
135 ;--- OBR-13 - Relevant Clinical Info. (Diagnosis Code)
136 S RORSEG(13)=RORARR("OBR","DIAG")
137 ;
138 ;--- OBR-14 - Specimen Received Date/time (Date Resolved/Inactivated)
139 S RORSEG(14)=RORARR("OBR","DR")
140 ;
141 ;--- OBR-16 - Ordering Provider
142 S PRV=RORARR("OBR","RP")
143 S TMP=$$GET1^DIQ(200,PRV_",",53.5,"E",,"RORMSG")
144 I $G(DIERR) D S ERRCNT=ERRCNT+1
145 . D DBS^RORERR("RORMSG",-99,,RORDFN,200,PRV_",")
146 E S $P(PRV,CS,13)=$$ESCAPE^RORHL7(TMP)
147 S RORSEG(16)=PRV
148 ;
149 ;--- OBR-20 - Filler Field 1 (Condition of the Record)
150 S RORSEG(20)=RORARR("OBR","COND")
151 ;
152 ;--- OBR-22 - Results Rpt/Status Change Date/time (Last Modified)
153 S RORSEG(22)=RORARR("OBR","DLM")
154 ;
155 ;--- OBR-24 - Diagnostic Service ID
156 S RORSEG(24)="TX"
157 ;
158 ;--- OBR-25 - Result Status (Status of the Problem)
159 S TMP1=RORARR("OBR","ST")
160 S TMP=$S(TMP1="A":"F",TMP1="I":"R",1:"")
161 S RORSEG(25)=TMP
162 ;
163 ;--- OBR-44 - Division
164 S RORSEG(44)=$$SITE^RORUTL03(CS)
165 ;
166 ;--- Store the segment
167 D ADDSEG^RORHL7(.RORSEG)
168 Q ERRCNT
169 ;
170 ;***** PROBLEM LIST OBX SEGMENT(S) BUILDER
171 ;
172 ; Return Values:
173 ; <0 Error code
174 ; 0 Ok
175 ; >0 Non-fatal error(s)
176 ;
177OBX(RORARR) ;
178 N BR,CS,ERRCNT,NDX,OBX3,RC
179 S (ERRCNT,RC)=0
180 D ECH^RORHL7(.CS)
181 S BR=$E(HLECH,3)_".br"_$E(HLECH,3)
182 ;
183 I $D(RORARR("OBX","PR")) D
184 . S OBX3="PRVN"_CS_"Provider Narrative"_CS_"VA080"
185 . D SETOBX(OBX3,"",$$ESCAPE^RORHL7(RORARR("OBX","PR")))
186 ;
187 I $D(RORARR("OBX","PROB")) D
188 . S OBX3="EXPR"_CS_"Expression"_CS_"VA080"
189 . D SETOBX(OBX3,"",$$ESCAPE^RORHL7(RORARR("OBX","PROB")))
190 ;
191 S OBX3="NOTE"_CS_"Note Narrative"_CS_"VA080"
192 D SETOBXWP^RORHLUT1(RORTMP,OBX3)
193 ;
194 Q ERRCNT
195 ;
196 ;*** CREATES AND STORES THE OBX SEGMENT
197SETOBX(OBX3,OBX4,OBX5) ;
198 N RORSEG
199 ;--- Initialize the segment
200 S RORSEG(0)="OBX"
201 ;--- OBX-2
202 S RORSEG(2)="FT"
203 ;--- OBX-3
204 S RORSEG(3)=OBX3
205 ;--- OBX-4
206 S:$G(OBX4)'="" RORSEG(4)=OBX4
207 ;--- OBX-5
208 S RORSEG(5)=OBX5
209 ;--- OBX-11
210 S RORSEG(11)="F"
211 ;--- Store the segment
212 D ADDSEG^RORHL7(.RORSEG)
213 Q
Note: See TracBrowser for help on using the repository browser.