Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (14 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLTCPB.m

    r613 r623  
    1 RAHLTCPB        ; HIRMFO/REL,GJC,BNT,PAV - Rad/Nuc Med HL7 TCP/IP Bridge;05/21/99
    2         ;;5.0;Radiology/Nuclear Medicine;**12,17,25,51,71,81,84**;Mar 16, 1998;Build 13
    3         ; 07/05/2006 BAY/KAM Remedy Call 124379 Eliminate unneeded ORM msgs
    4         ; 09/01/2006   Acomodate multiple ORC/OBR segments Patch 81
    5         ;
    6         ;Integration Agreements
    7         ;----------------------
    8         ;INIT^HLFNC2(2161); GENACK^HLMA1(2165); $$DT^XLFDT(10103)
    9         ;
    10 EN1     ; Build the ^TMP("RARPT-REC" global when we receive the
    11         ; 07/05/2006 Remedy Call 124379 message from HL7. If RAHLTCPB is defined, do not broadcast ORM messages. As of the writing
    12         ; of patch 71, RAHLTCPB is referenced in RAHLTCPB, UPSTAT^RAUTL0, & UP2^RAUTL1 Generic provider: RADIOLOGY,OUTSIDE SERVICE
    13         N RATELE,RATELENM,RATELEPI,RATELEKN,RATELEDR,RATELEDF
    14         D TELE^RAHLRPTT ;Patch 84
    15         ;** branch to new HL7 logic when the HL7 version surpasses 2.3 **
    16         I HL("VER")>2.3,($T(^RAHLTCPX))'="" GOTO EN1^RAHLTCPX
    17         S RASUB=HL("MID"),RAHLTCPB=1 K RAERR
    18         ;**********************************************
    19         ;RACN is Counter - Indication that ORC segment present
    20         N RACN,II,L,RAPRSET,RARRR,XX,RAHLD,RARSDNT,RATRSCRP S (RACN,RAPRSET)=0 ; = Address where we go to store data...
    21         ;**********************************************
    22         K ^TMP("RARPT-HL7",$J) ; clean area that holds data from HL7
    23         K ^TMP("RARPT-REC",$J,RASUB) ; kill storage area for new HL7 message id
    24         S ^TMP("RARPT-REC",$J,RASUB,"RADATE")=$$DT^XLFDT()
    25         F I=1:1 X HLNEXT Q:HLQUIT'>0  D
    26         .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)
    27         .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)
    28         S CNT=2,SEGMNT=$G(^TMP("RARPT-HL7",$J,CNT))
    29         S:'$$GETSFLAG^RAHLRU($G(HL("SAN")),$G(HL("MTN")),$G(HL("ETN")),$G(HL("VER"))) RANOSEND=$G(HL("SAN"))
    30         S ^TMP("RARPT-REC",$J,RASUB,"VENDOR")=$G(HL("SAN"))
    31 PID     ; Pick data off the 'PID' segment.
    32         I $P(SEGMNT,HL("FS"))="PID" D
    33         . S SEGMNT=$P(SEGMNT,HL("FS"),2,99999)
    34         . I $P($P(SEGMNT,HL("FS"),3),$E(HL("ECH")))]"" D
    35         .. S (^TMP("RARPT-REC",$J,RASUB,"RADFN"),RADFN)=$P($P(SEGMNT,HL("FS"),3),$E(HL("ECH")))
    36         .. Q
    37         . I $P(SEGMNT,HL("FS"),19)]"" D
    38         .. S ^TMP("RARPT-REC",$J,RASUB,"RASSN")=$P(SEGMNT,HL("FS"),19)
    39         .. Q
    40         . Q
    41         E  S RAERR="Missing PID segment" D XIT Q
    42         I '(+$G(^TMP("RARPT-REC",$J,RASUB,"RADFN"))) D  Q
    43         .S RAERR="Invalid Patient ID"
    44         .D XIT
    45         ; Save off E-Sig information (if it exists)
    46         S:$D(HL("ESIG")) ^TMP("RARPT-REC",$J,RASUB,"RAESIG")=HL("ESIG")
    47         ;********************************
    48 ORC     ; Pick data off the 'ORC' segment.
    49         D
    50         .N CNT1 S CNT1=CNT,RARRR=""
    51 111     .K SEGMNT S CNT1=$O(^TMP("RARPT-HL7",$J,CNT1)) Q:CNT1=""  S SEGMNT=$G(^(CNT1))
    52         .I $P(SEGMNT,HL("FS"))="PV1" S CNT=CNT1 G 111
    53         .Q:$P(SEGMNT,HL("FS"))'="ORC"
    54         .S CNT=CNT1 Q:$P(SEGMNT,HL("FS"),2)'="CN"  ; find the 'ORC' segment
    55         .S RACN=RACN+1,RARRR="RARPT-REC-"_RACN
    56         ;********************************
    57 OBR     ; Pick data off the 'OBR' segment.
    58         I $L(RARRR) K ^TMP(RARRR,$J) M ^TMP(RARRR,$J)=^TMP("RARPT-REC",$J) ;Merge if OBR without Report
    59         S:'$L(RARRR) RARRR="RARPT-REC"
    60         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
    61         I $P($G(SEGMNT),HL("FS"))'="OBR" S RAERR="Missing OBR segment" D XIT Q
    62         S SEGMNT=$P(SEGMNT,HL("FS"),2,99999) K RADTI,RACNI
    63         I $P(SEGMNT,HL("FS"),3)]"" D
    64         . N RADTCN S RADTCN=$P(SEGMNT,HL("FS"),3)
    65         . S:$P($P(RADTCN,$E(HL("ECH"))),"-")]"" (^TMP(RARRR,$J,RASUB,"RADTI"),RADTI)=$P($P(RADTCN,$E(HL("ECH"))),"-")
    66         . S:$P($P(RADTCN,$E(HL("ECH"))),"-",2)]"" (^TMP(RARRR,$J,RASUB,"RACNI"),RACNI)=$P($P(RADTCN,$E(HL("ECH"))),"-",2)
    67         . S:$P(RADTCN,$E(HL("ECH")),2)["&L" RADTCN=$TR(RADTCN,"&","^")
    68         . S:$P(RADTCN,$E(HL("ECH")),2)]"" ^TMP(RARRR,$J,RASUB,"RALONGCN")=$P(RADTCN,$E(HL("ECH")),2)
    69         . Q
    70         I $G(RADTI)'>0 S RAERR="Invalid exam registration timestamp" D XIT Q
    71         I $G(RACNI)'>0 S RAERR="Invalid exam record IEN" D XIT Q
    72         S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,25,HL("FS")) K RAHL70
    73         I RAHLD="" S RAERR="Missing Report Status" D XIT Q
    74         I "AFR"'[RAHLD S RAERR="Invalid Report Status: "_RAHLD D XIT Q
    75         S ^TMP(RARRR,$J,RASUB,"RASTAT")=RAHLD
    76         G:$P(RARRR,"-",3) 112 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,32,HL("FS")) K RAHL70
    77         I RAHLD']"" S RAERR="Missing Provider ID" D XIT Q
    78         S RAVERF=RAHLD
    79         ; -----   Check the validity of the provider name   -----
    80         I '$D(^VA(200,"B",RAVERF)) D  ; check for a partial match in file 200
    81         . D VFIER^RAHLO3 ; if one partial match found, return the entry ien
    82         E  D  ; $D(^VA(200,"B",RAVERF)) true, get the entry ien
    83         . S RAVERF=$O(^VA(200,"B",RAVERF,0))
    84         . S:'RAVERF RAERR="Invalid Provider Name: "_RAHLD
    85         ; can't get resident info from medspeak
    86         S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,33,HL("FS")),RARSDNT="" K RAHL70
    87         I RAHLD]"" D
    88         . S RARSDNT=$P(RAHLD,$E(HL("ECH"),4)) I '$D(^VA(200,+RARSDNT,0)) S RARSDNT=""
    89         S RAHLD="",RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,35,HL("FS")),RATRSCRP="" K RAHL70
    90         I RAHLD]"" D
    91         . S RATRSCRP=$P(RAHLD,$E(HL("ECH"),4)) I '$D(^VA(200,+RATRSCRP,0)) S RATRSCRP=""
    92         S ^TMP(RARRR,$J,RASUB,"RAVERF")=RAVERF
    93         S ^TMP(RARRR,$J,RASUB,"RATRANSCRIPT")=$S(RATRSCRP]"":RATRSCRP,RARSDNT]"":RARSDNT,1:RAVERF)
    94         S:$G(RARSDNT) ^TMP(RARRR,$J,RASUB,"RARESIDENT")=RARSDNT
    95         S ^TMP(RARRR,$J,RASUB,"RASTAFF")=RAVERF,^("RAWHOCHANGE")=RAVERF
    96         I $D(RAERR) D XIT Q
    97         D ESIG^RAHLO3
    98         ;
    99         ;If last OBR set provider info to all OBRs
    100         K XX F I=1:1:RACN S XX=RARRR_"-"_I D:$D(^TMP(XX,$J,RASUB))
    101         .N XXX M XXX=^TMP(XX,$J,RASUB),^TMP(XX,$J,RASUB)=^TMP(RARRR,$J,RASUB),^TMP(XX,$J,RASUB)=XXX
    102 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
    103         I $D(RADTI),'$D(RAPRSET(RADTI)) D  ;Get array of printset for date...
    104         .N RAPRTSET,RACN,RASUB,CNT
    105         .K XX D EN2^RAUTL20(.XX) M:$D(XX) RAPRSET(RADTI)=XX K RAPRSET(RADTI,RACNI)
    106         ;
    107 OBX     ; Pick data off the 'OBX' segments
    108         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
    109         . S SEGMNT=$P(SEGMNT,HL("FS"),2,9999)
    110         . Q:SEGMNT?@("1"""_HL("FS")_"""."""_HL("FS")_"""")  ;Quit if OBX is something as:    OBX||||||||
    111         . I $P(SEGMNT,HL("FS"),3)']"" S RAERR="Missing Observation Identifier" Q
    112         . S OBXTYP=$P($P(SEGMNT,HL("FS"),3),$E(HL("ECH"))),OBXTYP=$E($P(OBXTYP,"&",2))
    113         . S OBX2CE=""
    114         . S:OBXTYP="" OBXTYP=" "
    115         . I OBXTYP=" "&($P(SEGMNT,HL("FS"),2)="CE") D
    116         . . I $P(SEGMNT,HL("FS"),5)=" " S OBXTYP="F" Q
    117         . . S OBX2CE=1,OBXTYP="D" Q
    118         . I "IDRF"'[OBXTYP S RAERR="Invalid Observation Identifier" Q
    119         . D RPT Q
    120 XIT     ; RACKYES  Indicates that Ack will be sent on the last OBR segment or at Error condition.
    121         N RACKYES
    122         I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK G XIT1
    123         I $D(^TMP("RARPT-REC",$J)) S:'RACN RACKYES=1 D  G:$D(RAERR) XIT1
    124         .N RACN D EN1^RAHLO I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK
    125         F II=1:1:RACN S RARRR="RARPT-REC-"_II D:$D(^TMP(RARRR,$J))  Q:$D(RAERR)
    126         .K ^TMP("RARPT-REC",$J) M ^TMP("RARPT-REC",$J)=^TMP(RARRR,$J) K ^TMP(RARRR,$J)
    127         .S RACKYES=(II=RACN) N II,RACN D EN1^RAHLO I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK
    128 XIT1    K ^TMP("RARPT-REC",$J) ; kill storage area for current HL7 message id
    129         F II=1:1:RACN S RARRR="RARPT-REC-"_II K:$D(^TMP(RARRR,$J)) ^TMP(RARRR,$J)
    130         K ^TMP("RARPT-HL7",$J) ; clean up HL7 storage
    131         K CNT,OBXTYP,X1,LIN,RADATE,RADTCN,RAERR,RAESIG,RAHLD,RAHLTCPB,RANODE,RARCNT
    132         K RAVERF,RASUB,SEGMNT,RANOSEND,MSA1,OBX2CE,RADX,RADX1,RADX2,RADX3
    133         Q
    134 RPT     ; Save off Report Text data.
    135         N RAXADEDN
    136         S RAXADEDN=^TMP("RARPT-REC",$J,RASUB,"RASTAT")
    137         S RANODE=$S(OBXTYP="D":"RADX",OBXTYP="I":"RAIMP",1:"RATXT"),LIN=""
    138         I OBX2CE D  Q
    139         . S X=$P(SEGMNT,HL("FS"),5),RADX1=$P(X,$E(HL("ECH")))
    140         . S LIN=RADX1,L=999 D P2 S LIN=X
    141         . Q:X'["~"  F J=0:0 S J=$O(^TMP("RARPT-HL7",$J,CNT,J)) Q:'J  S X1=^(J),LIN=LIN_X1 Q
    142         . S RADX=LIN,RADX2=$P($P(RADX,"~",2),"^") S:RADX2]"" LIN=RADX2 D P2
    143         . S RADX3=$P($P(RADX,"~",3),"^") Q:RADX3']""  S LIN=RADX3 D P2 Q
    144         S X=$P(SEGMNT,HL("FS"),5)
    145         I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT
    146         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
    147         D PAR
    148         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
    149         I X=""!(LIN'="") S L=999 D P2
    150         Q
    151         ;
    152 PAR     ; Build text paragraph
    153         S LIN=LIN_X
    154 P1      I $L(LIN)<80 Q
    155         F L=80:-1:1 Q:$E(LIN,L)=" "
    156         D P2 S LIN=$E(LIN,L+1,999) G P1
    157 P2      ; Set node
    158         ; If Addendum and Report text is a space don't process
    159         I $P(SEGMNT,HL("FS"),1)=1,RAXADEDN="A",RANODE="RATXT",$E(LIN,1,L-1)=" " Q
    160         S RARCNT(OBXTYP)=$G(RARCNT(OBXTYP))+1
    161         S ^TMP("RARPT-REC",$J,RASUB,RANODE,RARCNT(OBXTYP))=$E(LIN,1,L-1)
    162         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)
    163         Q
    164         ;
    165 GENACK  ; Compile the 'ACK' segment, generate the 'ACK' message.
    166         Q:'$G(RACKYES)
    167         S MSA1="AA"
    168         Q:$E($G(HL("SAN")),1,3)'="RA-"  ; Don't allow non RA namespaced interfaces
    169         I $D(RAERR) S MSA1=$S($G(HL("SAN"))="RA-PSCRIBE-TCP"!$G(RATELE):"AE",1:"AR")
    170         ; Added next line to support MedSpeak interface.  Must re-initialize
    171         ; FS and EC's before sending ACK.
    172         D:$G(HL("SAN"))="RA-CLIENT-TCP" INIT^HLFNC2("RA VOICE TCP SERVER RPT",.HL)
    173         S HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$S($D(RAERR):HL("FS")_RAERR,1:"")
    174         ; 06/22/2006 KAM CHANGED NEXT TWO LINES FOR RA*5*71
    175         S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1
    176         K HLRESLT D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT)
    177         Q
    178         ;
    179 FORMAT  ; Format report text for Escape Character delimited codes.
    180         S Y=X N T,Q
    181         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
    182         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
    183         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
    184         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
    185         I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT
    186         Q
    187         ;
     1RAHLTCPB ; HIRMFO/REL,GJC,BNT,PAV - Rad/Nuc Med HL7 TCP/IP Bridge;05/21/99
     2 ;;5.0;Radiology/Nuclear Medicine;**12,17,25,51,71,81**;Mar 16, 1998;Build 12
     3 ; 07/05/2006 BAY/KAM Remedy Call 124379 Eliminate unneeded ORM msgs
     4 ; 09/01/2006   Acomodate multiplr ORC/OBR segments Patch 81
     5EN1 ; Build the ^TMP("RARPT-REC" global when we receive the
     6 ; 07/05/2006 Remedy Call 124379 message from HL7. If RAHLTCPB is defined, do not broadcast ORM messages. As of the writing
     7 ; of patch 71, RAHLTCPB is referenced in RAHLTCPB, UPSTAT^RAUTL0, & UP2^RAUTL1
     8 ;G:$G(HL("VER"))]"2.3" EN1^RAHLTCPX
     9 S RASUB=HL("MID"),RAHLTCPB=1 K RAERR
     10 ;**********************************************
     11 ;RACN is Counter - Indication that ORC segment present
     12 N RACN,II,L,RAPRSET,RARRR,XX,RAHLD,RARSDNT,RATRSCRP S (RACN,RAPRSET)=0 ; = Address where we go to store data...
     13 ;**********************************************
     14 K ^TMP("RARPT-HL7",$J) ; clean area that holds data from HL7
     15 K ^TMP("RARPT-REC",$J,RASUB) ; kill storage area for new HL7 message id
     16 S ^TMP("RARPT-REC",$J,RASUB,"RADATE")=$$DT^XLFDT()
     17 F I=1:1 X HLNEXT Q:HLQUIT'>0  D
     18 .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)
     19 .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)
     20 S CNT=2,SEGMNT=$G(^TMP("RARPT-HL7",$J,CNT))
     21 S:'$$GETSFLAG^RAHLRU($G(HL("SAN")),$G(HL("MTN")),$G(HL("ETN")),$G(HL("VER"))) RANOSEND=$G(HL("SAN"))
     22 S ^TMP("RARPT-REC",$J,RASUB,"VENDOR")=$G(HL("SAN"))
     23PID ; Pick data off the 'PID' segment.
     24 I $P(SEGMNT,HL("FS"))="PID" D
     25 . S SEGMNT=$P(SEGMNT,HL("FS"),2,99999)
     26 . I $P($P(SEGMNT,HL("FS"),3),$E(HL("ECH")))]"" D
     27 .. S (^TMP("RARPT-REC",$J,RASUB,"RADFN"),RADFN)=$P($P(SEGMNT,HL("FS"),3),$E(HL("ECH")))
     28 .. Q
     29 . I $P(SEGMNT,HL("FS"),19)]"" D
     30 .. S ^TMP("RARPT-REC",$J,RASUB,"RASSN")=$P(SEGMNT,HL("FS"),19)
     31 .. Q
     32 . Q
     33 E  S RAERR="Missing PID segment" D XIT Q
     34 I '(+$G(^TMP("RARPT-REC",$J,RASUB,"RADFN"))) D  Q
     35 .S RAERR="Invalid Patient ID"
     36 .D XIT
     37 ; Save off E-Sig information (if it exists)
     38 S:$D(HL("ESIG")) ^TMP("RARPT-REC",$J,RASUB,"RAESIG")=HL("ESIG")
     39 ;********************************
     40ORC ; Pick data off the 'ORC' segment.
     41 D
     42 .N CNT1 S CNT1=CNT,RARRR=""
     43111 .K SEGMNT S CNT1=$O(^TMP("RARPT-HL7",$J,CNT1)) Q:CNT1=""  S SEGMNT=$G(^(CNT1))
     44 .I $P(SEGMNT,HL("FS"))="PV1" S CNT=CNT1 G 111
     45 .Q:$P(SEGMNT,HL("FS"))'="ORC"
     46 .S CNT=CNT1 Q:$P(SEGMNT,HL("FS"),2)'="CN"  ; find the 'ORC' segment
     47 .S RACN=RACN+1,RARRR="RARPT-REC-"_RACN
     48 ;********************************
     49OBR ; Pick data off the 'OBR' segment.
     50 I $L(RARRR) K ^TMP(RARRR,$J) M ^TMP(RARRR,$J)=^TMP("RARPT-REC",$J) ;Merge if OBR without Report
     51 S:'$L(RARRR) RARRR="RARPT-REC"
     52 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
     53 I $P($G(SEGMNT),HL("FS"))'="OBR" S RAERR="Missing OBR segment" D XIT Q
     54 S SEGMNT=$P(SEGMNT,HL("FS"),2,99999) K RADTI,RACNI
     55 I $P(SEGMNT,HL("FS"),3)]"" D
     56 . N RADTCN S RADTCN=$P(SEGMNT,HL("FS"),3)
     57 . S:$P($P(RADTCN,$E(HL("ECH"))),"-")]"" (^TMP(RARRR,$J,RASUB,"RADTI"),RADTI)=$P($P(RADTCN,$E(HL("ECH"))),"-")
     58 . S:$P($P(RADTCN,$E(HL("ECH"))),"-",2)]"" (^TMP(RARRR,$J,RASUB,"RACNI"),RACNI)=$P($P(RADTCN,$E(HL("ECH"))),"-",2)
     59 . S:$P(RADTCN,$E(HL("ECH")),2)["&L" RADTCN=$TR(RADTCN,"&","^")
     60 . S:$P(RADTCN,$E(HL("ECH")),2)]"" ^TMP(RARRR,$J,RASUB,"RALONGCN")=$P(RADTCN,$E(HL("ECH")),2)
     61 . Q
     62 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,25,HL("FS")) K RAHL70
     63 I RAHLD="" S RAERR="Missing Report Status" D XIT Q
     64 I "AFR"'[RAHLD S RAERR="Invalid Report Status" D XIT Q
     65 S ^TMP(RARRR,$J,RASUB,"RASTAT")=RAHLD
     66 G:$P(RARRR,"-",3) 112 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,32,HL("FS")) K RAHL70
     67 I RAHLD']"" S RAERR="Missing Provider ID" D XIT Q
     68 S RAVERF=RAHLD
     69 ; -----   Check the validity of the provider name   -----
     70 I '$D(^VA(200,"B",RAVERF)) D  ; check for a partial match in file 200
     71 . D VFIER^RAHLO3 ; if one partial match found, return the entry ien
     72 E  D  ; $D(^VA(200,"B",RAVERF)) true, get the entry ien
     73 . S RAVERF=$O(^VA(200,"B",RAVERF,0))
     74 . S:'RAVERF RAERR="Invalid Provider Name"
     75 ; can't get resident info from medspeak
     76 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,33,HL("FS")),RARSDNT="" K RAHL70
     77 I RAHLD]"" D
     78 . S RARSDNT=$P(RAHLD,$E(HL("ECH"),4)) I '$D(^VA(200,+RARSDNT,0)) S RARSDNT=""
     79 S RAHLD="",RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,35,HL("FS")),RATRSCRP="" K RAHL70
     80 I RAHLD]"" D
     81 . S RATRSCRP=$P(RAHLD,$E(HL("ECH"),4)) I '$D(^VA(200,+RATRSCRP,0)) S RATRSCRP=""
     82 S ^TMP(RARRR,$J,RASUB,"RAVERF")=RAVERF
     83 S ^TMP(RARRR,$J,RASUB,"RATRANSCRIPT")=$S(RATRSCRP]"":RATRSCRP,RARSDNT]"":RARSDNT,1:RAVERF)
     84 S:$G(RARSDNT) ^TMP(RARRR,$J,RASUB,"RARESIDENT")=RARSDNT
     85 S ^TMP(RARRR,$J,RASUB,"RASTAFF")=RAVERF,^("RAWHOCHANGE")=RAVERF
     86 I $D(RAERR) D XIT Q
     87 D ESIG^RAHLO3
     88 ;If last OBR set provider info to all OBRs
     89 K XX F I=1:1:RACN S XX=RARRR_"-"_I D:$D(^TMP(XX,$J,RASUB))
     90 .N XXX M XXX=^TMP(XX,$J,RASUB),^TMP(XX,$J,RASUB)=^TMP(RARRR,$J,RASUB),^TMP(XX,$J,RASUB)=XXX
     91112 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
     92 I $D(RADTI),'$D(RAPRSET(RADTI)) D  ;Get array of printset for date...
     93 .N RAPRTSET,RACN,RASUB,CNT
     94 .K XX D EN2^RAUTL20(.XX) M:$D(XX) RAPRSET(RADTI)=XX K RAPRSET(RADTI,RACNI)
     95 ;
     96OBX ; Pick data off the 'OBX' segments
     97 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
     98 . S SEGMNT=$P(SEGMNT,HL("FS"),2,9999)
     99 . Q:SEGMNT?@("1"""_HL("FS")_"""."""_HL("FS")_"""")  ;Quit if OBX is something as:    OBX||||||||
     100 . I $P(SEGMNT,HL("FS"),3)']"" S RAERR="Missing Observation Identifier" Q
     101 . S OBXTYP=$P(SEGMNT,HL("FS"),3),OBXTYP=$E(OBXTYP,$F(OBXTYP,"&"))
     102 . S OBX2CE=""
     103 . S:OBXTYP="" OBXTYP=" "
     104 . I OBXTYP=" "&($P(SEGMNT,HL("FS"),2)="CE") D
     105 . . I $P(SEGMNT,HL("FS"),5)=" " S OBXTYP="F" Q
     106 . . S OBX2CE=1,OBXTYP="D" Q
     107 . I "IDRF"'[OBXTYP S RAERR="Invalid Observation Identifier" Q
     108 . D RPT Q
     109XIT ; RACKYES  Indicates that Ack will be sent on the last OBR segment or at Error condition.
     110 N RACKYES
     111 I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK G XIT1
     112 I $D(^TMP("RARPT-REC",$J)) S:'RACN RACKYES=1 D  G:$D(RAERR) XIT1
     113 .N RACN D EN1^RAHLO I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK
     114 F II=1:1:RACN S RARRR="RARPT-REC-"_II D:$D(^TMP(RARRR,$J))  Q:$D(RAERR)
     115 .K ^TMP("RARPT-REC",$J) M ^TMP("RARPT-REC",$J)=^TMP(RARRR,$J) K ^TMP(RARRR,$J)
     116 .S RACKYES=(II=RACN) N II,RACN D EN1^RAHLO I $D(RAERR) S RACKYES=1 D EN1^RAHLEXF,GENACK
     117XIT1 K ^TMP("RARPT-REC",$J) ; kill storage area for current HL7 message id
     118 F II=1:1:RACN S RARRR="RARPT-REC-"_II K:$D(^TMP(RARRR,$J)) ^TMP(RARRR,$J)
     119 K ^TMP("RARPT-HL7",$J) ; clean up HL7 storage
     120 K CNT,OBXTYP,X1,LIN,RADATE,RADTCN,RAERR,RAESIG,RAHLD,RAHLTCPB,RANODE,RARCNT
     121 K RAVERF,RASUB,SEGMNT,RANOSEND,MSA1,OBX2CE,RADX,RADX1,RADX2,RADX3
     122 Q
     123RPT ; Save off Report Text data.
     124 N RAXADEDN
     125 S RAXADEDN=^TMP("RARPT-REC",$J,RASUB,"RASTAT")
     126 S RANODE=$S(OBXTYP="D":"RADX",OBXTYP="I":"RAIMP",1:"RATXT"),LIN=""
     127 I OBX2CE D  Q
     128 . S X=$P(SEGMNT,HL("FS"),5),RADX1=$P(X,$E(HL("ECH")))
     129 . S LIN=RADX1,L=999 D P2 S LIN=X
     130 . Q:X'["~"  F J=0:0 S J=$O(^TMP("RARPT-HL7",$J,CNT,J)) Q:'J  S X1=^(J),LIN=LIN_X1 Q
     131 . S RADX=LIN,RADX2=$P($P(RADX,"~",2),"^") S:RADX2]"" LIN=RADX2 D P2
     132 . S RADX3=$P($P(RADX,"~",3),"^") Q:RADX3']""  S LIN=RADX3 D P2 Q
     133 S X=$P(SEGMNT,HL("FS"),5)
     134 I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT
     135 D PAR
     136 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
     137 I X=""!(LIN'="") S L=999 D P2
     138 Q
     139FORMAT ; Format report text for Escape Character delimited codes.
     140 S Y=X N T,Q
     141 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
     142 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
     143 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
     144 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
     145 I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT
     146 Q
     147PAR ; Build text paragraph
     148 S LIN=LIN_X
     149P1 I $L(LIN)<80 Q
     150 F L=80:-1:1 Q:$E(LIN,L)=" "
     151 D P2 S LIN=$E(LIN,L+1,999) G P1
     152P2 ; Set node
     153 ; If Addendum and Report text is a space don't process
     154 I $P(SEGMNT,HL("FS"),1)=1,RAXADEDN="A",RANODE="RATXT",$E(LIN,1,L-1)=" " Q
     155 S RARCNT(OBXTYP)=$G(RARCNT(OBXTYP))+1
     156 S ^TMP("RARPT-REC",$J,RASUB,RANODE,RARCNT(OBXTYP))=$E(LIN,1,L-1)
     157 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)
     158 Q
     159 ;
     160GENACK ; Compile the 'ACK' segment, generate the 'ACK' message.
     161 Q:'$G(RACKYES)
     162 S MSA1="AA"
     163 Q:$E($G(HL("SAN")),1,3)'="RA-"  ; Don't allow non RA namespaced interfaces
     164 I $D(RAERR) S MSA1=$S($G(HL("SAN"))="RA-PSCRIBE-TCP":"AE",1:"AR")
     165 ; Added next line to support MedSpeak interface.  Must re-initialize
     166 ; FS and EC's before sending ACK.
     167 D:$G(HL("SAN"))="RA-CLIENT-TCP" INIT^HLFNC2("RA VOICE TCP SERVER RPT",.HL)
     168 S HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$S($D(RAERR):HL("FS")_RAERR,1:"")
     169 ; 06/22/2006 KAM CHANGED NEXT TWO LINES FOR RA*5*71
     170 S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1
     171 K HLRESLT D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT)
     172 Q
Note: See TracChangeset for help on using the changeset viewer.