RAHLRU ;HISC/GJC - utilities for HL7 messaging ; Apr 26, 2023@12:41:24
;;5.0;Radiology/Nuclear Medicine;**10,25,81,103,47,125,162,203**;Mar 16, 1998;Build 1
;
; 08/13/2010 BP/KAM RA*5*103 Outside Report Status Code needs 'F'
;Integration Agreements
;----------------------
;$$GET1^DIQ(2056); $$HLDATE^HLFNC(10106); INIT^HLFNC2(2161)
;GENERATE^HLMA(2164); $$NOW^XLFDT(10103); $$PATCH^XPDUTL(10141)
;$$VERSION^XPDUTL(10141); $$HLNAME^XLFNAME(3065)
;
;IA: global read .01 field, file ^HL(771,
;IA: global read .01 field, file ^HL(771.2,
;IA: global read .01 field, file ^HL(771.5,
;IA: global read .01 field, file ^HL(779.001,
;
; RA*5.0*203 update NSR 20230216 gjc 04/26/23
OBR16 ;set OBR-16 Requesting Physician from the exam 70.03;14
;RAZXAM is the zero node for the exam (70.03)
;called from RAHLR1A & RAHLRPT1
K RAZNME S RAZNME("FILE")=200,RAZNME("IENS")=$P(RAZXAM,U,14)
S RAZNME("FIELD")=.01
S RAOBR(17)=$P(RAZXAM,U,14)_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1))
K RAZNME
Q
;
OBX11 ; set OBX-11, = 12th piece of string where piece 1 is "OBX"
N RARPTIEN,Y
S RARPTIEN=+$G(RARPT)
S Y=$P($G(^RARPT(RARPTIEN,0)),U,5)
; 08/13/2010 BP/KAM RA*5*103 Remedy Call 363538 Changed next line to
; test for 'EF' or 'V'
;S $P(HLA("HLS",RAN),HLFS,12)=$S(Y="R":"P",Y="V":"F",1:"I")
S $P(HLA("HLS",RAN),HLFS,12)=$S(Y="R":"P",(Y="V")!(Y="EF"):"F",1:"I")
; END *103 CHANGE
I $D(^RARPT(RARPTIEN,"ERR")) D Q
.S $P(HLA("HLS",RAN),HLFS,12)="C"
Q
;
ESCAPE(XDTA) ;apply the appropriate escape sequence to a string of data
; Insert a escape sequence place holder, then swap the escape sequence
; place holder with the real escape sequence. This action requires two
; passes because the escape sequence uses the escape ("\") character.
; Input: XDTA=data string to be escaped (if necessary)
; HLFS=field separator (global scope; set in INIT^RAHLR)
; HLECH=encoding characters (global scope; set in INIT^RAHLR)
; Return: XDTA=an escaped data string
;
N UFS,UCS,URS,UEC,USS ;field, component, repetition, escape, & subcomponent
S UFS=HLFS,UCS=$E(HLECH),URS=$E(HLECH,2),UEC=$E(HLECH,3),USS=$E(HLECH,4)
F Q:XDTA'[UFS S XDTA=$P(XDTA,UFS)_$C(1)_$P(XDTA,UFS,2,999)
F Q:XDTA'[UCS S XDTA=$P(XDTA,UCS)_$C(2)_$P(XDTA,UCS,2,999)
F Q:XDTA'[URS S XDTA=$P(XDTA,URS)_$C(3)_$P(XDTA,URS,2,999)
F Q:XDTA'[UEC S XDTA=$P(XDTA,UEC)_$C(4)_$P(XDTA,UEC,2,999)
F Q:XDTA'[USS S XDTA=$P(XDTA,USS)_$C(5)_$P(XDTA,USS,2,999)
F Q:XDTA'[$C(1) S XDTA=$P(XDTA,$C(1))_UEC_"F"_UEC_$P(XDTA,$C(1),2,999)
F Q:XDTA'[$C(2) S XDTA=$P(XDTA,$C(2))_UEC_"S"_UEC_$P(XDTA,$C(2),2,999)
F Q:XDTA'[$C(3) S XDTA=$P(XDTA,$C(3))_UEC_"R"_UEC_$P(XDTA,$C(3),2,999)
F Q:XDTA'[$C(4) S XDTA=$P(XDTA,$C(4))_UEC_"E"_UEC_$P(XDTA,$C(4),2,999)
F Q:XDTA'[$C(5) S XDTA=$P(XDTA,$C(5))_UEC_"T"_UEC_$P(XDTA,$C(5),2,999)
Q XDTA
;
OBXPRC ;Compile 'OBX' Segment for Procedure
S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"P"_$E(HLECH)_"PROCEDURE"_$E(HLECH)_"L"_HLFS_HLFS_$P(RACN0,"^",2)
S X=$S($D(^RAMIS(71,+$P(RACN0,"^",2),0)):$P(^(0),"^"),1:""),HLA("HLS",RAN)=HLA("HLS",RAN)_$E(HLECH)_X_$E(HLECH)_"L" D OBX11
; Replace above with following when Imaging can cope with ESC chars
; S X=$S($D(^RAMIS(71,+$P(RACN0,"^",2),0)):$P(^(0),"^"),1:""),HLA("HLS",RAN)=HLA("HLS",RAN)_$E(HLECH)_$$ESCAPE(X)_$E(HLECH)_"L" D OBX11
Q
OBXMOD ; Compile 'OBX' segments for both types of modifiers
; Procedure modifiers
N X3
D MODS^RAUTL2 S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"M"_$E(HLECH)_"MODIFIERS"_$E(HLECH)_"L"_HLFS_HLFS_Y D OBX11
Q:Y(1)="None"
; CPT Modifiers
F RAI=1:1 S X0=$P(Y(1),", ",RAI),X1=$P(Y(2),", ",RAI) Q:X0="" D
. S RAN=RAN+1
. S X3=$$BASICMOD^RACPTMSC(X1,DT)
. S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"C4"_$E(HLECH)_"CPT MODIFIERS"_$E(HLECH)_"C4"_HLFS_HLFS_X0_$E(HLECH)_$P(X3,"^",3)_$E(HLECH)_"C4"
. ; Replace above with following when Imaging can cope with ESC chars
. ;S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"C4"_$E(HLECH)_"CPT MODIFIERS"_$E(HLECH)_"C4"_HLFS_HLFS_X0_$E(HLECH)_$$ESCAPE($P(X3,"^",3))_$E(HLECH)_"C4"
. I $P(X3,"^",4)]"" S HLA("HLS",RAN)=HLA("HLS",RAN)_$E(HLECH)_$P(X3,"^",4)_$E(HLECH)_$P(X3,"^",3)_$E(HLECH)_"C4"
. ; Replace above with following when Imaging can cope with ESC chars
. ;I $P(X3,"^",4)]"" S HLA("HLS",RAN)=HLA("HLS",RAN)_$E(HLECH)_$P(X3,"^",4)_$E(HLECH)_$$ESCAPE($P(X3,"^",3))_$E(HLECH)_"C4"
. D OBX11
. Q
Q
;
OBXTCM ; Compile 'OBX' segment for latest TECH COMMENT
;
; Only Released version of Imaging 2.5 able to handle Tech Comments
Q:'($$PATCH^XPDUTL("MAG*2.5*1")!(+$$VERSION^XPDUTL("MAG")>2.5))
;
N X4,X3
S X4=$$GETTCOM^RAUTL11(RADFN,RADTI,RACNI)
Q:X4=""
S RAN=RAN+1
S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"TCM"_$E(HLECH)_"TECH COMMENT"_$E(HLECH)_"L"_HLFS_HLFS
D OBX11
I $L(X4)+$L(HLA("HLS",RAN))'>245 D Q
.S $P(HLA("HLS",RAN),HLFS,6)=X4
;
; If Tech Comment is v. long it will need to be
; split into two parts. Do not split words if possible....
;
S X3=$E(X4,1,245-$L(HLA("HLS",RAN)))
I $L(X3," ")>1 S X3=$P(X3," ",1,$L(X3," ")-1)
S X4=$P(X4,X3,2)
S $P(HLA("HLS",RAN),HLFS,6)=X3
S HLA("HLS",RAN,1)=X4_HLFS_$P(HLA("HLS",RAN),HLFS,7,12)
S HLA("HLS",RAN)=$P(HLA("HLS",RAN),HLFS,1,6)
Q
;
INIT ; initialize HL7 variables; called from RAHLR & RAHLRPT
Q:'$G(RAEID) ;undefined server application
S HLDT=$$NOW^XLFDT(),HLDT1=$$HLDATE^HLFNC(HLDT),EID=RAEID
S HL="HLS(""HLS"")",INT=1
D INIT^HLFNC2(EID,.HL,INT)
Q:'$D(HL("Q")) ;improperly defined server application
S HLQ=HL("Q"),HLFS=HL("FS"),HLECH=HL("ECH") K EID,INT
S HLCS=$E(HL("ECH"))
S HLSCS=$E(HL("ECH"),4)
S HLREP=$E(HL("ECH"),2)
Q
;
DOB(X) ;strip off trailing "0"'s from the date of birth
I $E(X,5,6)="00" S X=$E(X,1,4) ;if no month then no day, return year
E I $E(X,7,8)="00" S X=$E(X,1,6) ;if month & no day, return month/year
Q X
;
CPTMOD(RAIEN,HLECH,DT) ;return OBX-5 as it pertains to CPT Modifiers
;called from: RAHLRPT2 & RAHLR1A
;input: RAIEN=IEN of the record in file 81.3
; HLECH=HL7 encoding characters
; DT=today's date
N X S X=$$BASICMOD^RACPTMSC(RAIEN,DT)
;1st piece=IEN #81.3; 3rd piece=versioned name; 5th piece=coding sys
;Q RAIEN_$E(HLECH,1)_$$ESCAPE^RAHLRU($P(X,U,3))_$E(HLECH,1)_$P(X,U,5)
;9/5/08 the above line changed to below per IMAGING
Q $P(X,U,2)_$E(HLECH,1)_$$ESCAPE^RAHLRU($P(X,U,3))_$E(HLECH,1)_"C4"
;
GETSFLAG(SAN,MTN,ETN,VER) ;Return HL message flag (79.721,1)
Q:'$L(SAN)!'$L(MTN)!'$L(ETN)!'$L(VER) 0
S SAN=$O(^HL(771,"B",SAN,0)) Q:'SAN 0
S MTN=$O(^HL(771.2,"B",MTN,0)) Q:'MTN 0
S ETN=$O(^HL(779.001,"B",ETN,0)) Q:'ETN 0
S VER=$O(^HL(771.5,"B",VER,0)) Q:'VER 0
Q +$P($G(^RA(79.7,SAN,1,MTN,1,ETN,1,VER,0)),U,2)
;
OBR21(HLECH,RA7002) ;builds the OBR-21 field; called from RAHLR1A
;Input
; HLECH=encoding characters (required for $$ESCAPE^RAHLRU)
; RA7002=zero node of the REGISTERED EXAMS sub-file of the RAD/NUC MED
; PATIENT (#70) file.
;Return:
; Component one (derived from file #79.2)
; ABBREVIATION(#3)_NAME(#.01)
; Component two (derived from file #79.1)
; File 79.1 IEN_NAME(#.01) of the HOSPITAL LOCATION(#44) record.
; Component three (derived from file #79)
; DIVISION(#.01)_NAME(#.01) of the INSTITUTION(#4) record.
;
;Components as separated by the accent grave "`" (RAPCS); subcomponents by the
;underscore "_" (RAPSS)
;
; Ex: RAD_GENERAL RADIOLOGY`1_TD-RAD`660_SALT LAKE CITY
;
N RAX S RAPCS="`",RAPSS="_",RAX=""
S RA792Q=+$P(RA7002,U,2) ;imaging type pointer
S RA792Q(0)=$G(^RA(79.2,RA792Q,0)) ;imaging type zero node
;create the i-type abbreviation, component separator, and full name string
S RAX=$P(RA792Q(0),U,3)_RAPSS_$P(RA792Q(0),U)
;get hospital location and institution file data...
S RA791Q=+$P(RA7002,U,4) ;imaging location pointer
S RA44Q=+$P($G(^RA(79.1,RA791Q,0)),U) ;hospital location pointer
S RA44Q(0)=$$GET1^DIQ(44,RA44Q,.01) ;hospital location name
S RA4Q=+$P(RA7002,U,3) ;rad/nuc med division pointer dinum'd to INSTITUTION (#4) file
S RA4Q(0)=$$GET1^DIQ(4,RA4Q,.01) ;institution name
S RAX=RAX_RAPCS_RA791Q_RAPSS_RA44Q(0)_RAPCS_RA4Q_RAPSS_RA4Q(0)
K RA4Q,RA44Q,RA791Q,RA792Q,RAPCS,RAPSS
Q $$ESCAPE^RAHLRU(RAX)
;
BLDHLP ;build the HLP("EXCLUDE SUBSCRIBER",n) array
; is HLP("EXCLUDE SUBSCRIBER",n) defined? If yes get 'n'
N RAX,RAY S RAX="EXCLUDE SUBSCRIBER"
S RAY=$$HLPEXSUB(.HLP)
I RAY="" M HLP(RAX)=RASSS(RAX) Q
N RAI S RAI=0
F S RAI=$O(RASSS(RAX,RAI)) Q:RAI'>0 D
.S RAY=RAY+1,HLP(RAX,RAY)=RASSS(RAX,RAI)
.Q
Q
;
HLPEXSUB(A) ;determine the last subscript (n) of a local array
;whose format is: A("EXCLUDE SUBSCRIBER",n)
;Input: A = local array name;
Q $O(A("EXCLUDE SUBSCRIBER",$C(32)),-1)
;
GENERATE ;Broadcast the HL7 message (courtesy of the VistA HL7 application)
N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLP
S HLEID=RAEID,HLARYTYP="LM",HLFORMAT=1,HLMTIEN="",HLP("PRIORITY")="I"
;
;1 - RASSSX is set by the 'Resend Radiology HL7 Messages By Date Range'
; option. GETHLP sets the HLP("EXCLUDE SUBSCRIBER" array
D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX") ;RA5P125
;
;2 - Do we return this HL7 message to the application that broadcasted
; it? The following code also sets the HLP("EXCLUDE SUBSCRIBER" array
D:$D(RASSS("EXCLUDE SUBSCRIBER"))\10 BLDHLP ;RA5P125
;
;Note: Events 1 & 2 are independent of one another. They will never
; set the HLP array in the same process.
;
;//RA5P162 update //
;3 - exclude subscribers that are not teleradiology (file: 79.7)
D:$D(RASSSX1(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX1")
;//RA5P162 update end //
;
D GENERATE^HLMA(RAEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP)
D GSTATUS^RAHLACK(.HLRESLT,RAEID) K HLRESLT
;
EXIT ;kill the variables; exit the process...
K HL771RF,HL771SF,HL7STRG,HLA,HLARYTYP,HLCS,HLDOM,HLECH,HLEID,HLES,HLES2,HLFORMAT
K HLFS,HLINSTN,HLMTIEN,HLN,HLP,HLPARAM,HLPID,HLQ,HLREC,HLREP,HLRFREQ,HLSAN,HLSCS
K HLSFREQ,HLTYPE,HLX,OCXSEG,OCXTSPI,RAOBR,RAORC,RAPID,RAPURGE,RAPV1,RAREFDOC,RAZCPT
K RAZDAYCS,RAZDTE,RAZMODE,RAZNME,RAZORD,RAZORD1,RAZPHONE,RAZPMOD,RAZPREG,RAZPROC
K RAZRPT,RAZRXAM,RAZTRANS,RAZXAM,HLRESLT
K ^UTILITY($J,"W") ;note HLCS, HLREP, & HLSCS are set in INIT^RAHLRU
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAHLRU 10398 printed Sep 23, 2025@20:11:39 Page 2
RAHLRU ;HISC/GJC - utilities for HL7 messaging ; Apr 26, 2023@12:41:24
+1 ;;5.0;Radiology/Nuclear Medicine;**10,25,81,103,47,125,162,203**;Mar 16, 1998;Build 1
+2 ;
+3 ; 08/13/2010 BP/KAM RA*5*103 Outside Report Status Code needs 'F'
+4 ;Integration Agreements
+5 ;----------------------
+6 ;$$GET1^DIQ(2056); $$HLDATE^HLFNC(10106); INIT^HLFNC2(2161)
+7 ;GENERATE^HLMA(2164); $$NOW^XLFDT(10103); $$PATCH^XPDUTL(10141)
+8 ;$$VERSION^XPDUTL(10141); $$HLNAME^XLFNAME(3065)
+9 ;
+10 ;IA: global read .01 field, file ^HL(771,
+11 ;IA: global read .01 field, file ^HL(771.2,
+12 ;IA: global read .01 field, file ^HL(771.5,
+13 ;IA: global read .01 field, file ^HL(779.001,
+14 ;
+15 ; RA*5.0*203 update NSR 20230216 gjc 04/26/23
OBR16 ;set OBR-16 Requesting Physician from the exam 70.03;14
+1 ;RAZXAM is the zero node for the exam (70.03)
+2 ;called from RAHLR1A & RAHLRPT1
+3 KILL RAZNME
SET RAZNME("FILE")=200
SET RAZNME("IENS")=$PIECE(RAZXAM,U,14)
+4 SET RAZNME("FIELD")=.01
+5 SET RAOBR(17)=$PIECE(RAZXAM,U,14)_$EXTRACT(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$EXTRACT(HLECH,1))
+6 KILL RAZNME
+7 QUIT
+8 ;
OBX11 ; set OBX-11, = 12th piece of string where piece 1 is "OBX"
+1 NEW RARPTIEN,Y
+2 SET RARPTIEN=+$GET(RARPT)
+3 SET Y=$PIECE($GET(^RARPT(RARPTIEN,0)),U,5)
+4 ; 08/13/2010 BP/KAM RA*5*103 Remedy Call 363538 Changed next line to
+5 ; test for 'EF' or 'V'
+6 ;S $P(HLA("HLS",RAN),HLFS,12)=$S(Y="R":"P",Y="V":"F",1:"I")
+7 SET $PIECE(HLA("HLS",RAN),HLFS,12)=$SELECT(Y="R":"P",(Y="V")!(Y="EF"):"F",1:"I")
+8 ; END *103 CHANGE
+9 IF $DATA(^RARPT(RARPTIEN,"ERR"))
Begin DoDot:1
+10 SET $PIECE(HLA("HLS",RAN),HLFS,12)="C"
End DoDot:1
QUIT
+11 QUIT
+12 ;
ESCAPE(XDTA) ;apply the appropriate escape sequence to a string of data
+1 ; Insert a escape sequence place holder, then swap the escape sequence
+2 ; place holder with the real escape sequence. This action requires two
+3 ; passes because the escape sequence uses the escape ("\") character.
+4 ; Input: XDTA=data string to be escaped (if necessary)
+5 ; HLFS=field separator (global scope; set in INIT^RAHLR)
+6 ; HLECH=encoding characters (global scope; set in INIT^RAHLR)
+7 ; Return: XDTA=an escaped data string
+8 ;
+9 ;field, component, repetition, escape, & subcomponent
NEW UFS,UCS,URS,UEC,USS
+10 SET UFS=HLFS
SET UCS=$EXTRACT(HLECH)
SET URS=$EXTRACT(HLECH,2)
SET UEC=$EXTRACT(HLECH,3)
SET USS=$EXTRACT(HLECH,4)
+11 FOR
if XDTA'[UFS
QUIT
SET XDTA=$PIECE(XDTA,UFS)_$CHAR(1)_$PIECE(XDTA,UFS,2,999)
+12 FOR
if XDTA'[UCS
QUIT
SET XDTA=$PIECE(XDTA,UCS)_$CHAR(2)_$PIECE(XDTA,UCS,2,999)
+13 FOR
if XDTA'[URS
QUIT
SET XDTA=$PIECE(XDTA,URS)_$CHAR(3)_$PIECE(XDTA,URS,2,999)
+14 FOR
if XDTA'[UEC
QUIT
SET XDTA=$PIECE(XDTA,UEC)_$CHAR(4)_$PIECE(XDTA,UEC,2,999)
+15 FOR
if XDTA'[USS
QUIT
SET XDTA=$PIECE(XDTA,USS)_$CHAR(5)_$PIECE(XDTA,USS,2,999)
+16 FOR
if XDTA'[$CHAR(1)
QUIT
SET XDTA=$PIECE(XDTA,$CHAR(1))_UEC_"F"_UEC_$PIECE(XDTA,$CHAR(1),2,999)
+17 FOR
if XDTA'[$CHAR(2)
QUIT
SET XDTA=$PIECE(XDTA,$CHAR(2))_UEC_"S"_UEC_$PIECE(XDTA,$CHAR(2),2,999)
+18 FOR
if XDTA'[$CHAR(3)
QUIT
SET XDTA=$PIECE(XDTA,$CHAR(3))_UEC_"R"_UEC_$PIECE(XDTA,$CHAR(3),2,999)
+19 FOR
if XDTA'[$CHAR(4)
QUIT
SET XDTA=$PIECE(XDTA,$CHAR(4))_UEC_"E"_UEC_$PIECE(XDTA,$CHAR(4),2,999)
+20 FOR
if XDTA'[$CHAR(5)
QUIT
SET XDTA=$PIECE(XDTA,$CHAR(5))_UEC_"T"_UEC_$PIECE(XDTA,$CHAR(5),2,999)
+21 QUIT XDTA
+22 ;
OBXPRC ;Compile 'OBX' Segment for Procedure
+1 SET HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"P"_$EXTRACT(HLECH)_"PROCEDURE"_$EXTRACT(HLECH)_"L"_HLFS_HLFS_$PIECE(RACN0,"^",2)
+2 SET X=$SELECT($DATA(^RAMIS(71,+$PIECE(RACN0,"^",2),0)):$PIECE(^(0),"^"),1:"")
SET HLA("HLS",RAN)=HLA("HLS",RAN)_$EXTRACT(HLECH)_X_$EXTRACT(HLECH)_"L"
DO OBX11
+3 ; Replace above with following when Imaging can cope with ESC chars
+4 ; S X=$S($D(^RAMIS(71,+$P(RACN0,"^",2),0)):$P(^(0),"^"),1:""),HLA("HLS",RAN)=HLA("HLS",RAN)_$E(HLECH)_$$ESCAPE(X)_$E(HLECH)_"L" D OBX11
+5 QUIT
OBXMOD ; Compile 'OBX' segments for both types of modifiers
+1 ; Procedure modifiers
+2 NEW X3
+3 DO MODS^RAUTL2
SET HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"M"_$EXTRACT(HLECH)_"MODIFIERS"_$EXTRACT(HLECH)_"L"_HLFS_HLFS_Y
DO OBX11
+4 if Y(1)="None"
QUIT
+5 ; CPT Modifiers
+6 FOR RAI=1:1
SET X0=$PIECE(Y(1),", ",RAI)
SET X1=$PIECE(Y(2),", ",RAI)
if X0=""
QUIT
Begin DoDot:1
+7 SET RAN=RAN+1
+8 SET X3=$$BASICMOD^RACPTMSC(X1,DT)
+9 SET HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"C4"_$EXTRACT(HLECH)_"CPT MODIFIERS"_$EXTRACT(HLECH)_"C4"_HLFS_HLFS_X0_$EXTRACT(HLECH)_$PIECE(X3,"^",3)_$EXTRACT(HLECH)_"C4"
+10 ; Replace above with following when Imaging can cope with ESC chars
+11 ;S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"C4"_$E(HLECH)_"CPT MODIFIERS"_$E(HLECH)_"C4"_HLFS_HLFS_X0_$E(HLECH)_$$ESCAPE($P(X3,"^",3))_$E(HLECH)_"C4"
+12 IF $PIECE(X3,"^",4)]""
SET HLA("HLS",RAN)=HLA("HLS",RAN)_$EXTRACT(HLECH)_$PIECE(X3,"^",4)_$EXTRACT(HLECH)_$PIECE(X3,"^",3)_$EXTRACT(HLECH)_"C4"
+13 ; Replace above with following when Imaging can cope with ESC chars
+14 ;I $P(X3,"^",4)]"" S HLA("HLS",RAN)=HLA("HLS",RAN)_$E(HLECH)_$P(X3,"^",4)_$E(HLECH)_$$ESCAPE($P(X3,"^",3))_$E(HLECH)_"C4"
+15 DO OBX11
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
OBXTCM ; Compile 'OBX' segment for latest TECH COMMENT
+1 ;
+2 ; Only Released version of Imaging 2.5 able to handle Tech Comments
+3 if '($$PATCH^XPDUTL("MAG*2.5*1")!(+$$VERSION^XPDUTL("MAG")>2.5))
QUIT
+4 ;
+5 NEW X4,X3
+6 SET X4=$$GETTCOM^RAUTL11(RADFN,RADTI,RACNI)
+7 if X4=""
QUIT
+8 SET RAN=RAN+1
+9 SET HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"TCM"_$EXTRACT(HLECH)_"TECH COMMENT"_$EXTRACT(HLECH)_"L"_HLFS_HLFS
+10 DO OBX11
+11 IF $LENGTH(X4)+$LENGTH(HLA("HLS",RAN))'>245
Begin DoDot:1
+12 SET $PIECE(HLA("HLS",RAN),HLFS,6)=X4
End DoDot:1
QUIT
+13 ;
+14 ; If Tech Comment is v. long it will need to be
+15 ; split into two parts. Do not split words if possible....
+16 ;
+17 SET X3=$EXTRACT(X4,1,245-$LENGTH(HLA("HLS",RAN)))
+18 IF $LENGTH(X3," ")>1
SET X3=$PIECE(X3," ",1,$LENGTH(X3," ")-1)
+19 SET X4=$PIECE(X4,X3,2)
+20 SET $PIECE(HLA("HLS",RAN),HLFS,6)=X3
+21 SET HLA("HLS",RAN,1)=X4_HLFS_$PIECE(HLA("HLS",RAN),HLFS,7,12)
+22 SET HLA("HLS",RAN)=$PIECE(HLA("HLS",RAN),HLFS,1,6)
+23 QUIT
+24 ;
INIT ; initialize HL7 variables; called from RAHLR & RAHLRPT
+1 ;undefined server application
if '$GET(RAEID)
QUIT
+2 SET HLDT=$$NOW^XLFDT()
SET HLDT1=$$HLDATE^HLFNC(HLDT)
SET EID=RAEID
+3 SET HL="HLS(""HLS"")"
SET INT=1
+4 DO INIT^HLFNC2(EID,.HL,INT)
+5 ;improperly defined server application
if '$DATA(HL("Q"))
QUIT
+6 SET HLQ=HL("Q")
SET HLFS=HL("FS")
SET HLECH=HL("ECH")
KILL EID,INT
+7 SET HLCS=$EXTRACT(HL("ECH"))
+8 SET HLSCS=$EXTRACT(HL("ECH"),4)
+9 SET HLREP=$EXTRACT(HL("ECH"),2)
+10 QUIT
+11 ;
DOB(X) ;strip off trailing "0"'s from the date of birth
+1 ;if no month then no day, return year
IF $EXTRACT(X,5,6)="00"
SET X=$EXTRACT(X,1,4)
+2 ;if month & no day, return month/year
IF '$TEST
IF $EXTRACT(X,7,8)="00"
SET X=$EXTRACT(X,1,6)
+3 QUIT X
+4 ;
CPTMOD(RAIEN,HLECH,DT) ;return OBX-5 as it pertains to CPT Modifiers
+1 ;called from: RAHLRPT2 & RAHLR1A
+2 ;input: RAIEN=IEN of the record in file 81.3
+3 ; HLECH=HL7 encoding characters
+4 ; DT=today's date
+5 NEW X
SET X=$$BASICMOD^RACPTMSC(RAIEN,DT)
+6 ;1st piece=IEN #81.3; 3rd piece=versioned name; 5th piece=coding sys
+7 ;Q RAIEN_$E(HLECH,1)_$$ESCAPE^RAHLRU($P(X,U,3))_$E(HLECH,1)_$P(X,U,5)
+8 ;9/5/08 the above line changed to below per IMAGING
+9 QUIT $PIECE(X,U,2)_$EXTRACT(HLECH,1)_$$ESCAPE^RAHLRU($PIECE(X,U,3))_$EXTRACT(HLECH,1)_"C4"
+10 ;
GETSFLAG(SAN,MTN,ETN,VER) ;Return HL message flag (79.721,1)
+1 if '$LENGTH(SAN)!'$LENGTH(MTN)!'$LENGTH(ETN)!'$LENGTH(VER)
QUIT 0
+2 SET SAN=$ORDER(^HL(771,"B",SAN,0))
if 'SAN
QUIT 0
+3 SET MTN=$ORDER(^HL(771.2,"B",MTN,0))
if 'MTN
QUIT 0
+4 SET ETN=$ORDER(^HL(779.001,"B",ETN,0))
if 'ETN
QUIT 0
+5 SET VER=$ORDER(^HL(771.5,"B",VER,0))
if 'VER
QUIT 0
+6 QUIT +$PIECE($GET(^RA(79.7,SAN,1,MTN,1,ETN,1,VER,0)),U,2)
+7 ;
OBR21(HLECH,RA7002) ;builds the OBR-21 field; called from RAHLR1A
+1 ;Input
+2 ; HLECH=encoding characters (required for $$ESCAPE^RAHLRU)
+3 ; RA7002=zero node of the REGISTERED EXAMS sub-file of the RAD/NUC MED
+4 ; PATIENT (#70) file.
+5 ;Return:
+6 ; Component one (derived from file #79.2)
+7 ; ABBREVIATION(#3)_NAME(#.01)
+8 ; Component two (derived from file #79.1)
+9 ; File 79.1 IEN_NAME(#.01) of the HOSPITAL LOCATION(#44) record.
+10 ; Component three (derived from file #79)
+11 ; DIVISION(#.01)_NAME(#.01) of the INSTITUTION(#4) record.
+12 ;
+13 ;Components as separated by the accent grave "`" (RAPCS); subcomponents by the
+14 ;underscore "_" (RAPSS)
+15 ;
+16 ; Ex: RAD_GENERAL RADIOLOGY`1_TD-RAD`660_SALT LAKE CITY
+17 ;
+18 NEW RAX
SET RAPCS="`"
SET RAPSS="_"
SET RAX=""
+19 ;imaging type pointer
SET RA792Q=+$PIECE(RA7002,U,2)
+20 ;imaging type zero node
SET RA792Q(0)=$GET(^RA(79.2,RA792Q,0))
+21 ;create the i-type abbreviation, component separator, and full name string
+22 SET RAX=$PIECE(RA792Q(0),U,3)_RAPSS_$PIECE(RA792Q(0),U)
+23 ;get hospital location and institution file data...
+24 ;imaging location pointer
SET RA791Q=+$PIECE(RA7002,U,4)
+25 ;hospital location pointer
SET RA44Q=+$PIECE($GET(^RA(79.1,RA791Q,0)),U)
+26 ;hospital location name
SET RA44Q(0)=$$GET1^DIQ(44,RA44Q,.01)
+27 ;rad/nuc med division pointer dinum'd to INSTITUTION (#4) file
SET RA4Q=+$PIECE(RA7002,U,3)
+28 ;institution name
SET RA4Q(0)=$$GET1^DIQ(4,RA4Q,.01)
+29 SET RAX=RAX_RAPCS_RA791Q_RAPSS_RA44Q(0)_RAPCS_RA4Q_RAPSS_RA4Q(0)
+30 KILL RA4Q,RA44Q,RA791Q,RA792Q,RAPCS,RAPSS
+31 QUIT $$ESCAPE^RAHLRU(RAX)
+32 ;
BLDHLP ;build the HLP("EXCLUDE SUBSCRIBER",n) array
+1 ; is HLP("EXCLUDE SUBSCRIBER",n) defined? If yes get 'n'
+2 NEW RAX,RAY
SET RAX="EXCLUDE SUBSCRIBER"
+3 SET RAY=$$HLPEXSUB(.HLP)
+4 IF RAY=""
MERGE HLP(RAX)=RASSS(RAX)
QUIT
+5 NEW RAI
SET RAI=0
+6 FOR
SET RAI=$ORDER(RASSS(RAX,RAI))
if RAI'>0
QUIT
Begin DoDot:1
+7 SET RAY=RAY+1
SET HLP(RAX,RAY)=RASSS(RAX,RAI)
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
HLPEXSUB(A) ;determine the last subscript (n) of a local array
+1 ;whose format is: A("EXCLUDE SUBSCRIBER",n)
+2 ;Input: A = local array name;
+3 QUIT $ORDER(A("EXCLUDE SUBSCRIBER",$CHAR(32)),-1)
+4 ;
GENERATE ;Broadcast the HL7 message (courtesy of the VistA HL7 application)
+1 NEW HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLP
+2 SET HLEID=RAEID
SET HLARYTYP="LM"
SET HLFORMAT=1
SET HLMTIEN=""
SET HLP("PRIORITY")="I"
+3 ;
+4 ;1 - RASSSX is set by the 'Resend Radiology HL7 Messages By Date Range'
+5 ; option. GETHLP sets the HLP("EXCLUDE SUBSCRIBER" array
+6 ;RA5P125
if $DATA(RASSSX(HLEID))
DO GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX")
+7 ;
+8 ;2 - Do we return this HL7 message to the application that broadcasted
+9 ; it? The following code also sets the HLP("EXCLUDE SUBSCRIBER" array
+10 ;RA5P125
if $DATA(RASSS("EXCLUDE SUBSCRIBER"))\10
DO BLDHLP
+11 ;
+12 ;Note: Events 1 & 2 are independent of one another. They will never
+13 ; set the HLP array in the same process.
+14 ;
+15 ;//RA5P162 update //
+16 ;3 - exclude subscribers that are not teleradiology (file: 79.7)
+17 if $DATA(RASSSX1(HLEID))
DO GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX1")
+18 ;//RA5P162 update end //
+19 ;
+20 DO GENERATE^HLMA(RAEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP)
+21 DO GSTATUS^RAHLACK(.HLRESLT,RAEID)
KILL HLRESLT
+22 ;
EXIT ;kill the variables; exit the process...
+1 KILL HL771RF,HL771SF,HL7STRG,HLA,HLARYTYP,HLCS,HLDOM,HLECH,HLEID,HLES,HLES2,HLFORMAT
+2 KILL HLFS,HLINSTN,HLMTIEN,HLN,HLP,HLPARAM,HLPID,HLQ,HLREC,HLREP,HLRFREQ,HLSAN,HLSCS
+3 KILL HLSFREQ,HLTYPE,HLX,OCXSEG,OCXTSPI,RAOBR,RAORC,RAPID,RAPURGE,RAPV1,RAREFDOC,RAZCPT
+4 KILL RAZDAYCS,RAZDTE,RAZMODE,RAZNME,RAZORD,RAZORD1,RAZPHONE,RAZPMOD,RAZPREG,RAZPROC
+5 KILL RAZRPT,RAZRXAM,RAZTRANS,RAZXAM,HLRESLT
+6 ;note HLCS, HLREP, & HLSCS are set in INIT^RAHLRU
KILL ^UTILITY($JOB,"W")
+7 QUIT
+8 ;
