RAHLR1 ;HISC/GJC - Generate Common Order (ORM) Message ;18 Jul 2019 9:17 AM
;;5.0;Radiology/Nuclear Medicine;**47,125,129,158**;Mar 16, 1998;Build 2
;Generates msg whenever a case is registered or cancelled or examined
; registered cancelled examined complete
; Order control : NW CA XO XO
; Order status : IP CA IP CM
;
;Integration Agreements
;----------------------
;$$GET1^DIQ(10060); NPFON^MAG7UFO(5021); $$FMTHL7^XLFDT(10103)
;$$HLNAME^XLFNAME(3065); $$NS^XUAF4(2171); $$KSP^XUPARAM(2541)
;
;IA: 767 global read on ^DGSL(38.1,D0,0)
;IA: 10039 global read on ^DIC(42,D0,44)
;IA: 10040 global read on ^SC(D0
;
EN(RADFN,RADTI,RACNI,RAEID) ;Called from RA REG*, RA EXAMINED*, & RA CANCEL*
;event driver protocols whose HL7 version exceeds version 2.3.
;
; Input Variables (from RAHLR):
; 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)
; RACN0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
; Output variables:
; HLA("HLS", array containing HL7 msg
;
N RAPID,RAPV1,RAORC,RAOBR,RAOBX,RAX,X,XX,I,I1,I2,I3,II
;initialize Rad/Nuc Med specific variables
D:'$D(HLFS)!'$D(HL) INIT^RAHLRU
D INIT
;RA*5*82 RAEXEDT= Override the EXM conditions if Case edited
I '$G(RAEXEDT),$G(RAEXMDUN)=1,$P(RAZXAM,U,30)'="" Q ;last chance to stop exm'd msg if it's already been sent
;
PID ;compile the PID segment
D PID^RAHLRU1(+RADFN)
;
PV1 ;compile the PV1 segment determine if the patient is
;an inpatient or outpatient by looking at the exam record
D PV1^RAHLRU1(+RADFN)
;
ORC ;build the 'common order segment (ORC) segment
;RACANC is the status of the exam 'cancelled'? If ORDER (#3) field in
;the EXAMINATION STATUS (#72) file is set to zero, the exam has been
;cancelled. If order is set to nine, the exam is complete.
S RAXAMSTS=$P($G(^RA(72,+$P(RAZXAM,U,3),0)),U,3)
S RACANC=$S(RAXAMSTS=0:1,1:0),RACOMP=$S(RAXAMSTS=9:1,1:0)
S RAORC(2)=$S(RACANC:"CA",$G(RAEXMDUN)=1:"XO",1:"NW")
; define ORC-2 & ORC-3 to 'site id-mmddyy-case#' ex: 141-041106-6
; 9/2008 -- check Site Acc Number division parameter (79,.131) and only
; use the long site specific acc num if set to YES, else use old form
;
;iff pset: build the following unique patient/study identifier
;@Indy INC6620428
;ORC(4)=141-76-6809282.8562
;1st piece = 141 (station # 3 chars fixed)
;2nd piece = 76 (patient DFN)
;3rd piece = 6809282.8562 (inverse date/time of study)
I $P(RAZXAM,U,25)=2 D ;DD - 70.03;25 (combined report)
.S RAORC(5)=$P(RAPID(3),HLCS)_"-"_RADTI
.Q
;
S (RAORC(3),RAORC(4))=RAZDAYCS
S RAORC(6)=$S(RACANC:"CA",RACOMP:"CM",1:"IP")
;
;new logic in determining the value of order status (ORC-5)
;discovered in the development and testing of p47 on 01/14/2010
;Variables:
; RA101Z - defined in RAHLRPC
; RAOPT - array set/killed in the entry/exit actions in options:
;- [RA HL7 MESSAGE RESEND]
;- [RA HL7 RESEND BY DATE RANGE]
; these two options may impact the definition of ORC-5
I $E($O(RAOPT("")),1,6)="RESEND",($E($G(RA101Z),1,6)="RA REG") S RAORC(6)="IP"
;Executing the RA REG* event driver(s) should send an order control (ORC-1)
;value of 'NW' & an order status value of 'IP' when the aforementioned options
;are exercised.
;
;Quantity/Timing ORC-7.4 SCHEDULED DATE (TIME optional) 75.1;23
;Priority ORC-7.6 REQUEST URGENCY of order 75.1;6
S RAORC(8)=$$REPEAT^RAHLRU1($E(HLECH,1),3)_$$FMTHL7^XLFDT($P(RAZORD,U,23))_$$REPEAT^RAHLRU1($E(HLECH,1),2)_$S($P(RAZORD,U,6)=1:"S",$P(RAZORD,U,6)=2:"A",1:"R")
;Parent ORC-8 MEMBER OF SET (70.03;25); PURGED DATE (70.03,40)
S RAORC(9)=$$PARENT(RAPURGE,$P(RAZXAM,U,25))
;Note: ORC-8 & OBR-29 share the same value
;
;S RAORC(10)=$$FMTHL7^XLFDT($P(RAZORD,U,16)) ;transaction d/t (order)
S RAORC(10)=$$FMTHL7^XLFDT($P(RAZRXAM,U)) ;transaction d/t (exam d/t registered)
;
;Entered By ORC-10 (USER ENTERING REQUEST) 75.1;15
I $P(RAZORD,U,15),($$GET1^DIQ(200,$P(RAZORD,U,15),.01)'="") D
.S RAZNME("FILE")=200,RAZNME("IENS")=$P(RAZORD,U,15)
.S RAZNME("FIELD")=.01
.S RAORC(11)=$P(RAZORD,U,15)_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E($G(HLECH)))
.Q
;Ordering Provider ORC-12 (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 RAORC(13)=$P(RAZORD,U,14)_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E($G(HLECH)))
.Q
;Enterer's Location ORC-13 (USER ENTERING REQUEST)
S RASERSEC=$$ESCAPE^RAHLRU($$GET1^DIQ(200,$P(RAZORD,U,15),29))
S RAORC(14)=RASERSEC ;SERVICE/SECTION
;
;Call Back Phone numbers of Ordering Provider ORC-14
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) RAORC(15)=$E(M,1,$L(M)-1)
;
;Enterer's Organization ORC-17 (USER ENTERING REQUEST)
S RASERSEC(0)=+$$GET1^DIQ(200,$P(RAZORD,U,15),29,"I") ;pointer to 49
S RASERSEC(1)=$$GET1^DIQ(49,RASERSEC(0),1) ;abbr. of service/section
S RAORC(18)=RASERSEC(1)_$E(HLECH)_RASERSEC_$E(HLECH)_"VISTA49"
;build the ORC segment; set the HLA array
D BLSEG^RAHLRU1("ORC",.RAORC)
K RACANC,RACOMP,RASERSEC,RAXAMSTS,RAZNME,RAZPHONE
;
D:$T(EN^RAHLR1A)]"" EN^RAHLR1A ;continue building the OBR, OBX, & ZDS segments
;
; Broadcast the HL7 message and cleanup the symbol table
D GENERATE^RAHLRU
Q
;
INIT ;initialize some basic package specific variables
S:'($D(U)#2) U="^"
S RAZRXAM=$G(^RADPT(RADFN,"DT",RADTI,0)) ;reg. exam zero node
S RAZXAM=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) ;exam zero node
S RAPURGE=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PURGE"))
S RAZDTE=9999999.9999-RADTI ;FM internal date/time
; Check if SSAN is to be used:
I $$USESSAN^RAHLRU1()=1 D ;use SSAN as accession
.S RAZDAYCS=$P(RAZXAM,"^",31)
.; It could be that an old study is being resent
.; so build the SSAN on the fly.
.S:RAZDAYCS="" RAZDAYCS=$$ACCNUM^RAAPI(RADFN,RADTI,RACNI)
.Q
; odd, but v2.4 protocols activated w/o SSANs being used
E D
.; Legacy Accession Number: mmddyy-case#
.S RAZDAYCS=$E(RAZDTE,4,7)_$E(RAZDTE,2,3)_"-"_+RAZXAM
.Q
;
S RAZORD=$G(^RAO(75.1,+$P(RAZXAM,U,11),0)) ;rad/nuc med order zero node
S RAZORD1=$P($G(^RAO(75.1,+$P(RAZXAM,U,11),.1)),U) ;rad/nuc reason for study
S RAZPROC=$G(^RAMIS(71,+$P(RAZXAM,U,2),0)) ;exam specific procedure
Q
;
PARENT(PRGE,PRNT) ;Define fields ORC-8 & OBR-29 known as PARENT
; input: PRGE=purge date of the exam (if applicable)
; PRNT=parent/descendant if yes, specify if exam or printset
;return: VALUE=ORIGINAL ORDER PURGED if purged, EXAMSET: proc_name
; if examset, PRINTSET: proc_name if printset, or null.
N VALUE ;RA5P125
I PRGE,(PRGE'>DT) S VALUE="ORIGINAL ORDER PURGED"
I PRNT S VALUE=$S(PRNT=1:"Examset: ",1:"Printset: ")_$P($G(^RAMIS(71,+$P(RAZORD,U,2),0)),U)
Q $G(VALUE)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAHLR1 7164 printed Apr 09, 2024@21:40:59 Page 2
RAHLR1 ;HISC/GJC - Generate Common Order (ORM) Message ;18 Jul 2019 9:17 AM
+1 ;;5.0;Radiology/Nuclear Medicine;**47,125,129,158**;Mar 16, 1998;Build 2
+2 ;Generates msg whenever a case is registered or cancelled or examined
+3 ; registered cancelled examined complete
+4 ; Order control : NW CA XO XO
+5 ; Order status : IP CA IP CM
+6 ;
+7 ;Integration Agreements
+8 ;----------------------
+9 ;$$GET1^DIQ(10060); NPFON^MAG7UFO(5021); $$FMTHL7^XLFDT(10103)
+10 ;$$HLNAME^XLFNAME(3065); $$NS^XUAF4(2171); $$KSP^XUPARAM(2541)
+11 ;
+12 ;IA: 767 global read on ^DGSL(38.1,D0,0)
+13 ;IA: 10039 global read on ^DIC(42,D0,44)
+14 ;IA: 10040 global read on ^SC(D0
+15 ;
EN(RADFN,RADTI,RACNI,RAEID) ;Called from RA REG*, RA EXAMINED*, & RA CANCEL*
+1 ;event driver protocols whose HL7 version exceeds version 2.3.
+2 ;
+3 ; Input Variables (from RAHLR):
+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 ; RACN0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
+9 ; Output variables:
+10 ; HLA("HLS", array containing HL7 msg
+11 ;
+12 NEW RAPID,RAPV1,RAORC,RAOBR,RAOBX,RAX,X,XX,I,I1,I2,I3,II
+13 ;initialize Rad/Nuc Med specific variables
+14 if '$DATA(HLFS)!'$DATA(HL)
DO INIT^RAHLRU
+15 DO INIT
+16 ;RA*5*82 RAEXEDT= Override the EXM conditions if Case edited
+17 ;last chance to stop exm'd msg if it's already been sent
IF '$GET(RAEXEDT)
IF $GET(RAEXMDUN)=1
IF $PIECE(RAZXAM,U,30)'=""
QUIT
+18 ;
PID ;compile the PID segment
+1 DO PID^RAHLRU1(+RADFN)
+2 ;
PV1 ;compile the PV1 segment determine if the patient is
+1 ;an inpatient or outpatient by looking at the exam record
+2 DO PV1^RAHLRU1(+RADFN)
+3 ;
ORC ;build the 'common order segment (ORC) segment
+1 ;RACANC is the status of the exam 'cancelled'? If ORDER (#3) field in
+2 ;the EXAMINATION STATUS (#72) file is set to zero, the exam has been
+3 ;cancelled. If order is set to nine, the exam is complete.
+4 SET RAXAMSTS=$PIECE($GET(^RA(72,+$PIECE(RAZXAM,U,3),0)),U,3)
+5 SET RACANC=$SELECT(RAXAMSTS=0:1,1:0)
SET RACOMP=$SELECT(RAXAMSTS=9:1,1:0)
+6 SET RAORC(2)=$SELECT(RACANC:"CA",$GET(RAEXMDUN)=1:"XO",1:"NW")
+7 ; define ORC-2 & ORC-3 to 'site id-mmddyy-case#' ex: 141-041106-6
+8 ; 9/2008 -- check Site Acc Number division parameter (79,.131) and only
+9 ; use the long site specific acc num if set to YES, else use old form
+10 ;
+11 ;iff pset: build the following unique patient/study identifier
+12 ;@Indy INC6620428
+13 ;ORC(4)=141-76-6809282.8562
+14 ;1st piece = 141 (station # 3 chars fixed)
+15 ;2nd piece = 76 (patient DFN)
+16 ;3rd piece = 6809282.8562 (inverse date/time of study)
+17 ;DD - 70.03;25 (combined report)
IF $PIECE(RAZXAM,U,25)=2
Begin DoDot:1
+18 SET RAORC(5)=$PIECE(RAPID(3),HLCS)_"-"_RADTI
+19 QUIT
End DoDot:1
+20 ;
+21 SET (RAORC(3),RAORC(4))=RAZDAYCS
+22 SET RAORC(6)=$SELECT(RACANC:"CA",RACOMP:"CM",1:"IP")
+23 ;
+24 ;new logic in determining the value of order status (ORC-5)
+25 ;discovered in the development and testing of p47 on 01/14/2010
+26 ;Variables:
+27 ; RA101Z - defined in RAHLRPC
+28 ; RAOPT - array set/killed in the entry/exit actions in options:
+29 ;- [RA HL7 MESSAGE RESEND]
+30 ;- [RA HL7 RESEND BY DATE RANGE]
+31 ; these two options may impact the definition of ORC-5
+32 IF $EXTRACT($ORDER(RAOPT("")),1,6)="RESEND"
IF ($EXTRACT($GET(RA101Z),1,6)="RA REG")
SET RAORC(6)="IP"
+33 ;Executing the RA REG* event driver(s) should send an order control (ORC-1)
+34 ;value of 'NW' & an order status value of 'IP' when the aforementioned options
+35 ;are exercised.
+36 ;
+37 ;Quantity/Timing ORC-7.4 SCHEDULED DATE (TIME optional) 75.1;23
+38 ;Priority ORC-7.6 REQUEST URGENCY of order 75.1;6
+39 SET RAORC(8)=$$REPEAT^RAHLRU1($EXTRACT(HLECH,1),3)_$$FMTHL7^XLFDT($PIECE(RAZORD,U,23))_$$REPEAT^RAHLRU1($EXTRACT(HLECH,1),2)_$SELECT($PIECE(RAZORD,U,6)=1:"S",$PIECE(RAZORD,U,6)=2:"A",1:"R")
+40 ;Parent ORC-8 MEMBER OF SET (70.03;25); PURGED DATE (70.03,40)
+41 SET RAORC(9)=$$PARENT(RAPURGE,$PIECE(RAZXAM,U,25))
+42 ;Note: ORC-8 & OBR-29 share the same value
+43 ;
+44 ;S RAORC(10)=$$FMTHL7^XLFDT($P(RAZORD,U,16)) ;transaction d/t (order)
+45 ;transaction d/t (exam d/t registered)
SET RAORC(10)=$$FMTHL7^XLFDT($PIECE(RAZRXAM,U))
+46 ;
+47 ;Entered By ORC-10 (USER ENTERING REQUEST) 75.1;15
+48 IF $PIECE(RAZORD,U,15)
IF ($$GET1^DIQ(200,$PIECE(RAZORD,U,15),.01)'="")
Begin DoDot:1
+49 SET RAZNME("FILE")=200
SET RAZNME("IENS")=$PIECE(RAZORD,U,15)
+50 SET RAZNME("FIELD")=.01
+51 SET RAORC(11)=$PIECE(RAZORD,U,15)_$EXTRACT(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$EXTRACT($GET(HLECH)))
+52 QUIT
End DoDot:1
+53 ;Ordering Provider ORC-12 (REQUESTING PHYSICIAN) 75.1;14
+54 IF $PIECE(RAZORD,U,14)
IF ($$GET1^DIQ(200,$PIECE(RAZORD,U,14),.01)'="")
Begin DoDot:1
+55 KILL RAZNME
SET RAZNME("FILE")=200
SET RAZNME("IENS")=$PIECE(RAZORD,U,14)
+56 SET RAZNME("FIELD")=.01
+57 SET RAORC(13)=$PIECE(RAZORD,U,14)_$EXTRACT(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$EXTRACT($GET(HLECH)))
+58 QUIT
End DoDot:1
+59 ;Enterer's Location ORC-13 (USER ENTERING REQUEST)
+60 SET RASERSEC=$$ESCAPE^RAHLRU($$GET1^DIQ(200,$PIECE(RAZORD,U,15),29))
+61 ;SERVICE/SECTION
SET RAORC(14)=RASERSEC
+62 ;
+63 ;Call Back Phone numbers of Ordering Provider ORC-14
+64 Begin DoDot:1
+65 NEW RAX,I,M
SET M=""
SET I=0
+66 DO NPFON^MAG7UFO("RAX",$PIECE(RAZORD,U,14))
+67 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)
+68 if $LENGTH(M)
SET RAORC(15)=$EXTRACT(M,1,$LENGTH(M)-1)
End DoDot:1
+69 ;
+70 ;Enterer's Organization ORC-17 (USER ENTERING REQUEST)
+71 ;pointer to 49
SET RASERSEC(0)=+$$GET1^DIQ(200,$PIECE(RAZORD,U,15),29,"I")
+72 ;abbr. of service/section
SET RASERSEC(1)=$$GET1^DIQ(49,RASERSEC(0),1)
+73 SET RAORC(18)=RASERSEC(1)_$EXTRACT(HLECH)_RASERSEC_$EXTRACT(HLECH)_"VISTA49"
+74 ;build the ORC segment; set the HLA array
+75 DO BLSEG^RAHLRU1("ORC",.RAORC)
+76 KILL RACANC,RACOMP,RASERSEC,RAXAMSTS,RAZNME,RAZPHONE
+77 ;
+78 ;continue building the OBR, OBX, & ZDS segments
if $TEXT(EN^RAHLR1A)]""
DO EN^RAHLR1A
+79 ;
+80 ; Broadcast the HL7 message and cleanup the symbol table
+81 DO GENERATE^RAHLRU
+82 QUIT
+83 ;
INIT ;initialize some basic package specific variables
+1 if '($DATA(U)#2)
SET U="^"
+2 ;reg. exam zero node
SET RAZRXAM=$GET(^RADPT(RADFN,"DT",RADTI,0))
+3 ;exam zero node
SET RAZXAM=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+4 SET RAPURGE=+$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PURGE"))
+5 ;FM internal date/time
SET RAZDTE=9999999.9999-RADTI
+6 ; Check if SSAN is to be used:
+7 ;use SSAN as accession
IF $$USESSAN^RAHLRU1()=1
Begin DoDot:1
+8 SET RAZDAYCS=$PIECE(RAZXAM,"^",31)
+9 ; It could be that an old study is being resent
+10 ; so build the SSAN on the fly.
+11 if RAZDAYCS=""
SET RAZDAYCS=$$ACCNUM^RAAPI(RADFN,RADTI,RACNI)
+12 QUIT
End DoDot:1
+13 ; odd, but v2.4 protocols activated w/o SSANs being used
+14 IF '$TEST
Begin DoDot:1
+15 ; Legacy Accession Number: mmddyy-case#
+16 SET RAZDAYCS=$EXTRACT(RAZDTE,4,7)_$EXTRACT(RAZDTE,2,3)_"-"_+RAZXAM
+17 QUIT
End DoDot:1
+18 ;
+19 ;rad/nuc med order zero node
SET RAZORD=$GET(^RAO(75.1,+$PIECE(RAZXAM,U,11),0))
+20 ;rad/nuc reason for study
SET RAZORD1=$PIECE($GET(^RAO(75.1,+$PIECE(RAZXAM,U,11),.1)),U)
+21 ;exam specific procedure
SET RAZPROC=$GET(^RAMIS(71,+$PIECE(RAZXAM,U,2),0))
+22 QUIT
+23 ;
PARENT(PRGE,PRNT) ;Define fields ORC-8 & OBR-29 known as PARENT
+1 ; input: PRGE=purge date of the exam (if applicable)
+2 ; PRNT=parent/descendant if yes, specify if exam or printset
+3 ;return: VALUE=ORIGINAL ORDER PURGED if purged, EXAMSET: proc_name
+4 ; if examset, PRINTSET: proc_name if printset, or null.
+5 ;RA5P125
NEW VALUE
+6 IF PRGE
IF (PRGE'>DT)
SET VALUE="ORIGINAL ORDER PURGED"
+7 IF PRNT
SET VALUE=$SELECT(PRNT=1:"Examset: ",1:"Printset: ")_$PIECE($GET(^RAMIS(71,+$PIECE(RAZORD,U,2),0)),U)
+8 QUIT $GET(VALUE)
+9 ;
