IBEBR ;ALB/AAS - Add/Edit IB ACTION CHARGE FILE ;3-MAR-92
;;2.0;INTEGRATED BILLING;**34,52,429,524,563**;21-MAR-94;Build 12
;;Per VA Directive 6402, this routine should not be modified.
;
% ; entry point
D HOME^%ZIS W @IOF
EN W !!,?28,"Enter/Edit Billing Rates",!!
S IBX="MAIN" D CHOOSE I $D(DIRUT)!('Y) G END
I Y>0,Y<7 D @Y
G EN
Q
1 ;enter edit revenue code rates
;D EN1^IBCBR
;D ENR^IBEMTO ; bill MT OPT charges awaiting the new copay rate
;D END
W !!," ******* This option is no longer active.",!,?10,"Please use the Enter/Edit Charge Master option.",!
Q
;
2 ;enter per diem rate
S IBX="PERDIEM" D CHOOSE Q:$D(DIRUT)
D EFFDT,END
G 2
;
3 ;enter medicare deductable
S IBX="MEDIC",IBPD="MEDICARE DEDUCTIBLE" ;D CHOOSE Q:$D(DIRUT)
D EFFDT,END Q:$G(Y)<1
G 3
;
4 ;enter hcfa amb. surg. rates
S IBX="HCFA" D CHOOSE Q:$D(DIRUT)
D EFFDT,END
G 4
;
5 ;enter rx copay rates
N IBTIER
S IBX="COPAY" D CHOOSE Q:$D(DIRUT)
S IBTIER=$$TIER Q:$D(DIRUT)
D EFFDT,END
G 5
;
6 ;enter champva subsistence rates
S IBX="CHMPVA" D CHOOSE Q:$D(DIRUT)
D EFFDT,END
G 6
;
CHOOSE S IBSEL=$P($T(@IBX),";;",2,99),IB=""
F I=1:1 Q:$P($T(@IBX+I),";;",2,99)="" S IB=IB_I_":"_$P($P($T(@IBX+I),";;",2,99),"^",$S($P($P($T(@IBX+1),";;",2,99),"^",5)="":1,1:5))_";"
W !!,"CHOOSE FROM:"
F I=1:1 S X=$P(IB,";",I) Q:'X W !?4,+X,?20,$P(X,":",2)
S DIR("?")="^D 1^IBEBRH",DIR("??")="^D 2^IBEBRH"
W !! S DIR(0)="SOA^"_IB,DIR("A")="Select "_IBSEL_": " D ^DIR K DIR I $D(DIRUT) G CHOOSEQ
S IBP=$P($T(@IBX+Y),";;",2,99) S IBPD=$P(IBP,"^",1) F I=2:1 Q:$P(IBP,"^",I)="" S IBPD(I)=$P(IBP,"^",I)
CHOOSEQ Q
;
EFFDT S %DT="EX"
R !!," Select Effective Date: ",X:DTIME Q:X="" D:X["?" 3^IBEBRH I X=" ",$D(IBEFDT) S X=IBEFDT
D ^%DT K %DT G:X["?" EFFDT Q:Y<1 S IBEFDT=+Y
D FILE G EFFDT
Q
;
FILE ; -add new entries in 350.2 and edit
S DLAYGO=350.2,X=IBPD,DIC="^IBE(350.2,",DIC(0)="ELMQ",DIC("S")=$S($G(IBTIER):"I $P(^(0),U,2)=IBEFDT,$P(^(0),U,7)=IBTIER",1:"I $P(^(0),U,2)=IBEFDT"),DIC("DR")=".02///"_IBEFDT D ^DIC K DIC G:+Y<0 FILEQ
;
; -if a new entry
S IBNEW=$P(Y,"^",3)
K DR S DR="" S IBORIG=$O(^IBE(350.2,"B",IBPD,0)),IBLAST=$O(^IBE(350.2,"B",IBPD,+Y),-1) I IBNEW S DR=".02///"_IBEFDT_";.03///"_$P($G(^IBE(350.2,+IBORIG,0)),"^",3)_";" S:$G(IBTIER) DR=DR_".07///"_IBTIER_";"
;
S DIE="^IBE(350.2,",DA=+Y,DR=DR_".04;.06;.05;" D ^DIE K DIE
;
; -delete if no charge or not inactive
S X=$G(^IBE(350.2,DA,0)) I '$P(X,"^",4)&('$P(X,"^",5)) W !!,*7,"Deleting - no charge, not inactive" S DIK="^IBE(350.2," D ^DIK Q
;
; -set computed logic for new entry if needed
S IB10=$G(^IBE(350.2,+IBORIG,10)) I IB10]"" S ^IBE(350.2,DA,10)=IB10
; -set additional amount logic if needed (from last one)
S IB20=$G(^IBE(350.2,+IBLAST,20)) I IB20]"" S ^IBE(350.2,DA,20)=IB20
;
; -logic for rx3-rx6
S IB=0,IB0=$G(^IBE(350.2,DA,0)) F S IB=$O(IBPD(IB)) Q:'IB D
. S IBORIG=$O(^IBE(350.2,"B",IBPD(IB),0)),IBATYP=+$P($G(^IBE(350.2,+IBORIG,0)),"^",3)
. I 'IBNEW S DA=$O(^IBE(350.2,"AIVDT",IBATYP,-IBEFDT,0)) Q:'DA
. I IBNEW S X=IBPD(IB),DIC="^IBE(350.2,",DIC(0)="L" K DD,DO D FILE^DICN Q:Y<0 S DA=+Y
. S DIE="^IBE(350.2,",DR=".02////"_IBEFDT_";.03////"_IBATYP_";.04////"_$P(IB0,"^",4)_";.05////"_$S($P(IB0,"^",5)]"":$P(IB0,"^",5),1:"@")_";.06////"_$S($P(IB0,"^",6)]"":$P(IB0,"^",6),1:"@")_";.07////"_IBTIER D ^DIE
. I IB20]"" S ^IBE(350.2,DA,20)=IB20
;
FILEQ K IB10,DIC,DIE,DR,DA,IBNEW,IBORIG,DIK Q
;
TIER() ; -for Rx rates, prompt for tier
N DIR
S DIR(0)="350.2,.07" D ^DIR
Q +Y
END ;Kill vars
K I,X,Y,IBNOD,IBPD,DIR,DIC,DIE,DIK,DA,DR,DA,IB10,IBORIG,IB,IB0,IBP,IBEFDT,IBSEL,IBX,IBRUN,IB20,IBLAST,IBTIER
Q
;
;;
COPAY ;;Co-pay Type
NSC ;;RX1^RX3^RX4^^NSC RX CO-PAY (RX1)
SC ;;RX2^RX5^RX6^^SC RX CO-PAY (RX2)
FSNSC ;;FEE SERV RX1^FEE SERV RX3^FEE SERV RX4^^FEE SERV NSC RX CO-PAY (RX1)
;;
PERDIEM ;;Per Diem
;;INPT PER DIEM
;;NHCU PER DIEM
;;FEE SERV INPT PER DIEM
;;
HCFA ;;HCFA Amb. Surg. Rate
;;MEDICARE 1^^^^AMB SURG RATE 1
;;MEDICARE 2^^^^AMB SURG RATE 2
;;MEDICARE 3^^^^AMB SURG RATE 3
;;MEDICARE 4^^^^AMB SURG RATE 4
;;MEDICARE 5^^^^AMB SURG RATE 5
;;MEDICARE 6^^^^AMB SURG RATE 6
;;MEDICARE 7^^^^AMB SURG RATE 7
;;MEDICARE 8^^^^AMB SURG RATE 8
;;MEDICARE 9^^^^AMB SURG RATE 9
;;
CHMPVA ;;CHAMPVA Rate Type
;;CHAMPVA PER DIEM
;;CHAMPVA SUBSISTENCE LIMIT
;;
MEDIC ;;Medicare Deductible
;;MEDICARE DEDUCTIBLE
;;
MAIN ;;Billing Rate Type
;;REVENUE CODE RATES
;;PER DIEM RATES
;;MEDICARE DEDUCTIBLE
;;HCFA AMB. SURG. RATES
;;RX CO-PAYMENT
;;CHAMPVA SUBSISTENCE RATES
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBEBR 4630 printed Nov 22, 2024@17:31:11 Page 2
IBEBR ;ALB/AAS - Add/Edit IB ACTION CHARGE FILE ;3-MAR-92
+1 ;;2.0;INTEGRATED BILLING;**34,52,429,524,563**;21-MAR-94;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
% ; entry point
+1 DO HOME^%ZIS
WRITE @IOF
EN WRITE !!,?28,"Enter/Edit Billing Rates",!!
+1 SET IBX="MAIN"
DO CHOOSE
IF $DATA(DIRUT)!('Y)
GOTO END
+2 IF Y>0
IF Y<7
DO @Y
+3 GOTO EN
+4 QUIT
1 ;enter edit revenue code rates
+1 ;D EN1^IBCBR
+2 ;D ENR^IBEMTO ; bill MT OPT charges awaiting the new copay rate
+3 ;D END
+4 WRITE !!," ******* This option is no longer active.",!,?10,"Please use the Enter/Edit Charge Master option.",!
+5 QUIT
+6 ;
2 ;enter per diem rate
+1 SET IBX="PERDIEM"
DO CHOOSE
if $DATA(DIRUT)
QUIT
+2 DO EFFDT
DO END
+3 GOTO 2
+4 ;
3 ;enter medicare deductable
+1 ;D CHOOSE Q:$D(DIRUT)
SET IBX="MEDIC"
SET IBPD="MEDICARE DEDUCTIBLE"
+2 DO EFFDT
DO END
if $GET(Y)<1
QUIT
+3 GOTO 3
+4 ;
4 ;enter hcfa amb. surg. rates
+1 SET IBX="HCFA"
DO CHOOSE
if $DATA(DIRUT)
QUIT
+2 DO EFFDT
DO END
+3 GOTO 4
+4 ;
5 ;enter rx copay rates
+1 NEW IBTIER
+2 SET IBX="COPAY"
DO CHOOSE
if $DATA(DIRUT)
QUIT
+3 SET IBTIER=$$TIER
if $DATA(DIRUT)
QUIT
+4 DO EFFDT
DO END
+5 GOTO 5
+6 ;
6 ;enter champva subsistence rates
+1 SET IBX="CHMPVA"
DO CHOOSE
if $DATA(DIRUT)
QUIT
+2 DO EFFDT
DO END
+3 GOTO 6
+4 ;
CHOOSE SET IBSEL=$PIECE($TEXT(@IBX),";;",2,99)
SET IB=""
+1 FOR I=1:1
if $PIECE($TEXT(@IBX+I),";;",2,99)=""
QUIT
SET IB=IB_I_":"_$PIECE($PIECE($TEXT(@IBX+I),";;",2,99),"^",$SELECT($PIECE($PIECE($TEXT(@IBX+1),";;",2,99),"^",5)="":1,1:5))_";"
+2 WRITE !!,"CHOOSE FROM:"
+3 FOR I=1:1
SET X=$PIECE(IB,";",I)
if 'X
QUIT
WRITE !?4,+X,?20,$PIECE(X,":",2)
+4 SET DIR("?")="^D 1^IBEBRH"
SET DIR("??")="^D 2^IBEBRH"
+5 WRITE !!
SET DIR(0)="SOA^"_IB
SET DIR("A")="Select "_IBSEL_": "
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO CHOOSEQ
+6 SET IBP=$PIECE($TEXT(@IBX+Y),";;",2,99)
SET IBPD=$PIECE(IBP,"^",1)
FOR I=2:1
if $PIECE(IBP,"^",I)=""
QUIT
SET IBPD(I)=$PIECE(IBP,"^",I)
CHOOSEQ QUIT
+1 ;
EFFDT SET %DT="EX"
+1 READ !!," Select Effective Date: ",X:DTIME
if X=""
QUIT
if X["?"
DO 3^IBEBRH
IF X=" "
IF $DATA(IBEFDT)
SET X=IBEFDT
+2 DO ^%DT
KILL %DT
if X["?"
GOTO EFFDT
if Y<1
QUIT
SET IBEFDT=+Y
+3 DO FILE
GOTO EFFDT
+4 QUIT
+5 ;
FILE ; -add new entries in 350.2 and edit
+1 SET DLAYGO=350.2
SET X=IBPD
SET DIC="^IBE(350.2,"
SET DIC(0)="ELMQ"
SET DIC("S")=$SELECT($GET(IBTIER):"I $P(^(0),U,2)=IBEFDT,$P(^(0),U,7)=IBTIER",1:"I $P(^(0),U,2)=IBEFDT")
SET DIC("DR")=".02///"_IBEFDT
DO ^DIC
KILL DIC
if +Y<0
GOTO FILEQ
+2 ;
+3 ; -if a new entry
+4 SET IBNEW=$PIECE(Y,"^",3)
+5 KILL DR
SET DR=""
SET IBORIG=$ORDER(^IBE(350.2,"B",IBPD,0))
SET IBLAST=$ORDER(^IBE(350.2,"B",IBPD,+Y),-1)
IF IBNEW
SET DR=".02///"_IBEFDT_";.03///"_$PIECE($GET(^IBE(350.2,+IBORIG,0)),"^",3)_";"
if $GET(IBTIER)
SET DR=DR_".07///"_IBTIER_";"
+6 ;
+7 SET DIE="^IBE(350.2,"
SET DA=+Y
SET DR=DR_".04;.06;.05;"
DO ^DIE
KILL DIE
+8 ;
+9 ; -delete if no charge or not inactive
+10 SET X=$GET(^IBE(350.2,DA,0))
IF '$PIECE(X,"^",4)&('$PIECE(X,"^",5))
WRITE !!,*7,"Deleting - no charge, not inactive"
SET DIK="^IBE(350.2,"
DO ^DIK
QUIT
+11 ;
+12 ; -set computed logic for new entry if needed
+13 SET IB10=$GET(^IBE(350.2,+IBORIG,10))
IF IB10]""
SET ^IBE(350.2,DA,10)=IB10
+14 ; -set additional amount logic if needed (from last one)
+15 SET IB20=$GET(^IBE(350.2,+IBLAST,20))
IF IB20]""
SET ^IBE(350.2,DA,20)=IB20
+16 ;
+17 ; -logic for rx3-rx6
+18 SET IB=0
SET IB0=$GET(^IBE(350.2,DA,0))
FOR
SET IB=$ORDER(IBPD(IB))
if 'IB
QUIT
Begin DoDot:1
+19 SET IBORIG=$ORDER(^IBE(350.2,"B",IBPD(IB),0))
SET IBATYP=+$PIECE($GET(^IBE(350.2,+IBORIG,0)),"^",3)
+20 IF 'IBNEW
SET DA=$ORDER(^IBE(350.2,"AIVDT",IBATYP,-IBEFDT,0))
if 'DA
QUIT
+21 IF IBNEW
SET X=IBPD(IB)
SET DIC="^IBE(350.2,"
SET DIC(0)="L"
KILL DD,DO
DO FILE^DICN
if Y<0
QUIT
SET DA=+Y
+22 SET DIE="^IBE(350.2,"
SET DR=".02////"_IBEFDT_";.03////"_IBATYP_";.04////"_$PIECE(IB0,"^",4)_";.05////"_$SELECT($PIECE(IB0,"^",5)]"":$PIECE(IB0,"^",5),1:"@")_";.06////"_$SELECT($PIECE(IB0,"^",6)]"":$PIECE(IB0,"^",6),1:"@")_";.07////"_IBTIER
DO ^DIE
+23 IF IB20]""
SET ^IBE(350.2,DA,20)=IB20
End DoDot:1
+24 ;
FILEQ KILL IB10,DIC,DIE,DR,DA,IBNEW,IBORIG,DIK
QUIT
+1 ;
TIER() ; -for Rx rates, prompt for tier
+1 NEW DIR
+2 SET DIR(0)="350.2,.07"
DO ^DIR
+3 QUIT +Y
END ;Kill vars
+1 KILL I,X,Y,IBNOD,IBPD,DIR,DIC,DIE,DIK,DA,DR,DA,IB10,IBORIG,IB,IB0,IBP,IBEFDT,IBSEL,IBX,IBRUN,IB20,IBLAST,IBTIER
+2 QUIT
+3 ;
+4 ;;
COPAY ;;Co-pay Type
NSC ;;RX1^RX3^RX4^^NSC RX CO-PAY (RX1)
SC ;;RX2^RX5^RX6^^SC RX CO-PAY (RX2)
FSNSC ;;FEE SERV RX1^FEE SERV RX3^FEE SERV RX4^^FEE SERV NSC RX CO-PAY (RX1)
+1 ;;
PERDIEM ;;Per Diem
+1 ;;INPT PER DIEM
+2 ;;NHCU PER DIEM
+3 ;;FEE SERV INPT PER DIEM
+4 ;;
HCFA ;;HCFA Amb. Surg. Rate
+1 ;;MEDICARE 1^^^^AMB SURG RATE 1
+2 ;;MEDICARE 2^^^^AMB SURG RATE 2
+3 ;;MEDICARE 3^^^^AMB SURG RATE 3
+4 ;;MEDICARE 4^^^^AMB SURG RATE 4
+5 ;;MEDICARE 5^^^^AMB SURG RATE 5
+6 ;;MEDICARE 6^^^^AMB SURG RATE 6
+7 ;;MEDICARE 7^^^^AMB SURG RATE 7
+8 ;;MEDICARE 8^^^^AMB SURG RATE 8
+9 ;;MEDICARE 9^^^^AMB SURG RATE 9
+10 ;;
CHMPVA ;;CHAMPVA Rate Type
+1 ;;CHAMPVA PER DIEM
+2 ;;CHAMPVA SUBSISTENCE LIMIT
+3 ;;
MEDIC ;;Medicare Deductible
+1 ;;MEDICARE DEDUCTIBLE
+2 ;;
MAIN ;;Billing Rate Type
+1 ;;REVENUE CODE RATES
+2 ;;PER DIEM RATES
+3 ;;MEDICARE DEDUCTIBLE
+4 ;;HCFA AMB. SURG. RATES
+5 ;;RX CO-PAYMENT
+6 ;;CHAMPVA SUBSISTENCE RATES
