IBEBR.m

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