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

RAHLR1A.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;
  1. ;Integration Agreements
  1. ;----------------------
  1. ;$$GET1^DIQ(2056); ^DIWP(10011); NPFON^MAG7UFO(5021)
  1. ;$$ZDS^MAGDRAHL(5022); $$FMTHL7^XLFDT(10103); $$HLNAME^XLFNAME(3065)
  1. ;
  1. ;IA: 767 global read on ^DGSL(38.1,D0,0)
  1. ;calls to $$GET1^DIQ(44,IEN,.01) covered by IA: 10040
  1. ;calls to $$GET1^DIQ(4,IEN,.01) covered by IA: 10090
  1. ;
  1. EN ;Called from RAHLR1; used to build the OBR, OBX, & ZDS segments
  1. ;The following key variables are defined in INIT^RAHLR1
  1. ;RAZRXAM=reg. exam zero node
  1. ;RAZXAM=exam zero node
  1. ;RAZDTE=9999999.9999-RADTI ;FM internal date/time
  1. ;RAZDAYCS:
  1. ; IF SSAN SITE PARAMETER="Y" RAZDAYCS=SSAN (sss-mmddyy-case#)
  1. ; ELSE IF SSAN'="Y" RAZDAYCS=DAY CASE# (mmddyy-case#)
  1. ;RAZORD=rad/nuc med order zero node
  1. ;RAZPROC=exam specific procedure
  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,PI,PTR,X,Y,Z,RAX,RAXX
  1. ;Compile OBR Segment
  1. ;Set ID OBR-1
  1. OBRPRC ;OBR segment
  1. S RAOBR(2)=1
  1. ;Placer Order Number OBR-2 site id-mmddyy-case#
  1. ;Filler Order Number OBR-3 site id-mmddyy-case#
  1. ; RAZDAYCS will be set to SSAN (site specific acc number) if the Site
  1. ; Acc Number division parameter (79,.131)=YES, else DAY CASE# format
  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(5)=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. ;Priority OBR-5 (REQUEST URGENCY) 75.1;6
  1. S RAOBR(6)=$S($P(RAZORD,U,6)=1:"S",$P(RAZORD,U,6)=2:"A",1:"R")
  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. ;RA*5.0*203 update NSR 20230216 gjc 04/26/23
  1. ;From: Req. Physician on the order (75.1;14)
  1. ; To: Req. Physician on the exam (70.03;14)
  1. ;Ordering Provider OBR-16 (REQUESTING PHYSICIAN) 70.03;14
  1. I $P(RAZXAM,U,14),($$GET1^DIQ(200,$P(RAZXAM,U,14),.01)'="") D OBR16^RAHLRU
  1. ;
  1. ;Call Back Phone numbers of Ordering Provider OBR-17 (mirrors ORC-14)
  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
  1. S RAOBR(22)=$$OBR21^RAHLRU(HLECH,RAZRXAM)
  1. ;
  1. ;Diagnostic Service Section ID OBR-24 MODALITY 71.0731 ptr to #73.1
  1. ;we capture modality data if there is only one sub-file record
  1. S RAZIEN=+$O(^RAMIS(71,+$P(RAZXAM,U,2),"MDL",0))
  1. I RAZIEN,(RAZIEN=$O(^RAMIS(71,+$P(RAZXAM,U,2),"MDL",$C(32)),-1)) D
  1. .S RAZMODAL=+$G(^RAMIS(71,+$P(RAZXAM,U,2),"MDL",RAZIEN,0))
  1. .S RAOBR(25)=$$ESCAPE^RAHLRU($P($G(^RAMIS(73.1,RAZMODAL,0)),U))
  1. .Q
  1. ;Quantity/Timing OBR-27.4 equates to SCHEDULED DATE (TIME optional)
  1. ; 75.1;23 Priority OBR-27.6 equates to REQUEST URGENCY of order 75.1;6
  1. ;Quantity/Timing OBR-27 (OBR-27 & ORC-7 share the same value)
  1. 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")
  1. ;
  1. ;Parent OBR-29 (OBR-29 & ORC-8 share the same value)
  1. S RAOBR(30)=$G(RAORC(9)) ;see PARENT^RAHLR1
  1. ;
  1. ;Transportation Mode OBR-30 75.1;19
  1. S RAZTMODE=$P(RAZORD,U,19)
  1. S RAOBR(31)=$S(RAZTMODE="a":"WALK",RAZTMODE="w":"WHLC",RAZTMODE="s":"CART",RAZTMODE="p":"PORT",1:"")
  1. ;Reason for Study OBR-31
  1. S $P(RAOBR(32),HLCS,2)=$S($L(RAZORD1):RAZORD1,1:"See Clinical History:")
  1. ;build the OBR segment
  1. D BLSEG^RAHLRU1("OBR",.RAOBR)
  1. ;build the ZDS segment
  1. D ZDS(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)="O"
  1. D BLSEG^RAHLRU1("OBX",.RAOBX) K RAOBX
  1. ;
  1. OBXPMOD ;Compile 'OBX' segment for procedure modifiers
  1. S RAOBX(2)=$G(RAXX)
  1. S RAOBX(3)="TX",RAOBX(4)="M"_$E(HLECH)_"MODIFIERS"_$E(HLECH)_"L"
  1. S RAOBX(12)="O",(I,J)=0
  1. F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",I)) Q:'I D
  1. .S PTR=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",I,0))
  1. .S J=J+1,RAOBX(2)=RAXX+J,RAOBX(6)=$$ESCAPE^RAHLRU($P($G(^RAMIS(71.2,PTR,0)),U))
  1. .D BLSEG^RAHLRU1("OBX",.RAOBX)
  1. .Q
  1. S RAXX=RAOBX(2)
  1. K RAOBX
  1. ;
  1. OBXCPTM ;Compile 'OBX' segment for CPT modifiers
  1. S RAOBX(2)=$G(RAXX)
  1. S RAOBX(3)="CE",RAOBX(4)="C4"_$E(HLECH)_"CPT MODIFIERS"_$E(HLECH)_"L"
  1. S RAOBX(12)="O",(I,J)=0
  1. F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",I)) Q:'I D
  1. .S PTR=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",I,0))
  1. .S J=J+1,RAOBX(2)=RAXX+J,RAOBX(6)=$$CPTMOD^RAHLRU(PTR,HLECH,DT)
  1. .D BLSEG^RAHLRU1("OBX",.RAOBX)
  1. S RAXX=RAOBX(2)
  1. K RAOBX,RAZCPTM
  1. ;
  1. OBXHIST ;Compile 'OBX' Segment for Clinical History
  1. I $L(RAZORD1) D ;add Reason for Study as a prefix
  1. .S RAXX=RAXX+1,RAOBX(2)=RAXX,RAOBX(3)="TX"
  1. .S RAOBX(4)="H"_$E(HLECH)_"HISTORY"_$E(HLECH)_"L",RAOBX(12)="O"
  1. .S RAOBX(6)="Reason for Study: "_$$ESCAPE^RAHLRU($G(RAZORD1))
  1. .D BLSEG^RAHLRU1("OBX",.RAOBX)
  1. .S RAXX=RAXX+1,RAOBX(2)=RAXX,RAOBX(3)="TX"
  1. .S RAOBX(4)="H"_$E(HLECH)_"HISTORY"_$E(HLECH)_"L",RAOBX(12)="O"
  1. .S RAOBX(6)=" " ;blank line to separate Reason For Study & Clin Hist
  1. .D BLSEG^RAHLRU1("OBX",.RAOBX)
  1. .Q
  1. I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0)) D
  1. .S RAOBX(2)=$G(RAXX),RAOBX(3)="TX"
  1. .S RAOBX(4)="H"_$E(HLECH)_"HISTORY"_$E(HLECH)_"L"
  1. .;accumulate data into ^UTILITY($J,"W")...
  1. .K ^UTILITY($J,"W")
  1. .S DIWF="",DIWR=80,(DIWL,RADIWL)=1,RAI=0
  1. .F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAI)) Q:'RAI D
  1. ..S X=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAI,0)) D ^DIWP
  1. ..Q
  1. .;build the OBX segment from the data in ^UTILITY($J,"W")...
  1. .S (I,J)=0,RAOBX(12)="O"
  1. .F S I=$O(^UTILITY($J,"W",RADIWL,I)) Q:'I D
  1. ..S J=J+1,RAOBX(2)=RAXX+J
  1. ..S RAOBX(6)=$$ESCAPE^RAHLRU($G(^UTILITY($J,"W",RADIWL,I,0)))
  1. ..D BLSEG^RAHLRU1("OBX",.RAOBX)
  1. ..Q
  1. .S RAXX=RAOBX(2)
  1. .Q
  1. K DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,RADIWL,RAI,RAOBX,^UTILITY($J,"W")
  1. ;
  1. OBXALL ;Compile 'OBX' Segment for Allergies
  1. N DFN S DFN=RADFN D ALLERGY^RADEM
  1. S RAOBX(2)=$G(RAXX)
  1. S RAOBX(3)="TX",RAOBX(4)="A"_$E(HLECH)_"ALLERGIES"_$E(HLECH)_"L"
  1. S RAOBX(12)="O",(I,J)=0
  1. I $D(GMRAL)#2 D
  1. .F S I=$O(PI(I)) Q:'I D
  1. ..S J=J+1,FT=PI(I),RAOBX(2)=RAXX+J,RAOBX(6)=$$ESCAPE^RAHLRU(FT)
  1. ..D BLSEG^RAHLRU1("OBX",.RAOBX)
  1. .S RAXX=RAOBX(2)
  1. K RAOBX
  1. ;
  1. OBXTCOM ;Compile 'OBX' segment for tech comments
  1. S RAOBX(2)=$G(RAXX)
  1. S RAOBX(3)="TX",RAOBX(4)="TCM"_$E(HLECH)_"TECH COMMENT"_$E(HLECH)_"L"
  1. S RAOBX(12)="O",(I,J)=0
  1. F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",I)) Q:'I D
  1. .S J=J+1,FT=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",I,"TCOM"))
  1. .S RAOBX(2)=RAXX+J,RAOBX(6)=$$ESCAPE^RAHLRU(FT)
  1. .D BLSEG^RAHLRU1("OBX",.RAOBX)
  1. .Q
  1. EXIT ;clean up symbol table are return to RAHLR1
  1. K RAOBX,RAXX,GMRAL,RAOBR,RAZCPT,RAZDIV,RAZIEN,RAZILOC,RAZITYPE,RAZMODAL
  1. K RAZNME,RAZPHONE,RAZPMOD,RAZTMODE
  1. Q
  1. ;
  1. ZDS(RADTI,RACNI,RAZDAYCS) ;Compile the 'ZDS' segment
  1. ;Input: RADTI-inverse date/time of the examination
  1. ; RACNI-IEN of the examination record
  1. ; RAZDAYCS-If SSAN parameter="Y", SSAN format: sss-mmddyy-case#
  1. ; -If SSAN'="Y" day & case# of exam, format: mmddyy-case#
  1. ;Note: 'ZDS^MAGDRAHL' depends on the HLECH array being defined
  1. ;
  1. ;If the exam has a Study Instance UID defined [^DD(70.03,81)] use that
  1. ; value to build the ZDS segment
  1. ;If the exam does not have a Study Instance UID defined, i.e. it was
  1. ; created before the code to build the SIUID field, then build the
  1. ; SIUID on the fly here and use that value in the ZDS segment
  1. ;
  1. N I F I=1:1:$L(HLECH) S HLECH(I)=$E(HLECH,I)
  1. ;
  1. ;If exam has an SIUID defined use it
  1. S RASIUID=$$GETSIUID^RAAPI(RADFN,RADTI,RACNI) I RASIUID'="" D Q
  1. .S HLA("HLS",$$RTNSUB^RAHLRU1()+1)=$$ZDS^MAGDRAHL(RASIUID)
  1. .F I=$O(HLECH($C(32)),-1):-1:1 K HLECH(I) ;kill array elements
  1. ;
  1. ;If exam does not have an SIUID defined build it here on the fly
  1. I RASIUID="" D
  1. .S RASIUID=$$STUDYUID^MAGDRAHL(RADTI,RACNI,RAZDAYCS)
  1. .S HLA("HLS",$$RTNSUB^RAHLRU1()+1)=$$ZDS^MAGDRAHL(RASIUID)
  1. F I=$O(HLECH($C(32)),-1):-1:1 K HLECH(I) ;kill array elements
  1. Q