RAHLBMS.m

RAHLBMS ;HIRMFO/REL,GJC-Bridge, MedSpeak compatible to HL7 v1.6 ;11/18/97  12:12

 ;;5.0;Radiology/Nuclear Medicine;**4**;Mar 16, 1998

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

 ; message from HL7.

 S RASUB=HL("MID") K RAERR

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

 S ^TMP("RARPT-REC",$J,RASUB,"VENDOR")="IBM/MEDSPEAK"

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

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

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

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

 ;

OBR ; Pick data off the 'OBR' segment.

 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)

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

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

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

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

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

 . Q

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

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

 I "AFR"'[RAHLD S RAERR="Invalid Report Status" D XIT Q

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

 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 ; if one partial match found, return the entry ien

 . Q

 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"

 . Q

 I $D(RAERR) D XIT Q

 ; can't get resident info from medspeak

 S ^TMP("RARPT-REC",$J,RASUB,"RAVERF")=RAVERF,^("RATRANSCRIPT")=RAVERF,^("RASTAFF")=RAVERF,^("RAWHOCHANGE")=RAVERF

 ;

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)

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

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

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

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

 . D RPT Q

XIT ; Clean up environment, quit

 D INIT^HLFNC2("RA VOICE TCP SERVER RPT",.HL) ;field separators must be cleared and reset prior to sending ACK to prevent mixed/wrong separators in ACK

 I $D(RAERR) D GENACK G XIT1

 I $D(^TMP("RARPT-REC",$J)) D EN1^RAHLO I $D(RAERR) D GENACK

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

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

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

 K RAVERF,RASUB,SEGMNT

 Q

RPT ; Save off Report Text data.

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

 S X=$P(SEGMNT,HL("FS"),5) 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

 Q

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

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

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

 ;

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

 S HLA("HLA",1)="MSA"_HL("FS")_$S($D(RAERR):"AR",1:"AA")_HL("FS")_HL("MID")_$S($D(RAERR):HL("FS")_RAERR,1:"")

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

 D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.HLRESTLA)

 Q

VFIER ; Check if the RAVERF string is a partial match to an entry in file

 ; 200.  If if is, check to see that is a partial match to only ONE

 ; active provider entry in file 200.

 I '$L(RAVERF) S RAERR="Missing Provider information" Q

 K RAVCNT,RAVIEN,RAVLGTH,RAVPS

 S RAVLGTH=$L(RAVERF) ; length of the RAVERF string

 S RAVCNT=0,RAVS1=RAVERF

 F  S RAVS1=$O(^VA(200,"B",RAVS1)) Q:RAVS1=""!($E(RAVS1,1,RAVLGTH)'=RAVERF)  D  Q:RAVCNT>1

 . ; return subscripts that have the RAVERF string as the first

 . ; 1 - RAVLGTH chars of RAVS1

 . S RAVIEN=0

 . F  S RAVIEN=$O(^VA(200,"B",RAVS1,RAVIEN)) Q:RAVIEN'>0  D  Q:RAVCNT>1

 .. S RAVPS=$G(^VA(200,RAVIEN,"PS"))

 .. S:'$P(RAVPS,"^",4)!($P(RAVPS,"^",4)>DT) RAVCNT=RAVCNT+1

 .. I RAVCNT=1,('$D(RAVIEN(RAVCNT))#2) S RAVIEN(RAVCNT)=RAVIEN ; when

 .. ; we find the first active provider save the provider ien off

 .. ; in a local array.

 .. Q

 . Q

 I RAVCNT=0 S RAERR="Invalid Provider Name" Q  ; partial match not found

 I RAVCNT>1 S RAERR="Non-Unique Provider Name" Q  ; >1 partial match

 S RAVERF=$G(RAVIEN(1)) S:'RAVERF RAERR="Provider Name Entry Error"

 K RAVCNT,RAVIEN,RAVLGTH,RAVPS

 Q

RAHLBMS   ;HIRMFO/REL,GJC-Bridge, MedSpeak compatible to HL7 v1.6 ;11/18/97  12:12

 +1       ;;5.0;Radiology/Nuclear Medicine;**4**;Mar 16, 1998

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

 +1       ; message from HL7.

 +2        SET RASUB=HL("MID")

           KILL RAERR

 +3       ; clean area that holds data from HL7

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

 +4       ; kill storage area for new HL7 message id

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

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

 +6        SET ^TMP("RARPT-REC",$JOB,RASUB,"VENDOR")="IBM/MEDSPEAK"

 +7        FOR I=1:1

               XECUTE HLNEXT

               IF HLQUIT'>0

                   QUIT 

               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)

 +8        SET CNT=2

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

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")=$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      ; Save off E-Sig information (if it exists)

 +12       IF $DATA(HL("ESIG"))

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

 +13      ;

OBR       ; Pick data off the 'OBR' segment.

 +1       ; 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 

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

               SET RAERR="Missing OBR segment"

               DO XIT

               QUIT 

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

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

               Begin DoDot:1

 +5                NEW RADTCN

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

 +6                IF $PIECE($PIECE(RADTCN,$EXTRACT(HL("ECH"))),"-")]""

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

 +7                IF $PIECE($PIECE(RADTCN,$EXTRACT(HL("ECH"))),"-",2)]""

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

 +8                IF $PIECE(RADTCN,$EXTRACT(HL("ECH")),2)]""

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

 +9                QUIT 

               End DoDot:1

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

           KILL RAHL70

 +11       IF RAHLD=""

               SET RAERR="Missing Report Status"

               DO XIT

               QUIT 

 +12       IF "AFR"'[RAHLD

               SET RAERR="Invalid Report Status"

               DO XIT

               QUIT 

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

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

           KILL RAHL70

 +15       IF RAHLD']""

               SET RAERR="Missing Provider ID"

               DO XIT

               QUIT 

 +16       SET RAVERF=RAHLD

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

 +18      ; check for a partial match in file 200

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

               Begin DoDot:1

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

                   DO VFIER

 +20               QUIT 

               End DoDot:1

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

          IF '$TEST

               Begin DoDot:1

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

 +23               IF 'RAVERF

                       SET RAERR="Invalid Provider Name"

 +24               QUIT 

               End DoDot:1

 +25       IF $DATA(RAERR)

               DO XIT

               QUIT 

 +26      ; can't get resident info from medspeak

 +27       SET ^TMP("RARPT-REC",$JOB,RASUB,"RAVERF")=RAVERF

           SET ^("RATRANSCRIPT")=RAVERF

           SET ^("RASTAFF")=RAVERF

           SET ^("RAWHOCHANGE")=RAVERF

 +28      ;

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                    IF $PIECE(SEGMNT,HL("FS"),3)']""

                           SET RAERR="Missing Observation Identifier"

                           QUIT 

 +4                    SET OBXTYP=$PIECE(SEGMNT,HL("FS"),3)

                       SET OBXTYP=$EXTRACT(OBXTYP,$FIND(OBXTYP,"&"))

                       IF OBXTYP=""

                           SET OBXTYP=" "

 +5                    IF "IDR"'[OBXTYP

                           SET RAERR="Invalid Observation Identifier"

                           QUIT 

 +6                    DO RPT

                       QUIT 

                   End DoDot:1

               IF $DATA(RAERR)

                   QUIT 

