- 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
