IBCREE2 ;ALB/ARH - RATES: CM ENTER/EDIT (SG,RL,PD,DV) ; 10-OCT-1998
;;2.0;INTEGRATED BILLING;**106,138,148**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EDITSG ; enter/edit special groups (363.32)
N DIC,DIE,DA,DR,X,Y,DINUM,DLAYGO,IBX,IBSGFN
W !!,"Enter/Edit a Special Group: ",!
;
S DINUM=$O(^IBE(363.32,"A"),-1),DINUM=$S(DINUM<1000:1001,1:DINUM+1) I 'DINUM!($D(^IBE(363.32,DINUM,0))) Q
S DLAYGO=363.32,DIC="^IBE(363.32,",DIC(0)="AELNQ" D ^DIC K DIC,DINUM,DLAYGO I Y<1 K X,Y Q
;
S IBSGFN=+Y
;
S DR=".01;.02;11",DIE("NO^")="BACK"
;
S IBX=$$CHKSG^IBCREU1(+Y) I +IBX S DR="11" W ! D W !!
. I +$P(IBX,U,2) W !,"This was exported Nationally, only the assigned Billing Rates may be edited."
. I +$P(IBX,U,3) W !,"This group has associated Revenue Code Links, can not edit Type."
. I +$P(IBX,U,4) W !,"This group has associated Provider Discount Links, can not edit Type."
. I '$P(IBX,U,2) S DR=".01;"_DR
;
S DIDEL=363.32,DIE="^IBE(363.32,",DA=+IBSGFN D ^DIE K DIE,DA,DR,X,Y,DIDEL
Q
;
EDITRL ; enter/edit revenue code links (363.33)
N DIC,DIE,DA,DR,X,Y,DINUM,DLAYGO,IBX,IBRLFN
W !!,"Enter/Edit a Revenue Code Link: " I +$G(IBSGFN) W " (for "_$P(IBSGFN,U,2)_" group)",!
;
I '$G(IBSGFN) N IBSGFN S IBSGFN=$$GETSG^IBCRU1(1) Q:IBSGFN'>0 W !!
;
I IBSGFN<1000 W !,"This is a Nationally exported set of revenue code links.",!,"This should be modified only if the revenue code links added or changed",!,"fit the specific group definition: ",$P(IBSGFN,U,2),".",!!
;
S DIC("S")="I $P(^(0),U,2)="_+IBSGFN,DIC("DR")=".02////"_+IBSGFN,DIC("A")="Select REVENUE CODE: "
S DLAYGO=363.33,DIC="^IBE(363.33,",DIC(0)="AELNQ" D ^DIC K DIC,DINUM,DLAYGO I Y<1 K X,Y Q
;
S IBRLFN=+Y
;
S DR=".01;.03;.04"
S DIDEL=363.33,DIE="^IBE(363.33,",DA=+IBRLFN D ^DIE K DIE,DA,DR,X,Y,DIDEL
;
S IBX=$G(^IBE(363.33,+IBRLFN,0)) S IBCPT=$P(IBX,U,3) ; reset cpt being displayed
Q
;
EDITPD ; enter/edit provider discount (363.34)
N DIC,DIE,DA,DR,X,Y,DINUM,DLAYGO,IBX,IBPDFN
W !!,"Enter/Edit Provider Discount: " I +$G(IBSGFN) W " (for "_$P(IBSGFN,U,2)_" group)",!
;
I '$G(IBSGFN) S IBSGFN=$$GETSG^IBCRU1(2) Q:IBSGFN'>0
;
I IBSGFN<1000 W !!,"This is a Nationally exported set of Provider Discounts.",!,"This should be modified only if the provider discount added or changed",!,"fits the specific group definition: ",$P(IBSGFN,U,2),".",!!
;
S DIC("S")="I $P(^(0),U,2)="_+IBSGFN,DIC("DR")=".02////"_+IBSGFN
S DLAYGO=363.34,DIC="^IBE(363.34,",DIC(0)="AELNQ" D ^DIC K DIC,DINUM,DLAYGO I Y<1 K X,Y Q
;
S IBPDFN=+Y I $D(IBPDFNX) S IBPDFNX=+Y
;
S DR=".01;.03;11"
S DIDEL=363.34,DIE="^IBE(363.34,",DA=+IBPDFN D ^DIE K DIE,DA,DR,X,Y,DIDEL
Q
;
RESETDV(NAME) ; Reset Division numbers in both Charge Sets and Billing Regions (input CS or RG name)
; not all division numbers were known when the Reasonable Charges files were released,
; if the division number was not known then nnnXn or 9nnnn was used as a place holder in CS and RG names
; this option allows the user to change these fake division numbers to the correct division number, when known
;
N IBDIV,IBNDIV,IBFN,IBNM,IBNEW,IBI,IBX,DIC,DIE,DIR,DA,DR,DIRUT,DUOUT,DTOUT,X,Y,IBNDIVN,IBCT,IBST S IBNEW=""
Q:$G(NAME)="" I $E(NAME,1,3)'="RC ",$E(NAME,1,3)'="RC-" Q
;
S IBDIV="" F IBI=1:1 S IBX=$P(NAME," ",IBI) Q:IBX="" I (IBX?3N1"X"1.3N)!(IBX>899.9) S IBDIV=IBX Q
I IBDIV=""!(IBDIV=999) Q
;
W !!,">>> "_IBDIV," is an invalid site number.",!
S DIR("?")=IBDIV_" is not a valid site number, if you know the correct number for this division you may change it now for all Billing Region and Charge Set names."
RESET1 S DIR(0)="FO^3:7^I X'?3N,X'?3N1.4UN,'$O(^DG(40.8,""C"",X,0)) K X",DIR("A")="Enter the correct Division number for this site if available" D ^DIR Q:$D(DIRUT) I Y="" Q
;
S IBNDIV=Y,IBNDIVN=$O(^DG(40.8,"C",IBNDIV,0))
I 'IBNDIVN W !!,?5,IBNDIV," is not a valid Medical Center division on your system.",!!
;
S IBI="RC "_IBNDIV,IBX=$O(^IBE(363.31,"B",IBI)) I IBI=$P(IBX," ",1,2) W !!,IBX," already exists.",! G RESET1
S IBI="RC-PHYSICIAN "_IBNDIV,IBX=$O(^IBE(363.1,"B",IBI,0)) I +IBX W !!,IBI," already exists.",! G RESET1
;
S DIR(0)="YO",DIR("A")="Replace "_IBDIV_" with "_IBNDIV D ^DIR K DIR Q:$D(DIRUT) I Y'=1 Q
;
; change Billing Region Names
S IBFN=0 F S IBFN=$O(^IBE(363.31,IBFN)) Q:'IBFN D
. S IBNM=$P($G(^IBE(363.31,IBFN,0)),U,1) I IBNM'[IBDIV Q
. I ($E(IBNM,1,3)'="RC ")!($P(IBNM," ",2)'=IBDIV) Q
. ;
. S IBNEW=$P(IBNM,IBDIV,1)_IBNDIV_$P(IBNM,IBDIV,2)
. ;
. S DIE="^IBE(363.31,",DA=+IBFN,DR=".01///"_$E(IBNEW,1,30) D ^DIE K DIE,DR,X,Y
. ;
. ; check location of Billing Region, allow it to be updated if it does not appear to be standard
. I $P($P(IBNEW," - ",2),", ",2)'?2U D
.. W !!,">>> New Billing Region Name: ",IBNEW
.. W !,">>> The Billing Region location is not in the standard 'CITY, ST' format."
.. W !,">>> If you know the correct City, State for this division you may change it now.",!
.. S DIR(0)="PO^5:AEQMZ",DIR("A")="Enter the STATE where the Division is located"
.. D ^DIR Q:$D(DIRUT) S IBST=$P(Y(0),U,2)
.. S DIR(0)="FO^1:"_(30-$L($P(IBNEW," - ",1))-7),DIR("A")="Enter the CITY where the Division is located"
.. D ^DIR Q:$D(DIRUT) S IBCT=$$UP^XLFSTR(Y)
.. S IBNEW=$P(IBNEW," - ",1)_" - "_IBCT_", "_IBST W !!,IBNM," replaced with ",IBNEW
.. S DIE="^IBE(363.31,",DA=+IBFN,DR=".01///"_$E(IBNEW,1,30) D ^DIE K DIE,DR,X,Y
. ;
. ; add division to Billing Region, if not already there
. I +IBNDIVN,'$O(^IBE(363.31,+IBFN,11,"B",IBNDIVN,0)) D
.. S DLAYGO=363.31,DA(1)=+IBFN,DIC="^IBE(363.31,"_DA(1)_",11,",DIC(0)="L",X=+IBNDIVN,DIC("P")="363.3111P" D ^DIC K DIC,DIE,DLAYGO
;
; change Charge Set Names
S IBFN=0 F S IBFN=$O(^IBE(363.1,IBFN)) Q:'IBFN Q:IBFN'<1000 D
. S IBNM=$P($G(^IBE(363.1,IBFN,0)),U,1) I IBNM'[IBDIV Q
. I ($E(IBNM,1,3)'="RC-")!($E(IBNM,($L(IBNM)-$L(IBDIV)+1),999)'=IBDIV) Q
. ;
. S IBNEW=$P(IBNM,IBDIV,1)_IBNDIV_$P(IBNM,IBDIV,2)
. ;
. S DIE="^IBE(363.1,",DA=+IBFN,DR=".01///"_$E(IBNEW,1,30) D ^DIE K DIE,DR,X,Y
;
W " ... Done.",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCREE2 6146 printed Apr 09, 2024@21:25:54 Page 2
IBCREE2 ;ALB/ARH - RATES: CM ENTER/EDIT (SG,RL,PD,DV) ; 10-OCT-1998
+1 ;;2.0;INTEGRATED BILLING;**106,138,148**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EDITSG ; enter/edit special groups (363.32)
+1 NEW DIC,DIE,DA,DR,X,Y,DINUM,DLAYGO,IBX,IBSGFN
+2 WRITE !!,"Enter/Edit a Special Group: ",!
+3 ;
+4 SET DINUM=$ORDER(^IBE(363.32,"A"),-1)
SET DINUM=$SELECT(DINUM<1000:1001,1:DINUM+1)
IF 'DINUM!($DATA(^IBE(363.32,DINUM,0)))
QUIT
+5 SET DLAYGO=363.32
SET DIC="^IBE(363.32,"
SET DIC(0)="AELNQ"
DO ^DIC
KILL DIC,DINUM,DLAYGO
IF Y<1
KILL X,Y
QUIT
+6 ;
+7 SET IBSGFN=+Y
+8 ;
+9 SET DR=".01;.02;11"
SET DIE("NO^")="BACK"
+10 ;
+11 SET IBX=$$CHKSG^IBCREU1(+Y)
IF +IBX
SET DR="11"
WRITE !
Begin DoDot:1
+12 IF +$PIECE(IBX,U,2)
WRITE !,"This was exported Nationally, only the assigned Billing Rates may be edited."
+13 IF +$PIECE(IBX,U,3)
WRITE !,"This group has associated Revenue Code Links, can not edit Type."
+14 IF +$PIECE(IBX,U,4)
WRITE !,"This group has associated Provider Discount Links, can not edit Type."
+15 IF '$PIECE(IBX,U,2)
SET DR=".01;"_DR
End DoDot:1
WRITE !!
+16 ;
+17 SET DIDEL=363.32
SET DIE="^IBE(363.32,"
SET DA=+IBSGFN
DO ^DIE
KILL DIE,DA,DR,X,Y,DIDEL
+18 QUIT
+19 ;
EDITRL ; enter/edit revenue code links (363.33)
+1 NEW DIC,DIE,DA,DR,X,Y,DINUM,DLAYGO,IBX,IBRLFN
+2 WRITE !!,"Enter/Edit a Revenue Code Link: "
IF +$GET(IBSGFN)
WRITE " (for "_$PIECE(IBSGFN,U,2)_" group)",!
+3 ;
+4 IF '$GET(IBSGFN)
NEW IBSGFN
SET IBSGFN=$$GETSG^IBCRU1(1)
if IBSGFN'>0
QUIT
WRITE !!
+5 ;
+6 IF IBSGFN<1000
WRITE !,"This is a Nationally exported set of revenue code links.",!,"This should be modified only if the revenue code links added or changed",!,"fit the specific group definition: ",$PIECE(IBSGFN,U,2),".",!!
+7 ;
+8 SET DIC("S")="I $P(^(0),U,2)="_+IBSGFN
SET DIC("DR")=".02////"_+IBSGFN
SET DIC("A")="Select REVENUE CODE: "
+9 SET DLAYGO=363.33
SET DIC="^IBE(363.33,"
SET DIC(0)="AELNQ"
DO ^DIC
KILL DIC,DINUM,DLAYGO
IF Y<1
KILL X,Y
QUIT
+10 ;
+11 SET IBRLFN=+Y
+12 ;
+13 SET DR=".01;.03;.04"
+14 SET DIDEL=363.33
SET DIE="^IBE(363.33,"
SET DA=+IBRLFN
DO ^DIE
KILL DIE,DA,DR,X,Y,DIDEL
+15 ;
+16 ; reset cpt being displayed
SET IBX=$GET(^IBE(363.33,+IBRLFN,0))
SET IBCPT=$PIECE(IBX,U,3)
+17 QUIT
+18 ;
EDITPD ; enter/edit provider discount (363.34)
+1 NEW DIC,DIE,DA,DR,X,Y,DINUM,DLAYGO,IBX,IBPDFN
+2 WRITE !!,"Enter/Edit Provider Discount: "
IF +$GET(IBSGFN)
WRITE " (for "_$PIECE(IBSGFN,U,2)_" group)",!
+3 ;
+4 IF '$GET(IBSGFN)
SET IBSGFN=$$GETSG^IBCRU1(2)
if IBSGFN'>0
QUIT
+5 ;
+6 IF IBSGFN<1000
WRITE !!,"This is a Nationally exported set of Provider Discounts.",!,"This should be modified only if the provider discount added or changed",!,"fits the specific group definition: ",$PIECE(IBSGFN,U,2),".",!!
+7 ;
+8 SET DIC("S")="I $P(^(0),U,2)="_+IBSGFN
SET DIC("DR")=".02////"_+IBSGFN
+9 SET DLAYGO=363.34
SET DIC="^IBE(363.34,"
SET DIC(0)="AELNQ"
DO ^DIC
KILL DIC,DINUM,DLAYGO
IF Y<1
KILL X,Y
QUIT
+10 ;
+11 SET IBPDFN=+Y
IF $DATA(IBPDFNX)
SET IBPDFNX=+Y
+12 ;
+13 SET DR=".01;.03;11"
+14 SET DIDEL=363.34
SET DIE="^IBE(363.34,"
SET DA=+IBPDFN
DO ^DIE
KILL DIE,DA,DR,X,Y,DIDEL
+15 QUIT
+16 ;
RESETDV(NAME) ; Reset Division numbers in both Charge Sets and Billing Regions (input CS or RG name)
+1 ; not all division numbers were known when the Reasonable Charges files were released,
+2 ; if the division number was not known then nnnXn or 9nnnn was used as a place holder in CS and RG names
+3 ; this option allows the user to change these fake division numbers to the correct division number, when known
+4 ;
+5 NEW IBDIV,IBNDIV,IBFN,IBNM,IBNEW,IBI,IBX,DIC,DIE,DIR,DA,DR,DIRUT,DUOUT,DTOUT,X,Y,IBNDIVN,IBCT,IBST
SET IBNEW=""
+6 if $GET(NAME)=""
QUIT
IF $EXTRACT(NAME,1,3)'="RC "
IF $EXTRACT(NAME,1,3)'="RC-"
QUIT
+7 ;
+8 SET IBDIV=""
FOR IBI=1:1
SET IBX=$PIECE(NAME," ",IBI)
if IBX=""
QUIT
IF (IBX?3N1"X"1.3N)!(IBX>899.9)
SET IBDIV=IBX
QUIT
+9 IF IBDIV=""!(IBDIV=999)
QUIT
+10 ;
+11 WRITE !!,">>> "_IBDIV," is an invalid site number.",!
+12 SET DIR("?")=IBDIV_" is not a valid site number, if you know the correct number for this division you may change it now for all Billing Region and Charge Set names."
RESET1 SET DIR(0)="FO^3:7^I X'?3N,X'?3N1.4UN,'$O(^DG(40.8,""C"",X,0)) K X"
SET DIR("A")="Enter the correct Division number for this site if available"
DO ^DIR
if $DATA(DIRUT)
QUIT
IF Y=""
QUIT
+1 ;
+2 SET IBNDIV=Y
SET IBNDIVN=$ORDER(^DG(40.8,"C",IBNDIV,0))
+3 IF 'IBNDIVN
WRITE !!,?5,IBNDIV," is not a valid Medical Center division on your system.",!!
+4 ;
+5 SET IBI="RC "_IBNDIV
SET IBX=$ORDER(^IBE(363.31,"B",IBI))
IF IBI=$PIECE(IBX," ",1,2)
WRITE !!,IBX," already exists.",!
GOTO RESET1
+6 SET IBI="RC-PHYSICIAN "_IBNDIV
SET IBX=$ORDER(^IBE(363.1,"B",IBI,0))
IF +IBX
WRITE !!,IBI," already exists.",!
GOTO RESET1
+7 ;
+8 SET DIR(0)="YO"
SET DIR("A")="Replace "_IBDIV_" with "_IBNDIV
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
IF Y'=1
QUIT
+9 ;
+10 ; change Billing Region Names
+11 SET IBFN=0
FOR
SET IBFN=$ORDER(^IBE(363.31,IBFN))
if 'IBFN
QUIT
Begin DoDot:1
+12 SET IBNM=$PIECE($GET(^IBE(363.31,IBFN,0)),U,1)
IF IBNM'[IBDIV
QUIT
+13 IF ($EXTRACT(IBNM,1,3)'="RC ")!($PIECE(IBNM," ",2)'=IBDIV)
QUIT
+14 ;
+15 SET IBNEW=$PIECE(IBNM,IBDIV,1)_IBNDIV_$PIECE(IBNM,IBDIV,2)
+16 ;
+17 SET DIE="^IBE(363.31,"
SET DA=+IBFN
SET DR=".01///"_$EXTRACT(IBNEW,1,30)
DO ^DIE
KILL DIE,DR,X,Y
+18 ;
+19 ; check location of Billing Region, allow it to be updated if it does not appear to be standard
+20 IF $PIECE($PIECE(IBNEW," - ",2),", ",2)'?2U
Begin DoDot:2
+21 WRITE !!,">>> New Billing Region Name: ",IBNEW
+22 WRITE !,">>> The Billing Region location is not in the standard 'CITY, ST' format."
+23 WRITE !,">>> If you know the correct City, State for this division you may change it now.",!
+24 SET DIR(0)="PO^5:AEQMZ"
SET DIR("A")="Enter the STATE where the Division is located"
+25 DO ^DIR
if $DATA(DIRUT)
QUIT
SET IBST=$PIECE(Y(0),U,2)
+26 SET DIR(0)="FO^1:"_(30-$LENGTH($PIECE(IBNEW," - ",1))-7)
SET DIR("A")="Enter the CITY where the Division is located"
+27 DO ^DIR
if $DATA(DIRUT)
QUIT
SET IBCT=$$UP^XLFSTR(Y)
+28 SET IBNEW=$PIECE(IBNEW," - ",1)_" - "_IBCT_", "_IBST
WRITE !!,IBNM," replaced with ",IBNEW
+29 SET DIE="^IBE(363.31,"
SET DA=+IBFN
SET DR=".01///"_$EXTRACT(IBNEW,1,30)
DO ^DIE
KILL DIE,DR,X,Y
End DoDot:2
+30 ;
+31 ; add division to Billing Region, if not already there
+32 IF +IBNDIVN
IF '$ORDER(^IBE(363.31,+IBFN,11,"B",IBNDIVN,0))
Begin DoDot:2
+33 SET DLAYGO=363.31
SET DA(1)=+IBFN
SET DIC="^IBE(363.31,"_DA(1)_",11,"
SET DIC(0)="L"
SET X=+IBNDIVN
SET DIC("P")="363.3111P"
DO ^DIC
KILL DIC,DIE,DLAYGO
End DoDot:2
End DoDot:1
+34 ;
+35 ; change Charge Set Names
+36 SET IBFN=0
FOR
SET IBFN=$ORDER(^IBE(363.1,IBFN))
if 'IBFN
QUIT
if IBFN'<1000
QUIT
Begin DoDot:1
+37 SET IBNM=$PIECE($GET(^IBE(363.1,IBFN,0)),U,1)
IF IBNM'[IBDIV
QUIT
+38 IF ($EXTRACT(IBNM,1,3)'="RC-")!($EXTRACT(IBNM,($LENGTH(IBNM)-$LENGTH(IBDIV)+1),999)'=IBDIV)
QUIT
+39 ;
+40 SET IBNEW=$PIECE(IBNM,IBDIV,1)_IBNDIV_$PIECE(IBNM,IBDIV,2)
+41 ;
+42 SET DIE="^IBE(363.1,"
SET DA=+IBFN
SET DR=".01///"_$EXTRACT(IBNEW,1,30)
DO ^DIE
KILL DIE,DR,X,Y
End DoDot:1
+43 ;
+44 WRITE " ... Done.",!
+45 QUIT
