IBCNEDE6 ;DAOU/DAC - eIV DATA EXTRACTS ;15-OCT-2002
;;2.0;INTEGRATED BILLING;**184,271,345,416,497,506,621,668,778**;21-MAR-94;Build 28
;;Per VA Directive 6402, this routine should not be modified.
;
Q ; no direct calls allowed
;
; IB*2*416 removed the ability to perform Identification inquiries.
; However, this code is being left as is for future changes.
;
; IB*2*621 removed old code associated with a previous extract that
; is now replaced with EICD extract logic
;
UPDDTS(PIEN,SVDT,FRDT) ; Update service date and freshness date per payer
; date parameters FUTURE SERVICE DAYS (365.121,.14) and PAST SERVICE
; DAYS (365.121,.15)
; Output:
; SVDT - passed by reference - updates service date
; FRDT - passed by reference - updates freshness date - except for
; INAC where it is optional
N FDAYS,PDAYS,DIFF,AIEN,DATA,OSVDT,EDTFLG
;
; Init vars - save original service date to calc diff
S (FDAYS,PDAYS,EDTFLG)=0,OSVDT=SVDT
; Determine Payer App IEN
;IB*668/TAZ - Changed Payer Application from IIV to EIV
S AIEN=$$PYRAPP^IBCNEUT5("EIV",PIEN)
I AIEN="" Q ; Quit without changing if app is not defined
S DATA=$G(^IBE(365.12,PIEN,1,AIEN,0))
I DATA="" Q ; Quit without changing if node is not defined
;IB*668/TAZ - Changed location for FDAYS and PDAYS
S FDAYS=$$GET1^DIQ(365.121,AIEN_","_PIEN_",",4.03)
S PDAYS=$$GET1^DIQ(365.121,AIEN_","_PIEN_",",4.04)
; Process past service days if not null
I PDAYS'="" D
. ; If zero and Service Date is less than today, reset to today
. I PDAYS=0&(SVDT<DT) S SVDT=$$DT^XLFDT,EDTFLG=1
. ; If non-zero and service date is earlier than the allowed
. ; payer service date range, reset service date to earliest allowed
. ; date for the payer
. I PDAYS,(SVDT<$$FMADD^XLFDT($$DT^XLFDT,-PDAYS)) D
. . S SVDT=$$FMADD^XLFDT($$DT^XLFDT,-PDAYS),EDTFLG=1
; Process future service days if not edited and if not null
I EDTFLG=0,FDAYS'="" D
. ; If zero and Service Date is greater than today, reset to today
. I FDAYS=0&(SVDT>DT) S SVDT=$$DT^XLFDT,EDTFLG=1
. ; If non-zero and service date is later than the allowed
. ; payer service date range, reset service date to latest allowed
. ; date for the payer
. I FDAYS,(SVDT>$$FMADD^XLFDT($$DT^XLFDT,FDAYS)) D
. . S SVDT=$$FMADD^XLFDT($$DT^XLFDT,FDAYS),EDTFLG=1
;
; Determine if difference exists
I EDTFLG,$G(FRDT)'="" S FRDT=$$FMADD^XLFDT(FRDT,$$FMDIFF^XLFDT(SVDT,OSVDT))
;
Q
;
TFL(DFN) ; Examines treating facility list,
; value returned is 1 if patient has visited at least one other site
N IBC,IBZ,IBS
D TFL^VAFCTFU1(.IBZ,DFN) Q:-$G(IBZ(1))=1 0
S IBS=+$P($$SITE^VASITE,"^",3),(IBZ,IBC)=0
; Look for remote facilities of type VAMC:
F S IBZ=$O(IBZ(IBZ)) Q:IBZ<1 I +IBZ(IBZ)>0,+IBZ(IBZ)'=IBS,$P(IBZ(IBZ),U,5)="VAMC" S IBC=1 Q
Q IBC
;
;IB*778/TAZ - Moved CLINICEX from IBCNEDE2
CLINICEX ; Clinic exclusion
S OK=1
I $D(^DG(43,1,"DGPREC","B",CLNC)) S OK=0
Q
;
;IB*778/TAZ - Moved ELG from IBCNEDE2
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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEDE6 3140 printed Nov 22, 2024@17:24:34 Page 2
IBCNEDE6 ;DAOU/DAC - eIV DATA EXTRACTS ;15-OCT-2002
+1 ;;2.0;INTEGRATED BILLING;**184,271,345,416,497,506,621,668,778**;21-MAR-94;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; no direct calls allowed
QUIT
+5 ;
+6 ; IB*2*416 removed the ability to perform Identification inquiries.
+7 ; However, this code is being left as is for future changes.
+8 ;
+9 ; IB*2*621 removed old code associated with a previous extract that
+10 ; is now replaced with EICD extract logic
+11 ;
UPDDTS(PIEN,SVDT,FRDT) ; Update service date and freshness date per payer
+1 ; date parameters FUTURE SERVICE DAYS (365.121,.14) and PAST SERVICE
+2 ; DAYS (365.121,.15)
+3 ; Output:
+4 ; SVDT - passed by reference - updates service date
+5 ; FRDT - passed by reference - updates freshness date - except for
+6 ; INAC where it is optional
+7 NEW FDAYS,PDAYS,DIFF,AIEN,DATA,OSVDT,EDTFLG
+8 ;
+9 ; Init vars - save original service date to calc diff
+10 SET (FDAYS,PDAYS,EDTFLG)=0
SET OSVDT=SVDT
+11 ; Determine Payer App IEN
+12 ;IB*668/TAZ - Changed Payer Application from IIV to EIV
+13 SET AIEN=$$PYRAPP^IBCNEUT5("EIV",PIEN)
+14 ; Quit without changing if app is not defined
IF AIEN=""
QUIT
+15 SET DATA=$GET(^IBE(365.12,PIEN,1,AIEN,0))
+16 ; Quit without changing if node is not defined
IF DATA=""
QUIT
+17 ;IB*668/TAZ - Changed location for FDAYS and PDAYS
+18 SET FDAYS=$$GET1^DIQ(365.121,AIEN_","_PIEN_",",4.03)
+19 SET PDAYS=$$GET1^DIQ(365.121,AIEN_","_PIEN_",",4.04)
+20 ; Process past service days if not null
+21 IF PDAYS'=""
Begin DoDot:1
+22 ; If zero and Service Date is less than today, reset to today
+23 IF PDAYS=0&(SVDT<DT)
SET SVDT=$$DT^XLFDT
SET EDTFLG=1
+24 ; If non-zero and service date is earlier than the allowed
+25 ; payer service date range, reset service date to earliest allowed
+26 ; date for the payer
+27 IF PDAYS
IF (SVDT<$$FMADD^XLFDT($$DT^XLFDT,-PDAYS))
Begin DoDot:2
+28 SET SVDT=$$FMADD^XLFDT($$DT^XLFDT,-PDAYS)
SET EDTFLG=1
End DoDot:2
End DoDot:1
+29 ; Process future service days if not edited and if not null
+30 IF EDTFLG=0
IF FDAYS'=""
Begin DoDot:1
+31 ; If zero and Service Date is greater than today, reset to today
+32 IF FDAYS=0&(SVDT>DT)
SET SVDT=$$DT^XLFDT
SET EDTFLG=1
+33 ; If non-zero and service date is later than the allowed
+34 ; payer service date range, reset service date to latest allowed
+35 ; date for the payer
+36 IF FDAYS
IF (SVDT>$$FMADD^XLFDT($$DT^XLFDT,FDAYS))
Begin DoDot:2
+37 SET SVDT=$$FMADD^XLFDT($$DT^XLFDT,FDAYS)
SET EDTFLG=1
End DoDot:2
End DoDot:1
+38 ;
+39 ; Determine if difference exists
+40 IF EDTFLG
IF $GET(FRDT)'=""
SET FRDT=$$FMADD^XLFDT(FRDT,$$FMDIFF^XLFDT(SVDT,OSVDT))
+41 ;
+42 QUIT
+43 ;
TFL(DFN) ; Examines treating facility list,
+1 ; value returned is 1 if patient has visited at least one other site
+2 NEW IBC,IBZ,IBS
+3 DO TFL^VAFCTFU1(.IBZ,DFN)
if -$GET(IBZ(1))=1
QUIT 0
+4 SET IBS=+$PIECE($$SITE^VASITE,"^",3)
SET (IBZ,IBC)=0
+5 ; Look for remote facilities of type VAMC:
+6 FOR
SET IBZ=$ORDER(IBZ(IBZ))
if IBZ<1
QUIT
IF +IBZ(IBZ)>0
IF +IBZ(IBZ)'=IBS
IF $PIECE(IBZ(IBZ),U,5)="VAMC"
SET IBC=1
QUIT
+7 QUIT IBC
+8 ;
+9 ;IB*778/TAZ - Moved CLINICEX from IBCNEDE2
CLINICEX ; Clinic exclusion
+1 SET OK=1
+2 IF $DATA(^DG(43,1,"DGPREC","B",CLNC))
SET OK=0
+3 QUIT
+4 ;
+5 ;IB*778/TAZ - Moved ELG from IBCNEDE2
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 ;
