source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLBKVQ.m@ 1203

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