Routine: IBCNEDE4

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.

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")

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(")

 ;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  Apr 23, 2025@18:29                                                                                                                                                                                                       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

IBCNEDE4.m