- 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 Jan 18, 2025@03:15:55 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