RAHLRPT2 ;HISC/GJC-Compiles HL7 'ORU' Message Type ; 4/26/01 10:40am
;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21
;
;called from RAHLRPT1
;
;Integration Agreements
;----------------------
; ^DIWP(10011)
;
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)=$$OBX11(+$P(RAZXAM,U,17)),(RAI,RAJ)=0
F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",RAI)) Q:'RAI D
.Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",RAI,"TCOM"))
.S RAJ=RAJ+1,RAFT=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",RAI,"TCOM"))
.S RAOBX(2)=$G(RAXX)+RAJ,RAOBX(6)=$$ESCAPE^RAHLRU(RAFT)
.D BLSEG^RAHLRU1("OBX",.RAOBX)
.Q
S RAXX=$G(RAOBX(2))
K RAFT,RAOBX Q
;
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)=$$OBX11(+$P(RAZXAM,U,17)),(RAI,RAJ)=0
F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RAI)) Q:'RAI D
.S RAJ=RAJ+1,RAPTR=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RAI,0))
.S RAOBX(2)=RAXX+RAJ,RAOBX(6)=$$CPTMOD^RAHLRU(RAPTR,HLECH,DT)
.D BLSEG^RAHLRU1("OBX",.RAOBX)
.Q
S RAXX=$G(RAOBX(2))
Q
;
OBXRPT ;Compile the 'OBX' segment for Report Text
S RAOBX(2)=$G(RAXX)
I $O(^RARPT(+$P(RAZXAM,U,17),"R",0)) D
.S RAOBX(3)="TX",RAOBX(4)="R"_$E(HLECH)_"REPORT"_$E(HLECH)_"L"
.S RAOBX(12)=$$OBX11^RAHLRPT2(+$P(RAZXAM,U,17))
.K ^UTILITY($J,"W") S DIWF="",DIWR=75,(DIWL,RADIWL)=1
.S RAI=0 F S RAI=$O(^RARPT(+$P(RAZXAM,U,17),"R",RAI)) Q:'RAI D
..S X=$G(^RARPT(+$P(RAZXAM,U,17),"R",RAI,0)) D ^DIWP
..Q
.S (RAI,RAJ)=0 F S RAI=$O(^UTILITY($J,"W",RADIWL,RAI)) Q:'RAI D
..S RAJ=RAJ+1,RAOBX(2)=RAXX+RAJ
..S RAOBX(6)=$$ESCAPE^RAHLRU($G(^UTILITY($J,"W",RADIWL,RAI,0)))
..D BLSEG^RAHLRU1("OBX",.RAOBX)
..Q
.S RAXX=$G(RAOBX(2))
.Q
K DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,RADIWL,RAOBX,^UTILITY($J,"W")
Q
;
OBX11(RARPT) ;set OBX-11 (Observ. Rslt Status) correctly
;input : RARPT =IEN of the RAD/NUC MED REPORT record
; RAZRPT=zero node of the RAD/NUC MED REPORT record
;return: OBX-11 (as 'Y')
Q:RARPT=0 ""
N Y S:$D(^RARPT(RARPT,"ERR",1,0))#2 Y="C" ;corrected result
S:'$D(Y)#2 Y=$S(($P(^RARPT(RARPT,0),U,5)="V")!($P(^RARPT(RARPT,0),U,5)="EF"):"F",1:"R") ;"EF" reports send "F" (Final) in OBX-11
;S:'$D(Y)#2 Y=$S($P(^RARPT(RARPT,0),U,5)="V":"F",1:"R")
Q Y
;
RAHLRPT2 ;HISC/GJC-Compiles HL7 'ORU' Message Type ; 4/26/01 10:40am
+1 ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21
+2 ;
+3 ;called from RAHLRPT1
+4 ;
+5 ;Integration Agreements
+6 ;----------------------
+7 ; ^DIWP(10011)
+8 ;
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)=$$OBX11(+$PIECE(RAZXAM,U,17))
SET (RAI,RAJ)=0
+4 FOR
SET RAI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",RAI))
IF 'RAI
QUIT
Begin DoDot:1
+5 IF '$DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",RAI,"TCOM"))
QUIT
+6 SET RAJ=RAJ+1
SET RAFT=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",RAI,"TCOM"))
+7 SET RAOBX(2)=$GET(RAXX)+RAJ
SET RAOBX(6)=$$ESCAPE^RAHLRU(RAFT)
+8 DO BLSEG^RAHLRU1("OBX",.RAOBX)
+9 QUIT
End DoDot:1
+10 SET RAXX=$GET(RAOBX(2))
+11 KILL RAFT,RAOBX
QUIT
+12 ;
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)=$$OBX11(+$PIECE(RAZXAM,U,17))
SET (RAI,RAJ)=0
+4 FOR
SET RAI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RAI))
IF 'RAI
QUIT
Begin DoDot:1
+5 SET RAJ=RAJ+1
SET RAPTR=+$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RAI,0))
+6 SET RAOBX(2)=RAXX+RAJ
SET RAOBX(6)=$$CPTMOD^RAHLRU(RAPTR,HLECH,DT)
+7 DO BLSEG^RAHLRU1("OBX",.RAOBX)
+8 QUIT
End DoDot:1
+9 SET RAXX=$GET(RAOBX(2))
+10 QUIT
+11 ;
OBXRPT ;Compile the 'OBX' segment for Report Text
+1 SET RAOBX(2)=$GET(RAXX)
+2 IF $ORDER(^RARPT(+$PIECE(RAZXAM,U,17),"R",0))
Begin DoDot:1
+3 SET RAOBX(3)="TX"
SET RAOBX(4)="R"_$EXTRACT(HLECH)_"REPORT"_$EXTRACT(HLECH)_"L"
+4 SET RAOBX(12)=$$OBX11^RAHLRPT2(+$PIECE(RAZXAM,U,17))
+5 KILL ^UTILITY($JOB,"W")
SET DIWF=""
SET DIWR=75
SET (DIWL,RADIWL)=1
+6 SET RAI=0
FOR
SET RAI=$ORDER(^RARPT(+$PIECE(RAZXAM,U,17),"R",RAI))
IF 'RAI
QUIT
Begin DoDot:2
+7 SET X=$GET(^RARPT(+$PIECE(RAZXAM,U,17),"R",RAI,0))
DO ^DIWP
+8 QUIT
End DoDot:2
+9 SET (RAI,RAJ)=0
FOR
SET RAI=$ORDER(^UTILITY($JOB,"W",RADIWL,RAI))
IF 'RAI
QUIT
Begin DoDot:2
+10 SET RAJ=RAJ+1
SET RAOBX(2)=RAXX+RAJ
+11 SET RAOBX(6)=$$ESCAPE^RAHLRU($GET(^UTILITY($JOB,"W",RADIWL,RAI,0)))
+12 DO BLSEG^RAHLRU1("OBX",.RAOBX)
+13 QUIT
End DoDot:2
+14 SET RAXX=$GET(RAOBX(2))
+15 QUIT
End DoDot:1
+16 KILL DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,RADIWL,RAOBX,^UTILITY($JOB,"W")
+17 QUIT
+18 ;
OBX11(RARPT) ;set OBX-11 (Observ. Rslt Status) correctly
+1 ;input : RARPT =IEN of the RAD/NUC MED REPORT record
+2 ; RAZRPT=zero node of the RAD/NUC MED REPORT record
+3 ;return: OBX-11 (as 'Y')
+4 IF RARPT=0
QUIT ""
+5 ;corrected result
NEW Y
IF $DATA(^RARPT(RARPT,"ERR",1,0))#2
SET Y="C"
+6 ;"EF" reports send "F" (Final) in OBX-11
IF '$DATA(Y)#2
SET Y=$SELECT(($PIECE(^RARPT(RARPT,0),U,5)="V")!($PIECE(^RARPT(RARPT,0),U,5)="EF"):"F",1:"R")
+7 ;S:'$D(Y)#2 Y=$S($P(^RARPT(RARPT,0),U,5)="V":"F",1:"R")
+8 QUIT Y
+9 ;
