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

IBCNEHL1.m

Go to the documentation of this file. 
  1. IBCNEHL1 ;DAOU/ALA - HL7 Process Incoming RPI Messages ; 26-JUN-2002
  1.  ;;2.0;INTEGRATED BILLING;**300,345,416,444,438,497,506,549,593,601,595,621,631,668,687,702,732,743,771**;21-MAR-94;Build 26
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ;**Program Description**
  1.  ;  This program will process incoming IIV response messages.
  1.  ;  Including updating the record in the #365 File, updating
  1.  ;  the #355.33 record (if there is one or creating a new one)
  1.  ;  with the appropriate Buffer Symbol & data.
  1.  ;
  1.  ;  Variables
  1.  ;    ACK      - Acknowledgment (AA=Accepted, AE=Error)
  1.  ;    ERACT    - Error Action
  1.  ;    ERCON    - Error Condition
  1.  ;    ERFLG    - Error quit flag
  1.  ;    ERTXT    - Error Message Text
  1.  ;    HL       - Array of HL7 variables
  1.  ;    IBSEG    - Optional, array of fields in segment
  1.  ;    IIVSTAT  - EC generated flag interpreting status of response
  1.  ;                1 = + (auto-update requirement)
  1.  ;                6 = -
  1.  ;                V = #
  1.  ;                MBI% = %  ;will not receive from FSC, derived in FIL^IBCNEHL6
  1.  ;                MBI# = #  ;will not receive from FSC, derived in FIL^IBCNEHL6
  1.  ;    MAP      - Array that maps EC's IIV status flag to IIV STATUS TABLE (#365.15) IEN
  1.  ;    MSGID    - Original Message Control ID
  1.  ;    RIEN     - Response Record IEN
  1.  ;    SEG      - HL7 Segment Name
  1.  ;
  1.  ; IB*621/TAZ - Added EVENTYP to control type of event processing.
  1.  ;
  1.  ; *** With IB*702, the code in the tag AUTOFIL was moved to another routine.
  1.  ; *** Therefore, modifications from IB*631 and IB*687 are no longer found in this routine.
  1.  ;
  1.  ; IB*621/TAZ - Added to insure the routine is called via entry point EN with the event type.
  1.  Q  ;No direct entry to routine. Call label EN with parameter
  1.  ;
  1. EN(EVENTYP) ;Entry Point
  1.  ;EVENTYP=1 > EICD Identification Response (RPI^IO4)
  1.  ;EVENTYP=2 > Normal 271 Response (RPI^IO1) 
  1.  N ACK,AUTO,EBDA,ERACT,ERCON,ERFLG,ERROR,ERTXT,G2OFLG,HCT,HLCMP,HLREP,HLSCMP,IBTRACK
  1.  N IIVSTAT,IRIEN,MAP,MGRP,RIEN,RSUPDT,SEG,SUBID,TRACE,TRKIEN,UP
  1.  S (ERFLG,G2OFLG)=0,MGRP=$$MGRP^IBCNEUT5(),HCT=1,SUBID="",IIVSTAT=""
  1.  ;
  1.  S HLCMP=$E(HL("ECH"))    ;HL7 component separator
  1.  S HLSCMP=$E(HL("ECH"),4) ;HL7 subcomponent separator
  1.  S HLREP=$E(HL("ECH"),2)  ;HL7 repetition separator
  1.  ; Create map from EC to VistA
  1.  S MAP(1)=8,MAP(6)=9,MAP("V")=21   ;These are X12 codes mapped from EC to VistA
  1.  S MAP("MBI%")=26,MAP("MBI#")=27   ;These are NOT X12 codes from FSC - we derive them only for MBI responses
  1.  ;
  1.  ; Loop through the message & find each segment for processing
  1.  F  S HCT=$O(^TMP($J,"IBCNEHLI",HCT)) Q:HCT=""  D  Q:ERFLG
  1.  .D SPAR^IBCNEHLU
  1.  .S SEG=$G(IBSEG(1))
  1.  .; check if we are inside G2O group of segments
  1.  .I SEG="ZTY" S G2OFLG=1
  1.  .I G2OFLG,SEG'="ZTY",SEG'="CTD" S G2OFLG=0
  1.  .; If we are outside of Z_Benefit_group, kill EB multiple ien
  1.  .; I +$G(EBDA),".MSH.MSA.PRD.PID.GT1.IN1.IN3."[("."_SEG_".")!('G2OFLG&(SEG="CTD")) K EBDA
  1.  .;
  1.  .Q:SEG="PRD"  ;IB*497 PRD segment is not processed
  1.  .;
  1.  .;IB*621 - The ZMS is an exact copy of MSA segment. It was added for the PIN^I07 message
  1.  .; MSA logic closes out the file #365.1 & #365 - marks the status as "Response Received", (ien code=3)
  1.  .I SEG="MSA" D MSA^IBCNEHL2(.ERACT,.ERCON,.ERROR,.ERTXT,.IBSEG,MGRP,.RIEN,.TRACE,EVENTYP) Q
  1.  .I SEG="ZMS" D MSA^IBCNEHL2(.ERACT,.ERCON,.ERROR,.ERTXT,.IBSEG,MGRP,.RIEN,.TRACE,EVENTYP) Q
  1.  .;
  1.  .;Contact Seg
  1.  .I SEG="CTD",'G2OFLG D CTD^IBCNEHL2(.ERROR,.IBSEG,RIEN) Q
  1.  .;
  1.  .;Patient Seg
  1.  .I SEG="PID" D PID^IBCNEHL2(.ERFLG,.ERROR,.IBSEG,RIEN) Q
  1.  .;
  1.  .;Guarantor Seg
  1.  .;IB*621/TAZ Pass EVENTYP along
  1.  .I SEG="GT1" D GT1^IBCNEHL2(.ERROR,.IBSEG,RIEN,.SUBID,EVENTYP) Q
  1.  .;
  1.  .;Insurance Seg
  1.  .;IB*621/TAZ Pass EVENTYP along
  1.  .I SEG="IN1" D IN1^IBCNEHL2(.ERROR,.IBSEG,RIEN,SUBID,EVENTYP) Q
  1.  .;
  1.  .;Addt'l Insurance Seg
  1.  .;I SEG="IN2" ; for future expansion, add IN2 tag to IBCNEHL2
  1.  .;
  1.  .;Addt'l Insurance - Cert Seg
  1.  .I SEG="IN3" D IN3^IBCNEHL2(.ERROR,.IBSEG,RIEN) Q 
  1.  .;
  1.  .;IB*497 GROUP LEVEL REFERENCE ID segment (x12 loops 2100C & 2100D)
  1.  . I SEG="ZRF",'$D(EBDA) D GZRF^IBCNEHL5(.ERROR,.IBSEG,RIEN) Q
  1.  .;
  1.  .;Eligibility/Benefit Seg
  1.  .I SEG="ZEB" D ZEB^IBCNEHL2(.EBDA,.ERROR,.IBSEG,RIEN) Q
  1.  .;
  1.  .;Healthcare Delivery Seg
  1.  .I SEG="ZHS" D ZHS^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN) Q
  1.  .;
  1.  .;Benefit level Reference ID Seg (X12 loops 2110C & 2110D)
  1.  .I SEG="ZRF",+$G(EBDA) D ZRF^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN) Q  ;IB*497 add check to make sure z benefit group
  1.  .;
  1.  .;Subscriber Date Seg
  1.  .I SEG="ZSD" D ZSD^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN) Q
  1.  .;
  1.  .;Subscriber Additional Info Seg
  1.  .I SEG="ZII" D ZII^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN) Q
  1.  .;
  1.  .;Benefit Related Entity Seg
  1.  .I SEG="ZTY" D ZTY^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN) Q
  1.  .;
  1.  .;Benefit Related Entity Contact Seg
  1.  .I SEG="CTD",G2OFLG D G2OCTD^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN) Q
  1.  .;
  1.  .;Benefit Related Entity Notes Seg
  1.  .I SEG="NTE",+$G(EBDA) D EBNTE^IBCNEHL2(EBDA,.IBSEG,RIEN) Q
  1.  .;
  1.  .;Reject Reasons Seg
  1.  .I SEG="ERR" K ERDA D ERR^IBCNEHL4(.ERDA,.ERROR,.IBSEG,RIEN) Q
  1.  .;
  1.  .;Notes Seg
  1.  .I SEG="NTE",'$D(EBDA),+$G(ERDA) D NTE^IBCNEHL4(ERDA,.ERROR,.IBSEG,RIEN) Q
  1.  .;
  1.  .;Subscriber date seg (subscriber level)
  1.  .I SEG="ZTP" D ZTP^IBCNEHL4(.ERROR,.IBSEG,RIEN) Q
  1.  .;
  1.  .;Provider Code seg
  1.  .I SEG="ROL" D ROL^IBCNEHL5(.ERROR,.IBSEG,RIEN) Q  ;IB*497 - added
  1.  .;
  1.  .;Health Care Diagnosis Code seg
  1.  .I SEG="DG1" D DG1^IBCNEHL5(.ERROR,.IBSEG,RIEN) Q  ;IB*497 - added
  1.  .;
  1.  .;Military Personnel Information seg
  1.  .I SEG="ZMP" D ZMP^IBCNEHL5(.ERROR,.IBSEG,RIEN)    ;IB*497 - added
  1.  ;
  1.  ;
  1.  ;IB*621/TAZ - File EICD Identification Response
  1.  I EVENTYP=1 S TRKIEN=$$SVEICD^IBCNEHL7()
  1.  ;
  1.  ;IB*621/TAZ - Update EIV EICD TRACKING FILE for EICD verification Response 
  1.  I EVENTYP=2 D
  1.  . N D0,D1,FDA,IENS,TQN,EXT
  1.  . S TQN=$$GET1^DIQ(365,RIEN_",",.05,"I")
  1.  . S EXT=$$GET1^DIQ(365.1,TQN_",",.1,"I")
  1.  . I EXT'=4 Q
  1.  . S D0=$O(^IBCN(365.18,"C",TQN,"")) Q:'D0  S D1=$O(^IBCN(365.18,"C",TQN,D0,"")) Q:'D1
  1.  . S IENS=D1_","_D0_","
  1.  . S FDA(365.185,IENS,1.03)=RIEN
  1.  . I ERACT'=""!(ERTXT'="") S FDA(365.185,IENS,1.04)=0  ;Error response
  1.  . I IIVSTAT=1 S FDA(365.185,IENS,1.04)=1     ;Active
  1.  . I IIVSTAT=6 S FDA(365.185,IENS,1.04)=2     ;Inactive
  1.  . I IIVSTAT="V" S FDA(365.185,IENS,1.04)=3   ;Ambiguous
  1.  . D FILE^DIE("","FDA"),CLEAN^DILF
  1.  ;
  1.  ;IB*702/DTG - set variable for the auto eiv user (proxy in file #200)
  1.  N IBEIVUSR
  1.  S IBEIVUSR="AUTOUPDATE,IBEIV"
  1.  ;
  1.  S AUTO=$$AUTOUPD(RIEN)  ; 1=AUTO-UPDATE response  0=Save response to the buffer
  1.  ;
  1.  ;IB*771/DW ***Temporary fix required by VA eInsurance eBusiness team 'ERROR'
  1.  ;             is set when there is a problem filing part of the eIV payer
  1.  ;             response. (i.e. payer sends code that is not in file #353.1)
  1.  ;             Per eBiz, (Dec. 2023) do not let the existence of ERROR stop a
  1.  ;             eIV response from Auto-Updating.
  1.  ;   
  1.  ;
  1.  ;I $G(ACK)'="AE",$G(ERACT)="",$G(ERTXT)="",'$D(ERROR),+AUTO D  Q
  1.  I $G(ACK)'="AE",$G(ERACT)="",$G(ERTXT)="",+AUTO D  Q
  1.  . ;IB*743/TAZ - Updated code to lock the Buffer entries.
  1.  . N AUBUFF,AUOK,AULOCK
  1.  . S (AUOK,AULOCK)=0
  1.  . S AUBUFF=$$GET1^DIQ(365,RIEN,.04,"I")
  1.  . ;If Buffer Entry attempt to Lock, otherwise fall through to attempt to AUTOFIL.
  1.  . I AUBUFF D  I 'AUOK Q
  1.  .. N BUFFSTAT
  1.  .. ;Check for Buffer Status.  Quit if not ENTERED.
  1.  .. S BUFFSTAT=$$GET1^DIQ(355.33,AUBUFF,.04,"I") I BUFFSTAT'="E" Q
  1.  .. ;Get Lock
  1.  .. S AULOCK=$$BUFLOCK^IBCNEHL6(AUBUFF,1)
  1.  .. ;Re-Check Status.  Quit if not ENTERED.
  1.  .. S BUFFSTAT=$$GET1^DIQ(355.33,AUBUFF,.04,"I") I BUFFSTAT'="E" Q
  1.  .. S AUOK=1 ; regardless if locked we are going to update buffer
  1.  . D:$P(AUTO,U,3)'="" AUTOFIL($P(AUTO,U,2),$P(AUTO,U,3),$P(AUTO,U,6))
  1.  . D:$P(AUTO,U,4)'="" AUTOFIL($P(AUTO,U,2),$P(AUTO,U,4),$P(AUTO,U,6))
  1.  . ;Unlock global if locked.
  1.  . I AULOCK,$$BUFLOCK^IBCNEHL6(AUBUFF,0)
  1.  D FIL
  1.  ;
  1. ENX ;
  1.  Q
  1.  ;
  1.  ;=================================================================
  1. AUTOFIL(DFN,IEN312,ISSUB) ;Finish processing the response message - file directly into patient insurance
  1.  ;
  1.  ;IB*702/DTG - moved AUTOFIL to IBCNEHL5 due to routine file size
  1.  ;IB*732/CKB&TAZ - Loop through each insurance type IEN and file
  1.  N INSIEN,PCE
  1.  I $G(RIEN)="" G AUTOFILX
  1.  F PCE=1:1 S INSIEN=$P(IEN312,"~",PCE) Q:INSIEN=""  D
  1.  . D AUTOFIL^IBCNEHL5(DFN,INSIEN,ISSUB)
  1.  ;
  1. AUTOFILX ;
  1.  Q
  1.  ;
  1. GRPFILE(DFN,IEN312,RIEN,AFLG) ;IB*497 file data at node 12 & at subfiles 2.312, 9, 10 & 11
  1.  ;    DFN - file 2 ien
  1.  ; IEN312 - file 2.312 ien
  1.  ;   RIEN - file 365 ien
  1.  ;   AFLG - 1 if called from autoupdate, 0 if called from ins. buffer process entry
  1.  ;
  1.  ;output: 
  1.  ;     0 - entry update received an error when attempting to file
  1.  ;     1 - successful update
  1.  N DA,DATA12,DIAG,DIAG3121,ERFLG,ERROR,IENS,IENS365,IENS312,NODE,PROV,PROV332,REF,REF3129,Z,Z2
  1.  ;
  1.  ;retrieve external values of data located at node 12 of 365
  1.  S IENS=IEN312_","_DFN_","
  1.  D GETS^DIQ(365,RIEN,"12.01:12.07",,"MIL")
  1.  M DATA12(2.312,IENS)=MIL(365,RIEN_",")
  1.  D FILE^DIE("ET","DATA12","ERROR")
  1.  I $D(ERROR) D:AFLG WARN^IBCNEHL3 K ERROR
  1.  ;remove existing sub-file entries at nodes 9, 10, & 11 before update of new data
  1.  F NODE="9","10","11" D
  1.  . S DIK="^DPT("_DFN_",.312,"_IEN312_","_NODE_",",DA(2)=DFN,DA(1)=IEN312
  1.  . S DA=0 F  S DA=$O(^DPT(DFN,.312,IEN312,NODE,DA)) Q:DA=""!(DA?1.A)  D ^DIK
  1.  S IENS312="+1,"_IEN312_","_DFN_","
  1.  ;update node 9 data
  1.  S Z="" F  S Z=$O(^IBCN(365,RIEN,9,"B",Z)) Q:'Z  D
  1.  . S IENS365=$O(^IBCN(365,RIEN,9,"B",Z,""))_","_RIEN_","
  1.  . D GETS^DIQ(365.09,IENS365,"*",,"REF")
  1.  S Z2="" F  S Z2=$O(REF(365.09,Z2)) Q:Z2=""  M REF3129(2.3129,IENS312)=REF(365.09,Z2) D UPDATE^DIE("E","REF3129",,"ERROR") K REF3129 I $D(ERROR) D:AFLG WARN^IBCNEHL3 K ERROR
  1.  ;update node 10 data
  1.  S Z="" F  S Z=$O(^IBCN(365,RIEN,10,"B",Z)) Q:'Z  D
  1.  . S IENS365=$O(^IBCN(365,RIEN,10,"B",Z,""))_","_RIEN_","
  1.  . D GETS^DIQ(365.04,IENS365,"*",,"PROV")
  1.  S Z2="" F  S Z2=$O(PROV(365.04,Z2)) Q:Z2=""  M PROV332(2.332,IENS312)=PROV(365.04,Z2) D UPDATE^DIE("E","PROV332",,"ERROR") K PROV332 I $D(ERROR) D:AFLG WARN^IBCNEHL3 K ERROR
  1.  ;update node 11 data
  1.  S Z="" F  S Z=$O(^IBCN(365,RIEN,11,"B",Z)) Q:'Z  D
  1.  . S IENS365=$O(^IBCN(365,RIEN,11,"B",Z,""))_","_RIEN_","
  1.  . D GETS^DIQ(365.01,IENS365,"*",,"DIAG")
  1.  S Z2="" F  S Z2=$O(DIAG(365.01,Z2)) Q:Z2=""  M DIAG3121(2.31211,IENS312)=DIAG(365.01,Z2) D UPDATE^DIE("E","DIAG3121",,"ERROR") K DIAG3121 I $D(ERROR) D:AFLG WARN^IBCNEHL3 K ERROR
  1. GRPFILEX ;
  1.  Q $G(ERFLG)
  1.  ;
  1. FIL ;Finish processing the response message - file into insurance buffer
  1.  ;IB*601/DM - FIL moved to IBCNEHL6 due to routine size
  1.  D FIL^IBCNEHL6
  1.  Q
  1.  ;
  1. AUTOUPD(RIEN) ;
  1.  ;Returns "1^file 2 ien^file 2.312 ien^2nd file 2.312 ien^Medicare flag^subscriber flag", if entry
  1.  ; in file 365 is eligible for auto-update, returns 0 otherwise.
  1.  ;
  1.  ;Medicare flag: 1 for Medicare, 0 otherwise
  1.  ;Subscriber flag: 1 if patient is the subscriber, 0 otherwise
  1.  ;
  1.  ;For non-Medicare response: 1st file 2.312 ien is set, 2nd file 2.312 ien is empty, pieces 5-7 are empty
  1.  ;For Medicare response: 1st file 2.312 ien contains ien for Medicare Part A, 2nd file 2.312 ien contains ien for Medicare Part B,
  1.  ;                       either one may be empty, but at least one of them is set if entry is eligible.
  1.  ;
  1.  ;RIEN - ien in file 365
  1.  ;
  1.  ;IB*732/CKB&TAZ - New ISBLUE
  1.  N APPIEN,GDATA,GIEN,GNAME,GNUM,GNUM1,GOK,IEN2,IEN312,IEN36,IDATA0,IDATA3,ISSUB,MWNRA,MWNRB,MWNRIEN,MWNRTYP
  1.  N ONEPOL,PIEN,RDATA0,RDATA1,RES,TQIEN,IDATA7,RDATA13,RDATA14,ISBLUE
  1.  N IBGETTQ,IBGETWE,IBGETSTC,IBGETDEF,IBGETNOK
  1.  S RES=0
  1.  I +$G(RIEN)'>0 Q RES          ;Invalid ien for file 365
  1.  ;IB*595/DM if entry is missing from #200, file in buffer
  1.  I '$$FIND1^DIC(200,,"M",IBEIVUSR) Q RES  ; IB*702/DTG - use variable for name
  1.  ;
  1.  ;IB*549 - Moved up the next 5 lines.
  1.  S RDATA0=$G(^IBCN(365,RIEN,0)),RDATA1=$G(^IBCN(365,RIEN,1))
  1.  ;
  1.  ;IB*497 - longer fields for GROUP NAME, GROUP NUMBER, NAME OF INSURED, & SUBSCRIBER ID
  1.  S RDATA13=$G(^IBCN(365,RIEN,13)),RDATA14=$G(^IBCN(365,RIEN,14))
  1.  S PIEN=$P(RDATA0,U,3)
  1.  S ISBLUE=$$GET1^DIQ(365.12,PIEN_",",.09,"I") ;IB*732/CKB&TAZ
  1.  ;
  1.  ;IB*549 - Moved up the next 2 lines.
  1.  S MWNRIEN=$P($G(^IBE(350.9,1,51)),U,25),MWNRTYP=0,(MWNRA,MWNRB)=""
  1.  I PIEN=MWNRIEN S MWNRTYP=$$ISMCR^IBCNEHLU(RIEN)
  1.  ;
  1.  ;IB*549 - Added ',MWNRTYP' below to only quit for non-medicare policies
  1.  ;Only auto-update 'active policy' responses
  1.  I $G(IIVSTAT)'=1,'MWNRTYP Q RES
  1.  ;IB*668/TAZ - Changed app to EIV from IIV
  1.  I +PIEN>0 S APPIEN=$$PYRAPP^IBCNEUT5("EIV",PIEN)
  1.  I +$G(APPIEN)'>0 Q RES  ;couldn't find eIV application entry
  1.  ;
  1.  ;IB*601/HN Don't allow any entry with HMS SOI to auto-update
  1.  ;IB*595/HN Don't allow any entry with Contract Services SOI to auto-update
  1.  I $P(RDATA0,U,5)'="" I "^HMS^CONTRACT SERVICES^"[("^"_$$GET1^DIQ(365.1,$P(RDATA0,U,5)_",","SOURCE OF INFORMATION","E")_"^") Q RES  ; HAN IB*621
  1.  ;
  1.  ;IB*732/DTG start, allow auto update for some "Request Electronic Insurance Inquiry" requests
  1.  ;
  1.  ;Check dictionary 365.1 MANUAL REQUEST DATE/TIME Flag, Quit if Set.
  1.  ;I $P(RDATA0,U,5)'="",$P($G(^IBCN(365.1,$P(RDATA0,U,5),3)),U,1)'="" Q RES
  1.  ;
  1.  ; get values
  1.  S (IBGETTQ,IBGETDEF,IBGETWE,IBGETSTC)=""
  1.  ; Get 365.1 transmission queue number
  1.  S IBGETTQ=$$GET1^DIQ(365,RIEN_",",.05,"I") I IBGETTQ="" Q RES
  1.  ; Get 365.1 which extract
  1.  S IBGETNOK=0
  1.  S IBGETWE=$$GET1^DIQ(365.1,IBGETTQ_",",.1,"I") I IBGETWE=5 D  I IBGETNOK Q RES
  1.  . ; Get 350.9 default service type code
  1.  . S IBGETDEF=$$GET1^DIQ(350.9,1_",",60.01,"I") I IBGETDEF="" S IBGETNOK=1 Q
  1.  . ; Get 365 requested service type code
  1.  . S IBGETSTC=$$GET1^DIQ(365,RIEN_",",.15,"I") I IBGETSTC'=IBGETDEF S IBGETNOK=1 Q
  1.  ;
  1.  ;IB*732/DTG end, allow auto update for some "Request Electronic Insurance Inquiry" requests
  1.  ;
  1.  ;IB*668/TAZ - Changed to new field location
  1.  I '$$GET1^DIQ(365.121,APPIEN_","_PIEN_",",4.01,"I") Q RES  ; auto-update is OFF
  1.  S IEN2=$P(RDATA0,U,2) I +IEN2'>0 Q RES  ; couldn't find patient
  1.  S ONEPOL=$$ONEPOL^IBCNEHLU(PIEN,IEN2)
  1.  ;try to find a matching pat. insurance
  1.  ;IB*732/CKB&TAZ - Modify next two lines to check for ISBLUE
  1.  ;IB*771/CKB - remove the check for ISBLUE and RES
  1.  ;S IEN36="" F  S IEN36=$O(^DIC(36,"AC",PIEN,IEN36)) Q:IEN36=""  D  I 'ISBLUE&(RES>0) Q
  1.  ;.S IEN312="" F  S IEN312=$O(^DPT(IEN2,.312,"B",IEN36,IEN312)) Q:IEN312=""  D  I ('ISBLUE)&(RES>0&('+MWNRTYP)) Q
  1.  S IEN36="" F  S IEN36=$O(^DIC(36,"AC",PIEN,IEN36)) Q:IEN36=""  D
  1.  .S IEN312="" F  S IEN312=$O(^DPT(IEN2,.312,"B",IEN36,IEN312)) Q:IEN312=""  D
  1.  ..S IDATA0=$G(^DPT(IEN2,.312,IEN312,0)),IDATA3=$G(^DPT(IEN2,.312,IEN312,3))
  1.  ..S IDATA7=$G(^DPT(IEN2,.312,IEN312,7))   ;IB*497 (vd)
  1.  .. ; IB*771/DTG brought expired check into routine from IBCNEDE2
  1.  ..;I $$EXPIRED^IBCNEDE2($P(IDATA0,U,4)) Q  ;Insurance policy has expired
  1.  ..I $$EXPIRED($P(IDATA0,U,4)) Q  ;Insurance policy has expired
  1.  ..S ISSUB=$$PATISSUB^IBCNEHLU(IDATA0)
  1.  ..;Patient is the subscriber
  1.  ..I ISSUB,'$$CHK1^IBCNEHL3 Q
  1.  ..;Patient is the dependent
  1.  ..I 'ISSUB,'$$CHK2^IBCNEHL3(MWNRTYP) Q
  1.  ..;check group #
  1.  ..S GNUM=$P(RDATA14,U,2),GIEN=+$P(IDATA0,U,18),GOK=1  ;IB*497 - group # needs to be retrieved from new field
  1.  ..;check non-Medicare group #
  1.  ..I '+MWNRTYP D  Q:'GOK  ;Group # doesn't match
  1.  ...I 'ONEPOL D
  1.  ... .I GIEN'>0 S GOK=0 Q
  1.  ... .S GNUM1=$P($G(^IBA(355.3,GIEN,2)),U,2)   ;IB*497 (vd)
  1.  ... .I GNUM=""!(GNUM1="")!(GNUM'=GNUM1) S GOK=0
  1.  ...I ONEPOL D
  1.  ... .I GNUM'="",GIEN'="" S GNUM1=$P($G(^IBA(355.3,GIEN,2)),U,2) I GNUM1'="",GNUM'=GNUM1 S GOK=0  ;IB*497 (vd)
  1.  ..;check for Medicare part A/B
  1.  ..I +MWNRTYP D  Q:'GOK  ;Group # doesn't match
  1.  ...I GIEN'>0 S GOK=0 Q
  1.  ...S GDATA=$G(^IBA(355.3,GIEN,0))
  1.  ...I $P(GDATA,U,14)="A" D
  1.  ... .;IB*549 Change $P(MWNRTYP,U,2)="MA"!($P(MWNRTYP,U,2)="B")
  1.  ... .;           To     $P(MWNRTYP,U,5)="MA"!($P(MWNRTYP,U,5)="B")
  1.  ... .I $P(MWNRTYP,U,5)="MA"!($P(MWNRTYP,U,5)="B") S MWNRA=IEN312 Q
  1.  ... .S GOK=0
  1.  ...I $P(GDATA,U,14)="B" D
  1.  ... .;IB*549 Change $P(MWNRTYP,U,2)="MB"!($P(MWNRTYP,U,2)="B")
  1.  ... .;           To     $P(MWNRTYP,U,5)="MB"!($P(MWNRTYP,U,5)="B")
  1.  ... .I $P(MWNRTYP,U,5)="MB"!($P(MWNRTYP,U,5)="B") S MWNRB=IEN312 Q
  1.  ... .S GOK=0
  1.  ..;IB*732/CKB&TAZ - Restructured building RES string
  1.  ..I +MWNRTYP S RES=1_U_IEN2_U_MWNRA_U_MWNRB_U_1_U_ISSUB Q   ;Process MWNR
  1.  ..;IB*771/CKB - Process Blues and non-MWNR
  1.  ..I 'MWNRTYP D 
  1.  ... S P3=$P(RES,U,3),P3=P3_$S($L(P3):"~",1:"")_IEN312
  1.  ... S RES=1_U_IEN2_U_P3_U_U_0_U_ISSUB ;Process Blues and non-MWNR 
  1.  ..;I ISBLUE S P3=$P(RES,U,3),P3=P3_$S($L(P3):"~",1:"")_IEN312,RES=1_U_IEN2_U_P3_U_U_0_U_ISSUB Q  ;Process Blues
  1.  ..;S RES=1_U_IEN2_U_IEN312_U_U_0_U_ISSUB  ;Process non-MWNR and Non-Blue
  1.  Q RES
  1.  ;
  1. EBFILE(DFN,IEN312,RIEN,AFLG) ;File eligibility/benefit data from file 365 into file 2.312
  1.  ;Input:   DFN    - Internal Patient IEN
  1.  ;         IEN312 - Insurance multiple #
  1.  ;         RIEN   - file 365 ien
  1.  ;         AFLG   - 1 if called from autoupdate
  1.  ;                  0 if called from ins. buffer process entry
  1.  ;Returns: "" on success, ERFLG on failure. Also called from ACCEPT^IBCNBAR
  1.  ;         for manual processing of ins. buffer entry.
  1.  ;
  1.  Q $$EBFILE^IBCNEHL5(DFN,IEN312,RIEN,AFLG)  ;IB*549 moved because of routine size
  1.  ;
  1.  ; IB*771/DTG brought expired check into routine from IBCNEDE2
  1. EXPIRED(EXPDT) ; check if insurance policy has already expired
  1.  ; EXPDT - expiration date (2.312/3)
  1.  ; returns 1 if expiration date is in the past, 0 otherwise
  1.  N X1,X2
  1.  S X1=+$G(DT),X2=+$G(EXPDT)
  1.  I X1,X2 Q $S($$FMDIFF^XLFDT(DT,EXPDT,1)>0:1,1:0)
  1.  Q 0