RAHLRPT ;HISC/CAH AISC/SAW-Compiles HL7 'ORU' Message Type ; 4/26/01 10:40am
;;5.0;Radiology/Nuclear Medicine;**2,12,10,25,81,80,84**;Mar 16, 1998;Build 13
EN ; Called from RA RPT and RA RPT 2.3 protocol entry action
; Input variables:
; RADFN=file 2 IEN (DFN)
; RADTI=file 70 Exam subrecord IEN (reverse date/time)
; RACNI=file 70 Case subrecord IEN
; RARPT=file 74 Report IEN
; RASSS=List of Subscribers passed into GENERATE^HLMA will be set into HLP array.
; Output variables:
; HLA("HLS", array containing HL7 msg
; RATELREL = 1 Indicates that the text: 'Released for local dictation by National Teleradiology'
; has been included in Impression or Report section
; RATELX = Text used as indication of Release for local dictation... if not set use defauld above...
; RATELE = 1 If RANOSEND is Teleradiology type vendor
;
;Integration Agreements
;----------------------
;$$GET1^DIQ(2056); ^DIWP(10011); $$HLDATE/$$HLNAME^HLFNC(10106)
;GENERATE^HLMA(2164); DEM^VADPT(10061); $$FMTHL7^XLFDT(10103)
;$$PATCH^XPDUTL(10141); $$VERSION^XPDUTL(10141)
;
N RASET,RACN0,RATELE,RATELREL,RATELX
D INIT^RAHLRPTT ;Patch 84
I +$P(RACN0,U,25)=2 D Q ; printset
.; loop through all cases in set and create message
.S RASET=1
.N RACNI,RAII S RAII=0
.F S RAII=$O(^RADPT(RADFN,"DT",RADTI,"P",RAII)) Q:RAII'>0 D
.. Q:$P(^RADPT(RADFN,"DT",RADTI,"P",RAII,0),U,25)'=2
.. S RACNI=RAII
.. D NEW
NEW ; new variables
S:$D(ZTQUEUED) ZTREQ="@" ; delete task from task global
N DFN,DIWF,DIWL,DIWR,RACPT,RACPTNDE,RADTECN,RADTE0,RADTV,RAI,RAN,RAOBR4,RAPRCNDE,RAPROC,RAPROCIT,RAPRV,RARPT0
N VADM,VAERR,X,X1,X2,XX2,Y,X0,OBR36,EID,HL,INT,HLQ,HLFS,HLECH,HLA,RAN K RAVADM
D INIT^RAHLRU ;initialize HL7 variables
Q:+$G(HL)=15 ;no known client(item) linked to the event driver protocol
Q:$O(HL(""))="" ;failed return from INIT^HLFNC2 (called by INIT^RAHLRU)
;
;** branch to new HL7 logic when the HL7 version surpasses 2.3 **
I HL("VER")>2.3,($T(^RAHLRPT1))'="" D EN^RAHLRPT1(RADFN,RADTI,RACNI,RAEID),EXIT Q
;** branch to new HL7 logic when the HL7 version surpasses 2.3 **
;
S DFN=RADFN D DEM^VADPT
I VADM(1)']"" S HLP("ERRTEXT")="Invalid Patient Identifier" G EXIT
S RAN=0
S RAVADM(3)=$S($E(+VADM(3),6,7)="00":"",1:+VADM(3)) ; NOTE: Check
; for an inexact date of birth. If inexact, pass null for DOB in
; the 'PID' segment. Some COTS systems can't handle inexact DOB's.
D SETUP^RAHLRPTT,PID^RAHLRPTT,OBR,OBXPRC,OBXIMP,OBXDIA,OBXRPT,OBXMOD,OBXTCM
EXIT ; set HL7 message type & return to RA RPT protocol
;For P84 see if this is a >>Released for local reading<< type report and if yes resend the ORM (^RAHLRS1)...
I $G(RATELREL) D RESEND^RAHLRPTT(RADFN,RADTI,RACNI) Q ;P84 resend in the case that report released from Telerad
S HL("MTN")="ORU"
N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLP
S HLEID=RAEID,HLARYTYP="LM",HLFORMAT=1,HLMTIEN="",HLP("PRIORITY")="I"
M:$D(RASSS) HLP=RASSS
D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX")
D GENERATE^HLMA(HLEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP)
K RAVADM
Q
;
OBR ;Compile 'OBR' Segment
S RAOBR4=$P(RACPTNDE,U)_$E(HLECH)_$P(RACPTNDE,U,2)_$E(HLECH)_"C4"_$E(HLECH)_+RAPROC_$E(HLECH)_$P(RAPRCNDE,U)_$E(HLECH)_"99RAP"
; Replace above with following when Imaging can cope with ESC chars
; S RAOBR4=$P(RACPTNDE,U)_$E(HLECH)_$$ESCAPE^RAHLRU($P(RACPTNDE,U,2))_$E(HLECH)_"C4"_$E(HLECH)_+RAPROC_$E(HLECH)_$$ESCAPE^RAHLRU($P(RAPRCNDE,U))_$E(HLECH)_"99RAP"
; Have to use LOCAL code if Broad Procedure - no CPT code
I $P(RAOBR4,$E(HLECH))=""!($P(RAOBR4,$E(HLECH),2)="") S $P(RAOBR4,$E(HLECH),1,3)=$P(RAOBR4,$E(HLECH),4,5)_$E(HLECH)_"LOCAL"
S X1="OBR"_HLFS_HLFS_HLFS_RADTI_"-"_RACNI_$E(HLECH)_RADTECN_$E(HLECH)_"L"_HLFS_RAOBR4_HLFS_HLFS_HLFS_RADTE0_HLFS_HLQ_HLFS_HLQ_HLFS_HLFS_HLFS_HLFS_HLFS,Y=$$HLDATE^HLFNC($P(RARPT0,"^",6)) S X1=X1_Y_HLFS_HLFS
S RAPRV=$$GET1^DIQ(200,+$P(RACN0,"^",14),.01)
S Y=$$HLNAME^HLFNC(RAPRV) S X1=X1_$S(Y]"":+$P(RACN0,"^",14)_$E(HLECH)_Y,1:"")
S $P(X1,HLFS,19)=$S($D(^DIC(42,+$P(RACN0,"^",6),0)):$P(^(0),"^"),$D(^SC(+$P(RACN0,"^",8),0)):$P(^(0),"^"),1:"Unknown")
; PCE 21 -> ien file #79.1~name of img loc~stn #~stn name
N RACN00,RA20 S RACN00=$G(^RADPT(RADFN,"DT",RADTI,0))
S RA20=+$G(^RA(79.1,+$P(RACN00,U,4),0))
S $P(X1,HLFS,21)=$P(RACN00,"^",4)_$E(HLECH)_$P($G(^SC(RA20,0)),"^")_$E(HLECH)_$P(RACN00,"^",3)_$E(HLECH)_$P($G(^DIC(4,$P(RACN00,U,3),0)),"^")
S $P(X1,HLFS,21)=$P(X1,HLFS,21)
; Replace above with following when Imaging can cope with ESC chars
; S $P(X1,HLFS,21)=$$ESCAPE^RAHLRU($P(X1,HLFS,21))
;
S OBR36=9999999.9999-RADTI
S $P(X1,HLFS,37)=$$FMTHL7^XLFDT(OBR36)
;
S RADTV=HLDT1 I $P(RARPT0,"^",5)="V",$P(RARPT0,"^",7) K RADTV S RADTV=$$HLDATE^HLFNC($P(RARPT0,"^",7))
S $P(X1,HLFS,23)=RADTV,$P(X1,HLFS,26)=$S($P(RARPT0,"^",5)="V":"F",1:"R")
;Principal Result Interpreter = Verifying Physician
S $P(X1,HLFS,33)="" I $P(RARPT0,"^",9) D
.S X2=$$GET1^DIQ(200,$P(RARPT0,"^",9),.01) Q:X2']""
.S Y=$$HLNAME^HLFNC(X2) Q:Y']""
.S $P(X1,HLFS,33)=$P(RARPT0,"^",9)_$E(HLECH)_Y
;Assistant Result Interpreter = Primary Interpreting Staff OR Resident
S $P(X1,HLFS,34)="" I $P(RACN0,"^",15) D
.S X2=$$GET1^DIQ(200,$P(RACN0,"^",15),.01) Q:X2']""
.S Y=$$HLNAME^HLFNC(X2) Q:Y']""
.S $P(X1,HLFS,34)=$P(RACN0,"^",15)_$E(HLECH)_Y
I $P(RACN0,"^",12) D
.S X2=$$GET1^DIQ(200,$P(RACN0,"^",12),.01) Q:X2']""
.S Y=$$HLNAME^HLFNC(X2) Q:Y']""
.S $P(X1,HLFS,34)=$P(RACN0,"^",12)_$E(HLECH)_Y
;Technician = Technologist
S $P(X1,HLFS,35)="" I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0)) D
.S X2=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0)) I X2']"" Q
.S X2=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",X2,0)),"^",1) I X2']"" Q
.S XX2=$$GET1^DIQ(200,X2,.01) Q:XX2']""
.S Y=$$HLNAME^HLFNC(XX2) I Y']"" Q
.S $P(X1,HLFS,35)=X2_$E(HLECH)_Y
;Transcriptionist
S $P(X1,HLFS,36)="" I $G(^RARPT(RARPT,"T")) D
.S X2=$$GET1^DIQ(200,$P(^RARPT(RARPT,"T"),"^",1),.01) I X2']"" Q
.S Y=$$HLNAME^HLFNC(X2) I Y']"" Q
.S $P(X1,HLFS,36)=^RARPT(RARPT,"T")_$E(HLECH)_Y
;
; if long str, break so 2nd str begins with separator to avoid abend
N RAPART I $L(X1)>245 F RAPART=5:1:18 S RAPART(1)=$P(X1,HLFS,1,RAPART),RAPART(2)=$P(X1,HLFS,RAPART+1,99) Q:$L(RAPART(1))<245&($L(RAPART(2))<245)&($P(RAPART(2),HLFS)="")
I $D(RAPART) K:RAPART=18 RAPART ;if RAPART reaches 18, then something's wrong, so kill RAPART to allow abend due "string too long"
S RAN=RAN+1
I $D(RAPART) S HLA("HLS",RAN)=$P(RAPART(1),HLFS)_HLFS,HLA("HLS",RAN,1)=$P(RAPART(1),HLFS,2,99)_HLFS,HLA("HLS",RAN,2)=RAPART(2) K RAPART Q
S HLA("HLS",RAN)=X1
Q
OBXDIA ;Compile 'OBX' Segment for Diagnostic Code
S RAI=$P($G(^RA(78.3,+$P(RACN0,"^",13),0)),"^") I RAI]"" D
.S RAN=RAN+1
.I $$PATCH^XPDUTL("MAG*2.5*1")!(+$$VERSION^XPDUTL("MAG")>2.5) D
..S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_+$P(RACN0,"^",13)_$E(HLECH)_RAI_$E(HLECH)_"L"
..; Replace above with following when Imaging can cope with ESC chars
..; S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_+$P(RACN0,"^",13)_$E(HLECH)_$$ESCAPE^RAHLRU(RAI)_$E(HLECH)_"L"
.E D
..S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"ST"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_RAI
.D OBX11^RAHLRU
Q:'$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) ;any secondary dx
S X2=0
OBXDIA2 S X2=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",X2)) Q:'X2
S Y=+^(X2,0),X=$P($G(^RA(78.3,+Y,0)),U)
I X]"" D
.S RAN=RAN+1
.I $$PATCH^XPDUTL("MAG*2.5*1")!(+$$VERSION^XPDUTL("MAG")>2.5) D
..S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_Y_$E(HLECH)_X_$E(HLECH)_"L"
..; Replace above with following when Imaging can cope with ESC chars
..; S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_Y_$E(HLECH)_$$ESCAPE^RAHLRU(X)_$E(HLECH)_"L"
.E D
..S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"ST"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_X
.D OBX11^RAHLRU
G OBXDIA2
;
OBXIMP ;Compile 'OBX' segment for Impression
I '$O(^RARPT(RARPT,"I",0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"I"_$E(HLECH)_"IMPRESSION"_$E(HLECH)_"L"_HLFS_HLFS_"None Entered" D OBX11^RAHLRU Q
K ^UTILITY($J,"W") S DIWF="",DIWR=80,DIWL=1
F RAI=0:0 S RAI=$O(^RARPT(RARPT,"I",RAI)) Q:'RAI I $D(^(RAI,0)) S X=^(0) D RATELREL,^DIWP
F RAI=0:0 S RAI=$O(^UTILITY($J,"W",DIWL,RAI)) Q:'RAI I $D(^(RAI,0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"I"_$E(HLECH)_"IMPRESSION"_$E(HLECH)_"L"_HLFS_HLFS_^(0) D OBX11^RAHLRU
Q
OBXMOD ;Compile 'OBX' Segment for Modifiers
S RAN=RAN+1 D OBXMOD^RAHLRU
Q
OBXPRC ;Compile 'OBX' Segment for Procedure
S RAN=RAN+1 D OBXPRC^RAHLRU
Q
OBXTCM ;Compile 'OBX' Segment for Tech Comments
D OBXTCM^RAHLRU
Q
OBXRPT ;Compile 'OBX' Segment for Radiology Report Text
I '$O(^RARPT(RARPT,"R",0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"R"_$E(HLECH)_"REPORT"_$E(HLECH)_"L"_HLFS_HLFS_"None Entered" D OBX11^RAHLRU Q
K ^UTILITY($J,"W") S DIWF="",DIWR=80,DIWL=1
F RAI=0:0 S RAI=$O(^RARPT(RARPT,"R",RAI)) Q:'RAI I $D(^(RAI,0)) S X=^(0) D RATELREL,^DIWP
F RAI=0:0 S RAI=$O(^UTILITY($J,"W",DIWL,RAI)) Q:'RAI I $D(^(RAI,0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"R"_$E(HLECH)_"REPORT"_$E(HLECH)_"L"_HLFS_HLFS_^(0) D OBX11^RAHLRU
; Replace above with following when Imaging can cope with ESC chars
; F RAI=0:0 S RAI=$O(^UTILITY($J,"W",DIWL,RAI)) Q:'RAI I $D(^(RAI,0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"R"_$E(HLECH)_"REPORT"_$E(HLECH)_"L"_HLFS_HLFS_$$ESCAPE^RAHLRU(^(0)) D OBX11^RAHLRU
Q
RATELREL ;Release the study for local reading
I $G(RATELE),X[$G(RATELX) S RATELREL=1 Q
;
RAHLRPT ;HISC/CAH AISC/SAW-Compiles HL7 'ORU' Message Type ; 4/26/01 10:40am
+1 ;;5.0;Radiology/Nuclear Medicine;**2,12,10,25,81,80,84**;Mar 16, 1998;Build 13
EN ; Called from RA RPT and RA RPT 2.3 protocol entry action
+1 ; Input variables:
+2 ; RADFN=file 2 IEN (DFN)
+3 ; RADTI=file 70 Exam subrecord IEN (reverse date/time)
+4 ; RACNI=file 70 Case subrecord IEN
+5 ; RARPT=file 74 Report IEN
+6 ; RASSS=List of Subscribers passed into GENERATE^HLMA will be set into HLP array.
+7 ; Output variables:
+8 ; HLA("HLS", array containing HL7 msg
+9 ; RATELREL = 1 Indicates that the text: 'Released for local dictation by National Teleradiology'
+10 ; has been included in Impression or Report section
+11 ; RATELX = Text used as indication of Release for local dictation... if not set use defauld above...
+12 ; RATELE = 1 If RANOSEND is Teleradiology type vendor
+13 ;
+14 ;Integration Agreements
+15 ;----------------------
+16 ;$$GET1^DIQ(2056); ^DIWP(10011); $$HLDATE/$$HLNAME^HLFNC(10106)
+17 ;GENERATE^HLMA(2164); DEM^VADPT(10061); $$FMTHL7^XLFDT(10103)
+18 ;$$PATCH^XPDUTL(10141); $$VERSION^XPDUTL(10141)
+19 ;
+20 NEW RASET,RACN0,RATELE,RATELREL,RATELX
+21 ;Patch 84
DO INIT^RAHLRPTT
+22 ; printset
IF +$PIECE(RACN0,U,25)=2
Begin DoDot:1
+23 ; loop through all cases in set and create message
+24 SET RASET=1
+25 NEW RACNI,RAII
SET RAII=0
+26 FOR
SET RAII=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RAII))
IF RAII'>0
QUIT
Begin DoDot:2
+27 IF $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RAII,0),U,25)'=2
QUIT
+28 SET RACNI=RAII
+29 DO NEW
End DoDot:2
End DoDot:1
QUIT
NEW ; new variables
+1 ; delete task from task global
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 NEW DFN,DIWF,DIWL,DIWR,RACPT,RACPTNDE,RADTECN,RADTE0,RADTV,RAI,RAN,RAOBR4,RAPRCNDE,RAPROC,RAPROCIT,RAPRV,RARPT0
+3 NEW VADM,VAERR,X,X1,X2,XX2,Y,X0,OBR36,EID,HL,INT,HLQ,HLFS,HLECH,HLA,RAN
KILL RAVADM
+4 ;initialize HL7 variables
DO INIT^RAHLRU
+5 ;no known client(item) linked to the event driver protocol
IF +$GET(HL)=15
QUIT
+6 ;failed return from INIT^HLFNC2 (called by INIT^RAHLRU)
IF $ORDER(HL(""))=""
QUIT
+7 ;
+8 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 **
+9 IF HL("VER")>2.3
IF ($TEXT(^RAHLRPT1))'=""
DO EN^RAHLRPT1(RADFN,RADTI,RACNI,RAEID)
DO EXIT
QUIT
+10 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 **
+11 ;
+12 SET DFN=RADFN
DO DEM^VADPT
+13 IF VADM(1)']""
SET HLP("ERRTEXT")="Invalid Patient Identifier"
GOTO EXIT
+14 SET RAN=0
+15 ; NOTE: Check
SET RAVADM(3)=$SELECT($EXTRACT(+VADM(3),6,7)="00":"",1:+VADM(3))
+16 ; for an inexact date of birth. If inexact, pass null for DOB in
+17 ; the 'PID' segment. Some COTS systems can't handle inexact DOB's.
+18 DO SETUP^RAHLRPTT
DO PID^RAHLRPTT
DO OBR
DO OBXPRC
DO OBXIMP
DO OBXDIA
DO OBXRPT
DO OBXMOD
DO OBXTCM
EXIT ; set HL7 message type & return to RA RPT protocol
+1 ;For P84 see if this is a >>Released for local reading<< type report and if yes resend the ORM (^RAHLRS1)...
+2 ;P84 resend in the case that report released from Telerad
IF $GET(RATELREL)
DO RESEND^RAHLRPTT(RADFN,RADTI,RACNI)
QUIT
+3 SET HL("MTN")="ORU"
+4 NEW HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLP
+5 SET HLEID=RAEID
SET HLARYTYP="LM"
SET HLFORMAT=1
SET HLMTIEN=""
SET HLP("PRIORITY")="I"
+6 IF $DATA(RASSS)
MERGE HLP=RASSS
+7 IF $DATA(RASSSX(HLEID))
DO GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX")
+8 DO GENERATE^HLMA(HLEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP)
+9 KILL RAVADM
+10 QUIT
+11 ;
OBR ;Compile 'OBR' Segment
+1 SET RAOBR4=$PIECE(RACPTNDE,U)_$EXTRACT(HLECH)_$PIECE(RACPTNDE,U,2)_$EXTRACT(HLECH)_"C4"_$EXTRACT(HLECH)_+RAPROC_$EXTRACT(HLECH)_$PIECE(RAPRCNDE,U)_$EXTRACT(HLECH)_"99RAP"
+2 ; Replace above with following when Imaging can cope with ESC chars
+3 ; S RAOBR4=$P(RACPTNDE,U)_$E(HLECH)_$$ESCAPE^RAHLRU($P(RACPTNDE,U,2))_$E(HLECH)_"C4"_$E(HLECH)_+RAPROC_$E(HLECH)_$$ESCAPE^RAHLRU($P(RAPRCNDE,U))_$E(HLECH)_"99RAP"
+4 ; Have to use LOCAL code if Broad Procedure - no CPT code
+5 IF $PIECE(RAOBR4,$EXTRACT(HLECH))=""!($PIECE(RAOBR4,$EXTRACT(HLECH),2)="")
SET $PIECE(RAOBR4,$EXTRACT(HLECH),1,3)=$PIECE(RAOBR4,$EXTRACT(HLECH),4,5)_$EXTRACT(HLECH)_"LOCAL"
+6 SET X1="OBR"_HLFS_HLFS_HLFS_RADTI_"-"_RACNI_$EXTRACT(HLECH)_RADTECN_$EXTRACT(HLECH)_"L"_HLFS_RAOBR4_HLFS_HLFS_HLFS_RADTE0_HLFS_HLQ_HLFS_HLQ_HLFS_HLFS_HLFS_HLFS_HLFS
SET Y=$$HLDATE^HLFNC($PIECE(RARPT0,"^",6))
SET X1=X1_Y_HLFS_HLFS
+7 SET RAPRV=$$GET1^DIQ(200,+$PIECE(RACN0,"^",14),.01)
+8 SET Y=$$HLNAME^HLFNC(RAPRV)
SET X1=X1_$SELECT(Y]"":+$PIECE(RACN0,"^",14)_$EXTRACT(HLECH)_Y,1:"")
+9 SET $PIECE(X1,HLFS,19)=$SELECT($DATA(^DIC(42,+$PIECE(RACN0,"^",6),0)):$PIECE(^(0),"^"),$DATA(^SC(+$PIECE(RACN0,"^",8),0)):$PIECE(^(0),"^"),1:"Unknown")
+10 ; PCE 21 -> ien file #79.1~name of img loc~stn #~stn name
+11 NEW RACN00,RA20
SET RACN00=$GET(^RADPT(RADFN,"DT",RADTI,0))
+12 SET RA20=+$GET(^RA(79.1,+$PIECE(RACN00,U,4),0))
+13 SET $PIECE(X1,HLFS,21)=$PIECE(RACN00,"^",4)_$EXTRACT(HLECH)_$PIECE($GET(^SC(RA20,0)),"^")_$EXTRACT(HLECH)_$PIECE(RACN00,"^",3)_$EXTRACT(HLECH)_$PIECE($GET(^DIC(4,$PIECE(RACN00,U,3),0)),"^")
+14 SET $PIECE(X1,HLFS,21)=$PIECE(X1,HLFS,21)
+15 ; Replace above with following when Imaging can cope with ESC chars
+16 ; S $P(X1,HLFS,21)=$$ESCAPE^RAHLRU($P(X1,HLFS,21))
+17 ;
+18 SET OBR36=9999999.9999-RADTI
+19 SET $PIECE(X1,HLFS,37)=$$FMTHL7^XLFDT(OBR36)
+20 ;
+21 SET RADTV=HLDT1
IF $PIECE(RARPT0,"^",5)="V"
IF $PIECE(RARPT0,"^",7)
KILL RADTV
SET RADTV=$$HLDATE^HLFNC($PIECE(RARPT0,"^",7))
+22 SET $PIECE(X1,HLFS,23)=RADTV
SET $PIECE(X1,HLFS,26)=$SELECT($PIECE(RARPT0,"^",5)="V":"F",1:"R")
+23 ;Principal Result Interpreter = Verifying Physician
+24 SET $PIECE(X1,HLFS,33)=""
IF $PIECE(RARPT0,"^",9)
Begin DoDot:1
+25 SET X2=$$GET1^DIQ(200,$PIECE(RARPT0,"^",9),.01)
IF X2']""
QUIT
+26 SET Y=$$HLNAME^HLFNC(X2)
IF Y']""
QUIT
+27 SET $PIECE(X1,HLFS,33)=$PIECE(RARPT0,"^",9)_$EXTRACT(HLECH)_Y
End DoDot:1
+28 ;Assistant Result Interpreter = Primary Interpreting Staff OR Resident
+29 SET $PIECE(X1,HLFS,34)=""
IF $PIECE(RACN0,"^",15)
Begin DoDot:1
+30 SET X2=$$GET1^DIQ(200,$PIECE(RACN0,"^",15),.01)
IF X2']""
QUIT
+31 SET Y=$$HLNAME^HLFNC(X2)
IF Y']""
QUIT
+32 SET $PIECE(X1,HLFS,34)=$PIECE(RACN0,"^",15)_$EXTRACT(HLECH)_Y
End DoDot:1
+33 IF $PIECE(RACN0,"^",12)
Begin DoDot:1
+34 SET X2=$$GET1^DIQ(200,$PIECE(RACN0,"^",12),.01)
IF X2']""
QUIT
+35 SET Y=$$HLNAME^HLFNC(X2)
IF Y']""
QUIT
+36 SET $PIECE(X1,HLFS,34)=$PIECE(RACN0,"^",12)_$EXTRACT(HLECH)_Y
End DoDot:1
+37 ;Technician = Technologist
+38 SET $PIECE(X1,HLFS,35)=""
IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0))
Begin DoDot:1
+39 SET X2=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0))
IF X2']""
QUIT
+40 SET X2=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",X2,0)),"^",1)
IF X2']""
QUIT
+41 SET XX2=$$GET1^DIQ(200,X2,.01)
IF XX2']""
QUIT
+42 SET Y=$$HLNAME^HLFNC(XX2)
IF Y']""
QUIT
+43 SET $PIECE(X1,HLFS,35)=X2_$EXTRACT(HLECH)_Y
End DoDot:1
+44 ;Transcriptionist
+45 SET $PIECE(X1,HLFS,36)=""
IF $GET(^RARPT(RARPT,"T"))
Begin DoDot:1
+46 SET X2=$$GET1^DIQ(200,$PIECE(^RARPT(RARPT,"T"),"^",1),.01)
IF X2']""
QUIT
+47 SET Y=$$HLNAME^HLFNC(X2)
IF Y']""
QUIT
+48 SET $PIECE(X1,HLFS,36)=^RARPT(RARPT,"T")_$EXTRACT(HLECH)_Y
End DoDot:1
+49 ;
+50 ; if long str, break so 2nd str begins with separator to avoid abend
+51 NEW RAPART
IF $LENGTH(X1)>245
FOR RAPART=5:1:18
SET RAPART(1)=$PIECE(X1,HLFS,1,RAPART)
SET RAPART(2)=$PIECE(X1,HLFS,RAPART+1,99)
IF $LENGTH(RAPART(1))<245&($LENGTH(RAPART(2))<245)&($PIECE(RAPART(2),HLFS)="")
QUIT
+52 ;if RAPART reaches 18, then something's wrong, so kill RAPART to allow abend due "string too long"
IF $DATA(RAPART)
IF RAPART=18
KILL RAPART
+53 SET RAN=RAN+1
+54 IF $DATA(RAPART)
SET HLA("HLS",RAN)=$PIECE(RAPART(1),HLFS)_HLFS
SET HLA("HLS",RAN,1)=$PIECE(RAPART(1),HLFS,2,99)_HLFS
SET HLA("HLS",RAN,2)=RAPART(2)
KILL RAPART
QUIT
+55 SET HLA("HLS",RAN)=X1
+56 QUIT
OBXDIA ;Compile 'OBX' Segment for Diagnostic Code
+1 SET RAI=$PIECE($GET(^RA(78.3,+$PIECE(RACN0,"^",13),0)),"^")
IF RAI]""
Begin DoDot:1
+2 SET RAN=RAN+1
+3 IF $$PATCH^XPDUTL("MAG*2.5*1")!(+$$VERSION^XPDUTL("MAG")>2.5)
Begin DoDot:2
+4 SET HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$EXTRACT(HLECH)_"DIAGNOSTIC CODE"_$EXTRACT(HLECH)_"L"_HLFS_HLFS_+$PIECE(RACN0,"^",13)_$EXTRACT(HLECH)_RAI_$EXTRACT(HLECH)_"L"
+5 ; Replace above with following when Imaging can cope with ESC chars
+6 ; S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_+$P(RACN0,"^",13)_$E(HLECH)_$$ESCAPE^RAHLRU(RAI)_$E(HLECH)_"L"
End DoDot:2
+7 IF '$TEST
Begin DoDot:2
+8 SET HLA("HLS",RAN)="OBX"_HLFS_HLFS_"ST"_HLFS_"D"_$EXTRACT(HLECH)_"DIAGNOSTIC CODE"_$EXTRACT(HLECH)_"L"_HLFS_HLFS_RAI
End DoDot:2
+9 DO OBX11^RAHLRU
End DoDot:1
+10 ;any secondary dx
IF '$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0))
QUIT
+11 SET X2=0
OBXDIA2 SET X2=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",X2))
IF 'X2
QUIT
+1 SET Y=+^(X2,0)
SET X=$PIECE($GET(^RA(78.3,+Y,0)),U)
+2 IF X]""
Begin DoDot:1
+3 SET RAN=RAN+1
+4 IF $$PATCH^XPDUTL("MAG*2.5*1")!(+$$VERSION^XPDUTL("MAG")>2.5)
Begin DoDot:2
+5 SET HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$EXTRACT(HLECH)_"DIAGNOSTIC CODE"_$EXTRACT(HLECH)_"L"_HLFS_HLFS_Y_$EXTRACT(HLECH)_X_$EXTRACT(HLECH)_"L"
+6 ; Replace above with following when Imaging can cope with ESC chars
+7 ; S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"_HLFS_HLFS_Y_$E(HLECH)_$$ESCAPE^RAHLRU(X)_$E(HLECH)_"L"
End DoDot:2
+8 IF '$TEST
Begin DoDot:2
+9 SET HLA("HLS",RAN)="OBX"_HLFS_HLFS_"ST"_HLFS_"D"_$EXTRACT(HLECH)_"DIAGNOSTIC CODE"_$EXTRACT(HLECH)_"L"_HLFS_HLFS_X
End DoDot:2
+10 DO OBX11^RAHLRU
End DoDot:1
+11 GOTO OBXDIA2
+12 ;
OBXIMP ;Compile 'OBX' segment for Impression
+1 IF '$ORDER(^RARPT(RARPT,"I",0))
SET RAN=RAN+1
SET HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"I"_$EXTRACT(HLECH)_"IMPRESSION"_$EXTRACT(HLECH)_"L"_HLFS_HLFS_"None Entered"
DO OBX11^RAHLRU
QUIT
+2 KILL ^UTILITY($JOB,"W")
SET DIWF=""
SET DIWR=80
SET DIWL=1
+3 FOR RAI=0:0
SET RAI=$ORDER(^RARPT(RARPT,"I",RAI))
IF 'RAI
QUIT
IF $DATA(^(RAI,0))
SET X=^(0)
DO RATELREL
DO ^DIWP
+4 FOR RAI=0:0
SET RAI=$ORDER(^UTILITY($JOB,"W",DIWL,RAI))
IF 'RAI
QUIT
IF $DATA(^(RAI,0))
SET RAN=RAN+1
SET HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"I"_$EXTRACT(HLECH)_"IMPRESSION"_$EXTRACT(HLECH)_"L"_HLFS_HLFS_^(0)
DO OBX11^RAHLRU
+5 QUIT
OBXMOD ;Compile 'OBX' Segment for Modifiers
+1 SET RAN=RAN+1
DO OBXMOD^RAHLRU
+2 QUIT
OBXPRC ;Compile 'OBX' Segment for Procedure
+1 SET RAN=RAN+1
DO OBXPRC^RAHLRU
+2 QUIT
OBXTCM ;Compile 'OBX' Segment for Tech Comments
+1 DO OBXTCM^RAHLRU
+2 QUIT
OBXRPT ;Compile 'OBX' Segment for Radiology Report Text
+1 IF '$ORDER(^RARPT(RARPT,"R",0))
SET RAN=RAN+1
SET HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"R"_$EXTRACT(HLECH)_"REPORT"_$EXTRACT(HLECH)_"L"_HLFS_HLFS_"None Entered"
DO OBX11^RAHLRU
QUIT
+2 KILL ^UTILITY($JOB,"W")
SET DIWF=""
SET DIWR=80
SET DIWL=1
+3 FOR RAI=0:0
SET RAI=$ORDER(^RARPT(RARPT,"R",RAI))
IF 'RAI
QUIT
IF $DATA(^(RAI,0))
SET X=^(0)
DO RATELREL
DO ^DIWP
+4 FOR RAI=0:0
SET RAI=$ORDER(^UTILITY($JOB,"W",DIWL,RAI))
IF 'RAI
QUIT
IF $DATA(^(RAI,0))
SET RAN=RAN+1
SET HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"R"_$EXTRACT(HLECH)_"REPORT"_$EXTRACT(HLECH)_"L"_HLFS_HLFS_^(0)
DO OBX11^RAHLRU
+5 ; Replace above with following when Imaging can cope with ESC chars
+6 ; F RAI=0:0 S RAI=$O(^UTILITY($J,"W",DIWL,RAI)) Q:'RAI I $D(^(RAI,0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"R"_$E(HLECH)_"REPORT"_$E(HLECH)_"L"_HLFS_HLFS_$$ESCAPE^RAHLRU(^(0)) D OBX11^RAHLRU
+7 QUIT
RATELREL ;Release the study for local reading
+1 IF $GET(RATELE)
IF X[$GET(RATELX)
SET RATELREL=1
QUIT
+2 ;
