RAHLTCPB ; HIRMFO/REL,GJC,BNT,PAV - Rad/Nuc Med HL7 TCP/IP Bridge;05/21/99 ;17 Apr 2019 3:25 PM
;;5.0;Radiology/Nuclear Medicine;**12,17,25,51,71,81,84,106,157**;Mar 16, 1998;Build 2
; 07/05/2006 BAY/KAM Remedy Call 124379 Eliminate unneeded ORM msgs
; 09/01/2006 Accomodate multiple ORC/OBR segments Patch 81
;
;Integration Agreements
;----------------------
;INIT^HLFNC2(2161); GENACK^HLMA1(2165); $$DT^XLFDT(10103)
;
EN1 ; Build the ^TMP("RARPT-REC" global when we receive the
; 07/05/2006 Remedy Call 124379 message from HL7. If RAHLTCPB is defined, do not broadcast ORM messages. As of the writing
; of patch 71, RAHLTCPB is referenced in RAHLTCPB, UPSTAT^RAUTL0, & UP2^RAUTL1 Generic provider: RADIOLOGY,OUTSIDE SERVICE
N RATELE,RATELENM,RATELEPI,RATELEKN,RATELEDR,RATELEDF
D TELE^RAHLRPTT ;Patch 84
;** branch to new HL7 logic when the HL7 version surpasses 2.3 **
I HL("VER")>2.3,($T(^RAHLTCPX))'="" GOTO EN1^RAHLTCPX
S RASUB=HL("MID"),RAHLTCPB=1 K RAERR
;**********************************************
;RACN is Counter - Indication that ORC segment present
N RACN,II,L,RAPRSET,RARRR,XX,RAHLD,RARSDNT,RATRSCRP S (RACN,RAPRSET)=0 ; = Address where we go to store data...
;**********************************************
K ^TMP("RARPT-HL7",$J) ; clean area that holds data from HL7
K ^TMP("RARPT-REC",$J,RASUB) ; kill storage area for new HL7 message id
S ^TMP("RARPT-REC",$J,RASUB,"RADATE")=$$DT^XLFDT()
F I=1:1 X HLNEXT Q:HLQUIT'>0 D
.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)
.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)
S CNT=2,SEGMNT=$G(^TMP("RARPT-HL7",$J,CNT))
S:'$$GETSFLAG^RAHLRU($G(HL("SAN")),$G(HL("MTN")),$G(HL("ETN")),$G(HL("VER"))) RANOSEND=$G(HL("SAN"))
S ^TMP("RARPT-REC",$J,RASUB,"VENDOR")=$G(HL("SAN"))
PID ; Pick data off the 'PID' segment.
I $P(SEGMNT,HL("FS"))="PID" D
. S SEGMNT=$P(SEGMNT,HL("FS"),2,99999)
. I $P($P(SEGMNT,HL("FS"),3),$E(HL("ECH")))]"" D
.. S (^TMP("RARPT-REC",$J,RASUB,"RADFN"),RADFN)=$P($P(SEGMNT,HL("FS"),3),$E(HL("ECH")))
.. Q
. I $P(SEGMNT,HL("FS"),19)]"" D
.. S ^TMP("RARPT-REC",$J,RASUB,"RASSN")=$P(SEGMNT,HL("FS"),19)
.. Q
. Q
E S RAERR="Missing PID segment" D XIT Q
I '(+$G(^TMP("RARPT-REC",$J,RASUB,"RADFN"))) D Q
.S RAERR="Invalid Patient ID"
.D XIT
; Save off E-Sig information (if it exists)
S:$D(HL("ESIG")) ^TMP("RARPT-REC",$J,RASUB,"RAESIG")=HL("ESIG")
;********************************
ORC ; Pick data off the 'ORC' segment.
D
.N CNT1 S CNT1=CNT,RARRR=""
111 .K SEGMNT S CNT1=$O(^TMP("RARPT-HL7",$J,CNT1)) Q:CNT1="" S SEGMNT=$G(^(CNT1))
.I $P(SEGMNT,HL("FS"))="PV1" S CNT=CNT1 G 111
.Q:$P(SEGMNT,HL("FS"))'="ORC"
.S CNT=CNT1 Q:$P(SEGMNT,HL("FS"),2)'="CN" ; find the 'ORC' segment
.S RACN=RACN+1,RARRR="RARPT-REC-"_RACN
;********************************
OBR ; Pick data off the 'OBR' segment.
I $L(RARRR) K ^TMP(RARRR,$J) M ^TMP(RARRR,$J)=^TMP("RARPT-REC",$J) ;Merge if OBR without Report
S:'$L(RARRR) RARRR="RARPT-REC"
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
I $P($G(SEGMNT),HL("FS"))'="OBR" S RAERR="Missing OBR segment" D XIT Q
S SEGMNT=$P(SEGMNT,HL("FS"),2,99999) K RADTI,RACNI
I $P(SEGMNT,HL("FS"),3)]"" D
. N RADTCN S RADTCN=$P(SEGMNT,HL("FS"),3)
. S:$P($P(RADTCN,$E(HL("ECH"))),"-")]"" (^TMP(RARRR,$J,RASUB,"RADTI"),RADTI)=$P($P(RADTCN,$E(HL("ECH"))),"-")
. S:$P($P(RADTCN,$E(HL("ECH"))),"-",2)]"" (^TMP(RARRR,$J,RASUB,"RACNI"),RACNI)=$P($P(RADTCN,$E(HL("ECH"))),"-",2)
. S:$P(RADTCN,$E(HL("ECH")),2)["&L" RADTCN=$TR(RADTCN,"&","^")
. S:$P(RADTCN,$E(HL("ECH")),2)]"" ^TMP(RARRR,$J,RASUB,"RALONGCN")=$P(RADTCN,$E(HL("ECH")),2)
. Q
I $G(RADTI)'>0 S RAERR="Invalid exam registration timestamp" D XIT Q
I $G(RACNI)'>0 S RAERR="Invalid exam record IEN" D XIT Q
S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,25,HL("FS")) K RAHL70
I RAHLD="" S RAERR="Missing Report Status" D XIT Q
;P106
I "^A^F^R^VAQ^"'[("^"_RAHLD_"^") D D XIT Q
.S RAERR="Invalid Report Status: "_RAHLD QUIT
;
S ^TMP(RARRR,$J,RASUB,"RASTAT")=RAHLD
G:$P(RARRR,"-",3) 112 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,32,HL("FS")) K RAHL70
I RAHLD']"" S RAERR="Missing Provider ID" D XIT Q
S RAVERF=RAHLD
; ----- Check the validity of the provider name -----
I '$D(^VA(200,"B",RAVERF)) D ; check for a partial match in file 200
. D VFIER^RAHLO3 ; if one partial match found, return the entry ien
E D ; $D(^VA(200,"B",RAVERF)) true, get the entry ien
. S RAVERF=$O(^VA(200,"B",RAVERF,0))
. S:'RAVERF RAERR="Invalid Provider Name: "_RAHLD
; can't get resident info from medspeak
S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,33,HL("FS")),RARSDNT="" K RAHL70
I RAHLD]"" D
. S RARSDNT=$P(RAHLD,$E(HL("ECH"),4)) I '$D(^VA(200,+RARSDNT,0)) S RARSDNT=""
S RAHLD="",RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,35,HL("FS")),RATRSCRP="" K RAHL70
I RAHLD]"" D
. S RATRSCRP=$P(RAHLD,$E(HL("ECH"),4)) I '$D(^VA(200,+RATRSCRP,0)) S RATRSCRP=""
S ^TMP(RARRR,$J,RASUB,"RAVERF")=RAVERF
S ^TMP(RARRR,$J,RASUB,"RATRANSCRIPT")=$S(RATRSCRP]"":RATRSCRP,RARSDNT]"":RARSDNT,1:RAVERF)
S:$G(RARSDNT) ^TMP(RARRR,$J,RASUB,"RARESIDENT")=RARSDNT
S ^TMP(RARRR,$J,RASUB,"RASTAFF")=RAVERF,^("RAWHOCHANGE")=RAVERF
I $D(RAERR) D XIT Q
D ESIG^RAHLO3
;
;If last OBR set provider info to all OBRs
K XX F I=1:1:RACN S XX=RARRR_"-"_I D:$D(^TMP(XX,$J,RASUB))
.N XXX M XXX=^TMP(XX,$J,RASUB),^TMP(XX,$J,RASUB)=^TMP(RARRR,$J,RASUB),^TMP(XX,$J,RASUB)=XXX
112 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
I $D(RADTI),'$D(RAPRSET(RADTI)) D ;Get array of printset for date...
.N RAPRTSET,RACN,RASUB,CNT
.K XX D EN2^RAUTL20(.XX) M:$D(XX) RAPRSET(RADTI)=XX K RAPRSET(RADTI,RACNI)
;
OBX ; Pick data off the 'OBX' segments
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
. S SEGMNT=$P(SEGMNT,HL("FS"),2,9999)
. Q:SEGMNT?@("1"""_HL("FS")_"""."""_HL("FS")_"""") ;Quit if OBX is something as: OBX||||||||
. I $P(SEGMNT,HL("FS"),3)']"" S RAERR="Missing Observation Identifier" Q
. S OBXTYP=$P($P(SEGMNT,HL("FS"),3),$E(HL("ECH"))),OBXTYP=$E($P(OBXTYP,"&",2))
. S OBX2CE=""
. S:OBXTYP="" OBXTYP=" "
. I OBXTYP=" "&($P(SEGMNT,HL("FS"),2)="CE") D
. . I $P(SEGMNT,HL("FS"),5)=" " S OBXTYP="F" Q
. . S OBX2CE=1,OBXTYP="D" Q
. I "IDRF"'[OBXTYP S RAERR="Invalid Observation Identifier" Q
. D RPT Q
XIT ; RACKYES Indicates that Ack will be sent on the last OBR segment or at Error condition.
N RACKYES
I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK G XIT1
I $D(^TMP("RARPT-REC",$J)) S:'RACN RACKYES=1 D G:$D(RAERR) XIT1
.N RACN D EN1^RAHLO I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK
F II=1:1:RACN S RARRR="RARPT-REC-"_II D:$D(^TMP(RARRR,$J)) Q:$D(RAERR)
.K ^TMP("RARPT-REC",$J) M ^TMP("RARPT-REC",$J)=^TMP(RARRR,$J) K ^TMP(RARRR,$J)
.S RACKYES=(II=RACN) N II,RACN D EN1^RAHLO I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK
XIT1 K ^TMP("RARPT-REC",$J) ; kill storage area for current HL7 message id
F II=1:1:RACN S RARRR="RARPT-REC-"_II K:$D(^TMP(RARRR,$J)) ^TMP(RARRR,$J)
K ^TMP("RARPT-HL7",$J) ; clean up HL7 storage
K CNT,OBXTYP,X1,LIN,RADATE,RADTCN,RAERR,RAESIG,RAHLD,RAHLTCPB,RANODE,RARCNT
K RAVERF,RASUB,SEGMNT,RANOSEND,MSA1,OBX2CE,RADX,RADX1,RADX2,RADX3
Q
RPT ; Save off Report Text data.
N RAXADEDN
S RAXADEDN=^TMP("RARPT-REC",$J,RASUB,"RASTAT")
S RANODE=$S(OBXTYP="D":"RADX",OBXTYP="I":"RAIMP",1:"RATXT"),LIN=""
I OBX2CE D Q
. ; KLM/p157 update DX Code processing for v2.3 to accomodate VR passing a primary designation.
. ; We will need to set LIN (RADX,RADX2,RADX3)to the entire dx code passed (ie 1^NORMAL^P).
. S X=$P(SEGMNT,HL("FS"),5),RADX1=$P(X,$E(HL("ECH"),2))
. S LIN=RADX1,L=999 D P2 S LIN=X
. Q:X'["~" F J=0:0 S J=$O(^TMP("RARPT-HL7",$J,CNT,J)) Q:'J S X1=^(J),LIN=LIN_X1 Q
. S RADX=LIN,RADX2=$P(RADX,"~",2) S:RADX2]"" LIN=RADX2 D P2 ;p157
. S RADX3=$P(RADX,"~",3) Q:RADX3']"" S LIN=RADX3 D P2 Q ;p157
S X=$P(SEGMNT,HL("FS"),5)
I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT
I $G(RATELE),$D(RATELEKN),X[RATELEKN S X=$P(X,RATELEKN,2),RATELENM=$P(X,"-"),RATELEPI=$TR($P(X,"-",2)," ","") ;SFVAMC/DAD/9-7-2007/Comment out the quit Q ;Patch 84
D PAR
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
I X=""!(LIN'="") S L=999 D P2
Q
;
PAR ; Build text paragraph
S LIN=LIN_X
P1 I $L(LIN)<80 Q
F L=80:-1:1 Q:$E(LIN,L)=" "
D P2 S LIN=$E(LIN,L+1,999) G P1
P2 ; Set node
; If Addendum and Report text is a space don't process
I $P(SEGMNT,HL("FS"),1)=1,RAXADEDN="A",RANODE="RATXT",$E(LIN,1,L-1)=" " Q
S RARCNT(OBXTYP)=$G(RARCNT(OBXTYP))+1
;KLM/p157 Setting "PDX" node for the Primary indicator (to be used in RAHLO2)
I RANODE="RADX" D
. I $P($G(LIN),"^",3)="P" S ^TMP("RARPT-REC",$J,RASUB,RANODE,"PDX",RARCNT(OBXTYP))=+LIN
. S LIN=+LIN
. Q
S ^TMP("RARPT-REC",$J,RASUB,RANODE,RARCNT(OBXTYP))=$E(LIN,1,L-1)
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)
Q
;
GENACK ; Compile the 'ACK' segment, generate the 'ACK' message.
Q:'$G(RACKYES)
S MSA1="AA"
Q:$E($G(HL("SAN")),1,3)'="RA-" ; Don't allow non RA namespaced interfaces
I $D(RAERR) S MSA1=$S($G(HL("SAN"))="RA-PSCRIBE-TCP"!$G(RATELE):"AE",1:"AR")
; Added next line to support MedSpeak interface. Must re-initialize
; FS and EC's before sending ACK.
D:$G(HL("SAN"))="RA-CLIENT-TCP" INIT^HLFNC2("RA VOICE TCP SERVER RPT",.HL)
S HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$S($D(RAERR):HL("FS")_RAERR,1:"")
; 06/22/2006 KAM CHANGED NEXT TWO LINES FOR RA*5*71
S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1
K HLRESLT D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT)
Q
;
FORMAT ; Format report text for Escape Character delimited codes.
S Y=X N T,Q
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
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
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
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
I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAHLTCPB 10668 printed Apr 09, 2024@21:39:14 Page 2
RAHLTCPB ; HIRMFO/REL,GJC,BNT,PAV - Rad/Nuc Med HL7 TCP/IP Bridge;05/21/99 ;17 Apr 2019 3:25 PM
+1 ;;5.0;Radiology/Nuclear Medicine;**12,17,25,51,71,81,84,106,157**;Mar 16, 1998;Build 2
+2 ; 07/05/2006 BAY/KAM Remedy Call 124379 Eliminate unneeded ORM msgs
+3 ; 09/01/2006 Accomodate multiple ORC/OBR segments Patch 81
+4 ;
+5 ;Integration Agreements
+6 ;----------------------
+7 ;INIT^HLFNC2(2161); GENACK^HLMA1(2165); $$DT^XLFDT(10103)
+8 ;
EN1 ; Build the ^TMP("RARPT-REC" global when we receive the
+1 ; 07/05/2006 Remedy Call 124379 message from HL7. If RAHLTCPB is defined, do not broadcast ORM messages. As of the writing
+2 ; of patch 71, RAHLTCPB is referenced in RAHLTCPB, UPSTAT^RAUTL0, & UP2^RAUTL1 Generic provider: RADIOLOGY,OUTSIDE SERVICE
+3 NEW RATELE,RATELENM,RATELEPI,RATELEKN,RATELEDR,RATELEDF
+4 ;Patch 84
DO TELE^RAHLRPTT
+5 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 **
+6 IF HL("VER")>2.3
IF ($TEXT(^RAHLTCPX))'=""
GOTO EN1^RAHLTCPX
+7 SET RASUB=HL("MID")
SET RAHLTCPB=1
KILL RAERR
+8 ;**********************************************
+9 ;RACN is Counter - Indication that ORC segment present
+10 ; = Address where we go to store data...
NEW RACN,II,L,RAPRSET,RARRR,XX,RAHLD,RARSDNT,RATRSCRP
SET (RACN,RAPRSET)=0
+11 ;**********************************************
+12 ; clean area that holds data from HL7
KILL ^TMP("RARPT-HL7",$JOB)
+13 ; kill storage area for new HL7 message id
KILL ^TMP("RARPT-REC",$JOB,RASUB)
+14 SET ^TMP("RARPT-REC",$JOB,RASUB,"RADATE")=$$DT^XLFDT()
+15 FOR I=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+16 IF '$LENGTH(HLNODE)
IF $LENGTH($GET(HLNODE(1)))
SET HLNODE=HLNODE(1)
KILL HLNODE(1)
FOR J=2:1
if '$DATA(HLNODE(J))
QUIT
SET HLNODE(J-1)=HLNODE(J)
KILL HLNODE(J)
+17 SET ^TMP("RARPT-HL7",$JOB,I)=HLNODE
SET J=0
FOR
SET J=$ORDER(HLNODE(J))
if 'J
QUIT
SET ^TMP("RARPT-HL7",$JOB,I,J)=HLNODE(J)
End DoDot:1
+18 SET CNT=2
SET SEGMNT=$GET(^TMP("RARPT-HL7",$JOB,CNT))
+19 if '$$GETSFLAG^RAHLRU($GET(HL("SAN")),$GET(HL("MTN")),$GET(HL("ETN")),$GET(HL("VER")))
SET RANOSEND=$GET(HL("SAN"))
+20 SET ^TMP("RARPT-REC",$JOB,RASUB,"VENDOR")=$GET(HL("SAN"))
PID ; Pick data off the 'PID' segment.
+1 IF $PIECE(SEGMNT,HL("FS"))="PID"
Begin DoDot:1
+2 SET SEGMNT=$PIECE(SEGMNT,HL("FS"),2,99999)
+3 IF $PIECE($PIECE(SEGMNT,HL("FS"),3),$EXTRACT(HL("ECH")))]""
Begin DoDot:2
+4 SET (^TMP("RARPT-REC",$JOB,RASUB,"RADFN"),RADFN)=$PIECE($PIECE(SEGMNT,HL("FS"),3),$EXTRACT(HL("ECH")))
+5 QUIT
End DoDot:2
+6 IF $PIECE(SEGMNT,HL("FS"),19)]""
Begin DoDot:2
+7 SET ^TMP("RARPT-REC",$JOB,RASUB,"RASSN")=$PIECE(SEGMNT,HL("FS"),19)
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 IF '$TEST
SET RAERR="Missing PID segment"
DO XIT
QUIT
+11 IF '(+$GET(^TMP("RARPT-REC",$JOB,RASUB,"RADFN")))
Begin DoDot:1
+12 SET RAERR="Invalid Patient ID"
+13 DO XIT
End DoDot:1
QUIT
+14 ; Save off E-Sig information (if it exists)
+15 if $DATA(HL("ESIG"))
SET ^TMP("RARPT-REC",$JOB,RASUB,"RAESIG")=HL("ESIG")
+16 ;********************************
ORC ; Pick data off the 'ORC' segment.
+1 Begin DoDot:1
+2 NEW CNT1
SET CNT1=CNT
SET RARRR=""
111 KILL SEGMNT
SET CNT1=$ORDER(^TMP("RARPT-HL7",$JOB,CNT1))
if CNT1=""
QUIT
SET SEGMNT=$GET(^(CNT1))
+1 IF $PIECE(SEGMNT,HL("FS"))="PV1"
SET CNT=CNT1
GOTO 111
+2 if $PIECE(SEGMNT,HL("FS"))'="ORC"
QUIT
+3 ; find the 'ORC' segment
SET CNT=CNT1
if $PIECE(SEGMNT,HL("FS"),2)'="CN"
QUIT
+4 SET RACN=RACN+1
SET RARRR="RARPT-REC-"_RACN
End DoDot:1
+5 ;********************************
OBR ; Pick data off the 'OBR' segment.
+1 ;Merge if OBR without Report
IF $LENGTH(RARRR)
KILL ^TMP(RARRR,$JOB)
MERGE ^TMP(RARRR,$JOB)=^TMP("RARPT-REC",$JOB)
+2 if '$LENGTH(RARRR)
SET RARRR="RARPT-REC"
+3 ; find the 'OBR' segment
KILL SEGMNT
FOR
SET CNT=$ORDER(^TMP("RARPT-HL7",$JOB,CNT))
if CNT=""
QUIT
SET SEGMNT=$GET(^(CNT))
if $PIECE(SEGMNT,HL("FS"))="OBR"
QUIT
+4 IF $PIECE($GET(SEGMNT),HL("FS"))'="OBR"
SET RAERR="Missing OBR segment"
DO XIT
QUIT
+5 SET SEGMNT=$PIECE(SEGMNT,HL("FS"),2,99999)
KILL RADTI,RACNI
+6 IF $PIECE(SEGMNT,HL("FS"),3)]""
Begin DoDot:1
+7 NEW RADTCN
SET RADTCN=$PIECE(SEGMNT,HL("FS"),3)
+8 if $PIECE($PIECE(RADTCN,$EXTRACT(HL("ECH"))),"-")]""
SET (^TMP(RARRR,$JOB,RASUB,"RADTI"),RADTI)=$PIECE($PIECE(RADTCN,$EXTRACT(HL("ECH"))),"-")
+9 if $PIECE($PIECE(RADTCN,$EXTRACT(HL("ECH"))),"-",2)]""
SET (^TMP(RARRR,$JOB,RASUB,"RACNI"),RACNI)=$PIECE($PIECE(RADTCN,$EXTRACT(HL("ECH"))),"-",2)
+10 if $PIECE(RADTCN,$EXTRACT(HL("ECH")),2)["&L"
SET RADTCN=$TRANSLATE(RADTCN,"&","^")
+11 if $PIECE(RADTCN,$EXTRACT(HL("ECH")),2)]""
SET ^TMP(RARRR,$JOB,RASUB,"RALONGCN")=$PIECE(RADTCN,$EXTRACT(HL("ECH")),2)
+12 QUIT
End DoDot:1
+13 IF $GET(RADTI)'>0
SET RAERR="Invalid exam registration timestamp"
DO XIT
QUIT
+14 IF $GET(RACNI)'>0
SET RAERR="Invalid exam record IEN"
DO XIT
QUIT
+15 SET RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,25,HL("FS"))
KILL RAHL70
+16 IF RAHLD=""
SET RAERR="Missing Report Status"
DO XIT
QUIT
+17 ;P106
+18 IF "^A^F^R^VAQ^"'[("^"_RAHLD_"^")
Begin DoDot:1
+19 SET RAERR="Invalid Report Status: "_RAHLD
QUIT
End DoDot:1
DO XIT
QUIT
+20 ;
+21 SET ^TMP(RARRR,$JOB,RASUB,"RASTAT")=RAHLD
+22 if $PIECE(RARRR,"-",3)
GOTO 112
SET RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,32,HL("FS"))
KILL RAHL70
+23 IF RAHLD']""
SET RAERR="Missing Provider ID"
DO XIT
QUIT
+24 SET RAVERF=RAHLD
+25 ; ----- Check the validity of the provider name -----
+26 ; check for a partial match in file 200
IF '$DATA(^VA(200,"B",RAVERF))
Begin DoDot:1
+27 ; if one partial match found, return the entry ien
DO VFIER^RAHLO3
End DoDot:1
+28 ; $D(^VA(200,"B",RAVERF)) true, get the entry ien
IF '$TEST
Begin DoDot:1
+29 SET RAVERF=$ORDER(^VA(200,"B",RAVERF,0))
+30 if 'RAVERF
SET RAERR="Invalid Provider Name: "_RAHLD
End DoDot:1
+31 ; can't get resident info from medspeak
+32 SET RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,33,HL("FS"))
SET RARSDNT=""
KILL RAHL70
+33 IF RAHLD]""
Begin DoDot:1
+34 SET RARSDNT=$PIECE(RAHLD,$EXTRACT(HL("ECH"),4))
IF '$DATA(^VA(200,+RARSDNT,0))
SET RARSDNT=""
End DoDot:1
+35 SET RAHLD=""
SET RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,35,HL("FS"))
SET RATRSCRP=""
KILL RAHL70
+36 IF RAHLD]""
Begin DoDot:1
+37 SET RATRSCRP=$PIECE(RAHLD,$EXTRACT(HL("ECH"),4))
IF '$DATA(^VA(200,+RATRSCRP,0))
SET RATRSCRP=""
End DoDot:1
+38 SET ^TMP(RARRR,$JOB,RASUB,"RAVERF")=RAVERF
+39 SET ^TMP(RARRR,$JOB,RASUB,"RATRANSCRIPT")=$SELECT(RATRSCRP]"":RATRSCRP,RARSDNT]"":RARSDNT,1:RAVERF)
+40 if $GET(RARSDNT)
SET ^TMP(RARRR,$JOB,RASUB,"RARESIDENT")=RARSDNT
+41 SET ^TMP(RARRR,$JOB,RASUB,"RASTAFF")=RAVERF
SET ^("RAWHOCHANGE")=RAVERF
+42 IF $DATA(RAERR)
DO XIT
QUIT
+43 DO ESIG^RAHLO3
+44 ;
+45 ;If last OBR set provider info to all OBRs
+46 KILL XX
FOR I=1:1:RACN
SET XX=RARRR_"-"_I
if $DATA(^TMP(XX,$JOB,RASUB))
Begin DoDot:1
+47 NEW XXX
MERGE XXX=^TMP(XX,$JOB,RASUB),^TMP(XX,$JOB,RASUB)=^TMP(RARRR,$JOB,RASUB),^TMP(XX,$JOB,RASUB)=XXX
End DoDot:1
112 IF $DATA(RADTI)
IF $DATA(RACNI)
IF $DATA(RAPRSET(RADTI,RACNI))
KILL RAPRSET(RADTI,RACNI),^TMP(RARRR,$JOB)
SET RACN=RACN-1
if $PIECE(RARRR,"-",3)
GOTO ORC
MERGE ^TMP(RARRR,$JOB)=^TMP("RARPT-REC-"_(RACN+1),$JOB)
KILL ^TMP("RARPT-REC-"_(RACN+1),$JOB)
GOTO OBX
+1 ;Get array of printset for date...
IF $DATA(RADTI)
IF '$DATA(RAPRSET(RADTI))
Begin DoDot:1
+2 NEW RAPRTSET,RACN,RASUB,CNT
+3 KILL XX
DO EN2^RAUTL20(.XX)
if $DATA(XX)
MERGE RAPRSET(RADTI)=XX
KILL RAPRSET(RADTI,RACNI)
End DoDot:1
+4 ;
OBX ; Pick data off the 'OBX' segments
+1 KILL SEGMNT
FOR
SET CNT=$ORDER(^TMP("RARPT-HL7",$JOB,CNT))
if CNT=""
QUIT
SET SEGMNT=$GET(^(CNT))
if $PIECE(SEGMNT,HL("FS"))="OBX"
Begin DoDot:1
+2 SET SEGMNT=$PIECE(SEGMNT,HL("FS"),2,9999)
+3 ;Quit if OBX is something as: OBX||||||||
if SEGMNT?@("1"""_HL("FS")_"""."""_HL("FS")_"""")
QUIT
+4 IF $PIECE(SEGMNT,HL("FS"),3)']""
SET RAERR="Missing Observation Identifier"
QUIT
+5 SET OBXTYP=$PIECE($PIECE(SEGMNT,HL("FS"),3),$EXTRACT(HL("ECH")))
SET OBXTYP=$EXTRACT($PIECE(OBXTYP,"&",2))
+6 SET OBX2CE=""
+7 if OBXTYP=""
SET OBXTYP=" "
+8 IF OBXTYP=" "&($PIECE(SEGMNT,HL("FS"),2)="CE")
Begin DoDot:2
+9 IF $PIECE(SEGMNT,HL("FS"),5)=" "
SET OBXTYP="F"
QUIT
+10 SET OBX2CE=1
SET OBXTYP="D"
QUIT
End DoDot:2
+11 IF "IDRF"'[OBXTYP
SET RAERR="Invalid Observation Identifier"
QUIT
+12 DO RPT
QUIT
End DoDot:1
if $DATA(RAERR)
QUIT
IF $PIECE(SEGMNT,HL("FS"))="ORC"
SET CNT=CNT-1
GOTO ORC
XIT ; RACKYES Indicates that Ack will be sent on the last OBR segment or at Error condition.
+1 NEW RACKYES
+2 IF $DATA(RAERR)
SET RACKYES=1
DO EN1^RAHLEXF
DO GENACK
GOTO XIT1
+3 IF $DATA(^TMP("RARPT-REC",$JOB))
if 'RACN
SET RACKYES=1
Begin DoDot:1
+4 NEW RACN
DO EN1^RAHLO
IF $DATA(RAERR)
SET RACKYES=1
DO EN1^RAHLEXF
DO GENACK
End DoDot:1
if $DATA(RAERR)
GOTO XIT1
+5 FOR II=1:1:RACN
SET RARRR="RARPT-REC-"_II
if $DATA(^TMP(RARRR,$JOB))
Begin DoDot:1
+6 KILL ^TMP("RARPT-REC",$JOB)
MERGE ^TMP("RARPT-REC",$JOB)=^TMP(RARRR,$JOB)
KILL ^TMP(RARRR,$JOB)
+7 SET RACKYES=(II=RACN)
NEW II,RACN
DO EN1^RAHLO
IF $DATA(RAERR)
SET RACKYES=1
DO EN1^RAHLEXF
DO GENACK
End DoDot:1
if $DATA(RAERR)
QUIT
XIT1 ; kill storage area for current HL7 message id
KILL ^TMP("RARPT-REC",$JOB)
+1 FOR II=1:1:RACN
SET RARRR="RARPT-REC-"_II
if $DATA(^TMP(RARRR,$JOB))
KILL ^TMP(RARRR,$JOB)
+2 ; clean up HL7 storage
KILL ^TMP("RARPT-HL7",$JOB)
+3 KILL CNT,OBXTYP,X1,LIN,RADATE,RADTCN,RAERR,RAESIG,RAHLD,RAHLTCPB,RANODE,RARCNT
+4 KILL RAVERF,RASUB,SEGMNT,RANOSEND,MSA1,OBX2CE,RADX,RADX1,RADX2,RADX3
+5 QUIT
RPT ; Save off Report Text data.
+1 NEW RAXADEDN
+2 SET RAXADEDN=^TMP("RARPT-REC",$JOB,RASUB,"RASTAT")
+3 SET RANODE=$SELECT(OBXTYP="D":"RADX",OBXTYP="I":"RAIMP",1:"RATXT")
SET LIN=""
+4 IF OBX2CE
Begin DoDot:1
+5 ; KLM/p157 update DX Code processing for v2.3 to accomodate VR passing a primary designation.
+6 ; We will need to set LIN (RADX,RADX2,RADX3)to the entire dx code passed (ie 1^NORMAL^P).
+7 SET X=$PIECE(SEGMNT,HL("FS"),5)
SET RADX1=$PIECE(X,$EXTRACT(HL("ECH"),2))
+8 SET LIN=RADX1
SET L=999
DO P2
SET LIN=X
+9 if X'["~"
QUIT
FOR J=0:0
SET J=$ORDER(^TMP("RARPT-HL7",$JOB,CNT,J))
if 'J
QUIT
SET X1=^(J)
SET LIN=LIN_X1
QUIT
+10 ;p157
SET RADX=LIN
SET RADX2=$PIECE(RADX,"~",2)
if RADX2]""
SET LIN=RADX2
DO P2
+11 ;p157
SET RADX3=$PIECE(RADX,"~",3)
if RADX3']""
QUIT
SET LIN=RADX3
DO P2
QUIT
End DoDot:1
QUIT
+12 SET X=$PIECE(SEGMNT,HL("FS"),5)
+13 IF X["\S\"!(X["\R\")!(X["\E\")!(X["\T\")
DO FORMAT
+14 ;SFVAMC/DAD/9-7-2007/Comment out the quit Q ;Patch 84
IF $GET(RATELE)
IF $DATA(RATELEKN)
IF X[RATELEKN
SET X=$PIECE(X,RATELEKN,2)
SET RATELENM=$PIECE(X,"-")
SET RATELEPI=$TRANSLATE($PIECE(X,"-",2)," ","")
+15 DO PAR
+16 FOR J=0:0
SET J=$ORDER(^TMP("RARPT-HL7",$JOB,CNT,J))
if 'J
QUIT
SET X1=^(J)
SET X=$EXTRACT(X1,1,125)
DO PAR
IF $LENGTH(X1)>125
SET X=$EXTRACT(X1,126,999)
DO PAR
+17 IF X=""!(LIN'="")
SET L=999
DO P2
+18 QUIT
+19 ;
PAR ; Build text paragraph
+1 SET LIN=LIN_X
P1 IF $LENGTH(LIN)<80
QUIT
+1 FOR L=80:-1:1
if $EXTRACT(LIN,L)=" "
QUIT
+2 DO P2
SET LIN=$EXTRACT(LIN,L+1,999)
GOTO P1
P2 ; Set node
+1 ; If Addendum and Report text is a space don't process
+2 IF $PIECE(SEGMNT,HL("FS"),1)=1
IF RAXADEDN="A"
IF RANODE="RATXT"
IF $EXTRACT(LIN,1,L-1)=" "
QUIT
+3 SET RARCNT(OBXTYP)=$GET(RARCNT(OBXTYP))+1
+4 ;KLM/p157 Setting "PDX" node for the Primary indicator (to be used in RAHLO2)
+5 IF RANODE="RADX"
Begin DoDot:1
+6 IF $PIECE($GET(LIN),"^",3)="P"
SET ^TMP("RARPT-REC",$JOB,RASUB,RANODE,"PDX",RARCNT(OBXTYP))=+LIN
+7 SET LIN=+LIN
+8 QUIT
End DoDot:1
+9 SET ^TMP("RARPT-REC",$JOB,RASUB,RANODE,RARCNT(OBXTYP))=$EXTRACT(LIN,1,L-1)
+10 FOR I=1:1:RACN
SET RARRR="RARPT-REC-"_I
if $DATA(^TMP(RARRR,$JOB))
SET ^TMP(RARRR,$JOB,RASUB,RANODE,RARCNT(OBXTYP))=$EXTRACT(LIN,1,L-1)
+11 QUIT
+12 ;
GENACK ; Compile the 'ACK' segment, generate the 'ACK' message.
+1 if '$GET(RACKYES)
QUIT
+2 SET MSA1="AA"
+3 ; Don't allow non RA namespaced interfaces
if $EXTRACT($GET(HL("SAN")),1,3)'="RA-"
QUIT
+4 IF $DATA(RAERR)
SET MSA1=$SELECT($GET(HL("SAN"))="RA-PSCRIBE-TCP"!$GET(RATELE):"AE",1:"AR")
+5 ; Added next line to support MedSpeak interface. Must re-initialize
+6 ; FS and EC's before sending ACK.
+7 if $GET(HL("SAN"))="RA-CLIENT-TCP"
DO INIT^HLFNC2("RA VOICE TCP SERVER RPT",.HL)
+8 SET HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$SELECT($DATA(RAERR):HL("FS")_RAERR,1:"")
+9 ; 06/22/2006 KAM CHANGED NEXT TWO LINES FOR RA*5*71
+10 SET HLEID=HL("EID")
SET HLEIDS=HL("EIDS")
SET HLARYTYP="LM"
SET HLFORMAT=1
+11 KILL HLRESLT
DO GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT)
+12 QUIT
+13 ;
FORMAT ; Format report text for Escape Character delimited codes.
+1 SET Y=X
NEW T,Q
+2 IF Y["\S\"
SET Q=$FIND(Y,"\S\")
SET T=Q-4
SET X=$EXTRACT(Y,1,T)_$EXTRACT(HL("ECH"))_$EXTRACT(Y,Q,$LENGTH(X))
SET Y=X
+3 IF Y["\R\"
SET Q=$FIND(Y,"\R\")
SET T=Q-4
SET X=$EXTRACT(Y,1,T)_$EXTRACT(HL("ECH"),2)_$EXTRACT(Y,Q,$LENGTH(X))
SET Y=X
+4 IF Y["\E\"
SET Q=$FIND(Y,"\E\")
SET T=Q-4
SET X=$EXTRACT(Y,1,T)_$EXTRACT(HL("ECH"),3)_$EXTRACT(Y,Q,$LENGTH(X))
SET Y=X
+5 IF Y["\T\"
SET Q=$FIND(Y,"\T\")
SET T=Q-4
SET X=$EXTRACT(Y,1,T)_$EXTRACT(HL("ECH"),4)_$EXTRACT(Y,Q,$LENGTH(X))
SET Y=X
+6 IF X["\S\"!(X["\R\")!(X["\E\")!(X["\T\")
DO FORMAT
+7 QUIT
+8 ;
