IBCNEDE4 ;AITC/DM - EICD (Electronic Insurance Coverage Discovery) extract; 24-JUN-2002
;;2.0;INTEGRATED BILLING;**184,271,416,621,602,668,702,778**;21-MAR-94;Build 28
;;Per VA Directive 6402, this routine should not be modified.
;
; **Program Description**
; The Electronic Insurance Coverage Discovery a.k.a EICD extract (#4)
; is called from the nightly job - IBCNEDE.
;
; Formerly known as "No Insurance", we are reworking the entire logic for
; determining insurance for those who don't have active policies with patch IB*2.0*621.
;
Q
;
EN ; EICD extract entry
N CLNC,DATA1,DATA2,DATA5,DFN,EACTIVE,ELG,FRESHDT,IBACTV,IBAPPTDT
N IBBEGDT,IBCSIEN,IBDFNDONE,IBEFF,IBEICDPAY,IBENDDT,IBERR,IBEXP,IBFDA
N IBFREQ,IBIDX,IBINSNM,IBMSG,IBSDA,IBTASKTOT,IBTOPIEN,IBTQCNT,IBTQIEN
N IBTQSTAT,IBWK1,IBWK2,IBWKIEN,MAXCNT,OK
;
; Get Extract parameters
S EACTIVE=$$SETTINGS^IBCNEDE7(4)
I 'EACTIVE G ENQQ ; not active, or required fields missing
S MAXCNT=$P(EACTIVE,U,4) ; throttle daily extract queries
S:MAXCNT="" MAXCNT=9999999999
S IBWK1=$P(EACTIVE,U,6) ; start days
S IBBEGDT=$$FMADD^XLFDT(DT,IBWK1) ; begin date = today + start days
S IBENDDT=$$FMADD^XLFDT(DT,IBWK1+$P(EACTIVE,U,7)) ; end date = today + start days + days after start
S IBFREQ=$P(EACTIVE,U,8) ; frequency
S FRESHDT=$$FMADD^XLFDT(DT,-IBFREQ)
S IBCSIEN=$$FIND1^DIC(355.12,,"X","CONTRACT SERVICES","C")
S IBTQSTAT=$$FIND1^DIC(365.14,,"X","Ready to Transmit","B")
;
;/vd-IB*2*668 - replaced the following 2 lines of code to obtain the internal
; identifier for the Payer Application.
;IB*702/TAZ Moved Payer checks to EPAYR^IBCNEUT5 (includes the lines IB*668 fixed)
S IBEICDPAY=$$EPAYR^IBCNEUT5 I 'IBEICDPAY G ENQQ
;
S IBTASKTOT=0 ; Taskman check
S IBTQCNT=0 ; TQ entry count
K ^TMP($J,"SDAMA301"),^TMP($J,"IBCNEDE4"),IBDFNDONE
;
; Loop through clinics
S CLNC=0 F S CLNC=$O(^SC(CLNC)) Q:'CLNC D
. ;IB*778/TAZ - Redirected CLINICEX call to IBCNEDE6
. ;D CLINICEX^IBCNEDE2 Q:'OK ; clinic excluded
. D CLINICEX^IBCNEDE6 Q:'OK ; clinic excluded
. S ^TMP($J,"IBCNEDE4",CLNC)=""
;
; Set up variables for scheduling api and call
S IBSDA("FLDS")=8
S IBSDA(1)=IBBEGDT_";"_IBENDDT
S IBSDA(2)="^TMP($J,""IBCNEDE4"","
S IBSDA(3)="R"
S OK=$$SDAPI^SDAMA301(.IBSDA) I OK<1 D:OK<0 ERRMSG G ENQQ
;
; loop through returned clinics
S CLNC=0
F S CLNC=$O(^TMP($J,"SDAMA301",CLNC)) Q:'CLNC D G ENQQ:$G(ZTSTOP)!(IBTQCNT'<MAXCNT)
. ;
. ; Loop through patients returned
. S DFN=0
. F S DFN=$O(^TMP($J,"SDAMA301",CLNC,DFN)) Q:'DFN D Q:$G(ZTSTOP)!(IBTQCNT'<MAXCNT)
.. ;
.. ; CHECK DFN STUFF
.. Q:$D(IBDFNDONE(DFN)) ; DFN has been handled
.. ;
.. ;IB*702/TAZ Checks for TEST PATIENT, DATE LAST EICD RUN, DATE OF DEATH, CITY AND ZIP moved to EPAT^IBCNEUT5
.. I '$$EPAT^IBCNEUT5() S IBDFNDONE(DFN)="" Q ; patient requirements not met
.. ;
.. ; Loop through dates in range at clinic
.. S IBAPPTDT=IBBEGDT
.. F S IBAPPTDT=$O(^TMP($J,"SDAMA301",CLNC,DFN,IBAPPTDT)) Q:('IBAPPTDT)!((IBAPPTDT\1)>IBENDDT) D Q:$G(ZTSTOP)!(IBTQCNT'<MAXCNT)
... ;
... ; Update count for periodic check
... S IBTASKTOT=IBTASKTOT+1
... ; Check for request to stop background job, periodically
... I $D(ZTQUEUED),IBTASKTOT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
... ;
... Q:$D(IBDFNDONE(DFN)) ; we've already seen this DFN
... ;
... S IBWK1=$G(^TMP($J,"SDAMA301",CLNC,DFN,IBAPPTDT))
... S ELG=$P(IBWK1,U,8)
... S:ELG="" ELG=$$GET1^DIQ(2,DFN_",",.361) ; "PRIMARY ELIGIBILITY CODE"
... ;IB*778/TAZ - Redirected ELG call to IBCNEDE6
... ;D ELG^IBCNEDE2 Q:'OK ; eligibility exclusion
... D ELG^IBCNEDE6 Q:'OK ; eligibility exclusion
... ;IB*602/TAZ Screen out bad pointers to File 36
... ;IB*702/TAZ - Active Insurance check was moved to EACTPOL^IBCNEUT5
... I $$EACTPOL^IBCNEUT5 Q ; Active policies on patient. (screen out bad ptr's to File 36)
... ;
... ; This DFN is considered non-active, we'll attempt a TQ entry
... S IBDFNDONE(DFN)="" ; ok to flag DFN as handled now
... ; there should be no TQ entry for this DFN, consider it a safety check
... I '$$ADDTQ^IBCNEUT5(DFN,IBEICDPAY,DT,IBFREQ,1) Q
... ; SET prepare and file the TQ
... ; DFN:Patient IEN
... ; IBEICDPAY:EICD payer IEN
... ; IBTQSTAT:TQ STATUS IEN - Ready to Transmit
... ; FRESHDT:Freshness date
... ; 4:EICD data extract (#4)
... ; I:Identification
... ; DT:Todays date
... ; IBCSIEN:Source of Information IEN - Contract Services
... S DATA1=DFN_U_IBEICDPAY_U_IBTQSTAT_U_""_U_""_U_FRESHDT
... S DATA2=4_U_"I"_U_DT
... S DATA5=IBCSIEN
... S IBTQIEN=$$SETTQ^IBCNEDE7(DATA1,DATA2,,,DATA5) ; Sets in TQ
... I IBTQIEN="" K IBDFNDONE(DFN) Q ; didn't file, unmark DFN
... S IBTQCNT=IBTQCNT+1 ; increment the TQ count
... ; place a stub into EIV EICD TRACKING (#365.18)
... K IBFDA,IBERR
... ; EIV EICD TRACKING, .01:TRANSMISSION .02:DATE CREATED .03:PAYER .05:PATIENT
... S IBFDA(365.18,"+1,",.01)=IBTQIEN,IBFDA(365.18,"+1,",.02)=DT
... S IBFDA(365.18,"+1,",.03)=IBEICDPAY,IBFDA(365.18,"+1,",.05)=DFN
... D UPDATE^DIE(,"IBFDA",,"IBERR")
... I $G(IBERR("DIERR",1,"TEXT",1))'="" D Q
.... S IBMSG=""
.... D MSG002^IBCNEMS1(.IBMSG,.IBERR,IBTQIEN)
.... D MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV Problem: Error writing EIV EICD TRACKING (#365.18)","IBMSG(")
... Q ; next clinic appt
... ;
ENQQ ; clean and quit
K ^TMP($J,"SDAMA301"),^TMP($J,"IBCNEDE2")
Q
;
ERRMSG ; Send a message indicating an extract error has occurred
S IBMSG=""
D MSG001^IBCNEMS1(.IBMSG,"EICD")
D MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV Problem: EICD Extract","IBMSG(")
;
Q
;
;NAINSCO ; Non-active Insurance companies and NATPLANS ; Non-active Type of Plans Moved to IBCNEUT5
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEDE4 5820 printed Nov 22, 2024@17:24:32 Page 2
IBCNEDE4 ;AITC/DM - EICD (Electronic Insurance Coverage Discovery) extract; 24-JUN-2002
+1 ;;2.0;INTEGRATED BILLING;**184,271,416,621,602,668,702,778**;21-MAR-94;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; **Program Description**
+5 ; The Electronic Insurance Coverage Discovery a.k.a EICD extract (#4)
+6 ; is called from the nightly job - IBCNEDE.
+7 ;
+8 ; Formerly known as "No Insurance", we are reworking the entire logic for
+9 ; determining insurance for those who don't have active policies with patch IB*2.0*621.
+10 ;
+11 QUIT
+12 ;
EN ; EICD extract entry
+1 NEW CLNC,DATA1,DATA2,DATA5,DFN,EACTIVE,ELG,FRESHDT,IBACTV,IBAPPTDT
+2 NEW IBBEGDT,IBCSIEN,IBDFNDONE,IBEFF,IBEICDPAY,IBENDDT,IBERR,IBEXP,IBFDA
+3 NEW IBFREQ,IBIDX,IBINSNM,IBMSG,IBSDA,IBTASKTOT,IBTOPIEN,IBTQCNT,IBTQIEN
+4 NEW IBTQSTAT,IBWK1,IBWK2,IBWKIEN,MAXCNT,OK
+5 ;
+6 ; Get Extract parameters
+7 SET EACTIVE=$$SETTINGS^IBCNEDE7(4)
+8 ; not active, or required fields missing
IF 'EACTIVE
GOTO ENQQ
+9 ; throttle daily extract queries
SET MAXCNT=$PIECE(EACTIVE,U,4)
+10 if MAXCNT=""
SET MAXCNT=9999999999
+11 ; start days
SET IBWK1=$PIECE(EACTIVE,U,6)
+12 ; begin date = today + start days
SET IBBEGDT=$$FMADD^XLFDT(DT,IBWK1)
+13 ; end date = today + start days + days after start
SET IBENDDT=$$FMADD^XLFDT(DT,IBWK1+$PIECE(EACTIVE,U,7))
+14 ; frequency
SET IBFREQ=$PIECE(EACTIVE,U,8)
+15 SET FRESHDT=$$FMADD^XLFDT(DT,-IBFREQ)
+16 SET IBCSIEN=$$FIND1^DIC(355.12,,"X","CONTRACT SERVICES","C")
+17 SET IBTQSTAT=$$FIND1^DIC(365.14,,"X","Ready to Transmit","B")
+18 ;
+19 ;/vd-IB*2*668 - replaced the following 2 lines of code to obtain the internal
+20 ; identifier for the Payer Application.
+21 ;IB*702/TAZ Moved Payer checks to EPAYR^IBCNEUT5 (includes the lines IB*668 fixed)
+22 SET IBEICDPAY=$$EPAYR^IBCNEUT5
IF 'IBEICDPAY
GOTO ENQQ
+23 ;
+24 ; Taskman check
SET IBTASKTOT=0
+25 ; TQ entry count
SET IBTQCNT=0
+26 KILL ^TMP($JOB,"SDAMA301"),^TMP($JOB,"IBCNEDE4"),IBDFNDONE
+27 ;
+28 ; Loop through clinics
+29 SET CLNC=0
FOR
SET CLNC=$ORDER(^SC(CLNC))
if 'CLNC
QUIT
Begin DoDot:1
+30 ;IB*778/TAZ - Redirected CLINICEX call to IBCNEDE6
+31 ;D CLINICEX^IBCNEDE2 Q:'OK ; clinic excluded
+32 ; clinic excluded
DO CLINICEX^IBCNEDE6
if 'OK
QUIT
+33 SET ^TMP($JOB,"IBCNEDE4",CLNC)=""
End DoDot:1
+34 ;
+35 ; Set up variables for scheduling api and call
+36 SET IBSDA("FLDS")=8
+37 SET IBSDA(1)=IBBEGDT_";"_IBENDDT
+38 SET IBSDA(2)="^TMP($J,""IBCNEDE4"","
+39 SET IBSDA(3)="R"
+40 SET OK=$$SDAPI^SDAMA301(.IBSDA)
IF OK<1
if OK<0
DO ERRMSG
GOTO ENQQ
+41 ;
+42 ; loop through returned clinics
+43 SET CLNC=0
+44 FOR
SET CLNC=$ORDER(^TMP($JOB,"SDAMA301",CLNC))
if 'CLNC
QUIT
Begin DoDot:1
+45 ;
+46 ; Loop through patients returned
+47 SET DFN=0
+48 FOR
SET DFN=$ORDER(^TMP($JOB,"SDAMA301",CLNC,DFN))
if 'DFN
QUIT
Begin DoDot:2
+49 ;
+50 ; CHECK DFN STUFF
+51 ; DFN has been handled
if $DATA(IBDFNDONE(DFN))
QUIT
+52 ;
+53 ;IB*702/TAZ Checks for TEST PATIENT, DATE LAST EICD RUN, DATE OF DEATH, CITY AND ZIP moved to EPAT^IBCNEUT5
+54 ; patient requirements not met
IF '$$EPAT^IBCNEUT5()
SET IBDFNDONE(DFN)=""
QUIT
+55 ;
+56 ; Loop through dates in range at clinic
+57 SET IBAPPTDT=IBBEGDT
+58 FOR
SET IBAPPTDT=$ORDER(^TMP($JOB,"SDAMA301",CLNC,DFN,IBAPPTDT))
if ('IBAPPTDT)!((IBAPPTDT\1)>IBENDDT)
QUIT
Begin DoDot:3
+59 ;
+60 ; Update count for periodic check
+61 SET IBTASKTOT=IBTASKTOT+1
+62 ; Check for request to stop background job, periodically
+63 IF $DATA(ZTQUEUED)
IF IBTASKTOT#100=0
IF $$S^%ZTLOAD()
SET ZTSTOP=1
QUIT
+64 ;
+65 ; we've already seen this DFN
if $DATA(IBDFNDONE(DFN))
QUIT
+66 ;
+67 SET IBWK1=$GET(^TMP($JOB,"SDAMA301",CLNC,DFN,IBAPPTDT))
+68 SET ELG=$PIECE(IBWK1,U,8)
+69 ; "PRIMARY ELIGIBILITY CODE"
if ELG=""
SET ELG=$$GET1^DIQ(2,DFN_",",.361)
+70 ;IB*778/TAZ - Redirected ELG call to IBCNEDE6
+71 ;D ELG^IBCNEDE2 Q:'OK ; eligibility exclusion
+72 ; eligibility exclusion
DO ELG^IBCNEDE6
if 'OK
QUIT
+73 ;IB*602/TAZ Screen out bad pointers to File 36
+74 ;IB*702/TAZ - Active Insurance check was moved to EACTPOL^IBCNEUT5
+75 ; Active policies on patient. (screen out bad ptr's to File 36)
IF $$EACTPOL^IBCNEUT5
QUIT
+76 ;
+77 ; This DFN is considered non-active, we'll attempt a TQ entry
+78 ; ok to flag DFN as handled now
SET IBDFNDONE(DFN)=""
+79 ; there should be no TQ entry for this DFN, consider it a safety check
+80 IF '$$ADDTQ^IBCNEUT5(DFN,IBEICDPAY,DT,IBFREQ,1)
QUIT
+81 ; SET prepare and file the TQ
+82 ; DFN:Patient IEN
+83 ; IBEICDPAY:EICD payer IEN
+84 ; IBTQSTAT:TQ STATUS IEN - Ready to Transmit
+85 ; FRESHDT:Freshness date
+86 ; 4:EICD data extract (#4)
+87 ; I:Identification
+88 ; DT:Todays date
+89 ; IBCSIEN:Source of Information IEN - Contract Services
+90 SET DATA1=DFN_U_IBEICDPAY_U_IBTQSTAT_U_""_U_""_U_FRESHDT
+91 SET DATA2=4_U_"I"_U_DT
+92 SET DATA5=IBCSIEN
+93 ; Sets in TQ
SET IBTQIEN=$$SETTQ^IBCNEDE7(DATA1,DATA2,,,DATA5)
+94 ; didn't file, unmark DFN
IF IBTQIEN=""
KILL IBDFNDONE(DFN)
QUIT
+95 ; increment the TQ count
SET IBTQCNT=IBTQCNT+1
+96 ; place a stub into EIV EICD TRACKING (#365.18)
+97 KILL IBFDA,IBERR
+98 ; EIV EICD TRACKING, .01:TRANSMISSION .02:DATE CREATED .03:PAYER .05:PATIENT
+99 SET IBFDA(365.18,"+1,",.01)=IBTQIEN
SET IBFDA(365.18,"+1,",.02)=DT
+100 SET IBFDA(365.18,"+1,",.03)=IBEICDPAY
SET IBFDA(365.18,"+1,",.05)=DFN
+101 DO UPDATE^DIE(,"IBFDA",,"IBERR")
+102 IF $GET(IBERR("DIERR",1,"TEXT",1))'=""
Begin DoDot:4
+103 SET IBMSG=""
+104 DO MSG002^IBCNEMS1(.IBMSG,.IBERR,IBTQIEN)
+105 DO MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV Problem: Error writing EIV EICD TRACKING (#365.18)","IBMSG(")
End DoDot:4
QUIT
+106 ; next clinic appt
QUIT
+107 ;
End DoDot:3
if $GET(ZTSTOP)!(IBTQCNT'<MAXCNT)
QUIT
End DoDot:2
if $GET(ZTSTOP)!(IBTQCNT'<MAXCNT)
QUIT
End DoDot:1
if $GET(ZTSTOP)!(IBTQCNT'<MAXCNT)
GOTO ENQQ
ENQQ ; clean and quit
+1 KILL ^TMP($JOB,"SDAMA301"),^TMP($JOB,"IBCNEDE2")
+2 QUIT
+3 ;
ERRMSG ; Send a message indicating an extract error has occurred
+1 SET IBMSG=""
+2 DO MSG001^IBCNEMS1(.IBMSG,"EICD")
+3 DO MSG^IBCNEUT5($$MGRP^IBCNEUT5(),"eIV Problem: EICD Extract","IBMSG(")
+4 ;
+5 QUIT
+6 ;
+7 ;NAINSCO ; Non-active Insurance companies and NATPLANS ; Non-active Type of Plans Moved to IBCNEUT5
