- 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 Feb 18, 2025@23:40:50 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