- 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 ;
