RAHLBKVQ ;HIRMFO/GJC-Bridge Query, Kurzweil compatible to HL7 v1.5 ;10/7/97 16:01
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
EN1 ; Build the ^TMP("RARPT-QRY" global from HL7's message global ^HL(772
; same global will be used for data returned back from DHCP
Q:'$D(HLDA)#2 ; HLDA-ien of the record in ^HL(772, should be defined
K ^TMP("RARPT-QRY",$J),^TMP("RARPT-QBAK",$J) S RASUB=HLDA
I '$G(HLDUZ) S RAERR="Invalid Access Code" D XIT G KILL
S RAHLREC=$G(^HL(772,RASUB,"IN",+$O(^HL(772,RASUB,"IN",1)),0))
I $P(RAHLREC,HLFS)'="QRD" S RAERR="Missing QRD segment" D XIT G KILL
S SEGMENT=$P(RAHLREC,HLFS,2,99999)
S ^TMP("RARPT-QRY",$J,RASUB,"RAVERF")=$G(HLDUZ)
S ^TMP("RARPT-QRY",$J,RASUB,"RANUMREC")=+$P(SEGMENT,HLFS,7)
S:$P(SEGMENT,HLFS,10)="PATIENT" ^TMP("RARPT-QRY",$J,RASUB,"RASSN")=$P(SEGMENT,HLFS,8) ; if patient grab the patient's ssn
S:$P(SEGMENT,HLFS,10)="EXAM" ^TMP("RARPT-QRY",$J,RASUB,"RAEXAM")=$P(SEGMENT,HLFS,8) ; if exam grab the exam's case number
D EN1^RAHLQ
XIT ; compile the 'ACK' segment, kill variables and quit
S:$D(RAERR) $P(HLSDATA(1),HLFS,9)="ACK" S HLMTN=$P(HLSDATA(1),HLFS,9)
I $D(RAERR) S X1=HLSDATA(1) K HLSDATA S HLSDATA(1)=X1
S HLSDATA(2)="MSA"_HLFS_$S($D(RAERR):"AE",1:"AA")_HLFS_HLMID_$S($D(RAERR):HLFS_RAERR,1:"")
S HLSDATA(3)=$G(RAHLREC),$P(HLSDATA(3),HLFS,7)=$S($D(RAEXAM):1_$E(HLECH)_"RD",'$D(RARECNT):0,1:(RARECNT-1)_$E(HLECH)_"RD")
D SETUP
D:$D(HLTRANS) EN1^HLTRANS
KILL K DFN,DIWF,DIWL,DIWR,GMRAL,I,PI,RACN,RACN0,RACNI,RADFN,RADISP,RADTE,RADTE0,RADTI,RAERR,RAESIG,RAEXAM,RAHLREC,RAI
K RAMDIV,RAMDV,RAMEMLOW,RAMLC,RAN,RANUMREC,RAOBR,RAOBX,RAPID,RAPRTSET,RAPRV,RARECNT,RARPT,RASSN,RASTATUS,RASUB,RAVERF,SEGMENT,VA,VADM,VAERR,X,X0,X1,Y
K ^TMP("RARPT-QRY",$J),^TMP("RARPT-QBAK",$J)
Q
SETUP ;setup HLSDATA() from each "record" of ^TMP("RARPT-QBAK",$J,RARECNT,*)
; re-use var RARECNT
S RAN=3 ; subscript of the TMP global for 'PID', 'OBR', 'OBX' nodes
; 3 is reserved for the QRD
S RARECNT=0 F S RARECNT=$O(^TMP("RARPT-QBAK",$J,RARECNT)) Q:'RARECNT D REC
Q
REC ; -- PID --
; set vendor-calculated variables
S ^TMP("RARPT-QBAK",$J,RARECNT,"PID3")=$$M11^HLFNC(^TMP("RARPT-QBAK",$J,RARECNT,"RADFN"))
S ^TMP("RARPT-QBAK",$J,RARECNT,"PID5")=$$HLNAME^HLFNC(^TMP("RARPT-QBAK",$J,RARECNT,"VADM(1)"))
S ^TMP("RARPT-QBAK",$J,RARECNT,"PID7")=$$HLDATE^HLFNC(^TMP("RARPT-QBAK",$J,RARECNT,"VADM(3)"))
S RADTE0=^TMP("RARPT-QBAK",$J,RARECNT,"RADTE0")
S RADTE0=$S(RADTE0:$$HLDATE^HLFNC(RADTE0),1:HLQ)
S RAPRV=^TMP("RARPT-QBAK",$J,RARECNT,"RAPRV")
S ^TMP("RARPT-QBAK",$J,RARECNT,"OBR16B")=$S(RAPRV]"":$$HLNAME^HLFNC(RAPRV),1:"")
S ^TMP("RARPT-QBAK",$J,RARECNT,"OBR7")=RADTE0 ;exm dt/tm in HL7 pkg fmt
S ^TMP("RARPT-QBAK",$J,RARECNT,"OBR22")=RADTE0
;
S X1="",X1="PID"_HLFS_HLFS_HLFS_$G(^TMP("RARPT-QBAK",$J,RARECNT,"PID3"))_HLFS_HLFS_$G(^("PID5"))_HLFS_HLFS_$G(^("PID7"))_HLFS_$G(^("PID8"))
S:$G(^TMP("RARPT-QBAK",$J,RARECNT,"PID19"))]"" $P(X1,HLFS,20)=^("PID19")
S RAN=RAN+1,HLSDATA(RAN)=X1
; -- OBR --
S X1="",X1="OBR"_HLFS_HLFS_HLFS_HLFS_$G(^TMP("RARPT-QBAK",$J,RARECNT,"OBR4A"))_$E(HLECH)_$G(^("OBR4B"))_$E(HLECH)_"L"_HLFS_HLFS_HLFS_HLQ_HLFS_HLQ_HLFS_HLQ_HLFS_HLFS_HLFS_HLFS_HLFS_HLQ_HLFS_HLFS
S:$G(^TMP("RARPT-QBAK",$J,RARECNT,"OBR16A"))]"" X1=X1_^("OBR16A")_$E(HLECH)_$G(^("OBR16B"))
S $P(X1,HLFS,8)=$G(^TMP("RARPT-QBAK",$J,RARECNT,"OBR7"))
S $P(X1,HLFS,23)=$G(^TMP("RARPT-QBAK",$J,RARECNT,"OBR22"))
S $P(X1,HLFS,21)=$G(^TMP("RARPT-QBAK",$J,RARECNT,"OBR20"))
S RAN=RAN+1,HLSDATA(RAN)=X1
; -- OBX --
; Next line can be 'uncommented' out for Lanier units
; S RAN=RAN+1,HLSDATA(RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"P"_$E(HLECH)_"PROCEDURE"_$E(HLECH)_"L"_HLFS_HLFS_$G(^TMP("RARPT-QBAK",$J,RARECNT,"LAN-A"))_$E(HLECH)_$G(^("LAN-B"))_$E(HLECH)_"L"
; set flags if print set and/or lowest case of print set
; For Lanier units, comment out next line
S RAN=RAN+1,HLSDATA(RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"P"_$E(HLECH)_"PROCEDURE"_$E(HLECH)_"L"_HLFS_HLFS_$G(^TMP("RARPT-QBAK",$J,RARECNT,"OBX5")) D OBX11
; -- OBX modifiers --
S RAN=RAN+1
S HLSDATA(RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"M"_$E(HLECH)_"MODIFIERS"_$E(HLECH)_"L"_HLFS_HLFS_$G(^TMP("RARPT-QBAK",$J,RARECNT,"OBX5-MOD")) D OBX11
; -- OBX clinical history --
I $D(^TMP("RARPT-QBAK",$J,RARECNT,"OBX-HIST-NONE")) S RAN=RAN+1,HLSDATA(RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"H"_$E(HLECH)_"HISTORY"_$E(HLECH)_"L"_HLFS_HLFS_^("OBX-HIST-NONE") D OBX11 G ALLER
G:'$D(^UTILITY($J,"W")) ALLER S I=0
; get history nodes from ^utility($j,"w")
F S I=$O(^UTILITY($J,"W",1,I)) Q:'I I $D(^(I,0)) S RAN=RAN+1,HLSDATA(RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"H"_$E(HLECH)_"HISTORY"_$E(HLECH)_"L"_HLFS_HLFS_^(0) D OBX11
K ^UTILITY($J,"W")
ALLER ; -- OBX allergies --
I $D(^TMP("RARPT-QBAK",$J,RARECNT,"OBX5-ALLE")) S RAN=RAN+1,HLSDATA(RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"A"_$E(HLECH)_"ALLERGIES"_$E(HLECH)_"L"_HLFS_HLFS_$G(^("OBX5-ALLE")) D OBX11
Q
OBX11 ; for HL7 1.5
S $P(HLSDATA(RAN),HLFS,12)=""""""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAHLBKVQ 4979 printed Nov 22, 2024@17:45:13 Page 2
RAHLBKVQ ;HIRMFO/GJC-Bridge Query, Kurzweil compatible to HL7 v1.5 ;10/7/97 16:01
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
EN1 ; Build the ^TMP("RARPT-QRY" global from HL7's message global ^HL(772
+1 ; same global will be used for data returned back from DHCP
+2 ; HLDA-ien of the record in ^HL(772, should be defined
if '$DATA(HLDA)#2
QUIT
+3 KILL ^TMP("RARPT-QRY",$JOB),^TMP("RARPT-QBAK",$JOB)
SET RASUB=HLDA
+4 IF '$GET(HLDUZ)
SET RAERR="Invalid Access Code"
DO XIT
GOTO KILL
+5 SET RAHLREC=$GET(^HL(772,RASUB,"IN",+$ORDER(^HL(772,RASUB,"IN",1)),0))
+6 IF $PIECE(RAHLREC,HLFS)'="QRD"
SET RAERR="Missing QRD segment"
DO XIT
GOTO KILL
+7 SET SEGMENT=$PIECE(RAHLREC,HLFS,2,99999)
+8 SET ^TMP("RARPT-QRY",$JOB,RASUB,"RAVERF")=$GET(HLDUZ)
+9 SET ^TMP("RARPT-QRY",$JOB,RASUB,"RANUMREC")=+$PIECE(SEGMENT,HLFS,7)
+10 ; if patient grab the patient's ssn
if $PIECE(SEGMENT,HLFS,10)="PATIENT"
SET ^TMP("RARPT-QRY",$JOB,RASUB,"RASSN")=$PIECE(SEGMENT,HLFS,8)
+11 ; if exam grab the exam's case number
if $PIECE(SEGMENT,HLFS,10)="EXAM"
SET ^TMP("RARPT-QRY",$JOB,RASUB,"RAEXAM")=$PIECE(SEGMENT,HLFS,8)
+12 DO EN1^RAHLQ
XIT ; compile the 'ACK' segment, kill variables and quit
+1 if $DATA(RAERR)
SET $PIECE(HLSDATA(1),HLFS,9)="ACK"
SET HLMTN=$PIECE(HLSDATA(1),HLFS,9)
+2 IF $DATA(RAERR)
SET X1=HLSDATA(1)
KILL HLSDATA
SET HLSDATA(1)=X1
+3 SET HLSDATA(2)="MSA"_HLFS_$SELECT($DATA(RAERR):"AE",1:"AA")_HLFS_HLMID_$SELECT($DATA(RAERR):HLFS_RAERR,1:"")
+4 SET HLSDATA(3)=$GET(RAHLREC)
SET $PIECE(HLSDATA(3),HLFS,7)=$SELECT($DATA(RAEXAM):1_$EXTRACT(HLECH)_"RD",'$DATA(RARECNT):0,1:(RARECNT-1)_$EXTRACT(HLECH)_"RD")
+5 DO SETUP
+6 if $DATA(HLTRANS)
DO EN1^HLTRANS
KILL KILL DFN,DIWF,DIWL,DIWR,GMRAL,I,PI,RACN,RACN0,RACNI,RADFN,RADISP,RADTE,RADTE0,RADTI,RAERR,RAESIG,RAEXAM,RAHLREC,RAI
+1 KILL RAMDIV,RAMDV,RAMEMLOW,RAMLC,RAN,RANUMREC,RAOBR,RAOBX,RAPID,RAPRTSET,RAPRV,RARECNT,RARPT,RASSN,RASTATUS,RASUB,RAVERF,SEGMENT,VA,VADM,VAERR,X,X0,X1,Y
+2 KILL ^TMP("RARPT-QRY",$JOB),^TMP("RARPT-QBAK",$JOB)
+3 QUIT
SETUP ;setup HLSDATA() from each "record" of ^TMP("RARPT-QBAK",$J,RARECNT,*)
+1 ; re-use var RARECNT
+2 ; subscript of the TMP global for 'PID', 'OBR', 'OBX' nodes
SET RAN=3
+3 ; 3 is reserved for the QRD
+4 SET RARECNT=0
FOR
SET RARECNT=$ORDER(^TMP("RARPT-QBAK",$JOB,RARECNT))
if 'RARECNT
QUIT
DO REC
+5 QUIT
REC ; -- PID --
+1 ; set vendor-calculated variables
+2 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"PID3")=$$M11^HLFNC(^TMP("RARPT-QBAK",$JOB,RARECNT,"RADFN"))
+3 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"PID5")=$$HLNAME^HLFNC(^TMP("RARPT-QBAK",$JOB,RARECNT,"VADM(1)"))
+4 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"PID7")=$$HLDATE^HLFNC(^TMP("RARPT-QBAK",$JOB,RARECNT,"VADM(3)"))
+5 SET RADTE0=^TMP("RARPT-QBAK",$JOB,RARECNT,"RADTE0")
+6 SET RADTE0=$SELECT(RADTE0:$$HLDATE^HLFNC(RADTE0),1:HLQ)
+7 SET RAPRV=^TMP("RARPT-QBAK",$JOB,RARECNT,"RAPRV")
+8 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"OBR16B")=$SELECT(RAPRV]"":$$HLNAME^HLFNC(RAPRV),1:"")
+9 ;exm dt/tm in HL7 pkg fmt
SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"OBR7")=RADTE0
+10 SET ^TMP("RARPT-QBAK",$JOB,RARECNT,"OBR22")=RADTE0
+11 ;
+12 SET X1=""
SET X1="PID"_HLFS_HLFS_HLFS_$GET(^TMP("RARPT-QBAK",$JOB,RARECNT,"PID3"))_HLFS_HLFS_$GET(^("PID5"))_HLFS_HLFS_$GET(^("PID7"))_HLFS_$GET(^("PID8"))
+13 if $GET(^TMP("RARPT-QBAK",$JOB,RARECNT,"PID19"))]""
SET $PIECE(X1,HLFS,20)=^("PID19")
+14 SET RAN=RAN+1
SET HLSDATA(RAN)=X1
+15 ; -- OBR --
+16 SET X1=""
SET X1="OBR"_HLFS_HLFS_HLFS_HLFS_$GET(^TMP("RARPT-QBAK",$JOB,RARECNT,"OBR4A"))_$EXTRACT(HLECH)_$GET(^("OBR4B"))_$EXTRACT(HLECH)_"L"_HLFS_HLFS_HLFS_HLQ_HLFS_HLQ_HLFS_HLQ_HLFS_HLFS_HLFS_HLFS_HLFS_HLQ_HLFS_HLFS
+17 if $GET(^TMP("RARPT-QBAK",$JOB,RARECNT,"OBR16A"))]""
SET X1=X1_^("OBR16A")_$EXTRACT(HLECH)_$GET(^("OBR16B"))
+18 SET $PIECE(X1,HLFS,8)=$GET(^TMP("RARPT-QBAK",$JOB,RARECNT,"OBR7"))
+19 SET $PIECE(X1,HLFS,23)=$GET(^TMP("RARPT-QBAK",$JOB,RARECNT,"OBR22"))
+20 SET $PIECE(X1,HLFS,21)=$GET(^TMP("RARPT-QBAK",$JOB,RARECNT,"OBR20"))
+21 SET RAN=RAN+1
SET HLSDATA(RAN)=X1
+22 ; -- OBX --
+23 ; Next line can be 'uncommented' out for Lanier units
+24 ; S RAN=RAN+1,HLSDATA(RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"P"_$E(HLECH)_"PROCEDURE"_$E(HLECH)_"L"_HLFS_HLFS_$G(^TMP("RARPT-QBAK",$J,RARECNT,"LAN-A"))_$E(HLECH)_$G(^("LAN-B"))_$E(HLECH)_"L"
+25 ; set flags if print set and/or lowest case of print set
+26 ; For Lanier units, comment out next line
+27 SET RAN=RAN+1
SET HLSDATA(RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"P"_$EXTRACT(HLECH)_"PROCEDURE"_$EXTRACT(HLECH)_"L"_HLFS_HLFS_$GET(^TMP("RARPT-QBAK",$JOB,RARECNT,"OBX5"))
DO OBX11
+28 ; -- OBX modifiers --
+29 SET RAN=RAN+1
+30 SET HLSDATA(RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"M"_$EXTRACT(HLECH)_"MODIFIERS"_$EXTRACT(HLECH)_"L"_HLFS_HLFS_$GET(^TMP("RARPT-QBAK",$JOB,RARECNT,"OBX5-MOD"))
DO OBX11
+31 ; -- OBX clinical history --
+32 IF $DATA(^TMP("RARPT-QBAK",$JOB,RARECNT,"OBX-HIST-NONE"))
SET RAN=RAN+1
SET HLSDATA(RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"H"_$EXTRACT(HLECH)_"HISTORY"_$EXTRACT(HLECH)_"L"_HLFS_HLFS_^("OBX-HIST-NONE")
DO OBX11
GOTO ALLER
+33 if '$DATA(^UTILITY($JOB,"W"))
GOTO ALLER
SET I=0
+34 ; get history nodes from ^utility($j,"w")
+35 FOR
SET I=$ORDER(^UTILITY($JOB,"W",1,I))
if 'I
QUIT
IF $DATA(^(I,0))
SET RAN=RAN+1
SET HLSDATA(RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"H"_$EXTRACT(HLECH)_"HISTORY"_$EXTRACT(HLECH)_"L"_HLFS_HLFS_^(0)
DO OBX11
+36 KILL ^UTILITY($JOB,"W")
ALLER ; -- OBX allergies --
+1 IF $DATA(^TMP("RARPT-QBAK",$JOB,RARECNT,"OBX5-ALLE"))
SET RAN=RAN+1
SET HLSDATA(RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"A"_$EXTRACT(HLECH)_"ALLERGIES"_$EXTRACT(HLECH)_"L"_HLFS_HLFS_$GET(^("OBX5-ALLE"))
DO OBX11
+2 QUIT
OBX11 ; for HL7 1.5
+1 SET $PIECE(HLSDATA(RAN),HLFS,12)=""""""
+2 QUIT
