RAHLBMS ;HIRMFO/REL,GJC-Bridge, MedSpeak compatible to HL7 v1.6 ;11/18/97 12:12
;;5.0;Radiology/Nuclear Medicine;**4**;Mar 16, 1998
EN1 ; Build the ^TMP("RARPT-REC" global when we receive the
; message from HL7.
S RASUB=HL("MID") K RAERR
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()
S ^TMP("RARPT-REC",$J,RASUB,"VENDOR")="IBM/MEDSPEAK"
F I=1:1 X HLNEXT Q:HLQUIT'>0 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))
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")=$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
; Save off E-Sig information (if it exists)
S:$D(HL("ESIG")) ^TMP("RARPT-REC",$J,RASUB,"RAESIG")=HL("ESIG")
;
OBR ; Pick data off the 'OBR' segment.
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)
I $P(SEGMNT,HL("FS"),3)]"" D
. N RADTCN S RADTCN=$P(SEGMNT,HL("FS"),3)
. S:$P($P(RADTCN,$E(HL("ECH"))),"-")]"" ^TMP("RARPT-REC",$J,RASUB,"RADTI")=$P($P(RADTCN,$E(HL("ECH"))),"-")
. S:$P($P(RADTCN,$E(HL("ECH"))),"-",2)]"" ^TMP("RARPT-REC",$J,RASUB,"RACNI")=$P($P(RADTCN,$E(HL("ECH"))),"-",2)
. S:$P(RADTCN,$E(HL("ECH")),2)]"" ^TMP("RARPT-REC",$J,RASUB,"RALONGCN")=$P(RADTCN,$E(HL("ECH")),2)
. Q
S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,25,HL("FS")) K RAHL70
I RAHLD="" S RAERR="Missing Report Status" D XIT Q
I "AFR"'[RAHLD S RAERR="Invalid Report Status" D XIT Q
S ^TMP("RARPT-REC",$J,RASUB,"RASTAT")=RAHLD
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 ; if one partial match found, return the entry ien
. Q
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"
. Q
I $D(RAERR) D XIT Q
; can't get resident info from medspeak
S ^TMP("RARPT-REC",$J,RASUB,"RAVERF")=RAVERF,^("RATRANSCRIPT")=RAVERF,^("RASTAFF")=RAVERF,^("RAWHOCHANGE")=RAVERF
;
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)
. S SEGMNT=$P(SEGMNT,HL("FS"),2,9999)
. I $P(SEGMNT,HL("FS"),3)']"" S RAERR="Missing Observation Identifier" Q
. S OBXTYP=$P(SEGMNT,HL("FS"),3),OBXTYP=$E(OBXTYP,$F(OBXTYP,"&")) S:OBXTYP="" OBXTYP=" "
. I "IDR"'[OBXTYP S RAERR="Invalid Observation Identifier" Q
. D RPT Q
XIT ; Clean up environment, quit
D INIT^HLFNC2("RA VOICE TCP SERVER RPT",.HL) ;field separators must be cleared and reset prior to sending ACK to prevent mixed/wrong separators in ACK
I $D(RAERR) D GENACK G XIT1
I $D(^TMP("RARPT-REC",$J)) D EN1^RAHLO I $D(RAERR) D GENACK
XIT1 K ^TMP("RARPT-REC",$J) ; kill storage area for current HL7 message id
K ^TMP("RARPT-HL7",$J) ; clean up HL7 storage
K CNT,OBXTYPE,X1,LIN,RADATE,RADTCN,RAERR,RAESIG,RAHLD,RANODE,RARCNT
K RAVERF,RASUB,SEGMNT
Q
RPT ; Save off Report Text data.
S RANODE=$S(OBXTYP="D":"RADX",OBXTYP="I":"RAIMP",1:"RATXT"),LIN=""
S X=$P(SEGMNT,HL("FS"),5) 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
S RARCNT(OBXTYP)=$G(RARCNT(OBXTYP))+1
S ^TMP("RARPT-REC",$J,RASUB,RANODE,RARCNT(OBXTYP))=$E(LIN,1,L-1) Q
;
GENACK ; Compile the 'ACK' segment, generate the 'ACK' message.
S HLA("HLA",1)="MSA"_HL("FS")_$S($D(RAERR):"AR",1:"AA")_HL("FS")_HL("MID")_$S($D(RAERR):HL("FS")_RAERR,1:"")
S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1,HLRESLTA=HL("MID")
D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.HLRESTLA)
Q
VFIER ; Check if the RAVERF string is a partial match to an entry in file
; 200. If if is, check to see that is a partial match to only ONE
; active provider entry in file 200.
I '$L(RAVERF) S RAERR="Missing Provider information" Q
K RAVCNT,RAVIEN,RAVLGTH,RAVPS
S RAVLGTH=$L(RAVERF) ; length of the RAVERF string
S RAVCNT=0,RAVS1=RAVERF
F S RAVS1=$O(^VA(200,"B",RAVS1)) Q:RAVS1=""!($E(RAVS1,1,RAVLGTH)'=RAVERF) D Q:RAVCNT>1
. ; return subscripts that have the RAVERF string as the first
. ; 1 - RAVLGTH chars of RAVS1
. S RAVIEN=0
. F S RAVIEN=$O(^VA(200,"B",RAVS1,RAVIEN)) Q:RAVIEN'>0 D Q:RAVCNT>1
.. S RAVPS=$G(^VA(200,RAVIEN,"PS"))
.. S:'$P(RAVPS,"^",4)!($P(RAVPS,"^",4)>DT) RAVCNT=RAVCNT+1
.. I RAVCNT=1,('$D(RAVIEN(RAVCNT))#2) S RAVIEN(RAVCNT)=RAVIEN ; when
.. ; we find the first active provider save the provider ien off
.. ; in a local array.
.. Q
. Q
I RAVCNT=0 S RAERR="Invalid Provider Name" Q ; partial match not found
I RAVCNT>1 S RAERR="Non-Unique Provider Name" Q ; >1 partial match
S RAVERF=$G(RAVIEN(1)) S:'RAVERF RAERR="Provider Name Entry Error"
K RAVCNT,RAVIEN,RAVLGTH,RAVPS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAHLBMS 5731 printed Oct 16, 2024@18:35:52 Page 2
RAHLBMS ;HIRMFO/REL,GJC-Bridge, MedSpeak compatible to HL7 v1.6 ;11/18/97 12:12
+1 ;;5.0;Radiology/Nuclear Medicine;**4**;Mar 16, 1998
EN1 ; Build the ^TMP("RARPT-REC" global when we receive the
+1 ; message from HL7.
+2 SET RASUB=HL("MID")
KILL RAERR
+3 ; clean area that holds data from HL7
KILL ^TMP("RARPT-HL7",$JOB)
+4 ; kill storage area for new HL7 message id
KILL ^TMP("RARPT-REC",$JOB,RASUB)
+5 SET ^TMP("RARPT-REC",$JOB,RASUB,"RADATE")=$$DT^XLFDT()
+6 SET ^TMP("RARPT-REC",$JOB,RASUB,"VENDOR")="IBM/MEDSPEAK"
+7 FOR I=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
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)
+8 SET CNT=2
SET SEGMNT=$GET(^TMP("RARPT-HL7",$JOB,CNT))
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")=$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 ; Save off E-Sig information (if it exists)
+12 if $DATA(HL("ESIG"))
SET ^TMP("RARPT-REC",$JOB,RASUB,"RAESIG")=HL("ESIG")
+13 ;
OBR ; Pick data off the 'OBR' segment.
+1 ; 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
+2 IF $PIECE($GET(SEGMNT),HL("FS"))'="OBR"
SET RAERR="Missing OBR segment"
DO XIT
QUIT
+3 SET SEGMNT=$PIECE(SEGMNT,HL("FS"),2,99999)
+4 IF $PIECE(SEGMNT,HL("FS"),3)]""
Begin DoDot:1
+5 NEW RADTCN
SET RADTCN=$PIECE(SEGMNT,HL("FS"),3)
+6 if $PIECE($PIECE(RADTCN,$EXTRACT(HL("ECH"))),"-")]""
SET ^TMP("RARPT-REC",$JOB,RASUB,"RADTI")=$PIECE($PIECE(RADTCN,$EXTRACT(HL("ECH"))),"-")
+7 if $PIECE($PIECE(RADTCN,$EXTRACT(HL("ECH"))),"-",2)]""
SET ^TMP("RARPT-REC",$JOB,RASUB,"RACNI")=$PIECE($PIECE(RADTCN,$EXTRACT(HL("ECH"))),"-",2)
+8 if $PIECE(RADTCN,$EXTRACT(HL("ECH")),2)]""
SET ^TMP("RARPT-REC",$JOB,RASUB,"RALONGCN")=$PIECE(RADTCN,$EXTRACT(HL("ECH")),2)
+9 QUIT
End DoDot:1
+10 SET RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,25,HL("FS"))
KILL RAHL70
+11 IF RAHLD=""
SET RAERR="Missing Report Status"
DO XIT
QUIT
+12 IF "AFR"'[RAHLD
SET RAERR="Invalid Report Status"
DO XIT
QUIT
+13 SET ^TMP("RARPT-REC",$JOB,RASUB,"RASTAT")=RAHLD
+14 SET RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,32,HL("FS"))
KILL RAHL70
+15 IF RAHLD']""
SET RAERR="Missing Provider ID"
DO XIT
QUIT
+16 SET RAVERF=RAHLD
+17 ; ----- Check the validity of the provider name -----
+18 ; check for a partial match in file 200
IF '$DATA(^VA(200,"B",RAVERF))
Begin DoDot:1
+19 ; if one partial match found, return the entry ien
DO VFIER
+20 QUIT
End DoDot:1
+21 ; $D(^VA(200,"B",RAVERF)) true, get the entry ien
IF '$TEST
Begin DoDot:1
+22 SET RAVERF=$ORDER(^VA(200,"B",RAVERF,0))
+23 if 'RAVERF
SET RAERR="Invalid Provider Name"
+24 QUIT
End DoDot:1
+25 IF $DATA(RAERR)
DO XIT
QUIT
+26 ; can't get resident info from medspeak
+27 SET ^TMP("RARPT-REC",$JOB,RASUB,"RAVERF")=RAVERF
SET ^("RATRANSCRIPT")=RAVERF
SET ^("RASTAFF")=RAVERF
SET ^("RAWHOCHANGE")=RAVERF
+28 ;
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 IF $PIECE(SEGMNT,HL("FS"),3)']""
SET RAERR="Missing Observation Identifier"
QUIT
+4 SET OBXTYP=$PIECE(SEGMNT,HL("FS"),3)
SET OBXTYP=$EXTRACT(OBXTYP,$FIND(OBXTYP,"&"))
if OBXTYP=""
SET OBXTYP=" "
+5 IF "IDR"'[OBXTYP
SET RAERR="Invalid Observation Identifier"
QUIT
+6 DO RPT
QUIT
End DoDot:1
if $DATA(RAERR)
QUIT
XIT ; Clean up environment, quit
+1 ;field separators must be cleared and reset prior to sending ACK to prevent mixed/wrong separators in ACK
DO INIT^HLFNC2("RA VOICE TCP SERVER RPT",.HL)
+2 IF $DATA(RAERR)
DO GENACK
GOTO XIT1
+3 IF $DATA(^TMP("RARPT-REC",$JOB))
DO EN1^RAHLO
IF $DATA(RAERR)
DO GENACK
XIT1 ; kill storage area for current HL7 message id
KILL ^TMP("RARPT-REC",$JOB)
+1 ; clean up HL7 storage
KILL ^TMP("RARPT-HL7",$JOB)
+2 KILL CNT,OBXTYPE,X1,LIN,RADATE,RADTCN,RAERR,RAESIG,RAHLD,RANODE,RARCNT
+3 KILL RAVERF,RASUB,SEGMNT
+4 QUIT
RPT ; Save off Report Text data.
+1 SET RANODE=$SELECT(OBXTYP="D":"RADX",OBXTYP="I":"RAIMP",1:"RATXT")
SET LIN=""
+2 SET X=$PIECE(SEGMNT,HL("FS"),5)
DO PAR
+3 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
+4 IF X=""!(LIN'="")
SET L=999
DO P2
+5 QUIT
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 SET RARCNT(OBXTYP)=$GET(RARCNT(OBXTYP))+1
+2 SET ^TMP("RARPT-REC",$JOB,RASUB,RANODE,RARCNT(OBXTYP))=$EXTRACT(LIN,1,L-1)
QUIT
+3 ;
GENACK ; Compile the 'ACK' segment, generate the 'ACK' message.
+1 SET HLA("HLA",1)="MSA"_HL("FS")_$SELECT($DATA(RAERR):"AR",1:"AA")_HL("FS")_HL("MID")_$SELECT($DATA(RAERR):HL("FS")_RAERR,1:"")
+2 SET HLEID=HL("EID")
SET HLEIDS=HL("EIDS")
SET HLARYTYP="LM"
SET HLFORMAT=1
SET HLRESLTA=HL("MID")
+3 DO GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.HLRESTLA)
+4 QUIT
VFIER ; Check if the RAVERF string is a partial match to an entry in file
+1 ; 200. If if is, check to see that is a partial match to only ONE
+2 ; active provider entry in file 200.
+3 IF '$LENGTH(RAVERF)
SET RAERR="Missing Provider information"
QUIT
+4 KILL RAVCNT,RAVIEN,RAVLGTH,RAVPS
+5 ; length of the RAVERF string
SET RAVLGTH=$LENGTH(RAVERF)
+6 SET RAVCNT=0
SET RAVS1=RAVERF
+7 FOR
SET RAVS1=$ORDER(^VA(200,"B",RAVS1))
if RAVS1=""!($EXTRACT(RAVS1,1,RAVLGTH)'=RAVERF)
QUIT
Begin DoDot:1
+8 ; return subscripts that have the RAVERF string as the first
+9 ; 1 - RAVLGTH chars of RAVS1
+10 SET RAVIEN=0
+11 FOR
SET RAVIEN=$ORDER(^VA(200,"B",RAVS1,RAVIEN))
if RAVIEN'>0
QUIT
Begin DoDot:2
+12 SET RAVPS=$GET(^VA(200,RAVIEN,"PS"))
+13 if '$PIECE(RAVPS,"^",4)!($PIECE(RAVPS,"^",4)>DT)
SET RAVCNT=RAVCNT+1
+14 ; when
IF RAVCNT=1
IF ('$DATA(RAVIEN(RAVCNT))#2)
SET RAVIEN(RAVCNT)=RAVIEN
+15 ; we find the first active provider save the provider ien off
+16 ; in a local array.
+17 QUIT
End DoDot:2
if RAVCNT>1
QUIT
+18 QUIT
End DoDot:1
if RAVCNT>1
QUIT
+19 ; partial match not found
IF RAVCNT=0
SET RAERR="Invalid Provider Name"
QUIT
+20 ; >1 partial match
IF RAVCNT>1
SET RAERR="Non-Unique Provider Name"
QUIT
+21 SET RAVERF=$GET(RAVIEN(1))
if 'RAVERF
SET RAERR="Provider Name Entry Error"
+22 KILL RAVCNT,RAVIEN,RAVLGTH,RAVPS
+23 QUIT
