IBCU63 ;ALB/AAS - BILLING UTILITY TO SET AMB SURG REV CODES ; 20-NOV-91
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, 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,?65,$P($G(^ICPT(+$G(DGPROC),0)),"^")
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 hcfa 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=20,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
IBCU63 ;ALB/AAS - BILLING UTILITY TO SET AMB SURG REV CODES ; 20-NOV-91
+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 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,?65,$PIECE($GET(^ICPT(+$GET(DGPROC),0)),"^")
+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 hcfa 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=20
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