XIT       ; Clean up environment, quit

 +1       ;field separators must be cleared and reset prior to sending ACK to prevent mixed/wrong separators in ACK

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

 +2        IF $DATA(RAERR)

               DO GENACK

               GOTO XIT1

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

               DO EN1^RAHLO

               IF $DATA(RAERR)

                   DO GENACK

XIT1      ; kill storage area for current HL7 message id

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

 +1       ; clean up HL7 storage

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

 +2        KILL CNT,OBXTYPE,X1,LIN,RADATE,RADTCN,RAERR,RAESIG,RAHLD,RANODE,RARCNT

 +3        KILL RAVERF,RASUB,SEGMNT

 +4        QUIT 

RPT       ; Save off Report Text data.

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

           SET LIN=""

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

           DO PAR

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

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

               SET L=999

               DO P2

 +5        QUIT 

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        SET RARCNT(OBXTYP)=$GET(RARCNT(OBXTYP))+1

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

           QUIT 

 +3       ;

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

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

 +2        SET HLEID=HL("EID")

           SET HLEIDS=HL("EIDS")

           SET HLARYTYP="LM"

           SET HLFORMAT=1

           SET HLRESLTA=HL("MID")

 +3        DO GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.HLRESTLA)

 +4        QUIT 

VFIER     ; Check if the RAVERF string is a partial match to an entry in file

 +1       ; 200.  If if is, check to see that is a partial match to only ONE

 +2       ; active provider entry in file 200.

 +3        IF '$LENGTH(RAVERF)

               SET RAERR="Missing Provider information"

               QUIT 

 +4        KILL RAVCNT,RAVIEN,RAVLGTH,RAVPS

 +5       ; length of the RAVERF string

           SET RAVLGTH=$LENGTH(RAVERF)

 +6        SET RAVCNT=0

           SET RAVS1=RAVERF

 +7        FOR 

               SET RAVS1=$ORDER(^VA(200,"B",RAVS1))

               IF RAVS1=""!($EXTRACT(RAVS1,1,RAVLGTH)'=RAVERF)

                   QUIT 

               Begin DoDot:1

 +8       ; return subscripts that have the RAVERF string as the first

 +9       ; 1 - RAVLGTH chars of RAVS1

 +10               SET RAVIEN=0

 +11               FOR 

                       SET RAVIEN=$ORDER(^VA(200,"B",RAVS1,RAVIEN))

                       IF RAVIEN'>0

                           QUIT 

                       Begin DoDot:2

 +12                       SET RAVPS=$GET(^VA(200,RAVIEN,"PS"))

 +13                       IF '$PIECE(RAVPS,"^",4)!($PIECE(RAVPS,"^",4)>DT)

                               SET RAVCNT=RAVCNT+1

 +14      ; when

                           IF RAVCNT=1

                               IF ('$DATA(RAVIEN(RAVCNT))#2)

                                   SET RAVIEN(RAVCNT)=RAVIEN

 +15      ; we find the first active provider save the provider ien off

 +16      ; in a local array.

 +17                       QUIT 

                       End DoDot:2

                       IF RAVCNT>1

                           QUIT 

 +18               QUIT 

               End DoDot:1

               IF RAVCNT>1

                   QUIT 

 +19      ; partial match not found

           IF RAVCNT=0

               SET RAERR="Invalid Provider Name"

               QUIT 

 +20      ; >1 partial match

           IF RAVCNT>1

               SET RAERR="Non-Unique Provider Name"

               QUIT 

 +21       SET RAVERF=$GET(RAVIEN(1))

           IF 'RAVERF

               SET RAERR="Provider Name Entry Error"

 +22       KILL RAVCNT,RAVIEN,RAVLGTH,RAVPS

 +23       QUIT