- 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
- 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
