Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RAHLRPT1

RAHLRPT1.m

Go to the documentation of this file. 
  1. RAHLRPT1 ;HISC/GJC-Compiles HL7 'ORU' Message Type ; 4/26/01 10:40am
  1.  ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21
  1.  ;
  1.  ;Integration Agreements
  1.  ;----------------------
  1.  ;$$GET1^DIQ(2056); ^DIWP(10011); 
  1.  ;$$FMTHL7^XLFDT(10103); $$HLNAME^XLFNAME(3065)
  1.  ;
  1. EN(RADFN,RADTI,RACNI,RAEID) ;Called from all RA RPT* event driver protocols whose
  1.  ;HL7 version exceeds version 2.3.
  1.  ;
  1.  ;Input Variables (from RAHLRPT):
  1.  ; RADFN=file 2 IEN (DFN)
  1.  ; RADTI=file 70 Exam subrec IEN (inverse date/time of exam)
  1.  ; RACNI=file 70 Case subrecord IEN
  1.  ; RAEID=ien of the event driver protocol (defined in RAHLRPC)
  1.  ;Output variables:
  1.  ; HLA("HLS", array containing HL7 msg
  1.  ;
  1.  ;Note: RAOBR(n+1) = OBR 'n' because our software begins
  1.  ;building the segment with the segment header ('OBR')
  1.  ;
  1.  ;new some variables...
  1.  N %,DN,FT,I,J,PTR,X,Y
  1.  ;initialize Rad/Nuc Med specific variables
  1.  D INIT^RAHLR1
  1. PID ;Compile the 'PID' segment
  1.  D PID^RAHLRU1(RADFN)
  1. OBR ;Compile 'OBR' Segment
  1.  ;get pointer value to the rad/nuc med report; needed to build the OBR
  1.  S RAZRPT=+$P(RAZXAM,U,17)
  1.  ;get rad/nuc med report zero node & the transcriptionist (if exists)
  1.  S RAZRPT=$G(^RARPT(RAZRPT,0)),RAZTRANS=+$G(^RARPT(+$P(RAZXAM,U,17),"T"))
  1.  ;Set ID OBR-1
  1.  S RAOBR(2)=1
  1.  ;Placer Order Number OBR-2 mmddyy-case#
  1.  ;Filler Order Number OBR-3 mmddyy-case#
  1.  S (RAOBR(3),RAOBR(4))=RAZDAYCS
  1.  S RAZCPT=$P(RAZPROC,U,9),RAZCPT(0)=$$NAMCODE^RACPTMSC(RAZCPT,DT)
  1.  ;RAZCPT(0)=CPT code from file 81^short name of CPT code from file 81
  1.  ;RAOBR(4)=CPT code #81_comp sep_CPT code short name #81_comp sep_"C4"
  1.  ;         _comp sep_IEN file #71_comp sep_procedure name #71_comp sep_
  1.  ;         "99RAP"
  1.  ;
  1.  S RAOBR(5)=$P(RAZCPT(0),U)_$E(HLECH)_$$ESCAPE^RAHLRU($P(RAZCPT(0),U,2))_$E(HLECH)_"C4"
  1.  S RAOBR(5)=RAOBR(5)_$E(HLECH)_+$P(RAZXAM,U,2)_$E(HLECH)_$$ESCAPE^RAHLRU($P(RAZPROC,U))_$E(HLECH)_"99RAP"
  1.  ;Observation date/time OBR-7 (DATE REPORT ENTERED) 74;6
  1.  S RAOBR(8)=$$FMTHL7^XLFDT($P(RAZRPT,U,6))
  1.  ;Specimen Source OBR-15 75.1;125 PROCEDURE MODIFIERS (mult: 75.1125)
  1.  ;(left & right only)
  1.  S RAZPMOD=$$SPECSRC^RAHLRU1(+$P(RAZXAM,U,11))
  1.  S:$L(RAZPMOD) RAOBR(16)=$$REPEAT^RAHLRU1($E(HLECH),4)_$E(HLECH,4)_RAZPMOD
  1.  ;
  1.  ;Ordering Provider OBR-16 (REQUESTING PHYSICIAN) 75.1;14
  1.  I $P(RAZORD,U,14),($$GET1^DIQ(200,$P(RAZORD,U,14),.01)'="") D
  1.  .K RAZNME S RAZNME("FILE")=200,RAZNME("IENS")=$P(RAZORD,U,14)
  1.  .S RAZNME("FIELD")=.01
  1.  .S RAOBR(17)=$P(RAZORD,U,14)_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1))
  1.  .Q
  1.  ;
  1.  ;Call Back Phone numbers of Ordering Provider OBR-17
  1.  D
  1.  .N RAX,I,M S M="",I=0
  1.  .D NPFON^MAG7UFO("RAX",$P(RAZORD,U,14))
  1.  .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)
  1.  .S:$L(M) RAOBR(18)=$E(M,1,$L(M)-1)
  1.  ;
  1.  ;Placer Field 1 OBR-18 site id-mmddyy-case# (mirrors OBR-2 & OBR-3)
  1.  S RAOBR(19)=RAZDAYCS
  1.  ;
  1.  ;Placer Field 2 definition has been changed by a VistA Imaging request
  1.  ;-> prior to 07/2007: inv. date/time of the exam concatenated to (by the
  1.  ;  dash) the exam record IEN (Placer Fld 2 OBR-19 = Filler Fld 1 OBR-20)
  1.  ;-> after 07/2007: case number
  1.  ;RAZDAYCS=sss-mmddyy-case# OR mmddyy-case#
  1.  S RAOBR(20)=$P(RAZDAYCS,"-",$L(RAZDAYCS,"-"))
  1.  ;
  1.  ;Filler Field 1 OBR-20 is defined as the site specific accession number:
  1.  ;site id-mmddyy-case# Note: same value as OBR-18, OBR-2, & OBR-3
  1.  ;(change effective 07/2007)
  1.  S RAOBR(21)=RAZDAYCS
  1.  ;
  1.  ;Filler Field 2 OBR-21 (change effective 07/2007)
  1.  ;RAZRXAM defined in INIT^RAHLR1
  1.  S RAOBR(22)=$$OBR21^RAHLRU(HLECH,RAZRXAM)
  1.  ;
  1.  ;Results Rpt/Status Chng-date/time OBR-22
  1.  ;verified: VERIFIED DATE 74;7
  1.  ;unv'fied: DATE REPORT ENTERED 74;6
  1.  S:$P(RAZRPT,U,5)="V" RAOBR(23)=$$FMTHL7^XLFDT($P(RAZRPT,U,7))
  1.  S:$P(RAZRPT,U,5)'="V" RAOBR(23)=$$FMTHL7^XLFDT($P(RAZRPT,U,6))
  1.  ;Status OBR-25 REPORT STATUS 74;5
  1.  ;S:$D(^RARPT(+$P(RAZXAM,U,17),"ERR",1,0))#2 RAOBR(26)="C" ;corrected rt
  1.  S:'$D(RAOBR(26))#2 RAOBR(26)=$S(($P(RAZRPT,U,5)="V")!($P(RAZRPT,U,5)="EF"):"F",1:"R")   ;"EF" reports send "F" (Final) in OBR-25
  1.  ;Parent OBR-29 70.03;25 if exam/printset find ordered parent procedure
  1.  I $P(RAZXAM,U,25) D  ;is this case part of an examset/printset
  1.  .S RAOBR(30)=$S($P(RAZXAM,U,25)=1:"Examset: ",1:"Printset: ")_$P($G(^RAMIS(71,+$P(RAZORD,U,2),0)),U)
  1.  .Q
  1.  ;Principal Result Interpreter OBR-32 70.03;15
  1.  I $P(RAZXAM,U,15),($$GET1^DIQ(200,$P(RAZXAM,U,15),.01)'="") D
  1.  .K RAZNME S RAZNME("FILE")=200,RAZNME("IENS")=$P(RAZXAM,U,15)
  1.  .S RAZNME("FIELD")=.01
  1.  .;S RAOBR(33)=$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1))
  1.  .S RAOBR(33)=$P(RAZXAM,U,15)_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1))
  1.  .Q
  1.  ;Assistant Result Interpreter(s)/contributors OBR-33 70.03;12
  1.  N CNT,RAI,RAJ S CNT=0
  1.  I $P(RAZXAM,U,12),($$GET1^DIQ(200,$P(RAZXAM,U,12),.01)'="") D
  1.  .K RAZNME D INTNAM($P(RAZXAM,U,12))
  1.  .Q
  1.  K RAZNME F RAI="SRR","SSR" D  Q:CNT=10  ;ten or less interpreters
  1.  .S RAJ=0
  1.  .F  S RAJ=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,RAI,RAJ)) Q:'RAJ  S RAJ(0)=+$G(^(RAJ,0)) D  Q:CNT=10
  1.  ..D INTNAM(RAJ(0))
  1.  ..Q
  1.  .Q
  1.  ;Transcriptionist OBR-35 74;11
  1.  I RAZTRANS,($$GET1^DIQ(200,RAZTRANS,.01)'="") D
  1.  .S RAZNME("FILE")=200,RAZNME("IENS")=RAZTRANS,RAZNME("FIELD")=.01
  1.  .S RAOBR(36)=RAZTRANS_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1)) K RAZNME
  1.  .Q
  1.  ;
  1.  ;build the OBR segment
  1.  D BLSEG^RAHLRU1("OBR",.RAOBR)
  1.  ;
  1.  ;build the ZDS segment
  1.  D ZDS^RAHLR1A(RADTI,RACNI,RAZDAYCS)
  1.  ;
  1. OBXPRC ;Compile 'OBX' Segment for Procedure
  1.  ;RAXX = Counter in segment
  1.  S (RAOBX(2),RAXX)=1
  1.  S RAOBX(3)="CE",RAOBX(4)="P"_$E(HLECH)_"PROCEDURE"_$E(HLECH)_"L"
  1.  S RAOBX(6)=$P(RAZXAM,U,2)_$E(HLECH)_$$ESCAPE^RAHLRU($P($G(^RAMIS(71,+$P(RAZXAM,U,2),0)),U))_$E(HLECH)_"L"
  1.  S RAOBX(12)=$$OBX11^RAHLRPT2(+$P(RAZXAM,U,17))
  1.  D BLSEG^RAHLRU1("OBX",.RAOBX) K RAOBX
  1.  ;
  1. OBXIMP ;Compile the 'OBX' segment for Impression Text
  1.  S RAOBX(2)=$G(RAXX)
  1.  I $O(^RARPT(+$P(RAZXAM,U,17),"I",0)) D
  1.  .S RAOBX(3)="TX",RAOBX(4)="I"_$E(HLECH)_"IMPRESSION"_$E(HLECH)_"L"
  1.  .S RAOBX(12)=$$OBX11^RAHLRPT2(+$P(RAZXAM,U,17))
  1.  .K ^UTILITY($J,"W") S DIWF="",DIWR=75,(DIWL,RADIWL)=1
  1.  .S RAI=0 F  S RAI=$O(^RARPT(+$P(RAZXAM,U,17),"I",RAI)) Q:'RAI  D
  1.  ..S X=$G(^RARPT(+$P(RAZXAM,U,17),"I",RAI,0)) D ^DIWP
  1.  ..Q
  1.  .S (RAI,RAJ)=0 F  S RAI=$O(^UTILITY($J,"W",RADIWL,RAI)) Q:'RAI  D
  1.  ..S RAJ=RAJ+1,RAOBX(2)=RAXX+RAJ
  1.  ..S RAOBX(6)=$$ESCAPE^RAHLRU($G(^UTILITY($J,"W",RADIWL,RAI,0)))
  1.  ..D BLSEG^RAHLRU1("OBX",.RAOBX)
  1.  ..Q
  1.  .S RAXX=$G(RAOBX(2))
  1.  .Q
  1.  K DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,RADIWL,RAOBX,^UTILITY($J,"W")
  1.  ;
  1. OBXDX ;Compile the 'OBX' segment for Diagnostic Code
  1.  S RAOBX(2)=$G(RAXX)
  1.  I +$P(RAZXAM,U,13) D  ;pri. Dx code exists; look for secondary Dx
  1.  .S RAOBX(2)=RAXX+1,RAOBX(3)="CE"
  1.  .S RAOBX(4)="D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L"
  1.  .S RAOBX(6)=+$P(RAZXAM,U,13)_$E(HLECH)_$$ESCAPE^RAHLRU($P($G(^RA(78.3,+$P(RAZXAM,U,13),0)),U))_$E(HLECH)_"L"
  1.  .S RAOBX(12)=$$OBX11^RAHLRPT2(+$P(RAZXAM,U,17))
  1.  .D BLSEG^RAHLRU1("OBX",.RAOBX)
  1.  .S RAXX=$G(RAOBX(2))
  1.  .Q
  1.  I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) D  ;secondaries...
  1.  .S RAI=0,RAJ=0
  1.  .F  S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RAI)) Q:'RAI  D
  1.  ..S RAPTR=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RAI,0))
  1.  ..S RAFT=$P($G(^RA(78.3,RAPTR,0)),U)
  1.  ..S RAJ=RAJ+1,RAOBX(2)=RAXX+RAJ,RAOBX(6)=RAPTR_$E(HLECH)_$$ESCAPE^RAHLRU(RAFT)_$E(HLECH)_"L"
  1.  ..D BLSEG^RAHLRU1("OBX",.RAOBX)
  1.  ..Q
  1.  .S RAXX=$G(RAOBX(2))
  1.  .Q
  1.  K RAFT,RAOBX,RAPTR
  1.  ;
  1. OBXPMOD ;Compile 'OBX' segment for procedure modifiers
  1.  S RAOBX(2)=$G(RAXX),RAJ=0
  1.  S RAOBX(3)="TX",RAOBX(4)="M"_$E(HLECH)_"MODIFIERS"_$E(HLECH)_"L"
  1.  S RAOBX(12)=$$OBX11^RAHLRPT2(+$P(RAZXAM,U,17)),(RAI,RAJ)=0
  1.  F  S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",RAI)) Q:'RAI  D
  1.  .S RAJ=RAJ+1,RAPTR=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",RAI,0))
  1.  .S RAOBX(2)=RAXX+RAJ
  1.  .S RAOBX(6)=$$ESCAPE^RAHLRU($P($G(^RAMIS(71.2,RAPTR,0)),U))
  1.  .D BLSEG^RAHLRU1("OBX",.RAOBX)
  1.  .Q
  1.  S RAXX=$G(RAOBX(2))
  1.  K RAOBX,RAPTR
  1.  ;
  1. OBXTCOM ;Compile 'OBX' segment for tech comments
  1.  D OBXTCOM^RAHLRPT2
  1.  ;
  1. OBXCPTM ;Compile 'OBX' segment for CPT modifiers
  1.  D OBXCPTM^RAHLRPT2
  1.  ;
  1. OBXRPT ;Compile 'OBX' segment for Report Text
  1.  D OBXRPT^RAHLRPT2
  1.  ;
  1.  ;Broadcast the HL7 message and cleanup the symbol table
  1.  D GENERATE^RAHLRU
  1.  Q
  1.  ;
  1. INTNAM(Y) ;return the name of the intepreter(s)
  1.  ; input: Y=IEN of the record in the New Person (#200) file
  1.  ; CNT=second level subscript is newed,initialized and checked above
  1.  S RAZNME("FILE")=200,RAZNME("IENS")=Y,RAZNME("FIELD")=.01
  1.  S CNT=CNT+1  ;update counter by 1
  1.  S RAOBR(34,CNT)=Y_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1)) K RAZNME
  1.  Q