IBEBR ;ALB/AAS - Add/Edit IB ACTION CHARGE FILE; 3-MAR-92
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, 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 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
S IBX="COPAY" D CHOOSE 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")="I $P(^(0),U,2)=IBEFDT",DIC("DR")=".02///"_IBEFDT D ^DIC K DIC G:+Y<0 FILEQ
;
; -if a new entry
K DR S DR="" S IBORIG=$O(^IBE(350.2,"B",IBPD,0)) I $P(Y,"^",3) S DR=".02///"_IBEFDT_";.03///"_$P($G(^IBE(350.2,+IBORIG,0)),"^",3)_";"
;
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
;
; -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)
. S X=IBPD(IB),DIC="^IBE(350.2,",DIC(0)="L" K DD,DO D FILE^DICN Q:'Y S DA=+Y
. S DIE="^IBE(350.2,",DR=".02////"_IBEFDT_";.03////"_IBATYP_";.04////"_$P(IB0,"^",4)_";.05////"_$P(IB0,"^",5)_";.06////"_$P(IB0,"^",6) D ^DIE
;
FILEQ K IB10,DIC,DIE,DR,DA,IBORIG,DIK Q
;
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
Q
;
;;
COPAY ;;Co-pay Type
NSC ;;RX1^RX3^RX4^^NSC RX CO-PAY (RX1)
SC ;;RX2^RX5^RX6^^SC RX CO-PAY (RX2)
;;
PERDIEM ;;Per Diem
;;INPT PER DIEM
;;NHCU 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
IBEBR ;ALB/AAS - Add/Edit IB ACTION CHARGE FILE; 3-MAR-92
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, 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 DO EN1^IBCBR
+2 ; bill MT OPT charges awaiting the new copay rate
DO ENR^IBEMTO
+3 DO END
QUIT
+4 ;
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 SET IBX="COPAY"
DO CHOOSE
IF $DATA(DIRUT)
QUIT
+2 DO EFFDT
DO END
+3 GOTO 5
+4 ;
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")="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 KILL DR
SET DR=""
SET IBORIG=$ORDER(^IBE(350.2,"B",IBPD,0))
IF $PIECE(Y,"^",3)
SET DR=".02///"_IBEFDT_";.03///"_$PIECE($GET(^IBE(350.2,+IBORIG,0)),"^",3)_";"
+5 ;
+6 SET DIE="^IBE(350.2,"
SET DA=+Y
SET DR=DR_".04;.06;.05;"
DO ^DIE
KILL DIE
+7 ;
+8 ; -delete if no charge or not inactive
+9 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
+10 ;
+11 ; -set computed logic for new entry if needed
+12 SET IB10=$GET(^IBE(350.2,+IBORIG,10))
IF IB10]""
SET ^IBE(350.2,DA,10)=IB10
+13 ;
+14 ; -logic for rx3-rx6
+15 SET IB=0
SET IB0=$GET(^IBE(350.2,DA,0))
FOR
SET IB=$ORDER(IBPD(IB))
IF 'IB
QUIT
Begin DoDot:1
+16 SET IBORIG=$ORDER(^IBE(350.2,"B",IBPD(IB),0))
SET IBATYP=$PIECE($GET(^IBE(350.2,+IBORIG,0)),"^",3)
+17 SET X=IBPD(IB)
SET DIC="^IBE(350.2,"
SET DIC(0)="L"
KILL DD,DO
DO FILE^DICN
IF 'Y
QUIT
SET DA=+Y
+18 SET DIE="^IBE(350.2,"
SET DR=".02////"_IBEFDT_";.03////"_IBATYP_";.04////"_$PIECE(IB0,"^",4)_";.05////"_$PIECE(IB0,"^",5)_";.06////"_$PIECE(IB0,"^",6)
DO ^DIE
End DoDot:1
+19 ;
FILEQ KILL IB10,DIC,DIE,DR,DA,IBORIG,DIK
QUIT
+1 ;
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
+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)
+1 ;;
PERDIEM ;;Per Diem
+1 ;;INPT PER DIEM
+2 ;;NHCU PER DIEM
+3 ;;
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
