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**;21-MAR-94;Build 53
;;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*2*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*2*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*2*497 PRD segment is not processed
.;
.;IB*2*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 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*2*621/TAZ Pass EVENTYP along
.I SEG="GT1" D GT1^IBCNEHL2(.ERROR,.IBSEG,RIEN,.SUBID,EVENTYP) Q
.;
.;Insurance Seg
.;IB*2*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*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 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*2*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
. ;ib*2*497 - add processing for ROL, DG1, & ZMP segments
. ;Provider Code seg
. I SEG="ROL" D ROL^IBCNEHL5(.ERROR,.IBSEG,RIEN) Q
. ;
. ;Health Care Diagnosis Code seg
. I SEG="DG1" D DG1^IBCNEHL5(.ERROR,.IBSEG,RIEN) Q
. ;
. ;Military Personnel Information seg
. I SEG="ZMP" D ZMP^IBCNEHL5(.ERROR,.IBSEG,RIEN)
;
;IB*2*621/TAZ - File EICD Identification Response
I EVENTYP=1 S TRKIEN=$$SVEICD^IBCNEHL7()
;IB*2*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 start set auto eiv user name
N IBEIVUSR
S IBEIVUSR="AUTOUPDATE,IBEIV"
; IB*702/DTG end set auto eiv user name
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
;
;=================================================================
; IB*702/DTG start move body of AUTOFIL to IBCNEHL5 for SAC space size.
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
I $G(RIEN)="" G AUTOFILX
D AUTOFIL^IBCNEHL5(DFN,IEN312,ISSUB)
;
AUTOFILX ;
Q
; IB*702/DTG end move body of AUTOFIL to IBCNEHL5 for SAC space size.
;
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*497
S RES=0
I +$G(RIEN)'>0 Q RES ;Invalid ien for file 365
;IB*2*595/DM if entry is missing from #200, file in buffer
I '$$FIND1^DIC(200,,"M",IBEIVUSR) Q RES ; IB*702/DTG change user name ("AUTOUPDATE,IBEIV") to use var.
;
;IB*2*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*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*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*549 - Added ',MWNRTYP' below to only quit for non-medicare policies
I $G(IIVSTAT)'=1,'MWNRTYP Q RES ;Only auto-update 'active policy' responses
;IB*2*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*2*601/HN Don't allow any entry with HMS SOI to auto-update
;IB*2*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*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
;IB*2*668/TAZ - Changed to new field location
I '$$GET1^DIQ(365.121,APPIEN_","_PIEN_",",4.01,"I") 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*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*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*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*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*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*549 moved because of routine size
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEHL1 14602 printed Sep 10, 2022@02:54:48 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**;21-MAR-94;Build 53
+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*2*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*2*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*2*497 PRD segment is not processed
if SEG="PRD"
QUIT
+25 ;
+26 ;IB*2*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 Seg
+31 IF SEG="CTD"
IF 'G2OFLG
DO CTD^IBCNEHL2(.ERROR,.IBSEG,RIEN)
QUIT
+32 ;
+33 ;Patient Seg
+34 IF SEG="PID"
DO PID^IBCNEHL2(.ERFLG,.ERROR,.IBSEG,RIEN)
QUIT
+35 ;
+36 ;Guarantor Seg
+37 ;IB*2*621/TAZ Pass EVENTYP along
+38 IF SEG="GT1"
DO GT1^IBCNEHL2(.ERROR,.IBSEG,RIEN,.SUBID,EVENTYP)
QUIT
+39 ;
+40 ;Insurance Seg
+41 ;IB*2*621/TAZ Pass EVENTYP along
+42 IF SEG="IN1"
DO IN1^IBCNEHL2(.ERROR,.IBSEG,RIEN,SUBID,EVENTYP)
QUIT
+43 ;
+44 ;Addt'l Insurance Seg
+45 ;I SEG="IN2" ; for future expansion, add IN2 tag to IBCNEHL2
+46 ;
+47 ;Addt'l Insurance - Cert Seg
+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 Seg
+54 IF SEG="ZEB"
DO ZEB^IBCNEHL2(.EBDA,.ERROR,.IBSEG,RIEN)
QUIT
+55 ;
+56 ;Healthcare Delivery Seg
+57 IF SEG="ZHS"
DO ZHS^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN)
QUIT
+58 ;
+59 ;Benefit level Reference ID Seg (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 Seg
+63 IF SEG="ZSD"
DO ZSD^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN)
QUIT
+64 ;
+65 ;Subscriber Additional Info Seg
+66 IF SEG="ZII"
DO ZII^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN)
QUIT
+67 ;
+68 ;Benefit Related Entity Seg
+69 IF SEG="ZTY"
DO ZTY^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN)
QUIT
+70 ;
+71 ;Benefit Related Entity Contact Seg
+72 IF SEG="CTD"
IF G2OFLG
DO G2OCTD^IBCNEHL4(EBDA,.ERROR,.IBSEG,RIEN)
QUIT
+73 ;
+74 ;Benefit Related Entity Notes Seg
+75 IF SEG="NTE"
IF +$GET(EBDA)
DO EBNTE^IBCNEHL2(EBDA,.IBSEG,RIEN)
QUIT
+76 ;
+77 ;Reject Reasons Seg
+78 IF SEG="ERR"
KILL ERDA
DO ERR^IBCNEHL4(.ERDA,.ERROR,.IBSEG,RIEN)
QUIT
+79 ;
+80 ;Notes Seg
+81 IF SEG="NTE"
IF '$DATA(EBDA)
IF +$GET(ERDA)
DO NTE^IBCNEHL4(ERDA,.ERROR,.IBSEG,RIEN)
QUIT
+82 ;
+83 ;Subscriber date seg (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 seg
+87 IF SEG="ROL"
DO ROL^IBCNEHL5(.ERROR,.IBSEG,RIEN)
QUIT
+88 ;
+89 ;Health Care Diagnosis Code seg
+90 IF SEG="DG1"
DO DG1^IBCNEHL5(.ERROR,.IBSEG,RIEN)
QUIT
+91 ;
+92 ;Military Personnel Information seg
+93 IF SEG="ZMP"
DO ZMP^IBCNEHL5(.ERROR,.IBSEG,RIEN)
End DoDot:1
if ERFLG
QUIT
+94 ;
+95 ;IB*2*621/TAZ - File EICD Identification Response
+96 IF EVENTYP=1
SET TRKIEN=$$SVEICD^IBCNEHL7()
+97 ;IB*2*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 ; IB*702/DTG start set auto eiv user name
+113 NEW IBEIVUSR
+114 SET IBEIVUSR="AUTOUPDATE,IBEIV"
+115 ; IB*702/DTG end set auto eiv user name
+116 SET AUTO=$$AUTOUPD(RIEN)
+117 IF $GET(ACK)'="AE"
IF $GET(ERACT)=""
IF $GET(ERTXT)=""
IF '$DATA(ERROR)
IF +AUTO
Begin DoDot:1
+118 if $PIECE(AUTO,U,3)'=""
DO AUTOFIL($PIECE(AUTO,U,2),$PIECE(AUTO,U,3),$PIECE(AUTO,U,6))
+119 if $PIECE(AUTO,U,4)'=""
DO AUTOFIL($PIECE(AUTO,U,2),$PIECE(AUTO,U,4),$PIECE(AUTO,U,6))
+120 QUIT
End DoDot:1
QUIT
+121 DO FIL
+122 ;
ENX ;
+1 QUIT
+2 ;
+3 ;=================================================================
+4 ; IB*702/DTG start move body of AUTOFIL to IBCNEHL5 for SAC space size.
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 IF $GET(RIEN)=""
GOTO AUTOFILX
+4 DO AUTOFIL^IBCNEHL5(DFN,IEN312,ISSUB)
+5 ;
AUTOFILX ;
+1 QUIT
+2 ; IB*702/DTG end move body of AUTOFIL to IBCNEHL5 for SAC space size.
+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*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*595/DM if entry is missing from #200, file in buffer
+18 ; IB*702/DTG change user name ("AUTOUPDATE,IBEIV") to use var.
IF '$$FIND1^DIC(200,,"M",IBEIVUSR)
QUIT RES
+19 ;
+20 ;IB*2*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*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*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*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 ;IB*2*668/TAZ - Changed app to EIV from IIV
+36 IF +PIEN>0
SET APPIEN=$$PYRAPP^IBCNEUT5("EIV",PIEN)
+37 ;couldn't find eIV application entry
IF +$GET(APPIEN)'>0
QUIT RES
+38 ;
+39 ;IB*2*601/HN Don't allow any entry with HMS SOI to auto-update
+40 ;IB*2*595/HN Don't allow any entry with Contract Services SOI to auto-update
+41 ; HAN IB*2*621
IF $PIECE(RDATA0,U,5)'=""
IF "^HMS^CONTRACT SERVICES^"[("^"_$$GET1^DIQ(365.1,$PIECE(RDATA0,U,5)_",","SOURCE OF INFORMATION","E")_"^")
QUIT RES
+42 ;Check dictionary 365.1 MANUAL REQUEST DATE/TIME Flag, Quit if Set.
+43 IF $PIECE(RDATA0,U,5)'=""
IF $PIECE($GET(^IBCN(365.1,$PIECE(RDATA0,U,5),3)),U,1)'=""
QUIT RES
+44 ;IB*2*668/TAZ - Changed to new field location
+45 ; auto-accept is OFF
IF '$$GET1^DIQ(365.121,APPIEN_","_PIEN_",",4.01,"I")
QUIT RES
+46 ; couldn't find patient
SET IEN2=$PIECE(RDATA0,U,2)
IF +IEN2'>0
QUIT RES
+47 SET ONEPOL=$$ONEPOL^IBCNEHLU(PIEN,IEN2)
+48 ;try to find a matching pat. insurance
+49 SET IEN36=""
FOR
SET IEN36=$ORDER(^DIC(36,"AC",PIEN,IEN36))
if IEN36=""!(RES>0)
QUIT
Begin DoDot:1
+50 SET IEN312=""
FOR
SET IEN312=$ORDER(^DPT(IEN2,.312,"B",IEN36,IEN312))
if IEN312=""!(RES>0&('+MWNRTYP))
QUIT
Begin DoDot:2
+51 SET IDATA0=$GET(^DPT(IEN2,.312,IEN312,0))
SET IDATA3=$GET(^DPT(IEN2,.312,IEN312,3))
+52 ;IB*2*497 (vd)
SET IDATA7=$GET(^DPT(IEN2,.312,IEN312,7))
+53 ;Insurance policy has expired
IF $$EXPIRED^IBCNEDE2($PIECE(IDATA0,U,4))
QUIT
+54 SET ISSUB=$$PATISSUB^IBCNEHLU(IDATA0)
+55 ;Patient is the subscriber
+56 IF ISSUB
IF '$$CHK1^IBCNEHL3
QUIT
+57 ;Patient is the dependent
+58 IF 'ISSUB
IF '$$CHK2^IBCNEHL3(MWNRTYP)
QUIT
+59 ;check group #
+60 ;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
+61 ;check non-Medicare group #
+62 ;Group # doesn't match
IF '+MWNRTYP
Begin DoDot:3
+63 IF 'ONEPOL
Begin DoDot:4
+64 IF GIEN'>0
SET GOK=0
QUIT
+65 ;IB*2*497 (vd)
SET GNUM1=$PIECE($GET(^IBA(355.3,GIEN,2)),U,2)
+66 IF GNUM=""!(GNUM1="")!(GNUM'=GNUM1)
SET GOK=0
+67 QUIT
End DoDot:4
+68 IF ONEPOL
Begin DoDot:4
+69 ;IB*2*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
+70 QUIT
End DoDot:4
+71 QUIT
End DoDot:3
if 'GOK
QUIT
+72 ;check for Medicare part A/B
+73 ;Group # doesn't match
IF +MWNRTYP
Begin DoDot:3
+74 IF GIEN'>0
SET GOK=0
QUIT
+75 SET GDATA=$GET(^IBA(355.3,GIEN,0))
+76 IF $PIECE(GDATA,U,14)="A"
Begin DoDot:4
+77 ;IB*2*549 Change $P(MWNRTYP,U,2)="MA"!($P(MWNRTYP,U,2)="B")
+78 ; To $P(MWNRTYP,U,5)="MA"!($P(MWNRTYP,U,5)="B")
+79 IF $PIECE(MWNRTYP,U,5)="MA"!($PIECE(MWNRTYP,U,5)="B")
SET MWNRA=IEN312
QUIT
+80 SET GOK=0
+81 QUIT
End DoDot:4
+82 IF $PIECE(GDATA,U,14)="B"
Begin DoDot:4
+83 ;IB*2*549 Change $P(MWNRTYP,U,2)="MB"!($P(MWNRTYP,U,2)="B")
+84 ; To $P(MWNRTYP,U,5)="MB"!($P(MWNRTYP,U,5)="B")
+85 IF $PIECE(MWNRTYP,U,5)="MB"!($PIECE(MWNRTYP,U,5)="B")
SET MWNRB=IEN312
QUIT
+86 SET GOK=0
+87 QUIT
End DoDot:4
+88 QUIT
End DoDot:3
if 'GOK
QUIT
+89 SET RES=1_U_IEN2_U_$SELECT(+MWNRTYP:MWNRA_U_MWNRB_U_1,1:IEN312_U_U_0)
+90 SET $PIECE(RES,U,6)=ISSUB
+91 QUIT
End DoDot:2
+92 QUIT
End DoDot:1
+93 QUIT RES
+94 ;
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*549 moved because of routine size
QUIT $$EBFILE^IBCNEHL5(DFN,IEN312,RIEN,AFLG)
+10 ;
