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

RAHLRU.m

Go to the documentation of this file. 
  1. RAHLRU ;HISC/GJC - utilities for HL7 messaging ; Apr 26, 2023@12:41:24
  1.  ;;5.0;Radiology/Nuclear Medicine;**10,25,81,103,47,125,162,203**;Mar 16, 1998;Build 1
  1.  ;
  1.  ; 08/13/2010 BP/KAM RA*5*103 Outside Report Status Code needs 'F'
  1.  ;Integration Agreements
  1.  ;----------------------
  1.  ;$$GET1^DIQ(2056); $$HLDATE^HLFNC(10106); INIT^HLFNC2(2161)
  1.  ;GENERATE^HLMA(2164); $$NOW^XLFDT(10103); $$PATCH^XPDUTL(10141)
  1.  ;$$VERSION^XPDUTL(10141); $$HLNAME^XLFNAME(3065)
  1.  ;
  1.  ;IA:  global read .01 field, file ^HL(771,
  1.  ;IA:  global read .01 field, file ^HL(771.2,
  1.  ;IA:  global read .01 field, file ^HL(771.5,
  1.  ;IA:  global read .01 field, file ^HL(779.001,
  1.  ;
  1.  ; RA*5.0*203 update NSR 20230216 gjc 04/26/23
  1. OBR16 ;set OBR-16 Requesting Physician from the exam 70.03;14
  1.  ;RAZXAM is the zero node for the exam (70.03)
  1.  ;called from RAHLR1A & RAHLRPT1
  1.  K RAZNME S RAZNME("FILE")=200,RAZNME("IENS")=$P(RAZXAM,U,14)
  1.  S RAZNME("FIELD")=.01
  1.  S RAOBR(17)=$P(RAZXAM,U,14)_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1))
  1.  K RAZNME
  1.  Q
  1.  ;
  1. OBX11 ; set OBX-11, = 12th piece of string where piece 1 is "OBX"
  1.  N RARPTIEN,Y
  1.  S RARPTIEN=+$G(RARPT)
  1.  S Y=$P($G(^RARPT(RARPTIEN,0)),U,5)
  1.  ; 08/13/2010 BP/KAM RA*5*103 Remedy Call 363538 Changed next line to
  1.  ;                                               test for 'EF' or 'V'
  1.  ;S $P(HLA("HLS",RAN),HLFS,12)=$S(Y="R":"P",Y="V":"F",1:"I")
  1.  S $P(HLA("HLS",RAN),HLFS,12)=$S(Y="R":"P",(Y="V")!(Y="EF"):"F",1:"I")
  1.  ; END *103 CHANGE
  1.  I $D(^RARPT(RARPTIEN,"ERR")) D  Q
  1.  .S $P(HLA("HLS",RAN),HLFS,12)="C"
  1.  Q
  1.  ;
  1. ESCAPE(XDTA) ;apply the appropriate escape sequence to a string of data
  1.  ; Insert a escape sequence place holder, then swap the escape sequence
  1.  ; place holder with the real escape sequence. This action requires two
  1.  ; passes because the escape sequence uses the escape ("\") character.
  1.  ; Input:  XDTA=data string to be escaped (if necessary)
  1.  ;         HLFS=field separator     (global scope; set in INIT^RAHLR)
  1.  ;        HLECH=encoding characters (global scope; set in INIT^RAHLR)
  1.  ; Return: XDTA=an escaped data string
  1.  ;
  1.  N UFS,UCS,URS,UEC,USS ;field, component, repetition, escape, & subcomponent
  1.  S UFS=HLFS,UCS=$E(HLECH),URS=$E(HLECH,2),UEC=$E(HLECH,3),USS=$E(HLECH,4)
  1.  F  Q:XDTA'[UFS  S XDTA=$P(XDTA,UFS)_$C(1)_$P(XDTA,UFS,2,999)
  1.  F  Q:XDTA'[UCS  S XDTA=$P(XDTA,UCS)_$C(2)_$P(XDTA,UCS,2,999)
  1.  F  Q:XDTA'[URS  S XDTA=$P(XDTA,URS)_$C(3)_$P(XDTA,URS,2,999)
  1.  F  Q:XDTA'[UEC  S XDTA=$P(XDTA,UEC)_$C(4)_$P(XDTA,UEC,2,999)
  1.  F  Q:XDTA'[USS  S XDTA=$P(XDTA,USS)_$C(5)_$P(XDTA,USS,2,999)
  1.  F  Q:XDTA'[$C(1)  S XDTA=$P(XDTA,$C(1))_UEC_"F"_UEC_$P(XDTA,$C(1),2,999)
  1.  F  Q:XDTA'[$C(2)  S XDTA=$P(XDTA,$C(2))_UEC_"S"_UEC_$P(XDTA,$C(2),2,999)
  1.  F  Q:XDTA'[$C(3)  S XDTA=$P(XDTA,$C(3))_UEC_"R"_UEC_$P(XDTA,$C(3),2,999)
  1.  F  Q:XDTA'[$C(4)  S XDTA=$P(XDTA,$C(4))_UEC_"E"_UEC_$P(XDTA,$C(4),2,999)
  1.  F  Q:XDTA'[$C(5)  S XDTA=$P(XDTA,$C(5))_UEC_"T"_UEC_$P(XDTA,$C(5),2,999)
  1.  Q XDTA
  1.  ;
  1. OBXPRC ;Compile 'OBX' Segment for Procedure
  1.  S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"P"_$E(HLECH)_"PROCEDURE"_$E(HLECH)_"L"_HLFS_HLFS_$P(RACN0,"^",2)
  1.  S X=$S($D(^RAMIS(71,+$P(RACN0,"^",2),0)):$P(^(0),"^"),1:""),HLA("HLS",RAN)=HLA("HLS",RAN)_$E(HLECH)_X_$E(HLECH)_"L" D OBX11
  1.  ; Replace above with following when Imaging can cope with ESC chars
  1.  ; S X=$S($D(^RAMIS(71,+$P(RACN0,"^",2),0)):$P(^(0),"^"),1:""),HLA("HLS",RAN)=HLA("HLS",RAN)_$E(HLECH)_$$ESCAPE(X)_$E(HLECH)_"L" D OBX11
  1.  Q
  1. OBXMOD ; Compile 'OBX' segments for both types of modifiers
  1.  ; Procedure modifiers
  1.  N X3
  1.  D MODS^RAUTL2 S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"M"_$E(HLECH)_"MODIFIERS"_$E(HLECH)_"L"_HLFS_HLFS_Y D OBX11
  1.  Q:Y(1)="None"
  1.  ; CPT Modifiers
  1.  F RAI=1:1 S X0=$P(Y(1),", ",RAI),X1=$P(Y(2),", ",RAI) Q:X0=""  D
  1.  . S RAN=RAN+1
  1.  . S X3=$$BASICMOD^RACPTMSC(X1,DT)
  1.  . S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"C4"_$E(HLECH)_"CPT MODIFIERS"_$E(HLECH)_"C4"_HLFS_HLFS_X0_$E(HLECH)_$P(X3,"^",3)_$E(HLECH)_"C4"
  1.  . ; Replace above with following when Imaging can cope with ESC chars
  1.  . ;S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"C4"_$E(HLECH)_"CPT MODIFIERS"_$E(HLECH)_"C4"_HLFS_HLFS_X0_$E(HLECH)_$$ESCAPE($P(X3,"^",3))_$E(HLECH)_"C4"
  1.  . I $P(X3,"^",4)]"" S HLA("HLS",RAN)=HLA("HLS",RAN)_$E(HLECH)_$P(X3,"^",4)_$E(HLECH)_$P(X3,"^",3)_$E(HLECH)_"C4"
  1.  . ; Replace above with following when Imaging can cope with ESC chars
  1.  . ;I $P(X3,"^",4)]"" S HLA("HLS",RAN)=HLA("HLS",RAN)_$E(HLECH)_$P(X3,"^",4)_$E(HLECH)_$$ESCAPE($P(X3,"^",3))_$E(HLECH)_"C4"
  1.  . D OBX11
  1.  . Q
  1.  Q
  1.  ;
  1. OBXTCM ; Compile 'OBX' segment for latest TECH COMMENT
  1.  ;
  1.  ; Only Released version of Imaging 2.5 able to handle Tech Comments
  1.  Q:'($$PATCH^XPDUTL("MAG*2.5*1")!(+$$VERSION^XPDUTL("MAG")>2.5))
  1.  ;
  1.  N X4,X3
  1.  S X4=$$GETTCOM^RAUTL11(RADFN,RADTI,RACNI)
  1.  Q:X4=""
  1.  S RAN=RAN+1
  1.  S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"TCM"_$E(HLECH)_"TECH COMMENT"_$E(HLECH)_"L"_HLFS_HLFS
  1.  D OBX11
  1.  I $L(X4)+$L(HLA("HLS",RAN))'>245 D  Q
  1.  .S $P(HLA("HLS",RAN),HLFS,6)=X4
  1.  ;
  1.  ; If Tech Comment is v. long it will need to be
  1.  ; split into two parts. Do not split words if possible....
  1.  ;
  1.  S X3=$E(X4,1,245-$L(HLA("HLS",RAN)))
  1.  I $L(X3," ")>1 S X3=$P(X3," ",1,$L(X3," ")-1)
  1.  S X4=$P(X4,X3,2)
  1.  S $P(HLA("HLS",RAN),HLFS,6)=X3
  1.  S HLA("HLS",RAN,1)=X4_HLFS_$P(HLA("HLS",RAN),HLFS,7,12)
  1.  S HLA("HLS",RAN)=$P(HLA("HLS",RAN),HLFS,1,6)
  1.  Q
  1.  ;
  1. INIT ; initialize HL7 variables; called from RAHLR & RAHLRPT
  1.  Q:'$G(RAEID)  ;undefined server application
  1.  S HLDT=$$NOW^XLFDT(),HLDT1=$$HLDATE^HLFNC(HLDT),EID=RAEID
  1.  S HL="HLS(""HLS"")",INT=1
  1.  D INIT^HLFNC2(EID,.HL,INT)
  1.  Q:'$D(HL("Q"))  ;improperly defined server application
  1.  S HLQ=HL("Q"),HLFS=HL("FS"),HLECH=HL("ECH") K EID,INT
  1.  S HLCS=$E(HL("ECH"))
  1.  S HLSCS=$E(HL("ECH"),4)
  1.  S HLREP=$E(HL("ECH"),2)
  1.  Q
  1.  ;
  1. DOB(X) ;strip off trailing "0"'s from the date of birth
  1.  I $E(X,5,6)="00" S X=$E(X,1,4) ;if no month then no day, return year
  1.  E  I $E(X,7,8)="00" S X=$E(X,1,6) ;if month & no day, return month/year
  1.  Q X
  1.  ;
  1. CPTMOD(RAIEN,HLECH,DT) ;return OBX-5 as it pertains to CPT Modifiers
  1.  ;called from: RAHLRPT2 & RAHLR1A
  1.  ;input: RAIEN=IEN of the record in file 81.3
  1.  ;       HLECH=HL7 encoding characters
  1.  ;          DT=today's date
  1.  N X S X=$$BASICMOD^RACPTMSC(RAIEN,DT)
  1.  ;1st piece=IEN #81.3; 3rd piece=versioned name; 5th piece=coding sys
  1.  ;Q RAIEN_$E(HLECH,1)_$$ESCAPE^RAHLRU($P(X,U,3))_$E(HLECH,1)_$P(X,U,5)
  1.  ;9/5/08 the above line changed to below per IMAGING
  1.  Q $P(X,U,2)_$E(HLECH,1)_$$ESCAPE^RAHLRU($P(X,U,3))_$E(HLECH,1)_"C4"
  1.  ;
  1. GETSFLAG(SAN,MTN,ETN,VER) ;Return HL message flag (79.721,1)
  1.  Q:'$L(SAN)!'$L(MTN)!'$L(ETN)!'$L(VER) 0
  1.  S SAN=$O(^HL(771,"B",SAN,0)) Q:'SAN 0
  1.  S MTN=$O(^HL(771.2,"B",MTN,0)) Q:'MTN 0
  1.  S ETN=$O(^HL(779.001,"B",ETN,0)) Q:'ETN 0
  1.  S VER=$O(^HL(771.5,"B",VER,0)) Q:'VER 0
  1.  Q +$P($G(^RA(79.7,SAN,1,MTN,1,ETN,1,VER,0)),U,2)
  1.  ;
  1. OBR21(HLECH,RA7002) ;builds the OBR-21 field; called from RAHLR1A
  1.  ;Input
  1.  ;  HLECH=encoding characters (required for $$ESCAPE^RAHLRU)
  1.  ; RA7002=zero node of the REGISTERED EXAMS sub-file of the RAD/NUC MED
  1.  ;        PATIENT (#70) file.
  1.  ;Return:
  1.  ; Component one (derived from file #79.2)
  1.  ;   ABBREVIATION(#3)_NAME(#.01)
  1.  ; Component two (derived from file #79.1)
  1.  ;   File 79.1 IEN_NAME(#.01) of the HOSPITAL LOCATION(#44) record.
  1.  ; Component three (derived from file #79)
  1.  ;   DIVISION(#.01)_NAME(#.01) of the INSTITUTION(#4) record.
  1.  ;
  1.  ;Components as separated by the accent grave "`" (RAPCS); subcomponents by the
  1.  ;underscore "_" (RAPSS)
  1.  ;
  1.  ; Ex: RAD_GENERAL RADIOLOGY`1_TD-RAD`660_SALT LAKE CITY
  1.  ;
  1.  N RAX S RAPCS="`",RAPSS="_",RAX=""
  1.  S RA792Q=+$P(RA7002,U,2) ;imaging type pointer
  1.  S RA792Q(0)=$G(^RA(79.2,RA792Q,0)) ;imaging type zero node
  1.  ;create the i-type abbreviation, component separator, and full name string
  1.  S RAX=$P(RA792Q(0),U,3)_RAPSS_$P(RA792Q(0),U)
  1.  ;get hospital location and institution file data...
  1.  S RA791Q=+$P(RA7002,U,4) ;imaging location pointer
  1.  S RA44Q=+$P($G(^RA(79.1,RA791Q,0)),U) ;hospital location pointer
  1.  S RA44Q(0)=$$GET1^DIQ(44,RA44Q,.01) ;hospital location name
  1.  S RA4Q=+$P(RA7002,U,3) ;rad/nuc med division pointer dinum'd to INSTITUTION (#4) file
  1.  S RA4Q(0)=$$GET1^DIQ(4,RA4Q,.01) ;institution name
  1.  S RAX=RAX_RAPCS_RA791Q_RAPSS_RA44Q(0)_RAPCS_RA4Q_RAPSS_RA4Q(0)
  1.  K RA4Q,RA44Q,RA791Q,RA792Q,RAPCS,RAPSS
  1.  Q $$ESCAPE^RAHLRU(RAX)
  1.  ;
  1. BLDHLP ;build the HLP("EXCLUDE SUBSCRIBER",n) array
  1.  ; is HLP("EXCLUDE SUBSCRIBER",n) defined? If yes get 'n'
  1.  N RAX,RAY S RAX="EXCLUDE SUBSCRIBER"
  1.  S RAY=$$HLPEXSUB(.HLP)
  1.  I RAY="" M HLP(RAX)=RASSS(RAX) Q
  1.  N RAI S RAI=0
  1.  F  S RAI=$O(RASSS(RAX,RAI)) Q:RAI'>0  D
  1.  .S RAY=RAY+1,HLP(RAX,RAY)=RASSS(RAX,RAI)
  1.  .Q
  1.  Q
  1.  ;
  1. HLPEXSUB(A) ;determine the last subscript (n) of a local array
  1.  ;whose format is: A("EXCLUDE SUBSCRIBER",n)
  1.  ;Input: A = local array name;
  1.  Q $O(A("EXCLUDE SUBSCRIBER",$C(32)),-1)
  1.  ;
  1. GENERATE ;Broadcast the HL7 message (courtesy of the VistA HL7 application)
  1.  N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLP
  1.  S HLEID=RAEID,HLARYTYP="LM",HLFORMAT=1,HLMTIEN="",HLP("PRIORITY")="I"
  1.  ;
  1.  ;1 - RASSSX is set by the 'Resend Radiology HL7 Messages By Date Range'
  1.  ;    option. GETHLP sets the HLP("EXCLUDE SUBSCRIBER" array
  1.  D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX") ;RA5P125
  1.  ;
  1.  ;2 - Do we return this HL7 message to the application that broadcasted
  1.  ;    it? The following code also sets the HLP("EXCLUDE SUBSCRIBER" array
  1.  D:$D(RASSS("EXCLUDE SUBSCRIBER"))\10 BLDHLP ;RA5P125
  1.  ;
  1.  ;Note: Events 1 & 2 are independent of one another. They will never
  1.  ;      set the HLP array in the same process.
  1.  ;
  1.  ;//RA5P162 update //
  1.  ;3 - exclude subscribers that are not teleradiology (file: 79.7)
  1.  D:$D(RASSSX1(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX1")
  1.  ;//RA5P162 update end //
  1.  ;
  1.  D GENERATE^HLMA(RAEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP)
  1.  D GSTATUS^RAHLACK(.HLRESLT,RAEID) K HLRESLT
  1.  ;
  1. EXIT ;kill the variables; exit the process...
  1.  K HL771RF,HL771SF,HL7STRG,HLA,HLARYTYP,HLCS,HLDOM,HLECH,HLEID,HLES,HLES2,HLFORMAT
  1.  K HLFS,HLINSTN,HLMTIEN,HLN,HLP,HLPARAM,HLPID,HLQ,HLREC,HLREP,HLRFREQ,HLSAN,HLSCS
  1.  K HLSFREQ,HLTYPE,HLX,OCXSEG,OCXTSPI,RAOBR,RAORC,RAPID,RAPURGE,RAPV1,RAREFDOC,RAZCPT
  1.  K RAZDAYCS,RAZDTE,RAZMODE,RAZNME,RAZORD,RAZORD1,RAZPHONE,RAZPMOD,RAZPREG,RAZPROC
  1.  K RAZRPT,RAZRXAM,RAZTRANS,RAZXAM,HLRESLT
  1.  K ^UTILITY($J,"W") ;note HLCS, HLREP, & HLSCS are set in INIT^RAHLRU
  1.  Q
  1.  ;