Routine: RAHLTCPB

RAHLTCPB ; HIRMFO/REL,GJC,BNT,PAV - Rad/Nuc Med HL7 TCP/IP Bridge;05/21/99 ;17 Apr 2019 3:25 PM

 ;;5.0;Radiology/Nuclear Medicine;**12,17,25,51,71,81,84,106,157**;Mar 16, 1998;Build 2

 ; 07/05/2006 BAY/KAM Remedy Call 124379 Eliminate unneeded ORM msgs

 ; 09/01/2006   Accomodate multiple ORC/OBR segments Patch 81

 ;Integration Agreements

 ;----------------------

 ;INIT^HLFNC2(2161); GENACK^HLMA1(2165); $$DT^XLFDT(10103)

EN1 ; Build the ^TMP("RARPT-REC" global when we receive the

 ; 07/05/2006 Remedy Call 124379 message from HL7. If RAHLTCPB is defined, do not broadcast ORM messages. As of the writing

 ; of patch 71, RAHLTCPB is referenced in RAHLTCPB, UPSTAT^RAUTL0, & UP2^RAUTL1 Generic provider: RADIOLOGY,OUTSIDE SERVICE

 N RATELE,RATELENM,RATELEPI,RATELEKN,RATELEDR,RATELEDF

 D TELE^RAHLRPTT ;Patch 84

 ;** branch to new HL7 logic when the HL7 version surpasses 2.3 **

 I HL("VER")>2.3,($T(^RAHLTCPX))'="" GOTO EN1^RAHLTCPX

 S RASUB=HL("MID"),RAHLTCPB=1 K RAERR

 ;**********************************************

 ;RACN is Counter - Indication that ORC segment present

 N RACN,II,L,RAPRSET,RARRR,XX,RAHLD,RARSDNT,RATRSCRP S (RACN,RAPRSET)=0 ; = Address where we go to store data...

 ;**********************************************

 K ^TMP("RARPT-HL7",$J) ; clean area that holds data from HL7

 K ^TMP("RARPT-REC",$J,RASUB) ; kill storage area for new HL7 message id

 S ^TMP("RARPT-REC",$J,RASUB,"RADATE")=$$DT^XLFDT()

 F I=1:1 X HLNEXT Q:HLQUIT'>0  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)

 .S ^TMP("RARPT-HL7",$J,I)=HLNODE,J=0 F  S J=$O(HLNODE(J)) Q:'J  S ^TMP("RARPT-HL7",$J,I,J)=HLNODE(J)

 S CNT=2,SEGMNT=$G(^TMP("RARPT-HL7",$J,CNT))

 S:'$$GETSFLAG^RAHLRU($G(HL("SAN")),$G(HL("MTN")),$G(HL("ETN")),$G(HL("VER"))) RANOSEND=$G(HL("SAN"))

 S ^TMP("RARPT-REC",$J,RASUB,"VENDOR")=$G(HL("SAN"))

PID ; Pick data off the 'PID' segment.

 I $P(SEGMNT,HL("FS"))="PID" D

 . S SEGMNT=$P(SEGMNT,HL("FS"),2,99999)

 . I $P($P(SEGMNT,HL("FS"),3),$E(HL("ECH")))]"" D

 .. S (^TMP("RARPT-REC",$J,RASUB,"RADFN"),RADFN)=$P($P(SEGMNT,HL("FS"),3),$E(HL("ECH")))

 .. Q

 . I $P(SEGMNT,HL("FS"),19)]"" D

 .. S ^TMP("RARPT-REC",$J,RASUB,"RASSN")=$P(SEGMNT,HL("FS"),19)

 .. Q

. Q

 E  S RAERR="Missing PID segment" D XIT Q

 I '(+$G(^TMP("RARPT-REC",$J,RASUB,"RADFN"))) D  Q

 .S RAERR="Invalid Patient ID"

 .D XIT

 ; Save off E-Sig information (if it exists)

 S:$D(HL("ESIG")) ^TMP("RARPT-REC",$J,RASUB,"RAESIG")=HL("ESIG")

 ;********************************

ORC ; Pick data off the 'ORC' segment.

 .N CNT1 S CNT1=CNT,RARRR=""

111 .K SEGMNT S CNT1=$O(^TMP("RARPT-HL7",$J,CNT1)) Q:CNT1=""  S SEGMNT=$G(^(CNT1))

 .I $P(SEGMNT,HL("FS"))="PV1" S CNT=CNT1 G 111

 .Q:$P(SEGMNT,HL("FS"))'="ORC"

 .S CNT=CNT1 Q:$P(SEGMNT,HL("FS"),2)'="CN"  ; find the 'ORC' segment

 .S RACN=RACN+1,RARRR="RARPT-REC-"_RACN

 ;********************************

