RAHLTCPX ;HIRMFO/RTK,RVD,GJC - Rad/Nuc Med HL7 TCP/IP Bridge;02/11/08
;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21
;
; this is a modified copy of RAHLTCPB for HL7 v2.4
;
;Integration Agreements
;----------------------
;GENACK^HLMA1(2165); DT^XLFDT(10103) ^DPT("SSN" (10035)
;
EN1 ; Main entry point; Build the ^TMP("RARPT-REC" global
;
N ARR,HLCS,HLDTM,HLFS,HLSCS,MSA1,PAR,RAI,RAX,RAY,RAXX,RAEXIT,RARCNT
N RASEG,RASUB,RAHLTCPB,RANODE,RAVERF,RAESIG,RAERR,RANOSEND
N RARRR,RACNPPP,RACKYES,RAPRSET,RAT35,RASTRE,RARE33
D INIT,PROCESS,XIT
Q
;
INIT ; -- initialize
;
S RASUB=HL("MID"),RAHLTCPB=1,RACNPPP=0,RARRR="",RACKYES=0 K RAERR
K ^TMP("RARPT-REC",$J,RASUB) ; kill storage area for new HL7 message id
S ^TMP("RARPT-REC",$J,RASUB,"RADATE")=$$DT^XLFDT()
S ^TMP("RARPT-REC",$J,RASUB,"VENDOR")=$G(HL("SAN"))
S:$D(HL("ESIG")) ^TMP("RARPT-REC",$J,RASUB,"RAESIG")=HL("ESIG") ;Save off E-Sig information (if it exists)
S:'$$GETSFLAG^RAHLRU($G(HL("SAN")),$G(HL("MTN")),$G(HL("ETN")),$G(HL("VER"))) RANOSEND=$G(HL("SAN"))
;
S HLDTM=HL("DTM")
S HLFS=HL("FS")
S HLCS=$E(HL("ECH"))
S HLSCS=$E(HL("ECH"),4)
S HLREP=$E(HL("ECH"),2)
S HLECH=HL("ECH")
Q
;
PROCESS ; -- pull message text
;
F X HLNEXT Q:HLQUIT'>0!$G(RAEXIT) D
.I '$L(HLNODE),$L($G(HLNODE(1))) S HLNODE=HLNODE(1) K HLNODE(1) F J=2:1 Q:'$D(HLNODE(J)) S HLNODE(J-1)=HLNODE(J) K HLNODE(J)
.Q:$P(HLNODE,HLFS)=""
.Q:"^MSH^PID^PV1^OBR^OBX^ORC^"'[(U_$P(HLNODE,HLFS)_U)
.K ARR,PAR M ARR(1)=HLNODE D PARSEG^RAHLRU1(.ARR,.PAR)
.D @($P(HLNODE,HLFS))
Q:$G(RAEXIT)
I '$D(RASEG("PID")) S RAERR="Missing PID Segment" Q
I '$D(RASEG("OBR")) S RAERR="Missing OBR Segment" Q
I '$D(RASEG("OBX")) S RAERR="Missing OBX Segment" Q
Q
;
MSH ;
Q
PID ; Pick data off the 'PID' segment.
;Req: PID-2(Station number concatenated with dash and DFN ex: 587-1234),
; PID-3(SSN), PID-4(National ICN), PID-5(Patient Name), PID-19(SSN)
;Opt: PID-7(Date of Birth), PID-8(Sex), PID-10(Race), PID-11(Address),
; PID-13(Phone-Home), PID-14(Phone-Bus), PID-22(Ethnic Group)
;
;As a result of PID-2, PID-3, PID-4 discussions/emails with Imaging and
; Identity Management (IDM), the above description is what will be sent
; in fields PID-2 thru PID-4. For parsing incoming ORU messages from
; voice recognition systems, this code will first look for the SSN in
; PID-3. If that is null or not a valid SSN, the code will next look
; for the Station Number-DFN in PID-2. If that is null or does not
; contain a valid DFN, the message will be rejected with an "Invalid
; Patient Identifier" reject message.
;
; get SSN from PID-3/PAR(4) if unsuccessful get DFN from PID-2/PAR(3)
S RADFN="" S RASSNVAL=$P($G(PAR(4)),U,1) I RASSNVAL'="" S RADFN=$O(^DPT("SSN",RASSNVAL,""))
I RADFN="" S RADFN=$P($P($G(PAR(3)),U,1),"-",2) ;strip station number and get DFN
I $G(RADFN)="" S RAERR="Invalid patient identifier",RAEXIT=1 Q
I $G(RADFN)'="" S ^TMP("RARPT-REC",$J,RASUB,"RADFN")=RADFN
;
; get SSN from PID-19/PAR(20)
I $G(PAR(20)) S RASSN=PAR(20),^TMP("RARPT-REC",$J,RASUB,"RASSN")=RASSN
S RASEG("PID")=""
;.I $P(PAR(5),U,5)="NI" D Q ;check for valid ICN
;..S RAICNVAL=$P($P(PAR(5),U,1),"V",1),RADFN=$$GETDFN^MPIF001(RAICNVAL)
;..I $G(RADFN)<0 S RAERR="Invalid patient ICN",RAEXIT=1,RADFN="" Q
Q
PV1 ;Ignored at this time.
Q
ORC ; Pick data off the 'ORC' segment
;Opt: ORC -1
; = CN The combined result code provides a mechanism to transmit
; results that are associated with two or more orders.
; This situation occurs commonly in reports when the radiologist
; dictates a single report for two or more exams.
; = RE Observations to follow is used to transmit patient-specific information with an order.
; An order detail segment (e.g., OBR) can be followed by one or more observation RASEGments (OBX).
; Any observation that can be transmitted in an ORU message can be transmitted with this mechanism.
; When results are transmitted with an order, the results should immediately follow the order or orders that they support.
S RARRR="",RASEG("ORC")=PAR(2)
S:PAR(2)="CN" RACNPPP=RACNPPP+1,RARRR="RARPT-REC-"_RACNPPP
Q
OBR ; Pick data off the 'OBR' segment.
;Req: OBR-1(set ID), OBR-2(Placer Order #), OBR-3(Filler Order #), OBR-4(Uni. Service ID)
; OBR-7(Observ. Date/time), OBR-16(Ord. Provider), OBR-18(Placer Fld 1)
; OBR-19(Placer Fld 2), OBR-20(Filler Fld 1), OBR-21(Filler Fld 2)
; OBR-22(Rslts Rpt/Stat Chng D/T), OBR-25(Rslts Status)
;Opt: OBR-15(Specimen Source), OBR-17(Ord. Callback Phone #), OBR-29(Parent)
; OBR-32(Prin. Rslt Interpreter), OBR-33(Asst. Rslt Interpreter), OBR-35(Transcriptionist)
S RASEG("OBR")=""
I $L(RARRR) K ^TMP(RARRR,$J) M ^TMP(RARRR,$J)=^TMP("RARPT-REC",$J) ;Merge if OBR without Report
S:'$L(RARRR) RARRR="RARPT-REC"
N RAX,RAX1,RAX2,RAI,RARR,RAVERF,RARSDNT,RATRANSC,ARR
;OBR-3/PAR(4) for v2.4: site specific accession # (SSS-DDDDDD-CCCCC)
;Note: if SSAN parameter switch is off format is old # (DDDDDD-CCCCC)
D:$L(PAR(4))
.S RALONGCN=$P(PAR(4),HLCS),^TMP(RARRR,$J,RASUB,"RALONGCN")=RALONGCN
.I RALONGCN="" Q
.I $L(RALONGCN,"-")=2 D ;if old format get data from "ADC" x-ref
..S RADTI=$O(^RADPT("ADC",RALONGCN,RADFN,"")) Q:RADTI=""
..S RACNI=$O(^RADPT("ADC",RALONGCN,RADFN,RADTI,"")) Q:RACNI=""
.I $L(RALONGCN,"-")=3 D ;if new format get data from "ADC1" x-ref
..S RADTI=$O(^RADPT("ADC1",RALONGCN,RADFN,"")) Q:RADTI=""
..S RACNI=$O(^RADPT("ADC1",RALONGCN,RADFN,RADTI,"")) Q:RACNI=""
.Q:RADTI=""
.Q:RACNI=""
.S ^TMP(RARRR,$J,RASUB,"RADTI")=RADTI
.S ^TMP(RARRR,$J,RASUB,"RACNI")=RACNI
I $G(RADTI)'>0 S RAERR="Invalid exam registration timestamp" D XIT Q
I $G(RACNI)'>0 S RAERR="Invalid exam record IEN" D XIT Q
;OBR-25/PAR(26) STATUS: 'C'orrected, 'F'inal, or 'R'esults filed, not verified
I '$L(PAR(26)) S RAERR="Missing Report Status",RAEXIT=1 Q
I "CFR"'[PAR(26) S RAERR="Invalid Report Status: "_PAR(26),RAEXIT=1 Q
S ^TMP(RARRR,$J,RASUB,"RASTAT")=PAR(26)
G:$P(RARRR,"-",3) 112
;OBR-32 PAR(33) Principal Result Interpreter
S RAVERF=+$G(PAR(33)),RAST32=$$VFIER^RAHLRU1(.RAVERF,PAR(26),"OBR-32") I 'RAST32 S RAERR=$P(RAST32,"^",2),RAEXIT=1 Q
I '$D(^XUSEC("RA VERIFY",RAVERF)) S RAERR="PHYSICIAN has no RA VERIFY key",RAEXIT=1 Q
D SR^RAHLRU1(RAVERF)
I +RASTRE=-1 S RAERR=$P(RASTRE,U,2),RAEXIT=1 Q
I RASTRE'["^S^" S RAERR="PHYSICIAN must have a STAFF classification" S RAEXIT=1 Q
S ^TMP(RARRR,$J,RASUB,"RAVERF")=RAVERF
S ^TMP(RARRR,$J,RASUB,"RASTAFF",1)=RAVERF,^("RAWHOCHANGE")=RAVERF ;ID #^family^given
;OBR-33 First Interpreter of Resident type will be the Primary Interpreting staff
D:$L($G(PAR(34)))
.;build an array of good assistants (active & the proper classification)
.S RARR=0 F I=1:1:10 S RARE33=$P(PAR(34),HLREP,I) D:$L(RARE33)
..D SR^RAHLRU1(+RARE33) Q:+RASTRE=-1
..I RASTRE'["^S^",RASTRE'["^R^" Q ;must be a staff or res.
..;find the first resident...
..I RASTRE["^R^",('($D(RARSDNT)#2)) S (RARSDNT,^TMP(RARRR,$J,RASUB,"RARESIDENT"))=+RARE33 Q
..I RASTRE["^R^" S ^TMP(RARRR,$J,RASUB,"RARESIDENT",I)=+RARE33 Q ; To be stored in 70.03 field 70
..I RASTRE["^S^" S ^TMP(RARRR,$J,RASUB,"RASTAFF",I)=+RARE33 ;To be stored in 70.03 field 60
..Q
.Q
;"OBR-35" Transcriptionist
S RATRANSC=$G(PAR(36)),RATRANSC=$P(RATRANSC,HLCS,4)
I RATRANSC'="" S RAT35=$$VFIER^RAHLRU1(.RATRANSC,PAR(26),"OBR-35") I 'RAT35 S RAERR=$P(RAT35,"^",2),RAEXIT=1 Q
S ^TMP(RARRR,$J,RASUB,"RATRANSCRIPT")=$S(RATRANSC]"":RATRANSC,$D(RARSDNT):RARSDNT,1:RAVERF)
D ESIG^RAHLO3
;If last OBR set provider info to all OBRs
K RAXX F I=1:1:RACNPPP S RAXX=RARRR_"-"_I D:$D(^TMP(RAXX,$J,RASUB))
.N RAXXX M RAXXX=^TMP(RAXX,$J,RASUB),^TMP(RAXX,$J,RASUB)=^TMP(RARRR,$J,RASUB),^TMP(RAXX,$J,RASUB)=RAXXX
;
112 ;
I $D(RADTI),$D(RACNI),$D(RAPRSET(RADTI,RACNI)) K RAPRSET(RADTI,RACNI),^TMP(RARRR,$J) S RACNPPP=RACNPPP-1 Q:$P(RARRR,"-",3) M ^TMP(RARRR,$J)=^TMP("RARPT-REC-"_(RACNPPP+1),$J) K ^TMP("RARPT-REC-"_(RACNPPP+1),$J) Q
I $D(RADTI),'$D(RAPRSET(RADTI)) D ;Get array of printset for date...
.N RAPRTSET,RACN,RASUB,CNT
.K RAXX D EN2^RAUTL20(.RAXX) M:$D(RAXX) RAPRSET(RADTI)=RAXX K RAPRSET(RADTI,RACNI)
Q
;
OBX ; Pick data off the 'OBX' segments
;Req: OBX-2(Value Type), OBX-3(Observ. ID), OBX-5(Observ. Value)
; OBX-11(Observ. Rslt. Status)
;
; OBX-2=CE:Coded Element, T:Text
; OBX-3=Identifier ^ Text ^ Name of Coding System ('^' is the
; component separator)
; P^PROCEDURE^L, I^IMPRESSION^L, D^DIAGNOSTIC CODE^L, M:MODIFIERS^L,
; TCM^TECH COMMENT^L, C4^CPT MODIFIERS^L, R^REPORT^L
; OBX-5=data within classification (OBX-3) by Value Type (OBX-2)
; OBX-11=F:Final Results; C:Correction, replace final results;
; R:Rslts entered-not v'fied
;
N RAX S RAOBX3=3 ;RAOBX3 is the # of required components for OBX-3
S RASEG("OBX")="" I $G(PAR(4))']"" S RAERR="Missing Observation Identifier",RAEXIT=1 Q
I $L(PAR(4),HLCS)'=RAOBX3 S RAERR="Observation Identifier format error",RAEXIT=1 Q
;verify OBX-3 by component (three components)
;Ex. RAOBR3(1)="P", RAOBR3(2)="PROCEDURE", RAOBR3(3)="L" always "L"
F RAI=1:1:RAOBX3 S RAOBX3(RAI)=$P(PAR(4),HLCS,RAI)
;
I RAOBX3(3)'="L" S RAERR="Observation Identifier Coding System name in error",RAEXIT=1 Q
S RASTR=""_HLCS_"",RASTR(0)=$P(PAR(4),HLCS,1,2)
;RASTR(0)=identifer and text for this specific HL7 message
;build the identifier and text string for all possible values...
F RAI=1:1 S RAX=$T(OBX3+RAI) Q:RAX="" S RASTR=RASTR_$P(RAX,";",3)_HLCS_$P(RAX,";",4)_HLCS
I RASTR'[(HLCS_RASTR(0)_HLCS) S RAERR="Observation Identifier/Text mismatch" Q
;verify the Observation Value OBX-5
S RAX=$G(PAR(6)),RANODE=$S(RAOBX3(1)="D":"RADX",RAOBX3(1)="I":"RAIMP",1:"RATXT")
S RARCNT(RAOBX3(1))=$G(RARCNT(RAOBX3(1)))+1
I RAX["\S\"!(RAX["\R\")!(RAX["\E\")!(RAX["\T\") S RAX=$$DEESC(RAX)
; For DX Codes we are expecting only the # (ie, 1,2,5 etc not the text)
; If VR (PSCRIBE) sends text with DX Code, strip off text in next line
; Text only will be rejected
I RAOBX3(1)="D" S RAX=+RAX
S ^TMP("RARPT-REC",$J,RASUB,RANODE,RARCNT(RAOBX3(1)))=RAX
F RAI=1:1:RACNPPP S RARRR="RARPT-REC-"_RAI S ^TMP(RARRR,$J,RASUB,RANODE,RARCNT(RAOBX3(1)))=RAX
K RAOBX3,RASTR
Q
XIT ;
D ERR I RAERRCHK=1 G XIT1
I $D(^TMP("RARPT-REC",$J)) S:'RACNPPP RACKYES=1 D EN1^RAHLO D ERR I RAERRCHK=1 G XIT1
F RAI=1:1:RACNPPP S RARRR="RARPT-REC-"_RAI D:$D(^TMP(RARRR,$J))
.K ^TMP("RARPT-REC",$J) M ^TMP("RARPT-REC",$J)=^TMP(RARRR,$J) K ^TMP(RARRR,$J)
.S RACKYES=(RAI=RACNPPP) N I D EN1^RAHLO D ERR I RAERRCHK=1 G XIT1
XIT1 K ^TMP("RARPT-REC",$J) ; kill storage area for current HL7 message id
F RAI=1:1:RACNPPP S RARRR="RARPT-REC-"_RAI K ^TMP(RARRR,$J)
Q
ERR ;
S RAERRCHK=0
I $D(RAERR) D
.S RAEXIT=1,RACKYES=1,RAERRCHK=1
.D ENX^RAHLEXF(HLDTM,RASUB)
.D GENACK
.Q
Q
;
DEESC(RASTR) ;Replace escape sequences with their field separator and escape character
;equivalents. (RAHLTCPX)
;
;input : RASTR=the string of characters being checked for esc sequences
;output: returns a string with field separator and escape characters in
; place of escape sequences
;
;RAFSESC/HLFS = field separator
;RACSESC/$E(HLECH,1) = component separator
;RARSESC/$E(HLECH,2) = repetition separator
;RAESESC/$E(HLECH,3) = escape character
;RASCESC/$E(HLECH,4) = subcomponent separator
;
N RAFSESC,RACSESC,RARSESC,RAESESC,RASCESC
S RAFSESC="\F\",RACSESC="\S\",RARSESC="\R\",RAESESC="\E\",RASCESC="\T\"
N RAYES ;escape characters present? if yes, set YES to one
F D Q:'RAYES
.S RAYES=0
.I RASTR[RAFSESC S RASTR=$P(RASTR,RAFSESC)_HLFS_$P(RASTR,RAFSESC,2,99999),RAYES=1
.I RASTR[RACSESC S RASTR=$P(RASTR,RACSESC)_$E(HLECH,1)_$P(RASTR,RACSESC,2,99999),RAYES=1
.I RASTR[RARSESC S RASTR=$P(RASTR,RARSESC)_$E(HLECH,2)_$P(RASTR,RARSESC,2,99999),RAYES=1
.I RASTR[RAESESC S RASTR=$P(RASTR,RAESESC)_$E(HLECH,3)_$P(RASTR,RAESESC,2,99999),RAYES=1
.I RASTR[RASCESC S RASTR=$P(RASTR,RASCESC)_$E(HLECH,4)_$P(RASTR,RASCESC,2,99999),RAYES=1
.Q
Q RASTR
;
GENACK ; Compile the 'ACK' segment, generate the 'ACK' message.
Q:'$G(RACKYES)
N HLFORMAT,HLARYTYP,RESULT
S MSA1="AA"
Q:$E($G(HL("SAN")),1,3)'="RA-" ; Don't allow non RA namespaced interfaces
I $D(RAERR) S MSA1=$S(HL("SAN")="RA-PSCRIBE-TCP"!$G(RATELE):"AE",1:"AR")
; Added next line to support MedSpeak interface. Must re-initialize
; FS and EC's before sending ACK.
;D:HL("SAN")="RA-CLIENT-TCP" INIT^HLFNC2("RA VOICE TCP SERVER RPT",.HL)
S HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$S($D(RAERR):HL("FS")_RAERR,1:"")
S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1
K HLRESLT D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.RESULT)
I $G(RESULT)="" Q ; RTK 3/26/2008 - UNDEFINED 'RESULT' ERROR
I +$P(RESULT,U,2) D ASTATUS^RAHLACK(RESULT,RASUB,HL("SAN")) ;ERROR in gen ACK...
Q
;
OBX3 ;set the values for OBX-3.1 & OBX-3.2
;;P;PROCEDURE
;;I;IMPRESSION
;;D;DIAGNOSTIC CODE
;;M;MODIFIERS
;;TCM;TECH COMMENT
;;C4;CPT MODIFIERS
;;R;REPORT
RAHLTCPX ;HIRMFO/RTK,RVD,GJC - Rad/Nuc Med HL7 TCP/IP Bridge;02/11/08
+1 ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21
+2 ;
+3 ; this is a modified copy of RAHLTCPB for HL7 v2.4
+4 ;
+5 ;Integration Agreements
+6 ;----------------------
+7 ;GENACK^HLMA1(2165); DT^XLFDT(10103) ^DPT("SSN" (10035)
+8 ;
EN1 ; Main entry point; Build the ^TMP("RARPT-REC" global
+1 ;
+2 NEW ARR,HLCS,HLDTM,HLFS,HLSCS,MSA1,PAR,RAI,RAX,RAY,RAXX,RAEXIT,RARCNT
+3 NEW RASEG,RASUB,RAHLTCPB,RANODE,RAVERF,RAESIG,RAERR,RANOSEND
+4 NEW RARRR,RACNPPP,RACKYES,RAPRSET,RAT35,RASTRE,RARE33
+5 DO INIT
DO PROCESS
DO XIT
+6 QUIT
+7 ;
INIT ; -- initialize
+1 ;
+2 SET RASUB=HL("MID")
SET RAHLTCPB=1
SET RACNPPP=0
SET RARRR=""
SET RACKYES=0
KILL RAERR
+3 ; kill storage area for new HL7 message id
KILL ^TMP("RARPT-REC",$JOB,RASUB)
+4 SET ^TMP("RARPT-REC",$JOB,RASUB,"RADATE")=$$DT^XLFDT()
+5 SET ^TMP("RARPT-REC",$JOB,RASUB,"VENDOR")=$GET(HL("SAN"))
+6 ;Save off E-Sig information (if it exists)
IF $DATA(HL("ESIG"))
SET ^TMP("RARPT-REC",$JOB,RASUB,"RAESIG")=HL("ESIG")
+7 IF '$$GETSFLAG^RAHLRU($GET(HL("SAN")),$GET(HL("MTN")),$GET(HL("ETN")),$GET(HL("VER")))
SET RANOSEND=$GET(HL("SAN"))
+8 ;
+9 SET HLDTM=HL("DTM")
+10 SET HLFS=HL("FS")
+11 SET HLCS=$EXTRACT(HL("ECH"))
+12 SET HLSCS=$EXTRACT(HL("ECH"),4)
+13 SET HLREP=$EXTRACT(HL("ECH"),2)
+14 SET HLECH=HL("ECH")
+15 QUIT
+16 ;
PROCESS ; -- pull message text
+1 ;
+2 FOR
XECUTE HLNEXT
IF HLQUIT'>0!$GET(RAEXIT)
QUIT
Begin DoDot:1
+3 IF '$LENGTH(HLNODE)
IF $LENGTH($GET(HLNODE(1)))
SET HLNODE=HLNODE(1)
KILL HLNODE(1)
FOR J=2:1
IF '$DATA(HLNODE(J))
QUIT
SET HLNODE(J-1)=HLNODE(J)
KILL HLNODE(J)
+4 IF $PIECE(HLNODE,HLFS)=""
QUIT
+5 IF "^MSH^PID^PV1^OBR^OBX^ORC^"'[(U_$PIECE(HLNODE,HLFS)_U)
QUIT
+6 KILL ARR,PAR
MERGE ARR(1)=HLNODE
DO PARSEG^RAHLRU1(.ARR,.PAR)
+7 DO @($PIECE(HLNODE,HLFS))
End DoDot:1
+8 IF $GET(RAEXIT)
QUIT
+9 IF '$DATA(RASEG("PID"))
SET RAERR="Missing PID Segment"
QUIT
+10 IF '$DATA(RASEG("OBR"))
SET RAERR="Missing OBR Segment"
QUIT
+11 IF '$DATA(RASEG("OBX"))
SET RAERR="Missing OBX Segment"
QUIT
+12 QUIT
+13 ;
MSH ;
+1 QUIT
PID ; Pick data off the 'PID' segment.
+1 ;Req: PID-2(Station number concatenated with dash and DFN ex: 587-1234),
+2 ; PID-3(SSN), PID-4(National ICN), PID-5(Patient Name), PID-19(SSN)
+3 ;Opt: PID-7(Date of Birth), PID-8(Sex), PID-10(Race), PID-11(Address),
+4 ; PID-13(Phone-Home), PID-14(Phone-Bus), PID-22(Ethnic Group)
+5 ;
+6 ;As a result of PID-2, PID-3, PID-4 discussions/emails with Imaging and
+7 ; Identity Management (IDM), the above description is what will be sent
+8 ; in fields PID-2 thru PID-4. For parsing incoming ORU messages from
+9 ; voice recognition systems, this code will first look for the SSN in
+10 ; PID-3. If that is null or not a valid SSN, the code will next look
+11 ; for the Station Number-DFN in PID-2. If that is null or does not
+12 ; contain a valid DFN, the message will be rejected with an "Invalid
+13 ; Patient Identifier" reject message.
+14 ;
+15 ; get SSN from PID-3/PAR(4) if unsuccessful get DFN from PID-2/PAR(3)
+16 SET RADFN=""
SET RASSNVAL=$PIECE($GET(PAR(4)),U,1)
IF RASSNVAL'=""
SET RADFN=$ORDER(^DPT("SSN",RASSNVAL,""))
+17 ;strip station number and get DFN
IF RADFN=""
SET RADFN=$PIECE($PIECE($GET(PAR(3)),U,1),"-",2)
+18 IF $GET(RADFN)=""
SET RAERR="Invalid patient identifier"
SET RAEXIT=1
QUIT
+19 IF $GET(RADFN)'=""
SET ^TMP("RARPT-REC",$JOB,RASUB,"RADFN")=RADFN
+20 ;
+21 ; get SSN from PID-19/PAR(20)
+22 IF $GET(PAR(20))
SET RASSN=PAR(20)
SET ^TMP("RARPT-REC",$JOB,RASUB,"RASSN")=RASSN
+23 SET RASEG("PID")=""
+24 ;.I $P(PAR(5),U,5)="NI" D Q ;check for valid ICN
+25 ;..S RAICNVAL=$P($P(PAR(5),U,1),"V",1),RADFN=$$GETDFN^MPIF001(RAICNVAL)
+26 ;..I $G(RADFN)<0 S RAERR="Invalid patient ICN",RAEXIT=1,RADFN="" Q
+27 QUIT
PV1 ;Ignored at this time.
+1 QUIT
ORC ; Pick data off the 'ORC' segment
+1 ;Opt: ORC -1
+2 ; = CN The combined result code provides a mechanism to transmit
+3 ; results that are associated with two or more orders.
+4 ; This situation occurs commonly in reports when the radiologist
+5 ; dictates a single report for two or more exams.
+6 ; = RE Observations to follow is used to transmit patient-specific information with an order.
+7 ; An order detail segment (e.g., OBR) can be followed by one or more observation RASEGments (OBX).
+8 ; Any observation that can be transmitted in an ORU message can be transmitted with this mechanism.
+9 ; When results are transmitted with an order, the results should immediately follow the order or orders that they support.
+10 SET RARRR=""
SET RASEG("ORC")=PAR(2)
+11 IF PAR(2)="CN"
SET RACNPPP=RACNPPP+1
SET RARRR="RARPT-REC-"_RACNPPP
+12 QUIT
OBR ; Pick data off the 'OBR' segment.
+1 ;Req: OBR-1(set ID), OBR-2(Placer Order #), OBR-3(Filler Order #), OBR-4(Uni. Service ID)
+2 ; OBR-7(Observ. Date/time), OBR-16(Ord. Provider), OBR-18(Placer Fld 1)
+3 ; OBR-19(Placer Fld 2), OBR-20(Filler Fld 1), OBR-21(Filler Fld 2)
+4 ; OBR-22(Rslts Rpt/Stat Chng D/T), OBR-25(Rslts Status)
+5 ;Opt: OBR-15(Specimen Source), OBR-17(Ord. Callback Phone #), OBR-29(Parent)
+6 ; OBR-32(Prin. Rslt Interpreter), OBR-33(Asst. Rslt Interpreter), OBR-35(Transcriptionist)
+7 SET RASEG("OBR")=""
+8 ;Merge if OBR without Report
IF $LENGTH(RARRR)
KILL ^TMP(RARRR,$JOB)
MERGE ^TMP(RARRR,$JOB)=^TMP("RARPT-REC",$JOB)
+9 IF '$LENGTH(RARRR)
SET RARRR="RARPT-REC"
+10 NEW RAX,RAX1,RAX2,RAI,RARR,RAVERF,RARSDNT,RATRANSC,ARR
+11 ;OBR-3/PAR(4) for v2.4: site specific accession # (SSS-DDDDDD-CCCCC)
+12 ;Note: if SSAN parameter switch is off format is old # (DDDDDD-CCCCC)
+13 IF $LENGTH(PAR(4))
Begin DoDot:1
+14 SET RALONGCN=$PIECE(PAR(4),HLCS)
SET ^TMP(RARRR,$JOB,RASUB,"RALONGCN")=RALONGCN
+15 IF RALONGCN=""
QUIT
+16 ;if old format get data from "ADC" x-ref
IF $LENGTH(RALONGCN,"-")=2
Begin DoDot:2
+17 SET RADTI=$ORDER(^RADPT("ADC",RALONGCN,RADFN,""))
IF RADTI=""
QUIT
+18 SET RACNI=$ORDER(^RADPT("ADC",RALONGCN,RADFN,RADTI,""))
IF RACNI=""
QUIT
End DoDot:2
+19 ;if new format get data from "ADC1" x-ref
IF $LENGTH(RALONGCN,"-")=3
Begin DoDot:2
+20 SET RADTI=$ORDER(^RADPT("ADC1",RALONGCN,RADFN,""))
IF RADTI=""
QUIT
+21 SET RACNI=$ORDER(^RADPT("ADC1",RALONGCN,RADFN,RADTI,""))
IF RACNI=""
QUIT
End DoDot:2
+22 IF RADTI=""
QUIT
+23 IF RACNI=""
QUIT
+24 SET ^TMP(RARRR,$JOB,RASUB,"RADTI")=RADTI
+25 SET ^TMP(RARRR,$JOB,RASUB,"RACNI")=RACNI
End DoDot:1
+26 IF $GET(RADTI)'>0
SET RAERR="Invalid exam registration timestamp"
DO XIT
QUIT
+27 IF $GET(RACNI)'>0
SET RAERR="Invalid exam record IEN"
DO XIT
QUIT
+28 ;OBR-25/PAR(26) STATUS: 'C'orrected, 'F'inal, or 'R'esults filed, not verified
+29 IF '$LENGTH(PAR(26))
SET RAERR="Missing Report Status"
SET RAEXIT=1
QUIT
+30 IF "CFR"'[PAR(26)
SET RAERR="Invalid Report Status: "_PAR(26)
SET RAEXIT=1
QUIT
+31 SET ^TMP(RARRR,$JOB,RASUB,"RASTAT")=PAR(26)
+32 IF $PIECE(RARRR,"-",3)
GOTO 112
+33 ;OBR-32 PAR(33) Principal Result Interpreter
+34 SET RAVERF=+$GET(PAR(33))
SET RAST32=$$VFIER^RAHLRU1(.RAVERF,PAR(26),"OBR-32")
IF 'RAST32
SET RAERR=$PIECE(RAST32,"^",2)
SET RAEXIT=1
QUIT
+35 IF '$DATA(^XUSEC("RA VERIFY",RAVERF))
SET RAERR="PHYSICIAN has no RA VERIFY key"
SET RAEXIT=1
QUIT
+36 DO SR^RAHLRU1(RAVERF)
+37 IF +RASTRE=-1
SET RAERR=$PIECE(RASTRE,U,2)
SET RAEXIT=1
QUIT
+38 IF RASTRE'["^S^"
SET RAERR="PHYSICIAN must have a STAFF classification"
SET RAEXIT=1
QUIT
+39 SET ^TMP(RARRR,$JOB,RASUB,"RAVERF")=RAVERF
+40 ;ID #^family^given
SET ^TMP(RARRR,$JOB,RASUB,"RASTAFF",1)=RAVERF
SET ^("RAWHOCHANGE")=RAVERF
+41 ;OBR-33 First Interpreter of Resident type will be the Primary Interpreting staff
+42 IF $LENGTH($GET(PAR(34)))
Begin DoDot:1
+43 ;build an array of good assistants (active & the proper classification)
+44 SET RARR=0
FOR I=1:1:10
SET RARE33=$PIECE(PAR(34),HLREP,I)
IF $LENGTH(RARE33)
Begin DoDot:2
+45 DO SR^RAHLRU1(+RARE33)
IF +RASTRE=-1
QUIT
+46 ;must be a staff or res.
IF RASTRE'["^S^"
IF RASTRE'["^R^"
QUIT
+47 ;find the first resident...
+48 IF RASTRE["^R^"
IF ('($DATA(RARSDNT)#2))
SET (RARSDNT,^TMP(RARRR,$JOB,RASUB,"RARESIDENT"))=+RARE33
QUIT
+49 ; To be stored in 70.03 field 70
IF RASTRE["^R^"
SET ^TMP(RARRR,$JOB,RASUB,"RARESIDENT",I)=+RARE33
QUIT
+50 ;To be stored in 70.03 field 60
IF RASTRE["^S^"
SET ^TMP(RARRR,$JOB,RASUB,"RASTAFF",I)=+RARE33
+51 QUIT
End DoDot:2
+52 QUIT
End DoDot:1
+53 ;"OBR-35" Transcriptionist
+54 SET RATRANSC=$GET(PAR(36))
SET RATRANSC=$PIECE(RATRANSC,HLCS,4)
+55 IF RATRANSC'=""
SET RAT35=$$VFIER^RAHLRU1(.RATRANSC,PAR(26),"OBR-35")
IF 'RAT35
SET RAERR=$PIECE(RAT35,"^",2)
SET RAEXIT=1
QUIT
+56 SET ^TMP(RARRR,$JOB,RASUB,"RATRANSCRIPT")=$SELECT(RATRANSC]"":RATRANSC,$DATA(RARSDNT):RARSDNT,1:RAVERF)
+57 DO ESIG^RAHLO3
+58 ;If last OBR set provider info to all OBRs
+59 KILL RAXX
FOR I=1:1:RACNPPP
SET RAXX=RARRR_"-"_I
IF $DATA(^TMP(RAXX,$JOB,RASUB))
Begin DoDot:1
+60 NEW RAXXX
MERGE RAXXX=^TMP(RAXX,$JOB,RASUB),^TMP(RAXX,$JOB,RASUB)=^TMP(RARRR,$JOB,RASUB),^TMP(RAXX,$JOB,RASUB)=RAXXX
End DoDot:1
+61 ;
112 ;
+1 IF $DATA(RADTI)
IF $DATA(RACNI)
IF $DATA(RAPRSET(RADTI,RACNI))
KILL RAPRSET(RADTI,RACNI),^TMP(RARRR,$JOB)
SET RACNPPP=RACNPPP-1
IF $PIECE(RARRR,"-",3)
QUIT
MERGE ^TMP(RARRR,$JOB)=^TMP("RARPT-REC-"_(RACNPPP+1),$JOB)
KILL ^TMP("RARPT-REC-"_(RACNPPP+1),$JOB)
QUIT
+2 ;Get array of printset for date...
IF $DATA(RADTI)
IF '$DATA(RAPRSET(RADTI))
Begin DoDot:1
+3 NEW RAPRTSET,RACN,RASUB,CNT
+4 KILL RAXX
DO EN2^RAUTL20(.RAXX)
IF $DATA(RAXX)
MERGE RAPRSET(RADTI)=RAXX
KILL RAPRSET(RADTI,RACNI)
End DoDot:1
+5 QUIT
+6 ;
OBX ; Pick data off the 'OBX' segments
+1 ;Req: OBX-2(Value Type), OBX-3(Observ. ID), OBX-5(Observ. Value)
+2 ; OBX-11(Observ. Rslt. Status)
+3 ;
+4 ; OBX-2=CE:Coded Element, T:Text
+5 ; OBX-3=Identifier ^ Text ^ Name of Coding System ('^' is the
+6 ; component separator)
+7 ; P^PROCEDURE^L, I^IMPRESSION^L, D^DIAGNOSTIC CODE^L, M:MODIFIERS^L,
+8 ; TCM^TECH COMMENT^L, C4^CPT MODIFIERS^L, R^REPORT^L
+9 ; OBX-5=data within classification (OBX-3) by Value Type (OBX-2)
+10 ; OBX-11=F:Final Results; C:Correction, replace final results;
+11 ; R:Rslts entered-not v'fied
+12 ;
+13 ;RAOBX3 is the # of required components for OBX-3
NEW RAX
SET RAOBX3=3
+14 SET RASEG("OBX")=""
IF $GET(PAR(4))']""
SET RAERR="Missing Observation Identifier"
SET RAEXIT=1
QUIT
+15 IF $LENGTH(PAR(4),HLCS)'=RAOBX3
SET RAERR="Observation Identifier format error"
SET RAEXIT=1
QUIT
+16 ;verify OBX-3 by component (three components)
+17 ;Ex. RAOBR3(1)="P", RAOBR3(2)="PROCEDURE", RAOBR3(3)="L" always "L"
+18 FOR RAI=1:1:RAOBX3
SET RAOBX3(RAI)=$PIECE(PAR(4),HLCS,RAI)
+19 ;
+20 IF RAOBX3(3)'="L"
SET RAERR="Observation Identifier Coding System name in error"
SET RAEXIT=1
QUIT
+21 SET RASTR=""_HLCS_""
SET RASTR(0)=$PIECE(PAR(4),HLCS,1,2)
+22 ;RASTR(0)=identifer and text for this specific HL7 message
+23 ;build the identifier and text string for all possible values...
+24 FOR RAI=1:1
SET RAX=$TEXT(OBX3+RAI)
IF RAX=""
QUIT
SET RASTR=RASTR_$PIECE(RAX,";",3)_HLCS_$PIECE(RAX,";",4)_HLCS
+25 IF RASTR'[(HLCS_RASTR(0)_HLCS)
SET RAERR="Observation Identifier/Text mismatch"
QUIT
+26 ;verify the Observation Value OBX-5
+27 SET RAX=$GET(PAR(6))
SET RANODE=$SELECT(RAOBX3(1)="D":"RADX",RAOBX3(1)="I":"RAIMP",1:"RATXT")
+28 SET RARCNT(RAOBX3(1))=$GET(RARCNT(RAOBX3(1)))+1
+29 IF RAX["\S\"!(RAX["\R\")!(RAX["\E\")!(RAX["\T\")
SET RAX=$$DEESC(RAX)
+30 ; For DX Codes we are expecting only the # (ie, 1,2,5 etc not the text)
+31 ; If VR (PSCRIBE) sends text with DX Code, strip off text in next line
+32 ; Text only will be rejected
+33 IF RAOBX3(1)="D"
SET RAX=+RAX
+34 SET ^TMP("RARPT-REC",$JOB,RASUB,RANODE,RARCNT(RAOBX3(1)))=RAX
+35 FOR RAI=1:1:RACNPPP
SET RARRR="RARPT-REC-"_RAI
SET ^TMP(RARRR,$JOB,RASUB,RANODE,RARCNT(RAOBX3(1)))=RAX
+36 KILL RAOBX3,RASTR
+37 QUIT
XIT ;
+1 DO ERR
IF RAERRCHK=1
GOTO XIT1
+2 IF $DATA(^TMP("RARPT-REC",$JOB))
IF 'RACNPPP
SET RACKYES=1
DO EN1^RAHLO
DO ERR
IF RAERRCHK=1
GOTO XIT1
+3 FOR RAI=1:1:RACNPPP
SET RARRR="RARPT-REC-"_RAI
IF $DATA(^TMP(RARRR,$JOB))
Begin DoDot:1
+4 KILL ^TMP("RARPT-REC",$JOB)
MERGE ^TMP("RARPT-REC",$JOB)=^TMP(RARRR,$JOB)
KILL ^TMP(RARRR,$JOB)
+5 SET RACKYES=(RAI=RACNPPP)
NEW I
DO EN1^RAHLO
DO ERR
IF RAERRCHK=1
GOTO XIT1
End DoDot:1
XIT1 ; kill storage area for current HL7 message id
KILL ^TMP("RARPT-REC",$JOB)
+1 FOR RAI=1:1:RACNPPP
SET RARRR="RARPT-REC-"_RAI
KILL ^TMP(RARRR,$JOB)
+2 QUIT
ERR ;
+1 SET RAERRCHK=0
+2 IF $DATA(RAERR)
Begin DoDot:1
+3 SET RAEXIT=1
SET RACKYES=1
SET RAERRCHK=1
+4 DO ENX^RAHLEXF(HLDTM,RASUB)
+5 DO GENACK
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
DEESC(RASTR) ;Replace escape sequences with their field separator and escape character
+1 ;equivalents. (RAHLTCPX)
+2 ;
+3 ;input : RASTR=the string of characters being checked for esc sequences
+4 ;output: returns a string with field separator and escape characters in
+5 ; place of escape sequences
+6 ;
+7 ;RAFSESC/HLFS = field separator
+8 ;RACSESC/$E(HLECH,1) = component separator
+9 ;RARSESC/$E(HLECH,2) = repetition separator
+10 ;RAESESC/$E(HLECH,3) = escape character
+11 ;RASCESC/$E(HLECH,4) = subcomponent separator
+12 ;
+13 NEW RAFSESC,RACSESC,RARSESC,RAESESC,RASCESC
+14 SET RAFSESC="\F\"
SET RACSESC="\S\"
SET RARSESC="\R\"
SET RAESESC="\E\"
SET RASCESC="\T\"
+15 ;escape characters present? if yes, set YES to one
NEW RAYES
+16 FOR
Begin DoDot:1
+17 SET RAYES=0
+18 IF RASTR[RAFSESC
SET RASTR=$PIECE(RASTR,RAFSESC)_HLFS_$PIECE(RASTR,RAFSESC,2,99999)
SET RAYES=1
+19 IF RASTR[RACSESC
SET RASTR=$PIECE(RASTR,RACSESC)_$EXTRACT(HLECH,1)_$PIECE(RASTR,RACSESC,2,99999)
SET RAYES=1
+20 IF RASTR[RARSESC
SET RASTR=$PIECE(RASTR,RARSESC)_$EXTRACT(HLECH,2)_$PIECE(RASTR,RARSESC,2,99999)
SET RAYES=1
+21 IF RASTR[RAESESC
SET RASTR=$PIECE(RASTR,RAESESC)_$EXTRACT(HLECH,3)_$PIECE(RASTR,RAESESC,2,99999)
SET RAYES=1
+22 IF RASTR[RASCESC
SET RASTR=$PIECE(RASTR,RASCESC)_$EXTRACT(HLECH,4)_$PIECE(RASTR,RASCESC,2,99999)
SET RAYES=1
+23 QUIT
End DoDot:1
IF 'RAYES
QUIT
+24 QUIT RASTR
+25 ;
GENACK ; Compile the 'ACK' segment, generate the 'ACK' message.
+1 IF '$GET(RACKYES)
QUIT
+2 NEW HLFORMAT,HLARYTYP,RESULT
+3 SET MSA1="AA"
+4 ; Don't allow non RA namespaced interfaces
IF $EXTRACT($GET(HL("SAN")),1,3)'="RA-"
QUIT
+5 IF $DATA(RAERR)
SET MSA1=$SELECT(HL("SAN")="RA-PSCRIBE-TCP"!$GET(RATELE):"AE",1:"AR")
+6 ; Added next line to support MedSpeak interface. Must re-initialize
+7 ; FS and EC's before sending ACK.
+8 ;D:HL("SAN")="RA-CLIENT-TCP" INIT^HLFNC2("RA VOICE TCP SERVER RPT",.HL)
+9 SET HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$SELECT($DATA(RAERR):HL("FS")_RAERR,1:"")
+10 SET HLEID=HL("EID")
SET HLEIDS=HL("EIDS")
SET HLARYTYP="LM"
SET HLFORMAT=1
+11 KILL HLRESLT
DO GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.RESULT)
+12 ; RTK 3/26/2008 - UNDEFINED 'RESULT' ERROR
IF $GET(RESULT)=""
QUIT
+13 ;ERROR in gen ACK...
IF +$PIECE(RESULT,U,2)
DO ASTATUS^RAHLACK(RESULT,RASUB,HL("SAN"))
+14 QUIT
+15 ;
OBX3 ;set the values for OBX-3.1 & OBX-3.2
+1 ;;P;PROCEDURE
+2 ;;I;IMPRESSION
+3 ;;D;DIAGNOSTIC CODE
+4 ;;M;MODIFIERS
+5 ;;TCM;TECH COMMENT
+6 ;;C4;CPT MODIFIERS
+7 ;;R;REPORT
