- 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 Mar 13, 2025@21:23:59 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