Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBEBR

IBEBR.m

Go to the documentation of this file. 
  1. 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
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1. % ; entry point
  1.  D HOME^%ZIS W @IOF
  1. EN W !!,?28,"Enter/Edit Billing Rates",!!
  1.  S IBX="MAIN" D CHOOSE I $D(DIRUT)!('Y) G END
  1.  I Y>0,Y<7 D @Y
  1.  G EN
  1.  Q
  1. 1 ;enter edit revenue code rates
  1.  ;D EN1^IBCBR
  1.  ;D ENR^IBEMTO ; bill MT OPT charges awaiting the new copay rate
  1.  ;D END
  1.  W !!,"  ******* This option is no longer active.",!,?10,"Please use the Enter/Edit Charge Master option.",!
  1.  Q
  1.  ;
  1. 2 ;enter per diem rate
  1.  S IBX="PERDIEM" D CHOOSE Q:$D(DIRUT)
  1.  D EFFDT,END
  1.  G 2
  1.  ;
  1. 3 ;enter medicare deductable
  1.  S IBX="MEDIC",IBPD="MEDICARE DEDUCTIBLE" ;D CHOOSE Q:$D(DIRUT)
  1.  D EFFDT,END Q:$G(Y)<1
  1.  G 3
  1.  ;
  1. 4 ;enter hcfa amb. surg. rates
  1.  S IBX="HCFA" D CHOOSE Q:$D(DIRUT)
  1.  D EFFDT,END
  1.  G 4
  1.  ;
  1. 5 ;enter rx copay rates
  1.  N IBTIER
  1.  S IBX="COPAY" D CHOOSE Q:$D(DIRUT)
  1.  S IBTIER=$$TIER Q:$D(DIRUT)
  1.  D EFFDT,END
  1.  G 5
  1.  ;
  1. 6 ;enter champva subsistence rates
  1.  S IBX="CHMPVA" D CHOOSE Q:$D(DIRUT)
  1.  D EFFDT,END
  1.  G 6
  1.  ;
  1. CHOOSE S IBSEL=$P($T(@IBX),";;",2,99),IB=""
  1.  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))_";"
  1.  W !!,"CHOOSE FROM:"
  1.  F I=1:1 S X=$P(IB,";",I) Q:'X  W !?4,+X,?20,$P(X,":",2)
  1.  S DIR("?")="^D 1^IBEBRH",DIR("??")="^D 2^IBEBRH"
  1.  W !! S DIR(0)="SOA^"_IB,DIR("A")="Select "_IBSEL_": " D ^DIR K DIR I $D(DIRUT) G CHOOSEQ
  1.  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)
  1. CHOOSEQ Q
  1.  ;
  1. EFFDT S %DT="EX"
  1.  R !!,"   Select Effective Date: ",X:DTIME Q:X=""  D:X["?" 3^IBEBRH I X=" ",$D(IBEFDT) S X=IBEFDT
  1.  D ^%DT K %DT G:X["?" EFFDT Q:Y<1  S IBEFDT=+Y
  1.  D FILE G EFFDT
  1.  Q
  1.  ;
  1. FILE ;  -add new entries in 350.2 and edit
  1.  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
  1.  ;
  1.  ;  -if a new entry
  1.  S IBNEW=$P(Y,"^",3)
  1.  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_";"
  1.  ;
  1.  S DIE="^IBE(350.2,",DA=+Y,DR=DR_".04;.06;.05;" D ^DIE K DIE
  1.  ;
  1.  ;  -delete if no charge or not inactive
  1.  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
  1.  ;
  1.  ;  -set computed logic for new entry if needed
  1.  S IB10=$G(^IBE(350.2,+IBORIG,10)) I IB10]"" S ^IBE(350.2,DA,10)=IB10
  1.  ;  -set additional amount logic if needed (from last one)
  1.  S IB20=$G(^IBE(350.2,+IBLAST,20)) I IB20]"" S ^IBE(350.2,DA,20)=IB20
  1.  ;
  1.  ;  -logic for rx3-rx6
  1.  S IB=0,IB0=$G(^IBE(350.2,DA,0)) F  S IB=$O(IBPD(IB)) Q:'IB  D
  1.  . S IBORIG=$O(^IBE(350.2,"B",IBPD(IB),0)),IBATYP=+$P($G(^IBE(350.2,+IBORIG,0)),"^",3)
  1.  . I 'IBNEW S DA=$O(^IBE(350.2,"AIVDT",IBATYP,-IBEFDT,0)) Q:'DA
  1.  . 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
  1.  . 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
  1.  . I IB20]"" S ^IBE(350.2,DA,20)=IB20
  1.  ;
  1. FILEQ K IB10,DIC,DIE,DR,DA,IBNEW,IBORIG,DIK Q
  1.  ;
  1. TIER() ; -for Rx rates, prompt for tier
  1.  N DIR
  1.  S DIR(0)="350.2,.07" D ^DIR
  1.  Q +Y
  1. END ;Kill vars
  1.  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
  1.  Q
  1.  ;
  1.  ;;
  1. COPAY ;;Co-pay Type
  1. NSC ;;RX1^RX3^RX4^^NSC RX CO-PAY (RX1)
  1. SC ;;RX2^RX5^RX6^^SC RX CO-PAY (RX2)
  1. FSNSC ;;FEE SERV RX1^FEE SERV RX3^FEE SERV RX4^^FEE SERV NSC RX CO-PAY (RX1)
  1.  ;;
  1. PERDIEM ;;Per Diem
  1.  ;;INPT PER DIEM
  1.  ;;NHCU PER DIEM
  1.  ;;FEE SERV INPT PER DIEM
  1.  ;;
  1. HCFA ;;HCFA Amb. Surg. Rate
  1.  ;;MEDICARE 1^^^^AMB SURG RATE 1
  1.  ;;MEDICARE 2^^^^AMB SURG RATE 2
  1.  ;;MEDICARE 3^^^^AMB SURG RATE 3
  1.  ;;MEDICARE 4^^^^AMB SURG RATE 4
  1.  ;;MEDICARE 5^^^^AMB SURG RATE 5
  1.  ;;MEDICARE 6^^^^AMB SURG RATE 6
  1.  ;;MEDICARE 7^^^^AMB SURG RATE 7
  1.  ;;MEDICARE 8^^^^AMB SURG RATE 8
  1.  ;;MEDICARE 9^^^^AMB SURG RATE 9
  1.  ;;
  1. CHMPVA ;;CHAMPVA Rate Type
  1.  ;;CHAMPVA PER DIEM
  1.  ;;CHAMPVA SUBSISTENCE LIMIT
  1.  ;;
  1. MEDIC ;;Medicare Deductible
  1.  ;;MEDICARE DEDUCTIBLE
  1.  ;;
  1. MAIN ;;Billing Rate Type
  1.  ;;REVENUE CODE RATES
  1.  ;;PER DIEM RATES
  1.  ;;MEDICARE DEDUCTIBLE
  1.  ;;HCFA AMB. SURG. RATES
  1.  ;;RX CO-PAYMENT
  1.  ;;CHAMPVA SUBSISTENCE RATES