source: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLTCPB.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.1 KB
Line 
1RAHLTCPB ; HIRMFO/REL,GJC,BNT,PAV - Rad/Nuc Med HL7 TCP/IP Bridge;05/21/99
2 ;;5.0;Radiology/Nuclear Medicine;**12,17,25,51,71,81**;Mar 16, 1998;Build 12
3 ; 07/05/2006 BAY/KAM Remedy Call 124379 Eliminate unneeded ORM msgs
4 ; 09/01/2006 Acomodate multiplr ORC/OBR segments Patch 81
5EN1 ; Build the ^TMP("RARPT-REC" global when we receive the
6 ; 07/05/2006 Remedy Call 124379 message from HL7. If RAHLTCPB is defined, do not broadcast ORM messages. As of the writing
7 ; of patch 71, RAHLTCPB is referenced in RAHLTCPB, UPSTAT^RAUTL0, & UP2^RAUTL1
8 ;G:$G(HL("VER"))]"2.3" EN1^RAHLTCPX
9 S RASUB=HL("MID"),RAHLTCPB=1 K RAERR
10 ;**********************************************
11 ;RACN is Counter - Indication that ORC segment present
12 N RACN,II,L,RAPRSET,RARRR,XX,RAHLD,RARSDNT,RATRSCRP S (RACN,RAPRSET)=0 ; = Address where we go to store data...
13 ;**********************************************
14 K ^TMP("RARPT-HL7",$J) ; clean area that holds data from HL7
15 K ^TMP("RARPT-REC",$J,RASUB) ; kill storage area for new HL7 message id
16 S ^TMP("RARPT-REC",$J,RASUB,"RADATE")=$$DT^XLFDT()
17 F I=1:1 X HLNEXT Q:HLQUIT'>0 D
18 .I '$L(HLNODE),$L($G(HLNODE(1))) S HLNODE=HLNODE(1) K HLNODE(1) F J=2:1 Q:'$D(HLNODE(J)) S HLNODE(J-1)=HLNODE(J) K HLNODE(J)
19 .S ^TMP("RARPT-HL7",$J,I)=HLNODE,J=0 F S J=$O(HLNODE(J)) Q:'J S ^TMP("RARPT-HL7",$J,I,J)=HLNODE(J)
20 S CNT=2,SEGMNT=$G(^TMP("RARPT-HL7",$J,CNT))
21 S:'$$GETSFLAG^RAHLRU($G(HL("SAN")),$G(HL("MTN")),$G(HL("ETN")),$G(HL("VER"))) RANOSEND=$G(HL("SAN"))
22 S ^TMP("RARPT-REC",$J,RASUB,"VENDOR")=$G(HL("SAN"))
23PID ; Pick data off the 'PID' segment.
24 I $P(SEGMNT,HL("FS"))="PID" D
25 . S SEGMNT=$P(SEGMNT,HL("FS"),2,99999)
26 . I $P($P(SEGMNT,HL("FS"),3),$E(HL("ECH")))]"" D
27 .. S (^TMP("RARPT-REC",$J,RASUB,"RADFN"),RADFN)=$P($P(SEGMNT,HL("FS"),3),$E(HL("ECH")))
28 .. Q
29 . I $P(SEGMNT,HL("FS"),19)]"" D
30 .. S ^TMP("RARPT-REC",$J,RASUB,"RASSN")=$P(SEGMNT,HL("FS"),19)
31 .. Q
32 . Q
33 E S RAERR="Missing PID segment" D XIT Q
34 I '(+$G(^TMP("RARPT-REC",$J,RASUB,"RADFN"))) D Q
35 .S RAERR="Invalid Patient ID"
36 .D XIT
37 ; Save off E-Sig information (if it exists)
38 S:$D(HL("ESIG")) ^TMP("RARPT-REC",$J,RASUB,"RAESIG")=HL("ESIG")
39 ;********************************
40ORC ; Pick data off the 'ORC' segment.
41 D
42 .N CNT1 S CNT1=CNT,RARRR=""
43111 .K SEGMNT S CNT1=$O(^TMP("RARPT-HL7",$J,CNT1)) Q:CNT1="" S SEGMNT=$G(^(CNT1))
44 .I $P(SEGMNT,HL("FS"))="PV1" S CNT=CNT1 G 111
45 .Q:$P(SEGMNT,HL("FS"))'="ORC"
46 .S CNT=CNT1 Q:$P(SEGMNT,HL("FS"),2)'="CN" ; find the 'ORC' segment
47 .S RACN=RACN+1,RARRR="RARPT-REC-"_RACN
48 ;********************************
49OBR ; Pick data off the 'OBR' segment.
50 I $L(RARRR) K ^TMP(RARRR,$J) M ^TMP(RARRR,$J)=^TMP("RARPT-REC",$J) ;Merge if OBR without Report
51 S:'$L(RARRR) RARRR="RARPT-REC"
52 K SEGMNT F S CNT=$O(^TMP("RARPT-HL7",$J,CNT)) Q:CNT="" S SEGMNT=$G(^(CNT)) Q:$P(SEGMNT,HL("FS"))="OBR" ; find the 'OBR' segment
53 I $P($G(SEGMNT),HL("FS"))'="OBR" S RAERR="Missing OBR segment" D XIT Q
54 S SEGMNT=$P(SEGMNT,HL("FS"),2,99999) K RADTI,RACNI
55 I $P(SEGMNT,HL("FS"),3)]"" D
56 . N RADTCN S RADTCN=$P(SEGMNT,HL("FS"),3)
57 . S:$P($P(RADTCN,$E(HL("ECH"))),"-")]"" (^TMP(RARRR,$J,RASUB,"RADTI"),RADTI)=$P($P(RADTCN,$E(HL("ECH"))),"-")
58 . S:$P($P(RADTCN,$E(HL("ECH"))),"-",2)]"" (^TMP(RARRR,$J,RASUB,"RACNI"),RACNI)=$P($P(RADTCN,$E(HL("ECH"))),"-",2)
59 . S:$P(RADTCN,$E(HL("ECH")),2)["&L" RADTCN=$TR(RADTCN,"&","^")
60 . S:$P(RADTCN,$E(HL("ECH")),2)]"" ^TMP(RARRR,$J,RASUB,"RALONGCN")=$P(RADTCN,$E(HL("ECH")),2)
61 . Q
62 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,25,HL("FS")) K RAHL70
63 I RAHLD="" S RAERR="Missing Report Status" D XIT Q
64 I "AFR"'[RAHLD S RAERR="Invalid Report Status" D XIT Q
65 S ^TMP(RARRR,$J,RASUB,"RASTAT")=RAHLD
66 G:$P(RARRR,"-",3) 112 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,32,HL("FS")) K RAHL70
67 I RAHLD']"" S RAERR="Missing Provider ID" D XIT Q
68 S RAVERF=RAHLD
69 ; ----- Check the validity of the provider name -----
70 I '$D(^VA(200,"B",RAVERF)) D ; check for a partial match in file 200
71 . D VFIER^RAHLO3 ; if one partial match found, return the entry ien
72 E D ; $D(^VA(200,"B",RAVERF)) true, get the entry ien
73 . S RAVERF=$O(^VA(200,"B",RAVERF,0))
74 . S:'RAVERF RAERR="Invalid Provider Name"
75 ; can't get resident info from medspeak
76 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,33,HL("FS")),RARSDNT="" K RAHL70
77 I RAHLD]"" D
78 . S RARSDNT=$P(RAHLD,$E(HL("ECH"),4)) I '$D(^VA(200,+RARSDNT,0)) S RARSDNT=""
79 S RAHLD="",RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,35,HL("FS")),RATRSCRP="" K RAHL70
80 I RAHLD]"" D
81 . S RATRSCRP=$P(RAHLD,$E(HL("ECH"),4)) I '$D(^VA(200,+RATRSCRP,0)) S RATRSCRP=""
82 S ^TMP(RARRR,$J,RASUB,"RAVERF")=RAVERF
83 S ^TMP(RARRR,$J,RASUB,"RATRANSCRIPT")=$S(RATRSCRP]"":RATRSCRP,RARSDNT]"":RARSDNT,1:RAVERF)
84 S:$G(RARSDNT) ^TMP(RARRR,$J,RASUB,"RARESIDENT")=RARSDNT
85 S ^TMP(RARRR,$J,RASUB,"RASTAFF")=RAVERF,^("RAWHOCHANGE")=RAVERF
86 I $D(RAERR) D XIT Q
87 D ESIG^RAHLO3
88 ;If last OBR set provider info to all OBRs
89 K XX F I=1:1:RACN S XX=RARRR_"-"_I D:$D(^TMP(XX,$J,RASUB))
90 .N XXX M XXX=^TMP(XX,$J,RASUB),^TMP(XX,$J,RASUB)=^TMP(RARRR,$J,RASUB),^TMP(XX,$J,RASUB)=XXX
91112 I $D(RADTI),$D(RACNI),$D(RAPRSET(RADTI,RACNI)) K RAPRSET(RADTI,RACNI),^TMP(RARRR,$J) S RACN=RACN-1 G:$P(RARRR,"-",3) ORC M ^TMP(RARRR,$J)=^TMP("RARPT-REC-"_(RACN+1),$J) K ^TMP("RARPT-REC-"_(RACN+1),$J) G OBX
92 I $D(RADTI),'$D(RAPRSET(RADTI)) D ;Get array of printset for date...
93 .N RAPRTSET,RACN,RASUB,CNT
94 .K XX D EN2^RAUTL20(.XX) M:$D(XX) RAPRSET(RADTI)=XX K RAPRSET(RADTI,RACNI)
95 ;
96OBX ; Pick data off the 'OBX' segments
97 K SEGMNT F S CNT=$O(^TMP("RARPT-HL7",$J,CNT)) Q:CNT="" S SEGMNT=$G(^(CNT)) D:$P(SEGMNT,HL("FS"))="OBX" Q:$D(RAERR) I $P(SEGMNT,HL("FS"))="ORC" S CNT=CNT-1 G ORC
98 . S SEGMNT=$P(SEGMNT,HL("FS"),2,9999)
99 . Q:SEGMNT?@("1"""_HL("FS")_"""."""_HL("FS")_"""") ;Quit if OBX is something as: OBX||||||||
100 . I $P(SEGMNT,HL("FS"),3)']"" S RAERR="Missing Observation Identifier" Q
101 . S OBXTYP=$P(SEGMNT,HL("FS"),3),OBXTYP=$E(OBXTYP,$F(OBXTYP,"&"))
102 . S OBX2CE=""
103 . S:OBXTYP="" OBXTYP=" "
104 . I OBXTYP=" "&($P(SEGMNT,HL("FS"),2)="CE") D
105 . . I $P(SEGMNT,HL("FS"),5)=" " S OBXTYP="F" Q
106 . . S OBX2CE=1,OBXTYP="D" Q
107 . I "IDRF"'[OBXTYP S RAERR="Invalid Observation Identifier" Q
108 . D RPT Q
109XIT ; RACKYES Indicates that Ack will be sent on the last OBR segment or at Error condition.
110 N RACKYES
111 I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK G XIT1
112 I $D(^TMP("RARPT-REC",$J)) S:'RACN RACKYES=1 D G:$D(RAERR) XIT1
113 .N RACN D EN1^RAHLO I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK
114 F II=1:1:RACN S RARRR="RARPT-REC-"_II D:$D(^TMP(RARRR,$J)) Q:$D(RAERR)
115 .K ^TMP("RARPT-REC",$J) M ^TMP("RARPT-REC",$J)=^TMP(RARRR,$J) K ^TMP(RARRR,$J)
116 .S RACKYES=(II=RACN) N II,RACN D EN1^RAHLO I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK
117XIT1 K ^TMP("RARPT-REC",$J) ; kill storage area for current HL7 message id
118 F II=1:1:RACN S RARRR="RARPT-REC-"_II K:$D(^TMP(RARRR,$J)) ^TMP(RARRR,$J)
119 K ^TMP("RARPT-HL7",$J) ; clean up HL7 storage
120 K CNT,OBXTYP,X1,LIN,RADATE,RADTCN,RAERR,RAESIG,RAHLD,RAHLTCPB,RANODE,RARCNT
121 K RAVERF,RASUB,SEGMNT,RANOSEND,MSA1,OBX2CE,RADX,RADX1,RADX2,RADX3
122 Q
123RPT ; Save off Report Text data.
124 N RAXADEDN
125 S RAXADEDN=^TMP("RARPT-REC",$J,RASUB,"RASTAT")
126 S RANODE=$S(OBXTYP="D":"RADX",OBXTYP="I":"RAIMP",1:"RATXT"),LIN=""
127 I OBX2CE D Q
128 . S X=$P(SEGMNT,HL("FS"),5),RADX1=$P(X,$E(HL("ECH")))
129 . S LIN=RADX1,L=999 D P2 S LIN=X
130 . Q:X'["~" F J=0:0 S J=$O(^TMP("RARPT-HL7",$J,CNT,J)) Q:'J S X1=^(J),LIN=LIN_X1 Q
131 . S RADX=LIN,RADX2=$P($P(RADX,"~",2),"^") S:RADX2]"" LIN=RADX2 D P2
132 . S RADX3=$P($P(RADX,"~",3),"^") Q:RADX3']"" S LIN=RADX3 D P2 Q
133 S X=$P(SEGMNT,HL("FS"),5)
134 I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT
135 D PAR
136 F J=0:0 S J=$O(^TMP("RARPT-HL7",$J,CNT,J)) Q:'J S X1=^(J),X=$E(X1,1,125) D PAR I $L(X1)>125 S X=$E(X1,126,999) D PAR
137 I X=""!(LIN'="") S L=999 D P2
138 Q
139FORMAT ; Format report text for Escape Character delimited codes.
140 S Y=X N T,Q
141 I Y["\S\" S Q=$F(Y,"\S\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"))_$E(Y,Q,$L(X)),Y=X
142 I Y["\R\" S Q=$F(Y,"\R\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),2)_$E(Y,Q,$L(X)),Y=X
143 I Y["\E\" S Q=$F(Y,"\E\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),3)_$E(Y,Q,$L(X)),Y=X
144 I Y["\T\" S Q=$F(Y,"\T\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),4)_$E(Y,Q,$L(X)),Y=X
145 I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT
146 Q
147PAR ; Build text paragraph
148 S LIN=LIN_X
149P1 I $L(LIN)<80 Q
150 F L=80:-1:1 Q:$E(LIN,L)=" "
151 D P2 S LIN=$E(LIN,L+1,999) G P1
152P2 ; Set node
153 ; If Addendum and Report text is a space don't process
154 I $P(SEGMNT,HL("FS"),1)=1,RAXADEDN="A",RANODE="RATXT",$E(LIN,1,L-1)=" " Q
155 S RARCNT(OBXTYP)=$G(RARCNT(OBXTYP))+1
156 S ^TMP("RARPT-REC",$J,RASUB,RANODE,RARCNT(OBXTYP))=$E(LIN,1,L-1)
157 F I=1:1:RACN S RARRR="RARPT-REC-"_I S:$D(^TMP(RARRR,$J)) ^TMP(RARRR,$J,RASUB,RANODE,RARCNT(OBXTYP))=$E(LIN,1,L-1)
158 Q
159 ;
160GENACK ; Compile the 'ACK' segment, generate the 'ACK' message.
161 Q:'$G(RACKYES)
162 S MSA1="AA"
163 Q:$E($G(HL("SAN")),1,3)'="RA-" ; Don't allow non RA namespaced interfaces
164 I $D(RAERR) S MSA1=$S($G(HL("SAN"))="RA-PSCRIBE-TCP":"AE",1:"AR")
165 ; Added next line to support MedSpeak interface. Must re-initialize
166 ; FS and EC's before sending ACK.
167 D:$G(HL("SAN"))="RA-CLIENT-TCP" INIT^HLFNC2("RA VOICE TCP SERVER RPT",.HL)
168 S HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$S($D(RAERR):HL("FS")_RAERR,1:"")
169 ; 06/22/2006 KAM CHANGED NEXT TWO LINES FOR RA*5*71
170 S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1
171 K HLRESLT D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT)
172 Q
Note: See TracBrowser for help on using the repository browser.