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

BHLBPS.m

Go to the documentation of this file. 
  1. BHLBPS ; IHS/TUCSON/DCP - HL7 RDS Message Processor ; 
  1.  ;;1.0;IHS SUPPORT FOR HL7 INTERFACES;;JUL 7, 1997
  1.  ;
  1.  ;------------------------------------------------------------
  1.  ; This routine processes HL7 RDS 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.  ;  HLNEXT     = M code to be executed to $O through
  1.  ;               the nodes of global that contains the
  1.  ;               message being processed.
  1.  ;
  1.  ;  HLNODE     = A node from the message text global.  This
  1.  ;               variable is set to the next line of the
  1.  ;               incoming message when HLNEXT is executed.
  1.  ;
  1.  ;  HLQUIT     = A variable that indicates when there are no
  1.  ;               more nodes (message lines) to process.
  1.  ;
  1.  ;  HLMTIENS   = The IEN in the MESSAGE TEXT FILE (#772)
  1.  ;               for the subscriber application.
  1.  ;
  1.  ;  HL("APAT") = The application acknowledgement condition
  1.  ;               from the message header segment of the
  1.  ;               incoming message.
  1.  ;
  1.  ;  HL("EID")  = The IEN in the PROTOCOL FILE (#101) of
  1.  ;               the event driver protocol that generated
  1.  ;               the incoming message.
  1.  ;
  1.  ;  HL("EIDS") = The IEN in the PROTOCOL FILE (#101) of
  1.  ;               the subscriber protocol that is receiving
  1.  ;               the incoming message.
  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.  ;  HL("MID")  = The HL7 message control ID for the incoming
  1.  ;               message.
  1.  ;
  1.  ;
  1. START ;  ENTRY POINT from HL7 client protocol
  1.  ;
  1.  D INIT
  1.  F  X HLNEXT Q:HLQUIT'>0  S BHLSEG=$P(HLNODE,BHLFS,1) I BHLSEG'="",$T(@BHLSEG)'="" S BHLDATA=$P(HLNODE,BHLFS,2,$L(HLNODE,BHLFS)) D @BHLSEG
  1.  D FILING,ACKMSG
  1.  I $D(HLERR),BHLERR'="" S BHLERR=BHLERR_".  "_HLERR
  1.  I BHLERR'="" S HLERR=BHLERR D BULLETIN
  1.  D DISPLAY
  1. END D EOJ
  1.  Q
  1.  ;-------------------------------------------------------------
  1. MSH ;
  1.  N BHLFAC
  1.  ; adjust pieces so piece numbers match HL7 field numbers
  1.  S BHLDATA=BHLFS_BHLDATA
  1.  ; save MSH data for use in ACK message
  1.  S BHLMSH=BHLDATA
  1.  ; HL7 receiving facility number
  1.  S BHLFAC=$P(BHLDATA,BHLFS,6)
  1.  S $P(BHLBPS("PAT DEMO"),BHLFS,6)=BHLFAC
  1.  S $P(BHLBPS("VISIT"),BHLFS,3)=BHLFAC
  1.  Q
  1.  ;
  1. PID ;
  1.  S BHLBPS("PID")=""
  1.  ; name
  1.  S $P(BHLBPS("PAT DEMO"),BHLFS,1)=$$FMNAME^HLFNC($P(BHLDATA,BHLFS,5),HLECH)
  1.  ; dob
  1.  S $P(BHLBPS("PAT DEMO"),BHLFS,2)=$$FMDATE^HLFNC($P(BHLDATA,BHLFS,7))
  1.  ; sex
  1.  S $P(BHLBPS("PAT DEMO"),BHLFS,3)=$P(BHLDATA,BHLFS,8)
  1.  ; ssn
  1.  S $P(BHLBPS("PAT DEMO"),BHLFS,4)=$P(BHLDATA,BHLFS,19)
  1.  ; chart number (HRN)
  1.  S $P(BHLBPS("PAT DEMO"),BHLFS,5)=$P($P(BHLDATA,BHLFS,3),BHLCS,1)
  1.  Q
  1.  ;
  1. ORC ;
  1.  S BHLBPS("ORC")=""
  1.  ; provider DEA #
  1.  S $P(BHLBPS("MED"),BHLFS,11)=$P($P(BHLDATA,BHLFS,12),BHLCS,1)
  1.  ; provider name - last, first, middle, suffix - 30 char max
  1.  S $P(BHLBPS("MED"),BHLFS,12)=$$FMNAME^HLFNC($E($P($P(BHLDATA,BHLFS,12),BHLCS,2,5),1,30),HLECH)
  1.  Q
  1.  ;
  1. RXD ;
  1.  S BHLBPS("RXD")=""
  1.  ; rx number
  1.  S $P(BHLBPS("MED"),BHLFS,1)=$P(BHLDATA,BHLFS,7)
  1.  ; quantity
  1.  S $P(BHLBPS("MED"),BHLFS,2)=$P(BHLDATA,BHLFS,4)
  1.  ; dispense date
  1.  S $P(BHLBPS("MED"),BHLFS,4)=$$FMDATE^HLFNC($P(BHLDATA,BHLFS,3))
  1.  ; xkey
  1.  S $P(BHLBPS("MED"),BHLFS,5)=$P(BHLDATA,BHLFS,7)_"_"_$P(BHLDATA,BHLFS,1)
  1.  ; ndc
  1.  S $P(BHLBPS("MED"),BHLFS,7)=$P($P(BHLDATA,BHLFS,2),BHLCS,4)
  1.  ; drug
  1.  S $P(BHLBPS("MED"),BHLFS,8)=$P($P(BHLDATA,BHLFS,2),BHLCS,5)
  1.  ; units
  1.  S $P(BHLBPS("MED"),BHLFS,9)=$P(BHLDATA,BHLFS,5)
  1.  ; sig
  1.  S $P(BHLBPS("MED"),BHLFS,10)=$P(BHLDATA,BHLFS,9)
  1.  Q
  1.  ;
  1. Z02 ;
  1.  S BHLBPS("Z02")=""
  1.  ; days
  1.  S $P(BHLBPS("MED"),BHLFS,3)=$P(BHLDATA,BHLFS,2)
  1.  ; action
  1.  S $P(BHLBPS("MED"),BHLFS,6)=$P(BHLDATA,BHLFS,3)
  1.  ; rph code
  1.  S $P(BHLBPS("MED"),BHLFS,13)=$P($P(BHLDATA,BHLFS,1),BHLCS,1)
  1.  ; rph name - last, first, middle - 30 char max
  1.  S $P(BHLBPS("MED"),BHLFS,14)=$$FMNAME^HLFNC($E($P($P(BHLDATA,BHLFS,1),BHLCS,2,4),1,30),HLECH)
  1.  Q
  1.  ;
  1. Z03 ;
  1.  S BHLBPS("Z03")=""
  1.  ; visit date
  1.  S $P(BHLBPS("VISIT"),BHLFS,1)=$$FMDATE^HLFNC($P(BHLDATA,BHLFS,1))
  1.  ; service catagory
  1.  S $P(BHLBPS("VISIT"),BHLFS,2)=$P(BHLDATA,BHLFS,2)
  1.  Q
  1.  ;
  1. FILING ;
  1.  N SEG
  1.  F SEG="PID","ORC","RXD","Z02","Z03" I '$D(BHLBPS(SEG)) S BHLERR=BHLERR_","_SEG
  1.  I BHLERR'="" S BHLERR="MISSING MESSAGE SEGMENT(S): "_$E(BHLERR,2,$L(BHLERR)) Q
  1.  D ^BHLBPS1
  1.  Q
  1.  ;
  1. ACKMSG ;
  1.  ; transmit acknowledgement message back to sending application if required
  1.  N HLRESLTA
  1.  I $G(HL("APAT"))="",$G(HL("ACAT"))'="" Q
  1.  I HL("APAT")="NE" Q
  1.  I HL("APAT")="SU",BHLERR'="" Q
  1.  I HL("APAT")="ER",BHLERR="" Q
  1.  S HLA("HLA",1)="MSA"_BHLFS_$S(BHLERR="":"AA",1:"AE")_BHLFS_HL("MID")
  1.  I BHLERR'="" S HLA("HLA",2)="ERR"_BHLFS_BHLERR
  1.  Q:$G(BHLDBUG)  ; don't send ACK in programmer debug mode
  1.  D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.HLRESLTA)
  1.  I $P(HLRESLTA,U,2)'="" S BHLERR=BHLERR_" ** APP ACK GEN ERROR "_$TR(HLRESLTA,U,":")_" **"
  1.  Q
  1.  ;
  1. BULLETIN ; Send Error Bulletin
  1.  ;
  1.  Q:$G(BHLDBUG)
  1.  N %X,%Y,X,XMB,XMDT,XMDUZ,Y1
  1.  S XMB="BHLBPS RX-PCC MESSAGE ERROR"
  1.  S XMB(1)=BHLERR
  1.  S XMB(2)=$G(BHLEDATA)
  1.  S XMB(3)=HLMTIEN
  1.  S XMDUZ=.5
  1.  D ^XMB
  1.  Q
  1.  ;
  1. EOJ ;
  1.  K BHLDATA,BHLFS,BHLCS,BHLBPS,BHLMSH,BHLERR,BHLSEG,BHLEDATA
  1.  K D0,DA,DD,DFN,DIC,DIK,DO,DR,F,I,X,Y,%,HLA
  1.  Q
  1.  ;
  1. INIT ;
  1.  D ^XBKVAR ; make sure kernel variables are defined
  1.  D EOJ
  1.  K HLERR
  1.  S BHLERR=""
  1.  S BHLBPS("MED")=""
  1.  S BHLBPS("VISIT")=""
  1.  S BHLBPS("PAT DEMO")=""
  1.  S BHLFS=HL("FS")          ; HL7 field separator
  1.  S HLECH=HL("ECH")         ; HL7 encoding characters
  1.  S BHLCS=$E(HLECH,1)       ; HL7 component separator
  1.  Q
  1.  ;
  1. DEBUG ; ENTRY POINT for programmer testing
  1.  ;
  1.  ; This entry point will not send any bulletins or HL7 messages.
  1.  ; The ACK message, HL7 errors, and bulletin errors will be written
  1.  ; to the screen instead.  If the error involves data stored in
  1.  ; the APCDALVR array, that array will be written out to
  1.  ; ^TMP("BHLBPS",$J,"APCDALVR",I), where I is the ACPDALVR index.
  1.  ;
  1.  N BHLMSH9,BHLSAN,X,X2,HL,HLMTIEN,HLNODE,HLQUIT,HLNEXT,HLECH
  1.  N %1,%DT,DISYS,IO,DIR,X,Y
  1.  ;
  1.  S DIR(0)="NO",DIR("T")=300,DIR("A")="Enter IEN for message to be processed" D ^DIR
  1.  S HLMTIEN=Y Q:"^"[HLMTIEN
  1.  ;
  1.  S HLNODE=$G(^HL(772,HLMTIEN,"IN",1,0))
  1.  I $E(HLNODE,1,3)'="MSH" W !,"MSH is missing" Q
  1.  ;
  1.  ; extract data from MSH
  1.  ;
  1.  S HL("FS")=$E(HLNODE,4)
  1.  S HL("ECH")=$P(HLNODE,HL("FS"),2)
  1.  S HL("SAN")=$P(HLNODE,HL("FS"),3)
  1.  S HL("RAN")=$P(HLNODE,HL("FS"),5)
  1.  S BHLMSH9=$P(HLNODE,HL("FS"),9)
  1.  S HL("MTN")=$P(BHLMSH9,$E(HL("ECH"),1),1)
  1.  S HL("ETN")=$P(BHLMSH9,$E(HL("ECH"),1),2)
  1.  S HL("MID")=$P(HLNODE,HL("FS"),10)
  1.  S HL("ACAT")=$P(HLNODE,HL("FS"),15)
  1.  S HL("APAT")=$P(HLNODE,HL("FS"),16)
  1.  ;
  1.  ; check MSH for missing data
  1.  ;
  1.  I HL("SAN")="" W !,"sending application is missing from MSH" Q
  1.  I HL("RAN")="" W !,"receiving application is missing from MSH" Q
  1.  I HL("MTN")="" W !,"message type is missing from MSH" Q
  1.  I HL("ETN")="" W !,"event type is missing from MSH" Q
  1.  ;
  1.  ;Validate message type
  1.  ;
  1.  S HL("MTP")=0
  1.  S:(HL("MTN")'="") HL("MTP")=+$O(^HL(771.2,"B",HL("MTN"),0))
  1.  I ('HL("MTP")) W !,"Invalid Message Type" Q
  1.  ;
  1.  ;Validate event type
  1.  ;
  1.  S HL("ETP")=0
  1.  S:(HL("ETN")'="") HL("ETP")=+$O(^HL(779.001,"B",HL("ETN"),0))
  1.  I ('HL("ETP")) W !,"Invalid Event Type" Q
  1.  ;
  1.  ;Validate sending application
  1.  ;
  1.  S HL("SAP")=+$O(^HL(771,"B",HL("SAN"),0))
  1.  I 'HL("SAP") S BHLSAN=$$UPPER^HLFNC(HL("RAN")),HL("SAP")=+$O(^HL(771,"B",BHLSAN,0))
  1.  I 'HL("SAP") W !,"Invalid Sending Application" Q
  1.  ;
  1.  ;Validate receiving application
  1.  ;
  1.  S HL("RAP")=+$O(^HL(771,"B",HL("RAN"),0))
  1.  I 'HL("RAP") S X=$$UPPER^HLFNC(HL("RAN")),HL("RAP")=+$O(^HL(771,"B",X,0))
  1.  I 'HL("RAP") W !,"Invalid Receiving Application"
  1.  S X2=$G(^HL(771,HL("RAP"),0))
  1.  I (X2="") W !,"Invalid Receiving Application" Q
  1.  I ($P(X2,"^",2)'="a") W !,"Receiving Application is Inactive" Q
  1.  ;
  1.  ;Find Server Protocol - based on message and event type
  1.  ;
  1.  S HL("EID")=+$O(^ORD(101,"AHL1",HL("SAP"),HL("MTP"),HL("ETP"),0))
  1.  I 'HL("EID") W !,"Invalid Event" Q
  1.  ;
  1.  ;Find Client Protocol - in ITEM multiple of Server Protocol
  1.  ;
  1.  S HL("EIDS")=0
  1.  F  S HL("EIDS")=+$O(^ORD(101,HL("EID"),10,"B",HL("EIDS"))) Q:('HL("EIDS"))  S X=$G(^ORD(101,HL("EIDS"),770))  Q:(($P(X,"^",2)=HL("RAP"))&($P(X,"^",3)=HL("MTP"))&($P(X,"^",4)=HL("ETP")))
  1.  I 'HL("EIDS") W !,"Invalid Receiving Application for this Event" Q
  1.  ;
  1.  W !,"Processing..."
  1.  S HLNODE=""
  1.  S HLQUIT=0
  1.  S HLNEXT="S HLQUIT=$O(^HL(772,HLMTIEN,""IN"",HLQUIT)) S:HLQUIT HLNODE=$G(^(HLQUIT,0))"
  1.  K BHLMSH9,BHLSAN,X,X2
  1.  K ^TMP("BHLBPS",$J)
  1.  S BHLDBUG=1
  1.  D START
  1.  W !,"Done"
  1.  K BHLDBUG
  1.  Q
  1.  ;
  1. DISPLAY ; Display result messages (programmer debug mode only)
  1.  ;
  1.  Q:'$G(BHLDBUG)
  1.  W !,"Error Message:",!,?3,$S($G(HLERR)="":"none",1:HLERR)
  1.  W !,"Error Data:",!,?3,$S($G(BHLEDATA)="":"none",1:BHLEDATA)
  1.  W !,"ACK message:"
  1.  I '$D(HLA) W !,?3,"none" Q
  1.  N I S I=0 F  S I=$O(HLA("HLA",I)) Q:I=""  W !,?3,HLA("HLA",I)
  1.  Q