source: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRPT.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 9.5 KB
Line 
1RAHLRPT ;HISC/CAH AISC/SAW-Compiles HL7 'ORU' Message Type ; 4/26/01 10:40am
2 ;;5.0;Radiology/Nuclear Medicine;**2,12,10,25,81,80**;Mar 16, 1998;Build 19
3EN ; Called from RA RPT and RA RPT 2.3 protocol entry action
4 ; Input variables:
5 ; RADFN=file 2 IEN (DFN)
6 ; RADTI=file 70 Exam subrecord IEN (reverse date/time)
7 ; RACNI=file 70 Case subrecord IEN
8 ; RARPT=file 74 Report IEN
9 ; RASSS=List of Subscribers passed into GENERATE^HLMA will be set into HLP array.
10 ; Output variables:
11 ; HLA("HLS", array containing HL7 msg
12 ;
13 N RASET,RACN0
14 S RASET=0
15 S RACN0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
16 S:'$D(RARPT) RARPT=+$P(RACN0,"^",17)
17 I +$P(RACN0,U,25)=2 D Q ; printset
18 .; loop through all cases in set and create message
19 .S RASET=1
20 .N RACNI,RAII S RAII=0
21 .F S RAII=$O(^RADPT(RADFN,"DT",RADTI,"P",RAII)) Q:RAII'>0 D
22 .. Q:$P(^RADPT(RADFN,"DT",RADTI,"P",RAII,0),U,25)'=2
23 .. S RACNI=RAII
24 .. D NEW
25NEW ; new variables
26 S:$D(ZTQUEUED) ZTREQ="@" ; delete task from task global
27 N DFN,DIWF,DIWL,DIWR,RACPT,RACPTNDE,RADTECN,RADTE0,RADTV,RAI,RAN,RAOBR4,RAPRCNDE,RAPROC,RAPROCIT,RAPRV,RARPT0
28 N VADM,VAERR,X,X1,X2,XX2,Y,X0,OBR36,EID,HL,INT,HLQ,HLFS,HLECH,HLA,RAN K RAVADM
29 D INIT^RAHLRU ;initialize HL7 variables
30 Q:+$G(HL)=15 ;no known client(item) linked to the event driver protocol
31 Q:$O(HL(""))="" ;failed return from init^hlfnc2
32 ;
33 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 **
34 ;I HL("VER")]2.3 D EN^RAHLRPT1(RADFN,RADTI,RACNI,RAEID),EXIT Q
35 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 **
36 ;
37 S DFN=RADFN D DEM^VADPT
38 I VADM(1)']"" S HLP("ERRTEXT")="Invalid Patient Identifier" G EXIT
39 S RAN=0
40 S RAVADM(3)=$S($E(+VADM(3),6,7)="00":"",1:+VADM(3)) ; NOTE: Check
41 ; for an inexact date of birth. If inexact, pass null for DOB in
42 ; the 'PID' segment. Some COTS systems can't handle inexact DOB's.
43 D SETUP,PID,OBR,OBXPRC,OBXIMP,OBXDIA,OBXRPT,OBXMOD,OBXTCM
44EXIT ; set HL7 message type & return to RA RPT protocol
45 S HL("MTN")="ORU"
46 N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLP
47 S HLEID=RAEID,HLARYTYP="LM",HLFORMAT=1,HLMTIEN="",HLP("PRIORITY")="I"
48 M:$D(RASSS) HLP=RASSS
49 D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP)
50 D GENERATE^HLMA(HLEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP)
51 K RAVADM
52 Q
53 ;
54OBR ;Compile 'OBR' Segment
55 S RAOBR4=$P(RACPTNDE,U)_$E(HLECH)_$P(RACPTNDE,U,2)_$E(HLECH)_"C4"_$E(HLECH)_+RAPROC_$E(HLECH)_$P(RAPRCNDE,U)_$E(HLECH)_"99RAP"
56 ; Replace above with following when Imaging can cope with ESC chars
57 ; S RAOBR4=$P(RACPTNDE,U)_$E(HLECH)_$$ESCAPE^RAHLRU($P(RACPTNDE,U,2))_$E(HLECH)_"C4"_$E(HLECH)_+RAPROC_$E(HLECH)_$$ESCAPE^RAHLRU($P(RAPRCNDE,U))_$E(HLECH)_"99RAP"
58 ; Have to use LOCAL code if Broad Procedure - no CPT code
59 I $P(RAOBR4,$E(HLECH))=""!($P(RAOBR4,$E(HLECH),2)="") S $P(RAOBR4,$E(HLECH),1,3)=$P(RAOBR4,$E(HLECH),4,5)_$E(HLECH)_"LOCAL"
60 S X1="OBR"_HLFS_HLFS_HLFS_RADTI_"-"_RACNI_$E(HLECH)_RADTECN_$E(HLECH)_"L"_HLFS_RAOBR4_HLFS_HLFS_HLFS_RADTE0_HLFS_HLQ_HLFS_HLQ_HLFS_HLFS_HLFS_HLFS_HLFS,Y=$$HLDATE^HLFNC($P(RARPT0,"^",6)) S X1=X1_Y_HLFS_HLFS
61 S RAPRV=$$GET1^DIQ(200,+$P(RACN0,"^",14),.01)
62 S Y=$$HLNAME^HLFNC(RAPRV) S X1=X1_$S(Y]"":+$P(RACN0,"^",14)_$E(HLECH)_Y,1:"")
63 S $P(X1,HLFS,19)=$S($D(^DIC(42,+$P(RACN0,"^",6),0)):$P(^(0),"^"),$D(^SC(+$P(RACN0,"^",8),0)):$P(^(0),"^"),1:"Unknown")
64 ; PCE 21 -> ien file #79.1~name of img loc~stn #~stn name
65 N RACN00,RA20 S RACN00=$G(^RADPT(RADFN,"DT",RADTI,0))
66 S RA20=+$G(^RA(79.1,+$P(RACN00,U,4),0))
67 S $P(X1,HLFS,21)=$P(RACN00,"^",4)_$E(HLECH)_$P($G(^SC(RA20,0)),"^")_$E(HLECH)_$P(RACN00,"^",3)_$E(HLECH)_$P($G(^DIC(4,$P(RACN00,U,3),0)),"^")
68 S $P(X1,HLFS,21)=$P(X1,HLFS,21)
69 ; Replace above with following when Imaging can cope with ESC chars
70 ; S $P(X1,HLFS,21)=$$ESCAPE^RAHLRU($P(X1,HLFS,21))
71 ;
72 S OBR36=9999999.9999-RADTI
73 S $P(X1,HLFS,37)=$$FMTHL7^XLFDT(OBR36)
74 ;
75 S RADTV=HLDT1 I $P(RARPT0,"^",5)="V",$P(RARPT0,"^",7) K RADTV S RADTV=$$HLDATE^HLFNC($P(RARPT0,"^",7))
76 S $P(X1,HLFS,23)=RADTV,$P(X1,HLFS,26)=$S($P(RARPT0,"^",5)="V":"F",1:"R")
77 ;Principal Result Interpreter = Verifying Physician
78 S $P(X1,HLFS,33)="" I $P(RARPT0,"^",9) D
79 .S X2=$$GET1^DIQ(200,$P(RARPT0,"^",9),.01) Q:X2']""
80 .S Y=$$HLNAME^HLFNC(X2) Q:Y']""
81 .S $P(X1,HLFS,33)=$P(RARPT0,"^",9)_$E(HLECH)_Y
82 ;Assistant Result Interpreter = Primary Interpreting Staff OR Resident
83 S $P(X1,HLFS,34)="" I $P(RACN0,"^",15) D
84 .S X2=$$GET1^DIQ(200,$P(RACN0,"^",15),.01) Q:X2']""
85 .S Y=$$HLNAME^HLFNC(X2) Q:Y']""
86 .S $P(X1,HLFS,34)=$P(RACN0,"^",15)_$E(HLECH)_Y
87 I $P(RACN0,"^",12) D
88 .S X2=$$GET1^DIQ(200,$P(RACN0,"^",12),.01) Q:X2']""
89 .S Y=$$HLNAME^HLFNC(X2) Q:Y']""
90 .S $P(X1,HLFS,34)=$P(RACN0,"^",12)_$E(HLECH)_Y
91 ;Technician = Technologist
92 S $P(X1,HLFS,35)="" I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0)) D
93 .S X2=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0)) I X2']"" Q
94 .S X2=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",X2,0)) I X2']"" Q
95 .S XX2=$$GET1^DIQ(200,X2,.01) Q:XX2']""
96 .S Y=$$HLNAME^HLFNC(XX2) I Y']"" Q
97 .S $P(X1,HLFS,35)=X2_$E(HLECH)_Y
98 ;Transcriptionist
99 S $P(X1,HLFS,36)="" I $G(^RARPT(RARPT,"T")) D
100 .S X2=$$GET1^DIQ(200,^RARPT(RARPT,"T"),.01) I X2']"" Q
101 .S Y=$$HLNAME^HLFNC(X2) I Y']"" Q
102 .S $P(X1,HLFS,36)=^RARPT(RARPT,"T")_$E(HLECH)_Y
103 ;
104 ; if long str, break so 2nd str begins with separator to avoid abend
105 I $L(X1)>245 N RAPART F RAPART=5:1:18 S RAPART(1)=$P(X1,HLFS,1,RAPART),RAPART(2)=$P(X1,HLFS,RAPART+1,99) Q:$L(RAPART(1))<245&($L(RAPART(2))<245)&($P(RAPART(2),HLFS)="")
106 I $D(RAPART) K:RAPART=18 RAPART ;if RAPART reaches 18, then something's wrong, so kill RAPART to allow abend due "string too long"
107 S RAN=RAN+1
108 I $D(RAPART) S HLA("HLS",RAN)=$P(RAPART(1),HLFS)_HLFS,HLA("HLS",RAN,1)=$P(RAPART(1),HLFS,2,99)_HLFS,HLA("HLS",RAN,2)=RAPART(2) K RAPART Q
109 S HLA("HLS",RAN)=X1
110 Q
111OBXDIA ;Compile 'OBX' Segment for Diagnostic Code
112 S RAI=$P($G(^RA(78.3,+$P(RACN0,"^",13),0)),"^") I RAI]"" D
113 .S RAN=RAN+1
114 .I $$PATCH^XPDUTL("MAG*2.5*1")!(+$$VERSION^XPDUTL("MAG")>2.5) D
115 ..S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_+$P(RACN0,"^",13)_$E(HLECH)_RAI_$E(HLECH)_"L"
116 ..; Replace above with following when Imaging can cope with ESC chars
117 ..; S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_+$P(RACN0,"^",13)_$E(HLECH)_$$ESCAPE^RAHLRU(RAI)_$E(HLECH)_"L"
118 .E D
119 ..S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"ST"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_RAI
120 .D OBX11^RAHLRU
121 Q:'$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) ;any secondary dx
122 S X2=0
123OBXDIA2 S X2=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",X2)) Q:'X2
124 S Y=+^(X2,0),X=$P($G(^RA(78.3,+Y,0)),U)
125 I X]"" D
126 .S RAN=RAN+1
127 .I $$PATCH^XPDUTL("MAG*2.5*1")!(+$$VERSION^XPDUTL("MAG")>2.5) D
128 ..S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_Y_$E(HLECH)_X_$E(HLECH)_"L"
129 ..; Replace above with following when Imaging can cope with ESC chars
130 ..; S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_Y_$E(HLECH)_$$ESCAPE^RAHLRU(X)_$E(HLECH)_"L"
131 .E D
132 ..S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"ST"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_X
133 .D OBX11^RAHLRU
134 G OBXDIA2
135 ;
136OBXIMP ;Compile 'OBX' segment for Impression
137 I '$O(^RARPT(RARPT,"I",0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"I"_$E(HLECH)_"IMPRESSION"_$E(HLECH)_"L"_HLFS_HLFS_"None Entered" D OBX11^RAHLRU Q
138 K ^UTILITY($J,"W") S DIWF="",DIWR=80,DIWL=1 F RAI=0:0 S RAI=$O(^RARPT(RARPT,"I",RAI)) Q:'RAI I $D(^(RAI,0)) S X=^(0) D ^DIWP
139 F RAI=0:0 S RAI=$O(^UTILITY($J,"W",DIWL,RAI)) Q:'RAI I $D(^(RAI,0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"I"_$E(HLECH)_"IMPRESSION"_$E(HLECH)_"L"_HLFS_HLFS_^(0) D OBX11^RAHLRU
140 Q
141OBXMOD ;Compile 'OBX' Segment for Modifiers
142 S RAN=RAN+1 D OBXMOD^RAHLRU
143 Q
144OBXPRC ;Compile 'OBX' Segment for Procedure
145 S RAN=RAN+1 D OBXPRC^RAHLRU
146 Q
147OBXTCM ; Compile 'OBX' Segment for Tech Comments
148 D OBXTCM^RAHLRU
149 Q
150OBXRPT ;Compile 'OBX' Segment for Radiology Report Text
151 I '$O(^RARPT(RARPT,"R",0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"R"_$E(HLECH)_"REPORT"_$E(HLECH)_"L"_HLFS_HLFS_"None Entered" D OBX11^RAHLRU Q
152 K ^UTILITY($J,"W") S DIWF="",DIWR=80,DIWL=1 F RAI=0:0 S RAI=$O(^RARPT(RARPT,"R",RAI)) Q:'RAI I $D(^(RAI,0)) S X=^(0) D ^DIWP
153 F RAI=0:0 S RAI=$O(^UTILITY($J,"W",DIWL,RAI)) Q:'RAI I $D(^(RAI,0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"R"_$E(HLECH)_"REPORT"_$E(HLECH)_"L"_HLFS_HLFS_^(0) D OBX11^RAHLRU
154 ; Replace above with following when Imaging can cope with ESC chars
155 ; F RAI=0:0 S RAI=$O(^UTILITY($J,"W",DIWL,RAI)) Q:'RAI I $D(^(RAI,0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"R"_$E(HLECH)_"REPORT"_$E(HLECH)_"L"_HLFS_HLFS_$$ESCAPE^RAHLRU(^(0)) D OBX11^RAHLRU
156 Q
157PID ;Compile 'PID' Segment
158 I HL("VER")']"2.2" D
159 .S X1="",X1="PID"_HLFS_HLFS_$G(VA("PID"))_HLFS_Y_HLFS_HLFS S X=VADM(1),Y=$$HLNAME^HLFNC(X) S X1=X1_Y_HLFS_HLFS
160 .S X=RAVADM(3),Y=$$HLDATE^HLFNC(X) S X1=X1_Y_HLFS_$S(VADM(5)]"":$S("MF"[$P(VADM(5),"^"):$P(VADM(5),"^"),1:"O"),1:"U") S:$P(VADM(2),"^")]"" $P(X1,HLFS,20)=$P(VADM(2),"^") S RAN=RAN+1,HLA("HLS",RAN)=X1
161 I HL("VER")]"2.2" S RAN=RAN+1,HLA("HLS",RAN)=$$EN^VAFHLPID(DFN,"2,3,5,7,8,19,20")
162 Q
163SETUP ; Setup basic examination information
164 S:RASET RACN0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
165 S RADTE0=9999999.9999-RADTI,RADTECN=$E(RADTE0,4,7)_$E(RADTE0,2,3)_"-"_+RACN0,RARPT0=^RARPT(RARPT,0)
166 S RAPROC=+$P(RACN0,U,2),RAPROCIT=+$P($G(^RAMIS(71,RAPROC,0)),U,12),RAPROCIT=$P(^RA(79.2,RAPROCIT,0),U,1)
167 S RAPRCNDE=$G(^RAMIS(71,+RAPROC,0)),RACPT=+$P(RAPRCNDE,U,9)
168 S RACPTNDE=$$NAMCODE^RACPTMSC(RACPT,DT)
169 S Y=$$HLDATE^HLFNC(RADTE0) S RADTE0=$S(Y:Y,1:HLQ),Y=$$M11^HLFNC(RADFN)
170 Q
Note: See TracBrowser for help on using the repository browser.