source: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLBKVQ.m@ 628

Last change on this file since 628 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.8 KB
Line 
1RAHLBKVQ ;HIRMFO/GJC-Bridge Query, Kurzweil compatible to HL7 v1.5 ;10/7/97 16:01
2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
3EN1 ; Build the ^TMP("RARPT-QRY" global from HL7's message global ^HL(772
4 ; same global will be used for data returned back from DHCP
5 Q:'$D(HLDA)#2 ; HLDA-ien of the record in ^HL(772, should be defined
6 K ^TMP("RARPT-QRY",$J),^TMP("RARPT-QBAK",$J) S RASUB=HLDA
7 I '$G(HLDUZ) S RAERR="Invalid Access Code" D XIT G KILL
8 S RAHLREC=$G(^HL(772,RASUB,"IN",+$O(^HL(772,RASUB,"IN",1)),0))
9 I $P(RAHLREC,HLFS)'="QRD" S RAERR="Missing QRD segment" D XIT G KILL
10 S SEGMENT=$P(RAHLREC,HLFS,2,99999)
11 S ^TMP("RARPT-QRY",$J,RASUB,"RAVERF")=$G(HLDUZ)
12 S ^TMP("RARPT-QRY",$J,RASUB,"RANUMREC")=+$P(SEGMENT,HLFS,7)
13 S:$P(SEGMENT,HLFS,10)="PATIENT" ^TMP("RARPT-QRY",$J,RASUB,"RASSN")=$P(SEGMENT,HLFS,8) ; if patient grab the patient's ssn
14 S:$P(SEGMENT,HLFS,10)="EXAM" ^TMP("RARPT-QRY",$J,RASUB,"RAEXAM")=$P(SEGMENT,HLFS,8) ; if exam grab the exam's case number
15 D EN1^RAHLQ
16XIT ; compile the 'ACK' segment, kill variables and quit
17 S:$D(RAERR) $P(HLSDATA(1),HLFS,9)="ACK" S HLMTN=$P(HLSDATA(1),HLFS,9)
18 I $D(RAERR) S X1=HLSDATA(1) K HLSDATA S HLSDATA(1)=X1
19 S HLSDATA(2)="MSA"_HLFS_$S($D(RAERR):"AE",1:"AA")_HLFS_HLMID_$S($D(RAERR):HLFS_RAERR,1:"")
20 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")
21 D SETUP
22 D:$D(HLTRANS) EN1^HLTRANS
23KILL K DFN,DIWF,DIWL,DIWR,GMRAL,I,PI,RACN,RACN0,RACNI,RADFN,RADISP,RADTE,RADTE0,RADTI,RAERR,RAESIG,RAEXAM,RAHLREC,RAI
24 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
25 K ^TMP("RARPT-QRY",$J),^TMP("RARPT-QBAK",$J)
26 Q
27SETUP ;setup HLSDATA() from each "record" of ^TMP("RARPT-QBAK",$J,RARECNT,*)
28 ; re-use var RARECNT
29 S RAN=3 ; subscript of the TMP global for 'PID', 'OBR', 'OBX' nodes
30 ; 3 is reserved for the QRD
31 S RARECNT=0 F S RARECNT=$O(^TMP("RARPT-QBAK",$J,RARECNT)) Q:'RARECNT D REC
32 Q
33REC ; -- PID --
34 ; set vendor-calculated variables
35 S ^TMP("RARPT-QBAK",$J,RARECNT,"PID3")=$$M11^HLFNC(^TMP("RARPT-QBAK",$J,RARECNT,"RADFN"))
36 S ^TMP("RARPT-QBAK",$J,RARECNT,"PID5")=$$HLNAME^HLFNC(^TMP("RARPT-QBAK",$J,RARECNT,"VADM(1)"))
37 S ^TMP("RARPT-QBAK",$J,RARECNT,"PID7")=$$HLDATE^HLFNC(^TMP("RARPT-QBAK",$J,RARECNT,"VADM(3)"))
38 S RADTE0=^TMP("RARPT-QBAK",$J,RARECNT,"RADTE0")
39 S RADTE0=$S(RADTE0:$$HLDATE^HLFNC(RADTE0),1:HLQ)
40 S RAPRV=^TMP("RARPT-QBAK",$J,RARECNT,"RAPRV")
41 S ^TMP("RARPT-QBAK",$J,RARECNT,"OBR16B")=$S(RAPRV]"":$$HLNAME^HLFNC(RAPRV),1:"")
42 S ^TMP("RARPT-QBAK",$J,RARECNT,"OBR7")=RADTE0 ;exm dt/tm in HL7 pkg fmt
43 S ^TMP("RARPT-QBAK",$J,RARECNT,"OBR22")=RADTE0
44 ;
45 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"))
46 S:$G(^TMP("RARPT-QBAK",$J,RARECNT,"PID19"))]"" $P(X1,HLFS,20)=^("PID19")
47 S RAN=RAN+1,HLSDATA(RAN)=X1
48 ; -- OBR --
49 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
50 S:$G(^TMP("RARPT-QBAK",$J,RARECNT,"OBR16A"))]"" X1=X1_^("OBR16A")_$E(HLECH)_$G(^("OBR16B"))
51 S $P(X1,HLFS,8)=$G(^TMP("RARPT-QBAK",$J,RARECNT,"OBR7"))
52 S $P(X1,HLFS,23)=$G(^TMP("RARPT-QBAK",$J,RARECNT,"OBR22"))
53 S $P(X1,HLFS,21)=$G(^TMP("RARPT-QBAK",$J,RARECNT,"OBR20"))
54 S RAN=RAN+1,HLSDATA(RAN)=X1
55 ; -- OBX --
56 ; Next line can be 'uncommented' out for Lanier units
57 ; 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"
58 ; set flags if print set and/or lowest case of print set
59 ; For Lanier units, comment out next line
60 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
61 ; -- OBX modifiers --
62 S RAN=RAN+1
63 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
64 ; -- OBX clinical history --
65 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
66 G:'$D(^UTILITY($J,"W")) ALLER S I=0
67 ; get history nodes from ^utility($j,"w")
68 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
69 K ^UTILITY($J,"W")
70ALLER ; -- OBX allergies --
71 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
72 Q
73OBX11 ; for HL7 1.5
74 S $P(HLSDATA(RAN),HLFS,12)=""""""
75 Q
Note: See TracBrowser for help on using the repository browser.