RAHLR1A ;HISC/GJC - Generate Common Order (ORM) Message ; Apr 26, 2023@12:37:42
;;5.0;Radiology/Nuclear Medicine;**47,203**;Mar 16, 1998;Build 1
;
;
;Integration Agreements
;----------------------
;$$GET1^DIQ(2056); ^DIWP(10011); NPFON^MAG7UFO(5021)
;$$ZDS^MAGDRAHL(5022); $$FMTHL7^XLFDT(10103); $$HLNAME^XLFNAME(3065)
;
;IA: 767 global read on ^DGSL(38.1,D0,0)
;calls to $$GET1^DIQ(44,IEN,.01) covered by IA: 10040
;calls to $$GET1^DIQ(4,IEN,.01) covered by IA: 10090
;
EN ;Called from RAHLR1; used to build the OBR, OBX, & ZDS segments
;The following key variables are defined in INIT^RAHLR1
;RAZRXAM=reg. exam zero node
;RAZXAM=exam zero node
;RAZDTE=9999999.9999-RADTI ;FM internal date/time
;RAZDAYCS:
; IF SSAN SITE PARAMETER="Y" RAZDAYCS=SSAN (sss-mmddyy-case#)
; ELSE IF SSAN'="Y" RAZDAYCS=DAY CASE# (mmddyy-case#)
;RAZORD=rad/nuc med order zero node
;RAZPROC=exam specific procedure
;
;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,PI,PTR,X,Y,Z,RAX,RAXX
;Compile OBR Segment
;Set ID OBR-1
OBRPRC ;OBR segment
S RAOBR(2)=1
;Placer Order Number OBR-2 site id-mmddyy-case#
;Filler Order Number OBR-3 site id-mmddyy-case#
; RAZDAYCS will be set to SSAN (site specific acc number) if the Site
; Acc Number division parameter (79,.131)=YES, else DAY CASE# format
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(5)=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"
;Priority OBR-5 (REQUEST URGENCY) 75.1;6
S RAOBR(6)=$S($P(RAZORD,U,6)=1:"S",$P(RAZORD,U,6)=2:"A",1:"R")
;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
;
;RA*5.0*203 update NSR 20230216 gjc 04/26/23
;From: Req. Physician on the order (75.1;14)
; To: Req. Physician on the exam (70.03;14)
;Ordering Provider OBR-16 (REQUESTING PHYSICIAN) 70.03;14
I $P(RAZXAM,U,14),($$GET1^DIQ(200,$P(RAZXAM,U,14),.01)'="") D OBR16^RAHLRU
;
;Call Back Phone numbers of Ordering Provider OBR-17 (mirrors 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) 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
S RAOBR(22)=$$OBR21^RAHLRU(HLECH,RAZRXAM)
;
;Diagnostic Service Section ID OBR-24 MODALITY 71.0731 ptr to #73.1
;we capture modality data if there is only one sub-file record
S RAZIEN=+$O(^RAMIS(71,+$P(RAZXAM,U,2),"MDL",0))
I RAZIEN,(RAZIEN=$O(^RAMIS(71,+$P(RAZXAM,U,2),"MDL",$C(32)),-1)) D
.S RAZMODAL=+$G(^RAMIS(71,+$P(RAZXAM,U,2),"MDL",RAZIEN,0))
.S RAOBR(25)=$$ESCAPE^RAHLRU($P($G(^RAMIS(73.1,RAZMODAL,0)),U))
.Q
;Quantity/Timing OBR-27.4 equates to SCHEDULED DATE (TIME optional)
; 75.1;23 Priority OBR-27.6 equates to REQUEST URGENCY of order 75.1;6
;Quantity/Timing OBR-27 (OBR-27 & ORC-7 share the same value)
S RAOBR(28)=$$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 OBR-29 (OBR-29 & ORC-8 share the same value)
S RAOBR(30)=$G(RAORC(9)) ;see PARENT^RAHLR1
;
;Transportation Mode OBR-30 75.1;19
S RAZTMODE=$P(RAZORD,U,19)
S RAOBR(31)=$S(RAZTMODE="a":"WALK",RAZTMODE="w":"WHLC",RAZTMODE="s":"CART",RAZTMODE="p":"PORT",1:"")
;Reason for Study OBR-31
S $P(RAOBR(32),HLCS,2)=$S($L(RAZORD1):RAZORD1,1:"See Clinical History:")
;build the OBR segment
D BLSEG^RAHLRU1("OBR",.RAOBR)
;build the ZDS segment
D ZDS(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)="O"
D BLSEG^RAHLRU1("OBX",.RAOBX) K RAOBX
;
OBXPMOD ;Compile 'OBX' segment for procedure modifiers
S RAOBX(2)=$G(RAXX)
S RAOBX(3)="TX",RAOBX(4)="M"_$E(HLECH)_"MODIFIERS"_$E(HLECH)_"L"
S RAOBX(12)="O",(I,J)=0
F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",I)) Q:'I D
.S PTR=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",I,0))
.S J=J+1,RAOBX(2)=RAXX+J,RAOBX(6)=$$ESCAPE^RAHLRU($P($G(^RAMIS(71.2,PTR,0)),U))
.D BLSEG^RAHLRU1("OBX",.RAOBX)
.Q
S RAXX=RAOBX(2)
K RAOBX
;
OBXCPTM ;Compile 'OBX' segment for CPT modifiers
S RAOBX(2)=$G(RAXX)
S RAOBX(3)="CE",RAOBX(4)="C4"_$E(HLECH)_"CPT MODIFIERS"_$E(HLECH)_"L"
S RAOBX(12)="O",(I,J)=0
F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",I)) Q:'I D
.S PTR=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",I,0))
.S J=J+1,RAOBX(2)=RAXX+J,RAOBX(6)=$$CPTMOD^RAHLRU(PTR,HLECH,DT)
.D BLSEG^RAHLRU1("OBX",.RAOBX)
S RAXX=RAOBX(2)
K RAOBX,RAZCPTM
;
OBXHIST ;Compile 'OBX' Segment for Clinical History
I $L(RAZORD1) D ;add Reason for Study as a prefix
.S RAXX=RAXX+1,RAOBX(2)=RAXX,RAOBX(3)="TX"
.S RAOBX(4)="H"_$E(HLECH)_"HISTORY"_$E(HLECH)_"L",RAOBX(12)="O"
.S RAOBX(6)="Reason for Study: "_$$ESCAPE^RAHLRU($G(RAZORD1))
.D BLSEG^RAHLRU1("OBX",.RAOBX)
.S RAXX=RAXX+1,RAOBX(2)=RAXX,RAOBX(3)="TX"
.S RAOBX(4)="H"_$E(HLECH)_"HISTORY"_$E(HLECH)_"L",RAOBX(12)="O"
.S RAOBX(6)=" " ;blank line to separate Reason For Study & Clin Hist
.D BLSEG^RAHLRU1("OBX",.RAOBX)
.Q
I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0)) D
.S RAOBX(2)=$G(RAXX),RAOBX(3)="TX"
.S RAOBX(4)="H"_$E(HLECH)_"HISTORY"_$E(HLECH)_"L"
.;accumulate data into ^UTILITY($J,"W")...
.K ^UTILITY($J,"W")
.S DIWF="",DIWR=80,(DIWL,RADIWL)=1,RAI=0
.F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAI)) Q:'RAI D
..S X=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAI,0)) D ^DIWP
..Q
.;build the OBX segment from the data in ^UTILITY($J,"W")...
.S (I,J)=0,RAOBX(12)="O"
.F S I=$O(^UTILITY($J,"W",RADIWL,I)) Q:'I D
..S J=J+1,RAOBX(2)=RAXX+J
..S RAOBX(6)=$$ESCAPE^RAHLRU($G(^UTILITY($J,"W",RADIWL,I,0)))
..D BLSEG^RAHLRU1("OBX",.RAOBX)
..Q
.S RAXX=RAOBX(2)
.Q
K DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,RADIWL,RAI,RAOBX,^UTILITY($J,"W")
;
OBXALL ;Compile 'OBX' Segment for Allergies
N DFN S DFN=RADFN D ALLERGY^RADEM
S RAOBX(2)=$G(RAXX)
S RAOBX(3)="TX",RAOBX(4)="A"_$E(HLECH)_"ALLERGIES"_$E(HLECH)_"L"
S RAOBX(12)="O",(I,J)=0
I $D(GMRAL)#2 D
.F S I=$O(PI(I)) Q:'I D
..S J=J+1,FT=PI(I),RAOBX(2)=RAXX+J,RAOBX(6)=$$ESCAPE^RAHLRU(FT)
..D BLSEG^RAHLRU1("OBX",.RAOBX)
.S RAXX=RAOBX(2)
K RAOBX
;
OBXTCOM ;Compile 'OBX' segment for tech comments
S RAOBX(2)=$G(RAXX)
S RAOBX(3)="TX",RAOBX(4)="TCM"_$E(HLECH)_"TECH COMMENT"_$E(HLECH)_"L"
S RAOBX(12)="O",(I,J)=0
F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",I)) Q:'I D
.S J=J+1,FT=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",I,"TCOM"))
.S RAOBX(2)=RAXX+J,RAOBX(6)=$$ESCAPE^RAHLRU(FT)
.D BLSEG^RAHLRU1("OBX",.RAOBX)
.Q
EXIT ;clean up symbol table are return to RAHLR1
K RAOBX,RAXX,GMRAL,RAOBR,RAZCPT,RAZDIV,RAZIEN,RAZILOC,RAZITYPE,RAZMODAL
K RAZNME,RAZPHONE,RAZPMOD,RAZTMODE
Q
;
ZDS(RADTI,RACNI,RAZDAYCS) ;Compile the 'ZDS' segment
;Input: RADTI-inverse date/time of the examination
; RACNI-IEN of the examination record
; RAZDAYCS-If SSAN parameter="Y", SSAN format: sss-mmddyy-case#
; -If SSAN'="Y" day & case# of exam, format: mmddyy-case#
;Note: 'ZDS^MAGDRAHL' depends on the HLECH array being defined
;
;If the exam has a Study Instance UID defined [^DD(70.03,81)] use that
; value to build the ZDS segment
;If the exam does not have a Study Instance UID defined, i.e. it was
; created before the code to build the SIUID field, then build the
; SIUID on the fly here and use that value in the ZDS segment
;
N I F I=1:1:$L(HLECH) S HLECH(I)=$E(HLECH,I)
;
;If exam has an SIUID defined use it
S RASIUID=$$GETSIUID^RAAPI(RADFN,RADTI,RACNI) I RASIUID'="" D Q
.S HLA("HLS",$$RTNSUB^RAHLRU1()+1)=$$ZDS^MAGDRAHL(RASIUID)
.F I=$O(HLECH($C(32)),-1):-1:1 K HLECH(I) ;kill array elements
;
;If exam does not have an SIUID defined build it here on the fly
I RASIUID="" D
.S RASIUID=$$STUDYUID^MAGDRAHL(RADTI,RACNI,RAZDAYCS)
.S HLA("HLS",$$RTNSUB^RAHLRU1()+1)=$$ZDS^MAGDRAHL(RASIUID)
F I=$O(HLECH($C(32)),-1):-1:1 K HLECH(I) ;kill array elements
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAHLR1A 9568 printed Oct 16, 2024@18:36:04 Page 2
RAHLR1A ;HISC/GJC - Generate Common Order (ORM) Message ; Apr 26, 2023@12:37:42
+1 ;;5.0;Radiology/Nuclear Medicine;**47,203**;Mar 16, 1998;Build 1
+2 ;
+3 ;
+4 ;Integration Agreements
+5 ;----------------------
+6 ;$$GET1^DIQ(2056); ^DIWP(10011); NPFON^MAG7UFO(5021)
+7 ;$$ZDS^MAGDRAHL(5022); $$FMTHL7^XLFDT(10103); $$HLNAME^XLFNAME(3065)
+8 ;
+9 ;IA: 767 global read on ^DGSL(38.1,D0,0)
+10 ;calls to $$GET1^DIQ(44,IEN,.01) covered by IA: 10040
+11 ;calls to $$GET1^DIQ(4,IEN,.01) covered by IA: 10090
+12 ;
EN ;Called from RAHLR1; used to build the OBR, OBX, & ZDS segments
+1 ;The following key variables are defined in INIT^RAHLR1
+2 ;RAZRXAM=reg. exam zero node
+3 ;RAZXAM=exam zero node
+4 ;RAZDTE=9999999.9999-RADTI ;FM internal date/time
+5 ;RAZDAYCS:
+6 ; IF SSAN SITE PARAMETER="Y" RAZDAYCS=SSAN (sss-mmddyy-case#)
+7 ; ELSE IF SSAN'="Y" RAZDAYCS=DAY CASE# (mmddyy-case#)
+8 ;RAZORD=rad/nuc med order zero node
+9 ;RAZPROC=exam specific procedure
+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,PI,PTR,X,Y,Z,RAX,RAXX
+16 ;Compile OBR Segment
+17 ;Set ID OBR-1
OBRPRC ;OBR segment
+1 SET RAOBR(2)=1
+2 ;Placer Order Number OBR-2 site id-mmddyy-case#
+3 ;Filler Order Number OBR-3 site id-mmddyy-case#
+4 ; RAZDAYCS will be set to SSAN (site specific acc number) if the Site
+5 ; Acc Number division parameter (79,.131)=YES, else DAY CASE# format
+6 SET (RAOBR(3),RAOBR(4))=RAZDAYCS
+7 SET RAZCPT=$PIECE(RAZPROC,U,9)
SET RAZCPT(0)=$$NAMCODE^RACPTMSC(RAZCPT,DT)
+8 ;RAZCPT(0)=CPT code from file 81^short name of CPT code from file 81
+9 ;RAOBR(5)=CPT code #81_comp sep_CPT code short name #81_comp sep_"C4"
+10 ; _comp sep_IEN file #71_comp sep_procedure name #71_comp sep_
+11 ; "99RAP"
+12 ;
+13 SET RAOBR(5)=$PIECE(RAZCPT(0),U)_$EXTRACT(HLECH)_$$ESCAPE^RAHLRU($PIECE(RAZCPT(0),U,2))_$EXTRACT(HLECH)_"C4"
+14 SET RAOBR(5)=RAOBR(5)_$EXTRACT(HLECH)_+$PIECE(RAZXAM,U,2)_$EXTRACT(HLECH)_$$ESCAPE^RAHLRU($PIECE(RAZPROC,U))_$EXTRACT(HLECH)_"99RAP"
+15 ;Priority OBR-5 (REQUEST URGENCY) 75.1;6
+16 SET RAOBR(6)=$SELECT($PIECE(RAZORD,U,6)=1:"S",$PIECE(RAZORD,U,6)=2:"A",1:"R")
+17 ;Specimen Source OBR-15 75.1;125 PROCEDURE MODIFIERS (mult: 75.1125)
+18 ;(left & right only)
+19 SET RAZPMOD=$$SPECSRC^RAHLRU1(+$PIECE(RAZXAM,U,11))
+20 if $LENGTH(RAZPMOD)
SET RAOBR(16)=$$REPEAT^RAHLRU1($EXTRACT(HLECH),4)_$EXTRACT(HLECH,4)_RAZPMOD
+21 ;
+22 ;RA*5.0*203 update NSR 20230216 gjc 04/26/23
+23 ;From: Req. Physician on the order (75.1;14)
+24 ; To: Req. Physician on the exam (70.03;14)
+25 ;Ordering Provider OBR-16 (REQUESTING PHYSICIAN) 70.03;14
+26 IF $PIECE(RAZXAM,U,14)
IF ($$GET1^DIQ(200,$PIECE(RAZXAM,U,14),.01)'="")
DO OBR16^RAHLRU
+27 ;
+28 ;Call Back Phone numbers of Ordering Provider OBR-17 (mirrors ORC-14)
+29 Begin DoDot:1
+30 NEW RAX,I,M
SET M=""
SET I=0
+31 DO NPFON^MAG7UFO("RAX",$PIECE(RAZORD,U,14))
+32 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)
+33 if $LENGTH(M)
SET RAOBR(18)=$EXTRACT(M,1,$LENGTH(M)-1)
End DoDot:1
+34 ;
+35 ;Placer Field 1 OBR-18 site id-mmddyy-case# (mirrors OBR-2 & OBR-3)
+36 SET RAOBR(19)=RAZDAYCS
+37 ;
+38 ;Placer Field 2 definition has been changed by a VistA Imaging request
+39 ;-> prior to 07/2007: inv. date/time of the exam concatenated to (by the
+40 ; dash) the exam record IEN (Placer Fld 2 OBR-19 = Filler Fld 1 OBR-20)
+41 ;-> after 07/2007: case number
+42 ;RAZDAYCS=sss-mmddyy-case# OR mmddyy-case#
+43 SET RAOBR(20)=$PIECE(RAZDAYCS,"-",$LENGTH(RAZDAYCS,"-"))
+44 ;
+45 ;Filler Field 1 OBR-20 is defined as the site specific accession number:
+46 ;site id-mmddyy-case# Note: same value as OBR-18, OBR-2, & OBR-3
+47 ;(change effective 07/2007)
+48 SET RAOBR(21)=RAZDAYCS
+49 ;
+50 ;Filler Field 2 OBR-21
+51 SET RAOBR(22)=$$OBR21^RAHLRU(HLECH,RAZRXAM)
+52 ;
+53 ;Diagnostic Service Section ID OBR-24 MODALITY 71.0731 ptr to #73.1
+54 ;we capture modality data if there is only one sub-file record
+55 SET RAZIEN=+$ORDER(^RAMIS(71,+$PIECE(RAZXAM,U,2),"MDL",0))
+56 IF RAZIEN
IF (RAZIEN=$ORDER(^RAMIS(71,+$PIECE(RAZXAM,U,2),"MDL",$CHAR(32)),-1))
Begin DoDot:1
+57 SET RAZMODAL=+$GET(^RAMIS(71,+$PIECE(RAZXAM,U,2),"MDL",RAZIEN,0))
+58 SET RAOBR(25)=$$ESCAPE^RAHLRU($PIECE($GET(^RAMIS(73.1,RAZMODAL,0)),U))
+59 QUIT
End DoDot:1
+60 ;Quantity/Timing OBR-27.4 equates to SCHEDULED DATE (TIME optional)
+61 ; 75.1;23 Priority OBR-27.6 equates to REQUEST URGENCY of order 75.1;6
+62 ;Quantity/Timing OBR-27 (OBR-27 & ORC-7 share the same value)
+63 SET RAOBR(28)=$$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")
+64 ;
+65 ;Parent OBR-29 (OBR-29 & ORC-8 share the same value)
+66 ;see PARENT^RAHLR1
SET RAOBR(30)=$GET(RAORC(9))
+67 ;
+68 ;Transportation Mode OBR-30 75.1;19
+69 SET RAZTMODE=$PIECE(RAZORD,U,19)
+70 SET RAOBR(31)=$SELECT(RAZTMODE="a":"WALK",RAZTMODE="w":"WHLC",RAZTMODE="s":"CART",RAZTMODE="p":"PORT",1:"")
+71 ;Reason for Study OBR-31
+72 SET $PIECE(RAOBR(32),HLCS,2)=$SELECT($LENGTH(RAZORD1):RAZORD1,1:"See Clinical History:")
+73 ;build the OBR segment
+74 DO BLSEG^RAHLRU1("OBR",.RAOBR)
+75 ;build the ZDS segment
+76 DO ZDS(RADTI,RACNI,RAZDAYCS)
+77 ;
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)="O"
+6 DO BLSEG^RAHLRU1("OBX",.RAOBX)
KILL RAOBX
+7 ;
OBXPMOD ;Compile 'OBX' segment for procedure modifiers
+1 SET RAOBX(2)=$GET(RAXX)
+2 SET RAOBX(3)="TX"
SET RAOBX(4)="M"_$EXTRACT(HLECH)_"MODIFIERS"_$EXTRACT(HLECH)_"L"
+3 SET RAOBX(12)="O"
SET (I,J)=0
+4 FOR
SET I=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",I))
if 'I
QUIT
Begin DoDot:1
+5 SET PTR=+$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",I,0))
+6 SET J=J+1
SET RAOBX(2)=RAXX+J
SET RAOBX(6)=$$ESCAPE^RAHLRU($PIECE($GET(^RAMIS(71.2,PTR,0)),U))
+7 DO BLSEG^RAHLRU1("OBX",.RAOBX)
+8 QUIT
End DoDot:1
+9 SET RAXX=RAOBX(2)
+10 KILL RAOBX
+11 ;
OBXCPTM ;Compile 'OBX' segment for CPT modifiers
+1 SET RAOBX(2)=$GET(RAXX)
+2 SET RAOBX(3)="CE"
SET RAOBX(4)="C4"_$EXTRACT(HLECH)_"CPT MODIFIERS"_$EXTRACT(HLECH)_"L"
+3 SET RAOBX(12)="O"
SET (I,J)=0
+4 FOR
SET I=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",I))
if 'I
QUIT
Begin DoDot:1
+5 SET PTR=+$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",I,0))
+6 SET J=J+1
SET RAOBX(2)=RAXX+J
SET RAOBX(6)=$$CPTMOD^RAHLRU(PTR,HLECH,DT)
+7 DO BLSEG^RAHLRU1("OBX",.RAOBX)
End DoDot:1
+8 SET RAXX=RAOBX(2)
+9 KILL RAOBX,RAZCPTM
+10 ;
OBXHIST ;Compile 'OBX' Segment for Clinical History
+1 ;add Reason for Study as a prefix
IF $LENGTH(RAZORD1)
Begin DoDot:1
+2 SET RAXX=RAXX+1
SET RAOBX(2)=RAXX
SET RAOBX(3)="TX"
+3 SET RAOBX(4)="H"_$EXTRACT(HLECH)_"HISTORY"_$EXTRACT(HLECH)_"L"
SET RAOBX(12)="O"
+4 SET RAOBX(6)="Reason for Study: "_$$ESCAPE^RAHLRU($GET(RAZORD1))
+5 DO BLSEG^RAHLRU1("OBX",.RAOBX)
+6 SET RAXX=RAXX+1
SET RAOBX(2)=RAXX
SET RAOBX(3)="TX"
+7 SET RAOBX(4)="H"_$EXTRACT(HLECH)_"HISTORY"_$EXTRACT(HLECH)_"L"
SET RAOBX(12)="O"
+8 ;blank line to separate Reason For Study & Clin Hist
SET RAOBX(6)=" "
+9 DO BLSEG^RAHLRU1("OBX",.RAOBX)
+10 QUIT
End DoDot:1
+11 IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0))
Begin DoDot:1
+12 SET RAOBX(2)=$GET(RAXX)
SET RAOBX(3)="TX"
+13 SET RAOBX(4)="H"_$EXTRACT(HLECH)_"HISTORY"_$EXTRACT(HLECH)_"L"
+14 ;accumulate data into ^UTILITY($J,"W")...
+15 KILL ^UTILITY($JOB,"W")
+16 SET DIWF=""
SET DIWR=80
SET (DIWL,RADIWL)=1
SET RAI=0
+17 FOR
SET RAI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAI))
if 'RAI
QUIT
Begin DoDot:2
+18 SET X=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAI,0))
DO ^DIWP
+19 QUIT
End DoDot:2
+20 ;build the OBX segment from the data in ^UTILITY($J,"W")...
+21 SET (I,J)=0
SET RAOBX(12)="O"
+22 FOR
SET I=$ORDER(^UTILITY($JOB,"W",RADIWL,I))
if 'I
QUIT
Begin DoDot:2
+23 SET J=J+1
SET RAOBX(2)=RAXX+J
+24 SET RAOBX(6)=$$ESCAPE^RAHLRU($GET(^UTILITY($JOB,"W",RADIWL,I,0)))
+25 DO BLSEG^RAHLRU1("OBX",.RAOBX)
+26 QUIT
End DoDot:2
+27 SET RAXX=RAOBX(2)
+28 QUIT
End DoDot:1
+29 KILL DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,RADIWL,RAI,RAOBX,^UTILITY($JOB,"W")
+30 ;
OBXALL ;Compile 'OBX' Segment for Allergies
+1 NEW DFN
SET DFN=RADFN
DO ALLERGY^RADEM
+2 SET RAOBX(2)=$GET(RAXX)
+3 SET RAOBX(3)="TX"
SET RAOBX(4)="A"_$EXTRACT(HLECH)_"ALLERGIES"_$EXTRACT(HLECH)_"L"
+4 SET RAOBX(12)="O"
SET (I,J)=0
+5 IF $DATA(GMRAL)#2
Begin DoDot:1
+6 FOR
SET I=$ORDER(PI(I))
if 'I
QUIT
Begin DoDot:2
+7 SET J=J+1
SET FT=PI(I)
SET RAOBX(2)=RAXX+J
SET RAOBX(6)=$$ESCAPE^RAHLRU(FT)
+8 DO BLSEG^RAHLRU1("OBX",.RAOBX)
End DoDot:2
+9 SET RAXX=RAOBX(2)
End DoDot:1
+10 KILL RAOBX
+11 ;
OBXTCOM ;Compile 'OBX' segment for tech comments
+1 SET RAOBX(2)=$GET(RAXX)
+2 SET RAOBX(3)="TX"
SET RAOBX(4)="TCM"_$EXTRACT(HLECH)_"TECH COMMENT"_$EXTRACT(HLECH)_"L"
+3 SET RAOBX(12)="O"
SET (I,J)=0
+4 FOR
SET I=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",I))
if 'I
QUIT
Begin DoDot:1
+5 SET J=J+1
SET FT=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",I,"TCOM"))
+6 SET RAOBX(2)=RAXX+J
SET RAOBX(6)=$$ESCAPE^RAHLRU(FT)
+7 DO BLSEG^RAHLRU1("OBX",.RAOBX)
+8 QUIT
End DoDot:1
EXIT ;clean up symbol table are return to RAHLR1
+1 KILL RAOBX,RAXX,GMRAL,RAOBR,RAZCPT,RAZDIV,RAZIEN,RAZILOC,RAZITYPE,RAZMODAL
+2 KILL RAZNME,RAZPHONE,RAZPMOD,RAZTMODE
+3 QUIT
+4 ;
ZDS(RADTI,RACNI,RAZDAYCS) ;Compile the 'ZDS' segment
+1 ;Input: RADTI-inverse date/time of the examination
+2 ; RACNI-IEN of the examination record
+3 ; RAZDAYCS-If SSAN parameter="Y", SSAN format: sss-mmddyy-case#
+4 ; -If SSAN'="Y" day & case# of exam, format: mmddyy-case#
+5 ;Note: 'ZDS^MAGDRAHL' depends on the HLECH array being defined
+6 ;
+7 ;If the exam has a Study Instance UID defined [^DD(70.03,81)] use that
+8 ; value to build the ZDS segment
+9 ;If the exam does not have a Study Instance UID defined, i.e. it was
+10 ; created before the code to build the SIUID field, then build the
+11 ; SIUID on the fly here and use that value in the ZDS segment
+12 ;
+13 NEW I
FOR I=1:1:$LENGTH(HLECH)
SET HLECH(I)=$EXTRACT(HLECH,I)
+14 ;
+15 ;If exam has an SIUID defined use it
+16 SET RASIUID=$$GETSIUID^RAAPI(RADFN,RADTI,RACNI)
IF RASIUID'=""
Begin DoDot:1
+17 SET HLA("HLS",$$RTNSUB^RAHLRU1()+1)=$$ZDS^MAGDRAHL(RASIUID)
+18 ;kill array elements
FOR I=$ORDER(HLECH($CHAR(32)),-1):-1:1
KILL HLECH(I)
End DoDot:1
QUIT
+19 ;
+20 ;If exam does not have an SIUID defined build it here on the fly
+21 IF RASIUID=""
Begin DoDot:1
+22 SET RASIUID=$$STUDYUID^MAGDRAHL(RADTI,RACNI,RAZDAYCS)
+23 SET HLA("HLS",$$RTNSUB^RAHLRU1()+1)=$$ZDS^MAGDRAHL(RASIUID)
End DoDot:1
+24 ;kill array elements
FOR I=$ORDER(HLECH($CHAR(32)),-1):-1:1
KILL HLECH(I)
+25 QUIT
