IBCU63 ;ALB/AAS - BILLING UTILITY TO SET AMB SURG REV CODES ; 20-NOV-91
;;2.0;INTEGRATED BILLING;**21,133,349**;21-MAR-94;Build 46
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;MAP TO DGCRU63
% ; BASC
Q:IBIDS(.11)'="i"
K ^UTILITY($J,"IB-ASC")
S DGRVCOD=$S($P($G(DGINPAR),"^",4):$P(DGINPAR,"^",4),$P($G(^IBE(350.9,1,1)),"^",18):$P(^(1),"^",18),1:"") Q:DGRVCOD=""
;
BLD S DGASC=0 F S DGASC=$O(^DGCR(399,IBIFN,"CP","ASC",1,DGASC)) Q:'DGASC S DGPROC=$G(^DGCR(399,IBIFN,"CP",DGASC,0)) I DGPROC D
.S DGDIV=$P(DGPROC,"^",6),DGDAT=$P(DGPROC,"^",2)
.Q:'DGDIV
.Q:DGDAT+.9<$$STDATE
.S:'$D(^UTILITY($J,"IB-ASC",+DGPROC,+DGDAT,+DGDIV)) ^(+DGDIV)=0
.S ^(+DGDIV)=^UTILITY($J,"IB-ASC",+DGPROC,+DGDAT,+DGDIV)+1
;
STORREV ;build revenue codes in bill
I '$D(^DGCR(399,IBIFN,"RC",0)) S ^DGCR(399,IBIFN,"RC",0)="^399.042PA"
S DGPROC=0 F S DGPROC=$O(^UTILITY($J,"IB-ASC",DGPROC)) Q:'DGPROC S DGDAT=0 F S DGDAT=$O(^UTILITY($J,"IB-ASC",DGPROC,DGDAT)) Q:'DGDAT S DGDIV=0 F S DGDIV=$O(^UTILITY($J,"IB-ASC",DGPROC,DGDAT,DGDIV)) Q:'DGDIV S DGBSLOS=^(DGDIV) D
.S X=DGDAT_"^"_DGDIV_"^"_DGPROC D ^IBAUTL1 S DGAMNT=Y Q:Y<1
.S X=DGRVCOD,DGBSI=$O(^DGCR(399.1,"B",DGBILLBS,0))
.D FILE
.Q
K DGDAT,DGPROC,DGDIV,DGRVCOD,DGASC
Q
;
FILE ;
S DA(1)=IBIFN
D FILE^IBCU62
W:'$G(IBAUTO) !,"Adding",?12,$E(00_DGRVCOD,($L(DGRVCOD)-1),($L(DGRVCOD)+1)),?24,DGBSLOS,?31,"$",$J(DGAMNT,8,2),?44,DGBILLBS I +$G(DGPROC) W ?65,$P($$CPT^ICPTCOD(+DGPROC),"^",2)
Q
;
STDATE() ; -start date for basc billing
Q $S($P($G(^IBE(350.9,1,1)),"^",24):$P(^(1),"^",24),1:9999999)
;
RX ;add rx refill charges (adds default rx cpt for cms-1500)
;tries to use ins rx rev code, then site rx rev code finally standard revcode all with $20
I '$D(^DGCR(399,IBIFN,"RC",0)) S ^DGCR(399,IBIFN,"RC",0)="^399.042PA"
S DGBSLOS=IBCNT
S DGBS="PRESCRIPTION",DGBSI=$O(^DGCR(399.1,"B",DGBS,0)) Q:'DGBSI
I $$FT^IBCU3(IBIFN)=2 S DGPROC=$P($G(^IBE(350.9,1,1)),"^",30),DGDIV=""
S DGRVCOD=$P($G(DGINPAR),"^",10) ; ins rev cd
I DGRVCOD="" S DGRVCOD=$P($G(^IBE(350.9,1,1)),"^",28) ; site rev cd
I DGRVCOD="" D SETREV^IBCU62 G END ; standard rev cd
S DGAMNT=$$CHG(DGBSI,IBIDS(151),DGRVCOD) Q:'DGAMNT S X=DGRVCOD
D FILE
END K DGPROC,DGDIV,DGRVCOD
Q
;MAP TO DGCRU61
;
ALL ;delete all revenue codes that may have been set up automatically
;ie = $d(^IB(399.5,"d",code ifn))
K DA S DA(1)=IBIFN,DA=0 I '$G(IBAUTO) W !,"Removing old Revenue Codes."
F DGII=0:0 S DA=$O(^DGCR(399,IBIFN,"RC",DA)) Q:DA<1 S X=$G(^DGCR(399,IBIFN,"RC",DA,0)) D
. ;remove revenue codes pre-defined for automatic use AND revenue codes for BASC charges (are automatically created)
. W:'$G(IBAUTO) "." D DEL
Q
DEL S DIK="^DGCR(399,"_DA(1)_",""RC""," D ^DIK L ^DGCR(399,IBIFN):1
Q
;
;
CHG(IBSI,IBDT,IBRVCD) ; returns charge for bedsection and date, rev cd optional
N IBAMNT,IBACTDT,IBRC,IBDA,IBRT,IBQUIT,X S IBAMNT=0
;
S IBACTDT=-(IBDT+.01) F S IBACTDT=$O(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT)) Q:'IBACTDT!+IBAMNT D
. S IBRC=+IBRVCD,IBDA=0 F S IBDA=$O(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT,IBRC,IBDA)) Q:'IBDA!+IBAMNT D
.. S IBRT=$G(^DGCR(399.5,+IBDA,0))
.. I $P(IBRT,U,6)["i",+$P(IBRT,U,5) S IBAMNT=$P(IBRT,U,4)
;
I 'IBAMNT S IBACTDT=-(IBDT+.01) F S IBACTDT=$O(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT)) Q:'IBACTDT!+IBAMNT D
. S IBRC="" F S IBRC=$O(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT,IBRC)) Q:'IBRC!+IBAMNT D
.. S IBDA=0 F S IBDA=$O(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT,IBRC,IBDA)) Q:'IBDA!+IBAMNT D
... S IBRT=$G(^DGCR(399.5,+IBDA,0))
... I $P(IBRT,U,6)["i",+$P(IBRT,U,5) S IBAMNT=$P(IBRT,U,4)
Q IBAMNT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCU63 3643 printed Sep 23, 2025@19:56:59 Page 2
IBCU63 ;ALB/AAS - BILLING UTILITY TO SET AMB SURG REV CODES ; 20-NOV-91
+1 ;;2.0;INTEGRATED BILLING;**21,133,349**;21-MAR-94;Build 46
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRU63
% ; BASC
+1 if IBIDS(.11)'="i"
QUIT
+2 KILL ^UTILITY($JOB,"IB-ASC")
+3 SET DGRVCOD=$SELECT($PIECE($GET(DGINPAR),"^",4):$PIECE(DGINPAR,"^",4),$PIECE($GET(^IBE(350.9,1,1)),"^",18):$PIECE(^(1),"^",18),1:"")
if DGRVCOD=""
QUIT
+4 ;
BLD SET DGASC=0
FOR
SET DGASC=$ORDER(^DGCR(399,IBIFN,"CP","ASC",1,DGASC))
if 'DGASC
QUIT
SET DGPROC=$GET(^DGCR(399,IBIFN,"CP",DGASC,0))
IF DGPROC
Begin DoDot:1
+1 SET DGDIV=$PIECE(DGPROC,"^",6)
SET DGDAT=$PIECE(DGPROC,"^",2)
+2 if 'DGDIV
QUIT
+3 if DGDAT+.9<$$STDATE
QUIT
+4 if '$DATA(^UTILITY($JOB,"IB-ASC",+DGPROC,+DGDAT,+DGDIV))
SET ^(+DGDIV)=0
+5 SET ^(+DGDIV)=^UTILITY($JOB,"IB-ASC",+DGPROC,+DGDAT,+DGDIV)+1
End DoDot:1
+6 ;
STORREV ;build revenue codes in bill
+1 IF '$DATA(^DGCR(399,IBIFN,"RC",0))
SET ^DGCR(399,IBIFN,"RC",0)="^399.042PA"
+2 SET DGPROC=0
FOR
SET DGPROC=$ORDER(^UTILITY($JOB,"IB-ASC",DGPROC))
if 'DGPROC
QUIT
SET DGDAT=0
FOR
SET DGDAT=$ORDER(^UTILITY($JOB,"IB-ASC",DGPROC,DGDAT))
if 'DGDAT
QUIT
SET DGDIV=0
FOR
SET DGDIV=$ORDER(^UTILITY($JOB,"IB-ASC",DGPROC,DGDAT,DGDIV))
if 'DGDIV
QUIT
SET DGBSLOS=^(DGDIV)
Begin DoDot:1
+3 SET X=DGDAT_"^"_DGDIV_"^"_DGPROC
DO ^IBAUTL1
SET DGAMNT=Y
if Y<1
QUIT
+4 SET X=DGRVCOD
SET DGBSI=$ORDER(^DGCR(399.1,"B",DGBILLBS,0))
+5 DO FILE
+6 QUIT
End DoDot:1
+7 KILL DGDAT,DGPROC,DGDIV,DGRVCOD,DGASC
+8 QUIT
+9 ;
FILE ;
+1 SET DA(1)=IBIFN
+2 DO FILE^IBCU62
+3 if '$GET(IBAUTO)
WRITE !,"Adding",?12,$EXTRACT(00_DGRVCOD,($LENGTH(DGRVCOD)-1),($LENGTH(DGRVCOD)+1)),?24,DGBSLOS,?31,"$",$JUSTIFY(DGAMNT,8,2),?44,DGBILLBS
IF +$GET(DGPROC)
WRITE ?65,$PIECE($$CPT^ICPTCOD(+DGPROC),"^",2)
+4 QUIT
+5 ;
STDATE() ; -start date for basc billing
+1 QUIT $SELECT($PIECE($GET(^IBE(350.9,1,1)),"^",24):$PIECE(^(1),"^",24),1:9999999)
+2 ;
RX ;add rx refill charges (adds default rx cpt for cms-1500)
+1 ;tries to use ins rx rev code, then site rx rev code finally standard revcode all with $20
+2 IF '$DATA(^DGCR(399,IBIFN,"RC",0))
SET ^DGCR(399,IBIFN,"RC",0)="^399.042PA"
+3 SET DGBSLOS=IBCNT
+4 SET DGBS="PRESCRIPTION"
SET DGBSI=$ORDER(^DGCR(399.1,"B",DGBS,0))
if 'DGBSI
QUIT
+5 IF $$FT^IBCU3(IBIFN)=2
SET DGPROC=$PIECE($GET(^IBE(350.9,1,1)),"^",30)
SET DGDIV=""
+6 ; ins rev cd
SET DGRVCOD=$PIECE($GET(DGINPAR),"^",10)
+7 ; site rev cd
IF DGRVCOD=""
SET DGRVCOD=$PIECE($GET(^IBE(350.9,1,1)),"^",28)
+8 ; standard rev cd
IF DGRVCOD=""
DO SETREV^IBCU62
GOTO END
+9 SET DGAMNT=$$CHG(DGBSI,IBIDS(151),DGRVCOD)
if 'DGAMNT
QUIT
SET X=DGRVCOD
+10 DO FILE
END KILL DGPROC,DGDIV,DGRVCOD
+1 QUIT
+2 ;MAP TO DGCRU61
+3 ;
ALL ;delete all revenue codes that may have been set up automatically
+1 ;ie = $d(^IB(399.5,"d",code ifn))
+2 KILL DA
SET DA(1)=IBIFN
SET DA=0
IF '$GET(IBAUTO)
WRITE !,"Removing old Revenue Codes."
+3 FOR DGII=0:0
SET DA=$ORDER(^DGCR(399,IBIFN,"RC",DA))
if DA<1
QUIT
SET X=$GET(^DGCR(399,IBIFN,"RC",DA,0))
Begin DoDot:1
+4 ;remove revenue codes pre-defined for automatic use AND revenue codes for BASC charges (are automatically created)
+5 if '$GET(IBAUTO)
WRITE "."
DO DEL
End DoDot:1
+6 QUIT
DEL SET DIK="^DGCR(399,"_DA(1)_",""RC"","
DO ^DIK
LOCK ^DGCR(399,IBIFN):1
+1 QUIT
+2 ;
+3 ;
CHG(IBSI,IBDT,IBRVCD) ; returns charge for bedsection and date, rev cd optional
+1 NEW IBAMNT,IBACTDT,IBRC,IBDA,IBRT,IBQUIT,X
SET IBAMNT=0
+2 ;
+3 SET IBACTDT=-(IBDT+.01)
FOR
SET IBACTDT=$ORDER(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT))
if 'IBACTDT!+IBAMNT
QUIT
Begin DoDot:1
+4 SET IBRC=+IBRVCD
SET IBDA=0
FOR
SET IBDA=$ORDER(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT,IBRC,IBDA))
if 'IBDA!+IBAMNT
QUIT
Begin DoDot:2
+5 SET IBRT=$GET(^DGCR(399.5,+IBDA,0))
+6 IF $PIECE(IBRT,U,6)["i"
IF +$PIECE(IBRT,U,5)
SET IBAMNT=$PIECE(IBRT,U,4)
End DoDot:2
End DoDot:1
+7 ;
+8 IF 'IBAMNT
SET IBACTDT=-(IBDT+.01)
FOR
SET IBACTDT=$ORDER(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT))
if 'IBACTDT!+IBAMNT
QUIT
Begin DoDot:1
+9 SET IBRC=""
FOR
SET IBRC=$ORDER(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT,IBRC))
if 'IBRC!+IBAMNT
QUIT
Begin DoDot:2
+10 SET IBDA=0
FOR
SET IBDA=$ORDER(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT,IBRC,IBDA))
if 'IBDA!+IBAMNT
QUIT
Begin DoDot:3
+11 SET IBRT=$GET(^DGCR(399.5,+IBDA,0))
+12 IF $PIECE(IBRT,U,6)["i"
IF +$PIECE(IBRT,U,5)
SET IBAMNT=$PIECE(IBRT,U,4)
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT IBAMNT
