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

IBCNEHL3.m

Go to the documentation of this file. 
  1. IBCNEHL3 ;DAOU/ALA - HL7 Process Incoming RPI Continued ;03-JUL-2002  ; Compiled June 2, 2005 14:20:19
  1.  ;;2.0;INTEGRATED BILLING;**300,416,497,506,595,621,602,737**;21-MAR-94;Build 19
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ;**Program Description**
  1.  ;  This is a continuation of IBCNEHL1 which processes an incoming
  1.  ;  RPI IIV message.
  1.  ;  
  1.  ;  This routine is based on IBCNEHLS which was introduced with patch 184, and subsequently
  1.  ;  patched with patch 271.  IBCNEHLS is obsolete and deleted with patch 300.
  1.  ;
  1.  ;
  1.  Q   ; no direct calls allow
  1.  ;
  1. ERROR(TQN,ERACT,ERCON,TRCN) ; Entry point
  1.  ; Input:  TQN - IEN for eIV Transmission Queue (#365.1), required
  1.  ;         ERACT - Error Action Code (#365.14), required
  1.  ;         ERCON - Error Condition Code (#365.17), required
  1.  ;         TRCN - Trace # from eIV Response (#365)
  1.  ;
  1.  ;         IIVSTAT - IIV status transmitted by EC
  1.  ;                   Note: MAP(IIVSTAT) = IIV STATUS IEN
  1.  N MSG,ERDESC,ERIEN,XMY,DA,DIE,DR
  1.  ;
  1.  I $G(TQN)="" G ERRORX
  1.  ;
  1.  ;/Removed the following lines of code as part of IB*2.0*506 but wanted to
  1.  ;/leave this code available if it should be needed in the future.
  1.  ; Scenarios:
  1.  ; #1 - If error message = "Resubmission Allowed" OR "Please Resubmit
  1.  ; Original Transaction" - set TQ
  1.  ; Fut Trans Dt to T + Comm Failure Days and Status to "Hold"
  1.  ;I ERACT="R"!(ERACT="P") D G ERRORX
  1.  ;. I $P($G(^IBCN(365.1,TQN,0)),U,9)="" D Q ; first time payer asked us to resubmit
  1.  ;. . ; Update IIV TQ fields: "Hold" (4), IIV Site Param Comm Failure Days
  1.  ;. . D UPDATE(TQN,4,+$P($G(^IBE(350.9,1,51)),U,5),ERACT)
  1.  ;. . ;
  1.  ;. ; payer asked us to resubmit for the 2nd time for this inquiry
  1.  ;. ; Update IIV TQ fields: "Response Received" (3), n/a ("")
  1.  ;. D UPDATE(TQN,3,"",ERACT,ERCON)
  1.  ;. ; clear future transmission date so it won't display in the buffer
  1.  ;. S DA=TQN,DIE="^IBCN(365.1,",DR=".09///@" D ^DIE
  1.  ;
  1.  ; #2 - If error message = "Please Wait 30 Days and Resubmit" - set TQ
  1.  ; Fut Trans Dt to T + 30 and Status to "Hold"
  1.  ;I ERACT="W" D G ERRORX
  1.  ;. ; Update IIV TQ fields: "Hold" (4), 30
  1.  ;. D UPDATE(TQN,4,30,ERACT)
  1.  ;
  1.  ; #3 - If error message = "Please Wait 10 Days and Resubmit" - set TQ
  1.  ; Fut Trans Dt to T + 10 and Status to "Hold"
  1.  ;I ERACT="X" D G ERRORX
  1.  ;. ; Update IIV TQ fields: "Hold" (4), 10
  1.  ;. D UPDATE(TQN,4,10,ERACT)
  1.  ;
  1.  ; #4 - If error message = "Resubmission Not Allowed" or
  1.  ; "Do not resubmit ...." OR "Please correct and resubmit"
  1.  ; - set TQ Status to "Response Received"
  1.  ; If we receive error txt, treat as an "N"
  1.  ;I ERACT="" S ERACT="N"
  1.  ;I ERACT="N"!(ERACT="Y")!(ERACT="S")!(ERACT="C") D G ERRORX
  1.  ;. ; Update IIV TQ fields: "Response Received" (3), n/a ("")
  1.  ;. D UPDATE(TQN,3,"",ERACT,ERCON)
  1.  ;
  1.  ; #5 - Error message is unfamiliar - new Error Action Code
  1.  ; *** Currently processed in IBCNEHL1 ***
  1.  ;/End of removed code for IB*2.0*506
  1.  ;
  1.  ; /IB*2.0*506 Beginning
  1.  ; For all Scenarios 1 thru 5, set TQ Status to "Response Received"
  1.  I ERACT="" S ERACT="N"
  1.  I ",R,P,W,X,N,Y,S,C,"[(","_ERACT_",") D  G ERRORX
  1.  . ; Update IIV TQ fields: "Response Received" (3), n/a ("")
  1.  . D UPDATE(TQN,3,"",ERACT,ERCON)
  1.  ; /IB*2.0*506 End
  1.  ;
  1. ERRORX ; ERROR exit pt
  1.  Q
  1.  ;
  1. UPDATE(TQN,TSTS,TDAYS,ERACT,ERCON) ;  Update Transmission Queue (#365.1)
  1.  ; Update/Create Buffer information as necessary
  1.  ; * If unsolicited error or negative Verification response do not
  1.  ; update TQ entry.  However, create a new Buffer entry.
  1.  ; Input Variables
  1.  ; ERACT,ERCON,IIVSTAT,TDAYS,TQN,TSTS
  1.  ;
  1.  ; Output Variables
  1.  ; IIVSTAT (updated)
  1.  ;
  1.  ; Init optional param
  1.  S ERCON=$G(ERCON)
  1.  ;
  1.  ; Init vars
  1.  N D,D0,DA,DFN,DI,DIC,DIE,DQ,DR,FTDT,IBDATA,IBIEN,IBQFL,IBSTS,IBSYM
  1.  N INSIEN,RSTYPE,SYMBOL,TQDATA,X
  1.  ;
  1.  ; If no ZEB segment received, set IIVSTAT to "V"
  1.  I $TR(IIVSTAT," ")="" S IIVSTAT="V"
  1.  ;
  1.  S TQDATA=$G(^IBCN(365.1,TQN,0))
  1.  I TQDATA="" G UPDATX
  1.  ;
  1.  ; Ins Buffer IEN
  1.  S IBIEN=$P(TQDATA,U,5)
  1.  S IBQFL=$P(TQDATA,U,11)
  1.  S RSTYPE=$P($G(^IBCN(365,RIEN,0)),U,10)
  1.  ;
  1.  ; If unsolicited error or negative Identification response DON'T
  1.  ; update TQ entry or Buffer (includes not creating a new buffer)
  1.  I RSTYPE="U",(IBQFL="I") G UPDATX
  1.  ;
  1.  I RSTYPE="U" S IBIEN=""  ; makes sure a new buffer is created
  1.  ;
  1.  ; Ins Buffer processing
  1.  I IBIEN'="" D
  1.  . ; Ins Buf data
  1.  . S IBDATA=$G(^IBA(355.33,+IBIEN,0))
  1.  . S IBSTS=$P(IBDATA,U,4)   ; Status
  1.  . S IBSYM=$P(IBDATA,U,12)  ; Symbol
  1.  . ; If IB status is (A)ccepted or (R)ejected or IB symbol is "*"
  1.  . ;  (verified) or IB symbol is "-" (denied), update TQ status to
  1.  . ;  Resp Rec'd (3) and DON'T update the Ins Buffer symbol
  1.  . I IBSTS="A"!(IBSTS="R")!(IBSYM=8)!(IBSYM=9) S TSTS=3 Q
  1.  . ; If TQ status is "Hold", update buffer symbol to "?" (10)
  1.  . I TSTS=4 D BUFF^IBCNEUT2(IBIEN,10) Q  ; Set buffer symbol to "?"
  1.  . ; If TQ status is "Response Received", update buffer symbol to "-" (9) for Error
  1.  . ; Action Codes ('N','Y','S') & Action Codes ('P','R', if 2nd time payer sent that code)
  1.  . I TSTS=3,(ERACT="N"!(ERACT="Y")!(ERACT="S")!(ERACT="C")!(ERACT="P")!(ERACT="R")) D  Q
  1.  .. S SYMBOL=MAP(IIVSTAT)
  1.  .. D BUFF^IBCNEUT2(IBIEN,SYMBOL) ; Set buffer symbol to EC value
  1.  .. D IIVPROC(IBIEN)   ; Set IIV process date & IIV status
  1.  . ; If TQ status is "Response Received", update buffer symbol to "!" (12 = B9) for new Error Action Code
  1.  . I TSTS=3,",W,X,R,P,C,N,Y,S,"'[(","_ERACT_",") D BUFF^IBCNEUT2(IBIEN,22) Q
  1.  ;
  1.  ; Non-Ins Buffer processing, create entry only for Verification queries
  1.  I IBIEN="",IBQFL="V" D
  1.  . ; Determine Patient DFN
  1.  . S DFN=$P(TQDATA,U,2)
  1.  . ; Determine Patient Ins record IEN
  1.  . S INSIEN=$P(TQDATA,U,13)  ; If INSIEN="" avoids TQ update
  1.  . ; If ERACT="C" symbol is passed by EC
  1.  . I ERACT="C" S SYMBOL=MAP(IIVSTAT) D BUF Q
  1.  . ;  Resubmission Not Allowed or Do Not Resubmit ...
  1.  . I ERACT="N"!(ERACT="Y")!(ERACT="S") S SYMBOL=MAP(IIVSTAT) D BUF Q
  1.  . ; An unknown error action - generate a '#'
  1.  . I ",W,X,R,P,C,N,Y,S,"'[(","_ERACT_",") S SYMBOL=22 D BUF Q
  1.  ;
  1.  I RSTYPE="U" G UPDATX  ; finished creating new buffer
  1.  ;
  1.  ; Update TQ record - Status
  1.  D SST^IBCNEUT2(TQN,TSTS)
  1.  ;
  1.  ; If TQ Status = "Hold", update TQ record - Future Transmission Date
  1.  I TSTS=4,+$G(TDAYS) D
  1.  . S FTDT=$$FMADD^XLFDT($$DT^XLFDT,TDAYS)
  1.  . S DIE="^IBCN(365.1,",DA=TQN,DR=".09///^S X=FTDT"
  1.  . D ^DIE
  1.  I TSTS=4,$P(TQDATA,U,8) D
  1.  . S DIE="^IBCN(365.1,",DA=TQN,DR=".08///0"
  1.  . D ^DIE
  1.  ;
  1. UPDATX ; UPDATE exit point
  1.  Q
  1.  ;
  1. PCK ; Payer Check
  1.  ;  Find the associated Response IEN
  1.  ;
  1.  ; Input Variables
  1.  ; MSGID
  1.  ;
  1.  ; Output Variables
  1.  ; RIEN,ERFLG
  1.  ;
  1.  ;IB*737/TAZ - Remove references to Most Popular Payer and "~NO PAYER"
  1.  ;
  1.  N BUFF,DA,DFN,DIE,DR,IEN,IERN,IN1DATA,MDTM,QFL,PAYR,PIEN,PP
  1.  N PRDATA,PRIEN,RSIEN,X
  1.  N TQIEN
  1.  ;
  1.  K ^TMP("IBCNEMID",$J)
  1.  D FIND^DIC(365,"","","P",MSGID,"","B","","","^TMP(""IBCNEMID"",$J)")
  1.  ;
  1.  S PP=0,QFL=0,(RIEN,PIEN)=""
  1.  S TQIEN=$O(^IBCN(365.1,"C",MSGID,""))
  1.  F  S PP=$O(^TMP("IBCNEMID",$J,"DILIST",PP)) Q:'PP  D  Q:QFL
  1.  . S PRIEN=$P(^TMP("IBCNEMID",$J,"DILIST",PP,0),U,1)
  1.  . ;
  1.  . ;  If this is a response w/o an IN1 segment
  1.  . ;  Get payer IEN from TQ as original response shell will change
  1.  . ;  if a payer response is received
  1.  . S IN1DATA=$S(EVENTYP=1:"",1:$$GIN1()) ; IB*2.0*621
  1.  . I IN1DATA="",PRIEN'="",TQIEN'="" D
  1.  ..  S QFL=1,PIEN=$P(^IBCN(365.1,TQIEN,0),U,3)
  1.  . ;
  1.  . I 'PIEN D PFN(IN1DATA) I 'PIEN S QFL=1 Q
  1.  . ;
  1.  . ; If message id/payer found & Response (#365) status is NOT
  1.  . ; 'Response Received' update the existing response entry (set RIEN)
  1.  . I $P(^IBCN(365,PRIEN,0),U,3)=PIEN,($P(^IBCN(365,PRIEN,0),U,6)'=3) D  Q
  1.  .. S RIEN=PRIEN,QFL=1
  1.  ..;
  1.  ..; If message id/payer found & Response (#365) status equals
  1.  . ; 'Response Received', RIEN is still null so that this tag knows
  1.  . ; to create a new unsolicited response entry
  1.  ;
  1.  ;  If message id/payer not found or unsolicited response, create new response entry
  1.  I RIEN="" D  Q:ERFLG
  1.  . I $G(PRIEN)'="" D
  1.  .. S PRDATA=$G(^IBCN(365,PRIEN,0))
  1.  .. S DFN=$P(PRDATA,U,2),IEN=$P(PRDATA,U,5),MDTM=$P(PRDATA,U,8)
  1.  . ;
  1.  . I PIEN="" D  Q:ERFLG
  1.  ..  S IN1DATA=$$GIN1()
  1.  ..  I IN1DATA]"" D PFN(IN1DATA) I 'PIEN S PIEN="",QFL=1
  1.  . S PAYR=PIEN,(RSTYPE,BUFF)=""
  1.  . ;I MDTM="" S MDTM=$$NOW^XLFDT
  1.  . D RESP^IBCNEDEQ
  1.  . S RIEN=RSIEN
  1.  ;
  1.  ; If no payer in response file, set it
  1.  ; IB*2*595/DM correctly identify a payer when the payer name begins with numbers 
  1.  I $G(PIEN)'="",$G(RIEN)'="",$P($G(^IBCN(365,RIEN,0)),U,3)="" D
  1.  . S DIE="^IBCN(365,",DA=RIEN,DR=".03////^S X=PIEN" D ^DIE ;stuff internal value for payer
  1.  Q
  1.  ;
  1. BUF ; Create Buffer Record if Doesn't Exist
  1.  ;
  1.  ; Input Variables
  1.  ; RIEN,RSTYPE,TQN
  1.  ;
  1.  ; Output Variables
  1.  ; ERROR,SYMBOL is killed,TQIEN and IRIEN may be reset
  1.  ;
  1.  N BUFF,IBFDA,UP
  1.  I $G(RSTYPE)="U" S (TQIEN,IRIEN)=""
  1.  D RP^IBCNEBF(RIEN,1)
  1.  S BUFF=+IBFDA
  1.  S UP(365,RIEN_",",.04)=+IBFDA
  1.  I RSTYPE="O" S UP(365.1,TQN_",",.05)=+IBFDA
  1.  D FILE^DIE("I","UP","ERROR")
  1.  K SYMBOL
  1.  Q
  1.  ;
  1. IIVPROC(BUFF) ; Set IIV Processed Date to current dt/tm & IIV stat (aka SYMBOL)
  1.  ; Input Variables
  1.  ; BUFF
  1.  ;
  1.  ; Output Variables
  1.  ; SYMBOL
  1.  ;
  1.  N IDUZ,UP
  1.  S UP(355.33,BUFF_",",.15)=$$NOW^XLFDT()
  1.  ;  Set IDUZ to the specific, non-human user.
  1.  S IDUZ=$$FIND1^DIC(200,"","X","INTERFACE,IB EIV")
  1.  D FILE^DIE("I","UP","ERROR")
  1.  ; set the symbol of the buffer entry
  1.  D BUFF^IBCNEUT2(BUFF,SYMBOL)  ; reset symbol to appropriate value
  1.  Q
  1.  ;
  1. PFN(IN1DATA) ;  Find Payer from HL7 msg
  1.  ;
  1.  ; Input Variables
  1.  ; IN1DATA, TRACE
  1.  ;
  1.  ; Output Variables
  1.  ; ERFLG,ERROR,PIEN
  1.  ;
  1.  N IERN,PAYRID
  1.  S PAYRID=$$CLNSTR^IBCNEHLU($P($P(IN1DATA,HLFS,4),$E(HL("ECH"))),HL("ECH"),$E(HL("ECH")))
  1.  S PIEN=+$$FIND1^DIC(365.12,"","MX",PAYRID)
  1.  I PIEN=0 D  Q
  1.  . S ERFLG=1,IERN=$$ERRN^IBCNEUT7("ERROR(""DIERR"")")
  1.  . S ERROR("DIERR",IERN,"TEXT",1)="National Id: "_PAYRID_" not found in Payer Table"
  1.  . S ERROR("DIERR",IERN,"TEXT",2)="for Trace Number: "_TRACE
  1.  Q
  1.  ;
  1. GIN1() ;Get IN1 segment
  1.  ;
  1.  ; Input Variables
  1.  ; HCT
  1.  ;
  1.  ; Returns value of SEGMT
  1.  ;
  1.  N IPCT,SEGMT
  1.  S IPCT=HCT,SEGMT=""
  1.  F  S IPCT=$O(^TMP($J,"IBCNEHLI",IPCT)) Q:IPCT=""  D
  1.  . I $E(^TMP($J,"IBCNEHLI",IPCT,0),1,3)="IN1" S SEGMT=^TMP($J,"IBCNEHLI",IPCT,0)
  1.  Q SEGMT
  1.  ;
  1.  ; =================================================================
  1. WARN ;  Create and send a response processing error warning message
  1.  ;
  1.  ; Input Variables
  1.  ; ERROR, TRACE
  1.  ;
  1.  ; Output Variables
  1.  ; ERFLG=1
  1.  ;
  1.  N MCT,MSG,SUBCNT,VEN,XMY
  1.  S VEN=0,MCT=9,ERFLG=1,SUBCNT=""
  1.  S MSG(1)="IMPORTANT: Error While Processing Response Message from the EC"
  1.  S MSG(2)="-------------------------------------------------------------"
  1.  S MSG(3)="*** IRM *** Please contact Help Desk because the"
  1.  S MSG(4)="response message received from the Eligibility Communicator"
  1.  S MSG(5)="could not be processed.  Programming changes may be necessary"
  1.  S MSG(6)="to properly handle the response."
  1.  S MSG(7)="The associated Trace # is "_$S($G(TRACE)="":"Unknown",1:TRACE)_". If applicable,"
  1.  S MSG(8)="please review the response with the eIV Response Report by Trace#."
  1.  S MSG(9)=" "
  1.  F  S VEN=$O(ERROR("DIERR",VEN)) Q:'VEN  D
  1.  .S MCT=MCT+1,MSG(MCT)="Error:"
  1.  .F  S SUBCNT=$O(ERROR("DIERR",VEN,"TEXT",SUBCNT)) Q:'SUBCNT  S MCT=MCT+1,MSG(MCT)=ERROR("DIERR",VEN,"TEXT",SUBCNT)
  1.  .S MCT=MCT+1,MSG(MCT)=" "
  1.  .I $G(ERROR("DIERR",VEN,"PARAM","FILE"))'="" S MCT=MCT+1,MSG(MCT)="File: "_ERROR("DIERR",VEN,"PARAM","FILE")
  1.  .I $G(ERROR("DIERR",VEN,"PARAM","IENS"))'="" S MCT=MCT+1,MSG(MCT)="IENS: "_ERROR("DIERR",VEN,"PARAM","IENS")
  1.  .I $G(ERROR("DIERR",VEN,"PARAM","FIELD"))'="" S MCT=MCT+1,MSG(MCT)="Field: "_ERROR("DIERR",VEN,"PARAM","FIELD")
  1.  .S MCT=MCT+1,MSG(MCT)=" "
  1.  .Q
  1.  D MSG^IBCNEUT5(MGRP,MSG(1),"MSG(",,.XMY)
  1.  Q
  1.  ;
  1.  ; =================================================================
  1. UEACT ; Send warning msg if Unknown Error Action Code was received or
  1.  ; encountered problem filing date
  1.  ;
  1.  ; Input Variables
  1.  ; ERROR, IBIEN, IBQFL, RIEN, RSTYPE, TQDATA, TRACE
  1.  ;
  1.  ; Output Variables
  1.  ; ERFLG=1 (SET IN WARN TAG)
  1.  ;
  1.  N DFN,SYMBOL
  1.  D WARN  ; send warning msg
  1.  ;
  1.  ; If the response could not be created or there is no associated TQ entry, stop processing
  1.  I '$G(RIEN)!(TQDATA="") Q
  1.  ;
  1.  ;  For an original response, set the Transmission Queue Status to 'Response Received' &
  1.  ;  update remaining retries to comm failure (5)
  1.  I $G(RSTYPE)="O" D SST^IBCNEUT2(TQN,3),RSTA^IBCNEUT7(TQN)
  1.  ;
  1.  ; If it is an identification and policy is not active don't
  1.  ; create buffer entry
  1.  I IBQFL="I",IIVSTAT'=1 Q
  1.  ;
  1.  ; If unsolicited message or no buffer in TQ, create new buffer entry
  1.  I RSTYPE="U" S IBIEN=""
  1.  I IBIEN="" D  Q
  1.  .  S DFN=$P(TQDATA,U,2)        ; Determine Patient DFN
  1.  .  S SYMBOL=22 D BUF^IBCNEHL3  ; Create a new buffer entry
  1.  ;
  1.  ;Update buffer symbol
  1.  D BUFF^IBCNEUT2(IBIEN,22)
  1.  ;
  1.  Q
  1.  ;
  1. CHK1() ; check auto-update criteria for patient who is the subscriber
  1.  ; called from tag AUTOUPD, uses variables defined there
  1.  ;
  1.  ; returns 1 if given policy satisfies auto-update criteria, returns 0 otherwise
  1.  N RES
  1.  S RES=0
  1.  I $P(RDATA13,U,2)'=$P(IDATA7,U,2) G CHK1X  ; Subscriber ID doesn't match   ; IB*2.0*497 compare subscriber ID data at their new locations
  1.  I $P(RDATA1,U,2)'=$P(IDATA3,U) G CHK1X  ; DOB doesn't match
  1.  I '$$NAMECMP^IBCNEHLU($P(RDATA13,U),$P(IDATA7,U)) G CHK1X  ; Insured's name doesn't match  ; IB*2.0*497 compare name of insured data at their new locations
  1.  S RES=1
  1. CHK1X ;
  1.  Q RES
  1.  ;
  1. CHK2(MWNRTYP) ; check auto-update criteria for patient who is not the subscriber
  1.  ; called from tag AUTOUPD, uses variables defined there
  1.  ;
  1.  ; returns 1 if policy satisfies auto-update criteria, returns 0 otherwise
  1.  N DOB,ID,IDATA5,IENS,NAME,PDOB,PNAME,RES
  1.  S RES=0
  1.  S IDATA5=$G(^DPT(IEN2,.312,IEN312,5))
  1.  S IENS=IEN2_","
  1.  S ID=$P(RDATA13,U,2)    ; IB*2.0*497 Subscriber ID needs to be retrieved from its new location
  1.  I ID'=$P(IDATA7,U,2),ID'=$P(IDATA5,U) G CHK2X  ; both Subscriber ID and Patient ID don't match ; IB*2.0*497 compare subscriber ID at new locations
  1.  S DOB=$P(RDATA1,U,2),PDOB=$$GET1^DIQ(2,IENS,.03,"I")
  1.  I DOB'=$P(IDATA3,U),DOB'=PDOB G CHK2X  ; both Subscriber and Patient DOB don't match
  1.  S NAME=$P(RDATA13,U),PNAME=$$GET1^DIQ(2,IENS,.01)   ; IB*2.0*497 get name of insured at its new location
  1.  I '+MWNRTYP,'$$NAMECMP^IBCNEHLU(NAME,$P(IDATA7,U)),'$$NAMECMP^IBCNEHLU(NAME,PNAME) G CHK2X  ; non-Medicare, both Subscriber and Patient name don't match ; IB*2*497
  1.  I +MWNRTYP,'$$NAMECMP^IBCNEHLU(NAME,PNAME) G CHK2X  ; Medicare, Patient name doesn't match
  1.  S RES=1
  1. CHK2X ;
  1.  Q RES
  1.  ;
  1. UPDIREC(RIEN,IEN312) ; IB*2*595/DM update INSUR RECORD IEN in the response file (#365,.12) 
  1.  ; RIEN - ien in eIV Response file (365)
  1.  ; IEN312 - ien in pat. insurance multiple (2.312)
  1.  ;
  1.  N DATA,ERROR,IENS
  1.  I RIEN'>0!(IEN312'>0) Q
  1.  ; IB*2*595/DM do not update TQ file. 
  1.  ; The proper INSUR RECORD IEN field is now located in the response file 
  1.  ;S IENS=$P($G(^IBCN(365,RIEN,0)),U,5)_"," I IENS="," Q
  1.  ;S DATA(365.1,IENS,.13)=IEN312
  1.  S DATA(365,RIEN_",",.12)=IEN312
  1.  D FILE^DIE("ET","DATA","ERROR")
  1.  Q
  1.  ;
  1. LCKERR ; send locking error message
  1.  N MSG,XMY
  1.  S MSG(1)="WARNING: Unable to Auto-file Response Message from the EC"
  1.  S MSG(2)="---------------------------------------------------------"
  1.  S MSG(3)="Failed to lock patient insurance entry:"
  1.  S MSG(4)="  Patient name - "_$$GET1^DIQ(2,DFN_",",.01)
  1.  S MSG(5)="  Insurance - "_$$GET1^DIQ(2.312,IENS,.01)
  1.  S MSG(6)="  IENS - "_$S($G(IENS)="":"Unknown",1:IENS)
  1.  S MSG(7)=" "
  1.  S MSG(8)="The response will be filed into Insurance Buffer instead."
  1.  S MSG(9)=" "
  1.  D MSG^IBCNEUT5(MGRP,MSG(1),"MSG(",,.XMY)
  1.  Q
  1.  ;