RAHLBKVR ;HIRMFO/GJC-Bridge, Kurzweil compatible to HL7 v1.5 ;12/31/97 12:05
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
EN1 ; Build the ^TMP("RARPT-REC" global when we
; receive the message from HL7.
; HLDA-ien of the record in ^HL(772, should be defined.
K ^TMP("RARPT-REC",$J) S RASUB=HLDA
I '$G(HLDUZ) S RAERR="Invalid Access Code" D XIT Q
S ^TMP("RARPT-REC",$J,RASUB,"RADATE")=$$DT^XLFDT()
S ^TMP("RARPT-REC",$J,RASUB,"VENDOR")="KURZWEIL"
;If OBR-32 exists use it as verifying phys even if HLDUZ has resident
; or staff classif
S CNT=2,SEGMNT=$G(^HL(772,RASUB,"IN",CNT,0))
PID ; Pick data off the 'PID' segment.
I $P(SEGMNT,HLFS)="PID" D
. S SEGMNT=$P(SEGMNT,HLFS,2,99999)
. I $P($P(SEGMNT,HLFS,3),$E(HLECH))]"" D
.. S ^TMP("RARPT-REC",$J,RASUB,"RADFN")=$P($P(SEGMNT,HLFS,3),$E(HLECH))
.. Q
. I $P(SEGMNT,HLFS,19)]"" D
.. S ^TMP("RARPT-REC",$J,RASUB,"RASSN")=$P(SEGMNT,HLFS,19)
.. Q
. Q
E S RAERR="Missing PID segment" D XIT Q
; Save off E-Sig information (if it exists)
S:$D(HLESIG) ^TMP("RARPT-REC",$J,RASUB,"RAESIG")=HLESIG
;
OBR ; Pick data off the 'OBR' segment.
K SEGMNT F S CNT=$O(^HL(772,RASUB,"IN",CNT)) Q:CNT="" S SEGMNT=$G(^(CNT,0)) Q:$P(SEGMNT,HLFS)="OBR" ; find the 'OBR' segment
I $P($G(SEGMNT),HLFS)'="OBR" S RAERR="Missing OBR segment" D XIT Q
S SEGMNT=$P(SEGMNT,HLFS,2,99999)
I $P(SEGMNT,HLFS,4)]"" D
. N RADTCN S RADTCN=$P(SEGMNT,HLFS,4)
. S:$P($P(RADTCN,$E(HLECH)),"-")]"" ^TMP("RARPT-REC",$J,RASUB,"RADTI")=$P($P(RADTCN,$E(HLECH)),"-")
. S:$P($P(RADTCN,$E(HLECH)),"-",2)]"" ^TMP("RARPT-REC",$J,RASUB,"RACNI")=$P($P(RADTCN,$E(HLECH)),"-",2)
. S:$P(RADTCN,$E(HLECH),2)]"" ^TMP("RARPT-REC",$J,RASUB,"RALONGCN")=$P(RADTCN,$E(HLECH),2)
. Q
; note: must use $D on hlesig, as it's alphanumeric
S ^TMP("RARPT-REC",$J,RASUB,"RASTAT")=$S($D(HLESIG):"V",1:"P")
I $P(SEGMNT,HLFS,16)']"" S RAERR="Missing Provider ID" D XIT Q
S ^TMP("RARPT-REC",$J,RASUB,"RAVERF")=$S($D(HLESIG):HLDUZ,1:"")
S ^TMP("RARPT-REC",$J,RASUB,"RATRANSCRIPT")=$G(HLDUZ)
S ^TMP("RARPT-REC",$J,RASUB,"RASTAFF")=$S(+$P(SEGMNT,HLFS,32):+$P(SEGMNT,HLFS,32),1:$G(HLDUZ))
S ^TMP("RARPT-REC",$J,RASUB,"RARESIDENT")=$S(+$P(SEGMNT,HLFS,33):+$P(SEGMNT,HLFS,33),1:"")
S ^TMP("RARPT-REC",$J,RASUB,"RAWHOCHANGE")=$G(HLDUZ)
;
OBX ; Pick data off the 'OBX' segments
K SEGMNT F S CNT=$O(^HL(772,RASUB,"IN",CNT)) Q:CNT="" S SEGMNT=$G(^(CNT,0)) D:$P(SEGMNT,HLFS)="OBX" Q:$D(RAERR)
. S SEGMNT=$P(SEGMNT,HLFS,2,9999)
. I $P(SEGMNT,HLFS,3)']"" S RAERR="Missing Observation Identifier" Q
. S OBXTYP=$P($P(SEGMNT,HLFS,3),$E(HLECH))
. I "IDR"'[OBXTYP S RAERR="Invalid Observation Identifier" Q
. D:OBXTYP="I" IMP D:OBXTYP="R" RPT D:OBXTYP="D" DIAG
. Q
XIT ; Clean up environment, quit
I $D(^TMP("RARPT-REC",$J,RASUB)),('$D(RAERR)) D EN1^RAHLO
K ^TMP("RARPT-REC",$J,RASUB)
; Compile the 'ACK' segment
I $D(RAERR) S X1=HLSDATA(1) K HLSDATA S HLSDATA(1)=X1,HLERR=RAERR
S HLMTN="ACK",HLSDATA(2)="MSA"_HLFS_$S($D(HLERR):"AE",1:"AA")_HLFS_HLMID_$S($D(HLERR):HLFS_HLERR,1:"")
D:$D(HLTRANS) EN1^HLTRANS K CNT,OBXTYPE
K RADATE,RADCNT,RADTCN,RAERR,RAESIG,RAICNT,RARCNT,RASUB,RAVERF,SEGMNT
K RATRANSC,RAPRIMAR
Q
DIAG ; Save off Diagnostic Code data.
S RADCNT=+$G(RADCNT)+1
I $P(SEGMNT,HLFS,5)]"" D ; strip off leading spaces, save Dx code
. N DXSTR,X ; DXSTR=Dx code entered by user, X=char pos following space
. S DXSTR=$P(SEGMNT,HLFS,5)
. F S X=$F(DXSTR," ") Q:X'=2 S DXSTR=$E(DXSTR,X,999)
. S ^TMP("RARPT-REC",$J,RASUB,"RADX",RADCNT)=DXSTR
. Q
Q
IMP ; Save off Impression Text data.
S RAICNT=+$G(RAICNT)+1
S ^TMP("RARPT-REC",$J,RASUB,"RAIMP",RAICNT)=$P(SEGMNT,HLFS,5)
Q
RPT ; Save off Report Text data.
S RARCNT=+$G(RARCNT)+1
S ^TMP("RARPT-REC",$J,RASUB,"RATXT",RARCNT)=$P(SEGMNT,HLFS,5)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAHLBKVR 3809 printed Apr 09, 2024@21:40:52 Page 2
RAHLBKVR ;HIRMFO/GJC-Bridge, Kurzweil compatible to HL7 v1.5 ;12/31/97 12:05
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
EN1 ; Build the ^TMP("RARPT-REC" global when we
+1 ; receive the message from HL7.
+2 ; HLDA-ien of the record in ^HL(772, should be defined.
+3 KILL ^TMP("RARPT-REC",$JOB)
SET RASUB=HLDA
+4 IF '$GET(HLDUZ)
SET RAERR="Invalid Access Code"
DO XIT
QUIT
+5 SET ^TMP("RARPT-REC",$JOB,RASUB,"RADATE")=$$DT^XLFDT()
+6 SET ^TMP("RARPT-REC",$JOB,RASUB,"VENDOR")="KURZWEIL"
+7 ;If OBR-32 exists use it as verifying phys even if HLDUZ has resident
+8 ; or staff classif
+9 SET CNT=2
SET SEGMNT=$GET(^HL(772,RASUB,"IN",CNT,0))
PID ; Pick data off the 'PID' segment.
+1 IF $PIECE(SEGMNT,HLFS)="PID"
Begin DoDot:1
+2 SET SEGMNT=$PIECE(SEGMNT,HLFS,2,99999)
+3 IF $PIECE($PIECE(SEGMNT,HLFS,3),$EXTRACT(HLECH))]""
Begin DoDot:2
+4 SET ^TMP("RARPT-REC",$JOB,RASUB,"RADFN")=$PIECE($PIECE(SEGMNT,HLFS,3),$EXTRACT(HLECH))
+5 QUIT
End DoDot:2
+6 IF $PIECE(SEGMNT,HLFS,19)]""
Begin DoDot:2
+7 SET ^TMP("RARPT-REC",$JOB,RASUB,"RASSN")=$PIECE(SEGMNT,HLFS,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(HLESIG)
SET ^TMP("RARPT-REC",$JOB,RASUB,"RAESIG")=HLESIG
+13 ;
OBR ; Pick data off the 'OBR' segment.
+1 ; find the 'OBR' segment
KILL SEGMNT
FOR
SET CNT=$ORDER(^HL(772,RASUB,"IN",CNT))
if CNT=""
QUIT
SET SEGMNT=$GET(^(CNT,0))
if $PIECE(SEGMNT,HLFS)="OBR"
QUIT
+2 IF $PIECE($GET(SEGMNT),HLFS)'="OBR"
SET RAERR="Missing OBR segment"
DO XIT
QUIT
+3 SET SEGMNT=$PIECE(SEGMNT,HLFS,2,99999)
+4 IF $PIECE(SEGMNT,HLFS,4)]""
Begin DoDot:1
+5 NEW RADTCN
SET RADTCN=$PIECE(SEGMNT,HLFS,4)
+6 if $PIECE($PIECE(RADTCN,$EXTRACT(HLECH)),"-")]""
SET ^TMP("RARPT-REC",$JOB,RASUB,"RADTI")=$PIECE($PIECE(RADTCN,$EXTRACT(HLECH)),"-")
+7 if $PIECE($PIECE(RADTCN,$EXTRACT(HLECH)),"-",2)]""
SET ^TMP("RARPT-REC",$JOB,RASUB,"RACNI")=$PIECE($PIECE(RADTCN,$EXTRACT(HLECH)),"-",2)
+8 if $PIECE(RADTCN,$EXTRACT(HLECH),2)]""
SET ^TMP("RARPT-REC",$JOB,RASUB,"RALONGCN")=$PIECE(RADTCN,$EXTRACT(HLECH),2)
+9 QUIT
End DoDot:1
+10 ; note: must use $D on hlesig, as it's alphanumeric
+11 SET ^TMP("RARPT-REC",$JOB,RASUB,"RASTAT")=$SELECT($DATA(HLESIG):"V",1:"P")
+12 IF $PIECE(SEGMNT,HLFS,16)']""
SET RAERR="Missing Provider ID"
DO XIT
QUIT
+13 SET ^TMP("RARPT-REC",$JOB,RASUB,"RAVERF")=$SELECT($DATA(HLESIG):HLDUZ,1:"")
+14 SET ^TMP("RARPT-REC",$JOB,RASUB,"RATRANSCRIPT")=$GET(HLDUZ)
+15 SET ^TMP("RARPT-REC",$JOB,RASUB,"RASTAFF")=$SELECT(+$PIECE(SEGMNT,HLFS,32):+$PIECE(SEGMNT,HLFS,32),1:$GET(HLDUZ))
+16 SET ^TMP("RARPT-REC",$JOB,RASUB,"RARESIDENT")=$SELECT(+$PIECE(SEGMNT,HLFS,33):+$PIECE(SEGMNT,HLFS,33),1:"")
+17 SET ^TMP("RARPT-REC",$JOB,RASUB,"RAWHOCHANGE")=$GET(HLDUZ)
+18 ;
OBX ; Pick data off the 'OBX' segments
+1 KILL SEGMNT
FOR
SET CNT=$ORDER(^HL(772,RASUB,"IN",CNT))
if CNT=""
QUIT
SET SEGMNT=$GET(^(CNT,0))
if $PIECE(SEGMNT,HLFS)="OBX"
Begin DoDot:1
+2 SET SEGMNT=$PIECE(SEGMNT,HLFS,2,9999)
+3 IF $PIECE(SEGMNT,HLFS,3)']""
SET RAERR="Missing Observation Identifier"
QUIT
+4 SET OBXTYP=$PIECE($PIECE(SEGMNT,HLFS,3),$EXTRACT(HLECH))
+5 IF "IDR"'[OBXTYP
SET RAERR="Invalid Observation Identifier"
QUIT
+6 if OBXTYP="I"
DO IMP
if OBXTYP="R"
DO RPT
if OBXTYP="D"
DO DIAG
+7 QUIT
End DoDot:1
if $DATA(RAERR)
QUIT
XIT ; Clean up environment, quit
+1 IF $DATA(^TMP("RARPT-REC",$JOB,RASUB))
IF ('$DATA(RAERR))
DO EN1^RAHLO
+2 KILL ^TMP("RARPT-REC",$JOB,RASUB)
+3 ; Compile the 'ACK' segment
+4 IF $DATA(RAERR)
SET X1=HLSDATA(1)
KILL HLSDATA
SET HLSDATA(1)=X1
SET HLERR=RAERR
+5 SET HLMTN="ACK"
SET HLSDATA(2)="MSA"_HLFS_$SELECT($DATA(HLERR):"AE",1:"AA")_HLFS_HLMID_$SELECT($DATA(HLERR):HLFS_HLERR,1:"")
+6 if $DATA(HLTRANS)
DO EN1^HLTRANS
KILL CNT,OBXTYPE
+7 KILL RADATE,RADCNT,RADTCN,RAERR,RAESIG,RAICNT,RARCNT,RASUB,RAVERF,SEGMNT
+8 KILL RATRANSC,RAPRIMAR
+9 QUIT
DIAG ; Save off Diagnostic Code data.
+1 SET RADCNT=+$GET(RADCNT)+1
+2 ; strip off leading spaces, save Dx code
IF $PIECE(SEGMNT,HLFS,5)]""
Begin DoDot:1
+3 ; DXSTR=Dx code entered by user, X=char pos following space
NEW DXSTR,X
+4 SET DXSTR=$PIECE(SEGMNT,HLFS,5)
+5 FOR
SET X=$FIND(DXSTR," ")
if X'=2
QUIT
SET DXSTR=$EXTRACT(DXSTR,X,999)
+6 SET ^TMP("RARPT-REC",$JOB,RASUB,"RADX",RADCNT)=DXSTR
+7 QUIT
End DoDot:1
+8 QUIT
IMP ; Save off Impression Text data.
+1 SET RAICNT=+$GET(RAICNT)+1
+2 SET ^TMP("RARPT-REC",$JOB,RASUB,"RAIMP",RAICNT)=$PIECE(SEGMNT,HLFS,5)
+3 QUIT
RPT ; Save off Report Text data.
+1 SET RARCNT=+$GET(RARCNT)+1
+2 SET ^TMP("RARPT-REC",$JOB,RASUB,"RATXT",RARCNT)=$PIECE(SEGMNT,HLFS,5)
+3 QUIT
