BHLBCH.m

BHLBCH ; IHS/TUCSON/DCP - HL7 ORU Message Processor ; 

 ;;1.0;IHS SUPPORT FOR HL7 INTERFACES;;JUL 7, 1997

 ;

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

 ; This routine processes HL7 ORU messages and files the data

 ; into RPMS/PCC.  It does not produce any output variables.

 ;

 ; This routine requires the input variables listed below.

 ; These variables are supplied by the HL7 package, based

 ; on the incoming message that it was processing when it

 ; branched to this routine via the protocol file.

 ;

 ;  HLMTIEN    = The IEN in the MESSAGE TEXT FILE (#772)

 ;               for the message being processed.

 ;

 ;  HL("FS")   = HL7 field separator character for the

 ;               incoming message.

 ;

 ;  HL("ECH")  = HL7 encoding characters for the incoming

 ;               message.

 ;

 ;

START ; ENTRY POINT from HL7 protocol

 ;

 D INIT

 F  X HLNEXT Q:'HLQUIT  S BHLSEG=$P(HLNODE,BHLFS,1) I BHLSEG'="",$T(@BHLSEG)'="" S BHLDATA=$P(HLNODE,BHLFS,2,$L(HLNODE,BHLFS)) D @BHLSEG

 D FILING

 Q

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

MSH ;

 S BHLBCH("MSH")=""

 S BHLDATA=BHLFS_BHLDATA   ; make piece numbers match HL7 field numbers

 S $P(BHLBCH("DEMO"),U,8)=$P(BHLDATA,BHLFS,6)     ; receiving facility

 S $P(BHLBCH("TRANS"),U,3)=$P(BHLDATA,BHLFS,3)    ; sending application

 Q

 ;

PID ;

 S BHLBCH("PID")=""

 I $P(BHLDATA,BHLFS,7)?1."0" S $P(BHLDATA,BHLFS,7)=""

 ;

 S $P(BHLBCH("DEMO"),U,1)=$$FMNAME^HLFNC($P(BHLDATA,BHLFS,5),HLECH) ; name

 S $P(BHLBCH("DEMO"),U,7)=$P($P(BHLDATA,BHLFS,3),BHLCS)           ; chart number (HRN)

 S $P(BHLBCH("DEMO"),U,2)=$$FMDATE^HLFNC($P(BHLDATA,BHLFS,7))     ; dob

 S $P(BHLBCH("DEMO"),U,3)=$P(BHLDATA,BHLFS,8)                     ; sex

 S $P(BHLBCH("DEMO"),U,4)=$P(BHLDATA,BHLFS,19)                    ; ssn

 S $P(BHLBCH("DEMO"),U,5)=$P(BHLDATA,BHLFS,22)                    ; tribe [ethnic group]

 S $P(BHLBCH("DEMO"),U,9)=$TR($P($P(BHLDATA,BHLFS,11),BHLCS,1,7),BHLCS," ") ; translate address delimiters from component separator to space

 Q

 ;

OBR ;

 S BHLBCH("OBR")=""

 S BHLBCH("OBR CNT")=BHLBCH("OBR CNT")+1

 I $P(BHLDATA,BHLFS,4)["99CHRSVC" D

 . S $P(BHLBCH("POV",BHLBCH("OBR CNT")),U,2)=$P($P(BHLDATA,BHLFS,4),BHLCS,4) ;SVCCODE

 . S $P(BHLBCH("POV",BHLBCH("OBR CNT")),U,3)=$P(BHLDATA,BHLFS,20)      ;SVCMIN

 . S $P(BHLBCH("POV",BHLBCH("OBR CNT")),U,5)=$P(BHLDATA,BHLFS,21)      ;SUBSTANC

 . Q:$D(BHLBCH("REC"))

 . S $P(BHLBCH("REC"),U,1)=$$FMDATE^HLFNC($P(BHLDATA,BHLFS,7))         ; SVCDATE [observation date / service date]

 . S $P(BHLBCH("REC"),U,3)=$$STRIP^XLFSTR($P(BHLDATA,BHLFS,31)," ")    ; PROVIDER (note: this should be in Field 32)

 . Q

 Q

 ;

OBX ;

 S BHLBCH("OBX")=""

 I $P(BHLDATA,BHLFS,3)["99CHRSVC" D

 . S $P(BHLBCH("POV",BHLBCH("OBR CNT")),U,4)=$P(BHLDATA,BHLFS,5)       ; NARRATV

 . Q

 ;

 I $P(BHLDATA,BHLFS,3)["99CHRHAC" D

 . S $P(BHLBCH("POV",BHLBCH("OBR CNT")),U,1)=$P($P(BHLDATA,BHLFS,3),BHLCS,4) ;HAC

 . Q

 ;

 I $P(BHLDATA,BHLFS,3)["99CHRTM" D

 . S BHLBCH("OBX CNT")=BHLBCH("OBX CNT")+1

 . N TYPE,VALUE

 . S TYPE=$P($P(BHLDATA,BHLFS,3),BHLCS,4)

 . S VALUE=$P(BHLDATA,BHLFS,5)

 . S:VALUE["99CHRFPM" VALUE=$P(VALUE,BHLCS,4)

 . I TYPE="LMP" S VALUE=$$FMDATE^HLFNC(VALUE) N Y S Y=VALUE X ^DD("DD") S VALUE=Y

 . S BHLBCH("MSR",BHLBCH("OBX CNT"))=TYPE_U_VALUE

 . Q

 ;

 Q

 ;

Z01 ;

 S BHLBCH("Z01")=""

 S $P(BHLBCH("DEMO"),U,6)=$P($P(BHLDATA,BHLFS,1),BHLCS,4)     ;COMRES

 S $P(BHLBCH("REC"),U,2)=$P($P(BHLDATA,BHLFS,2),BHLCS,4)      ;PROGRAM

 S $P(BHLBCH("REC"),U,4)=$P($P(BHLDATA,BHLFS,3),BHLCS,4)      ;ACTLOC

 S $P(BHLBCH("REC"),U,12)=$P(BHLDATA,BHLFS,4)                 ;LOCENC

 S $P(BHLBCH("REC"),U,6)=$P($P(BHLDATA,BHLFS,5),BHLCS,4)      ;REFBY

 S $P(BHLBCH("REC"),U,5)=$P($P(BHLDATA,BHLFS,6),BHLCS,4)      ;REFTO

 S $P(BHLBCH("REC"),U,7)=$P(BHLDATA,BHLFS,7)                  ;EVAL

 S $P(BHLBCH("REC"),U,8)=$P(BHLDATA,BHLFS,8)                  ;TRAVEL

 S $P(BHLBCH("REC"),U,9)=$P(BHLDATA,BHLFS,9)                  ;NUMBER

 S $P(BHLBCH("TRANS"),U,2)=$P($P(BHLDATA,BHLFS,10),BHLCS,1)   ;RECORD

 S $P(BHLBCH("TRANS"),U,1)=$P($P(BHLDATA,BHLFS,10),BHLCS,2)   ;RECTYPE

 S $P(BHLBCH("REC"),U,10)=$P(BHLDATA,BHLFS,11)                ;INSURER

 Q

 ;

FILING ;

 ; N SEG F SEG="PID","OBR","OBX","Z01" I '$D(BHLBCH(SEG)) S BHLERR=$S(BHLERR="":"",1:",")_SEG

 ; I BHLERR'="" S BHLQUIT=1,HLERR="MISSING MESSAGE SEGMENT(S): "_BHLERR D EOJ^BHLBCH1 Q

 D START^BHLBCH1

 Q

INIT ;

 K BHLBCH,BHLFS,BHLCS

 S BHLERR="",(BHLQUIT,BHLR)=0

 S HLECH=HL("ECH")

 S BHLFS=HL("FS"),BHLCS=$E(HLECH,1) ; field and component separators extracted fm message

 S HLQUIT=0

 S BHLBCH("OBR CNT")=0,BHLBCH("OBX CNT")=0

 S HLNEXT="S HLQUIT=$O(^HL(772,HLMTIEN,""IN"",HLQUIT)) S:HLQUIT HLNODE=$G(^(HLQUIT,0))"

 Q

DEBUG ; EP - PROGRAMMER DEBUGGING

 D:'$G(DUZ(0)) ^XBKVAR

 S U="^"

 S HL("ECH")="~|\&"

 S HL("FS")="^"

 G START

 Q

BHLBCH    ; IHS/TUCSON/DCP - HL7 ORU Message Processor ; 

 +1       ;;1.0;IHS SUPPORT FOR HL7 INTERFACES;;JUL 7, 1997

 +2       ;

 +3       ;------------------------------------------------------------

 +4       ; This routine processes HL7 ORU messages and files the data

 +5       ; into RPMS/PCC.  It does not produce any output variables.

 +6       ;

 +7       ; This routine requires the input variables listed below.

 +8       ; These variables are supplied by the HL7 package, based

 +9       ; on the incoming message that it was processing when it

 +10      ; branched to this routine via the protocol file.

 +11      ;

 +12      ;  HLMTIEN    = The IEN in the MESSAGE TEXT FILE (#772)

 +13      ;               for the message being processed.

 +14      ;

 +15      ;  HL("FS")   = HL7 field separator character for the

 +16      ;               incoming message.

 +17      ;

 +18      ;  HL("ECH")  = HL7 encoding characters for the incoming

 +19      ;               message.

 +20      ;

 +21      ;

START     ; ENTRY POINT from HL7 protocol

 +1       ;

 +2        DO INIT

 +3        FOR 

               XECUTE HLNEXT

               IF 'HLQUIT

                   QUIT 

               SET BHLSEG=$PIECE(HLNODE,BHLFS,1)

               IF BHLSEG'=""

                   IF $TEXT(@BHLSEG)'=""

                       SET BHLDATA=$PIECE(HLNODE,BHLFS,2,$LENGTH(HLNODE,BHLFS))

                       DO @BHLSEG

 +4        DO FILING

 +5        QUIT 

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

MSH       ;

 +1        SET BHLBCH("MSH")=""

 +2       ; make piece numbers match HL7 field numbers

           SET BHLDATA=BHLFS_BHLDATA

 +3       ; receiving facility

           SET $PIECE(BHLBCH("DEMO"),U,8)=$PIECE(BHLDATA,BHLFS,6)

 +4       ; sending application

           SET $PIECE(BHLBCH("TRANS"),U,3)=$PIECE(BHLDATA,BHLFS,3)

 +5        QUIT 

 +6       ;

PID       ;

 +1        SET BHLBCH("PID")=""

 +2        IF $PIECE(BHLDATA,BHLFS,7)?1."0"

               SET $PIECE(BHLDATA,BHLFS,7)=""

 +3       ;

 +4       ; name

           SET $PIECE(BHLBCH("DEMO"),U,1)=$$FMNAME^HLFNC($PIECE(BHLDATA,BHLFS,5),HLECH)

 +5       ; chart number (HRN)

           SET $PIECE(BHLBCH("DEMO"),U,7)=$PIECE($PIECE(BHLDATA,BHLFS,3),BHLCS)

 +6       ; dob

           SET $PIECE(BHLBCH("DEMO"),U,2)=$$FMDATE^HLFNC($PIECE(BHLDATA,BHLFS,7))

 +7       ; sex

           SET $PIECE(BHLBCH("DEMO"),U,3)=$PIECE(BHLDATA,BHLFS,8)

 +8       ; ssn

           SET $PIECE(BHLBCH("DEMO"),U,4)=$PIECE(BHLDATA,BHLFS,19)

 +9       ; tribe [ethnic group]

           SET $PIECE(BHLBCH("DEMO"),U,5)=$PIECE(BHLDATA,BHLFS,22)

 +10      ; translate address delimiters from component separator to space

           SET $PIECE(BHLBCH("DEMO"),U,9)=$TRANSLATE($PIECE($PIECE(BHLDATA,BHLFS,11),BHLCS,1,7),BHLCS," ")

 +11       QUIT 

 +12      ;

OBR       ;

 +1        SET BHLBCH("OBR")=""

 +2        SET BHLBCH("OBR CNT")=BHLBCH("OBR CNT")+1

 +3        IF $PIECE(BHLDATA,BHLFS,4)["99CHRSVC"

               Begin DoDot:1

 +4       ;SVCCODE

                   SET $PIECE(BHLBCH("POV",BHLBCH("OBR CNT")),U,2)=$PIECE($PIECE(BHLDATA,BHLFS,4),BHLCS,4)

 +5       ;SVCMIN

                   SET $PIECE(BHLBCH("POV",BHLBCH("OBR CNT")),U,3)=$PIECE(BHLDATA,BHLFS,20)

 +6       ;SUBSTANC

                   SET $PIECE(BHLBCH("POV",BHLBCH("OBR CNT")),U,5)=$PIECE(BHLDATA,BHLFS,21)

 +7                IF $DATA(BHLBCH("REC"))

                       QUIT 

 +8       ; SVCDATE [observation date / service date]

                   SET $PIECE(BHLBCH("REC"),U,1)=$$FMDATE^HLFNC($PIECE(BHLDATA,BHLFS,7))

 +9       ; PROVIDER (note: this should be in Field 32)

                   SET $PIECE(BHLBCH("REC"),U,3)=$$STRIP^XLFSTR($PIECE(BHLDATA,BHLFS,31)," ")

 +10               QUIT 

               End DoDot:1

 +11       QUIT 

 +12      ;

OBX       ;

 +1        SET BHLBCH("OBX")=""

 +2        IF $PIECE(BHLDATA,BHLFS,3)["99CHRSVC"

               Begin DoDot:1

 +3       ; NARRATV

                   SET $PIECE(BHLBCH("POV",BHLBCH("OBR CNT")),U,4)=$PIECE(BHLDATA,BHLFS,5)

 +4                QUIT 

               End DoDot:1

 +5       ;

 +6        IF $PIECE(BHLDATA,BHLFS,3)["99CHRHAC"

               Begin DoDot:1

 +7       ;HAC

                   SET $PIECE(BHLBCH("POV",BHLBCH("OBR CNT")),U,1)=$PIECE($PIECE(BHLDATA,BHLFS,3),BHLCS,4)

 +8                QUIT 

               End DoDot:1

 +9       ;

 +10       IF $PIECE(BHLDATA,BHLFS,3)["99CHRTM"

               Begin DoDot:1

 +11               SET BHLBCH("OBX CNT")=BHLBCH("OBX CNT")+1

 +12               NEW TYPE,VALUE

 +13               SET TYPE=$PIECE($PIECE(BHLDATA,BHLFS,3),BHLCS,4)

 +14               SET VALUE=$PIECE(BHLDATA,BHLFS,5)

 +15               IF VALUE["99CHRFPM"

                       SET VALUE=$PIECE(VALUE,BHLCS,4)

 +16               IF TYPE="LMP"

                       SET VALUE=$$FMDATE^HLFNC(VALUE)

                       NEW Y

                       SET Y=VALUE

                       XECUTE ^DD("DD")

                       SET VALUE=Y

 +17               SET BHLBCH("MSR",BHLBCH("OBX CNT"))=TYPE_U_VALUE

 +18               QUIT 

               End DoDot:1

 +19      ;

 +20       QUIT 

 +21      ;

Z01       ;

 +1        SET BHLBCH("Z01")=""

 +2       ;COMRES

           SET $PIECE(BHLBCH("DEMO"),U,6)=$PIECE($PIECE(BHLDATA,BHLFS,1),BHLCS,4)

 +3       ;PROGRAM

           SET $PIECE(BHLBCH("REC"),U,2)=$PIECE($PIECE(BHLDATA,BHLFS,2),BHLCS,4)

 +4       ;ACTLOC

           SET $PIECE(BHLBCH("REC"),U,4)=$PIECE($PIECE(BHLDATA,BHLFS,3),BHLCS,4)

 +5       ;LOCENC

           SET $PIECE(BHLBCH("REC"),U,12)=$PIECE(BHLDATA,BHLFS,4)

 +6       ;REFBY

           SET $PIECE(BHLBCH("REC"),U,6)=$PIECE($PIECE(BHLDATA,BHLFS,5),BHLCS,4)

 +7       ;REFTO

           SET $PIECE(BHLBCH("REC"),U,5)=$PIECE($PIECE(BHLDATA,BHLFS,6),BHLCS,4)

 +8       ;EVAL

           SET $PIECE(BHLBCH("REC"),U,7)=$PIECE(BHLDATA,BHLFS,7)

 +9       ;TRAVEL

           SET $PIECE(BHLBCH("REC"),U,8)=$PIECE(BHLDATA,BHLFS,8)

 +10      ;NUMBER

           SET $PIECE(BHLBCH("REC"),U,9)=$PIECE(BHLDATA,BHLFS,9)

 +11      ;RECORD

           SET $PIECE(BHLBCH("TRANS"),U,2)=$PIECE($PIECE(BHLDATA,BHLFS,10),BHLCS,1)

 +12      ;RECTYPE

           SET $PIECE(BHLBCH("TRANS"),U,1)=$PIECE($PIECE(BHLDATA,BHLFS,10),BHLCS,2)

 +13      ;INSURER

           SET $PIECE(BHLBCH("REC"),U,10)=$PIECE(BHLDATA,BHLFS,11)

 +14       QUIT 

 +15      ;

FILING    ;

 +1       ; N SEG F SEG="PID","OBR","OBX","Z01" I '$D(BHLBCH(SEG)) S BHLERR=$S(BHLERR="":"",1:",")_SEG

 +2       ; I BHLERR'="" S BHLQUIT=1,HLERR="MISSING MESSAGE SEGMENT(S): "_BHLERR D EOJ^BHLBCH1 Q

 +3        DO START^BHLBCH1

 +4        QUIT 

INIT      ;

 +1        KILL BHLBCH,BHLFS,BHLCS

 +2        SET BHLERR=""

           SET (BHLQUIT,BHLR)=0

 +3        SET HLECH=HL("ECH")

 +4       ; field and component separators extracted fm message

           SET BHLFS=HL("FS")

           SET BHLCS=$EXTRACT(HLECH,1)

 +5        SET HLQUIT=0

 +6        SET BHLBCH("OBR CNT")=0

           SET BHLBCH("OBX CNT")=0

 +7        SET HLNEXT="S HLQUIT=$O(^HL(772,HLMTIEN,""IN"",HLQUIT)) S:HLQUIT HLNODE=$G(^(HLQUIT,0))"

 +8        QUIT 

DEBUG     ; EP - PROGRAMMER DEBUGGING

 +1        IF '$GET(DUZ(0))

               DO ^XBKVAR

 +2        SET U="^"

 +3        SET HL("ECH")="~|\&"

 +4        SET HL("FS")="^"

 +5        GOTO START

 +6        QUIT