IBCA ;ALB/MRL - ADD NEW BILLING RECORD ;01 JUN 88 12:00
;;2.0;INTEGRATED BILLING;**43,80,109,106,137,312,461**;21-MAR-94;Build 58
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;MAP TO DGCRA
;
N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312
;
D Q1 S IBCABRT=0,IOP="HOME" D ^%ZIS K IOP I $S('$D(DFN):1,'$D(^DPT(DFN,0)):1,1:0) S IBCABRT=1 G NREC
I $S('$D(^IBE(350.9,1,1)):1,'$P(^(1),U,14):1,1:0) S IBCABRT=4 G NREC
S PRCASV("SER")=$P(^IBE(350.9,1,1),U,14)
S PRCASV("SITE")=+$P($$SITE^VASITE,"^",3) I PRCASV("SITE")<1 S IBCABRT=5 G NREC
S IBNWBL="",IBQUIT=0 I '$D(DUZ(0)) S IBCABRT=2 G NREC
I $S($D(DLAYGO):2\1-(DLAYGO\1),1:1),DUZ(0)'="@",$D(^DIC(399,0,"LAYGO")) S DLAYGO=399
;I $S($D(DLAYGO):2\1-(DLAYGO\1),1:1),DUZ(0)'="@",$D(^DIC(399,0,"LAYGO")) F I=1:1 I DUZ(0)[$E(^("LAYGO"),I) Q:I'>$L(^("LAYGO")) S IBCABRT=3 G NREC
;
CHKID D DEM^VADPT S DGDIR0="399,.04^399,.05^399,.06^399,155^399,151^399,152",DGDIRA="LOCATION OF CARE^EVENT INFORMATION SOURCE^TIMEFRAME^IS THIS A SENSITIVE RECORD?^STATEMENT COVERS FROM^STATEMENT COVERS TO"
S DGDIRB="1^^^NO"
F IBI=1:1:4 S:$P(DGDIRB,"^",IBI)]"" DIR("B")=$P(DGDIRB,"^",IBI) S DIR(0)=$P(DGDIR0,"^",IBI),DIR("A")=" BILLING "_$P(DGDIRA,"^",IBI) D READ G:IBQUIT NREC K DIR
S DIC="^DGCR(399.3,",DIC(0)="AEQMZ",DIC("A")=" BILLING RATE TYPE: ",DIC("S")="I '$P(^(0),U,3)" D ^DIC K DIC G NREC:Y'>0 S IBIDS(.07)=+Y,IBIDS(.11)=$P(^DGCR(399.3,+Y,0),"^",7)
;
OP G IP:IBIDS(.05)'>2 S %DT="EAX",%DT(0)="-NOW",%DT("A")=" BILLING OUTPATIENT EVENT DATE: " D ^%DT I Y'>0 G NREC
;S X=Y D APPT^IBCU3
; Do NOT PROCESS on VistA if Y >= Switch Eff Date ;CCR-930
I +IBSWINFO,(Y+1)>$P(IBSWINFO,"^",2) S IBCABRT=7 G NREC ;IB*2.0*312
;
S X=$$APPT^IBCU3(Y,DFN,1)
S IBIDS(.03)=+Y X ^DD("DD") S DIR("B")=Y G CEOC
;
IP D DISPAD^IBCA0 G:'$D(IBIDS(.03)) NREC
; Do NOT PROCESS on VistA if Date = Switch Eff Date ;CCR-930*312
I +IBSWINFO,(IBIDS(.03)+1)>$P(IBSWINFO,"^",2) S IBCABRT=7 G NREC ;P312
;
I $D(IBDSDT) K:'IBDSDT IBDSDT S:$D(IBDSDT) IBDSDT=$P(IBDSDT,".")
S Y=$P(IBIDS(.03),".") X ^DD("DD") S DIR("B")=Y
;
CEOC S IBIDS(.27)="" I +$$BILLRATE^IBCRU3(IBIDS(.07),IBIDS(.05),IBIDS(.03),"RC") S IBIDS(.27)=1
S IBIDS(.22)=$P($G(^IBE(350.9,1,1)),"^",25)
I $G(IBIDS(.11))="i" N IBDTIN,IBCOVEXT S IBDTIN=$G(IBIDS(.03)),IBCOVEXT=1 W ! D DISPDT^IBCNS W !
W ! S X=$P(IBIDS(.03),".") D EN3^IBCA3 W ! S IBQUIT=0 ;show other bills this date
I IBIDS(.05)>2 S X=$$ADM^IBCU64(DFN,IBIDS(.03)) I +X W !,"Warning: Patient is an Inpatient on ",$$FMTE^XLFDT(IBIDS(.03),2),": ",$$FMTE^XLFDT(+X,2)," - " W:+$P(X,U,2) $$FMTE^XLFDT(+$P(X,U,2),2) W !
I +$G(IBIDS(.08)),+$P($G(^DGPT(+IBIDS(.08),70)),"^",2),$G(^DIC(42.4,+$P(^(70),"^",2),0))'="",$P(^(0),"^",5)="" W !!,"Discharge bedsection of this PTF record is NOT billable!",!!!
S IBI=5,DIR(0)="399,151",DIR("A")=" BILLING STATEMENT COVERS FROM" D READ G:IBQUIT NREC S DGX=IBIDS(151) D LASTDAY X ^DD("DD") S DIR("B")=Y
S IBI=6,DIR(0)="399,152",DIR("A")=" BILLING STATEMENT COVERS TO" D READ G:IBQUIT NREC
K %DT,DIR G ^IBCA1:'$O(^DGCR(399,"C",DFN,0)) S X=9999999-IBIDS(.03)
F I=0:0 S I=$O(^DGCR(399,"APDT",DFN,I)) Q:'I I $O(^DGCR(399,"APDT",DFN,I,0))=X,$D(^DGCR(399,+I,0)),$S('$D(^DGCR(399,I,"S")):1,$P(^("S"),"^",16)=1:0,1:1) S IBIDS(.17)=$P(^(0),"^",17) Q
I $D(IBIDS(.17)) G CHKINQ
I '$D(IBIDS(.17)),IBIDS(.05)<3 G CHKINQ
CEOC1 D CEOC1^IBCA0 Q:'$D(IBIDS)
CHKINQ G ^IBCA1
;
READ D ^DIR I X?1"^"1.ANP W !?6,*7,"Sorry '^' not allowed!" G READ
I $D(DIRUT) S IBQUIT=1 Q
S IBIDS($P($P(DGDIR0,"^",IBI),",",2))=Y
Q
;
NREC S IBYN=0 D SET W !?6,*7,"<",$S('$G(IBCABRT):"ABORTED",$P(IBCABRT(1),U,IBCABRT)]"":$P(IBCABRT(1),U,IBCABRT),1:"ABORTED"),", NO BILLING RECORD CREATED>" K IBIFN
Q1 K IBIDS,IB
Q K %,%DT,D,IBCABRT,IBNWBL,IBQUIT,IBYN,DIRUT,DTOUT,DIROUT,DUOUT,PRCASV,X1,X2,IBI,IBJ,IBX,DGX,IBDSDT,IBDFN,IBID0,IBSET,IBI,DGDIRB,DGDIR0,DGDIRA,DIR,DIC,DLAYGO,I,X,Y Q
Q
SET S IBCABRT(1)="PATIENT INFORMATION LACKING^FILEMAN ACCESS UNDEFINED^"
S IBCABRT(1)=IBCABRT(1)_"NO LAYGO ACCESS TO BILLING FILE^"
S IBCABRT(1)=IBCABRT(1)_"MAS SERVICE PARAMETER UNKNOWN^"
S IBCABRT(1)=IBCABRT(1)_"FACILITY UNDEFINED^"
S IBCABRT(1)=IBCABRT(1)_"UNABLE TO CREATE ACCOUNTS RECEIVABLE ENTRY^"
S IBCABRT(1)=IBCABRT(1)_"EPISODE CANNOT BE ON OR AFTER PFSS EFFECTIVE DATE"
Q
;
LASTDAY ;find last day of last month
; -set x to default last date
S X1=DT,X2=-($E(DT,6,7)) D C^%DTC S Y=X
K Y
I $D(IBDSDT) D G:$D(Y) LDQ
. ;I $E(DGX,4,5)<10 S Y=$E(DGX,1,3)_"0930" S:IBDSDT<Y Y=IBDSDT Q ;don't cross fy's
. ;I $E(DGX,4,5)>9 S Y=$E(DGX,1,3)_"1231" S:IBDSDT<Y Y=IBDSDT Q ;don't cross cy's
. S Y=IBDSDT
;
I DGX>X S X=DT ;billing for this month
;
I IBIDS(.05)>2 N Z S Z=$$ICD10S^IBCU4(DGX,X) I +Z S X=$$FMADD^XLFDT(Z,-1)
;
;I $E(DGX,4,5)<10 S Y=$E(DGX,1,3)_"0930" S:X<Y Y=X G LDQ ; end of month, don't cross fy's
;I $E(DGX,4,5)>9 S Y=$E(DGX,1,3)_"1231" S:X<Y Y=X G LDQ ; end of month, don't cross cy's
I '$D(Y) S Y=X
LDQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCA 5046 printed Dec 13, 2024@02:08:28 Page 2
IBCA ;ALB/MRL - ADD NEW BILLING RECORD ;01 JUN 88 12:00
+1 ;;2.0;INTEGRATED BILLING;**43,80,109,106,137,312,461**;21-MAR-94;Build 58
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRA
+5 ;
+6 ;IB*2.0*312
NEW IBSWINFO
SET IBSWINFO=$$SWSTAT^IBBAPI()
+7 ;
+8 DO Q1
SET IBCABRT=0
SET IOP="HOME"
DO ^%ZIS
KILL IOP
IF $SELECT('$DATA(DFN):1,'$DATA(^DPT(DFN,0)):1,1:0)
SET IBCABRT=1
GOTO NREC
+9 IF $SELECT('$DATA(^IBE(350.9,1,1)):1,'$PIECE(^(1),U,14):1,1:0)
SET IBCABRT=4
GOTO NREC
+10 SET PRCASV("SER")=$PIECE(^IBE(350.9,1,1),U,14)
+11 SET PRCASV("SITE")=+$PIECE($$SITE^VASITE,"^",3)
IF PRCASV("SITE")<1
SET IBCABRT=5
GOTO NREC
+12 SET IBNWBL=""
SET IBQUIT=0
IF '$DATA(DUZ(0))
SET IBCABRT=2
GOTO NREC
+13 IF $SELECT($DATA(DLAYGO):2\1-(DLAYGO\1),1:1)
IF DUZ(0)'="@"
IF $DATA(^DIC(399,0,"LAYGO"))
SET DLAYGO=399
+14 ;I $S($D(DLAYGO):2\1-(DLAYGO\1),1:1),DUZ(0)'="@",$D(^DIC(399,0,"LAYGO")) F I=1:1 I DUZ(0)[$E(^("LAYGO"),I) Q:I'>$L(^("LAYGO")) S IBCABRT=3 G NREC
+15 ;
CHKID DO DEM^VADPT
SET DGDIR0="399,.04^399,.05^399,.06^399,155^399,151^399,152"
SET DGDIRA="LOCATION OF CARE^EVENT INFORMATION SOURCE^TIMEFRAME^IS THIS A SENSITIVE RECORD?^STATEMENT COVERS FROM^STATEMENT COVERS TO"
+1 SET DGDIRB="1^^^NO"
+2 FOR IBI=1:1:4
if $PIECE(DGDIRB,"^",IBI)]""
SET DIR("B")=$PIECE(DGDIRB,"^",IBI)
SET DIR(0)=$PIECE(DGDIR0,"^",IBI)
SET DIR("A")=" BILLING "_$PIECE(DGDIRA,"^",IBI)
DO READ
if IBQUIT
GOTO NREC
KILL DIR
+3 SET DIC="^DGCR(399.3,"
SET DIC(0)="AEQMZ"
SET DIC("A")=" BILLING RATE TYPE: "
SET DIC("S")="I '$P(^(0),U,3)"
DO ^DIC
KILL DIC
if Y'>0
GOTO NREC
SET IBIDS(.07)=+Y
SET IBIDS(.11)=$PIECE(^DGCR(399.3,+Y,0),"^",7)
+4 ;
OP if IBIDS(.05)'>2
GOTO IP
SET %DT="EAX"
SET %DT(0)="-NOW"
SET %DT("A")=" BILLING OUTPATIENT EVENT DATE: "
DO ^%DT
IF Y'>0
GOTO NREC
+1 ;S X=Y D APPT^IBCU3
+2 ; Do NOT PROCESS on VistA if Y >= Switch Eff Date ;CCR-930
+3 ;IB*2.0*312
IF +IBSWINFO
IF (Y+1)>$PIECE(IBSWINFO,"^",2)
SET IBCABRT=7
GOTO NREC
+4 ;
+5 SET X=$$APPT^IBCU3(Y,DFN,1)
+6 SET IBIDS(.03)=+Y
XECUTE ^DD("DD")
SET DIR("B")=Y
GOTO CEOC
+7 ;
IP DO DISPAD^IBCA0
if '$DATA(IBIDS(.03))
GOTO NREC
+1 ; Do NOT PROCESS on VistA if Date = Switch Eff Date ;CCR-930*312
+2 ;P312
IF +IBSWINFO
IF (IBIDS(.03)+1)>$PIECE(IBSWINFO,"^",2)
SET IBCABRT=7
GOTO NREC
+3 ;
+4 IF $DATA(IBDSDT)
if 'IBDSDT
KILL IBDSDT
if $DATA(IBDSDT)
SET IBDSDT=$PIECE(IBDSDT,".")
+5 SET Y=$PIECE(IBIDS(.03),".")
XECUTE ^DD("DD")
SET DIR("B")=Y
+6 ;
CEOC SET IBIDS(.27)=""
IF +$$BILLRATE^IBCRU3(IBIDS(.07),IBIDS(.05),IBIDS(.03),"RC")
SET IBIDS(.27)=1
+1 SET IBIDS(.22)=$PIECE($GET(^IBE(350.9,1,1)),"^",25)
+2 IF $GET(IBIDS(.11))="i"
NEW IBDTIN,IBCOVEXT
SET IBDTIN=$GET(IBIDS(.03))
SET IBCOVEXT=1
WRITE !
DO DISPDT^IBCNS
WRITE !
+3 ;show other bills this date
WRITE !
SET X=$PIECE(IBIDS(.03),".")
DO EN3^IBCA3
WRITE !
SET IBQUIT=0
+4 IF IBIDS(.05)>2
SET X=$$ADM^IBCU64(DFN,IBIDS(.03))
IF +X
WRITE !,"Warning: Patient is an Inpatient on ",$$FMTE^XLFDT(IBIDS(.03),2),": ",$$FMTE^XLFDT(+X,2)," - "
if +$PIECE(X,U,2)
WRITE $$FMTE^XLFDT(+$PIECE(X,U,2),2)
WRITE !
+5 IF +$GET(IBIDS(.08))
IF +$PIECE($GET(^DGPT(+IBIDS(.08),70)),"^",2)
IF $GET(^DIC(42.4,+$PIECE(^(70),"^",2),0))'=""
IF $PIECE(^(0),"^",5)=""
WRITE !!,"Discharge bedsection of this PTF record is NOT billable!",!!!
+6 SET IBI=5
SET DIR(0)="399,151"
SET DIR("A")=" BILLING STATEMENT COVERS FROM"
DO READ
if IBQUIT
GOTO NREC
SET DGX=IBIDS(151)
DO LASTDAY
XECUTE ^DD("DD")
SET DIR("B")=Y
+7 SET IBI=6
SET DIR(0)="399,152"
SET DIR("A")=" BILLING STATEMENT COVERS TO"
DO READ
if IBQUIT
GOTO NREC
+8 KILL %DT,DIR
if '$ORDER(^DGCR(399,"C",DFN,0))
GOTO ^IBCA1
SET X=9999999-IBIDS(.03)
+9 FOR I=0:0
SET I=$ORDER(^DGCR(399,"APDT",DFN,I))
if 'I
QUIT
IF $ORDER(^DGCR(399,"APDT",DFN,I,0))=X
IF $DATA(^DGCR(399,+I,0))
IF $SELECT('$DATA(^DGCR(399,I,"S")):1,$PIECE(^("S"),"^",16)=1:0,1:1)
SET IBIDS(.17)=$PIECE(^(0),"^",17)
QUIT
+10 IF $DATA(IBIDS(.17))
GOTO CHKINQ
+11 IF '$DATA(IBIDS(.17))
IF IBIDS(.05)<3
GOTO CHKINQ
CEOC1 DO CEOC1^IBCA0
if '$DATA(IBIDS)
QUIT
CHKINQ GOTO ^IBCA1
+1 ;
READ DO ^DIR
IF X?1"^"1.ANP
WRITE !?6,*7,"Sorry '^' not allowed!"
GOTO READ
+1 IF $DATA(DIRUT)
SET IBQUIT=1
QUIT
+2 SET IBIDS($PIECE($PIECE(DGDIR0,"^",IBI),",",2))=Y
+3 QUIT
+4 ;
NREC SET IBYN=0
DO SET
WRITE !?6,*7,"<",$SELECT('$GET(IBCABRT):"ABORTED",$PIECE(IBCABRT(1),U,IBCABRT)]"":$PIECE(IBCABRT(1),U,IBCABRT),1:"ABORTED"),", NO BILLING RECORD CREATED>"
KILL IBIFN
Q1 KILL IBIDS,IB
Q KILL %,%DT,D,IBCABRT,IBNWBL,IBQUIT,IBYN,DIRUT,DTOUT,DIROUT,DUOUT,PRCASV,X1,X2,IBI,IBJ,IBX,DGX,IBDSDT,IBDFN,IBID0,IBSET,IBI,DGDIRB,DGDIR0,DGDIRA,DIR,DIC,DLAYGO,I,X,Y
QUIT
+1 QUIT
SET SET IBCABRT(1)="PATIENT INFORMATION LACKING^FILEMAN ACCESS UNDEFINED^"
+1 SET IBCABRT(1)=IBCABRT(1)_"NO LAYGO ACCESS TO BILLING FILE^"
+2 SET IBCABRT(1)=IBCABRT(1)_"MAS SERVICE PARAMETER UNKNOWN^"
+3 SET IBCABRT(1)=IBCABRT(1)_"FACILITY UNDEFINED^"
+4 SET IBCABRT(1)=IBCABRT(1)_"UNABLE TO CREATE ACCOUNTS RECEIVABLE ENTRY^"
+5 SET IBCABRT(1)=IBCABRT(1)_"EPISODE CANNOT BE ON OR AFTER PFSS EFFECTIVE DATE"
+6 QUIT
+7 ;
LASTDAY ;find last day of last month
+1 ; -set x to default last date
+2 SET X1=DT
SET X2=-($EXTRACT(DT,6,7))
DO C^%DTC
SET Y=X
+3 KILL Y
+4 IF $DATA(IBDSDT)
Begin DoDot:1
+5 ;I $E(DGX,4,5)<10 S Y=$E(DGX,1,3)_"0930" S:IBDSDT<Y Y=IBDSDT Q ;don't cross fy's
+6 ;I $E(DGX,4,5)>9 S Y=$E(DGX,1,3)_"1231" S:IBDSDT<Y Y=IBDSDT Q ;don't cross cy's
+7 SET Y=IBDSDT
End DoDot:1
if $DATA(Y)
GOTO LDQ
+8 ;
+9 ;billing for this month
IF DGX>X
SET X=DT
+10 ;
+11 IF IBIDS(.05)>2
NEW Z
SET Z=$$ICD10S^IBCU4(DGX,X)
IF +Z
SET X=$$FMADD^XLFDT(Z,-1)
+12 ;
+13 ;I $E(DGX,4,5)<10 S Y=$E(DGX,1,3)_"0930" S:X<Y Y=X G LDQ ; end of month, don't cross fy's
+14 ;I $E(DGX,4,5)>9 S Y=$E(DGX,1,3)_"1231" S:X<Y Y=X G LDQ ; end of month, don't cross cy's
+15 IF '$DATA(Y)
SET Y=X
LDQ QUIT
