IBCU61 ;ALB/AAS - DELETE ENTRIES IN REVENUE CODE MULT. ; 4-MAY-90
;;2.0;INTEGRATED BILLING;**153,447**;21-MAR-94;Build 80
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;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)
. ;I $D(^DGCR(399.5,"D",+$P(X,"^")))!($D(^DGCR(399,"ASC1",+$P(X,U,6),IBIFN)))!(+$P(X,U,8)) W:'$G(IBAUTO) "." D DEL
. ; IB*2.0*447 BI Added a filter to avoid updating a MANUALLY EDITED revenue code.
. I $D(^DGCR(399.5,"D",+$P(X,"^")))!($D(^DGCR(399,"ASC1",+$P(X,U,6),IBIFN)))!(+$P(X,U,8))!('+$P(X,U,16)) W:'$G(IBAUTO) "." D DEL
Q
DEL S DIK="^DGCR(399,"_DA(1)_",""RC""," D ^DIK L ^DGCR(399,IBIFN):1
Q
;
GVAR ;I $D(PTF),PTF]"",$D(^DGPT(PTF,0)),'$P(^DGPT(PTF,0),"^",6),$D(DGPTUPDT) D UPDT^DGPTUTL S DGPTUPDT="" ;if open, update ptf record
S IBND0=$S('$D(^DGCR(399,IBIFN,0)):"",1:^(0))
S IBNDU=$S('$D(^DGCR(399,IBIFN,"U")):"",1:^("U"))
I '$D(IBIDS(.03)) S IBIDS(.03)=$P(IBND0,"^",3)
I '$D(IBIDS(.05)) S IBIDS(.05)=$P(IBND0,"^",5)
I '$D(IBIDS(.06)) S IBIDS(.06)=$P(IBND0,"^",6)
I '$D(IBIDS(.11)) S IBIDS(.11)=$P(IBND0,"^",11)
I '$D(IBIDS(.19)) S IBIDS(.19)=$P(IBND0,"^",19)
I '$D(IBIDS(151)) S IBIDS(151)=$S(+IBNDU:+IBNDU,1:IBIDS(.03))
I '$D(IBIDS(152)) S IBIDS(152)=$S(+$P(IBNDU,"^",2):$P(IBNDU,"^",2),1:IBIDS(.03))
I '$D(IBIDS(101)),IBIDS(.11)="i",$D(^DGCR(399,IBIFN,"M")),+^("M"),$D(^DIC(36,+^("M"),0)) S IBIDS(101)=+^DGCR(399,IBIFN,"M")
I IBIDS(.11)="i",'$D(IBIDS(101)) S IBQUIT=1 Q
;I IBIDS(.11)="i" S DGINPAR=$S('$D(^DIC(36,+IBIDS(101),0)):"",1:$P(^(0),"^",6,10))
I IBIDS(.11)="i" S DGINPAR=$S('$D(^DIC(36,+IBIDS(101),0)):"",1:$P(^(0),"^",6,15))
;
CAT ;check patient bills to see if Means Test. set IBIDS(.11)="y" (yes)
;I IBIDS(.11)="p",$P(^PRCA(430.2,$P(^DGCR(399.3,$P(^DGCR(399,IBIFN,0),"^",7),0),"^",6),0),"^",6)="C" S IBIDS(.11)="c"
I IBIDS(.11)="p",$P($$CATN^PRCAFN(+$P(^DGCR(399.3,+$P(^DGCR(399,IBIFN,0),"^",7),0),"^",6)),"^",3)="C" S IBIDS(.11)="y"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCU61 2321 printed Oct 16, 2024@18:21:22 Page 2
IBCU61 ;ALB/AAS - DELETE ENTRIES IN REVENUE CODE MULT. ; 4-MAY-90
+1 ;;2.0;INTEGRATED BILLING;**153,447**;21-MAR-94;Build 80
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRU61
+5 ;
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 ;I $D(^DGCR(399.5,"D",+$P(X,"^")))!($D(^DGCR(399,"ASC1",+$P(X,U,6),IBIFN)))!(+$P(X,U,8)) W:'$G(IBAUTO) "." D DEL
+6 ; IB*2.0*447 BI Added a filter to avoid updating a MANUALLY EDITED revenue code.
+7 IF $DATA(^DGCR(399.5,"D",+$PIECE(X,"^")))!($DATA(^DGCR(399,"ASC1",+$PIECE(X,U,6),IBIFN)))!(+$PIECE(X,U,8))!('+$PIECE(X,U,16))
if '$GET(IBAUTO)
WRITE "."
DO DEL
End DoDot:1
+8 QUIT
DEL SET DIK="^DGCR(399,"_DA(1)_",""RC"","
DO ^DIK
LOCK ^DGCR(399,IBIFN):1
+1 QUIT
+2 ;
GVAR ;I $D(PTF),PTF]"",$D(^DGPT(PTF,0)),'$P(^DGPT(PTF,0),"^",6),$D(DGPTUPDT) D UPDT^DGPTUTL S DGPTUPDT="" ;if open, update ptf record
+1 SET IBND0=$SELECT('$DATA(^DGCR(399,IBIFN,0)):"",1:^(0))
+2 SET IBNDU=$SELECT('$DATA(^DGCR(399,IBIFN,"U")):"",1:^("U"))
+3 IF '$DATA(IBIDS(.03))
SET IBIDS(.03)=$PIECE(IBND0,"^",3)
+4 IF '$DATA(IBIDS(.05))
SET IBIDS(.05)=$PIECE(IBND0,"^",5)
+5 IF '$DATA(IBIDS(.06))
SET IBIDS(.06)=$PIECE(IBND0,"^",6)
+6 IF '$DATA(IBIDS(.11))
SET IBIDS(.11)=$PIECE(IBND0,"^",11)
+7 IF '$DATA(IBIDS(.19))
SET IBIDS(.19)=$PIECE(IBND0,"^",19)
+8 IF '$DATA(IBIDS(151))
SET IBIDS(151)=$SELECT(+IBNDU:+IBNDU,1:IBIDS(.03))
+9 IF '$DATA(IBIDS(152))
SET IBIDS(152)=$SELECT(+$PIECE(IBNDU,"^",2):$PIECE(IBNDU,"^",2),1:IBIDS(.03))
+10 IF '$DATA(IBIDS(101))
IF IBIDS(.11)="i"
IF $DATA(^DGCR(399,IBIFN,"M"))
IF +^("M")
IF $DATA(^DIC(36,+^("M"),0))
SET IBIDS(101)=+^DGCR(399,IBIFN,"M")
+11 IF IBIDS(.11)="i"
IF '$DATA(IBIDS(101))
SET IBQUIT=1
QUIT
+12 ;I IBIDS(.11)="i" S DGINPAR=$S('$D(^DIC(36,+IBIDS(101),0)):"",1:$P(^(0),"^",6,10))
+13 IF IBIDS(.11)="i"
SET DGINPAR=$SELECT('$DATA(^DIC(36,+IBIDS(101),0)):"",1:$PIECE(^(0),"^",6,15))
+14 ;
CAT ;check patient bills to see if Means Test. set IBIDS(.11)="y" (yes)
+1 ;I IBIDS(.11)="p",$P(^PRCA(430.2,$P(^DGCR(399.3,$P(^DGCR(399,IBIFN,0),"^",7),0),"^",6),0),"^",6)="C" S IBIDS(.11)="c"
+2 IF IBIDS(.11)="p"
IF $PIECE($$CATN^PRCAFN(+$PIECE(^DGCR(399.3,+$PIECE(^DGCR(399,IBIFN,0),"^",7),0),"^",6)),"^",3)="C"
SET IBIDS(.11)="y"
+3 QUIT
