source: FOIAVistA/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORHL14.m@ 1384

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

initial load of FOIAVistA 6/30/08 version
File size: 5.5 KB
Line 
1RORHL14 ;HOIFO/BH,SG - HL7 ALLERGY DATA: OBR,OBX ; 8/26/05 2:43pm
2 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
3 ;
4 ; This routine uses the following IAs:
5 ;
6 ; #2167 Read access to the file #120.83 (controlled)
7 ; #4531 ZERO^PSN50P41
8 ; #4543 IEN^PSN50P65
9 ; #10060 Read access to the file #200 (supported)
10 ;
11 ;
12 Q
13 ;
14 ;***** SEARCHES FOR ALLERGY DATA
15 ;
16 ; RORDFN IEN of the patient in the PATIENT file (#2)
17 ;
18 ; .DXDTS Reference to a local variable where the
19 ; data extraction time frames are stored.
20 ;
21 ; Return Values:
22 ; <0 Error code
23 ; 0 Ok
24 ; >0 Non-fatal error(s)
25 ;
26EN1(RORDFN,DXDTS) ;
27 N ERRCNT,IDX,RC,RORARR,RORDTE,RORENDT,RORIEN,RORSTDT,TMP
28 S (ERRCNT,RC)=0
29 ;
30 S IDX=0
31 F S IDX=$O(DXDTS(13,IDX)) Q:IDX'>0 D Q:RC<0
32 . S RORSTDT=$P(DXDTS(13,IDX),U),RORENDT=$P(DXDTS(13,IDX),U,2)
33 . ;---
34 . S RORDTE=$O(^GMR(120.8,"AODT",RORSTDT),-1)
35 . F S RORDTE=$O(^GMR(120.8,"AODT",RORDTE)) Q:'RORDTE!(RORDTE'<RORENDT) D
36 . . S RORIEN=0
37 . . F S RORIEN=$O(^GMR(120.8,"AODT",RORDTE,RORIEN)) Q:'RORIEN D
38 . . . S:$D(^GMR(120.8,"B",RORDFN,RORIEN)) RORARR(RORIEN)=""
39 . I $D(RORARR)<10 S ERRCNT=ERRCNT+1 Q
40 . ;
41 . S RORIEN=0
42 . F S RORIEN=$O(RORARR(RORIEN)) Q:'RORIEN D
43 . . S TMP=$$OBR(RORIEN,RORDFN)
44 . . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
45 . . S TMP=$$OBX(RORIEN,RORDFN)
46 . . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
47 ;
48 Q $S(RC<0:RC,1:ERRCNT)
49 ;
50 ;***** ALLERGY OBR SEGMENT BUILDER
51 ;
52 ; RORAIEN IEN of Allergy entry
53 ; RORDFN IEN of the patient in the PATIENT file (#2)
54 ;
55 ; Return Values:
56 ; <0 Error code
57 ; 0 Ok
58 ; >0 Non-fatal error(s)
59 ;
60OBR(RORAIEN,RORDFN) ;
61 N BUF,CS,ERRCNT,RC,RORLST,RORMSG,RORSEG,TMP
62 S (ERRCNT,RC)=0
63 D ECH^RORHL7(.CS)
64 ;
65 S RORAIEN=RORAIEN_","
66 D GETS^DIQ(120.8,RORAIEN,".02;3.1;4;5;6","EI","RORLST","RORMSG")
67 I $G(DIERR) D S ERRCNT=ERRCNT+1
68 . D DBS^RORERR("RORMSG",-9,,RORDFN,120.8,RORAIEN)
69 ;
70 ;--- Initialize the segment
71 S RORSEG(0)="OBR"
72 ;
73 ;--- OBR-3 - IEN of the record
74 S RORSEG(3)=$P(RORAIEN,",")
75 ;
76 ;--- OBR-4 - Sevice ID
77 S RORSEG(4)="95000"_CS_"ALLERGY"_CS_"C4"
78 ;
79 ;--- OBR-7 - Observation Date/Time (Origination Date)
80 S TMP=$$FMTHL7^XLFDT($G(RORLST(120.8,RORAIEN,4,"I")))
81 Q:TMP'>0 $$ERROR^RORERR(-95,,,RORDFN,120.8,RORAIEN,4)
82 S RORSEG(7)=TMP
83 ;
84 ;--- OBR-13 - Relevant Clinical Info. (Reactant)
85 S RORSEG(13)=$G(RORLST(120.8,RORAIEN,.02,"E"))
86 ;
87 ;--- OBR-16 - Ordering Provider
88 S BUF=$G(RORLST(120.8,RORAIEN,5,"I"))
89 I BUF>0 D
90 . S $P(BUF,CS,13)=$$GET1^DIQ(200,+BUF_",",53.5,"E",,"RORMSG")
91 . I $G(DIERR) D S ERRCNT=ERRCNT+1 Q
92 . . D DBS^RORERR("RORMSG",-99,,RORDFN,200,+BUF_",")
93 . S RORSEG(16)=BUF
94 ;
95 ;--- OBR-20 - Filler Field 1 (Allergy Type)
96 S RORSEG(20)=$G(RORLST(120.8,RORAIEN,3.1,"E"))
97 ;
98 ;--- OBR-24 - Diagnostic Service ID
99 S RORSEG(24)="TX"
100 ;
101 ;--- OBR-25 - Result Status (Observed/Historical)
102 S TMP=$G(RORLST(120.8,RORAIEN,6,"E"))
103 I TMP'="" D S RORSEG(25)=TMP
104 . S TMP=$S(TMP="HISTORICAL":"R",TMP="OBSERVED":"F",1:"")
105 ;
106 ;--- Store the segment
107 D ADDSEG^RORHL7(.RORSEG)
108 Q ERRCNT
109 ;
110 ;***** ALLERGY OBX SEGMENT(S) BUILDER
111 ;
112 ; RORAIEN IEN of Allergy entry
113 ; RORDFN IEN of the patient in the PATIENT file (#2)
114 ;
115 ; Return Values:
116 ; <0 Error code
117 ; 0 Ok
118 ; >0 Non-fatal error(s)
119 ;
120OBX(RORAIEN,RORDFN) ;
121 N BUF,CS,DTE,ERRCNT,IEN,RC,REAC,RORID,RORIENS,RORKEY,RORLST,RORMSG,RORSEG,RORTMP,RORTS,RPS,TMP
122 S (ERRCNT,RC)=0,RORIENS=","_RORAIEN_","
123 D ECH^RORHL7(.CS,,.RPS)
124 ;
125 ;=== Ingredients
126 K RORLST,RORMSG
127 D LIST^DIC(120.802,RORIENS,"@;.01","I",,,,,,,"RORLST","RORMSG")
128 I $G(DIERR) D Q RC
129 . S RC=$$DBS^RORERR("RORMSG",-9,,RORDFN,120.802,RORIENS)
130 S RORID="INGR"_CS_"Ingredients"_CS_"VA080"
131 ;---
132 S RORTMP=$$ALLOC^RORTMP(.RORTS)
133 S RORKEY=0
134 F S RORKEY=$O(RORLST("DILIST","ID",RORKEY)) Q:'RORKEY D
135 . S IEN=+$G(RORLST("DILIST","ID",RORKEY,.01)) Q:IEN'>0
136 . D ZERO^PSN50P41(IEN,,,RORTS)
137 . S TMP=$G(@RORTMP@(IEN,.01))
138 . D:TMP'="" SETOBX(TMP,RORID)
139 D FREE^RORTMP(RORTMP)
140 ;
141 ;=== Classes
142 K RORLST,RORMSG
143 D LIST^DIC(120.803,RORIENS,"@;.01","I",,,,,,,"RORLST","RORMSG")
144 I $G(DIERR) D Q RC
145 . S RC=$$DBS^RORERR("RORMSG",-9,,RORDFN,120.803,RORIENS)
146 ;---
147 S RORTMP=$$ALLOC^RORTMP(.RORTS)
148 S (CNT,RORKEY)=0,BUF=""
149 F S RORKEY=$O(RORLST("DILIST","ID",RORKEY)) Q:'RORKEY D
150 . S IEN=+$G(RORLST("DILIST","ID",RORKEY,.01)) Q:IEN'>0
151 . D IEN^PSN50P65(IEN,,RORTS)
152 . S TMP=$G(@RORTMP@(IEN,.01))
153 . S:TMP'="" BUF=BUF_$S(BUF'="":RPS_TMP,1:TMP)
154 D:BUF'="" SETOBX(BUF,"CLAS"_CS_"Drug Class"_CS_"VA080")
155 D FREE^RORTMP(RORTMP)
156 ;
157 ;=== Reactions
158 K RORLST,RORMSG
159 D LIST^DIC(120.81,RORIENS,"@;.01;3","I",,,,,,,"RORLST","RORMSG")
160 I $G(DIERR) D Q RC
161 . S RC=$$DBS^RORERR("RORMSG",-9,,RORDFN,120.81,RORIENS)
162 S RORID="RCTS"_CS_"Reactions"_CS_"VA080"
163 ;---
164 S RORKEY=0
165 F S RORKEY=$O(RORLST("DILIST","ID",RORKEY)) Q:'RORKEY D
166 . S IEN=RORLST("DILIST","ID",RORKEY,.01) Q:IEN'>0
167 . S REAC=$$GET1^DIQ(120.83,IEN_",",.01,"E",,"RORMSG")
168 . I $G(DIERR) D S ERRCNT=ERRCNT+1 Q
169 . . D DBS^RORERR("RORMSG",-99,,RORDFN,120.83,IEN_",")
170 . Q:REAC=""
171 . S DTE=$$FM2HL^RORHL7($G(RORLST("DILIST","ID",RORKEY,3)))
172 . D SETOBX(REAC,RORID,DTE)
173 ;
174 Q $S(RC<0:RC,1:ERRCNT)
175 ;
176 ;***** CREATES AND STORES THE OBX SEGMENT
177SETOBX(OBX5,OBX3,OBX12) ;
178 N RORSEG
179 ;--- Initialize the segment
180 S RORSEG(0)="OBX"
181 ;--- OBX-2 - Value Type
182 S RORSEG(2)="FT"
183 ;--- OBX-3 - Observation Identifier
184 S RORSEG(3)=OBX3
185 ;--- OBX-5 - Observation Value
186 S RORSEG(5)=OBX5
187 ;--- OBX-11 - Observation Result Status
188 S RORSEG(11)="F"
189 ;--- OBX-12 - Reactions Date/Time Entered
190 S:$G(OBX12)'="" RORSEG(12)=OBX12
191 ;--- Store the segment
192 D ADDSEG^RORHL7(.RORSEG)
193 Q
Note: See TracBrowser for help on using the repository browser.