IBCNEDE2 ;DAOU/DAC - eIV Appointment Extract ;23-SEP-2015
;;2.0;INTEGRATED BILLING;**184,271,249,345,416,438,506,549,593,595,621,659,743,778**;21-MAR-94;Build 28
;;Per VA Directive 6402, this routine should not be modified.
;
;IB*778/CKB - rewrote the eIV Appointment Extract from scratch, reusing the routine IBCNEDE2.
; Any modifications based on patches prior to 778 are no longer applicable for this
; routine, due to the rewrite.
;
;**Program Description**
; This program finds patients who have upcoming appointments within a
; specified date range. The date range is parameter driven.
; Periodically check for stop request as this is a background task.
;
Q ; can't be called directly
;
EN ; Loop through designated cross-references for updates
N APTDT,CLNC,CNT,DFN,DTRANGE,ENDDT,EXCLTOC,EXCLTOP,FRESHDAY,IBCNETOT,IBFNDTQ,IBPQ,IBSDA,INREC,INSIEN,INSNAME
N MAXCNT,MFLG,MFRESHDAY,NUM,OK,PATID,PAYERSTR,PIEN,PTINS,PYRAPP,QURYFLAG,SETSTR,SRVICEDT
N SYMBOL,TQIEN,VDATE,ZTQUEUED,ZTSTOP,ZZ
;
S SETSTR=$$SETTINGS^IBCNEDE7(2) ; Get setting for pre reg. extract
I 'SETSTR Q ; Quit if extract is not active
S DTRANGE=$P(SETSTR,U,2) ; Selection Criteria #1 - how far in the future do I look for appts
S MAXCNT=$P(SETSTR,U,4) ; Max # of TQ entries to create & send to FSC
S:MAXCNT="" MAXCNT=9999999999
S FRESHDAY=$P($G(^IBE(350.9,1,51)),U,1) ; Freshness days span
S MFRESHDAY=$$GET1^DIQ(350.9,"1,",51.32) ; Medicare Freshness days span
S ENDDT=$$FMADD^XLFDT(DT,DTRANGE) ; End of appt. date selection range
S CNT=0 ; Init. entries created in TQ and send to FSC
S IBCNETOT=0 ; Initialize count for periodic TaskMan check
S EXCLTOC=$$GETELST(355.2) ; Initialize excluded TYPEs OF COVERAGE
S EXCLTOP=$$GETELST(355.1) ; Initialize excluded TYPEs OF PLAN
; Clean TMP globals
K ^TMP($J,"SDAMA301"),^TMP($J,"IBCNEDE2DFN")
;
; Set up variables for scheduling call and call
S IBSDA("FLDS")=8
S IBSDA(1)=DT_";"_ENDDT
S IBSDA(3)="R"
S NUM=$$SDAPI^SDAMA301(.IBSDA) I NUM<1 D:NUM<0 ERRMSG G ENQ
;
;
S CLNC=0 ; Init. clinic
; Loop through clinics returned
F S CLNC=$O(^TMP($J,"SDAMA301",CLNC)) Q:'CLNC D Q:$G(ZTSTOP)
. ;
. ; Loop through patients returned
. S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",CLNC,DFN)) Q:'DFN D Q:$G(ZTSTOP)
.. ;
.. S APTDT=DT ; Check for appointment date
.. ;
.. ; Loop through dates in range at clinic
.. F S APTDT=$O(^TMP($J,"SDAMA301",CLNC,DFN,APTDT)) Q:('APTDT)!((APTDT\1)>ENDDT) D Q:$G(ZTSTOP)
... ;
... S SRVICEDT=APTDT\1 ;Set service date equal to appointment date
... ;
... ; Update count for periodic check
... S IBCNETOT=IBCNETOT+1
... ; Check for request to stop background job, periodically
... I $D(ZTQUEUED),IBCNETOT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
... ;
... I $P($G(^DPT(DFN,0)),U,21) Q ; Exclude if test patient
... ;
... ; Build temp array for allowed DFN's
... S ^TMP($J,"IBCNEDE2DFN",DFN,(+$G(SRVICEDT)))=""
;
100 ;
; Check the insurance for the selected DFNs based on future appointments
S DFN=0
F S DFN=$O(^TMP($J,"IBCNEDE2DFN",DFN)) Q:'DFN D
. ;
. K IBFNDTQ
. K PTINS D ALL^IBCNEDE3(DFN,"PTINS")
. I '$D(PTINS(0)) Q ; Patient has no insurance to be evaluated
. ;
. ; Find the service date that is closest to TODAY (DT), do not look for past dates.
. S SRVICEDT=$O(^TMP($J,"IBCNEDE2DFN",DFN,(DT-1)))
. I SRVICEDT="" Q ; No future appointments are found for the patient
. ;
. ;Loop through Patient policies and check MAXCNT
. S INREC=0 F S INREC=$O(PTINS(INREC)) Q:('INREC)!(CNT'<MAXCNT) D
.. N ADDTQ,FSCSEND,GIEN,GRPNAM,GRPNUM,PATID
.. N SENDNOW,SUBID,TQENT,TQFOUND,XXGN
.. S MFLG=0
.. ; Repull Service Date for each Policy
.. S SRVICEDT=$O(^TMP($J,"IBCNEDE2DFN",DFN,(DT-1)))
.. ; Get Payer, Insurance and Group Plan info
.. S INSIEN=$P($G(PTINS(INREC,0)),U,1)
.. S INSNAME=$$GET1^DIQ(36,INSIEN_",",.01,"E")
.. S GIEN=$$GET1^DIQ(2.312,INREC_","_DFN_",",.18,"I")
.. S GRPNAM=$$GET1^DIQ(355.3,GIEN_",",2.01,"E")
.. S GRPNUM=$$GET1^DIQ(355.3,GIEN_",",2.02,"E")
.. S SUBID=$$GET1^DIQ(2.312,INREC_","_DFN_",",7.02,"E")
.. S PATID=$$GET1^DIQ(2.312,INREC_","_DFN_",",5.01,"E")
.. ; Remove any non-alpha numeric characters
.. I SUBID'="" S SUBID=$$STRIP^IBCNEDE3(SUBID)
.. I PATID'="" S PATID=$$STRIP^IBCNEDE3(PATID)
.. ;
.. ; Type of Plan
.. S ZZ=$$GET1^DIQ(355.3,GIEN_",",.09,"I")
.. Q:EXCLTOP[("^"_ZZ_"^") ; Excluded Types of Plan
.. ;
.. ; Type of Coverage
.. S ZZ=$$GET1^DIQ(36,INSIEN_",",.13,"I")
.. Q:EXCLTOC[("^"_ZZ_"^") ; Excluded Type of Coverage
.. ;
.. ; OKFRESH properly identifies the policies to exclude when verified
.. ; within the "freshness days" for Medicare and non-Medicare policies (MFLG)
.. I '$$OKFRESH(INREC,FRESHDAY,MFRESHDAY,.MFLG) Q
.. ;
.. ; $$INSERROR, when passing in "I", gets Insurance company and Payer info and performs the following checks:
.. ; - Insurance company must be active, linked to a eIV payer AND not marked for deletion
.. ; - Insurance company name must not contain "MEDICAID"
.. ; - Payer must be Nationally and Locally enabled for eIV AND not deactivated
.. ; - Payer must have a VA National ID
.. S IBPQ=0
.. S PAYERSTR=$$INSERROR^IBCNEUT3("I",INSIEN)
.. S SYMBOL=+PAYERSTR ; error symbol
.. S PIEN=$P(PAYERSTR,U,2) ; Payer IEN
.. ;
.. I +PIEN D
... ; Determine Payer App IEN
... S PYRAPP=$$PYRAPP^IBCNEUT5("EIV",PIEN)
... ; If Payer requires a Subscriber ID and the policy does not have one on file, drop to buffer
... I $$GET1^DIQ(365.121,PYRAPP_","_PIEN_",",4.02,"I") I SUBID="" S IBPQ=1
.. ;
.. ; If Payer IEN is not defined or Payer is Nationally Inactive, drop to buffer
.. I ('+PIEN)!('$$PYRACTV^IBCNEDE7(PIEN)) S IBPQ=1
.. ;
.. ; Drop to the Buffer and quit, had an issue with Insurance Co or Payer or Policy
.. I (SYMBOL)!(IBPQ=1) D Q
... I '$$BFEXIST^IBCNEDE3(DFN,INSNAME,SUBID,GRPNUM) D PT^IBCNEBF(DFN,INREC,SYMBOL,"",1)
.. ;
.. ; If MEDICARE (MFLG) and GRPNUM="PART A" or "PART B", check for the existence in array IBFNDTQ
.. ; Only allow ONE occurrence in the TQ for Medicare Part A and Medicare Part B, never both
.. I MFLG&((GRPNUM="PART A")!(GRPNUM="PART B")) I $D(IBFNDTQ(PIEN,$S(SUBID="":" ",1:SUBID),"PART A"))!$D(IBFNDTQ(PIEN,$S(SUBID="":" ",1:SUBID),"PART B")) Q
.. ;
.. ; Check for the existence in array IBFNDTQ, DO NOT continue
.. I $D(IBFNDTQ(PIEN,$S(SUBID="":" ",1:SUBID),$S(GRPNUM="":" ",1:GRPNUM))) Q
.. ;
.. ; Update service date based on Payers allowed date range
.. D UPDSD^IBCNEDE3(PIEN,PYRAPP,.SRVICEDT)
.. ;
.. ; Initialize variables for TQUPDSV and TQCHKS
.. S ADDTQ=1,(FSCSEND,TQFOUND)=0,TQENT=""
.. ;
.. ; Update service dates for inquiry to be transmitted
.. ; sets TQFOUND, FSCSEND and TQENT
.. D TQUPDSV^IBCNEDE3(DFN,PIEN,SRVICEDT,SUBID,GRPNUM)
.. ; Check to see if a new entry can be added to the TQ file
.. ; sets ADDTQ
.. D TQCHKS^IBCNEDE3(DFN,PIEN,SRVICEDT,SUBID,GRPNUM,$S(MFLG:MFRESHDAY,1:FRESHDAY))
.. ;
.. ; to handle Medicare Part A and Medicare Part B, only allow one occurrence
.. I ADDTQ&'TQFOUND&MFLG&((GRPNUM="PART A")!(GRPNUM="PART B")) D
... S XXGN=$S(GRPNUM="PART A":"PART B",1:"PART A")
... D TQUPDSV^IBCNEDE3(DFN,PIEN,SRVICEDT,SUBID,XXGN)
... D TQCHKS^IBCNEDE3(DFN,PIEN,SRVICEDT,SUBID,XXGN,$S(MFLG:MFRESHDAY,1:FRESHDAY))
.. ;
.. ; If a valid entry was found in the TQ file (TQFOUND=1) AND the send to FSC now flag
.. ; (FSCSEND) is set to '1', transmit to FSC and increment counter
.. ; DO NOT create a new entry if TQFOUND is true
.. I TQFOUND D Q
... I FSCSEND,TQENT I CNT'>MAXCNT D XMIT1^IBCNEDEP(TQENT) S CNT=CNT+1 ; Increment counter of entries sent to FSC
.. ; If ADDTQ is set to '0', DO NOT create a new entry (safety valve)
.. I 'ADDTQ Q
.. ;
.. ; Determine if the Subscriber ID should be included/saved to the TQ
.. ; The policy has a subscriber ID on file - include subscriber ID
.. S QURYFLAG="V"
.. I SUBID'="" D SET(SUBID,INREC,PATID)
.. ; If the policy does NOT have subscriber ID on file - don't include subscriber ID
.. I SUBID="" D SET("",INREC,PATID)
.. ; Set local array of patient's added to the TQ file
.. S IBFNDTQ(PIEN,$S(SUBID="":" ",1:SUBID),$S(GRPNUM="":" ",1:GRPNUM))=1
;
ENQ ;
K ^TMP($J,"SDAMA301")
K ^TMP($J,"IBCNEDE2DFN")
Q
;========================================================================
GETELST(FILE) ; Returns a '^' delimited list of IENs Type of Plans or Type of
; coverages to be excluded with leading and trailing '^'s
;Input:
; FILE = 355.1 - Type of Plans
; = 355.2 - Type of Coverages
;Returns:
; EXCLIST - '^' delimited list of IENs for Type of Plans or Type of Coverages
; to be excluded (ie., ^10^6^22^)
;
N EXCLIST,IEN,LINE,TYPE
S EXCLIST=""
I FILE="355.1" F LINE=1:1 S TYPE=$P($T(TOP+LINE),";;",2) Q:TYPE="" D
. I '$D(^IBE(FILE,"B",TYPE)) Q
. N IEN S IEN=$O(^IBE(FILE,"B",TYPE,""))
. S EXCLIST=$S(EXCLIST="":IEN,1:EXCLIST_"^"_IEN)
;
I FILE="355.2" F LINE=1:1 S TYPE=$P($T(TOC+LINE),";;",2) Q:TYPE="" D
. I '$D(^IBE(FILE,"B",TYPE)) Q
. N IEN S IEN=$O(^IBE(FILE,"B",TYPE,""))
. S EXCLIST=$S(EXCLIST="":IEN,1:EXCLIST_"^"_IEN)
;
Q "^"_EXCLIST_"^"
;----------------------------------
TOP ; Type of Plans (#355.1) to exclude
;;AUTOMOBILE
;;MEDICAID
;;MEDI-CAL
;;TORT FEASOR
;;WORKERS' COMPENSATION INSURANCE
;;VA SPECIAL CLASS
;;ACCIDENT AND HEALTH INSURANCE
;;AVIATION TRIP INSURANCE
;;CATASTROPHIC INSURANCE
;;COINSURANCE
;;INCOME PROTECTION (INDEMNITY)
;;MEDICARE/MEDICAID (MEDI-CAL)
;;QUALIFIED IMPAIRMENT INSURANCE
;;SPECIAL CLASS INSURANCE
;;SPECIAL RISK INSURANCE
;----------------------------------
TOC ; Type of Coverages (#355.2) to exclude
;;MEDICAID
;;MEDI-CAL
;;TORT/FEASOR
;;WORKERS' COMPENSATION
;;VA SPECIAL CLASS
;;DISABILITY INCOME INSURANCE
;;INDEMNITY
;;SUBSTANCE ABUSE ONLY
;----------------------------------
OKFRESH(INREC,FRESHDAY,MFRESHDAY,MFLG) ; Identify those policies to exclude when
; verified within the "freshness days" for Medicare and non-Medicare policies.
; INPUT:
; INREC - IEN to current Insurance Plan
; FRESHDAY - Freshness Days Span
; MFRESHDAY - Medicare Freshness Days Span
; MFLG - Used to determine if the insurance plan is a Medicare Plan - 1=MEDICARE, 0=non-MEDICARE
; OUTPUT:
; OK = 0 - Exclude Policy
; = 1 - Include Policy
N GIEN,IIEN,OK,VDATE
S MFLG=0,OK=1,VDATE=$P($G(PTINS(INREC,1)),U,3)
S IIEN=$P($G(PTINS(INREC,0)),U,1) ; Insurance ien
; Is the Insurance company PAYER (#36,3.1) the same as MEDICARE PAYER (#350.9,51.25)
I $$GET1^DIQ(36,IIEN_",",3.1)=$$GET1^DIQ(350.9,"1,",51.25) S MFLG=1 ;Medicare Part A and Part B Policies
; Determine if Type of Plan (#355.3,.09) for the Group Plan is MEDICARE ADVANTAGE
I 'MFLG D
. S GIEN=+$P($G(PTINS(INREC,0)),U,18) ; Group Plan ien
. I GIEN,$$GET1^DIQ(355.3,GIEN_",",.09)="MEDICARE ADVANTAGE" S MFLG=1 ;Medicare Part C
I $$GET1^DIQ(36,IIEN_",",.01)="MEDICARE PART D (WNR)" S MFLG=1 ;Medicare Part D (WNR)
;
I VDATE'="",'MFLG,SRVICEDT'>$$FMADD^XLFDT(VDATE,FRESHDAY) S OK=0 ;Non-Medicare Policy outside of Freshness Day span
I VDATE'="",MFLG,SRVICEDT'>$$FMADD^XLFDT(VDATE,MFRESHDAY) S OK=0 ;Medicare Policy outside of Medicare Freshness Day span
Q OK
;----------------------------------
SET(SID,INR,PATID) ; Set data in TQ and send to FSC
;
N DATA1,DATA2,DATA5,ORIG
;
; The hard coded '1' in the 3rd piece of DATA1 sets the Transmission
; status of file 365.1 to "Ready to Transmit"
; 10/2023: FRESHDT is no longer being included in DATA1
S DATA1=DFN_U_PIEN_U_1_U_""_U_SID ; SETTQ 1st parameter
S $P(DATA1,U,8)=PATID
;
; The hardcoded '2' in the 1st piece of DATA2 is the value to tell
; the file 365.1 that it is the appointment extract.
S DATA2=2_U_QURYFLAG_U_SRVICEDT_U_INR ; SETTQ 2nd parameter
;
S ORIG=U_$S(GRPNUM=" ":"",1:GRPNUM)_U_$S(GRPNAM=" ":"",1:GRPNAM)
;
S DATA5=$$FIND1^DIC(355.12,,,"eIV","C") ; Set to IEN of "eIV" Source of Information
;
S TQIEN=$$SETTQ^IBCNEDE7(DATA1,DATA2,ORIG,,DATA5) ; Sets entry into the TQ
; Send entry to FSC
I TQIEN I CNT'>MAXCNT D XMIT1^IBCNEDEP(TQIEN) S CNT=CNT+1 ; Increment the counter of entries sent to FSC
Q
;----------------------------------
ERRMSG ; Send a message indicating an extract error has occurred
N MGRP,XMSUB,MSG,IBX,IBM
;
; Set to IB site parameter MAILGROUP
S MGRP=$$MGRP^IBCNEUT5()
;
S XMSUB="eIV Problem: Appointment Extract"
S MSG(1)="On "_$$FMTE^XLFDT(DT)_" the Appointment Extract for eIV encountered one or more"
S MSG(2)="errors while attempting to get Appointment data from the scheduling"
S MSG(3)="package."
S MSG(4)=""
S MSG(5)="Error(s) encountered: "
S MSG(6)=""
S MSG(7)=" Error Code Error Message"
S MSG(8)=" ---------- -------------"
S IBM=8,IBX=0 F S IBX=$O(^TMP($J,"SDAMA301",IBX)) Q:IBX="" S IBM=IBM+1,MSG(IBM)=" "_$$LJ^XLFSTR(IBX,13)_$G(^TMP($J,"SDAMA301",IBX))
S IBM=IBM+1,MSG(IBM)=""
S IBM=IBM+1,MSG(IBM)="As a result of this error the extract was not done. The extract"
S IBM=IBM+1,MSG(IBM)="will be attempted again the next night automatically. If you"
S IBM=IBM+1,MSG(IBM)="continue to receive error messages you should contact your IRM"
S IBM=IBM+1,MSG(IBM)="and possibly call the Help Desk for assistance."
;
D MSG^IBCNEUT5(MGRP,XMSUB,"MSG(")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEDE2 13825 printed Dec 13, 2024@02:14:26 Page 2
IBCNEDE2 ;DAOU/DAC - eIV Appointment Extract ;23-SEP-2015
+1 ;;2.0;INTEGRATED BILLING;**184,271,249,345,416,438,506,549,593,595,621,659,743,778**;21-MAR-94;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;IB*778/CKB - rewrote the eIV Appointment Extract from scratch, reusing the routine IBCNEDE2.
+5 ; Any modifications based on patches prior to 778 are no longer applicable for this
+6 ; routine, due to the rewrite.
+7 ;
+8 ;**Program Description**
+9 ; This program finds patients who have upcoming appointments within a
+10 ; specified date range. The date range is parameter driven.
+11 ; Periodically check for stop request as this is a background task.
+12 ;
+13 ; can't be called directly
QUIT
+14 ;
EN ; Loop through designated cross-references for updates
+1 NEW APTDT,CLNC,CNT,DFN,DTRANGE,ENDDT,EXCLTOC,EXCLTOP,FRESHDAY,IBCNETOT,IBFNDTQ,IBPQ,IBSDA,INREC,INSIEN,INSNAME
+2 NEW MAXCNT,MFLG,MFRESHDAY,NUM,OK,PATID,PAYERSTR,PIEN,PTINS,PYRAPP,QURYFLAG,SETSTR,SRVICEDT
+3 NEW SYMBOL,TQIEN,VDATE,ZTQUEUED,ZTSTOP,ZZ
+4 ;
+5 ; Get setting for pre reg. extract
SET SETSTR=$$SETTINGS^IBCNEDE7(2)
+6 ; Quit if extract is not active
IF 'SETSTR
QUIT
+7 ; Selection Criteria #1 - how far in the future do I look for appts
SET DTRANGE=$PIECE(SETSTR,U,2)
+8 ; Max # of TQ entries to create & send to FSC
SET MAXCNT=$PIECE(SETSTR,U,4)
+9 if MAXCNT=""
SET MAXCNT=9999999999
+10 ; Freshness days span
SET FRESHDAY=$PIECE($GET(^IBE(350.9,1,51)),U,1)
+11 ; Medicare Freshness days span
SET MFRESHDAY=$$GET1^DIQ(350.9,"1,",51.32)
+12 ; End of appt. date selection range
SET ENDDT=$$FMADD^XLFDT(DT,DTRANGE)
+13 ; Init. entries created in TQ and send to FSC
SET CNT=0
+14 ; Initialize count for periodic TaskMan check
SET IBCNETOT=0
+15 ; Initialize excluded TYPEs OF COVERAGE
SET EXCLTOC=$$GETELST(355.2)
+16 ; Initialize excluded TYPEs OF PLAN
SET EXCLTOP=$$GETELST(355.1)
+17 ; Clean TMP globals
+18 KILL ^TMP($JOB,"SDAMA301"),^TMP($JOB,"IBCNEDE2DFN")
+19 ;
+20 ; Set up variables for scheduling call and call
+21 SET IBSDA("FLDS")=8
+22 SET IBSDA(1)=DT_";"_ENDDT
+23 SET IBSDA(3)="R"
+24 SET NUM=$$SDAPI^SDAMA301(.IBSDA)
IF NUM<1
if NUM<0
DO ERRMSG
GOTO ENQ
+25 ;
+26 ;
+27 ; Init. clinic
SET CLNC=0
+28 ; Loop through clinics returned
+29 FOR
SET CLNC=$ORDER(^TMP($JOB,"SDAMA301",CLNC))
if 'CLNC
QUIT
Begin DoDot:1
+30 ;
+31 ; Loop through patients returned
+32 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"SDAMA301",CLNC,DFN))
if 'DFN
QUIT
Begin DoDot:2
+33 ;
+34 ; Check for appointment date
SET APTDT=DT
+35 ;
+36 ; Loop through dates in range at clinic
+37 FOR
SET APTDT=$ORDER(^TMP($JOB,"SDAMA301",CLNC,DFN,APTDT))
if ('APTDT)!((APTDT\1)>ENDDT)
QUIT
Begin DoDot:3
+38 ;
+39 ;Set service date equal to appointment date
SET SRVICEDT=APTDT\1
+40 ;
+41 ; Update count for periodic check
+42 SET IBCNETOT=IBCNETOT+1
+43 ; Check for request to stop background job, periodically
+44 IF $DATA(ZTQUEUED)
IF IBCNETOT#100=0
IF $$S^%ZTLOAD()
SET ZTSTOP=1
QUIT
+45 ;
+46 ; Exclude if test patient
IF $PIECE($GET(^DPT(DFN,0)),U,21)
QUIT
+47 ;
+48 ; Build temp array for allowed DFN's
+49 SET ^TMP($JOB,"IBCNEDE2DFN",DFN,(+$GET(SRVICEDT)))=""
End DoDot:3
if $GET(ZTSTOP)
QUIT
End DoDot:2
if $GET(ZTSTOP)
QUIT
End DoDot:1
if $GET(ZTSTOP)
QUIT
+50 ;
100 ;
+1 ; Check the insurance for the selected DFNs based on future appointments
+2 SET DFN=0
+3 FOR
SET DFN=$ORDER(^TMP($JOB,"IBCNEDE2DFN",DFN))
if 'DFN
QUIT
Begin DoDot:1
+4 ;
+5 KILL IBFNDTQ
+6 KILL PTINS
DO ALL^IBCNEDE3(DFN,"PTINS")
+7 ; Patient has no insurance to be evaluated
IF '$DATA(PTINS(0))
QUIT
+8 ;
+9 ; Find the service date that is closest to TODAY (DT), do not look for past dates.
+10 SET SRVICEDT=$ORDER(^TMP($JOB,"IBCNEDE2DFN",DFN,(DT-1)))
+11 ; No future appointments are found for the patient
IF SRVICEDT=""
QUIT
+12 ;
+13 ;Loop through Patient policies and check MAXCNT
+14 SET INREC=0
FOR
SET INREC=$ORDER(PTINS(INREC))
if ('INREC)!(CNT'<MAXCNT)
QUIT
Begin DoDot:2
+15 NEW ADDTQ,FSCSEND,GIEN,GRPNAM,GRPNUM,PATID
+16 NEW SENDNOW,SUBID,TQENT,TQFOUND,XXGN
+17 SET MFLG=0
+18 ; Repull Service Date for each Policy
+19 SET SRVICEDT=$ORDER(^TMP($JOB,"IBCNEDE2DFN",DFN,(DT-1)))
+20 ; Get Payer, Insurance and Group Plan info
+21 SET INSIEN=$PIECE($GET(PTINS(INREC,0)),U,1)
+22 SET INSNAME=$$GET1^DIQ(36,INSIEN_",",.01,"E")
+23 SET GIEN=$$GET1^DIQ(2.312,INREC_","_DFN_",",.18,"I")
+24 SET GRPNAM=$$GET1^DIQ(355.3,GIEN_",",2.01,"E")
+25 SET GRPNUM=$$GET1^DIQ(355.3,GIEN_",",2.02,"E")
+26 SET SUBID=$$GET1^DIQ(2.312,INREC_","_DFN_",",7.02,"E")
+27 SET PATID=$$GET1^DIQ(2.312,INREC_","_DFN_",",5.01,"E")
+28 ; Remove any non-alpha numeric characters
+29 IF SUBID'=""
SET SUBID=$$STRIP^IBCNEDE3(SUBID)
+30 IF PATID'=""
SET PATID=$$STRIP^IBCNEDE3(PATID)
+31 ;
+32 ; Type of Plan
+33 SET ZZ=$$GET1^DIQ(355.3,GIEN_",",.09,"I")
+34 ; Excluded Types of Plan
if EXCLTOP[("^"_ZZ_"^")
QUIT
+35 ;
+36 ; Type of Coverage
+37 SET ZZ=$$GET1^DIQ(36,INSIEN_",",.13,"I")
+38 ; Excluded Type of Coverage
if EXCLTOC[("^"_ZZ_"^")
QUIT
+39 ;
+40 ; OKFRESH properly identifies the policies to exclude when verified
+41 ; within the "freshness days" for Medicare and non-Medicare policies (MFLG)
+42 IF '$$OKFRESH(INREC,FRESHDAY,MFRESHDAY,.MFLG)
QUIT
+43 ;
+44 ; $$INSERROR, when passing in "I", gets Insurance company and Payer info and performs the following checks:
+45 ; - Insurance company must be active, linked to a eIV payer AND not marked for deletion
+46 ; - Insurance company name must not contain "MEDICAID"
+47 ; - Payer must be Nationally and Locally enabled for eIV AND not deactivated
+48 ; - Payer must have a VA National ID
+49 SET IBPQ=0
+50 SET PAYERSTR=$$INSERROR^IBCNEUT3("I",INSIEN)
+51 ; error symbol
SET SYMBOL=+PAYERSTR
+52 ; Payer IEN
SET PIEN=$PIECE(PAYERSTR,U,2)
+53 ;
+54 IF +PIEN
Begin DoDot:3
+55 ; Determine Payer App IEN
+56 SET PYRAPP=$$PYRAPP^IBCNEUT5("EIV",PIEN)
+57 ; If Payer requires a Subscriber ID and the policy does not have one on file, drop to buffer
+58 IF $$GET1^DIQ(365.121,PYRAPP_","_PIEN_",",4.02,"I")
IF SUBID=""
SET IBPQ=1
End DoDot:3
+59 ;
+60 ; If Payer IEN is not defined or Payer is Nationally Inactive, drop to buffer
+61 IF ('+PIEN)!('$$PYRACTV^IBCNEDE7(PIEN))
SET IBPQ=1
+62 ;
+63 ; Drop to the Buffer and quit, had an issue with Insurance Co or Payer or Policy
+64 IF (SYMBOL)!(IBPQ=1)
Begin DoDot:3
+65 IF '$$BFEXIST^IBCNEDE3(DFN,INSNAME,SUBID,GRPNUM)
DO PT^IBCNEBF(DFN,INREC,SYMBOL,"",1)
End DoDot:3
QUIT
+66 ;
+67 ; If MEDICARE (MFLG) and GRPNUM="PART A" or "PART B", check for the existence in array IBFNDTQ
+68 ; Only allow ONE occurrence in the TQ for Medicare Part A and Medicare Part B, never both
+69 IF MFLG&((GRPNUM="PART A")!(GRPNUM="PART B"))
IF $DATA(IBFNDTQ(PIEN,$SELECT(SUBID="":" ",1:SUBID),"PART A"))!$DATA(IBFNDTQ(PIEN,$SELECT(SUBID="":" ",1:SUBID),"PART B"))
QUIT
+70 ;
+71 ; Check for the existence in array IBFNDTQ, DO NOT continue
+72 IF $DATA(IBFNDTQ(PIEN,$SELECT(SUBID="":" ",1:SUBID),$SELECT(GRPNUM="":" ",1:GRPNUM)))
QUIT
+73 ;
+74 ; Update service date based on Payers allowed date range
+75 DO UPDSD^IBCNEDE3(PIEN,PYRAPP,.SRVICEDT)
+76 ;
+77 ; Initialize variables for TQUPDSV and TQCHKS
+78 SET ADDTQ=1
SET (FSCSEND,TQFOUND)=0
SET TQENT=""
+79 ;
+80 ; Update service dates for inquiry to be transmitted
+81 ; sets TQFOUND, FSCSEND and TQENT
+82 DO TQUPDSV^IBCNEDE3(DFN,PIEN,SRVICEDT,SUBID,GRPNUM)
+83 ; Check to see if a new entry can be added to the TQ file
+84 ; sets ADDTQ
+85 DO TQCHKS^IBCNEDE3(DFN,PIEN,SRVICEDT,SUBID,GRPNUM,$SELECT(MFLG:MFRESHDAY,1:FRESHDAY))
+86 ;
+87 ; to handle Medicare Part A and Medicare Part B, only allow one occurrence
+88 IF ADDTQ&'TQFOUND&MFLG&((GRPNUM="PART A")!(GRPNUM="PART B"))
Begin DoDot:3
+89 SET XXGN=$SELECT(GRPNUM="PART A":"PART B",1:"PART A")
+90 DO TQUPDSV^IBCNEDE3(DFN,PIEN,SRVICEDT,SUBID,XXGN)
+91 DO TQCHKS^IBCNEDE3(DFN,PIEN,SRVICEDT,SUBID,XXGN,$SELECT(MFLG:MFRESHDAY,1:FRESHDAY))
End DoDot:3
+92 ;
+93 ; If a valid entry was found in the TQ file (TQFOUND=1) AND the send to FSC now flag
+94 ; (FSCSEND) is set to '1', transmit to FSC and increment counter
+95 ; DO NOT create a new entry if TQFOUND is true
+96 IF TQFOUND
Begin DoDot:3
+97 ; Increment counter of entries sent to FSC
IF FSCSEND
IF TQENT
IF CNT'>MAXCNT
DO XMIT1^IBCNEDEP(TQENT)
SET CNT=CNT+1
End DoDot:3
QUIT
+98 ; If ADDTQ is set to '0', DO NOT create a new entry (safety valve)
+99 IF 'ADDTQ
QUIT
+100 ;
+101 ; Determine if the Subscriber ID should be included/saved to the TQ
+102 ; The policy has a subscriber ID on file - include subscriber ID
+103 SET QURYFLAG="V"
+104 IF SUBID'=""
DO SET(SUBID,INREC,PATID)
+105 ; If the policy does NOT have subscriber ID on file - don't include subscriber ID
+106 IF SUBID=""
DO SET("",INREC,PATID)
+107 ; Set local array of patient's added to the TQ file
+108 SET IBFNDTQ(PIEN,$SELECT(SUBID="":" ",1:SUBID),$SELECT(GRPNUM="":" ",1:GRPNUM))=1
End DoDot:2
End DoDot:1
+109 ;
ENQ ;
+1 KILL ^TMP($JOB,"SDAMA301")
+2 KILL ^TMP($JOB,"IBCNEDE2DFN")
+3 QUIT
+4 ;========================================================================
GETELST(FILE) ; Returns a '^' delimited list of IENs Type of Plans or Type of
+1 ; coverages to be excluded with leading and trailing '^'s
+2 ;Input:
+3 ; FILE = 355.1 - Type of Plans
+4 ; = 355.2 - Type of Coverages
+5 ;Returns:
+6 ; EXCLIST - '^' delimited list of IENs for Type of Plans or Type of Coverages
+7 ; to be excluded (ie., ^10^6^22^)
+8 ;
+9 NEW EXCLIST,IEN,LINE,TYPE
+10 SET EXCLIST=""
+11 IF FILE="355.1"
FOR LINE=1:1
SET TYPE=$PIECE($TEXT(TOP+LINE),";;",2)
if TYPE=""
QUIT
Begin DoDot:1
+12 IF '$DATA(^IBE(FILE,"B",TYPE))
QUIT
+13 NEW IEN
SET IEN=$ORDER(^IBE(FILE,"B",TYPE,""))
+14 SET EXCLIST=$SELECT(EXCLIST="":IEN,1:EXCLIST_"^"_IEN)
End DoDot:1
+15 ;
+16 IF FILE="355.2"
FOR LINE=1:1
SET TYPE=$PIECE($TEXT(TOC+LINE),";;",2)
if TYPE=""
QUIT
Begin DoDot:1
+17 IF '$DATA(^IBE(FILE,"B",TYPE))
QUIT
+18 NEW IEN
SET IEN=$ORDER(^IBE(FILE,"B",TYPE,""))
+19 SET EXCLIST=$SELECT(EXCLIST="":IEN,1:EXCLIST_"^"_IEN)
End DoDot:1
+20 ;
+21 QUIT "^"_EXCLIST_"^"
+22 ;----------------------------------
TOP ; Type of Plans (#355.1) to exclude
+1 ;;AUTOMOBILE
+2 ;;MEDICAID
+3 ;;MEDI-CAL
+4 ;;TORT FEASOR
+5 ;;WORKERS' COMPENSATION INSURANCE
+6 ;;VA SPECIAL CLASS
+7 ;;ACCIDENT AND HEALTH INSURANCE
+8 ;;AVIATION TRIP INSURANCE
+9 ;;CATASTROPHIC INSURANCE
+10 ;;COINSURANCE
+11 ;;INCOME PROTECTION (INDEMNITY)
+12 ;;MEDICARE/MEDICAID (MEDI-CAL)
+13 ;;QUALIFIED IMPAIRMENT INSURANCE
+14 ;;SPECIAL CLASS INSURANCE
+15 ;;SPECIAL RISK INSURANCE
+16 ;----------------------------------
TOC ; Type of Coverages (#355.2) to exclude
+1 ;;MEDICAID
+2 ;;MEDI-CAL
+3 ;;TORT/FEASOR
+4 ;;WORKERS' COMPENSATION
+5 ;;VA SPECIAL CLASS
+6 ;;DISABILITY INCOME INSURANCE
+7 ;;INDEMNITY
+8 ;;SUBSTANCE ABUSE ONLY
+9 ;----------------------------------
OKFRESH(INREC,FRESHDAY,MFRESHDAY,MFLG) ; Identify those policies to exclude when
+1 ; verified within the "freshness days" for Medicare and non-Medicare policies.
+2 ; INPUT:
+3 ; INREC - IEN to current Insurance Plan
+4 ; FRESHDAY - Freshness Days Span
+5 ; MFRESHDAY - Medicare Freshness Days Span
+6 ; MFLG - Used to determine if the insurance plan is a Medicare Plan - 1=MEDICARE, 0=non-MEDICARE
+7 ; OUTPUT:
+8 ; OK = 0 - Exclude Policy
+9 ; = 1 - Include Policy
+10 NEW GIEN,IIEN,OK,VDATE
+11 SET MFLG=0
SET OK=1
SET VDATE=$PIECE($GET(PTINS(INREC,1)),U,3)
+12 ; Insurance ien
SET IIEN=$PIECE($GET(PTINS(INREC,0)),U,1)
+13 ; Is the Insurance company PAYER (#36,3.1) the same as MEDICARE PAYER (#350.9,51.25)
+14 ;Medicare Part A and Part B Policies
IF $$GET1^DIQ(36,IIEN_",",3.1)=$$GET1^DIQ(350.9,"1,",51.25)
SET MFLG=1
+15 ; Determine if Type of Plan (#355.3,.09) for the Group Plan is MEDICARE ADVANTAGE
+16 IF 'MFLG
Begin DoDot:1
+17 ; Group Plan ien
SET GIEN=+$PIECE($GET(PTINS(INREC,0)),U,18)
+18 ;Medicare Part C
IF GIEN
IF $$GET1^DIQ(355.3,GIEN_",",.09)="MEDICARE ADVANTAGE"
SET MFLG=1
End DoDot:1
+19 ;Medicare Part D (WNR)
IF $$GET1^DIQ(36,IIEN_",",.01)="MEDICARE PART D (WNR)"
SET MFLG=1
+20 ;
+21 ;Non-Medicare Policy outside of Freshness Day span
IF VDATE'=""
IF 'MFLG
IF SRVICEDT'>$$FMADD^XLFDT(VDATE,FRESHDAY)
SET OK=0
+22 ;Medicare Policy outside of Medicare Freshness Day span
IF VDATE'=""
IF MFLG
IF SRVICEDT'>$$FMADD^XLFDT(VDATE,MFRESHDAY)
SET OK=0
+23 QUIT OK
+24 ;----------------------------------
SET(SID,INR,PATID) ; Set data in TQ and send to FSC
+1 ;
+2 NEW DATA1,DATA2,DATA5,ORIG
+3 ;
+4 ; The hard coded '1' in the 3rd piece of DATA1 sets the Transmission
+5 ; status of file 365.1 to "Ready to Transmit"
+6 ; 10/2023: FRESHDT is no longer being included in DATA1
+7 ; SETTQ 1st parameter
SET DATA1=DFN_U_PIEN_U_1_U_""_U_SID
+8 SET $PIECE(DATA1,U,8)=PATID
+9 ;
+10 ; The hardcoded '2' in the 1st piece of DATA2 is the value to tell
+11 ; the file 365.1 that it is the appointment extract.
+12 ; SETTQ 2nd parameter
SET DATA2=2_U_QURYFLAG_U_SRVICEDT_U_INR
+13 ;
+14 SET ORIG=U_$SELECT(GRPNUM=" ":"",1:GRPNUM)_U_$SELECT(GRPNAM=" ":"",1:GRPNAM)
+15 ;
+16 ; Set to IEN of "eIV" Source of Information
SET DATA5=$$FIND1^DIC(355.12,,,"eIV","C")
+17 ;
+18 ; Sets entry into the TQ
SET TQIEN=$$SETTQ^IBCNEDE7(DATA1,DATA2,ORIG,,DATA5)
+19 ; Send entry to FSC
+20 ; Increment the counter of entries sent to FSC
IF TQIEN
IF CNT'>MAXCNT
DO XMIT1^IBCNEDEP(TQIEN)
SET CNT=CNT+1
+21 QUIT
+22 ;----------------------------------
ERRMSG ; Send a message indicating an extract error has occurred
+1 NEW MGRP,XMSUB,MSG,IBX,IBM
+2 ;
+3 ; Set to IB site parameter MAILGROUP
+4 SET MGRP=$$MGRP^IBCNEUT5()
+5 ;
+6 SET XMSUB="eIV Problem: Appointment Extract"
+7 SET MSG(1)="On "_$$FMTE^XLFDT(DT)_" the Appointment Extract for eIV encountered one or more"
+8 SET MSG(2)="errors while attempting to get Appointment data from the scheduling"
+9 SET MSG(3)="package."
+10 SET MSG(4)=""
+11 SET MSG(5)="Error(s) encountered: "
+12 SET MSG(6)=""
+13 SET MSG(7)=" Error Code Error Message"
+14 SET MSG(8)=" ---------- -------------"
+15 SET IBM=8
SET IBX=0
FOR
SET IBX=$ORDER(^TMP($JOB,"SDAMA301",IBX))
if IBX=""
QUIT
SET IBM=IBM+1
SET MSG(IBM)=" "_$$LJ^XLFSTR(IBX,13)_$GET(^TMP($JOB,"SDAMA301",IBX))
+16 SET IBM=IBM+1
SET MSG(IBM)=""
+17 SET IBM=IBM+1
SET MSG(IBM)="As a result of this error the extract was not done. The extract"
+18 SET IBM=IBM+1
SET MSG(IBM)="will be attempted again the next night automatically. If you"
+19 SET IBM=IBM+1
SET MSG(IBM)="continue to receive error messages you should contact your IRM"
+20 SET IBM=IBM+1
SET MSG(IBM)="and possibly call the Help Desk for assistance."
+21 ;
+22 DO MSG^IBCNEUT5(MGRP,XMSUB,"MSG(")
+23 QUIT
