IBCREE ;ALB/ARH - RATES: CM ENTER/EDIT ;16-MAY-1996
;;2.0;INTEGRATED BILLING;**52,106,115,223,474**;21-MAR-94;Build 29
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EDITRT ; ACTION enter/edit rate types (399.3)
N DIC,DIE,DA,DR,X,Y,IBRTFN
W !!,"CAUTION: This is a standard file with entries released nationally, do not add or"
W !," modify unless necessary. Changing the Name or AR Category or if it is"
W !," a Third Party rate type will effect processing of claims."
W !!,"Enter/Edit a Rate Type:"
;
S DIC="^DGCR(399.3,",DIC(0)="AELNQ" D ^DIC K DIC I Y<1 K X,Y Q
;
S IBRTFN=+Y I $D(IBRTFNX) S IBRTFNX=+Y
;
S DIE="^DGCR(399.3,",DA=+IBRTFN,DR=".01;.02;.04;.05;.08;.09;.03;.06" D ^DIE K DIE,DA,DR,X,Y
Q
;
EDITRS ; ACTION enter/edit rate schedules (363)
N DIC,DIE,DA,DR,X,Y,DINUM,DLAYGO,IBRSFN
W !!,"The Rate Schedule Adjustment is an M code field, it therefore requires"
W !,"programmer access to enter or edit (using Charge Master IRM Enter/Edit"
W !,"[IBCR CHARGE MASTER IRM] option. Contact IRM if this field needs to be modified."
W !!,"Enter/Edit a Rate Schedule:"
;
S DINUM=$O(^IBE(363,"A"),-1),DINUM=$S(DINUM<1000:1001,1:DINUM+1) I 'DINUM!($D(^IBE(363,DINUM,0))) Q
S DLAYGO=363,DIC="^IBE(363,",DIC(0)="AELNQ" D ^DIC K DIC,DINUM,DLAYGO I Y<1 K X,Y Q
;
S IBRSFN=+Y I $D(IBRSFNX) S IBRSFNX=+Y
;
S DIE("NO^")="BACK"
S DIDEL=363,DIE="^IBE(363,",DA=+IBRSFN,DR=".01;.02;.03;.04;.05;.06;11" D ^DIE K DIE,DA,DR,X,Y,DIDEL
Q
;
EDITRSA ; OPTION enter/edit Rate Schedule Adjustment field (363,10) if DUZ="@"
N IBRS10,IBRS10A,IBRS10B,DIR,DIC,DIE,DA,DR,X,Y,IBRSFN
I DUZ(0)'="@" W !,"This option requires programmer access (DUZ(0)=@).",! G ERSA1Q
;
S DIC="^IBE(363,",DIC(0)="AENQ" D ^DIC K DIC S IBRSFN=+Y I Y<1 K X,Y Q
S IBRS10B=$G(^IBE(363,+IBRSFN,10))
;
ERSA1 W !
S IBRS10=$G(^IBE(363,+IBRSFN,10))
I IBRS10="" W !,?7,"The base unit charges are not currently Adjusted.",!
I IBRS10'="" S X=100 X IBRS10 W !,?7,"If the base unit charge is $100,",!,?7,"this Adjustment will result in a charge of: $",$J(X,10,2),!!
S DIE="^IBE(363,",DA=+IBRSFN,DR="10" D ^DIE K DIE,DA,DR,X,Y
S IBRS10A=$G(^IBE(363,+IBRSFN,10))
I IBRS10A=IBRS10 W " ... no change"
I IBRS10A="" W !!,?7,"The base unit charges will not be modified."
S X=100 X IBRS10A W !!,?7,"If the base unit charge is $100,",!,?7,"this Adjustment will result in a charge of: $",$J(X,10,2),!
S DIR("?")="If the correct Adjustment has been entered, answer Yes to this question. If the Adjustment has been entered incorrectly, answer No, and then enter the correct value."
S DIR("?")=DIR("?")_" To exit the option without saving changes to the original Adjustment, enter '^'."
S DIR("?",1)="Enter 'Y' or 'N' or '^' to exit the option.",DIR("?",2)=" "
S DIR("?",3)="The Adjustment has an immediate effect on the charges for this rate."
;
W !,"Please note: using '^' to exit the option will not change the adjustment."
S DIR(0)="Y",DIR("A")="Is this correct" D ^DIR K DIR
; restore the original adjustment or remove the change (#10)
I $D(DIRUT) D G ERSA1Q
. I IBRS10B'="" S DIE="^IBE(363,",DA=+IBRSFN,DR="10///"_IBRS10B D ^DIE K DIE,DA,DR,X,Y Q
. S DA(1)=+IBRSFN,DIK="^IBE(363,"_DA(1)_",",DA=10 D ^DIK K DIK,DA
G:'Y ERSA1
;
I $P($G(^DGCR(399.1,+$P(^IBE(363,+IBRSFN,0),"^",4),0)),"^")="PRESCRIPTION",IBRS10A["+" D
. W !,"The adjustment you entered may have included a dispensing fee or administrative"
. W !,"fee. If that is the case, please record the amount of the respective fee(s)"
. W !,"used in the adjustment calculation above."
. S DIE="^IBE(363,",DA=+IBRSFN,DR="1.01;1.02" D ^DIE
;
ERSA1Q Q
;
EDITRG ; enter/edit billing regions (363.31)
N DIC,DIE,DA,DR,X,Y,DLAYGO,IBRGFN,IBI
W !!,"Enter/Edit a Rate's Billing Regions:"
;
S DLAYGO=363.31,DIC="^IBE(363.31,",DIC(0)="AELNQ" D ^DIC K DIC,DLAYGO I Y<1 K X,Y Q
;
S IBRGFN=+Y D RESETDV^IBCREE2($P(Y,U,2))
;
; dr to only allow divisions or institutions not both
S DIDEL=363.31,DIE="^IBE(363.31,",DA=+IBRGFN,DR=".01;"_$S($O(^IBE(363.31,DA,21,0)):"",1:"11;S:$O(^IBE(363.31,DA,11,0)) Y=0;")_"21" D ^DIE K DIE,DR,X,Y,DIDEL
;
I '$D(DA),+IBRGFN S IBI=0 F S IBI=$O(^IBE(363.1,IBI)) Q:'IBI D ; remove deleted regions from charge sets
. I +$P($G(^IBE(363.1,IBI,0)),U,7)=+IBRGFN S DIE="^IBE(363.1,",DA=+IBI,DR=".07///@" D ^DIE K DIE,DA,DR,X,Y
Q
;
EDITBR ; enter/edit billing rates (363.3)
N DIC,DIE,DA,DR,X,Y,DINUM,DLAYGO,IBX,IBBRFN
W !!,"Enter/Edit a Billing Rate: "
;
S DINUM=$O(^IBE(363.3,"A"),-1),DINUM=$S(DINUM<1000:1001,1:DINUM+1) I 'DINUM!($D(^IBE(363.3,DINUM,0))) Q
S DLAYGO=363.3,DIC="^IBE(363.3,",DIC(0)="AELNQ" D ^DIC K DIC,DINUM,DLAYGO I Y<1 K X,Y Q
;
S IBBRFN=+Y
;
S DIE("NO^")="BACK"
S DR=".01;.02;.03////2;.05;I X=2 S Y=""@6"";.04;@6" ; VA Cost sets should not have a billable item
;
S IBX=$$CHKBR^IBCREU1(+Y) I +IBX S DR=".02" D W !!
. W !!,"Only the Abbreviation may be edited, the Billing Rate Definition can not change:"
. I +$P(IBX,U,2) W !," - this Billing Rate definition was exported Nationally"
. I +$P(IBX,U,3) W !," - there are Charge Sets defined for this Billing Rate"
. I +$P(IBX,U,4) W !," - there are Charge Items defined for a Charge Set with this Billing Rate"
I '$P(IBX,U,3) W !,"This Billing Rate does not have any Charge Sets assigned.",!
;
S DIDEL=363.3,DIE="^IBE(363.3,",DA=+IBBRFN D ^DIE K DIE,DA,DR,X,Y,DIDEL
Q
;
EDITCS ; enter/edit Charge Sets (363.1)
N DIC,DIE,DA,DR,X,Y,DINUM,DLAYGO,IBX,IBCSFN
W !!,"Enter/Edit a Charge Set:"
;
S DINUM=$O(^IBE(363.1,"A"),-1),DINUM=$S(DINUM<1000:1001,1:DINUM+1) I 'DINUM!($D(^IBE(363.1,DINUM,0))) Q
S DLAYGO=363.1,DIC="^IBE(363.1,",DIC(0)="AELNQ" D ^DIC K DIC,DINUM,DLAYGO I Y<1 K X,Y Q
;
S IBCSFN=+Y I $D(IBCSFNX) S IBCSFNX=+Y
I IBCSFN<1000 D RESETDV^IBCREE2($P(Y,U,2))
;
S DR=".01;.02;.03;.04;.05;.06;.07"
S IBX=$$CHKCS^IBCREU1(+Y) I +IBX S DR=".04;.05;.06;.07" D W !!
. W !!,"Not all elements of this Charge Set may be edited:"
. I +$P(IBX,U,3) D Q
.. W !," - the Set name, Rate, and Billable Event may not be modified since this",!," Charge Set definition was exported nationally."
. I +$P(IBX,U,2) D S DR=".01;.03;"_DR
.. W !," - the Billing Rate may not change since the Charge Set has Charge Items."
;
;
REDTCS S DIDEL=363.1,DIE="^IBE(363.1,",DA=+IBCSFN D ^DIE K DIE,DR,X,DIDEL
;
I $D(DA),$D(Y)=0 S IBX=$$RQCS^IBCREU1(IBCSFN) I +IBX S DR="" W ! D G REDTCS
. I $P(IBX,U,2)=1 W !,"The Charge Set requires a Billing Rate.",! S DR=DR_".02;"
. I $P(IBX,U,3)=1 W !,"The Charge Set requires a Billable Event.",! S DR=DR_".03;"
. I $P(IBX,U,5) D S DR=DR_".05;"
.. W !,"This Charge Set requires a default Revenue Code:"
.. W !," - A VA Cost Charge Set requires a default Rev Code since there are no"
.. W !," Items to assign the rev code to",!
. I $P(IBX,U,4) D S DR=DR_".06;"
.. W !,"This Charge Set requires a default bedsection:"
.. W !," - a bedsection is required before a charge can be added to a bill"
.. W !," therefore a default bedsection is required for every Charge Set whose"
.. W !," charge item is not bedsection",!
;
Q
;
EDITBI ; enter/edit billing items - NDC #, MISC (363.21)
N DIC,DIE,DIR,DA,DR,X,Y,DLAYGO,IBX,IBBIN,IBTYPE
W !!,"These are items that are billable but not found in other DHCP source files."
W !,"Items entered that already exist and have no associated charge, can be deleted.",!
;
S DIR(0)="363.21,.02A",DIR("A")="Enter which type of Billable Item? " D ^DIR K DIR I Y<1 Q
S IBTYPE=+Y_U_Y(0)
;
EBI1 W !
;
S DLAYGO=363.21,DIC="^IBA(363.21,",DIC(0)="AELQ",DIC("A")=$P(IBTYPE,U,2)_" Item: ",DIC("DR")=".02////"_+IBTYPE
S DIC("S")="I $P(^(0),U,2)="_+IBTYPE D ^DIC K DIC,DIE,DA,DR,DLAYGO I Y<1 K X,Y Q
S IBBIN=Y
;
I +IBTYPE=1,+$P(IBBIN,U,3),$P(IBBIN,U,2)'?1N.N1"-"1N.N1"-"1N.N D G EBI1
. I $$DELBI(+IBBIN) W !," ... not added, invalid format (n-n-n)"
;
I +$P(IBBIN,U,3) W " ... added" G EBI1
;
I '$P(IBBIN,U,3) W " ... already exists" D G EBI1
. S IBX=+IBBIN_";IBA(363.21," I $O(^IBA(363.2,"B",IBX,0)) W " => can not delete, has Charge Items" Q
. S DIR(0)="Y",DIR("A")=" DELETE "_$P(IBTYPE,U,2)_" - "_$P(IBBIN,U,2) D ^DIR K DIR I Y'=1 W ?50," ... no change" Q
. I Y=1 I $$DELBI(+IBBIN) W ?50," ... deleted"
G EBI1
Q
DELBI(DA) ;
N IBX,DIK S IBX=0 I $D(^IBA(363.21,+$G(DA),0)) S DIK="^IBA(363.21," D ^DIK K DA,DIK S IBX=1
Q IBX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCREE 8553 printed Dec 13, 2024@02:19 Page 2
IBCREE ;ALB/ARH - RATES: CM ENTER/EDIT ;16-MAY-1996
+1 ;;2.0;INTEGRATED BILLING;**52,106,115,223,474**;21-MAR-94;Build 29
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EDITRT ; ACTION enter/edit rate types (399.3)
+1 NEW DIC,DIE,DA,DR,X,Y,IBRTFN
+2 WRITE !!,"CAUTION: This is a standard file with entries released nationally, do not add or"
+3 WRITE !," modify unless necessary. Changing the Name or AR Category or if it is"
+4 WRITE !," a Third Party rate type will effect processing of claims."
+5 WRITE !!,"Enter/Edit a Rate Type:"
+6 ;
+7 SET DIC="^DGCR(399.3,"
SET DIC(0)="AELNQ"
DO ^DIC
KILL DIC
IF Y<1
KILL X,Y
QUIT
+8 ;
+9 SET IBRTFN=+Y
IF $DATA(IBRTFNX)
SET IBRTFNX=+Y
+10 ;
+11 SET DIE="^DGCR(399.3,"
SET DA=+IBRTFN
SET DR=".01;.02;.04;.05;.08;.09;.03;.06"
DO ^DIE
KILL DIE,DA,DR,X,Y
+12 QUIT
+13 ;
EDITRS ; ACTION enter/edit rate schedules (363)
+1 NEW DIC,DIE,DA,DR,X,Y,DINUM,DLAYGO,IBRSFN
+2 WRITE !!,"The Rate Schedule Adjustment is an M code field, it therefore requires"
+3 WRITE !,"programmer access to enter or edit (using Charge Master IRM Enter/Edit"
+4 WRITE !,"[IBCR CHARGE MASTER IRM] option. Contact IRM if this field needs to be modified."
+5 WRITE !!,"Enter/Edit a Rate Schedule:"
+6 ;
+7 SET DINUM=$ORDER(^IBE(363,"A"),-1)
SET DINUM=$SELECT(DINUM<1000:1001,1:DINUM+1)
IF 'DINUM!($DATA(^IBE(363,DINUM,0)))
QUIT
+8 SET DLAYGO=363
SET DIC="^IBE(363,"
SET DIC(0)="AELNQ"
DO ^DIC
KILL DIC,DINUM,DLAYGO
IF Y<1
KILL X,Y
QUIT
+9 ;
+10 SET IBRSFN=+Y
IF $DATA(IBRSFNX)
SET IBRSFNX=+Y
+11 ;
+12 SET DIE("NO^")="BACK"
+13 SET DIDEL=363
SET DIE="^IBE(363,"
SET DA=+IBRSFN
SET DR=".01;.02;.03;.04;.05;.06;11"
DO ^DIE
KILL DIE,DA,DR,X,Y,DIDEL
+14 QUIT
+15 ;
EDITRSA ; OPTION enter/edit Rate Schedule Adjustment field (363,10) if DUZ="@"
+1 NEW IBRS10,IBRS10A,IBRS10B,DIR,DIC,DIE,DA,DR,X,Y,IBRSFN
+2 IF DUZ(0)'="@"
WRITE !,"This option requires programmer access (DUZ(0)=@).",!
GOTO ERSA1Q
+3 ;
+4 SET DIC="^IBE(363,"
SET DIC(0)="AENQ"
DO ^DIC
KILL DIC
SET IBRSFN=+Y
IF Y<1
KILL X,Y
QUIT
+5 SET IBRS10B=$GET(^IBE(363,+IBRSFN,10))
+6 ;
ERSA1 WRITE !
+1 SET IBRS10=$GET(^IBE(363,+IBRSFN,10))
+2 IF IBRS10=""
WRITE !,?7,"The base unit charges are not currently Adjusted.",!
+3 IF IBRS10'=""
SET X=100
XECUTE IBRS10
WRITE !,?7,"If the base unit charge is $100,",!,?7,"this Adjustment will result in a charge of: $",$JUSTIFY(X,10,2),!!
+4 SET DIE="^IBE(363,"
SET DA=+IBRSFN
SET DR="10"
DO ^DIE
KILL DIE,DA,DR,X,Y
+5 SET IBRS10A=$GET(^IBE(363,+IBRSFN,10))
+6 IF IBRS10A=IBRS10
WRITE " ... no change"
+7 IF IBRS10A=""
WRITE !!,?7,"The base unit charges will not be modified."
+8 SET X=100
XECUTE IBRS10A
WRITE !!,?7,"If the base unit charge is $100,",!,?7,"this Adjustment will result in a charge of: $",$JUSTIFY(X,10,2),!
+9 SET DIR("?")="If the correct Adjustment has been entered, answer Yes to this question. If the Adjustment has been entered incorrectly, answer No, and then enter the correct value."
+10 SET DIR("?")=DIR("?")_" To exit the option without saving changes to the original Adjustment, enter '^'."
+11 SET DIR("?",1)="Enter 'Y' or 'N' or '^' to exit the option."
SET DIR("?",2)=" "
+12 SET DIR("?",3)="The Adjustment has an immediate effect on the charges for this rate."
+13 ;
+14 WRITE !,"Please note: using '^' to exit the option will not change the adjustment."
+15 SET DIR(0)="Y"
SET DIR("A")="Is this correct"
DO ^DIR
KILL DIR
+16 ; restore the original adjustment or remove the change (#10)
+17 IF $DATA(DIRUT)
Begin DoDot:1
+18 IF IBRS10B'=""
SET DIE="^IBE(363,"
SET DA=+IBRSFN
SET DR="10///"_IBRS10B
DO ^DIE
KILL DIE,DA,DR,X,Y
QUIT
+19 SET DA(1)=+IBRSFN
SET DIK="^IBE(363,"_DA(1)_","
SET DA=10
DO ^DIK
KILL DIK,DA
End DoDot:1
GOTO ERSA1Q
+20 if 'Y
GOTO ERSA1
+21 ;
+22 IF $PIECE($GET(^DGCR(399.1,+$PIECE(^IBE(363,+IBRSFN,0),"^",4),0)),"^")="PRESCRIPTION"
IF IBRS10A["+"
Begin DoDot:1
+23 WRITE !,"The adjustment you entered may have included a dispensing fee or administrative"
+24 WRITE !,"fee. If that is the case, please record the amount of the respective fee(s)"
+25 WRITE !,"used in the adjustment calculation above."
+26 SET DIE="^IBE(363,"
SET DA=+IBRSFN
SET DR="1.01;1.02"
DO ^DIE
End DoDot:1
+27 ;
ERSA1Q QUIT
+1 ;
EDITRG ; enter/edit billing regions (363.31)
+1 NEW DIC,DIE,DA,DR,X,Y,DLAYGO,IBRGFN,IBI
+2 WRITE !!,"Enter/Edit a Rate's Billing Regions:"
+3 ;
+4 SET DLAYGO=363.31
SET DIC="^IBE(363.31,"
SET DIC(0)="AELNQ"
DO ^DIC
KILL DIC,DLAYGO
IF Y<1
KILL X,Y
QUIT
+5 ;
+6 SET IBRGFN=+Y
DO RESETDV^IBCREE2($PIECE(Y,U,2))
+7 ;
+8 ; dr to only allow divisions or institutions not both
+9 SET DIDEL=363.31
SET DIE="^IBE(363.31,"
SET DA=+IBRGFN
SET DR=".01;"_$SELECT($ORDER(^IBE(363.31,DA,21,0)):"",1:"11;S:$O(^IBE(363.31,DA,11,0)) Y=0;")_"21"
DO ^DIE
KILL DIE,DR,X,Y,DIDEL
+10 ;
+11 ; remove deleted regions from charge sets
IF '$DATA(DA)
IF +IBRGFN
SET IBI=0
FOR
SET IBI=$ORDER(^IBE(363.1,IBI))
if 'IBI
QUIT
Begin DoDot:1
+12 IF +$PIECE($GET(^IBE(363.1,IBI,0)),U,7)=+IBRGFN
SET DIE="^IBE(363.1,"
SET DA=+IBI
SET DR=".07///@"
DO ^DIE
KILL DIE,DA,DR,X,Y
End DoDot:1
+13 QUIT
+14 ;
EDITBR ; enter/edit billing rates (363.3)
+1 NEW DIC,DIE,DA,DR,X,Y,DINUM,DLAYGO,IBX,IBBRFN
+2 WRITE !!,"Enter/Edit a Billing Rate: "
+3 ;
+4 SET DINUM=$ORDER(^IBE(363.3,"A"),-1)
SET DINUM=$SELECT(DINUM<1000:1001,1:DINUM+1)
IF 'DINUM!($DATA(^IBE(363.3,DINUM,0)))
QUIT
+5 SET DLAYGO=363.3
SET DIC="^IBE(363.3,"
SET DIC(0)="AELNQ"
DO ^DIC
KILL DIC,DINUM,DLAYGO
IF Y<1
KILL X,Y
QUIT
+6 ;
+7 SET IBBRFN=+Y
+8 ;
+9 SET DIE("NO^")="BACK"
+10 ; VA Cost sets should not have a billable item
SET DR=".01;.02;.03////2;.05;I X=2 S Y=""@6"";.04;@6"
+11 ;
+12 SET IBX=$$CHKBR^IBCREU1(+Y)
IF +IBX
SET DR=".02"
Begin DoDot:1
+13 WRITE !!,"Only the Abbreviation may be edited, the Billing Rate Definition can not change:"
+14 IF +$PIECE(IBX,U,2)
WRITE !," - this Billing Rate definition was exported Nationally"
+15 IF +$PIECE(IBX,U,3)
WRITE !," - there are Charge Sets defined for this Billing Rate"
+16 IF +$PIECE(IBX,U,4)
WRITE !," - there are Charge Items defined for a Charge Set with this Billing Rate"
End DoDot:1
WRITE !!
+17 IF '$PIECE(IBX,U,3)
WRITE !,"This Billing Rate does not have any Charge Sets assigned.",!
+18 ;
+19 SET DIDEL=363.3
SET DIE="^IBE(363.3,"
SET DA=+IBBRFN
DO ^DIE
KILL DIE,DA,DR,X,Y,DIDEL
+20 QUIT
+21 ;
EDITCS ; enter/edit Charge Sets (363.1)
+1 NEW DIC,DIE,DA,DR,X,Y,DINUM,DLAYGO,IBX,IBCSFN
+2 WRITE !!,"Enter/Edit a Charge Set:"
+3 ;
+4 SET DINUM=$ORDER(^IBE(363.1,"A"),-1)
SET DINUM=$SELECT(DINUM<1000:1001,1:DINUM+1)
IF 'DINUM!($DATA(^IBE(363.1,DINUM,0)))
QUIT
+5 SET DLAYGO=363.1
SET DIC="^IBE(363.1,"
SET DIC(0)="AELNQ"
DO ^DIC
KILL DIC,DINUM,DLAYGO
IF Y<1
KILL X,Y
QUIT
+6 ;
+7 SET IBCSFN=+Y
IF $DATA(IBCSFNX)
SET IBCSFNX=+Y
+8 IF IBCSFN<1000
DO RESETDV^IBCREE2($PIECE(Y,U,2))
+9 ;
+10 SET DR=".01;.02;.03;.04;.05;.06;.07"
+11 SET IBX=$$CHKCS^IBCREU1(+Y)
IF +IBX
SET DR=".04;.05;.06;.07"
Begin DoDot:1
+12 WRITE !!,"Not all elements of this Charge Set may be edited:"
+13 IF +$PIECE(IBX,U,3)
Begin DoDot:2
+14 WRITE !," - the Set name, Rate, and Billable Event may not be modified since this",!," Charge Set definition was exported nationally."
End DoDot:2
QUIT
+15 IF +$PIECE(IBX,U,2)
Begin DoDot:2
+16 WRITE !," - the Billing Rate may not change since the Charge Set has Charge Items."
End DoDot:2
SET DR=".01;.03;"_DR
End DoDot:1
WRITE !!
+17 ;
+18 ;
REDTCS SET DIDEL=363.1
SET DIE="^IBE(363.1,"
SET DA=+IBCSFN
DO ^DIE
KILL DIE,DR,X,DIDEL
+1 ;
+2 IF $DATA(DA)
IF $DATA(Y)=0
SET IBX=$$RQCS^IBCREU1(IBCSFN)
IF +IBX
SET DR=""
WRITE !
Begin DoDot:1
+3 IF $PIECE(IBX,U,2)=1
WRITE !,"The Charge Set requires a Billing Rate.",!
SET DR=DR_".02;"
+4 IF $PIECE(IBX,U,3)=1
WRITE !,"The Charge Set requires a Billable Event.",!
SET DR=DR_".03;"
+5 IF $PIECE(IBX,U,5)
Begin DoDot:2
+6 WRITE !,"This Charge Set requires a default Revenue Code:"
+7 WRITE !," - A VA Cost Charge Set requires a default Rev Code since there are no"
+8 WRITE !," Items to assign the rev code to",!
End DoDot:2
SET DR=DR_".05;"
+9 IF $PIECE(IBX,U,4)
Begin DoDot:2
+10 WRITE !,"This Charge Set requires a default bedsection:"
+11 WRITE !," - a bedsection is required before a charge can be added to a bill"
+12 WRITE !," therefore a default bedsection is required for every Charge Set whose"
+13 WRITE !," charge item is not bedsection",!
End DoDot:2
SET DR=DR_".06;"
End DoDot:1
GOTO REDTCS
+14 ;
+15 QUIT
+16 ;
EDITBI ; enter/edit billing items - NDC #, MISC (363.21)
+1 NEW DIC,DIE,DIR,DA,DR,X,Y,DLAYGO,IBX,IBBIN,IBTYPE
+2 WRITE !!,"These are items that are billable but not found in other DHCP source files."
+3 WRITE !,"Items entered that already exist and have no associated charge, can be deleted.",!
+4 ;
+5 SET DIR(0)="363.21,.02A"
SET DIR("A")="Enter which type of Billable Item? "
DO ^DIR
KILL DIR
IF Y<1
QUIT
+6 SET IBTYPE=+Y_U_Y(0)
+7 ;
EBI1 WRITE !
+1 ;
+2 SET DLAYGO=363.21
SET DIC="^IBA(363.21,"
SET DIC(0)="AELQ"
SET DIC("A")=$PIECE(IBTYPE,U,2)_" Item: "
SET DIC("DR")=".02////"_+IBTYPE
+3 SET DIC("S")="I $P(^(0),U,2)="_+IBTYPE
DO ^DIC
KILL DIC,DIE,DA,DR,DLAYGO
IF Y<1
KILL X,Y
QUIT
+4 SET IBBIN=Y
+5 ;
+6 IF +IBTYPE=1
IF +$PIECE(IBBIN,U,3)
IF $PIECE(IBBIN,U,2)'?1N.N1"-"1N.N1"-"1N.N
Begin DoDot:1
+7 IF $$DELBI(+IBBIN)
WRITE !," ... not added, invalid format (n-n-n)"
End DoDot:1
GOTO EBI1
+8 ;
+9 IF +$PIECE(IBBIN,U,3)
WRITE " ... added"
GOTO EBI1
+10 ;
+11 IF '$PIECE(IBBIN,U,3)
WRITE " ... already exists"
Begin DoDot:1
+12 SET IBX=+IBBIN_";IBA(363.21,"
IF $ORDER(^IBA(363.2,"B",IBX,0))
WRITE " => can not delete, has Charge Items"
QUIT
+13 SET DIR(0)="Y"
SET DIR("A")=" DELETE "_$PIECE(IBTYPE,U,2)_" - "_$PIECE(IBBIN,U,2)
DO ^DIR
KILL DIR
IF Y'=1
WRITE ?50," ... no change"
QUIT
+14 IF Y=1
IF $$DELBI(+IBBIN)
WRITE ?50," ... deleted"
End DoDot:1
GOTO EBI1
+15 GOTO EBI1
+16 QUIT
DELBI(DA) ;
+1 NEW IBX,DIK
SET IBX=0
IF $DATA(^IBA(363.21,+$GET(DA),0))
SET DIK="^IBA(363.21,"
DO ^DIK
KILL DA,DIK
SET IBX=1
+2 QUIT IBX
