RAHLRPT1 ;HISC/GJC-Compiles HL7 'ORU' Message Type ; 4/26/01 10:40am
;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21
;
;Integration Agreements
;----------------------
;$$GET1^DIQ(2056); ^DIWP(10011);
;$$FMTHL7^XLFDT(10103); $$HLNAME^XLFNAME(3065)
;
EN(RADFN,RADTI,RACNI,RAEID) ;Called from all RA RPT* event driver protocols whose
;HL7 version exceeds version 2.3.
;
;Input Variables (from RAHLRPT):
; RADFN=file 2 IEN (DFN)
; RADTI=file 70 Exam subrec IEN (inverse date/time of exam)
; RACNI=file 70 Case subrecord IEN
; RAEID=ien of the event driver protocol (defined in RAHLRPC)
;Output variables:
; HLA("HLS", array containing HL7 msg
;
;Note: RAOBR(n+1) = OBR 'n' because our software begins
;building the segment with the segment header ('OBR')
;
;new some variables...
N %,DN,FT,I,J,PTR,X,Y
;initialize Rad/Nuc Med specific variables
D INIT^RAHLR1
PID ;Compile the 'PID' segment
D PID^RAHLRU1(RADFN)
OBR ;Compile 'OBR' Segment
;get pointer value to the rad/nuc med report; needed to build the OBR
S RAZRPT=+$P(RAZXAM,U,17)
;get rad/nuc med report zero node & the transcriptionist (if exists)
S RAZRPT=$G(^RARPT(RAZRPT,0)),RAZTRANS=+$G(^RARPT(+$P(RAZXAM,U,17),"T"))
;Set ID OBR-1
S RAOBR(2)=1
;Placer Order Number OBR-2 mmddyy-case#
;Filler Order Number OBR-3 mmddyy-case#
S (RAOBR(3),RAOBR(4))=RAZDAYCS
S RAZCPT=$P(RAZPROC,U,9),RAZCPT(0)=$$NAMCODE^RACPTMSC(RAZCPT,DT)
;RAZCPT(0)=CPT code from file 81^short name of CPT code from file 81
;RAOBR(4)=CPT code #81_comp sep_CPT code short name #81_comp sep_"C4"
; _comp sep_IEN file #71_comp sep_procedure name #71_comp sep_
; "99RAP"
;
S RAOBR(5)=$P(RAZCPT(0),U)_$E(HLECH)_$$ESCAPE^RAHLRU($P(RAZCPT(0),U,2))_$E(HLECH)_"C4"
S RAOBR(5)=RAOBR(5)_$E(HLECH)_+$P(RAZXAM,U,2)_$E(HLECH)_$$ESCAPE^RAHLRU($P(RAZPROC,U))_$E(HLECH)_"99RAP"
;Observation date/time OBR-7 (DATE REPORT ENTERED) 74;6
S RAOBR(8)=$$FMTHL7^XLFDT($P(RAZRPT,U,6))
;Specimen Source OBR-15 75.1;125 PROCEDURE MODIFIERS (mult: 75.1125)
;(left & right only)
S RAZPMOD=$$SPECSRC^RAHLRU1(+$P(RAZXAM,U,11))
S:$L(RAZPMOD) RAOBR(16)=$$REPEAT^RAHLRU1($E(HLECH),4)_$E(HLECH,4)_RAZPMOD
;
;Ordering Provider OBR-16 (REQUESTING PHYSICIAN) 75.1;14
I $P(RAZORD,U,14),($$GET1^DIQ(200,$P(RAZORD,U,14),.01)'="") D
.K RAZNME S RAZNME("FILE")=200,RAZNME("IENS")=$P(RAZORD,U,14)
.S RAZNME("FIELD")=.01
.S RAOBR(17)=$P(RAZORD,U,14)_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1))
.Q
;
;Call Back Phone numbers of Ordering Provider OBR-17
D
.N RAX,I,M S M="",I=0
.D NPFON^MAG7UFO("RAX",$P(RAZORD,U,14))
.F S I=$O(RAX(I)) Q:'I S M=M_$$ESCAPE^RAHLRU($G(RAX(I,1,1)))_$E(HLECH)_$G(RAX(I,2,1))_$E(HLECH)_$G(RAX(I,3,1))_$E(HLECH,2)
.S:$L(M) RAOBR(18)=$E(M,1,$L(M)-1)
;
;Placer Field 1 OBR-18 site id-mmddyy-case# (mirrors OBR-2 & OBR-3)
S RAOBR(19)=RAZDAYCS
;
;Placer Field 2 definition has been changed by a VistA Imaging request
;-> prior to 07/2007: inv. date/time of the exam concatenated to (by the
; dash) the exam record IEN (Placer Fld 2 OBR-19 = Filler Fld 1 OBR-20)
;-> after 07/2007: case number
;RAZDAYCS=sss-mmddyy-case# OR mmddyy-case#
S RAOBR(20)=$P(RAZDAYCS,"-",$L(RAZDAYCS,"-"))
;
;Filler Field 1 OBR-20 is defined as the site specific accession number:
;site id-mmddyy-case# Note: same value as OBR-18, OBR-2, & OBR-3
;(change effective 07/2007)
S RAOBR(21)=RAZDAYCS
;
;Filler Field 2 OBR-21 (change effective 07/2007)
;RAZRXAM defined in INIT^RAHLR1
S RAOBR(22)=$$OBR21^RAHLRU(HLECH,RAZRXAM)
;
;Results Rpt/Status Chng-date/time OBR-22
;verified: VERIFIED DATE 74;7
;unv'fied: DATE REPORT ENTERED 74;6
S:$P(RAZRPT,U,5)="V" RAOBR(23)=$$FMTHL7^XLFDT($P(RAZRPT,U,7))
S:$P(RAZRPT,U,5)'="V" RAOBR(23)=$$FMTHL7^XLFDT($P(RAZRPT,U,6))
;Status OBR-25 REPORT STATUS 74;5
;S:$D(^RARPT(+$P(RAZXAM,U,17),"ERR",1,0))#2 RAOBR(26)="C" ;corrected rt
S:'$D(RAOBR(26))#2 RAOBR(26)=$S(($P(RAZRPT,U,5)="V")!($P(RAZRPT,U,5)="EF"):"F",1:"R") ;"EF" reports send "F" (Final) in OBR-25
;Parent OBR-29 70.03;25 if exam/printset find ordered parent procedure
I $P(RAZXAM,U,25) D ;is this case part of an examset/printset
.S RAOBR(30)=$S($P(RAZXAM,U,25)=1:"Examset: ",1:"Printset: ")_$P($G(^RAMIS(71,+$P(RAZORD,U,2),0)),U)
.Q
;Principal Result Interpreter OBR-32 70.03;15
I $P(RAZXAM,U,15),($$GET1^DIQ(200,$P(RAZXAM,U,15),.01)'="") D
.K RAZNME S RAZNME("FILE")=200,RAZNME("IENS")=$P(RAZXAM,U,15)
.S RAZNME("FIELD")=.01
.;S RAOBR(33)=$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1))
.S RAOBR(33)=$P(RAZXAM,U,15)_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1))
.Q
;Assistant Result Interpreter(s)/contributors OBR-33 70.03;12
N CNT,RAI,RAJ S CNT=0
I $P(RAZXAM,U,12),($$GET1^DIQ(200,$P(RAZXAM,U,12),.01)'="") D
.K RAZNME D INTNAM($P(RAZXAM,U,12))
.Q
K RAZNME F RAI="SRR","SSR" D Q:CNT=10 ;ten or less interpreters
.S RAJ=0
.F S RAJ=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,RAI,RAJ)) Q:'RAJ S RAJ(0)=+$G(^(RAJ,0)) D Q:CNT=10
..D INTNAM(RAJ(0))
..Q
.Q
;Transcriptionist OBR-35 74;11
I RAZTRANS,($$GET1^DIQ(200,RAZTRANS,.01)'="") D
.S RAZNME("FILE")=200,RAZNME("IENS")=RAZTRANS,RAZNME("FIELD")=.01
.S RAOBR(36)=RAZTRANS_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1)) K RAZNME
.Q
;
;build the OBR segment
D BLSEG^RAHLRU1("OBR",.RAOBR)
;
;build the ZDS segment
D ZDS^RAHLR1A(RADTI,RACNI,RAZDAYCS)
;
OBXPRC ;Compile 'OBX' Segment for Procedure
;RAXX = Counter in segment
S (RAOBX(2),RAXX)=1
S RAOBX(3)="CE",RAOBX(4)="P"_$E(HLECH)_"PROCEDURE"_$E(HLECH)_"L"
S RAOBX(6)=$P(RAZXAM,U,2)_$E(HLECH)_$$ESCAPE^RAHLRU($P($G(^RAMIS(71,+$P(RAZXAM,U,2),0)),U))_$E(HLECH)_"L"
S RAOBX(12)=$$OBX11^RAHLRPT2(+$P(RAZXAM,U,17))
D BLSEG^RAHLRU1("OBX",.RAOBX) K RAOBX
;
OBXIMP ;Compile the 'OBX' segment for Impression Text
S RAOBX(2)=$G(RAXX)
I $O(^RARPT(+$P(RAZXAM,U,17),"I",0)) D
.S RAOBX(3)="TX",RAOBX(4)="I"_$E(HLECH)_"IMPRESSION"_$E(HLECH)_"L"
.S RAOBX(12)=$$OBX11^RAHLRPT2(+$P(RAZXAM,U,17))
.K ^UTILITY($J,"W") S DIWF="",DIWR=75,(DIWL,RADIWL)=1
.S RAI=0 F S RAI=$O(^RARPT(+$P(RAZXAM,U,17),"I",RAI)) Q:'RAI D
..S X=$G(^RARPT(+$P(RAZXAM,U,17),"I",RAI,0)) D ^DIWP
..Q
.S (RAI,RAJ)=0 F S RAI=$O(^UTILITY($J,"W",RADIWL,RAI)) Q:'RAI D
..S RAJ=RAJ+1,RAOBX(2)=RAXX+RAJ
..S RAOBX(6)=$$ESCAPE^RAHLRU($G(^UTILITY($J,"W",RADIWL,RAI,0)))
..D BLSEG^RAHLRU1("OBX",.RAOBX)
..Q
.S RAXX=$G(RAOBX(2))
.Q
K DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,RADIWL,RAOBX,^UTILITY($J,"W")
;
OBXDX ;Compile the 'OBX' segment for Diagnostic Code
S RAOBX(2)=$G(RAXX)
I +$P(RAZXAM,U,13) D ;pri. Dx code exists; look for secondary Dx
.S RAOBX(2)=RAXX+1,RAOBX(3)="CE"
.S RAOBX(4)="D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"
.S RAOBX(6)=+$P(RAZXAM,U,13)_$E(HLECH)_$$ESCAPE^RAHLRU($P($G(^RA(78.3,+$P(RAZXAM,U,13),0)),U))_$E(HLECH)_"L"
.S RAOBX(12)=$$OBX11^RAHLRPT2(+$P(RAZXAM,U,17))
.D BLSEG^RAHLRU1("OBX",.RAOBX)
.S RAXX=$G(RAOBX(2))
.Q
I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) D ;secondaries...
.S RAI=0,RAJ=0
.F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RAI)) Q:'RAI D
..S RAPTR=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RAI,0))
..S RAFT=$P($G(^RA(78.3,RAPTR,0)),U)
..S RAJ=RAJ+1,RAOBX(2)=RAXX+RAJ,RAOBX(6)=RAPTR_$E(HLECH)_$$ESCAPE^RAHLRU(RAFT)_$E(HLECH)_"L"
..D BLSEG^RAHLRU1("OBX",.RAOBX)
..Q
.S RAXX=$G(RAOBX(2))
.Q
K RAFT,RAOBX,RAPTR
;
OBXPMOD ;Compile 'OBX' segment for procedure modifiers
S RAOBX(2)=$G(RAXX),RAJ=0
S RAOBX(3)="TX",RAOBX(4)="M"_$E(HLECH)_"MODIFIERS"_$E(HLECH)_"L"
S RAOBX(12)=$$OBX11^RAHLRPT2(+$P(RAZXAM,U,17)),(RAI,RAJ)=0
F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",RAI)) Q:'RAI D
.S RAJ=RAJ+1,RAPTR=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",RAI,0))
.S RAOBX(2)=RAXX+RAJ
.S RAOBX(6)=$$ESCAPE^RAHLRU($P($G(^RAMIS(71.2,RAPTR,0)),U))
.D BLSEG^RAHLRU1("OBX",.RAOBX)
.Q
S RAXX=$G(RAOBX(2))
K RAOBX,RAPTR
;
OBXTCOM ;Compile 'OBX' segment for tech comments
D OBXTCOM^RAHLRPT2
;
OBXCPTM ;Compile 'OBX' segment for CPT modifiers
D OBXCPTM^RAHLRPT2
;
OBXRPT ;Compile 'OBX' segment for Report Text
D OBXRPT^RAHLRPT2
;
;Broadcast the HL7 message and cleanup the symbol table
D GENERATE^RAHLRU
Q
;
INTNAM(Y) ;return the name of the intepreter(s)
; input: Y=IEN of the record in the New Person (#200) file
; CNT=second level subscript is newed,initialized and checked above
S RAZNME("FILE")=200,RAZNME("IENS")=Y,RAZNME("FIELD")=.01
S CNT=CNT+1 ;update counter by 1
S RAOBR(34,CNT)=Y_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1)) K RAZNME
Q
RAHLRPT1 ;HISC/GJC-Compiles HL7 'ORU' Message Type ; 4/26/01 10:40am
+1 ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21
+2 ;
+3 ;Integration Agreements
+4 ;----------------------
+5 ;$$GET1^DIQ(2056); ^DIWP(10011);
+6 ;$$FMTHL7^XLFDT(10103); $$HLNAME^XLFNAME(3065)
+7 ;
EN(RADFN,RADTI,RACNI,RAEID) ;Called from all RA RPT* event driver protocols whose
+1 ;HL7 version exceeds version 2.3.
+2 ;
+3 ;Input Variables (from RAHLRPT):
+4 ; RADFN=file 2 IEN (DFN)
+5 ; RADTI=file 70 Exam subrec IEN (inverse date/time of exam)
+6 ; RACNI=file 70 Case subrecord IEN
+7 ; RAEID=ien of the event driver protocol (defined in RAHLRPC)
+8 ;Output variables:
+9 ; HLA("HLS", array containing HL7 msg
+10 ;
+11 ;Note: RAOBR(n+1) = OBR 'n' because our software begins
+12 ;building the segment with the segment header ('OBR')
+13 ;
+14 ;new some variables...
+15 NEW %,DN,FT,I,J,PTR,X,Y
+16 ;initialize Rad/Nuc Med specific variables
+17 DO INIT^RAHLR1
PID ;Compile the 'PID' segment
+1 DO PID^RAHLRU1(RADFN)
OBR ;Compile 'OBR' Segment
+1 ;get pointer value to the rad/nuc med report; needed to build the OBR
+2 SET RAZRPT=+$PIECE(RAZXAM,U,17)
+3 ;get rad/nuc med report zero node & the transcriptionist (if exists)
+4 SET RAZRPT=$GET(^RARPT(RAZRPT,0))
SET RAZTRANS=+$GET(^RARPT(+$PIECE(RAZXAM,U,17),"T"))
+5 ;Set ID OBR-1
+6 SET RAOBR(2)=1
+7 ;Placer Order Number OBR-2 mmddyy-case#
+8 ;Filler Order Number OBR-3 mmddyy-case#
+9 SET (RAOBR(3),RAOBR(4))=RAZDAYCS
+10 SET RAZCPT=$PIECE(RAZPROC,U,9)
SET RAZCPT(0)=$$NAMCODE^RACPTMSC(RAZCPT,DT)
+11 ;RAZCPT(0)=CPT code from file 81^short name of CPT code from file 81
+12 ;RAOBR(4)=CPT code #81_comp sep_CPT code short name #81_comp sep_"C4"
+13 ; _comp sep_IEN file #71_comp sep_procedure name #71_comp sep_
+14 ; "99RAP"
+15 ;
+16 SET RAOBR(5)=$PIECE(RAZCPT(0),U)_$EXTRACT(HLECH)_$$ESCAPE^RAHLRU($PIECE(RAZCPT(0),U,2))_$EXTRACT(HLECH)_"C4"
+17 SET RAOBR(5)=RAOBR(5)_$EXTRACT(HLECH)_+$PIECE(RAZXAM,U,2)_$EXTRACT(HLECH)_$$ESCAPE^RAHLRU($PIECE(RAZPROC,U))_$EXTRACT(HLECH)_"99RAP"
+18 ;Observation date/time OBR-7 (DATE REPORT ENTERED) 74;6
+19 SET RAOBR(8)=$$FMTHL7^XLFDT($PIECE(RAZRPT,U,6))
+20 ;Specimen Source OBR-15 75.1;125 PROCEDURE MODIFIERS (mult: 75.1125)
+21 ;(left & right only)
+22 SET RAZPMOD=$$SPECSRC^RAHLRU1(+$PIECE(RAZXAM,U,11))
+23 IF $LENGTH(RAZPMOD)
SET RAOBR(16)=$$REPEAT^RAHLRU1($EXTRACT(HLECH),4)_$EXTRACT(HLECH,4)_RAZPMOD
+24 ;
+25 ;Ordering Provider OBR-16 (REQUESTING PHYSICIAN) 75.1;14
+26 IF $PIECE(RAZORD,U,14)
IF ($$GET1^DIQ(200,$PIECE(RAZORD,U,14),.01)'="")
Begin DoDot:1
+27 KILL RAZNME
SET RAZNME("FILE")=200
SET RAZNME("IENS")=$PIECE(RAZORD,U,14)
+28 SET RAZNME("FIELD")=.01
+29 SET RAOBR(17)=$PIECE(RAZORD,U,14)_$EXTRACT(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$EXTRACT(HLECH,1))
+30 QUIT
End DoDot:1
+31 ;
+32 ;Call Back Phone numbers of Ordering Provider OBR-17
+33 Begin DoDot:1
+34 NEW RAX,I,M
SET M=""
SET I=0
+35 DO NPFON^MAG7UFO("RAX",$PIECE(RAZORD,U,14))
+36 FOR
SET I=$ORDER(RAX(I))
IF 'I
QUIT
SET M=M_$$ESCAPE^RAHLRU($GET(RAX(I,1,1)))_$EXTRACT(HLECH)_$GET(RAX(I,2,1))_$EXTRACT(HLECH)_$GET(RAX(I,3,1))_$EXTRACT(HLECH,2)
+37 IF $LENGTH(M)
SET RAOBR(18)=$EXTRACT(M,1,$LENGTH(M)-1)
End DoDot:1
+38 ;
+39 ;Placer Field 1 OBR-18 site id-mmddyy-case# (mirrors OBR-2 & OBR-3)
+40 SET RAOBR(19)=RAZDAYCS
+41 ;
+42 ;Placer Field 2 definition has been changed by a VistA Imaging request
+43 ;-> prior to 07/2007: inv. date/time of the exam concatenated to (by the
+44 ; dash) the exam record IEN (Placer Fld 2 OBR-19 = Filler Fld 1 OBR-20)
+45 ;-> after 07/2007: case number
+46 ;RAZDAYCS=sss-mmddyy-case# OR mmddyy-case#
+47 SET RAOBR(20)=$PIECE(RAZDAYCS,"-",$LENGTH(RAZDAYCS,"-"))
+48 ;
+49 ;Filler Field 1 OBR-20 is defined as the site specific accession number:
+50 ;site id-mmddyy-case# Note: same value as OBR-18, OBR-2, & OBR-3
+51 ;(change effective 07/2007)
+52 SET RAOBR(21)=RAZDAYCS
+53 ;
+54 ;Filler Field 2 OBR-21 (change effective 07/2007)
+55 ;RAZRXAM defined in INIT^RAHLR1
+56 SET RAOBR(22)=$$OBR21^RAHLRU(HLECH,RAZRXAM)
+57 ;
+58 ;Results Rpt/Status Chng-date/time OBR-22
+59 ;verified: VERIFIED DATE 74;7
+60 ;unv'fied: DATE REPORT ENTERED 74;6
+61 IF $PIECE(RAZRPT,U,5)="V"
SET RAOBR(23)=$$FMTHL7^XLFDT($PIECE(RAZRPT,U,7))
+62 IF $PIECE(RAZRPT,U,5)'="V"
SET RAOBR(23)=$$FMTHL7^XLFDT($PIECE(RAZRPT,U,6))
+63 ;Status OBR-25 REPORT STATUS 74;5
+64 ;S:$D(^RARPT(+$P(RAZXAM,U,17),"ERR",1,0))#2 RAOBR(26)="C" ;corrected rt
+65 ;"EF" reports send "F" (Final) in OBR-25
IF '$DATA(RAOBR(26))#2
SET RAOBR(26)=$SELECT(($PIECE(RAZRPT,U,5)="V")!($PIECE(RAZRPT,U,5)="EF"):"F",1:"R")
+66 ;Parent OBR-29 70.03;25 if exam/printset find ordered parent procedure
+67 ;is this case part of an examset/printset
IF $PIECE(RAZXAM,U,25)
Begin DoDot:1
+68 SET RAOBR(30)=$SELECT($PIECE(RAZXAM,U,25)=1:"Examset: ",1:"Printset: ")_$PIECE($GET(^RAMIS(71,+$PIECE(RAZORD,U,2),0)),U)
+69 QUIT
End DoDot:1
+70 ;Principal Result Interpreter OBR-32 70.03;15
+71 IF $PIECE(RAZXAM,U,15)
IF ($$GET1^DIQ(200,$PIECE(RAZXAM,U,15),.01)'="")
Begin DoDot:1
+72 KILL RAZNME
SET RAZNME("FILE")=200
SET RAZNME("IENS")=$PIECE(RAZXAM,U,15)
+73 SET RAZNME("FIELD")=.01
+74 ;S RAOBR(33)=$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1))
+75 SET RAOBR(33)=$PIECE(RAZXAM,U,15)_$EXTRACT(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$EXTRACT(HLECH,1))
+76 QUIT
End DoDot:1
+77 ;Assistant Result Interpreter(s)/contributors OBR-33 70.03;12
+78 NEW CNT,RAI,RAJ
SET CNT=0
+79 IF $PIECE(RAZXAM,U,12)
IF ($$GET1^DIQ(200,$PIECE(RAZXAM,U,12),.01)'="")
Begin DoDot:1
+80 KILL RAZNME
DO INTNAM($PIECE(RAZXAM,U,12))
+81 QUIT
End DoDot:1
+82 ;ten or less interpreters
KILL RAZNME
FOR RAI="SRR","SSR"
Begin DoDot:1
+83 SET RAJ=0
+84 FOR
SET RAJ=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,RAI,RAJ))
IF 'RAJ
QUIT
SET RAJ(0)=+$GET(^(RAJ,0))
Begin DoDot:2
+85 DO INTNAM(RAJ(0))
+86 QUIT
End DoDot:2
IF CNT=10
QUIT
+87 QUIT
End DoDot:1
IF CNT=10
QUIT
+88 ;Transcriptionist OBR-35 74;11
+89 IF RAZTRANS
IF ($$GET1^DIQ(200,RAZTRANS,.01)'="")
Begin DoDot:1
+90 SET RAZNME("FILE")=200
SET RAZNME("IENS")=RAZTRANS
SET RAZNME("FIELD")=.01
+91 SET RAOBR(36)=RAZTRANS_$EXTRACT(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$EXTRACT(HLECH,1))
KILL RAZNME
+92 QUIT
End DoDot:1
+93 ;
+94 ;build the OBR segment
+95 DO BLSEG^RAHLRU1("OBR",.RAOBR)
+96 ;
+97 ;build the ZDS segment
+98 DO ZDS^RAHLR1A(RADTI,RACNI,RAZDAYCS)
+99 ;
OBXPRC ;Compile 'OBX' Segment for Procedure
+1 ;RAXX = Counter in segment
+2 SET (RAOBX(2),RAXX)=1
+3 SET RAOBX(3)="CE"
SET RAOBX(4)="P"_$EXTRACT(HLECH)_"PROCEDURE"_$EXTRACT(HLECH)_"L"
+4 SET RAOBX(6)=$PIECE(RAZXAM,U,2)_$EXTRACT(HLECH)_$$ESCAPE^RAHLRU($PIECE($GET(^RAMIS(71,+$PIECE(RAZXAM,U,2),0)),U))_$EXTRACT(HLECH)_"L"
+5 SET RAOBX(12)=$$OBX11^RAHLRPT2(+$PIECE(RAZXAM,U,17))
+6 DO BLSEG^RAHLRU1("OBX",.RAOBX)
KILL RAOBX
+7 ;
OBXIMP ;Compile the 'OBX' segment for Impression Text
+1 SET RAOBX(2)=$GET(RAXX)
+2 IF $ORDER(^RARPT(+$PIECE(RAZXAM,U,17),"I",0))
Begin DoDot:1
+3 SET RAOBX(3)="TX"
SET RAOBX(4)="I"_$EXTRACT(HLECH)_"IMPRESSION"_$EXTRACT(HLECH)_"L"
+4 SET RAOBX(12)=$$OBX11^RAHLRPT2(+$PIECE(RAZXAM,U,17))
+5 KILL ^UTILITY($JOB,"W")
SET DIWF=""
SET DIWR=75
SET (DIWL,RADIWL)=1
+6 SET RAI=0
FOR
SET RAI=$ORDER(^RARPT(+$PIECE(RAZXAM,U,17),"I",RAI))
IF 'RAI
QUIT
Begin DoDot:2
+7 SET X=$GET(^RARPT(+$PIECE(RAZXAM,U,17),"I",RAI,0))
DO ^DIWP
+8 QUIT
End DoDot:2
+9 SET (RAI,RAJ)=0
FOR
SET RAI=$ORDER(^UTILITY($JOB,"W",RADIWL,RAI))
IF 'RAI
QUIT
Begin DoDot:2
+10 SET RAJ=RAJ+1
SET RAOBX(2)=RAXX+RAJ
+11 SET RAOBX(6)=$$ESCAPE^RAHLRU($GET(^UTILITY($JOB,"W",RADIWL,RAI,0)))
+12 DO BLSEG^RAHLRU1("OBX",.RAOBX)
+13 QUIT
End DoDot:2
+14 SET RAXX=$GET(RAOBX(2))
+15 QUIT
End DoDot:1
+16 KILL DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,RADIWL,RAOBX,^UTILITY($JOB,"W")
+17 ;
OBXDX ;Compile the 'OBX' segment for Diagnostic Code
+1 SET RAOBX(2)=$GET(RAXX)
+2 ;pri. Dx code exists; look for secondary Dx
IF +$PIECE(RAZXAM,U,13)
Begin DoDot:1
+3 SET RAOBX(2)=RAXX+1
SET RAOBX(3)="CE"
+4 SET RAOBX(4)="D"_$EXTRACT(HLECH)_"DIAGNOSTIC CODE"_$EXTRACT(HLECH)_"L"
+5 SET RAOBX(6)=+$PIECE(RAZXAM,U,13)_$EXTRACT(HLECH)_$$ESCAPE^RAHLRU($PIECE($GET(^RA(78.3,+$PIECE(RAZXAM,U,13),0)),U))_$EXTRACT(HLECH)_"L"
+6 SET RAOBX(12)=$$OBX11^RAHLRPT2(+$PIECE(RAZXAM,U,17))
+7 DO BLSEG^RAHLRU1("OBX",.RAOBX)
+8 SET RAXX=$GET(RAOBX(2))
+9 QUIT
End DoDot:1
+10 ;secondaries...
IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0))
Begin DoDot:1
+11 SET RAI=0
SET RAJ=0
+12 FOR
SET RAI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RAI))
IF 'RAI
QUIT
Begin DoDot:2
+13 SET RAPTR=+$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RAI,0))
+14 SET RAFT=$PIECE($GET(^RA(78.3,RAPTR,0)),U)
+15 SET RAJ=RAJ+1
SET RAOBX(2)=RAXX+RAJ
SET RAOBX(6)=RAPTR_$EXTRACT(HLECH)_$$ESCAPE^RAHLRU(RAFT)_$EXTRACT(HLECH)_"L"
+16 DO BLSEG^RAHLRU1("OBX",.RAOBX)
+17 QUIT
End DoDot:2
+18 SET RAXX=$GET(RAOBX(2))
+19 QUIT
End DoDot:1
+20 KILL RAFT,RAOBX,RAPTR
+21 ;
OBXPMOD ;Compile 'OBX' segment for procedure modifiers
+1 SET RAOBX(2)=$GET(RAXX)
SET RAJ=0
+2 SET RAOBX(3)="TX"
SET RAOBX(4)="M"_$EXTRACT(HLECH)_"MODIFIERS"_$EXTRACT(HLECH)_"L"
+3 SET RAOBX(12)=$$OBX11^RAHLRPT2(+$PIECE(RAZXAM,U,17))
SET (RAI,RAJ)=0
+4 FOR
SET RAI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",RAI))
IF 'RAI
QUIT
Begin DoDot:1
+5 SET RAJ=RAJ+1
SET RAPTR=+$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",RAI,0))
+6 SET RAOBX(2)=RAXX+RAJ
+7 SET RAOBX(6)=$$ESCAPE^RAHLRU($PIECE($GET(^RAMIS(71.2,RAPTR,0)),U))
+8 DO BLSEG^RAHLRU1("OBX",.RAOBX)
+9 QUIT
End DoDot:1
+10 SET RAXX=$GET(RAOBX(2))
+11 KILL RAOBX,RAPTR
+12 ;
OBXTCOM ;Compile 'OBX' segment for tech comments
+1 DO OBXTCOM^RAHLRPT2
+2 ;
OBXCPTM ;Compile 'OBX' segment for CPT modifiers
+1 DO OBXCPTM^RAHLRPT2
+2 ;
OBXRPT ;Compile 'OBX' segment for Report Text
+1 DO OBXRPT^RAHLRPT2
+2 ;
+3 ;Broadcast the HL7 message and cleanup the symbol table
+4 DO GENERATE^RAHLRU
+5 QUIT
+6 ;
INTNAM(Y) ;return the name of the intepreter(s)
+1 ; input: Y=IEN of the record in the New Person (#200) file
+2 ; CNT=second level subscript is newed,initialized and checked above
+3 SET RAZNME("FILE")=200
SET RAZNME("IENS")=Y
SET RAZNME("FIELD")=.01
+4 ;update counter by 1
SET CNT=CNT+1
+5 SET RAOBR(34,CNT)=Y_$EXTRACT(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$EXTRACT(HLECH,1))
KILL RAZNME
+6 QUIT
