IBCNEHLI ;DAOU/ALA - Incoming HL7 messages ;16-JUN-2002
;;2.0;INTEGRATED BILLING;**184,252,251,271,300,416,550,601,621**;21-MAR-94;Build 14
;;Per VA Directive 6402, this routine should not be modified.
;
;**Program Description**
; This program parses each incoming HL7 message.
;
EN ; Starting point - put message into a TMP global
;
N ACK,BUFF,DFN,ERACT,ERCON,ERFLG,ERTXT,EVENT,HCT,HLECH,HLEID
N HLEIDS,HLFS,HLQ,IBPRTCL,IDUZ,MGRP,MSGID,RDAT0,RIEN,SBDEP,SEG
N SEGMT,SEGMT2,TAG,TQN,TRACE,VRFDT,DISYS,IPCT,PAYRID,PIEN,CNT
N ERROR,IRIEN,RSTYPE,SUBID,TQIEN
N DA,EBDA,IBFDA,II,MSGP,SYMBOL,IBSEG,PP,PRIEN,QFL,IBIEN,TQDATA,IBQFL
N DATAMFK,EPHARM
;
K ^TMP($J,"IBCNEHLI")
F SEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D
. S CNT=0
. S ^TMP($J,"IBCNEHLI",SEGCNT,CNT)=HLNODE
. F S CNT=$O(HLNODE(CNT)) Q:'CNT D
.. S ^TMP($J,"IBCNEHLI",SEGCNT,CNT)=HLNODE(CNT)
;
; Get the eIV user
S IDUZ=$$FIND1^DIC(200,"","X","INTERFACE,IB EIV")
; Determine which protocol to use
S SEGMT=$G(^TMP($J,"IBCNEHLI",1,0))
I $E(SEGMT,1,3)'="MSH" D D ERR Q
. S MSG(1)="MSH Segment is not the first segment found"
. S MSG(2)="Please call the Help Desk and report this problem."
S HLFS=$E(SEGMT,4)
S EVENT=$P(SEGMT,HLFS,9),IBPRTCL=""
;
; The event type determines protocol
; IB*2.0*601 - Added logic for MFN^M01 event
I EVENT="MFN^M01" S TAG="TBL",IBPRTCL="IBCNE IIV MFN IN"
I EVENT="RPI^I01" S TAG="RSP",IBPRTCL="IBCNE IIV IN" I '$$HL7VAL G XIT
I EVENT="MFK^M01" S TAG="ACK",IBPRTCL="IBCNE IIV REGISTER"
;IB*2.0*621/TAZ - Added new event
I EVENT="PIN^I07" S TAG="EICD",IBPRTCL="IBCNE EIV PIN-I07 IN"
I IBPRTCL="" S MSG(1)="Unable to find a protocol for Event = "_EVENT D ERR G XIT
;
; Initialize the HL7 variables
D INIT^HLFNC2(IBPRTCL,.HL)
;
; Call the event tag
D @TAG
;
XIT K ^TMP($J,"IBCNEHLI"),HL,HLNEXT,HLNODE,HLQUIT,SEGCNT,EVENTYP
Q
;
TBL ; Table Update Processing
N IBACK
S IBACK="AE"
D ^IBCNEHLT
;
I ERFLG D ERR
K ERFLG
;
D ACK^IBCNEHLK
Q
;
RSP ; Response Processing
D EN^IBCNEHL1(2) ;IB*2.0*621 Added Parameter
;
K ACK,BUFF,DFN,ERACT,ERCON,ERFLG,ERTXT,EVENT,HCT,HL,HLECH,HLEID
K HLEIDS,HLFS,HLQ,IBPRTCL,IDUZ,MGRP,MSGID,RDAT0,RIEN,SBDEP,SEG
K SEGMT,SEGMT2,TAG,TQN,TRACE,VRFDT,DISYS,IPCT,PAYRID,PIEN
K ERROR,IRIEN,RSTYPE,SUBID,TQIEN
K DA,EBDA,IBFDA,II,MSGP,SYMBOL,IBSEG,PP,PRIEN,QFL
Q
;
;IB*2.0*621/TAZ - Added section to process the EICD Inquiry Response.
EICD ; Insurance Discovery Inquiry Response.
D EN^IBCNEHL1(1)
;
K ACK,BUFF,DFN,ERACT,ERCON,ERFLG,ERTXT,EVENT,HCT,HL,HLECH,HLEID
K HLEIDS,HLFS,HLQ,IBPRTCL,IDUZ,MGRP,MSGID,RDAT0,RIEN,SBDEP,SEG
K SEGMT,SEGMT2,TAG,TQN,TRACE,VRFDT,DISYS,IPCT,PAYRID,PIEN
K ERROR,IRIEN,RSTYPE,SUBID,TQIEN
K DA,EBDA,IBFDA,II,MSGP,SYMBOL,IBSEG,PP,PRIEN,QFL,IBTRACK,TRKIEN
Q
;
ACK ; Acknowledgement Processing
D ^IBCNEHLK
;
Q
;
ERR ; Process an error
S MGRP=$$MGRP^IBCNEUT5()
D MSG^IBCNEUT5(MGRP,"INCOMING eIV HL7 PROBLEM","MSG(")
K MSG,MGRP
Q
;
HL7VAL() ; Check for valid post 300 response
N X,HCT
S X=0,HCT=0
F S HCT=$O(^TMP($J,"IBCNEHLI",HCT)) Q:HCT="" D SPAR^IBCNEHLU I $G(IBSEG(1))="PRD" S X=1 Q
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEHLI 3201 printed Dec 13, 2024@02:14:42 Page 2
IBCNEHLI ;DAOU/ALA - Incoming HL7 messages ;16-JUN-2002
+1 ;;2.0;INTEGRATED BILLING;**184,252,251,271,300,416,550,601,621**;21-MAR-94;Build 14
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;**Program Description**
+5 ; This program parses each incoming HL7 message.
+6 ;
EN ; Starting point - put message into a TMP global
+1 ;
+2 NEW ACK,BUFF,DFN,ERACT,ERCON,ERFLG,ERTXT,EVENT,HCT,HLECH,HLEID
+3 NEW HLEIDS,HLFS,HLQ,IBPRTCL,IDUZ,MGRP,MSGID,RDAT0,RIEN,SBDEP,SEG
+4 NEW SEGMT,SEGMT2,TAG,TQN,TRACE,VRFDT,DISYS,IPCT,PAYRID,PIEN,CNT
+5 NEW ERROR,IRIEN,RSTYPE,SUBID,TQIEN
+6 NEW DA,EBDA,IBFDA,II,MSGP,SYMBOL,IBSEG,PP,PRIEN,QFL,IBIEN,TQDATA,IBQFL
+7 NEW DATAMFK,EPHARM
+8 ;
+9 KILL ^TMP($JOB,"IBCNEHLI")
+10 FOR SEGCNT=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+11 SET CNT=0
+12 SET ^TMP($JOB,"IBCNEHLI",SEGCNT,CNT)=HLNODE
+13 FOR
SET CNT=$ORDER(HLNODE(CNT))
if 'CNT
QUIT
Begin DoDot:2
+14 SET ^TMP($JOB,"IBCNEHLI",SEGCNT,CNT)=HLNODE(CNT)
End DoDot:2
End DoDot:1
+15 ;
+16 ; Get the eIV user
+17 SET IDUZ=$$FIND1^DIC(200,"","X","INTERFACE,IB EIV")
+18 ; Determine which protocol to use
+19 SET SEGMT=$GET(^TMP($JOB,"IBCNEHLI",1,0))
+20 IF $EXTRACT(SEGMT,1,3)'="MSH"
Begin DoDot:1
+21 SET MSG(1)="MSH Segment is not the first segment found"
+22 SET MSG(2)="Please call the Help Desk and report this problem."
End DoDot:1
DO ERR
QUIT
+23 SET HLFS=$EXTRACT(SEGMT,4)
+24 SET EVENT=$PIECE(SEGMT,HLFS,9)
SET IBPRTCL=""
+25 ;
+26 ; The event type determines protocol
+27 ; IB*2.0*601 - Added logic for MFN^M01 event
+28 IF EVENT="MFN^M01"
SET TAG="TBL"
SET IBPRTCL="IBCNE IIV MFN IN"
+29 IF EVENT="RPI^I01"
SET TAG="RSP"
SET IBPRTCL="IBCNE IIV IN"
IF '$$HL7VAL
GOTO XIT
+30 IF EVENT="MFK^M01"
SET TAG="ACK"
SET IBPRTCL="IBCNE IIV REGISTER"
+31 ;IB*2.0*621/TAZ - Added new event
+32 IF EVENT="PIN^I07"
SET TAG="EICD"
SET IBPRTCL="IBCNE EIV PIN-I07 IN"
+33 IF IBPRTCL=""
SET MSG(1)="Unable to find a protocol for Event = "_EVENT
DO ERR
GOTO XIT
+34 ;
+35 ; Initialize the HL7 variables
+36 DO INIT^HLFNC2(IBPRTCL,.HL)
+37 ;
+38 ; Call the event tag
+39 DO @TAG
+40 ;
XIT KILL ^TMP($JOB,"IBCNEHLI"),HL,HLNEXT,HLNODE,HLQUIT,SEGCNT,EVENTYP
+1 QUIT
+2 ;
TBL ; Table Update Processing
+1 NEW IBACK
+2 SET IBACK="AE"
+3 DO ^IBCNEHLT
+4 ;
+5 IF ERFLG
DO ERR
+6 KILL ERFLG
+7 ;
+8 DO ACK^IBCNEHLK
+9 QUIT
+10 ;
RSP ; Response Processing
+1 ;IB*2.0*621 Added Parameter
DO EN^IBCNEHL1(2)
+2 ;
+3 KILL ACK,BUFF,DFN,ERACT,ERCON,ERFLG,ERTXT,EVENT,HCT,HL,HLECH,HLEID
+4 KILL HLEIDS,HLFS,HLQ,IBPRTCL,IDUZ,MGRP,MSGID,RDAT0,RIEN,SBDEP,SEG
+5 KILL SEGMT,SEGMT2,TAG,TQN,TRACE,VRFDT,DISYS,IPCT,PAYRID,PIEN
+6 KILL ERROR,IRIEN,RSTYPE,SUBID,TQIEN
+7 KILL DA,EBDA,IBFDA,II,MSGP,SYMBOL,IBSEG,PP,PRIEN,QFL
+8 QUIT
+9 ;
+10 ;IB*2.0*621/TAZ - Added section to process the EICD Inquiry Response.
EICD ; Insurance Discovery Inquiry Response.
+1 DO EN^IBCNEHL1(1)
+2 ;
+3 KILL ACK,BUFF,DFN,ERACT,ERCON,ERFLG,ERTXT,EVENT,HCT,HL,HLECH,HLEID
+4 KILL HLEIDS,HLFS,HLQ,IBPRTCL,IDUZ,MGRP,MSGID,RDAT0,RIEN,SBDEP,SEG
+5 KILL SEGMT,SEGMT2,TAG,TQN,TRACE,VRFDT,DISYS,IPCT,PAYRID,PIEN
+6 KILL ERROR,IRIEN,RSTYPE,SUBID,TQIEN
+7 KILL DA,EBDA,IBFDA,II,MSGP,SYMBOL,IBSEG,PP,PRIEN,QFL,IBTRACK,TRKIEN
+8 QUIT
+9 ;
ACK ; Acknowledgement Processing
+1 DO ^IBCNEHLK
+2 ;
+3 QUIT
+4 ;
ERR ; Process an error
+1 SET MGRP=$$MGRP^IBCNEUT5()
+2 DO MSG^IBCNEUT5(MGRP,"INCOMING eIV HL7 PROBLEM","MSG(")
+3 KILL MSG,MGRP
+4 QUIT
+5 ;
HL7VAL() ; Check for valid post 300 response
+1 NEW X,HCT
+2 SET X=0
SET HCT=0
+3 FOR
SET HCT=$ORDER(^TMP($JOB,"IBCNEHLI",HCT))
if HCT=""
QUIT
DO SPAR^IBCNEHLU
IF $GET(IBSEG(1))="PRD"
SET X=1
QUIT
+4 QUIT X
