76 lines
4.8 KiB
Mathematica
76 lines
4.8 KiB
Mathematica
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
|