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**;21-MAR-94;Build 18
;;Per VA Directive 6402, this routine should not be modified.
;
;**Program Description**
; This program finds veterans who are scheduled to be seen within a
; specified date range.
; Periodically check for stop request for background task
;
Q ; can't be called directly
;
EN ; Loop through designated cross-references for updates
; Appointment extract
; IB*2.0*593 - Added EXCLTOC,EXCLTOP now initialized at top. Removed YY.
; IB*2.0*549 - Added YY,ZZ, Re-Arranged in alphabetical order
; IB*2*659/vd - Added the MFRESHDAY variable for Medicare Frequency.
; IB*2.0*743/DTG - Added IBBCK,IBFNDBLUP,IBPAYBLU,IBPQ,IBSNDOK,IBSRVICEDT for management of split dfn find and ins work.
; IB*2.0*743 Reorganize routine thus eliminating looping through the patient's insurance multiple times.
; This improves the efficiency and reduces risk of duplicate requests for the same policy. Make
; sure to create no more than one TQ entry per Blue payer per patient.
N ACTINS,APTDT,CLNC,CNT,DATA1,DATA2,DFN,DISYS,ELG,ENDDT,EXCLTOC,EXCLTOP,FOUND1,FOUND2,FRESHDAY
N FRESHDT,GIEN,IBBCK,IBCNETOT,IBDDI,IBFNDBLUP,IBINDT,IBINS,IBOUTP,IBPAYBLU,IBPQ,IBSDA,IBSDATA
N IBSNDOK,IBSRVICEDT,INREC,INS,INSIEN,INSNAME,MAXCNT,MCAREFLG,MFRESHDAY
N NUM,OK,PATID,PAYER,PAYERID,PAYERSTR,PIEN,QURYFLAG,SETSTR,SID,SIDACT,SIDARRAY,SIDCNT
N SIDDATA,SLCCRIT1,SRVICEDT,SUPPBUFF,SYMBOL,TODAYSDT,TQIEN,VAIN,VDATE,YY,ZZ
;
S SETSTR=$$SETTINGS^IBCNEDE7(2) ; Get setting for pre reg. extract
I 'SETSTR Q ; Quit if extract is not active
S SLCCRIT1=$P(SETSTR,U,2) ; Selection Criteria #1
S MAXCNT=$P(SETSTR,U,4) ; Max # of TQ entries to create
S:MAXCNT="" MAXCNT=9999999999
S SUPPBUFF=$P(SETSTR,U,5) ; Suppress Buffer Flag
S FRESHDAY=$P($G(^IBE(350.9,1,51)),U,1) ; Freshness days span
S MFRESHDAY=$$GET1^DIQ(350.9,"1,",51.32) ;/vd-IB*2*659 - Medicare Freshness days span
S CNT=0 ; Init. TQ entry counter
S ENDDT=$$FMADD^XLFDT(DT,SLCCRIT1) ; End of appt. date selection range
S IBCNETOT=0 ; Initialize count for periodic TaskMan check
S EXCLTOC=$$GETELST(355.2) ; Initialize excluded TYPEs OF COVERAGE IB*2.0*593
S EXCLTOP=$$GETELST(355.1) ; Initialize excluded TYPEs OF PLAN IB*2.0*593
K ^TMP($J,"SDAMA301"),^TMP("IBCNEDE2",$J) ; Clean TMP globals
K ^TMP($J,"IBCNEDE2DFN") ; IB*743/DTG collect DFN's that are potential candidates for this extract
;
S CLNC=0 ; Init. clinic
; Loop through clinics
F S CLNC=$O(^SC(CLNC)) Q:'CLNC!(CNT'<MAXCNT) D Q:$G(ZTSTOP)
. ;
. D CLINICEX Q:'OK ; Check for clinic exclusion
. ;
. S ^TMP("IBCNEDE2",$J,CLNC)=""
;
; Set up variables for scheduling call and call
S IBSDA("FLDS")=8
S IBSDA(1)=DT_";"_ENDDT
S IBSDA(2)="^TMP(""IBCNEDE2"",$J,"
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)!(CNT'<MAXCNT)
. ;
. ; Loop through patients returned
. S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",CLNC,DFN)) Q:'DFN!(CNT'<MAXCNT) D Q:$G(ZTSTOP)
.. ;
.. S APTDT=DT ; Check for appointment date
.. S MCAREFLG=0
.. ;
.. ; Loop through dates in range at clinic
.. F S APTDT=$O(^TMP($J,"SDAMA301",CLNC,DFN,APTDT)) Q:('APTDT)!((APTDT\1)>ENDDT)!(CNT'<MAXCNT) D Q:$G(ZTSTOP)
... ;S FRESHDT=$$FMADD^XLFDT(SRVICEDT,-FRESHDAY) ;/vd - IB*2.0*659 - moved the setting of FRESHDT to right after the OKFRESH call
... ;
... 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
... ;
... S IBSDATA=$G(^TMP($J,"SDAMA301",CLNC,DFN,APTDT))
... S ELG=$P(IBSDATA,U,8)
... S ELG=$S(ELG'="":ELG,1:$P($G(^DPT(DFN,.36)),U,1))
... I $P($G(^DPT(DFN,0)),U,21) Q ; Exclude if test patient
... ; IB*2.0*549 removed the following line
... ;I $P($G(^DPT(DFN,.35)),"^",1)'="" Q ; Exclude if patient is deceased
... ;
... D ELG Q:'OK ; Check for eligibility exclusion
... ;
... ;IB*743/DTG build temp array for allowed DFN's
... S ^TMP($J,"IBCNEDE2DFN",DFN,(+$G(SRVICEDT)))=""
;
; IB*743/DTG check the insurance for the selected DFNs
;
S DFN=0
F S DFN=$O(^TMP($J,"IBCNEDE2DFN",DFN)) Q:'DFN K IBFNDBLUP D ;IB*743/DTG new $order based on DFN
. ;
. K ACTINS
. D ALL^IBCNS1(DFN,"ACTINS",2)
. ;
. I '$D(ACTINS(0)) Q ; Patient has no active ins
. ;
. S MCAREFLG=0
. S IBSRVICEDT=""
. F S IBSRVICEDT=$O(^TMP($J,"IBCNEDE2DFN",DFN,IBSRVICEDT)) Q:'IBSRVICEDT D ;loop thru service dates
.. ;
.. S SRVICEDT=IBSRVICEDT,INREC=0 ; Record IEN
.. F S INREC=$O(ACTINS(INREC)) Q:('INREC)!(CNT'<MAXCNT) D
... N MFLG ;Initialized in $$OKFRESH IB*2.0*659/VD
... S INSIEN=$P($G(ACTINS(INREC,0)),U,1) ; Insurance ien
... S INSNAME=$P($G(^DIC(36,INSIEN,0)),U)
... ;
... ; IB*2.0*549 Added next 3 lines to exclude certain Type of Coverages
... ; IB*2.0*593 Moved exclusion list initialization to top execution level.
... S ZZ=$$GET1^DIQ(36,INSIEN_",",.13,"I") ; Type of Coverage
... ;S YY=$$GETELST(355.2) ; Type of Coverages to exclude
... ;Q:YY[("^"_ZZ_"^") ; Excluded Type of Coverage
... Q:EXCLTOC[("^"_ZZ_"^") ; Excluded Type of Coverage
... ;
... ;/vd-IB*2*659 - Replaced the following lines with the call to OKFRESH
... ; which properly identify those policies to exclude when
... ; verified within the "freshness days" for Medicare and
... ; non-Medicare policies.
... ; Exclude policies that have been verified within "freshness days"
... ;S VDATE=$P($G(ACTINS(INREC,1)),U,3)
... ;I VDATE'="",SRVICEDT'>$$FMADD^XLFDT(VDATE,FRESHDAY) Q
... I '$$OKFRESH(INREC,FRESHDAY,MFRESHDAY,.MFLG) Q
... S FRESHDT=$$FMADD^XLFDT(SRVICEDT,$S(MFLG:-MFRESHDAY,1:-FRESHDAY))
... ;
... ; Allow only one MEDICARE transmission per patient
... I INSNAME["MEDICARE",MCAREFLG Q
... ;
... ; Exclude pharmacy policies IB*2.0*549 - Commented out following line
... ;I $$GET1^DIQ(36,INSIEN_",",.13)="PRESCRIPTION ONLY" Q
... S GIEN=+$P($G(ACTINS(INREC,0)),U,18)
... ;
... ; IB*2.0*549 Added next 3 lines to exclude certain Type of Plans
... ; IB*2.0*593/TAZ Moved exclusion list initialization to top execution level.
... S ZZ=$$GET1^DIQ(355.3,GIEN_",",.09,"I") ; Type of Plan
... ;S YY=$$GETELST(355.1) ; Type of Plans to exclude
... ;Q:YY[("^"_ZZ_"^") ; Excluded Type of Plan
... Q:EXCLTOP[("^"_ZZ_"^") ; Excluded Type of Plan
... ;
... ;I GIEN,$$GET1^DIQ(355.3,GIEN_",",.09)="PRESCRIPTION" Q ; IB*2.0*549 - Removed line
... ; check for ins. to exclude (i.e. Medicaid)
... I $$EXCLUDE^IBCNEUT4(INSNAME) Q
... ; check insurance policy expiration date
... I $$EXPIRED($P($G(ACTINS(INREC,0)),U,4)) Q
... ;
... ; set patient id field IB*2*416
... S PATID=$P($G(ACTINS(INREC,5)),U,1) ; 5.01 field
... ;
... S PAYERSTR=$$INSERROR^IBCNEUT3("I",INSIEN) ; Get payer info
... ;
... S SYMBOL=+PAYERSTR ; error symbol
... S PAYERID=$P(PAYERSTR,U,3) ; (National ID) payer id
... S PIEN=$P(PAYERSTR,U,2) ; Payer ien
... ;IB*743/DTG get payer ISBLUE flag from file #365.12
... S IBPAYBLU=0
... I +PIEN S IBPQ=0 D I IBPQ Q ; IB*743/DTG only submit blue payer once
.... K IBBCK D PAYER^IBCNINSU(+PIEN,,".09","I",.IBBCK)
.... S IBPAYBLU=+$G(IBBCK(365.12,(+PIEN)_",",.09,"I"))
.... I IBPAYBLU&(+$G(IBFNDBLUP(PIEN))=1) S IBPQ=1
... ;
... ; If Payer is Nationally Inactive create an Insurance Buffer record w/blank SYMBOL & quit. - IB*2.0*506
... I '$$PYRACTV^IBCNEDE7(PIEN) D Q
.... S SYMBOL=""
.... I 'SUPPBUFF,'$$BFEXIST^IBCNEUT5(DFN,INSNAME) D PT^IBCNEBF(DFN,INREC,SYMBOL,"",1)
... ;
... ; If error symbol exists, set record in insurance buffer & quit
... I SYMBOL D Q
.... I 'SUPPBUFF,'$$BFEXIST^IBCNEUT5(DFN,INSNAME) D PT^IBCNEBF(DFN,INREC,SYMBOL,"",1)
... ;
... ; Update service date and freshness date based on payers allowed
... ; date range
... D UPDDTS^IBCNEDE6(PIEN,.SRVICEDT,.FRESHDT)
... ;
... ; Update service dates for inquiry to be transmitted
... D TQUPDSV^IBCNEUT5(DFN,PIEN,SRVICEDT)
... ;
... ; Quit before filing if outstanding entries in TQ
... ; IB*2.0*659/VD - Added $S for MFLG
... I '$$ADDTQ^IBCNEUT5(DFN,PIEN,SRVICEDT,$S(MFLG:MFRESHDAY,1:FRESHDAY),0) Q ;IB*2.0*621 add flag, from EICDEXT
... ;
... S QURYFLAG="V"
... K SIDARRAY
... S SIDDATA=$$SIDCHK^IBCNEDE5(PIEN,DFN,,.SIDARRAY,FRESHDT)
... S SIDACT=$P(SIDDATA,U),SIDCNT=$P(SIDDATA,U,2)
... I SIDACT=3,'SUPPBUFF,'$$BFEXIST^IBCNEUT5(DFN,INSNAME) D PT^IBCNEBF(DFN,INREC,18,"",1) Q
... I CNT+SIDCNT>MAXCNT S CNT=MAXCNT Q ;exceeds MAXCNT
... ;
... S SID=""
... ;F S SID=$O(SIDARRAY(SID)) Q:SID="" D:$P(SID,"_")'="" SET($P(SID,"_"),$P(SID,"_",2),PATID) S:INSNAME["MEDICARE" MCAREFLG=1
... F S SID=$O(SIDARRAY(SID)) Q:SID="" D
... . I $P(SID,"_")="" Q
... . I (PIEN&(IBPAYBLU)&(+$G(IBFNDBLUP(PIEN))=1)) Q ; IB*743/DTG only submit blue payer once
... . D SET($P(SID,"_"),$P(SID,"_",2),PATID) D
... .. S:INSNAME["MEDICARE" MCAREFLG=1
... .. I (PIEN&(IBPAYBLU)&(+$G(TQIEN)>0)) S IBFNDBLUP(PIEN)=1
... ;
... I SIDACT=4 D
... . ;D SET("","",PATID)
... . ;S:INSNAME["MEDICARE" MCAREFLG=1
... . ; IB*743/DTG keep check and INSNAME check at same level
... . S IBSNDOK=1 I (PIEN&(IBPAYBLU)&(+$G(IBFNDBLUP(PIEN))=1)) S IBSNDOK=0 ; IB*743/DTG only submit blue payer once
... . I +IBSNDOK D SET("","",PATID) I (PIEN&(IBPAYBLU)&(+$G(TQIEN)>0)) S IBFNDBLUP(PIEN)=1 ; IB*743/DTG if isblue and filed then only do once
... . S:INSNAME["MEDICARE" MCAREFLG=1
;
ENQ K ^TMP($J,"SDAMA301"),^TMP("IBCNEDE2",$J)
K ^TMP($J,"IBCNEDE2DFN") ; IB*743/DTG
Q
;
GETELST(FILE) ; Returns a '^' delimited list of Type of Plans or Type of
; coverages to be excluded with leading and trailing '^'s
; IB*2.0*549 Added method
; IB*2.0*593 Added NO-FAULT INSURANCE. Refactored.
; Input: FILE - 355.1 - Return a list of Type of Plans to be excluded
; 355.2 - Return a list of Type of Coverages to be excluded
; Returns: '^' delimited list of Type of Plans or Type of Coverages
; to be excluded
;N EXCLIST,IEN,NM,XX
;S EXCLIST="",NM("AUTOMOBILE")="",NM("MEDI-CAL")="",NM("TORT FEASOR")=""
;S NM("WORKERS' COMPENSATION INSURANCE")="",NM("VA SPECIAL CLASS")=""
;S NM("MEDICAID")=""
;S XX=""
;F D Q:XX=""
;. S XX=$O(NM(XX))
;. Q:XX=""
;. S IEN=""
;. F D Q:IEN=""
;. . S IEN=$O(^IBE(FILE,"B",XX,IEN))
;. . Q:IEN=""
;. . S EXCLIST=$S(EXCLIST="":IEN,1:EXCLIST_"^"_IEN)
N EXCLIST,TYPE
S EXCLIST=""
F TYPE="AUTOMOBILE","MEDICAID","MEDI-CAL","NO-FAULT INSURANCE","TORT FEASOR","WORKERS' COMPENSATION INSURANCE","VA SPECIAL CLASS" D
. N IEN S IEN=$O(^IBE(FILE,"B",TYPE,""))
. Q:IEN=""
. S EXCLIST=$S(EXCLIST="":IEN,1:EXCLIST_"^"_IEN)
Q "^"_EXCLIST_"^"
;
CLINICEX ; Clinic exclusion
S OK=1
I $D(^DG(43,1,"DGPREC","B",CLNC)) S OK=0
Q
;
ELG ; Eligibility exclusion
I ELG="" S OK=0 Q
I $D(^DG(43,1,"DGPREE","B",ELG)) S OK=0 Q
S OK=1
Q
;
INP ; Inpatient status
D INP^VADPT
I $G(VAIN(1))'="" K VAIN S OK=0 Q
K VAIN
S OK=1
Q
;
SET(SID,INR,PATID) ; Set data in TQ
;
; The hard coded '1' in the 3rd piece of DATA1 sets the Transmission
; status of file 365.1 to "Ready to Transmit"
;
; IB*2*595/DM add DATA5 to the SETTQ call
N DATA5
;
S DATA1=DFN_U_PIEN_U_1_U_""_U_SID_U_FRESHDT ; SETTQ 1st parameter
S $P(DATA1,U,8)=PATID ; IB*2*416
;
; 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 DATA5=$$FIND1^DIC(355.12,,,"eIV","C") ; Set to IEN of "eIV" Source of Information
;
S TQIEN=$$SETTQ^IBCNEDE7(DATA1,DATA2,,,DATA5) ; Sets in TQ
I TQIEN'="" S CNT=CNT+1 ; If filed increment count
;
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
;
;/vd-IB*2.0*659 - Added the OKFRESH module of code to verify Policies.
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(ACTINS(INREC,1)),U,3)
S IIEN=$P($G(ACTINS(INREC,0)),U,1) ; Insurance ien
I $$GET1^DIQ(36,IIEN_",",3.1)=$$GET1^DIQ(350.9,"1,",51.25) S MFLG=1 ; These are Medicare Part A and Part B Policies.
I 'MFLG D ;Determine if Group Plan is for Medicare Replacement (Part C) Policies (MEDICARE ADVANTAGE)
. S GIEN=+$P($G(ACTINS(INREC,0)),U,18) ; Group Plan ien
. I GIEN,$$GET1^DIQ(355.3,GIEN_",",.09)="MEDICARE ADVANTAGE" S MFLG=1 ; Type of Policy
. Q
I $$GET1^DIQ(36,IIEN_",",.01)="MEDICARE PART D (WNR)" S MFLG=1 ; This is a Medicare Part D (MEDICARE (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
;
EXPIRED(EXPDT) ; check if insurance policy has already expired
; EXPDT - expiration date (2.312/3)
; returns 1 if expiration date is in the past, 0 otherwise
N X1,X2
S X1=+$G(DT),X2=+$G(EXPDT)
I X1,X2 Q $S($$FMDIFF^XLFDT(DT,EXPDT,1)>0:1,1:0)
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEDE2 15372 printed Apr 09, 2024@21:38:37 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**;21-MAR-94;Build 18
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;**Program Description**
+5 ; This program finds veterans who are scheduled to be seen within a
+6 ; specified date range.
+7 ; Periodically check for stop request for background task
+8 ;
+9 ; can't be called directly
QUIT
+10 ;
EN ; Loop through designated cross-references for updates
+1 ; Appointment extract
+2 ; IB*2.0*593 - Added EXCLTOC,EXCLTOP now initialized at top. Removed YY.
+3 ; IB*2.0*549 - Added YY,ZZ, Re-Arranged in alphabetical order
+4 ; IB*2*659/vd - Added the MFRESHDAY variable for Medicare Frequency.
+5 ; IB*2.0*743/DTG - Added IBBCK,IBFNDBLUP,IBPAYBLU,IBPQ,IBSNDOK,IBSRVICEDT for management of split dfn find and ins work.
+6 ; IB*2.0*743 Reorganize routine thus eliminating looping through the patient's insurance multiple times.
+7 ; This improves the efficiency and reduces risk of duplicate requests for the same policy. Make
+8 ; sure to create no more than one TQ entry per Blue payer per patient.
+9 NEW ACTINS,APTDT,CLNC,CNT,DATA1,DATA2,DFN,DISYS,ELG,ENDDT,EXCLTOC,EXCLTOP,FOUND1,FOUND2,FRESHDAY
+10 NEW FRESHDT,GIEN,IBBCK,IBCNETOT,IBDDI,IBFNDBLUP,IBINDT,IBINS,IBOUTP,IBPAYBLU,IBPQ,IBSDA,IBSDATA
+11 NEW IBSNDOK,IBSRVICEDT,INREC,INS,INSIEN,INSNAME,MAXCNT,MCAREFLG,MFRESHDAY
+12 NEW NUM,OK,PATID,PAYER,PAYERID,PAYERSTR,PIEN,QURYFLAG,SETSTR,SID,SIDACT,SIDARRAY,SIDCNT
+13 NEW SIDDATA,SLCCRIT1,SRVICEDT,SUPPBUFF,SYMBOL,TODAYSDT,TQIEN,VAIN,VDATE,YY,ZZ
+14 ;
+15 ; Get setting for pre reg. extract
SET SETSTR=$$SETTINGS^IBCNEDE7(2)
+16 ; Quit if extract is not active
IF 'SETSTR
QUIT
+17 ; Selection Criteria #1
SET SLCCRIT1=$PIECE(SETSTR,U,2)
+18 ; Max # of TQ entries to create
SET MAXCNT=$PIECE(SETSTR,U,4)
+19 if MAXCNT=""
SET MAXCNT=9999999999
+20 ; Suppress Buffer Flag
SET SUPPBUFF=$PIECE(SETSTR,U,5)
+21 ; Freshness days span
SET FRESHDAY=$PIECE($GET(^IBE(350.9,1,51)),U,1)
+22 ;/vd-IB*2*659 - Medicare Freshness days span
SET MFRESHDAY=$$GET1^DIQ(350.9,"1,",51.32)
+23 ; Init. TQ entry counter
SET CNT=0
+24 ; End of appt. date selection range
SET ENDDT=$$FMADD^XLFDT(DT,SLCCRIT1)
+25 ; Initialize count for periodic TaskMan check
SET IBCNETOT=0
+26 ; Initialize excluded TYPEs OF COVERAGE IB*2.0*593
SET EXCLTOC=$$GETELST(355.2)
+27 ; Initialize excluded TYPEs OF PLAN IB*2.0*593
SET EXCLTOP=$$GETELST(355.1)
+28 ; Clean TMP globals
KILL ^TMP($JOB,"SDAMA301"),^TMP("IBCNEDE2",$JOB)
+29 ; IB*743/DTG collect DFN's that are potential candidates for this extract
KILL ^TMP($JOB,"IBCNEDE2DFN")
+30 ;
+31 ; Init. clinic
SET CLNC=0
+32 ; Loop through clinics
+33 FOR
SET CLNC=$ORDER(^SC(CLNC))
if 'CLNC!(CNT'<MAXCNT)
QUIT
Begin DoDot:1
+34 ;
+35 ; Check for clinic exclusion
DO CLINICEX
if 'OK
QUIT
+36 ;
+37 SET ^TMP("IBCNEDE2",$JOB,CLNC)=""
End DoDot:1
if $GET(ZTSTOP)
QUIT
+38 ;
+39 ; Set up variables for scheduling call and call
+40 SET IBSDA("FLDS")=8
+41 SET IBSDA(1)=DT_";"_ENDDT
+42 SET IBSDA(2)="^TMP(""IBCNEDE2"",$J,"
+43 SET IBSDA(3)="R"
+44 SET NUM=$$SDAPI^SDAMA301(.IBSDA)
IF NUM<1
if NUM<0
DO ERRMSG
GOTO ENQ
+45 ;
+46 ;
+47 ; Init. clinic
SET CLNC=0
+48 ; Loop through clinics returned
+49 FOR
SET CLNC=$ORDER(^TMP($JOB,"SDAMA301",CLNC))
if 'CLNC
QUIT
Begin DoDot:1
+50 ;
+51 ; Loop through patients returned
+52 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"SDAMA301",CLNC,DFN))
if 'DFN!(CNT'<MAXCNT)
QUIT
Begin DoDot:2
+53 ;
+54 ; Check for appointment date
SET APTDT=DT
+55 SET MCAREFLG=0
+56 ;
+57 ; Loop through dates in range at clinic
+58 FOR
SET APTDT=$ORDER(^TMP($JOB,"SDAMA301",CLNC,DFN,APTDT))
if ('APTDT)!((APTDT\1)>ENDDT)!(CNT'<MAXCNT)
QUIT
Begin DoDot:3
+59 ;S FRESHDT=$$FMADD^XLFDT(SRVICEDT,-FRESHDAY) ;/vd - IB*2.0*659 - moved the setting of FRESHDT to right after the OKFRESH call
+60 ;
+61 ;Set service date equal to appointment date
SET SRVICEDT=APTDT\1
+62 ;
+63 ; Update count for periodic check
+64 SET IBCNETOT=IBCNETOT+1
+65 ; Check for request to stop background job, periodically
+66 IF $DATA(ZTQUEUED)
IF IBCNETOT#100=0
IF $$S^%ZTLOAD()
SET ZTSTOP=1
QUIT
+67 ;
+68 SET IBSDATA=$GET(^TMP($JOB,"SDAMA301",CLNC,DFN,APTDT))
+69 SET ELG=$PIECE(IBSDATA,U,8)
+70 SET ELG=$SELECT(ELG'="":ELG,1:$PIECE($GET(^DPT(DFN,.36)),U,1))
+71 ; Exclude if test patient
IF $PIECE($GET(^DPT(DFN,0)),U,21)
QUIT
+72 ; IB*2.0*549 removed the following line
+73 ;I $P($G(^DPT(DFN,.35)),"^",1)'="" Q ; Exclude if patient is deceased
+74 ;
+75 ; Check for eligibility exclusion
DO ELG
if 'OK
QUIT
+76 ;
+77 ;IB*743/DTG build temp array for allowed DFN's
+78 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)!(CNT'<MAXCNT)
QUIT
+79 ;
+80 ; IB*743/DTG check the insurance for the selected DFNs
+81 ;
+82 SET DFN=0
+83 ;IB*743/DTG new $order based on DFN
FOR
SET DFN=$ORDER(^TMP($JOB,"IBCNEDE2DFN",DFN))
if 'DFN
QUIT
KILL IBFNDBLUP
Begin DoDot:1
+84 ;
+85 KILL ACTINS
+86 DO ALL^IBCNS1(DFN,"ACTINS",2)
+87 ;
+88 ; Patient has no active ins
IF '$DATA(ACTINS(0))
QUIT
+89 ;
+90 SET MCAREFLG=0
+91 SET IBSRVICEDT=""
+92 ;loop thru service dates
FOR
SET IBSRVICEDT=$ORDER(^TMP($JOB,"IBCNEDE2DFN",DFN,IBSRVICEDT))
if 'IBSRVICEDT
QUIT
Begin DoDot:2
+93 ;
+94 ; Record IEN
SET SRVICEDT=IBSRVICEDT
SET INREC=0
+95 FOR
SET INREC=$ORDER(ACTINS(INREC))
if ('INREC)!(CNT'<MAXCNT)
QUIT
Begin DoDot:3
+96 ;Initialized in $$OKFRESH IB*2.0*659/VD
NEW MFLG
+97 ; Insurance ien
SET INSIEN=$PIECE($GET(ACTINS(INREC,0)),U,1)
+98 SET INSNAME=$PIECE($GET(^DIC(36,INSIEN,0)),U)
+99 ;
+100 ; IB*2.0*549 Added next 3 lines to exclude certain Type of Coverages
+101 ; IB*2.0*593 Moved exclusion list initialization to top execution level.
+102 ; Type of Coverage
SET ZZ=$$GET1^DIQ(36,INSIEN_",",.13,"I")
+103 ;S YY=$$GETELST(355.2) ; Type of Coverages to exclude
+104 ;Q:YY[("^"_ZZ_"^") ; Excluded Type of Coverage
+105 ; Excluded Type of Coverage
if EXCLTOC[("^"_ZZ_"^")
QUIT
+106 ;
+107 ;/vd-IB*2*659 - Replaced the following lines with the call to OKFRESH
+108 ; which properly identify those policies to exclude when
+109 ; verified within the "freshness days" for Medicare and
+110 ; non-Medicare policies.
+111 ; Exclude policies that have been verified within "freshness days"
+112 ;S VDATE=$P($G(ACTINS(INREC,1)),U,3)
+113 ;I VDATE'="",SRVICEDT'>$$FMADD^XLFDT(VDATE,FRESHDAY) Q
+114 IF '$$OKFRESH(INREC,FRESHDAY,MFRESHDAY,.MFLG)
QUIT
+115 SET FRESHDT=$$FMADD^XLFDT(SRVICEDT,$SELECT(MFLG:-MFRESHDAY,1:-FRESHDAY))
+116 ;
+117 ; Allow only one MEDICARE transmission per patient
+118 IF INSNAME["MEDICARE"
IF MCAREFLG
QUIT
+119 ;
+120 ; Exclude pharmacy policies IB*2.0*549 - Commented out following line
+121 ;I $$GET1^DIQ(36,INSIEN_",",.13)="PRESCRIPTION ONLY" Q
+122 SET GIEN=+$PIECE($GET(ACTINS(INREC,0)),U,18)
+123 ;
+124 ; IB*2.0*549 Added next 3 lines to exclude certain Type of Plans
+125 ; IB*2.0*593/TAZ Moved exclusion list initialization to top execution level.
+126 ; Type of Plan
SET ZZ=$$GET1^DIQ(355.3,GIEN_",",.09,"I")
+127 ;S YY=$$GETELST(355.1) ; Type of Plans to exclude
+128 ;Q:YY[("^"_ZZ_"^") ; Excluded Type of Plan
+129 ; Excluded Type of Plan
if EXCLTOP[("^"_ZZ_"^")
QUIT
+130 ;
+131 ;I GIEN,$$GET1^DIQ(355.3,GIEN_",",.09)="PRESCRIPTION" Q ; IB*2.0*549 - Removed line
+132 ; check for ins. to exclude (i.e. Medicaid)
+133 IF $$EXCLUDE^IBCNEUT4(INSNAME)
QUIT
+134 ; check insurance policy expiration date
+135 IF $$EXPIRED($PIECE($GET(ACTINS(INREC,0)),U,4))
QUIT
+136 ;
+137 ; set patient id field IB*2*416
+138 ; 5.01 field
SET PATID=$PIECE($GET(ACTINS(INREC,5)),U,1)
+139 ;
+140 ; Get payer info
SET PAYERSTR=$$INSERROR^IBCNEUT3("I",INSIEN)
+141 ;
+142 ; error symbol
SET SYMBOL=+PAYERSTR
+143 ; (National ID) payer id
SET PAYERID=$PIECE(PAYERSTR,U,3)
+144 ; Payer ien
SET PIEN=$PIECE(PAYERSTR,U,2)
+145 ;IB*743/DTG get payer ISBLUE flag from file #365.12
+146 SET IBPAYBLU=0
+147 ; IB*743/DTG only submit blue payer once
IF +PIEN
SET IBPQ=0
Begin DoDot:4
+148 KILL IBBCK
DO PAYER^IBCNINSU(+PIEN,,".09","I",.IBBCK)
+149 SET IBPAYBLU=+$GET(IBBCK(365.12,(+PIEN)_",",.09,"I"))
+150 IF IBPAYBLU&(+$GET(IBFNDBLUP(PIEN))=1)
SET IBPQ=1
End DoDot:4
IF IBPQ
QUIT
+151 ;
+152 ; If Payer is Nationally Inactive create an Insurance Buffer record w/blank SYMBOL & quit. - IB*2.0*506
+153 IF '$$PYRACTV^IBCNEDE7(PIEN)
Begin DoDot:4
+154 SET SYMBOL=""
+155 IF 'SUPPBUFF
IF '$$BFEXIST^IBCNEUT5(DFN,INSNAME)
DO PT^IBCNEBF(DFN,INREC,SYMBOL,"",1)
End DoDot:4
QUIT
+156 ;
+157 ; If error symbol exists, set record in insurance buffer & quit
+158 IF SYMBOL
Begin DoDot:4
+159 IF 'SUPPBUFF
IF '$$BFEXIST^IBCNEUT5(DFN,INSNAME)
DO PT^IBCNEBF(DFN,INREC,SYMBOL,"",1)
End DoDot:4
QUIT
+160 ;
+161 ; Update service date and freshness date based on payers allowed
+162 ; date range
+163 DO UPDDTS^IBCNEDE6(PIEN,.SRVICEDT,.FRESHDT)
+164 ;
+165 ; Update service dates for inquiry to be transmitted
+166 DO TQUPDSV^IBCNEUT5(DFN,PIEN,SRVICEDT)
+167 ;
+168 ; Quit before filing if outstanding entries in TQ
+169 ; IB*2.0*659/VD - Added $S for MFLG
+170 ;IB*2.0*621 add flag, from EICDEXT
IF '$$ADDTQ^IBCNEUT5(DFN,PIEN,SRVICEDT,$SELECT(MFLG:MFRESHDAY,1:FRESHDAY),0)
QUIT
+171 ;
+172 SET QURYFLAG="V"
+173 KILL SIDARRAY
+174 SET SIDDATA=$$SIDCHK^IBCNEDE5(PIEN,DFN,,.SIDARRAY,FRESHDT)
+175 SET SIDACT=$PIECE(SIDDATA,U)
SET SIDCNT=$PIECE(SIDDATA,U,2)
+176 IF SIDACT=3
IF 'SUPPBUFF
IF '$$BFEXIST^IBCNEUT5(DFN,INSNAME)
DO PT^IBCNEBF(DFN,INREC,18,"",1)
QUIT
+177 ;exceeds MAXCNT
IF CNT+SIDCNT>MAXCNT
SET CNT=MAXCNT
QUIT
+178 ;
+179 SET SID=""
+180 ;F S SID=$O(SIDARRAY(SID)) Q:SID="" D:$P(SID,"_")'="" SET($P(SID,"_"),$P(SID,"_",2),PATID) S:INSNAME["MEDICARE" MCAREFLG=1
+181 FOR
SET SID=$ORDER(SIDARRAY(SID))
if SID=""
QUIT
Begin DoDot:4
+182 IF $PIECE(SID,"_")=""
QUIT
+183 ; IB*743/DTG only submit blue payer once
IF (PIEN&(IBPAYBLU)&(+$GET(IBFNDBLUP(PIEN))=1))
QUIT
+184 DO SET($PIECE(SID,"_"),$PIECE(SID,"_",2),PATID)
Begin DoDot:5
+185 if INSNAME["MEDICARE"
SET MCAREFLG=1
+186 IF (PIEN&(IBPAYBLU)&(+$GET(TQIEN)>0))
SET IBFNDBLUP(PIEN)=1
End DoDot:5
End DoDot:4
+187 ;
+188 IF SIDACT=4
Begin DoDot:4
+189 ;D SET("","",PATID)
+190 ;S:INSNAME["MEDICARE" MCAREFLG=1
+191 ; IB*743/DTG keep check and INSNAME check at same level
+192 ; IB*743/DTG only submit blue payer once
SET IBSNDOK=1
IF (PIEN&(IBPAYBLU)&(+$GET(IBFNDBLUP(PIEN))=1))
SET IBSNDOK=0
+193 ; IB*743/DTG if isblue and filed then only do once
IF +IBSNDOK
DO SET("","",PATID)
IF (PIEN&(IBPAYBLU)&(+$GET(TQIEN)>0))
SET IBFNDBLUP(PIEN)=1
+194 if INSNAME["MEDICARE"
SET MCAREFLG=1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+195 ;
ENQ KILL ^TMP($JOB,"SDAMA301"),^TMP("IBCNEDE2",$JOB)
+1 ; IB*743/DTG
KILL ^TMP($JOB,"IBCNEDE2DFN")
+2 QUIT
+3 ;
GETELST(FILE) ; Returns a '^' delimited list of Type of Plans or Type of
+1 ; coverages to be excluded with leading and trailing '^'s
+2 ; IB*2.0*549 Added method
+3 ; IB*2.0*593 Added NO-FAULT INSURANCE. Refactored.
+4 ; Input: FILE - 355.1 - Return a list of Type of Plans to be excluded
+5 ; 355.2 - Return a list of Type of Coverages to be excluded
+6 ; Returns: '^' delimited list of Type of Plans or Type of Coverages
+7 ; to be excluded
+8 ;N EXCLIST,IEN,NM,XX
+9 ;S EXCLIST="",NM("AUTOMOBILE")="",NM("MEDI-CAL")="",NM("TORT FEASOR")=""
+10 ;S NM("WORKERS' COMPENSATION INSURANCE")="",NM("VA SPECIAL CLASS")=""
+11 ;S NM("MEDICAID")=""
+12 ;S XX=""
+13 ;F D Q:XX=""
+14 ;. S XX=$O(NM(XX))
+15 ;. Q:XX=""
+16 ;. S IEN=""
+17 ;. F D Q:IEN=""
+18 ;. . S IEN=$O(^IBE(FILE,"B",XX,IEN))
+19 ;. . Q:IEN=""
+20 ;. . S EXCLIST=$S(EXCLIST="":IEN,1:EXCLIST_"^"_IEN)
+21 NEW EXCLIST,TYPE
+22 SET EXCLIST=""
+23 FOR TYPE="AUTOMOBILE","MEDICAID","MEDI-CAL","NO-FAULT INSURANCE","TORT FEASOR","WORKERS' COMPENSATION INSURANCE","VA SPECIAL CLASS"
Begin DoDot:1
+24 NEW IEN
SET IEN=$ORDER(^IBE(FILE,"B",TYPE,""))
+25 if IEN=""
QUIT
+26 SET EXCLIST=$SELECT(EXCLIST="":IEN,1:EXCLIST_"^"_IEN)
End DoDot:1
+27 QUIT "^"_EXCLIST_"^"
+28 ;
CLINICEX ; Clinic exclusion
+1 SET OK=1
+2 IF $DATA(^DG(43,1,"DGPREC","B",CLNC))
SET OK=0
+3 QUIT
+4 ;
ELG ; Eligibility exclusion
+1 IF ELG=""
SET OK=0
QUIT
+2 IF $DATA(^DG(43,1,"DGPREE","B",ELG))
SET OK=0
QUIT
+3 SET OK=1
+4 QUIT
+5 ;
INP ; Inpatient status
+1 DO INP^VADPT
+2 IF $GET(VAIN(1))'=""
KILL VAIN
SET OK=0
QUIT
+3 KILL VAIN
+4 SET OK=1
+5 QUIT
+6 ;
SET(SID,INR,PATID) ; Set data in TQ
+1 ;
+2 ; The hard coded '1' in the 3rd piece of DATA1 sets the Transmission
+3 ; status of file 365.1 to "Ready to Transmit"
+4 ;
+5 ; IB*2*595/DM add DATA5 to the SETTQ call
+6 NEW DATA5
+7 ;
+8 ; SETTQ 1st parameter
SET DATA1=DFN_U_PIEN_U_1_U_""_U_SID_U_FRESHDT
+9 ; IB*2*416
SET $PIECE(DATA1,U,8)=PATID
+10 ;
+11 ; The hardcoded '2' in the 1st piece of DATA2 is the value to tell
+12 ; the file 365.1 that it is the appointment extract.
+13 ; SETTQ 2nd parameter
SET DATA2=2_U_QURYFLAG_U_SRVICEDT_U_INR
+14 ;
+15 ; Set to IEN of "eIV" Source of Information
SET DATA5=$$FIND1^DIC(355.12,,,"eIV","C")
+16 ;
+17 ; Sets in TQ
SET TQIEN=$$SETTQ^IBCNEDE7(DATA1,DATA2,,,DATA5)
+18 ; If filed increment count
IF TQIEN'=""
SET CNT=CNT+1
+19 ;
+20 QUIT
+21 ;
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 ;
+24 QUIT
+25 ;
+26 ;/vd-IB*2.0*659 - Added the OKFRESH module of code to verify Policies.
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(ACTINS(INREC,1)),U,3)
+12 ; Insurance ien
SET IIEN=$PIECE($GET(ACTINS(INREC,0)),U,1)
+13 ; These are Medicare Part A and Part B Policies.
IF $$GET1^DIQ(36,IIEN_",",3.1)=$$GET1^DIQ(350.9,"1,",51.25)
SET MFLG=1
+14 ;Determine if Group Plan is for Medicare Replacement (Part C) Policies (MEDICARE ADVANTAGE)
IF 'MFLG
Begin DoDot:1
+15 ; Group Plan ien
SET GIEN=+$PIECE($GET(ACTINS(INREC,0)),U,18)
+16 ; Type of Policy
IF GIEN
IF $$GET1^DIQ(355.3,GIEN_",",.09)="MEDICARE ADVANTAGE"
SET MFLG=1
+17 QUIT
End DoDot:1
+18 ; This is a Medicare Part D (MEDICARE (WNR))
IF $$GET1^DIQ(36,IIEN_",",.01)="MEDICARE PART D (WNR)"
SET MFLG=1
+19 ;
+20 ;Non-Medicare Policy outside of Freshness Day span
IF VDATE'=""
IF 'MFLG
IF SRVICEDT'>$$FMADD^XLFDT(VDATE,FRESHDAY)
SET OK=0
+21 ;Medicare Policy outside of Medicare Freshness Day span
IF VDATE'=""
IF MFLG
IF SRVICEDT'>$$FMADD^XLFDT(VDATE,MFRESHDAY)
SET OK=0
+22 QUIT OK
+23 ;
EXPIRED(EXPDT) ; check if insurance policy has already expired
+1 ; EXPDT - expiration date (2.312/3)
+2 ; returns 1 if expiration date is in the past, 0 otherwise
+3 NEW X1,X2
+4 SET X1=+$GET(DT)
SET X2=+$GET(EXPDT)
+5 IF X1
IF X2
QUIT $SELECT($$FMDIFF^XLFDT(DT,EXPDT,1)>0:1,1:0)
+6 QUIT 0
