IBCU62 ;ALB/AAS - UTILITY ROUTINE TO SET BEDSECTION/REVENUE CODES FROM PTF DATA ; 29-OCT-90
;;2.0;INTEGRATED BILLING;**133,447**;21-MAR-94;Build 80
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;MAP TO DGCRU62
;
SETREV ;find current active revenue codes for bedsection
S (DGREV,DGBR)=0,DGACTDT=-(IBIDS(151)+.01) K DGFND
F S DGACTDT=$O(^DGCR(399.5,"AIVDT",DGBSI,DGACTDT)) Q:'DGACTDT!($D(DGFND)) D
. F S DGREV=$O(^DGCR(399.5,"AIVDT",DGBSI,DGACTDT,DGREV)) Q:'DGREV D
.. F S DGBR=$O(^DGCR(399.5,"AIVDT",DGBSI,DGACTDT,DGREV,DGBR)) Q:'DGBR D CHKREV,STORREV:IBCHK
Q
CHKREV ;check if billing rate (dgbr) is active, and use with payer.
S IBCHK=0
S DGBRN=^DGCR(399.5,DGBR,0) I '$P(DGBRN,"^",5) Q ;quit if inactive
I IBIDS(.11)="i",$P(DGINPAR,"^",2)="",+$P(DGBRN,"^",7) Q ;quit if non-standard rate
I IBIDS(.11)'="i",+$P(DGBRN,"^",7) Q ;non-standard rates only for ins.
S DGREV00="00"_DGREV I IBIDS(.11)="i",$P(DGINPAR,"^",2)]"",$P(DGINPAR,"^",2)'[$E(DGREV00,$L(DGREV00)-2,$L(DGREV00)) Q ;quit if revenue code not in exception list
I $P(DGBRN,U,6)[IBIDS(.11) S:'$D(DGFND) DGFND="" S IBCHK=1 Q
Q
STORREV ;store revenue code in revenue code file
S X=$P(^DGCR(399.5,DGBR,0),"^",3),DGAMNT=$P(^(0),"^",4),DA(1)=IBIFN,DIC(0)="L",DIC="^DGCR(399,IBIFN,""RC"",",DGFUNC="Adding"
I $D(^DGCR(399,IBIFN,"RC","ABS",X,DGBSI)) S DA=$O(^DGCR(399,IBIFN,"RC","ABS",X,DGBSI,0)),DGFUNC="Editing" G EDITREV
D FILE,WRT
Q
;
FILE ;manually file entry, index with ix1^dik to use compiled x-ref
I '$D(DGREVHDR) D REVHDR
I IBIDS(.11)="c",IBIDS(.05)<3 S DGBSLOS=1
L ^DGCR(399,IBIFN):1
S DA=$P(^DGCR(399,IBIFN,"RC",0),"^",3)
F DGLL=0:0 S DA=DA+1 Q:'$D(^DGCR(399,IBIFN,"RC",DA,0))
;S ^DGCR(399,IBIFN,"RC",DA,0)=X_"^"_DGAMNT_"^"_DGBSLOS_"^^"_DGBSI_$S($D(DGPROC)&($D(DGDIV)):"^"_DGPROC_"^"_DGDIV,1:"")
S ^DGCR(399,IBIFN,"RC",DA,0)=X_"^"_DGAMNT_"^"_DGBSLOS_"^^"_DGBSI_"^"_$G(DGPROC)_"^"_$G(DGDIV)_"^"_1
S ^DGCR(399,IBIFN,"RC",0)=$P(^DGCR(399,IBIFN,"RC",0),"^",1,2)_"^"_DA_"^"_($P(^DGCR(399,IBIFN,"RC",0),"^",4)+1)
S DIK="^DGCR(399,"_DA(1)_",""RC""," D IX1^DIK L ^DGCR(399,IBIFN):1
Q
;
EDITREV ;edit revenue code data.
I '$D(DGREVHDR) D REVHDR
I $P(^DGCR(399,IBIFN,"RC",DA,0),U,16) Q ; IB*2.0*447 BI
I IBIDS(.11)="c",IBIDS(.05)<3 S DGBSLOS=1
S DIE=DIC,DA(1)=IBIFN,DR=".02///"_DGAMNT_";.03///"_DGBSLOS_";.05///"_DGBS D ^DIE
;
WRT ;S Z="00"_$P(^DGCR(399.5,DGBR,0),"^",3) W:'$G(IBAUTO) !,DGFUNC,?12,$E(Z,($L(Z)-2),$L(Z)),?24,DGBSLOS,?31,"$",$J(DGAMNT,8,2),?44,DGBS
S Z="00"_$P(^DGCR(399.5,DGBR,0),"^",3)
W:'$G(IBAUTO) !,DGFUNC,?12,$E(Z,($L(Z)-2),$L(Z)),?24,DGBSLOS,?31,"$",$J(DGAMNT,8,2),?44,DGBS I +$G(DGPROC) W ?65,$P($$CPT^ICPTCOD(+DGPROC),U,2)
Q
REVHDR S DGREVHDR=1 W:'$G(IBAUTO) !,"Updating Revenue Codes",!?10,"REV. CODE",?22,"UNITS",?31,"CHARGE",?44,"BEDSECTION" I $D(DGPROC) W:'$G(IBAUTO) ?65,"PROCEDURE"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCU62 2890 printed Dec 13, 2024@02:20:44 Page 2
IBCU62 ;ALB/AAS - UTILITY ROUTINE TO SET BEDSECTION/REVENUE CODES FROM PTF DATA ; 29-OCT-90
+1 ;;2.0;INTEGRATED BILLING;**133,447**;21-MAR-94;Build 80
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRU62
+5 ;
SETREV ;find current active revenue codes for bedsection
+1 SET (DGREV,DGBR)=0
SET DGACTDT=-(IBIDS(151)+.01)
KILL DGFND
+2 FOR
SET DGACTDT=$ORDER(^DGCR(399.5,"AIVDT",DGBSI,DGACTDT))
if 'DGACTDT!($DATA(DGFND))
QUIT
Begin DoDot:1
+3 FOR
SET DGREV=$ORDER(^DGCR(399.5,"AIVDT",DGBSI,DGACTDT,DGREV))
if 'DGREV
QUIT
Begin DoDot:2
+4 FOR
SET DGBR=$ORDER(^DGCR(399.5,"AIVDT",DGBSI,DGACTDT,DGREV,DGBR))
if 'DGBR
QUIT
DO CHKREV
if IBCHK
DO STORREV
End DoDot:2
End DoDot:1
+5 QUIT
CHKREV ;check if billing rate (dgbr) is active, and use with payer.
+1 SET IBCHK=0
+2 ;quit if inactive
SET DGBRN=^DGCR(399.5,DGBR,0)
IF '$PIECE(DGBRN,"^",5)
QUIT
+3 ;quit if non-standard rate
IF IBIDS(.11)="i"
IF $PIECE(DGINPAR,"^",2)=""
IF +$PIECE(DGBRN,"^",7)
QUIT
+4 ;non-standard rates only for ins.
IF IBIDS(.11)'="i"
IF +$PIECE(DGBRN,"^",7)
QUIT
+5 ;quit if revenue code not in exception list
SET DGREV00="00"_DGREV
IF IBIDS(.11)="i"
IF $PIECE(DGINPAR,"^",2)]""
IF $PIECE(DGINPAR,"^",2)'[$EXTRACT(DGREV00,$LENGTH(DGREV00)-2,$LENGTH(DGREV00))
QUIT
+6 IF $PIECE(DGBRN,U,6)[IBIDS(.11)
if '$DATA(DGFND)
SET DGFND=""
SET IBCHK=1
QUIT
+7 QUIT
STORREV ;store revenue code in revenue code file
+1 SET X=$PIECE(^DGCR(399.5,DGBR,0),"^",3)
SET DGAMNT=$PIECE(^(0),"^",4)
SET DA(1)=IBIFN
SET DIC(0)="L"
SET DIC="^DGCR(399,IBIFN,""RC"","
SET DGFUNC="Adding"
+2 IF $DATA(^DGCR(399,IBIFN,"RC","ABS",X,DGBSI))
SET DA=$ORDER(^DGCR(399,IBIFN,"RC","ABS",X,DGBSI,0))
SET DGFUNC="Editing"
GOTO EDITREV
+3 DO FILE
DO WRT
+4 QUIT
+5 ;
FILE ;manually file entry, index with ix1^dik to use compiled x-ref
+1 IF '$DATA(DGREVHDR)
DO REVHDR
+2 IF IBIDS(.11)="c"
IF IBIDS(.05)<3
SET DGBSLOS=1
+3 LOCK ^DGCR(399,IBIFN):1
+4 SET DA=$PIECE(^DGCR(399,IBIFN,"RC",0),"^",3)
+5 FOR DGLL=0:0
SET DA=DA+1
if '$DATA(^DGCR(399,IBIFN,"RC",DA,0))
QUIT
+6 ;S ^DGCR(399,IBIFN,"RC",DA,0)=X_"^"_DGAMNT_"^"_DGBSLOS_"^^"_DGBSI_$S($D(DGPROC)&($D(DGDIV)):"^"_DGPROC_"^"_DGDIV,1:"")
+7 SET ^DGCR(399,IBIFN,"RC",DA,0)=X_"^"_DGAMNT_"^"_DGBSLOS_"^^"_DGBSI_"^"_$GET(DGPROC)_"^"_$GET(DGDIV)_"^"_1
+8 SET ^DGCR(399,IBIFN,"RC",0)=$PIECE(^DGCR(399,IBIFN,"RC",0),"^",1,2)_"^"_DA_"^"_($PIECE(^DGCR(399,IBIFN,"RC",0),"^",4)+1)
+9 SET DIK="^DGCR(399,"_DA(1)_",""RC"","
DO IX1^DIK
LOCK ^DGCR(399,IBIFN):1
+10 QUIT
+11 ;
EDITREV ;edit revenue code data.
+1 IF '$DATA(DGREVHDR)
DO REVHDR
+2 ; IB*2.0*447 BI
IF $PIECE(^DGCR(399,IBIFN,"RC",DA,0),U,16)
QUIT
+3 IF IBIDS(.11)="c"
IF IBIDS(.05)<3
SET DGBSLOS=1
+4 SET DIE=DIC
SET DA(1)=IBIFN
SET DR=".02///"_DGAMNT_";.03///"_DGBSLOS_";.05///"_DGBS
DO ^DIE
+5 ;
WRT ;S Z="00"_$P(^DGCR(399.5,DGBR,0),"^",3) W:'$G(IBAUTO) !,DGFUNC,?12,$E(Z,($L(Z)-2),$L(Z)),?24,DGBSLOS,?31,"$",$J(DGAMNT,8,2),?44,DGBS
+1 SET Z="00"_$PIECE(^DGCR(399.5,DGBR,0),"^",3)
+2 if '$GET(IBAUTO)
WRITE !,DGFUNC,?12,$EXTRACT(Z,($LENGTH(Z)-2),$LENGTH(Z)),?24,DGBSLOS,?31,"$",$JUSTIFY(DGAMNT,8,2),?44,DGBS
IF +$GET(DGPROC)
WRITE ?65,$PIECE($$CPT^ICPTCOD(+DGPROC),U,2)
+3 QUIT
REVHDR SET DGREVHDR=1
if '$GET(IBAUTO)
WRITE !,"Updating Revenue Codes",!?10,"REV. CODE",?22,"UNITS",?31,"CHARGE",?44,"BEDSECTION"
IF $DATA(DGPROC)
if '$GET(IBAUTO)
WRITE ?65,"PROCEDURE"
