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**;21-MAR-94;Build 23
;;Per VA Directive 6402, this routine should not be modified.
;
;**Program Description**
; This program will process incoming IIV response messages.
; This includes updating the record in the IIV Response File,
; updating the Buffer record (if there is one & creating a new
; one if there isn't) 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*2.0*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
;
;IB*2.0*621/TAZ - Added EVENTYP to control type of event processing.
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*2*497 PRD segment is not processed
.;
.;IB*2.0*621 - The ZMS is an exact copy of MSA segment. It was added for the PIN^I07 message
.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 Segment
.I SEG="CTD",'G2OFLG D CTD^IBCNEHL2(.ERROR,.IBSEG,RIEN) Q
.;
.;Patient Segment
.I SEG="PID" D PID^IBCNEHL2(.ERFLG,.ERROR,.IBSEG,RIEN) Q
.;
.;Guarantor Segment
.;IB*2.0*621/TAZ Pass EVENTYP along
.I SEG="GT1" D GT1^IBCNEHL2(.ERROR,.IBSEG,RIEN,.SUBID,EVENTYP) Q
.;
.;Insurance Segment
.;IB*2.0*621/TAZ Pass EVENTYP along
.I SEG="IN1" D IN1^IBCNEHL2(.ERROR,.IBSEG,RIEN,SUBID,EVENTYP) Q
.;
.;Addt'l Insurance Segment
.;I SEG="IN2" ; for future expansion, add IN2 tag to IBCNEHL2
.;
.;Addt'l Insurance - Cert Segment
.I SEG="IN3" D IN3^IBCNEHL2(.ERROR,.IBSEG,RIEN) Q
.;
.;IB*2*497 GROUP LEVEL REFERENCE ID segment (x12 loops 2100C & 2100D)
. I SEG="ZRF",'$D(EBDA) D GZRF^IBCNEHL5(.ERROR,.IBSEG,RIEN) Q
.;
.;Eligibility/Benefit Segment
.I SEG="ZEB" D ZEB^IBCNEHL2(.EBDA,.ERROR,.IBSEG,RIEN) Q
.;
.;Healthcare Delivery Segment
.I SEG="ZHS" D ZHS^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN) Q
.;
.;Benefit level Reference ID Segment (X12 loops 2110C & 2110D)
.I SEG="ZRF",+$G(EBDA) D ZRF^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN) Q ;IB*2*497 add check to make sure z benefit group
.;
.;Subscriber Date Segment
.I SEG="ZSD" D ZSD^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN) Q
.;
.;Subscriber Additional Info Segment
.I SEG="ZII" D ZII^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN) Q
.;
.;Benefit Related Entity Segment
.I SEG="ZTY" D ZTY^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN) Q
.;
.;Benefit Related Entity Contact Segment
.I SEG="CTD",G2OFLG D G2OCTD^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN) Q
.;
.;Benefit Related Entity Notes Segment
.I SEG="NTE",+$G(EBDA) D EBNTE^IBCNEHL2(EBDA,.IBSEG,RIEN) Q
.;
.;Reject Reasons Segment
.I SEG="ERR" K ERDA D ERR^IBCNEHL4(.ERDA,.ERROR,.IBSEG,RIEN) Q
.;
.;Notes Segment
.I SEG="NTE",'$D(EBDA),+$G(ERDA) D NTE^IBCNEHL4(ERDA,.ERROR,.IBSEG,RIEN) Q
.;
.;Subscriber date segment (subscriber level)
.I SEG="ZTP" D ZTP^IBCNEHL4(.ERROR,.IBSEG,RIEN) Q
. ;ib*2*497 - add processing for ROL, DG1, & ZMP segments
. ;Provider Code segment
. I SEG="ROL" D ROL^IBCNEHL5(.ERROR,.IBSEG,RIEN) Q
. ;
. ;Health Care Diagnosis Code segment
. I SEG="DG1" D DG1^IBCNEHL5(.ERROR,.IBSEG,RIEN) Q
. ;
. ;Military Personnel Information segment
. I SEG="ZMP" D ZMP^IBCNEHL5(.ERROR,.IBSEG,RIEN)
;
;IB*2.0*621/TAZ - File EICD Identification Response
I EVENTYP=1 S TRKIEN=$$SVEICD^IBCNEHL7()
;IB*2.0*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
;
S AUTO=$$AUTOUPD(RIEN)
I $G(ACK)'="AE",$G(ERACT)="",$G(ERTXT)="",'$D(ERROR),+AUTO D Q
.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))
.Q
D FIL
;
ENX ;
Q
;
;=================================================================
AUTOFIL(DFN,IEN312,ISSUB) ;Finish processing the response message - file directly into patient insurance
;
N BUFF,DATA,ERROR,IENS,MIL,OKAY,PREL,RDATA0,RDATA1,RDATA5,RDATA13,RSTYPE,TQN,TSTAMP,XX ;IB*2.0*497 (vd)
;
Q:$G(RIEN)=""
S TSTAMP=$$NOW^XLFDT(),IENS=IEN312_","_DFN_","
S RDATA0=$G(^IBCN(365,RIEN,0)),RDATA1=$G(^IBCN(365,RIEN,1)),RDATA5=$G(^IBCN(365,RIEN,5))
S RDATA13=$G(^IBCN(365,RIEN,13)) ;IB*2.0*497 (vd)
S TQN=$P(RDATA0,U,5),RSTYPE=$P(RDATA0,U,10)
;\Beginning IB*2.0*549 - Modified the following lines
S XX=$$GET1^DIQ(2.312,IENS,7.01,"I")
I ISSUB,XX="" S DATA(2.312,IENS,7.01)=$P(RDATA13,U) ;Name
S XX=$$GET1^DIQ(2.312,IENS,3.01,"I")
I XX="" S DATA(2.312,IENS,3.01)=$P(RDATA1,U,2) ;DOB
S XX=$$GET1^DIQ(2.312,IENS,3.05,"I")
I XX="" S DATA(2.312,IENS,3.05)=$P(RDATA1,U,3) ;SSN
S XX=$$GET1^DIQ(2.312,IENS,6,"I")
I ISSUB,XX="" S DATA(2.312,IENS,6)=$P(RDATA1,U,8) ;Whose insurance
;pt. relationship (365,8.01) IB*2*497 code from 365,8.01 needs evaluation & possible conversion
S PREL=$$GET1^DIQ(365,RIEN,8.01)
S XX=$$GET1^DIQ(2.312,IENS,4.03,"I")
I ISSUB,XX="",PREL'="" D
. S DATA(2.312,IENS,4.03)=$$PREL^IBCNEHLU(2.312,4.03,PREL)
;\End of IB*2.0*549 changes.
;IB*2*595/DM moved the following 4 lines below
;S DATA(2.312,IENS,1.03)=TSTAMP ;Date last verified
;S DATA(2.312,IENS,1.04)="" ;Last verified by
;S DATA(2.312,IENS,1.05)=TSTAMP ;Date last edited
;S DATA(2.312,IENS,1.06)="" ;Last edited by
;S DATA(2.312,IENS,1.09)=5 ;Source of info = eIV
;IB*2.0*595/DM persist the original Source of Information
;note: external values are used to populate DATA
I $$GET1^DIQ(2.312,IENS,1.09,"I")="" D
. S XX=$$GET1^DIQ(365.1,TQN_",1,",3.02)
. I XX="" S XX="eIV"
. S DATA(2.312,IENS,1.09)=XX
;
;Set Subscriber address Fields if none of the fields are currently defined
;\Beginning IB*2.0*549 - Modified the following lines
S XX=$$GET1^DIQ(2.312,IENS,3.06,"I") ;Current Ins Street Line 1
I XX="" D
. S XX=$$GET1^DIQ(2.312,IENS,3.07,"I") ;Current Ins Street Line 2
. Q:XX'=""
. S XX=$$GET1^DIQ(2.312,IENS,3.08,"I") ;Current Ins City
. Q:XX'=""
. S XX=$$GET1^DIQ(2.312,IENS,3.09,"I") ;Current Ins State
. Q:XX'=""
. S XX=$$GET1^DIQ(2.312,IENS,3.1,"I") ;Current Ins Zip
. Q:XX'=""
. S XX=$$GET1^DIQ(2.312,IENS,3.13,"I") ;Current Ins Country
. Q:XX'=""
. S XX=$$GET1^DIQ(2.312,IENS,3.14,"I") ;Current Ins Country Subdivision
. Q:XX'=""
. S DATA(2.312,IENS,3.06)=$P(RDATA5,U) ;Street line 1
. S DATA(2.312,IENS,3.07)=$P(RDATA5,U,2) ;Street line 2
. S DATA(2.312,IENS,3.08)=$P(RDATA5,U,3) ;City
. S DATA(2.312,IENS,3.09)=$P(RDATA5,U,4) ;State
. S DATA(2.312,IENS,3.1)=$P(RDATA5,U,5) ;Zip
. S DATA(2.312,IENS,3.13)=$P(RDATA5,U,6) ;Country
. S DATA(2.312,IENS,3.14)=$P(RDATA5,U,7) ;Country subdivision
;\End of IB*2.0*549 changes.
;
L +^DPT(DFN,.312,IEN312):15 I '$T D LCKERR^IBCNEHL3 D FIL Q
I $D(DATA) D FILE^DIE("ET","DATA","ERROR") ;IB*2*595/DM make sure DATA has data
I $D(ERROR) D WARN^IBCNEHL3 K ERROR D FIL G AUTOFILX
;IB*2*595/DM set auto-update fields
;the EIV AUTO-UPDATE flag is now located in the IIV Response file
;set eIV auto-update field separately because of the trigger on field 1.05
;S DATA(2.312,IENS,4.04)="YES"
K DATA
S DATA(2.312,IENS,1.03)=TSTAMP ;Date last verified
S DATA(2.312,IENS,1.04)="AUTOUPDATE,IBEIV" ;Last verified by ; Edit with 595 was null
S DATA(2.312,IENS,1.05)=TSTAMP ;Date last edited
S DATA(2.312,IENS,1.06)="AUTOUPDATE,IBEIV" ;Last edited by ; Edit with 595 was null
D FILE^DIE("ET","DATA","ERROR")
I $D(ERROR) D WARN^IBCNEHL3 G AUTOFILX
;IB*2*595/DM set the insurance record IEN in the IIV Response file
;to track which policy was updated based on the response
D UPDIREC^IBCNEHL3(RIEN,IEN312)
;IB*2*595/DM set the EIV AUTO-UPDATE in the response file to signal auto-update
K DATA
S DATA(365,RIEN_",",.13)="YES"
D FILE^DIE("ET","DATA")
;
S ERFLG=$$GRPFILE(DFN,IEN312,RIEN,1)
I $G(ERFLG) G AUTOFILX ;IB*2*497 file data at 2.312, 9, 10 & 11 subfiles; if error is produced update buffer entry & then quit processing
;file new EB data
S ERFLG=$$EBFILE(DFN,IEN312,RIEN,1)
;bail out if something went wrong during filing of EB data
I $G(ERFLG) G AUTOFILX
;update insurance record ien in transmission queue
D UPDIREC^IBCNEHL3(RIEN,IEN312)
;For an original response, set the Transmission Queue Status to 'Response Received' &
;update remaining retries to comm failure (5)
I $G(RSTYPE)="O" D SST^IBCNEUT2(TQN,3),RSTA^IBCNEUT7(TQN)
;update buffer file entry so only stub remains & status is changed
S BUFF=+$P($G(^IBCN(365,RIEN,0)),U,4)
I BUFF D
.D STATUS^IBCNBEE(BUFF,"A",0,0,0) ;update buffer entry's status to accepted
.D DELDATA^IBCNBED(BUFF) ;delete buffer's insurance/patient data
;
;IB*2*631/vd - Start of new code for filing data to #355.36 file.
N BUFF,ERROR,FDA,WE
S WE=$$GET1^DIQ(365.1,TQN_",",.1,"I")
S BUFF=$$GET1^DIQ(365,RIEN_",",.04,"I")
S FDA(355.36,"+1,",.01)=$$NOW^XLFDT ;Date Processed
S FDA(355.36,"+1,",.02)=$S("^5^6^"[(U_WE_U):3,"^1^2^3^"[(U_WE_U):1,1:"") ;"WE" Should never be 4 or 7 at this point
S FDA(355.36,"+1,",.03)=$$GET1^DIQ(365.1,TQN_",",3.02,"I") ;Source of Information
S FDA(355.36,"+1,",.04)=$$GET1^DIQ(365,RIEN_",",.13,"I") ;EIV Auto-Update
S FDA(355.36,"+1,",.05)=TQN ;EIV Inquiry
S FDA(355.36,"+1,",.06)=RIEN ;IV Response
S FDA(355.36,"+1,",.07)=BUFF ;Buffer
S FDA(355.36,"+1,",.08)=WE ;Source of Request (Which Extract)
D UPDATE^DIE("","FDA",,"ERROR")
I $D(ERROR) D
. D MSG003^IBCNEMS1(.IBMSG,.ERROR,TQN,RIEN,BUFF)
. D MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV Problem: Error writing to the CREATION TO PROCESSING TRACKING File (#355.36)","IBMSG(")
;IB*2*631/vd - End of new code.
;
AUTOFILX ;
L -^DPT(DFN,.312,IEN312)
Q
;
GRPFILE(DFN,IEN312,RIEN,AFLG) ;ib*2*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 - returns 0 or 1
; 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*2*601/DM FIL()routine moved to IBCNEHL6 to meet SAC guidelines due to 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
;
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 ;IB*2.0*497
S RES=0
I +$G(RIEN)'>0 Q RES ;Invalid ien for file 365
;IB*2.0*595/DM if entry is missing from #200, file in buffer
I '$$FIND1^DIC(200,,"M","AUTOUPDATE,IBEIV") Q RES
;
;IB*2.0*549 - Moved up the next 5 lines. Originally, these lines were
; directly after line 'I $G(IIVSTAT)'=1 Q RES'
S RDATA0=$G(^IBCN(365,RIEN,0)),RDATA1=$G(^IBCN(365,RIEN,1))
;
;IB*2.0*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)
;
;IB*2.0*549 - Moved up the next 2 lines. Originally, these lines were
; directly after 'S IEN2=$P(RDATA0,U,2) I +IEN2'>0 Q RES'
S MWNRIEN=$P($G(^IBE(350.9,1,51)),U,25),MWNRTYP=0,(MWNRA,MWNRB)=""
I PIEN=MWNRIEN S MWNRTYP=$$ISMCR^IBCNEHLU(RIEN)
;
;IB*2.0*549 - Added ',MWNRTYP' below to only quit for non-medicare policies
I $G(IIVSTAT)'=1,'MWNRTYP Q RES ;Only auto-update 'active policy' responses
I +PIEN>0 S APPIEN=$$PYRAPP^IBCNEUT5("IIV",PIEN)
I +$G(APPIEN)'>0 Q RES ;couldn't find eIV application entry
;
;IB*2.0*601/HN Don't allow any entry with HMS SOI to auto-update
;IB*2.0*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*2.0*621
;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
I $P(^IBE(365.12,PIEN,1,APPIEN,0),U,7)=0 Q RES ; auto-accept 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
S IEN36="" F S IEN36=$O(^DIC(36,"AC",PIEN,IEN36)) Q:IEN36=""!(RES>0) D
.S IEN312="" F S IEN312=$O(^DPT(IEN2,.312,"B",IEN36,IEN312)) Q:IEN312=""!(RES>0&('+MWNRTYP)) 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*2.0*497 (vd)
..I $$EXPIRED^IBCNEDE2($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*2*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*2.0*497 (vd)
....I GNUM=""!(GNUM1="")!(GNUM'=GNUM1) S GOK=0
....Q
...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*2.0*497 (vd)
....Q
...Q
..;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*2.0*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
....Q
...I $P(GDATA,U,14)="B" D
....;IB*2.0*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
....Q
...Q
..S RES=1_U_IEN2_U_$S(+MWNRTYP:MWNRA_U_MWNRB_U_1,1:IEN312_U_U_0)
..S $P(RES,U,6)=ISSUB
..Q
.Q
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*2.0*549 moved because of routine size
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEHL1 19855 printed Feb 10, 2021@20:49:03 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**;21-MAR-94;Build 23
+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 ; This includes updating the record in the IIV Response File,
+7 ; updating the Buffer record (if there is one & creating a new
+8 ; one if there isn't) 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*2.0*621/TAZ - Added to insure the routine is called via entry point EN with the event type.
+30 ;No direct entry to routine. Call label EN with parameter
QUIT
+31 ;
+32 ;IB*2.0*621/TAZ - Added EVENTYP to control type of event processing.
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*2*497 PRD segment is not processed
if SEG="PRD"
QUIT
+25 ;
+26 ;IB*2.0*621 - The ZMS is an exact copy of MSA segment. It was added for the PIN^I07 message
+27 IF SEG="MSA"
DO MSA^IBCNEHL2(.ERACT,.ERCON,.ERROR,.ERTXT,.IBSEG,MGRP,.RIEN,.TRACE,EVENTYP)
QUIT
+28 IF SEG="ZMS"
DO MSA^IBCNEHL2(.ERACT,.ERCON,.ERROR,.ERTXT,.IBSEG,MGRP,.RIEN,.TRACE,EVENTYP)
QUIT
+29 ;
+30 ;Contact Segment
+31 IF SEG="CTD"
IF 'G2OFLG
DO CTD^IBCNEHL2(.ERROR,.IBSEG,RIEN)
QUIT
+32 ;
+33 ;Patient Segment
+34 IF SEG="PID"
DO PID^IBCNEHL2(.ERFLG,.ERROR,.IBSEG,RIEN)
QUIT
+35 ;
+36 ;Guarantor Segment
+37 ;IB*2.0*621/TAZ Pass EVENTYP along
+38 IF SEG="GT1"
DO GT1^IBCNEHL2(.ERROR,.IBSEG,RIEN,.SUBID,EVENTYP)
QUIT
+39 ;
+40 ;Insurance Segment
+41 ;IB*2.0*621/TAZ Pass EVENTYP along
+42 IF SEG="IN1"
DO IN1^IBCNEHL2(.ERROR,.IBSEG,RIEN,SUBID,EVENTYP)
QUIT
+43 ;
+44 ;Addt'l Insurance Segment
+45 ;I SEG="IN2" ; for future expansion, add IN2 tag to IBCNEHL2
+46 ;
+47 ;Addt'l Insurance - Cert Segment
+48 IF SEG="IN3"
DO IN3^IBCNEHL2(.ERROR,.IBSEG,RIEN)
QUIT
+49 ;
+50 ;IB*2*497 GROUP LEVEL REFERENCE ID segment (x12 loops 2100C & 2100D)
+51 IF SEG="ZRF"
IF '$DATA(EBDA)
DO GZRF^IBCNEHL5(.ERROR,.IBSEG,RIEN)
QUIT
+52 ;
+53 ;Eligibility/Benefit Segment
+54 IF SEG="ZEB"
DO ZEB^IBCNEHL2(.EBDA,.ERROR,.IBSEG,RIEN)
QUIT
+55 ;
+56 ;Healthcare Delivery Segment
+57 IF SEG="ZHS"
DO ZHS^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN)
QUIT
+58 ;
+59 ;Benefit level Reference ID Segment (X12 loops 2110C & 2110D)
+60 ;IB*2*497 add check to make sure z benefit group
IF SEG="ZRF"
IF +$GET(EBDA)
DO ZRF^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN)
QUIT
+61 ;
+62 ;Subscriber Date Segment
+63 IF SEG="ZSD"
DO ZSD^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN)
QUIT
+64 ;
+65 ;Subscriber Additional Info Segment
+66 IF SEG="ZII"
DO ZII^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN)
QUIT
+67 ;
+68 ;Benefit Related Entity Segment
+69 IF SEG="ZTY"
DO ZTY^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN)
QUIT
+70 ;
+71 ;Benefit Related Entity Contact Segment
+72 IF SEG="CTD"
IF G2OFLG
DO G2OCTD^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN)
QUIT
+73 ;
+74 ;Benefit Related Entity Notes Segment
+75 IF SEG="NTE"
IF +$GET(EBDA)
DO EBNTE^IBCNEHL2(EBDA,.IBSEG,RIEN)
QUIT
+76 ;
+77 ;Reject Reasons Segment
+78 IF SEG="ERR"
KILL ERDA
DO ERR^IBCNEHL4(.ERDA,.ERROR,.IBSEG,RIEN)
QUIT
+79 ;
+80 ;Notes Segment
+81 IF SEG="NTE"
IF '$DATA(EBDA)
IF +$GET(ERDA)
DO NTE^IBCNEHL4(ERDA,.ERROR,.IBSEG,RIEN)
QUIT
+82 ;
+83 ;Subscriber date segment (subscriber level)
+84 IF SEG="ZTP"
DO ZTP^IBCNEHL4(.ERROR,.IBSEG,RIEN)
QUIT
+85 ;ib*2*497 - add processing for ROL, DG1, & ZMP segments
+86 ;Provider Code segment
+87 IF SEG="ROL"
DO ROL^IBCNEHL5(.ERROR,.IBSEG,RIEN)
QUIT
+88 ;
+89 ;Health Care Diagnosis Code segment
+90 IF SEG="DG1"
DO DG1^IBCNEHL5(.ERROR,.IBSEG,RIEN)
QUIT
+91 ;
+92 ;Military Personnel Information segment
+93 IF SEG="ZMP"
DO ZMP^IBCNEHL5(.ERROR,.IBSEG,RIEN)
End DoDot:1
if ERFLG
QUIT
+94 ;
+95 ;IB*2.0*621/TAZ - File EICD Identification Response
+96 IF EVENTYP=1
SET TRKIEN=$$SVEICD^IBCNEHL7()
+97 ;IB*2.0*621/TAZ - Update EIV EICD TRACKING FILE for EICD verification Response
+98 IF EVENTYP=2
Begin DoDot:1
+99 NEW D0,D1,FDA,IENS,TQN,EXT
+100 SET TQN=$$GET1^DIQ(365,RIEN_",",.05,"I")
+101 SET EXT=$$GET1^DIQ(365.1,TQN_",",.1,"I")
+102 IF EXT'=4
QUIT
+103 SET D0=$ORDER(^IBCN(365.18,"C",TQN,""))
if 'D0
QUIT
SET D1=$ORDER(^IBCN(365.18,"C",TQN,D0,""))
if 'D1
QUIT
+104 SET IENS=D1_","_D0_","
+105 SET FDA(365.185,IENS,1.03)=RIEN
+106 ;Error response
IF ERACT'=""!(ERTXT'="")
SET FDA(365.185,IENS,1.04)=0
+107 ;Active
IF IIVSTAT=1
SET FDA(365.185,IENS,1.04)=1
+108 ;Inactive
IF IIVSTAT=6
SET FDA(365.185,IENS,1.04)=2
+109 ;Ambiguous
IF IIVSTAT="V"
SET FDA(365.185,IENS,1.04)=3
+110 DO FILE^DIE("","FDA")
DO CLEAN^DILF
End DoDot:1
+111 ;
+112 SET AUTO=$$AUTOUPD(RIEN)
+113 IF $GET(ACK)'="AE"
IF $GET(ERACT)=""
IF $GET(ERTXT)=""
IF '$DATA(ERROR)
IF +AUTO
Begin DoDot:1
+114 if $PIECE(AUTO,U,3)'=""
DO AUTOFIL($PIECE(AUTO,U,2),$PIECE(AUTO,U,3),$PIECE(AUTO,U,6))
+115 if $PIECE(AUTO,U,4)'=""
DO AUTOFIL($PIECE(AUTO,U,2),$PIECE(AUTO,U,4),$PIECE(AUTO,U,6))
+116 QUIT
End DoDot:1
QUIT
+117 DO FIL
+118 ;
ENX ;
+1 QUIT
+2 ;
+3 ;=================================================================
AUTOFIL(DFN,IEN312,ISSUB) ;Finish processing the response message - file directly into patient insurance
+1 ;
+2 ;IB*2.0*497 (vd)
NEW BUFF,DATA,ERROR,IENS,MIL,OKAY,PREL,RDATA0,RDATA1,RDATA5,RDATA13,RSTYPE,TQN,TSTAMP,XX
+3 ;
+4 if $GET(RIEN)=""
QUIT
+5 SET TSTAMP=$$NOW^XLFDT()
SET IENS=IEN312_","_DFN_","
+6 SET RDATA0=$GET(^IBCN(365,RIEN,0))
SET RDATA1=$GET(^IBCN(365,RIEN,1))
SET RDATA5=$GET(^IBCN(365,RIEN,5))
+7 ;IB*2.0*497 (vd)
SET RDATA13=$GET(^IBCN(365,RIEN,13))
+8 SET TQN=$PIECE(RDATA0,U,5)
SET RSTYPE=$PIECE(RDATA0,U,10)
+9 ;\Beginning IB*2.0*549 - Modified the following lines
+10 SET XX=$$GET1^DIQ(2.312,IENS,7.01,"I")
+11 ;Name
IF ISSUB
IF XX=""
SET DATA(2.312,IENS,7.01)=$PIECE(RDATA13,U)
+12 SET XX=$$GET1^DIQ(2.312,IENS,3.01,"I")
+13 ;DOB
IF XX=""
SET DATA(2.312,IENS,3.01)=$PIECE(RDATA1,U,2)
+14 SET XX=$$GET1^DIQ(2.312,IENS,3.05,"I")
+15 ;SSN
IF XX=""
SET DATA(2.312,IENS,3.05)=$PIECE(RDATA1,U,3)
+16 SET XX=$$GET1^DIQ(2.312,IENS,6,"I")
+17 ;Whose insurance
IF ISSUB
IF XX=""
SET DATA(2.312,IENS,6)=$PIECE(RDATA1,U,8)
+18 ;pt. relationship (365,8.01) IB*2*497 code from 365,8.01 needs evaluation & possible conversion
+19 SET PREL=$$GET1^DIQ(365,RIEN,8.01)
+20 SET XX=$$GET1^DIQ(2.312,IENS,4.03,"I")
+21 IF ISSUB
IF XX=""
IF PREL'=""
Begin DoDot:1
+22 SET DATA(2.312,IENS,4.03)=$$PREL^IBCNEHLU(2.312,4.03,PREL)
End DoDot:1
+23 ;\End of IB*2.0*549 changes.
+24 ;IB*2*595/DM moved the following 4 lines below
+25 ;S DATA(2.312,IENS,1.03)=TSTAMP ;Date last verified
+26 ;S DATA(2.312,IENS,1.04)="" ;Last verified by
+27 ;S DATA(2.312,IENS,1.05)=TSTAMP ;Date last edited
+28 ;S DATA(2.312,IENS,1.06)="" ;Last edited by
+29 ;S DATA(2.312,IENS,1.09)=5 ;Source of info = eIV
+30 ;IB*2.0*595/DM persist the original Source of Information
+31 ;note: external values are used to populate DATA
+32 IF $$GET1^DIQ(2.312,IENS,1.09,"I")=""
Begin DoDot:1
+33 SET XX=$$GET1^DIQ(365.1,TQN_",1,",3.02)
+34 IF XX=""
SET XX="eIV"
+35 SET DATA(2.312,IENS,1.09)=XX
End DoDot:1
+36 ;
+37 ;Set Subscriber address Fields if none of the fields are currently defined
+38 ;\Beginning IB*2.0*549 - Modified the following lines
+39 ;Current Ins Street Line 1
SET XX=$$GET1^DIQ(2.312,IENS,3.06,"I")
+40 IF XX=""
Begin DoDot:1
+41 ;Current Ins Street Line 2
SET XX=$$GET1^DIQ(2.312,IENS,3.07,"I")
+42 if XX'=""
QUIT
+43 ;Current Ins City
SET XX=$$GET1^DIQ(2.312,IENS,3.08,"I")
+44 if XX'=""
QUIT
+45 ;Current Ins State
SET XX=$$GET1^DIQ(2.312,IENS,3.09,"I")
+46 if XX'=""
QUIT
+47 ;Current Ins Zip
SET XX=$$GET1^DIQ(2.312,IENS,3.1,"I")
+48 if XX'=""
QUIT
+49 ;Current Ins Country
SET XX=$$GET1^DIQ(2.312,IENS,3.13,"I")
+50 if XX'=""
QUIT
+51 ;Current Ins Country Subdivision
SET XX=$$GET1^DIQ(2.312,IENS,3.14,"I")
+52 if XX'=""
QUIT
+53 ;Street line 1
SET DATA(2.312,IENS,3.06)=$PIECE(RDATA5,U)
+54 ;Street line 2
SET DATA(2.312,IENS,3.07)=$PIECE(RDATA5,U,2)
+55 ;City
SET DATA(2.312,IENS,3.08)=$PIECE(RDATA5,U,3)
+56 ;State
SET DATA(2.312,IENS,3.09)=$PIECE(RDATA5,U,4)
+57 ;Zip
SET DATA(2.312,IENS,3.1)=$PIECE(RDATA5,U,5)
+58 ;Country
SET DATA(2.312,IENS,3.13)=$PIECE(RDATA5,U,6)
+59 ;Country subdivision
SET DATA(2.312,IENS,3.14)=$PIECE(RDATA5,U,7)
End DoDot:1
+60 ;\End of IB*2.0*549 changes.
+61 ;
+62 LOCK +^DPT(DFN,.312,IEN312):15
IF '$TEST
DO LCKERR^IBCNEHL3
DO FIL
QUIT
+63 ;IB*2*595/DM make sure DATA has data
IF $DATA(DATA)
DO FILE^DIE("ET","DATA","ERROR")
+64 IF $DATA(ERROR)
DO WARN^IBCNEHL3
KILL ERROR
DO FIL
GOTO AUTOFILX
+65 ;IB*2*595/DM set auto-update fields
+66 ;the EIV AUTO-UPDATE flag is now located in the IIV Response file
+67 ;set eIV auto-update field separately because of the trigger on field 1.05
+68 ;S DATA(2.312,IENS,4.04)="YES"
+69 KILL DATA
+70 ;Date last verified
SET DATA(2.312,IENS,1.03)=TSTAMP
+71 ;Last verified by ; Edit with 595 was null
SET DATA(2.312,IENS,1.04)="AUTOUPDATE,IBEIV"
+72 ;Date last edited
SET DATA(2.312,IENS,1.05)=TSTAMP
+73 ;Last edited by ; Edit with 595 was null
SET DATA(2.312,IENS,1.06)="AUTOUPDATE,IBEIV"
+74 DO FILE^DIE("ET","DATA","ERROR")
+75 IF $DATA(ERROR)
DO WARN^IBCNEHL3
GOTO AUTOFILX
+76 ;IB*2*595/DM set the insurance record IEN in the IIV Response file
+77 ;to track which policy was updated based on the response
+78 DO UPDIREC^IBCNEHL3(RIEN,IEN312)
+79 ;IB*2*595/DM set the EIV AUTO-UPDATE in the response file to signal auto-update
+80 KILL DATA
+81 SET DATA(365,RIEN_",",.13)="YES"
+82 DO FILE^DIE("ET","DATA")
+83 ;
+84 SET ERFLG=$$GRPFILE(DFN,IEN312,RIEN,1)
+85 ;IB*2*497 file data at 2.312, 9, 10 & 11 subfiles; if error is produced update buffer entry & then quit processing
IF $GET(ERFLG)
GOTO AUTOFILX
+86 ;file new EB data
+87 SET ERFLG=$$EBFILE(DFN,IEN312,RIEN,1)
+88 ;bail out if something went wrong during filing of EB data
+89 IF $GET(ERFLG)
GOTO AUTOFILX
+90 ;update insurance record ien in transmission queue
+91 DO UPDIREC^IBCNEHL3(RIEN,IEN312)
+92 ;For an original response, set the Transmission Queue Status to 'Response Received' &
+93 ;update remaining retries to comm failure (5)
+94 IF $GET(RSTYPE)="O"
DO SST^IBCNEUT2(TQN,3)
DO RSTA^IBCNEUT7(TQN)
+95 ;update buffer file entry so only stub remains & status is changed
+96 SET BUFF=+$PIECE($GET(^IBCN(365,RIEN,0)),U,4)
+97 IF BUFF
Begin DoDot:1
+98 ;update buffer entry's status to accepted
DO STATUS^IBCNBEE(BUFF,"A",0,0,0)
+99 ;delete buffer's insurance/patient data
DO DELDATA^IBCNBED(BUFF)
End DoDot:1
+100 ;
+101 ;IB*2*631/vd - Start of new code for filing data to #355.36 file.
+102 NEW BUFF,ERROR,FDA,WE
+103 SET WE=$$GET1^DIQ(365.1,TQN_",",.1,"I")
+104 SET BUFF=$$GET1^DIQ(365,RIEN_",",.04,"I")
+105 ;Date Processed
SET FDA(355.36,"+1,",.01)=$$NOW^XLFDT
+106 ;"WE" Should never be 4 or 7 at this point
SET FDA(355.36,"+1,",.02)=$SELECT("^5^6^"[(U_WE_U):3,"^1^2^3^"[(U_WE_U):1,1:"")
+107 ;Source of Information
SET FDA(355.36,"+1,",.03)=$$GET1^DIQ(365.1,TQN_",",3.02,"I")
+108 ;EIV Auto-Update
SET FDA(355.36,"+1,",.04)=$$GET1^DIQ(365,RIEN_",",.13,"I")
+109 ;EIV Inquiry
SET FDA(355.36,"+1,",.05)=TQN
+110 ;IV Response
SET FDA(355.36,"+1,",.06)=RIEN
+111 ;Buffer
SET FDA(355.36,"+1,",.07)=BUFF
+112 ;Source of Request (Which Extract)
SET FDA(355.36,"+1,",.08)=WE
+113 DO UPDATE^DIE("","FDA",,"ERROR")
+114 IF $DATA(ERROR)
Begin DoDot:1
+115 DO MSG003^IBCNEMS1(.IBMSG,.ERROR,TQN,RIEN,BUFF)
+116 DO MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV Problem: Error writing to the CREATION TO PROCESSING TRACKING File (#355.36)","IBMSG(")
End DoDot:1
+117 ;IB*2*631/vd - End of new code.
+118 ;
AUTOFILX ;
+1 LOCK -^DPT(DFN,.312,IEN312)
+2 QUIT
+3 ;
GRPFILE(DFN,IEN312,RIEN,AFLG) ;ib*2*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 ;output - returns 0 or 1
+6 ; 0 - entry update received an error when attempting to file
+7 ; 1 - successful update
+8 NEW DA,DATA12,DIAG,DIAG3121,ERFLG,ERROR,IENS,IENS365,IENS312,NODE,PROV,PROV332,REF,REF3129,Z,Z2
+9 ;retrieve external values of data located at node 12 of 365
+10 SET IENS=IEN312_","_DFN_","
+11 DO GETS^DIQ(365,RIEN,"12.01:12.07",,"MIL")
+12 MERGE DATA12(2.312,IENS)=MIL(365,RIEN_",")
+13 DO FILE^DIE("ET","DATA12","ERROR")
+14 IF $DATA(ERROR)
if AFLG
DO WARN^IBCNEHL3
KILL ERROR
+15 ;remove existing sub-file entries at nodes 9, 10, & 11 before update of new data
+16 FOR NODE="9","10","11"
Begin DoDot:1
+17 SET DIK="^DPT("_DFN_",.312,"_IEN312_","_NODE_","
SET DA(2)=DFN
SET DA(1)=IEN312
+18 SET DA=0
FOR
SET DA=$ORDER(^DPT(DFN,.312,IEN312,NODE,DA))
if DA=""!(DA?1.A)
QUIT
DO ^DIK
End DoDot:1
+19 SET IENS312="+1,"_IEN312_","_DFN_","
+20 ;update node 9 data
+21 SET Z=""
FOR
SET Z=$ORDER(^IBCN(365,RIEN,9,"B",Z))
if 'Z
QUIT
Begin DoDot:1
+22 SET IENS365=$ORDER(^IBCN(365,RIEN,9,"B",Z,""))_","_RIEN_","
+23 DO GETS^DIQ(365.09,IENS365,"*",,"REF")
End DoDot:1
+24 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
+25 ;update node 10 data
+26 SET Z=""
FOR
SET Z=$ORDER(^IBCN(365,RIEN,10,"B",Z))
if 'Z
QUIT
Begin DoDot:1
+27 SET IENS365=$ORDER(^IBCN(365,RIEN,10,"B",Z,""))_","_RIEN_","
+28 DO GETS^DIQ(365.04,IENS365,"*",,"PROV")
End DoDot:1
+29 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
+30 ;update node 11 data
+31 SET Z=""
FOR
SET Z=$ORDER(^IBCN(365,RIEN,11,"B",Z))
if 'Z
QUIT
Begin DoDot:1
+32 SET IENS365=$ORDER(^IBCN(365,RIEN,11,"B",Z,""))_","_RIEN_","
+33 DO GETS^DIQ(365.01,IENS365,"*",,"DIAG")
End DoDot:1
+34 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*2*601/DM FIL()routine moved to IBCNEHL6 to meet SAC guidelines due to 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 NEW APPIEN,GDATA,GIEN,GNAME,GNUM,GNUM1,GOK,IEN2,IEN312,IEN36,IDATA0,IDATA3,ISSUB,MWNRA,MWNRB,MWNRIEN,MWNRTYP
+14 ;IB*2.0*497
NEW ONEPOL,PIEN,RDATA0,RDATA1,RES,TQIEN,IDATA7,RDATA13,RDATA14
+15 SET RES=0
+16 ;Invalid ien for file 365
IF +$GET(RIEN)'>0
QUIT RES
+17 ;IB*2.0*595/DM if entry is missing from #200, file in buffer
+18 IF '$$FIND1^DIC(200,,"M","AUTOUPDATE,IBEIV")
QUIT RES
+19 ;
+20 ;IB*2.0*549 - Moved up the next 5 lines. Originally, these lines were
+21 ; directly after line 'I $G(IIVSTAT)'=1 Q RES'
+22 SET RDATA0=$GET(^IBCN(365,RIEN,0))
SET RDATA1=$GET(^IBCN(365,RIEN,1))
+23 ;
+24 ;IB*2.0*497 - longer fields for GROUP NAME, GROUP NUMBER, NAME OF INSURED, & SUBSCRIBER ID
+25 SET RDATA13=$GET(^IBCN(365,RIEN,13))
SET RDATA14=$GET(^IBCN(365,RIEN,14))
+26 SET PIEN=$PIECE(RDATA0,U,3)
+27 ;
+28 ;IB*2.0*549 - Moved up the next 2 lines. Originally, these lines were
+29 ; directly after 'S IEN2=$P(RDATA0,U,2) I +IEN2'>0 Q RES'
+30 SET MWNRIEN=$PIECE($GET(^IBE(350.9,1,51)),U,25)
SET MWNRTYP=0
SET (MWNRA,MWNRB)=""
+31 IF PIEN=MWNRIEN
SET MWNRTYP=$$ISMCR^IBCNEHLU(RIEN)
+32 ;
+33 ;IB*2.0*549 - Added ',MWNRTYP' below to only quit for non-medicare policies
+34 ;Only auto-update 'active policy' responses
IF $GET(IIVSTAT)'=1
IF 'MWNRTYP
QUIT RES
+35 IF +PIEN>0
SET APPIEN=$$PYRAPP^IBCNEUT5("IIV",PIEN)
+36 ;couldn't find eIV application entry
IF +$GET(APPIEN)'>0
QUIT RES
+37 ;
+38 ;IB*2.0*601/HN Don't allow any entry with HMS SOI to auto-update
+39 ;IB*2.0*595/HN Don't allow any entry with Contract Services SOI to auto-update
+40 ; HAN IB*2.0*621
IF $PIECE(RDATA0,U,5)'=""
IF "^HMS^CONTRACT SERVICES^"[("^"_$$GET1^DIQ(365.1,$PIECE(RDATA0,U,5)_",","SOURCE OF INFORMATION","E")_"^")
QUIT RES
+41 ;Check dictionary 365.1 MANUAL REQUEST DATE/TIME Flag, Quit if Set.
+42 IF $PIECE(RDATA0,U,5)'=""
IF $PIECE($GET(^IBCN(365.1,$PIECE(RDATA0,U,5),3)),U,1)'=""
QUIT RES
+43 ; auto-accept is OFF
IF $PIECE(^IBE(365.12,PIEN,1,APPIEN,0),U,7)=0
QUIT RES
+44 ; couldn't find patient
SET IEN2=$PIECE(RDATA0,U,2)
IF +IEN2'>0
QUIT RES
+45 SET ONEPOL=$$ONEPOL^IBCNEHLU(PIEN,IEN2)
+46 ;try to find a matching pat. insurance
+47 SET IEN36=""
FOR
SET IEN36=$ORDER(^DIC(36,"AC",PIEN,IEN36))
if IEN36=""!(RES>0)
QUIT
Begin DoDot:1
+48 SET IEN312=""
FOR
SET IEN312=$ORDER(^DPT(IEN2,.312,"B",IEN36,IEN312))
if IEN312=""!(RES>0&('+MWNRTYP))
QUIT
Begin DoDot:2
+49 SET IDATA0=$GET(^DPT(IEN2,.312,IEN312,0))
SET IDATA3=$GET(^DPT(IEN2,.312,IEN312,3))
+50 ;IB*2.0*497 (vd)
SET IDATA7=$GET(^DPT(IEN2,.312,IEN312,7))
+51 ;Insurance policy has expired
IF $$EXPIRED^IBCNEDE2($PIECE(IDATA0,U,4))
QUIT
+52 SET ISSUB=$$PATISSUB^IBCNEHLU(IDATA0)
+53 ;Patient is the subscriber
+54 IF ISSUB
IF '$$CHK1^IBCNEHL3
QUIT
+55 ;Patient is the dependent
+56 IF 'ISSUB
IF '$$CHK2^IBCNEHL3(MWNRTYP)
QUIT
+57 ;check group #
+58 ;IB*2*497 - group # needs to be retrieved from new field
SET GNUM=$PIECE(RDATA14,U,2)
SET GIEN=+$PIECE(IDATA0,U,18)
SET GOK=1
+59 ;check non-Medicare group #
+60 ;Group # doesn't match
IF '+MWNRTYP
Begin DoDot:3
+61 IF 'ONEPOL
Begin DoDot:4
+62 IF GIEN'>0
SET GOK=0
QUIT
+63 ;IB*2.0*497 (vd)
SET GNUM1=$PIECE($GET(^IBA(355.3,GIEN,2)),U,2)
+64 IF GNUM=""!(GNUM1="")!(GNUM'=GNUM1)
SET GOK=0
+65 QUIT
End DoDot:4
+66 IF ONEPOL
Begin DoDot:4
+67 ;IB*2.0*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
+68 QUIT
End DoDot:4
+69 QUIT
End DoDot:3
if 'GOK
QUIT
+70 ;check for Medicare part A/B
+71 ;Group # doesn't match
IF +MWNRTYP
Begin DoDot:3
+72 IF GIEN'>0
SET GOK=0
QUIT
+73 SET GDATA=$GET(^IBA(355.3,GIEN,0))
+74 IF $PIECE(GDATA,U,14)="A"
Begin DoDot:4
+75 ;IB*2.0*549 Change $P(MWNRTYP,U,2)="MA"!($P(MWNRTYP,U,2)="B")
+76 ; To $P(MWNRTYP,U,5)="MA"!($P(MWNRTYP,U,5)="B")
+77 IF $PIECE(MWNRTYP,U,5)="MA"!($PIECE(MWNRTYP,U,5)="B")
SET MWNRA=IEN312
QUIT
+78 SET GOK=0
+79 QUIT
End DoDot:4
+80 IF $PIECE(GDATA,U,14)="B"
Begin DoDot:4
+81 ;IB*2.0*549 Change $P(MWNRTYP,U,2)="MB"!($P(MWNRTYP,U,2)="B")
+82 ; To $P(MWNRTYP,U,5)="MB"!($P(MWNRTYP,U,5)="B")
+83 IF $PIECE(MWNRTYP,U,5)="MB"!($PIECE(MWNRTYP,U,5)="B")
SET MWNRB=IEN312
QUIT
+84 SET GOK=0
+85 QUIT
End DoDot:4
+86 QUIT
End DoDot:3
if 'GOK
QUIT
+87 SET RES=1_U_IEN2_U_$SELECT(+MWNRTYP:MWNRA_U_MWNRB_U_1,1:IEN312_U_U_0)
+88 SET $PIECE(RES,U,6)=ISSUB
+89 QUIT
End DoDot:2
+90 QUIT
End DoDot:1
+91 QUIT RES
+92 ;
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*2.0*549 moved because of routine size
QUIT $$EBFILE^IBCNEHL5(DFN,IEN312,RIEN,AFLG)
+10 ;
