Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BHLBCH

BHLBCH.m

Go to the documentation of this file. 
  1. BHLBCH ; IHS/TUCSON/DCP - HL7 ORU Message Processor ; 
  1.  ;;1.0;IHS SUPPORT FOR HL7 INTERFACES;;JUL 7, 1997
  1.  ;
  1.  ;------------------------------------------------------------
  1.  ; This routine processes HL7 ORU messages and files the data
  1.  ; into RPMS/PCC.  It does not produce any output variables.
  1.  ;
  1.  ; This routine requires the input variables listed below.
  1.  ; These variables are supplied by the HL7 package, based
  1.  ; on the incoming message that it was processing when it
  1.  ; branched to this routine via the protocol file.
  1.  ;
  1.  ;  HLMTIEN    = The IEN in the MESSAGE TEXT FILE (#772)
  1.  ;               for the message being processed.
  1.  ;
  1.  ;  HL("FS")   = HL7 field separator character for the
  1.  ;               incoming message.
  1.  ;
  1.  ;  HL("ECH")  = HL7 encoding characters for the incoming
  1.  ;               message.
  1.  ;
  1.  ;
  1. START ; ENTRY POINT from HL7 protocol
  1.  ;
  1.  D INIT
  1.  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
  1.  D FILING
  1.  Q
  1.  ;-------------------------------------------------------------
  1. MSH ;
  1.  S BHLBCH("MSH")=""
  1.  S BHLDATA=BHLFS_BHLDATA   ; make piece numbers match HL7 field numbers
  1.  S $P(BHLBCH("DEMO"),U,8)=$P(BHLDATA,BHLFS,6)     ; receiving facility
  1.  S $P(BHLBCH("TRANS"),U,3)=$P(BHLDATA,BHLFS,3)    ; sending application
  1.  Q
  1.  ;
  1. PID ;
  1.  S BHLBCH("PID")=""
  1.  I $P(BHLDATA,BHLFS,7)?1."0" S $P(BHLDATA,BHLFS,7)=""
  1.  ;
  1.  S $P(BHLBCH("DEMO"),U,1)=$$FMNAME^HLFNC($P(BHLDATA,BHLFS,5),HLECH) ; name
  1.  S $P(BHLBCH("DEMO"),U,7)=$P($P(BHLDATA,BHLFS,3),BHLCS)           ; chart number (HRN)
  1.  S $P(BHLBCH("DEMO"),U,2)=$$FMDATE^HLFNC($P(BHLDATA,BHLFS,7))     ; dob
  1.  S $P(BHLBCH("DEMO"),U,3)=$P(BHLDATA,BHLFS,8)                     ; sex
  1.  S $P(BHLBCH("DEMO"),U,4)=$P(BHLDATA,BHLFS,19)                    ; ssn
  1.  S $P(BHLBCH("DEMO"),U,5)=$P(BHLDATA,BHLFS,22)                    ; tribe [ethnic group]
  1.  S $P(BHLBCH("DEMO"),U,9)=$TR($P($P(BHLDATA,BHLFS,11),BHLCS,1,7),BHLCS," ") ; translate address delimiters from component separator to space
  1.  Q
  1.  ;
  1. OBR ;
  1.  S BHLBCH("OBR")=""
  1.  S BHLBCH("OBR CNT")=BHLBCH("OBR CNT")+1
  1.  I $P(BHLDATA,BHLFS,4)["99CHRSVC" D
  1.  . S $P(BHLBCH("POV",BHLBCH("OBR CNT")),U,2)=$P($P(BHLDATA,BHLFS,4),BHLCS,4) ;SVCCODE
  1.  . S $P(BHLBCH("POV",BHLBCH("OBR CNT")),U,3)=$P(BHLDATA,BHLFS,20)      ;SVCMIN
  1.  . S $P(BHLBCH("POV",BHLBCH("OBR CNT")),U,5)=$P(BHLDATA,BHLFS,21)      ;SUBSTANC
  1.  . Q:$D(BHLBCH("REC"))
  1.  . S $P(BHLBCH("REC"),U,1)=$$FMDATE^HLFNC($P(BHLDATA,BHLFS,7))         ; SVCDATE [observation date / service date]
  1.  . S $P(BHLBCH("REC"),U,3)=$$STRIP^XLFSTR($P(BHLDATA,BHLFS,31)," ")    ; PROVIDER (note: this should be in Field 32)
  1.  . Q
  1.  Q
  1.  ;
  1. OBX ;
  1.  S BHLBCH("OBX")=""
  1.  I $P(BHLDATA,BHLFS,3)["99CHRSVC" D
  1.  . S $P(BHLBCH("POV",BHLBCH("OBR CNT")),U,4)=$P(BHLDATA,BHLFS,5)       ; NARRATV
  1.  . Q
  1.  ;
  1.  I $P(BHLDATA,BHLFS,3)["99CHRHAC" D
  1.  . S $P(BHLBCH("POV",BHLBCH("OBR CNT")),U,1)=$P($P(BHLDATA,BHLFS,3),BHLCS,4) ;HAC
  1.  . Q
  1.  ;
  1.  I $P(BHLDATA,BHLFS,3)["99CHRTM" D
  1.  . S BHLBCH("OBX CNT")=BHLBCH("OBX CNT")+1
  1.  . N TYPE,VALUE
  1.  . S TYPE=$P($P(BHLDATA,BHLFS,3),BHLCS,4)
  1.  . S VALUE=$P(BHLDATA,BHLFS,5)
  1.  . S:VALUE["99CHRFPM" VALUE=$P(VALUE,BHLCS,4)
  1.  . I TYPE="LMP" S VALUE=$$FMDATE^HLFNC(VALUE) N Y S Y=VALUE X ^DD("DD") S VALUE=Y
  1.  . S BHLBCH("MSR",BHLBCH("OBX CNT"))=TYPE_U_VALUE
  1.  . Q
  1.  ;
  1.  Q
  1.  ;
  1. Z01 ;
  1.  S BHLBCH("Z01")=""
  1.  S $P(BHLBCH("DEMO"),U,6)=$P($P(BHLDATA,BHLFS,1),BHLCS,4)     ;COMRES
  1.  S $P(BHLBCH("REC"),U,2)=$P($P(BHLDATA,BHLFS,2),BHLCS,4)      ;PROGRAM
  1.  S $P(BHLBCH("REC"),U,4)=$P($P(BHLDATA,BHLFS,3),BHLCS,4)      ;ACTLOC
  1.  S $P(BHLBCH("REC"),U,12)=$P(BHLDATA,BHLFS,4)                 ;LOCENC
  1.  S $P(BHLBCH("REC"),U,6)=$P($P(BHLDATA,BHLFS,5),BHLCS,4)      ;REFBY
  1.  S $P(BHLBCH("REC"),U,5)=$P($P(BHLDATA,BHLFS,6),BHLCS,4)      ;REFTO
  1.  S $P(BHLBCH("REC"),U,7)=$P(BHLDATA,BHLFS,7)                  ;EVAL
  1.  S $P(BHLBCH("REC"),U,8)=$P(BHLDATA,BHLFS,8)                  ;TRAVEL
  1.  S $P(BHLBCH("REC"),U,9)=$P(BHLDATA,BHLFS,9)                  ;NUMBER
  1.  S $P(BHLBCH("TRANS"),U,2)=$P($P(BHLDATA,BHLFS,10),BHLCS,1)   ;RECORD
  1.  S $P(BHLBCH("TRANS"),U,1)=$P($P(BHLDATA,BHLFS,10),BHLCS,2)   ;RECTYPE
  1.  S $P(BHLBCH("REC"),U,10)=$P(BHLDATA,BHLFS,11)                ;INSURER
  1.  Q
  1.  ;
  1. FILING ;
  1.  ; N SEG F SEG="PID","OBR","OBX","Z01" I '$D(BHLBCH(SEG)) S BHLERR=$S(BHLERR="":"",1:",")_SEG
  1.  ; I BHLERR'="" S BHLQUIT=1,HLERR="MISSING MESSAGE SEGMENT(S): "_BHLERR D EOJ^BHLBCH1 Q
  1.  D START^BHLBCH1
  1.  Q
  1. INIT ;
  1.  K BHLBCH,BHLFS,BHLCS
  1.  S BHLERR="",(BHLQUIT,BHLR)=0
  1.  S HLECH=HL("ECH")
  1.  S BHLFS=HL("FS"),BHLCS=$E(HLECH,1) ; field and component separators extracted fm message
  1.  S HLQUIT=0
  1.  S BHLBCH("OBR CNT")=0,BHLBCH("OBX CNT")=0
  1.  S HLNEXT="S HLQUIT=$O(^HL(772,HLMTIEN,""IN"",HLQUIT)) S:HLQUIT HLNODE=$G(^(HLQUIT,0))"
  1.  Q
  1. DEBUG ; EP - PROGRAMMER DEBUGGING
  1.  D:'$G(DUZ(0)) ^XBKVAR
  1.  S U="^"
  1.  S HL("ECH")="~|\&"
  1.  S HL("FS")="^"
  1.  G START
  1.  Q