- 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 Feb 18, 2025@23:34:52 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
