- 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 Jan 18, 2025@03:36:28 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