IBCA ;ALB/MRL - ADD NEW BILLING RECORD ;01 JUN 88 12:00
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;MAP TO DGCRA
;
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^BILL CLASSIFICATION^TIMEFRAME OF BILL^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)
I $G(IBIDS(.11))="i" W ! D DISP^IBCNS W !
;
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
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 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 W ! S X=$P(IBIDS(.03),".") D EN3^IBCA3 W ! S IBQUIT=0 ;show other bills this date
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('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^NO LAYGO ACCESS TO BILLING FILE^MAS SERVICE PARAMETER UNKNOWN^FACILITY UNDEFINED^UNABLE TO CREATE ACCOUNTS RECEIVABLE ENTRY" Q
;
LASTDAY ;find last day of last month
; -set x to default last date, don't cross fy's or cy's
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 Y=DT Q ;billing for this month
;
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
IBCA ;ALB/MRL - ADD NEW BILLING RECORD ;01 JUN 88 12:00
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRA
+5 ;
+6 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
+7 IF $SELECT('$DATA(^IBE(350.9,1,1)):1,'$PIECE(^(1),U,14):1,1:0)
SET IBCABRT=4
GOTO NREC
+8 SET PRCASV("SER")=$PIECE(^IBE(350.9,1,1),U,14)
+9 SET PRCASV("SITE")=+$PIECE($$SITE^VASITE,"^",3)
IF PRCASV("SITE")<1
SET IBCABRT=5
GOTO NREC
+10 SET IBNWBL=""
SET IBQUIT=0
IF '$DATA(DUZ(0))
SET IBCABRT=2
GOTO NREC
+11 IF $SELECT($DATA(DLAYGO):2\1-(DLAYGO\1),1:1)
IF DUZ(0)'="@"
IF $DATA(^DIC(399,0,"LAYGO"))
SET DLAYGO=399
+12 ;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
+13 ;
CHKID DO DEM^VADPT
SET DGDIR0="399,.04^399,.05^399,.06^399,155^399,151^399,152"
SET DGDIRA="LOCATION OF CARE^BILL CLASSIFICATION^TIMEFRAME OF BILL^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 IF $GET(IBIDS(.11))="i"
WRITE !
DO DISP^IBCNS
WRITE !
+5 ;
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 SET X=$$APPT^IBCU3(Y,DFN,1)
+3 SET IBIDS(.03)=+Y
XECUTE ^DD("DD")
SET DIR("B")=Y
GOTO CEOC
+4 ;
IP DO DISPAD^IBCA0
IF '$DATA(IBIDS(.03))
GOTO NREC
IF $DATA(IBDSDT)
IF 'IBDSDT
KILL IBDSDT
IF $DATA(IBDSDT)
SET IBDSDT=$PIECE(IBDSDT,".")
+1 SET Y=$PIECE(IBIDS(.03),".")
XECUTE ^DD("DD")
SET DIR("B")=Y
+2 ;
CEOC ;show other bills this date
WRITE !
SET X=$PIECE(IBIDS(.03),".")
DO EN3^IBCA3
WRITE !
SET IBQUIT=0
+1 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!",!!!
+2 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
+3 SET IBI=6
SET DIR(0)="399,152"
SET DIR("A")=" BILLING STATEMENT COVERS TO"
DO READ
IF IBQUIT
GOTO NREC
+4 KILL %DT,DIR
IF '$ORDER(^DGCR(399,"C",DFN,0))
GOTO ^IBCA1
SET X=9999999-IBIDS(.03)
+5 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
+6 IF $DATA(IBIDS(.17))
GOTO CHKINQ
+7 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('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^NO LAYGO ACCESS TO BILLING FILE^MAS SERVICE PARAMETER UNKNOWN^FACILITY UNDEFINED^UNABLE TO CREATE ACCOUNTS RECEIVABLE ENTRY"
QUIT
+1 ;
LASTDAY ;find last day of last month
+1 ; -set x to default last date, don't cross fy's or cy's
+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 ;don't cross fy's
IF $EXTRACT(DGX,4,5)<10
SET Y=$EXTRACT(DGX,1,3)_"0930"
IF IBDSDT<Y
SET Y=IBDSDT
QUIT
+6 ;don't cross cy's
IF $EXTRACT(DGX,4,5)>9
SET Y=$EXTRACT(DGX,1,3)_"1231"
IF IBDSDT<Y
SET Y=IBDSDT
QUIT
+7 SET Y=IBDSDT
End DoDot:1
IF $DATA(Y)
GOTO LDQ
+8 ;
+9 ;billing for this month
IF DGX>X
SET Y=DT
QUIT
+10 ;
+11 ; end of month, don't cross fy's
IF $EXTRACT(DGX,4,5)<10
SET Y=$EXTRACT(DGX,1,3)_"0930"
IF X<Y
SET Y=X
GOTO LDQ
+12 ; end of month, don't cross cy's
IF $EXTRACT(DGX,4,5)>9
SET Y=$EXTRACT(DGX,1,3)_"1231"
IF X<Y
SET Y=X
GOTO LDQ
+13 IF '$DATA(Y)
SET Y=X
LDQ QUIT
