- 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 Mar 13, 2025@21:40 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