OBR ; Pick data off the 'OBR' segment.

 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"

 K SEGMNT F  S CNT=$O(^TMP("RARPT-HL7",$J,CNT)) Q:CNT=""  S SEGMNT=$G(^(CNT)) Q:$P(SEGMNT,HL("FS"))="OBR"  ; find the 'OBR' segment

 I $P($G(SEGMNT),HL("FS"))'="OBR" S RAERR="Missing OBR segment" D XIT Q

 S SEGMNT=$P(SEGMNT,HL("FS"),2,99999) K RADTI,RACNI

 I $P(SEGMNT,HL("FS"),3)]"" D

 . N RADTCN S RADTCN=$P(SEGMNT,HL("FS"),3)

 . S:$P($P(RADTCN,$E(HL("ECH"))),"-")]"" (^TMP(RARRR,$J,RASUB,"RADTI"),RADTI)=$P($P(RADTCN,$E(HL("ECH"))),"-")

 . S:$P($P(RADTCN,$E(HL("ECH"))),"-",2)]"" (^TMP(RARRR,$J,RASUB,"RACNI"),RACNI)=$P($P(RADTCN,$E(HL("ECH"))),"-",2)

 . S:$P(RADTCN,$E(HL("ECH")),2)["&L" RADTCN=$TR(RADTCN,"&","^")

 . S:$P(RADTCN,$E(HL("ECH")),2)]"" ^TMP(RARRR,$J,RASUB,"RALONGCN")=$P(RADTCN,$E(HL("ECH")),2)

. Q

 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

 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,25,HL("FS")) K RAHL70

 I RAHLD="" S RAERR="Missing Report Status" D XIT Q

 ;P106

 I "^A^F^R^VAQ^"'[("^"_RAHLD_"^") D  D XIT Q

 .S RAERR="Invalid Report Status: "_RAHLD QUIT

 S ^TMP(RARRR,$J,RASUB,"RASTAT")=RAHLD

 G:$P(RARRR,"-",3) 112 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,32,HL("FS")) K RAHL70

 I RAHLD']"" S RAERR="Missing Provider ID" D XIT Q

 S RAVERF=RAHLD

 ; -----   Check the validity of the provider name   -----

 I '$D(^VA(200,"B",RAVERF)) D  ; check for a partial match in file 200

 . D VFIER^RAHLO3 ; if one partial match found, return the entry ien

 E  D  ; $D(^VA(200,"B",RAVERF)) true, get the entry ien

 . S RAVERF=$O(^VA(200,"B",RAVERF,0))

 . S:'RAVERF RAERR="Invalid Provider Name: "_RAHLD

 ; can't get resident info from medspeak

 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,33,HL("FS")),RARSDNT="" K RAHL70

 I RAHLD]"" D

 . S RARSDNT=$P(RAHLD,$E(HL("ECH"),4)) I '$D(^VA(200,+RARSDNT,0)) S RARSDNT=""

 S RAHLD="",RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,35,HL("FS")),RATRSCRP="" K RAHL70

 I RAHLD]"" D

 . S RATRSCRP=$P(RAHLD,$E(HL("ECH"),4)) I '$D(^VA(200,+RATRSCRP,0)) S RATRSCRP=""

 S ^TMP(RARRR,$J,RASUB,"RAVERF")=RAVERF

 S ^TMP(RARRR,$J,RASUB,"RATRANSCRIPT")=$S(RATRSCRP]"":RATRSCRP,RARSDNT]"":RARSDNT,1:RAVERF)

 S:$G(RARSDNT) ^TMP(RARRR,$J,RASUB,"RARESIDENT")=RARSDNT

 S ^TMP(RARRR,$J,RASUB,"RASTAFF")=RAVERF,^("RAWHOCHANGE")=RAVERF

 I $D(RAERR) D XIT Q

 D ESIG^RAHLO3

 ;If last OBR set provider info to all OBRs

 K XX F I=1:1:RACN S XX=RARRR_"-"_I D:$D(^TMP(XX,$J,RASUB))

 .N XXX M XXX=^TMP(XX,$J,RASUB),^TMP(XX,$J,RASUB)=^TMP(RARRR,$J,RASUB),^TMP(XX,$J,RASUB)=XXX

112 I $D(RADTI),$D(RACNI),$D(RAPRSET(RADTI,RACNI)) K RAPRSET(RADTI,RACNI),^TMP(RARRR,$J) S RACN=RACN-1 G:$P(RARRR,"-",3) ORC M ^TMP(RARRR,$J)=^TMP("RARPT-REC-"_(RACN+1),$J) K ^TMP("RARPT-REC-"_(RACN+1),$J) G OBX

 I $D(RADTI),'$D(RAPRSET(RADTI)) D  ;Get array of printset for date...

 .N RAPRTSET,RACN,RASUB,CNT

 .K XX D EN2^RAUTL20(.XX) M:$D(XX) RAPRSET(RADTI)=XX K RAPRSET(RADTI,RACNI)

