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