source: WorldVistAEHR/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORHL05.m@ 1800

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

initial load of WorldVistAEHR
File size: 4.6 KB
Line 
1RORHL05 ;HOIFO/CRT - HL7 AUTOPSY: OBR ; 3/13/06 9:23am
2 ;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
3 ;
4 ; This routine uses the following IAs:
5 ;
6 ; #1995 $$CPT^ICPTCOD (supported)
7 ; #3465 Access to autopsy data (private)
8 ; #10040 Read the INSTITUTION field of file #44 (supported)
9 ; #10090 Read access to the file #4 (supported)
10 ;
11 Q
12 ;
13 ;***** SEARCHES FOR AUTOPSY 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 ; [FORCE] Force the extraction of the autopsy data
21 ;
22 ; Return Values:
23 ; <0 Error code
24 ; 0 Ok
25 ; >0 Non-fatal error(s)
26 ;
27EN1(RORDFN,DXDTS,FORCE) ;
28 N ADATE,ERRCNT,RC,RORLRDFN,RORMSG
29 S (ERRCNT,RC)=0
30 ;
31 ;--- Check if the autopsy has been performed
32 S RORLRDFN=+$$LABREF^RORUTL18(RORDFN) Q:RORLRDFN'>0 0
33 S ADATE=$$GET1^DIQ(63,RORLRDFN_",",11,"I",,"RORMSG")
34 Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,RORDFN,63,RORLRDFN_",")
35 ;
36 D:ADATE>0
37 . ;--- Check if the autopsy data should be sent (autopsy date
38 . ; falls into one of the data extraction time frames or
39 . ;--- the extraction if forced by the function parameter).
40 . I '$G(FORCE) S RC=0 D Q:'RC
41 . . N D1,D2,IDX
42 . . S IDX=0
43 . . F S IDX=$O(DXDTS(7,IDX)) Q:IDX'>0 D Q:RC
44 . . . S D1=$P(DXDTS(7,IDX),U),D2=$P(DXDTS(7,IDX),U,2)
45 . . . S:(ADATE'<D1)&(ADATE<D2) RC=1
46 . .
47 . ;--- Send the data
48 . S RC=$$OBR(RORLRDFN)
49 . I RC Q:RC<0 S ERRCNT=ERRCNT+RC
50 . S RC=$$OBX(RORLRDFN)
51 . I RC Q:RC<0 S ERRCNT=ERRCNT+RC
52 ;
53 Q $S(RC<0:RC,1:ERRCNT)
54 ;
55 ;***** AUTOPSY OBR SEGMENT BUILDER
56 ;
57 ; RORLRDFN IEN of Lab Patient Record in File #63
58 ;
59 ; Return Values:
60 ; <0 Error code
61 ; 0 Ok
62 ; >0 Non-fatal error(s)
63 ;
64OBR(RORLRDFN) ;
65 N BUF,CS,ERRCNT,IEN,IENS63,RC,RORMSG,ROROUT,RORSEG,TMP
66 S (ERRCNT,RC)=0
67 D ECH^RORHL7(.CS)
68 ;
69 S IENS63=+$G(RORLRDFN)_","
70 D GETS^DIQ(63,IENS63,"11;12.1;13.1;14;14.1;14.5;14.7","IE","ROROUT","RORMSG")
71 I $G(DIERR) D S ERRCNT=ERRCNT+1
72 . D DBS^RORERR("RORMSG",-9,,,63,IENS63)
73 ;
74 ;--- Initialize the segment
75 S RORSEG(0)="OBR"
76 ;
77 ;--- OBR-3 - Order #
78 I $G(ROROUT(63,IENS63,14,"E"))="" D Q RC
79 . S RC=$$ERROR^RORERR(-95,,,,63,IENS63,14)
80 S RORSEG(3)=ROROUT(63,IENS63,14,"E")
81 ;
82 ;--- OBR-4 - CPT Code
83 S BUF=88099,TMP=$$CPT^ICPTCOD(BUF)
84 I TMP<0 D S ERRCNT=ERRCNT+1,TMP=""
85 . D ERROR^RORERR(-57,,$P(TMP,U,2),,+TMP,"$$CPT^ICPTCOD")
86 S $P(BUF,CS,2)=$$ESCAPE^RORHL7($P(TMP,U,3))
87 S $P(BUF,CS,3)="C4"
88 S RORSEG(4)=BUF
89 ;
90 ;--- OBR-7 - Autopsy Date/Time
91 S TMP=$$FMTHL7^XLFDT($G(ROROUT(63,IENS63,11,"I")))
92 Q:TMP'>0 $$ERROR^RORERR(-95,,,,63,IENS63,11)
93 S RORSEG(7)=TMP
94 ;
95 ;--- OBR-8 - Date of the final autopsy diagnoses
96 S RORSEG(8)=$$FMTHL7^XLFDT($G(ROROUT(63,IENS63,13.1,"I")))
97 ;
98 ;--- OBR-16 - Ordering Provider
99 S RORSEG(16)=$G(ROROUT(63,IENS63,12.1,"I"))
100 ;
101 ;--- OBR-22 - Date/TIme the report is released
102 S RORSEG(22)=$$FMTHL7^XLFDT($G(ROROUT(63,IENS63,14.7,"I")))
103 ;
104 ;--- OBR-24 - Diagnostic Service ID
105 S RORSEG(24)="SP"
106 ;
107 ;--- OBR-44 - Division
108 S TMP=$G(ROROUT(63,IENS63,14.1,"I"))
109 S IEN=$S(TMP'="":+$O(^SC("B",TMP,0)),1:0)
110 S RORSEG(44)=$$DIV44^RORHLUT1(IEN,CS)
111 ;
112 ;--- OBR-46 - Service
113 S BUF=+$G(ROROUT(63,IENS63,14.5,"I"))
114 D:BUF>0
115 . S $P(BUF,CS,2)=$G(ROROUT(63,IENS63,14.5,"E"))
116 . S RORSEG(46)=BUF
117 ;
118 ;--- Store the segment
119 D ADDSEG^RORHL7(.RORSEG)
120 Q ERRCNT
121 ;
122 ;***** AUTOPSY OBX SEGMENT BUILDER
123 ;
124 ; RORLRDFN IEN of Lab Patient Record in File #63
125 ;
126 ; Return Values:
127 ; <0 Error code
128 ; 0 Ok
129 ; >0 Non-fatal error(s)
130 ;
131OBX(RORLRDFN) ;
132 ;;32.2;;AUCD^Clinical Diagnosis^VA080
133 ;;32.3;;AUPD^Pathological Diagnosis^VA080
134 ;
135 N BR,BUF,CS,ERRCNT,FLD,I,I1,ICNT,IENS63,IMF,RC,RORMSG,RORSEG,RORTXT,TMP
136 S (ERRCNT,RC)=0
137 D ECH^RORHL7(.CS)
138 S BR=$E(HLECH,3)_".br"_$E(HLECH,3)
139 ;
140 ;--- Initialize the segment
141 S RORSEG(0)="OBX"
142 ;
143 ;--- OBX-2 - Value Type
144 S RORSEG(2)="FT"
145 ;
146 ;--- OBX-11 - Observation Result Status
147 S RORSEG(11)="F"
148 ;
149 ;--- Generate the OBX segments
150 S IENS63=+$G(RORLRDFN)_","
151 F IMF=1,2 D
152 . S BUF=$T(OBX+IMF),FLD=$P(BUF,";;",2)
153 . K RORMSG,RORTXT,RORSEG(5)
154 . ;--- OBX-3 - Observation Identifier
155 . S RORSEG(3)=$P(BUF,";;",3)
156 . ;--- Load the text
157 . S TMP=$$GET1^DIQ(63,IENS63,FLD,,"RORTXT","RORMSG")
158 . I $G(DIERR) D S ERRCNT=ERRCNT+1
159 . . D DBS^RORERR("RORMSG",-9,,,63,IENS63)
160 . ;--- Process the text
161 . S I=$O(RORTXT("")),ICNT=0
162 . F Q:I="" S I1=$O(RORTXT(I)) D S I=I1
163 . . ;--- OBX-5 - Observation Value
164 . . S TMP=$$ESCAPE^RORHL7(RORTXT(I))
165 . . S ICNT=ICNT+1,RORSEG(5,ICNT)=$S(I1'="":TMP_BR,1:TMP)
166 . ;--- Store the segment
167 . D:ICNT>0 ADDSEG^RORHL7(.RORSEG)
168 ;
169 ;---
170 Q ERRCNT
Note: See TracBrowser for help on using the repository browser.