Routine: RAHLTCPX

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

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")

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

MSH ;

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

PV1 ;Ignored at this time.

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

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)

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

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)

ERR ;

 S RAERRCHK=0

 I $D(RAERR) D

 .S RAEXIT=1,RACKYES=1,RAERRCHK=1

 .D ENX^RAHLEXF(HLDTM,RASUB)

 .D GENACK

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

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

RAHLTCPX.m