OBX ; Pick data off the 'OBX' segments

 K SEGMNT F  S CNT=$O(^TMP("RARPT-HL7",$J,CNT)) Q:CNT=""  S SEGMNT=$G(^(CNT)) D:$P(SEGMNT,HL("FS"))="OBX"  Q:$D(RAERR)  I $P(SEGMNT,HL("FS"))="ORC" S CNT=CNT-1 G ORC

 . S SEGMNT=$P(SEGMNT,HL("FS"),2,9999)

 . Q:SEGMNT?@("1"""_HL("FS")_"""."""_HL("FS")_"""")  ;Quit if OBX is something as:    OBX||||||||

 . I $P(SEGMNT,HL("FS"),3)']"" S RAERR="Missing Observation Identifier" Q

 . S OBXTYP=$P($P(SEGMNT,HL("FS"),3),$E(HL("ECH"))),OBXTYP=$E($P(OBXTYP,"&",2))

 . S OBX2CE=""

 . S:OBXTYP="" OBXTYP=" "

 . I OBXTYP=" "&($P(SEGMNT,HL("FS"),2)="CE") D

 . . I $P(SEGMNT,HL("FS"),5)=" " S OBXTYP="F" Q

 . . S OBX2CE=1,OBXTYP="D" Q

 . I "IDRF"'[OBXTYP S RAERR="Invalid Observation Identifier" Q

 . D RPT Q

XIT ; RACKYES  Indicates that Ack will be sent on the last OBR segment or at Error condition.

 N RACKYES

 I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK G XIT1

 I $D(^TMP("RARPT-REC",$J)) S:'RACN RACKYES=1 D  G:$D(RAERR) XIT1

 .N RACN D EN1^RAHLO I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK

 F II=1:1:RACN S RARRR="RARPT-REC-"_II D:$D(^TMP(RARRR,$J))  Q:$D(RAERR)

 .K ^TMP("RARPT-REC",$J) M ^TMP("RARPT-REC",$J)=^TMP(RARRR,$J) K ^TMP(RARRR,$J)

 .S RACKYES=(II=RACN) N II,RACN D EN1^RAHLO I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK

XIT1 K ^TMP("RARPT-REC",$J) ; kill storage area for current HL7 message id

 F II=1:1:RACN S RARRR="RARPT-REC-"_II K:$D(^TMP(RARRR,$J)) ^TMP(RARRR,$J)

 K ^TMP("RARPT-HL7",$J) ; clean up HL7 storage

 K CNT,OBXTYP,X1,LIN,RADATE,RADTCN,RAERR,RAESIG,RAHLD,RAHLTCPB,RANODE,RARCNT

 K RAVERF,RASUB,SEGMNT,RANOSEND,MSA1,OBX2CE,RADX,RADX1,RADX2,RADX3

RPT ; Save off Report Text data.

 N RAXADEDN

 S RAXADEDN=^TMP("RARPT-REC",$J,RASUB,"RASTAT")

 S RANODE=$S(OBXTYP="D":"RADX",OBXTYP="I":"RAIMP",1:"RATXT"),LIN=""

 I OBX2CE D  Q

 . ; KLM/p157 update DX Code processing for v2.3 to accomodate VR passing a primary designation.

 . ; We will need to set LIN (RADX,RADX2,RADX3)to the entire dx code passed (ie 1^NORMAL^P).

 . S X=$P(SEGMNT,HL("FS"),5),RADX1=$P(X,$E(HL("ECH"),2))

 . S LIN=RADX1,L=999 D P2 S LIN=X

 . Q:X'["~"  F J=0:0 S J=$O(^TMP("RARPT-HL7",$J,CNT,J)) Q:'J  S X1=^(J),LIN=LIN_X1 Q

 . S RADX=LIN,RADX2=$P(RADX,"~",2) S:RADX2]"" LIN=RADX2 D P2 ;p157

 . S RADX3=$P(RADX,"~",3) Q:RADX3']""  S LIN=RADX3 D P2 Q  ;p157

 S X=$P(SEGMNT,HL("FS"),5)

 I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT

 I $G(RATELE),$D(RATELEKN),X[RATELEKN S X=$P(X,RATELEKN,2),RATELENM=$P(X,"-"),RATELEPI=$TR($P(X,"-",2)," ","") ;SFVAMC/DAD/9-7-2007/Comment out the quit Q  ;Patch 84

 D PAR

 F J=0:0 S J=$O(^TMP("RARPT-HL7",$J,CNT,J)) Q:'J  S X1=^(J),X=$E(X1,1,125) D PAR I $L(X1)>125 S X=$E(X1,126,999) D PAR

 I X=""!(LIN'="") S L=999 D P2

PAR ; Build text paragraph

 S LIN=LIN_X

P1 I $L(LIN)<80 Q

 F L=80:-1:1 Q:$E(LIN,L)=" "

 D P2 S LIN=$E(LIN,L+1,999) G P1

P2 ; Set node

 ; If Addendum and Report text is a space don't process

 I $P(SEGMNT,HL("FS"),1)=1,RAXADEDN="A",RANODE="RATXT",$E(LIN,1,L-1)=" " Q

 S RARCNT(OBXTYP)=$G(RARCNT(OBXTYP))+1

 ;KLM/p157 Setting "PDX" node for the Primary indicator (to be used in RAHLO2)

 I RANODE="RADX" D

 . I $P($G(LIN),"^",3)="P" S ^TMP("RARPT-REC",$J,RASUB,RANODE,"PDX",RARCNT(OBXTYP))=+LIN

 . S LIN=+LIN

. Q

 S ^TMP("RARPT-REC",$J,RASUB,RANODE,RARCNT(OBXTYP))=$E(LIN,1,L-1)

 F I=1:1:RACN S RARRR="RARPT-REC-"_I S:$D(^TMP(RARRR,$J)) ^TMP(RARRR,$J,RASUB,RANODE,RARCNT(OBXTYP))=$E(LIN,1,L-1)

GENACK ; Compile the 'ACK' segment, generate the 'ACK' message.

 Q:'$G(RACKYES)

 S MSA1="AA"

 Q:$E($G(HL("SAN")),1,3)'="RA-"  ; Don't allow non RA namespaced interfaces

 I $D(RAERR) S MSA1=$S($G(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:$G(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:"")

 ; 06/22/2006 KAM CHANGED NEXT TWO LINES FOR RA*5*71

 S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1

 K HLRESLT D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT)

FORMAT ; Format report text for Escape Character delimited codes.

 S Y=X N T,Q

 I Y["\S\" S Q=$F(Y,"\S\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"))_$E(Y,Q,$L(X)),Y=X

 I Y["\R\" S Q=$F(Y,"\R\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),2)_$E(Y,Q,$L(X)),Y=X

 I Y["\E\" S Q=$F(Y,"\E\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),3)_$E(Y,Q,$L(X)),Y=X

 I Y["\T\" S Q=$F(Y,"\T\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),4)_$E(Y,Q,$L(X)),Y=X

 I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAHLTCPB   10668     printed  Feb 19, 2025@00:01:55                                                                                                                                                                                                   Page 2

RAHLTCPB  ; HIRMFO/REL,GJC,BNT,PAV - Rad/Nuc Med HL7 TCP/IP Bridge;05/21/99 ;17 Apr 2019 3:25 PM

 +1       ;;5.0;Radiology/Nuclear Medicine;**12,17,25,51,71,81,84,106,157**;Mar 16, 1998;Build 2

 +2       ; 07/05/2006 BAY/KAM Remedy Call 124379 Eliminate unneeded ORM msgs

 +3       ; 09/01/2006   Accomodate multiple ORC/OBR segments Patch 81

 +4       ;

 +5       ;Integration Agreements

 +6       ;----------------------

 +7       ;INIT^HLFNC2(2161); GENACK^HLMA1(2165); $$DT^XLFDT(10103)

 +8       ;

EN1       ; Build the ^TMP("RARPT-REC" global when we receive the

 +1       ; 07/05/2006 Remedy Call 124379 message from HL7. If RAHLTCPB is defined, do not broadcast ORM messages. As of the writing

 +2       ; of patch 71, RAHLTCPB is referenced in RAHLTCPB, UPSTAT^RAUTL0, & UP2^RAUTL1 Generic provider: RADIOLOGY,OUTSIDE SERVICE

 +3        NEW RATELE,RATELENM,RATELEPI,RATELEKN,RATELEDR,RATELEDF

 +4       ;Patch 84

           DO TELE^RAHLRPTT

 +5       ;** branch to new HL7 logic when the HL7 version surpasses 2.3 **

 +6        IF HL("VER")>2.3

               IF ($TEXT(^RAHLTCPX))'=""

                   GOTO EN1^RAHLTCPX

 +7        SET RASUB=HL("MID")

           SET RAHLTCPB=1

           KILL RAERR

 +8       ;**********************************************

 +9       ;RACN is Counter - Indication that ORC segment present

 +10      ; = Address where we go to store data...

           NEW RACN,II,L,RAPRSET,RARRR,XX,RAHLD,RARSDNT,RATRSCRP

           SET (RACN,RAPRSET)=0

 +11      ;**********************************************

 +12      ; clean area that holds data from HL7

           KILL ^TMP("RARPT-HL7",$JOB)

 +13      ; kill storage area for new HL7 message id

           KILL ^TMP("RARPT-REC",$JOB,RASUB)

 +14       SET ^TMP("RARPT-REC",$JOB,RASUB,"RADATE")=$$DT^XLFDT()

 +15       FOR I=1:1

               XECUTE HLNEXT

               if HLQUIT'>0

                   QUIT

               Begin DoDot:1

 +16               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)

 +17               SET ^TMP("RARPT-HL7",$JOB,I)=HLNODE

                   SET J=0

FOR

                       SET J=$ORDER(HLNODE(J))

                       if 'J

                           QUIT

                       SET ^TMP("RARPT-HL7",$JOB,I,J)=HLNODE(J)

               End DoDot:1

 +18       SET CNT=2

           SET SEGMNT=$GET(^TMP("RARPT-HL7",$JOB,CNT))

 +19       if '$$GETSFLAG^RAHLRU($GET(HL("SAN")),$GET(HL("MTN")),$GET(HL("ETN")),$GET(HL("VER")))

               SET RANOSEND=$GET(HL("SAN"))

 +20       SET ^TMP("RARPT-REC",$JOB,RASUB,"VENDOR")=$GET(HL("SAN"))

PID       ; Pick data off the 'PID' segment.

 +1        IF $PIECE(SEGMNT,HL("FS"))="PID"

               Begin DoDot:1

 +2                SET SEGMNT=$PIECE(SEGMNT,HL("FS"),2,99999)

 +3                IF $PIECE($PIECE(SEGMNT,HL("FS"),3),$EXTRACT(HL("ECH")))]""

                       Begin DoDot:2

 +4                        SET (^TMP("RARPT-REC",$JOB,RASUB,"RADFN"),RADFN)=$PIECE($PIECE(SEGMNT,HL("FS"),3),$EXTRACT(HL("ECH")))

 +5                        QUIT

                       End DoDot:2

 +6                IF $PIECE(SEGMNT,HL("FS"),19)]""

                       Begin DoDot:2

 +7                        SET ^TMP("RARPT-REC",$JOB,RASUB,"RASSN")=$PIECE(SEGMNT,HL("FS"),19)

 +8                        QUIT

                       End DoDot:2

 +9                QUIT

               End DoDot:1

 +10      IF '$TEST

               SET RAERR="Missing PID segment"

               DO XIT

               QUIT

 +11       IF '(+$GET(^TMP("RARPT-REC",$JOB,RASUB,"RADFN")))

               Begin DoDot:1

 +12               SET RAERR="Invalid Patient ID"

 +13               DO XIT

               End DoDot:1

               QUIT

 +14      ; Save off E-Sig information (if it exists)

 +15       if $DATA(HL("ESIG"))

               SET ^TMP("RARPT-REC",$JOB,RASUB,"RAESIG")=HL("ESIG")

 +16      ;********************************

ORC       ; Pick data off the 'ORC' segment.

 +1        Begin DoDot:1

 +2            NEW CNT1

               SET CNT1=CNT

               SET RARRR=""

111            KILL SEGMNT

               SET CNT1=$ORDER(^TMP("RARPT-HL7",$JOB,CNT1))

               if CNT1=""

                   QUIT

               SET SEGMNT=$GET(^(CNT1))

 +1            IF $PIECE(SEGMNT,HL("FS"))="PV1"

                   SET CNT=CNT1

                   GOTO 111

 +2            if $PIECE(SEGMNT,HL("FS"))'="ORC"

                   QUIT

 +3       ; find the 'ORC' segment

               SET CNT=CNT1

               if $PIECE(SEGMNT,HL("FS"),2)'="CN"

                   QUIT

 +4            SET RACN=RACN+1

               SET RARRR="RARPT-REC-"_RACN

           End DoDot:1

 +5       ;********************************

OBR       ; Pick data off the 'OBR' segment.

 +1       ;Merge if OBR without Report

           IF $LENGTH(RARRR)

               KILL ^TMP(RARRR,$JOB)

               MERGE ^TMP(RARRR,$JOB)=^TMP("RARPT-REC",$JOB)

 +2        if '$LENGTH(RARRR)

               SET RARRR="RARPT-REC"

 +3       ; find the 'OBR' segment

           KILL SEGMNT

FOR

               SET CNT=$ORDER(^TMP("RARPT-HL7",$JOB,CNT))

               if CNT=""

                   QUIT

               SET SEGMNT=$GET(^(CNT))

               if $PIECE(SEGMNT,HL("FS"))="OBR"

                   QUIT

 +4        IF $PIECE($GET(SEGMNT),HL("FS"))'="OBR"

               SET RAERR="Missing OBR segment"

               DO XIT

               QUIT

 +5        SET SEGMNT=$PIECE(SEGMNT,HL("FS"),2,99999)

           KILL RADTI,RACNI

 +6        IF $PIECE(SEGMNT,HL("FS"),3)]""

               Begin DoDot:1

 +7                NEW RADTCN

                   SET RADTCN=$PIECE(SEGMNT,HL("FS"),3)

 +8                if $PIECE($PIECE(RADTCN,$EXTRACT(HL("ECH"))),"-")]""

                       SET (^TMP(RARRR,$JOB,RASUB,"RADTI"),RADTI)=$PIECE($PIECE(RADTCN,$EXTRACT(HL("ECH"))),"-")

 +9                if $PIECE($PIECE(RADTCN,$EXTRACT(HL("ECH"))),"-",2)]""

                       SET (^TMP(RARRR,$JOB,RASUB,"RACNI"),RACNI)=$PIECE($PIECE(RADTCN,$EXTRACT(HL("ECH"))),"-",2)

 +10               if $PIECE(RADTCN,$EXTRACT(HL("ECH")),2)["&L"

                       SET RADTCN=$TRANSLATE(RADTCN,"&","^")

 +11               if $PIECE(RADTCN,$EXTRACT(HL("ECH")),2)]""

                       SET ^TMP(RARRR,$JOB,RASUB,"RALONGCN")=$PIECE(RADTCN,$EXTRACT(HL("ECH")),2)

 +12               QUIT

               End DoDot:1

 +13       IF $GET(RADTI)'>0

               SET RAERR="Invalid exam registration timestamp"

               DO XIT

               QUIT

 +14       IF $GET(RACNI)'>0

               SET RAERR="Invalid exam record IEN"

               DO XIT

               QUIT

 +15       SET RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,25,HL("FS"))

           KILL RAHL70

 +16       IF RAHLD=""

               SET RAERR="Missing Report Status"

               DO XIT

               QUIT

 +17      ;P106

 +18       IF "^A^F^R^VAQ^"'[("^"_RAHLD_"^")

               Begin DoDot:1

 +19               SET RAERR="Invalid Report Status: "_RAHLD

                   QUIT

               End DoDot:1

               DO XIT

               QUIT

 +20      ;

 +21       SET ^TMP(RARRR,$JOB,RASUB,"RASTAT")=RAHLD

 +22       if $PIECE(RARRR,"-",3)

               GOTO 112

           SET RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,32,HL("FS"))

           KILL RAHL70

 +23       IF RAHLD']""

               SET RAERR="Missing Provider ID"

               DO XIT

               QUIT

 +24       SET RAVERF=RAHLD

 +25      ; -----   Check the validity of the provider name   -----

 +26      ; check for a partial match in file 200

           IF '$DATA(^VA(200,"B",RAVERF))

               Begin DoDot:1

 +27      ; if one partial match found, return the entry ien

                   DO VFIER^RAHLO3

               End DoDot:1

 +28      ; $D(^VA(200,"B",RAVERF)) true, get the entry ien

          IF '$TEST

               Begin DoDot:1

 +29               SET RAVERF=$ORDER(^VA(200,"B",RAVERF,0))

 +30               if 'RAVERF

                       SET RAERR="Invalid Provider Name: "_RAHLD

               End DoDot:1

 +31      ; can't get resident info from medspeak

 +32       SET RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,33,HL("FS"))

           SET RARSDNT=""

           KILL RAHL70

 +33       IF RAHLD]""

               Begin DoDot:1

 +34               SET RARSDNT=$PIECE(RAHLD,$EXTRACT(HL("ECH"),4))

                   IF '$DATA(^VA(200,+RARSDNT,0))

                       SET RARSDNT=""

               End DoDot:1

 +35       SET RAHLD=""

           SET RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,35,HL("FS"))

           SET RATRSCRP=""

           KILL RAHL70

 +36       IF RAHLD]""

               Begin DoDot:1

 +37               SET RATRSCRP=$PIECE(RAHLD,$EXTRACT(HL("ECH"),4))

                   IF '$DATA(^VA(200,+RATRSCRP,0))

                       SET RATRSCRP=""

               End DoDot:1

 +38       SET ^TMP(RARRR,$JOB,RASUB,"RAVERF")=RAVERF

 +39       SET ^TMP(RARRR,$JOB,RASUB,"RATRANSCRIPT")=$SELECT(RATRSCRP]"":RATRSCRP,RARSDNT]"":RARSDNT,1:RAVERF)

 +40       if $GET(RARSDNT)

               SET ^TMP(RARRR,$JOB,RASUB,"RARESIDENT")=RARSDNT

 +41       SET ^TMP(RARRR,$JOB,RASUB,"RASTAFF")=RAVERF

           SET ^("RAWHOCHANGE")=RAVERF

 +42       IF $DATA(RAERR)

               DO XIT

               QUIT

 +43       DO ESIG^RAHLO3

 +44      ;

 +45      ;If last OBR set provider info to all OBRs

 +46       KILL XX

           FOR I=1:1:RACN

               SET XX=RARRR_"-"_I

               if $DATA(^TMP(XX,$JOB,RASUB))

                   Begin DoDot:1

 +47                   NEW XXX

                       MERGE XXX=^TMP(XX,$JOB,RASUB),^TMP(XX,$JOB,RASUB)=^TMP(RARRR,$JOB,RASUB),^TMP(XX,$JOB,RASUB)=XXX

                   End DoDot:1

112        IF $DATA(RADTI)

               IF $DATA(RACNI)

                   IF $DATA(RAPRSET(RADTI,RACNI))

                       KILL RAPRSET(RADTI,RACNI),^TMP(RARRR,$JOB)

                       SET RACN=RACN-1

                       if $PIECE(RARRR,"-",3)

                           GOTO ORC

                       MERGE ^TMP(RARRR,$JOB)=^TMP("RARPT-REC-"_(RACN+1),$JOB)

                       KILL ^TMP("RARPT-REC-"_(RACN+1),$JOB)

                       GOTO OBX

 +1       ;Get array of printset for date...

           IF $DATA(RADTI)

               IF '$DATA(RAPRSET(RADTI))

                   Begin DoDot:1

 +2                    NEW RAPRTSET,RACN,RASUB,CNT

 +3                    KILL XX

                       DO EN2^RAUTL20(.XX)

                       if $DATA(XX)

                           MERGE RAPRSET(RADTI)=XX

                       KILL RAPRSET(RADTI,RACNI)

                   End DoDot:1

 +4       ;

OBX       ; Pick data off the 'OBX' segments

 +1        KILL SEGMNT

FOR

               SET CNT=$ORDER(^TMP("RARPT-HL7",$JOB,CNT))

               if CNT=""

                   QUIT

               SET SEGMNT=$GET(^(CNT))

               if $PIECE(SEGMNT,HL("FS"))="OBX"

                   Begin DoDot:1

 +2                    SET SEGMNT=$PIECE(SEGMNT,HL("FS"),2,9999)

 +3       ;Quit if OBX is something as:    OBX||||||||

                       if SEGMNT?@("1"""_HL("FS")_"""."""_HL("FS")_"""")

                           QUIT

 +4                    IF $PIECE(SEGMNT,HL("FS"),3)']""

                           SET RAERR="Missing Observation Identifier"

                           QUIT

 +5                    SET OBXTYP=$PIECE($PIECE(SEGMNT,HL("FS"),3),$EXTRACT(HL("ECH")))

                       SET OBXTYP=$EXTRACT($PIECE(OBXTYP,"&",2))

 +6                    SET OBX2CE=""

 +7                    if OBXTYP=""

                           SET OBXTYP=" "

 +8                    IF OBXTYP=" "&($PIECE(SEGMNT,HL("FS"),2)="CE")

                           Begin DoDot:2

 +9                            IF $PIECE(SEGMNT,HL("FS"),5)=" "

                                   SET OBXTYP="F"

                                   QUIT

 +10                           SET OBX2CE=1

                               SET OBXTYP="D"

                               QUIT

                           End DoDot:2

 +11                   IF "IDRF"'[OBXTYP

                           SET RAERR="Invalid Observation Identifier"

                           QUIT

 +12                   DO RPT

                       QUIT

                   End DoDot:1

               if $DATA(RAERR)

                   QUIT

               IF $PIECE(SEGMNT,HL("FS"))="ORC"

                   SET CNT=CNT-1

                   GOTO ORC

XIT       ; RACKYES  Indicates that Ack will be sent on the last OBR segment or at Error condition.

 +1        NEW RACKYES

 +2        IF $DATA(RAERR)

               SET RACKYES=1

               DO EN1^RAHLEXF

               DO GENACK

               GOTO XIT1

 +3        IF $DATA(^TMP("RARPT-REC",$JOB))

               if 'RACN

                   SET RACKYES=1

               Begin DoDot:1

 +4                NEW RACN

                   DO EN1^RAHLO

                   IF $DATA(RAERR)

                       SET RACKYES=1

                       DO EN1^RAHLEXF

                       DO GENACK

               End DoDot:1

               if $DATA(RAERR)

                   GOTO XIT1

 +5        FOR II=1:1:RACN

               SET RARRR="RARPT-REC-"_II

               if $DATA(^TMP(RARRR,$JOB))

                   Begin DoDot:1

 +6                    KILL ^TMP("RARPT-REC",$JOB)

                       MERGE ^TMP("RARPT-REC",$JOB)=^TMP(RARRR,$JOB)

                       KILL ^TMP(RARRR,$JOB)

 +7                    SET RACKYES=(II=RACN)

                       NEW II,RACN

                       DO EN1^RAHLO

                       IF $DATA(RAERR)

                           SET RACKYES=1

                           DO EN1^RAHLEXF

                           DO GENACK

                   End DoDot:1

               if $DATA(RAERR)

                   QUIT

XIT1      ; kill storage area for current HL7 message id

           KILL ^TMP("RARPT-REC",$JOB)

 +1        FOR II=1:1:RACN

               SET RARRR="RARPT-REC-"_II

               if $DATA(^TMP(RARRR,$JOB))

                   KILL ^TMP(RARRR,$JOB)

 +2       ; clean up HL7 storage

           KILL ^TMP("RARPT-HL7",$JOB)

 +3        KILL CNT,OBXTYP,X1,LIN,RADATE,RADTCN,RAERR,RAESIG,RAHLD,RAHLTCPB,RANODE,RARCNT

 +4        KILL RAVERF,RASUB,SEGMNT,RANOSEND,MSA1,OBX2CE,RADX,RADX1,RADX2,RADX3

 +5        QUIT

RPT       ; Save off Report Text data.

 +1        NEW RAXADEDN

 +2        SET RAXADEDN=^TMP("RARPT-REC",$JOB,RASUB,"RASTAT")

 +3        SET RANODE=$SELECT(OBXTYP="D":"RADX",OBXTYP="I":"RAIMP",1:"RATXT")

           SET LIN=""

 +4        IF OBX2CE

               Begin DoDot:1

 +5       ; KLM/p157 update DX Code processing for v2.3 to accomodate VR passing a primary designation.

 +6       ; We will need to set LIN (RADX,RADX2,RADX3)to the entire dx code passed (ie 1^NORMAL^P).

 +7                SET X=$PIECE(SEGMNT,HL("FS"),5)

                   SET RADX1=$PIECE(X,$EXTRACT(HL("ECH"),2))

 +8                SET LIN=RADX1

                   SET L=999

                   DO P2

                   SET LIN=X

 +9                if X'["~"

                       QUIT

                   FOR J=0:0

                       SET J=$ORDER(^TMP("RARPT-HL7",$JOB,CNT,J))

                       if 'J

                           QUIT

                       SET X1=^(J)

                       SET LIN=LIN_X1

                       QUIT

 +10      ;p157

                   SET RADX=LIN

                   SET RADX2=$PIECE(RADX,"~",2)

                   if RADX2]""

                       SET LIN=RADX2

                   DO P2

 +11      ;p157

                   SET RADX3=$PIECE(RADX,"~",3)

                   if RADX3']""

                       QUIT

                   SET LIN=RADX3

                   DO P2

                   QUIT

               End DoDot:1

               QUIT

 +12       SET X=$PIECE(SEGMNT,HL("FS"),5)

 +13       IF X["\S\"!(X["\R\")!(X["\E\")!(X["\T\")

               DO FORMAT

 +14      ;SFVAMC/DAD/9-7-2007/Comment out the quit Q  ;Patch 84

           IF $GET(RATELE)

               IF $DATA(RATELEKN)

                   IF X[RATELEKN

                       SET X=$PIECE(X,RATELEKN,2)

                       SET RATELENM=$PIECE(X,"-")

                       SET RATELEPI=$TRANSLATE($PIECE(X,"-",2)," ","")

 +15       DO PAR

 +16       FOR J=0:0

               SET J=$ORDER(^TMP("RARPT-HL7",$JOB,CNT,J))

               if 'J

                   QUIT

               SET X1=^(J)

               SET X=$EXTRACT(X1,1,125)

               DO PAR

               IF $LENGTH(X1)>125

                   SET X=$EXTRACT(X1,126,999)

                   DO PAR

 +17       IF X=""!(LIN'="")

               SET L=999

               DO P2

 +18       QUIT

 +19      ;

PAR       ; Build text paragraph

 +1        SET LIN=LIN_X

P1         IF $LENGTH(LIN)<80

               QUIT

 +1        FOR L=80:-1:1

               if $EXTRACT(LIN,L)=" "

                   QUIT

 +2        DO P2

           SET LIN=$EXTRACT(LIN,L+1,999)

           GOTO P1

P2        ; Set node

 +1       ; If Addendum and Report text is a space don't process

 +2        IF $PIECE(SEGMNT,HL("FS"),1)=1

               IF RAXADEDN="A"

                   IF RANODE="RATXT"

                       IF $EXTRACT(LIN,1,L-1)=" "

                           QUIT

 +3        SET RARCNT(OBXTYP)=$GET(RARCNT(OBXTYP))+1

 +4       ;KLM/p157 Setting "PDX" node for the Primary indicator (to be used in RAHLO2)

 +5        IF RANODE="RADX"

               Begin DoDot:1

 +6                IF $PIECE($GET(LIN),"^",3)="P"

                       SET ^TMP("RARPT-REC",$JOB,RASUB,RANODE,"PDX",RARCNT(OBXTYP))=+LIN

 +7                SET LIN=+LIN

 +8                QUIT

               End DoDot:1

 +9        SET ^TMP("RARPT-REC",$JOB,RASUB,RANODE,RARCNT(OBXTYP))=$EXTRACT(LIN,1,L-1)

 +10       FOR I=1:1:RACN

               SET RARRR="RARPT-REC-"_I

               if $DATA(^TMP(RARRR,$JOB))

                   SET ^TMP(RARRR,$JOB,RASUB,RANODE,RARCNT(OBXTYP))=$EXTRACT(LIN,1,L-1)

 +11       QUIT

 +12      ;

GENACK    ; Compile the 'ACK' segment, generate the 'ACK' message.

 +1        if '$GET(RACKYES)

               QUIT

 +2        SET MSA1="AA"

 +3       ; Don't allow non RA namespaced interfaces

           if $EXTRACT($GET(HL("SAN")),1,3)'="RA-"

               QUIT

 +4        IF $DATA(RAERR)

               SET MSA1=$SELECT($GET(HL("SAN"))="RA-PSCRIBE-TCP"!$GET(RATELE):"AE",1:"AR")

 +5       ; Added next line to support MedSpeak interface.  Must re-initialize

 +6       ; FS and EC's before sending ACK.

 +7        if $GET(HL("SAN"))="RA-CLIENT-TCP"

               DO INIT^HLFNC2("RA VOICE TCP SERVER RPT",.HL)

 +8        SET HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$SELECT($DATA(RAERR):HL("FS")_RAERR,1:"")

 +9       ; 06/22/2006 KAM CHANGED NEXT TWO LINES FOR RA*5*71

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

 +12       QUIT

 +13      ;

FORMAT    ; Format report text for Escape Character delimited codes.

 +1        SET Y=X

           NEW T,Q

 +2        IF Y["\S\"

               SET Q=$FIND(Y,"\S\")

               SET T=Q-4

               SET X=$EXTRACT(Y,1,T)_$EXTRACT(HL("ECH"))_$EXTRACT(Y,Q,$LENGTH(X))

               SET Y=X

 +3        IF Y["\R\"

               SET Q=$FIND(Y,"\R\")

               SET T=Q-4

               SET X=$EXTRACT(Y,1,T)_$EXTRACT(HL("ECH"),2)_$EXTRACT(Y,Q,$LENGTH(X))

               SET Y=X

 +4        IF Y["\E\"

               SET Q=$FIND(Y,"\E\")

               SET T=Q-4

               SET X=$EXTRACT(Y,1,T)_$EXTRACT(HL("ECH"),3)_$EXTRACT(Y,Q,$LENGTH(X))

               SET Y=X

 +5        IF Y["\T\"

               SET Q=$FIND(Y,"\T\")

               SET T=Q-4

               SET X=$EXTRACT(Y,1,T)_$EXTRACT(HL("ECH"),4)_$EXTRACT(Y,Q,$LENGTH(X))

               SET Y=X

 +6        IF X["\S\"!(X["\R\")!(X["\E\")!(X["\T\")

               DO FORMAT

 +7        QUIT

 +8       ;

RAHLTCPB.m