IBCRETP ;LL/ELZ - RATES: TRANSFER PRICING CM FAST ENTER/EDIT ; 24-AUG-1999
;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
ENTER ; OPTION: Transfer Pricing rates fast enter - this requires billing
; rate names are not changed. Will set up charge sets if not defined.
;
N DIR,DIRUT,DTOUT,DUOUT,X,Y,IBARR,IBRATE,IBEFDT,IBRVCD,IBCS,IBA
W @IOF W !!,?10,"Fast Enter of Transfer Pricing Rates",!!
;
S DIR(0)="SO^I:Inpatient;O:Outpatient",DIR("A")="Enter which rates" D ^DIR K DIR
S IBRATE=$S(Y="I":"1^TP INPATIENT",Y="O":"2^TP OUTPATIENT",1:"") Q:'IBRATE
;
S IBEFDT=$$GETDT^IBCRU1() I IBEFDT'?7N Q
;
S IBCS=$$FAC(IBRATE)
D EDITCI(IBCS,IBEFDT)
Q
;
FAC(TYPE) ; ask facility, create charge sets and billing region if not defined, return chargeset
N DIC,X,Y,DTOUT,DUOUT,IBFAC,IBCS,IBRG
;
S DIC="^DIC(4,",DIC(0)="AEMNQ" D ^DIC Q:Y<1 0 S IBFAC=Y
;
S IBCS=$$TPCS^IBCRU7(TYPE,+IBFAC) Q:IBCS IBCS
;
; add billing region and charge set to charge master
S IBRG=$$RG(IBFAC) Q:'IBRG 0
S IBCS=$$ACS(TYPE,IBRG,IBFAC)
Q IBCS
;
RG(INST) ; add a new Billing Region for Transfer pricing (363.31)
; input institution 0 by ref and institution pointer
; returns billing region IFN ^ name
N IBNAME,IBRG,X,Y,DLAYGO,DIC,DA,DTOUT,DUOUT,MSG,D0
I $G(INST)="" Q 0
;
F X=0,1,3,99 S INST(X)=$G(^DIC(4,+INST,X))
S IBNAME=$$NNT^XUAF4(+INST)
S IBNAME="TP "_$S($P(IBNAME,"^",3)="VISN":$P(IBNAME,"^"),1:$P(INST(99),"^")_" "_$P(INST(1),"^",3))_$S($P(INST(0),"^",2)&($P(IBNAME,"^",3)'="VISN"):", "_$P($G(^DIC(5,$P(INST(0),"^",2),0)),"^",2),1:"")
S IBRG=$O(^IBE(363.31,"B",IBNAME,0)) I IBRG Q IBRG_"^"_IBNAME
;
K D0 S DLAYGO=363.31,DIC="^IBE(363.31,",DIC(0)="L",X=$E(IBNAME,1,30) D FILE^DICN I Y<1 Q 0
S IBRG=Y D MSG(" Added Billing Region "_$P(IBRG,"^",2))
;
K DA S DIC(0)="L",DA(1)=+IBRG,DIC=DIC_DA(1)_",21,",X=+INST D FILE^DICN
D MSG(" with"_$S(Y>0:"",1:"OUT")_" Institution "_$P(INST(0),"^"))
;
D MSGP Q IBRG
;
ACS(RATE,RG,FAC) ; find or add charge set
; returns IFN of new charge set, 0 otherwise, input is in internal^external format
N IBOK,IBNAME,IBEVENT,IBFN,IBBR,IBBE,IBJ,DD,DO,DLAYDO,DINUM,DIC,DA,X,Y,DR,DIE,IBA,IBCSN,MSG S IBOK=1
S RATE=$G(RATE),RG=$G(RG),FAC=$G(FAC) I RATE="" G ACSQ
;
S IBNAME="TP-"_$S((+RATE)=1:"INPT ",1:"OPT ")_$S($E($P(FAC,"^",2),1,5)="VISN ":$P(FAC,"^",2),1:+FAC)
S IBEVENT=$S(RATE[" I":"INPATIENT DRG",1:"PROCEDURE")
S IBFN=$O(^IBE(363.1,"B",$E(IBNAME,1,30),0)) I +IBFN S IBOK=0 D MSG(" *** Charge Set "_$E(IBNAME,1,30)_" found")
S IBBR=$O(^IBE(363.3,"B",$P(RATE,"^",2),0)) I 'IBBR S IBOK=0 D MSG(" *** Error: "_RATE_" Billing Rate does not exist")
S IBBE=$$MCCRUTL(IBEVENT,14) I 'IBBE S IBOK=0 D MSG(" *** Error: "_IBEVENT_" Billable Event undefined")
I '$D(^IBE(363.3,+RG)) S IBOK=0 D MSG(" *** Error: "_$P($E(RG,1,30),"^",2)_" Billing Region does not exist")
I '$G(IBOK) G ACSQ
;
F IBJ=1:1 S IBFN=$G(^IBE(363.1,IBJ,0)) I IBFN="" S DINUM=IBJ Q
;
K DD,DO S DLAYGO=363.1,DIC="^IBE(363.1,",DIC(0)="L",X=$E(IBNAME,1,30) D FILE^DICN K DIC K DIC,DINUM,DLAYGO I Y<1 K X,Y Q
S IBFN=+Y,IBCSN=$P(Y,U,2)
;
S DR=".02////"_IBBR_";.03////"_IBBE_";.07////"_(+RG)
S DIE="^IBE(363.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
S IBA(1)=" "_$E(IBNAME,1,30)_" Charge Set "_$S('$G(IBFN):"NOT ",1:"")_"added"
;
ACSQ D MSGP
Q +$G(IBFN)
;
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
N IBX,IBY S IBY=""
I $G(X)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"B",X,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX
Q IBY
;
MSG(X) ; add message to end of message list, reserves IBA(1) for primary message
N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
S IBA(IBX)=$G(X)
Q
MSGP ; print error messages in IBA
N IBX S IBX="" F S IBX=$O(IBA(IBX)) Q:'IBX W !,IBA(IBX)
Q
;
EDITCI(IBCSFN,IBDT) ; Enter/Edit Charge Items
N IBCS0,IBBR0,IBBRFN,IBITEM,IBBRBI,IBCIFN,IBX,DIE,DR,DA,X,Y
;
CS I '$G(IBCSFN) S IBCSFN=+$$GETCS^IBCRU1 Q:IBCSFN'>0
D DISPCS^IBCRU7(+IBCSFN)
;
S IBCS0=$G(^IBE(363.1,+IBCSFN,0)),IBBRFN=$P(IBCS0,U,2)
S IBBR0=$G(^IBE(363.3,+IBBRFN,0)),IBBRBI=$P(IBBR0,U,4)
W !!,"Enter/edit a billable item (",$$BITM(IBBRBI),") for Charge Set ",$P(IBCS0,U,1)
;
CI W ! S IBITEM=$$GETITEM^IBCRU1(IBCSFN,"",1) I +IBITEM<1 Q
I '$$ITFILE^IBCRU2(IBBRBI,+IBITEM) W !!,$$BITM(IBBRBI)," ",$P(IBITEM,U,2)," CURRENTLY INACTIVE",!
;
EF D DISPCI^IBCRU5(+IBCSFN,+IBITEM)
I IBDT<1 S IBDT="" W " ... no change" G CI
D SCRNDSPL
;
S IBCIFN=$$FINDCI(+IBCSFN,+IBITEM,IBDT) I IBCIFN<0 G EF
;
I IBCIFN>0 W !,?50,"Editing Charge Item!"
;
I 'IBCIFN D I 'IBCIFN W !!,"A charge can not be added for this item!",! Q
. S IBCIFN=$$ADDCI^IBCREF(+IBCSFN,+IBITEM,IBDT) W !,?50,"Adding a new Charge Item!"
;
S DR=$$DR01(+$P(IBITEM,U,4))_";.03;.04;.05;"
;
I $P(IBITEM,U,4)=81 S DR=DR_".07"
;
DIE S DIDEL=363.2,DIE="^IBA(363.2,",DA=+IBCIFN D ^DIE K DIE,DR,X,DIDEL
;
I $D(DA),$D(Y)=0 S IBX=$$RQCI^IBCREU1(+IBCIFN) I +IBX
D DISPCSL^IBCRU7(+IBCSFN)
G CI
Q
BITM(X) ; return external form of billable item
S X=+$G(X) S X=$$EXPAND^IBCRU1(363.3,.04,X)
Q X
FINDCI(IBCSFN,IBITEM,IBDT) ; find item to edit returns CIIFN or 0 (new) or -1 (error)
;
N IBY,IBI,IBCNT,DIR,X,Y,IBARR S IBY=-1
S IBI=$O(^IBA(363.2,"AIVDTS"_IBCSFN,+IBITEM,-IBDT,0)) I 'IBI S IBY=0 G FCQ ; none found
;
S (IBI,IBCNT)=0 F S IBI=$O(^IBA(363.2,"AIVDTS"_IBCSFN,+IBITEM,-IBDT,+IBI)) Q:'IBI D
. S IBCNT=IBCNT+1,IBARR(IBCNT)=IBI D DISPCIL^IBCRU5(IBI,IBCNT)
I +IBCNT S DIR(0)="NO^1:"_IBCNT D ^DIR I Y>0 S IBY=$G(IBARR(Y))
I '$D(DTOUT),'$D(DUOUT),IBY<1 S DIR(0)="Y",DIR("A")="Add a new Charge Item? " S DIR("B")="Y" D ^DIR I Y=1 S IBY=0
FCQ Q IBY
;
DR01(FILE) ; return DR string for editing the .01 field of charge item
N IBX S IBX=""
I +$G(FILE) S IBX="S DIC(""V"")=""I +Y(0)="_+FILE_""";.01;K DIC(""V"")"
Q IBX
;
SCRNDSPL ; if this edit is called from the screen return the items and dates edited so screen can be
; redisplayed with the new/edited items
I $D(IBSRNITM) S IBSRNITM=IBITEM
I $D(IBSRNBDT),IBSRNBDT>IBDT S IBSRNBDT=IBDT
I $D(IBSRNEDT),+IBSRNEDT,IBSRNEDT<IBDT S IBSRNEDT=IBDT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRETP 6289 printed Nov 22, 2024@17:29:11 Page 2
IBCRETP ;LL/ELZ - RATES: TRANSFER PRICING CM FAST ENTER/EDIT ; 24-AUG-1999
+1 ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
ENTER ; OPTION: Transfer Pricing rates fast enter - this requires billing
+1 ; rate names are not changed. Will set up charge sets if not defined.
+2 ;
+3 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y,IBARR,IBRATE,IBEFDT,IBRVCD,IBCS,IBA
+4 WRITE @IOF
WRITE !!,?10,"Fast Enter of Transfer Pricing Rates",!!
+5 ;
+6 SET DIR(0)="SO^I:Inpatient;O:Outpatient"
SET DIR("A")="Enter which rates"
DO ^DIR
KILL DIR
+7 SET IBRATE=$SELECT(Y="I":"1^TP INPATIENT",Y="O":"2^TP OUTPATIENT",1:"")
if 'IBRATE
QUIT
+8 ;
+9 SET IBEFDT=$$GETDT^IBCRU1()
IF IBEFDT'?7N
QUIT
+10 ;
+11 SET IBCS=$$FAC(IBRATE)
+12 DO EDITCI(IBCS,IBEFDT)
+13 QUIT
+14 ;
FAC(TYPE) ; ask facility, create charge sets and billing region if not defined, return chargeset
+1 NEW DIC,X,Y,DTOUT,DUOUT,IBFAC,IBCS,IBRG
+2 ;
+3 SET DIC="^DIC(4,"
SET DIC(0)="AEMNQ"
DO ^DIC
if Y<1
QUIT 0
SET IBFAC=Y
+4 ;
+5 SET IBCS=$$TPCS^IBCRU7(TYPE,+IBFAC)
if IBCS
QUIT IBCS
+6 ;
+7 ; add billing region and charge set to charge master
+8 SET IBRG=$$RG(IBFAC)
if 'IBRG
QUIT 0
+9 SET IBCS=$$ACS(TYPE,IBRG,IBFAC)
+10 QUIT IBCS
+11 ;
RG(INST) ; add a new Billing Region for Transfer pricing (363.31)
+1 ; input institution 0 by ref and institution pointer
+2 ; returns billing region IFN ^ name
+3 NEW IBNAME,IBRG,X,Y,DLAYGO,DIC,DA,DTOUT,DUOUT,MSG,D0
+4 IF $GET(INST)=""
QUIT 0
+5 ;
+6 FOR X=0,1,3,99
SET INST(X)=$GET(^DIC(4,+INST,X))
+7 SET IBNAME=$$NNT^XUAF4(+INST)
+8 SET IBNAME="TP "_$SELECT($PIECE(IBNAME,"^",3)="VISN":$PIECE(IBNAME,"^"),1:$PIECE(INST(99),"^")_" "_$PIECE(INST(1),"^",3))_$SELECT($PIECE(INST(0),"^",2)&($PIECE(IBNAME,"^",3)'="VISN"):", "_$PIECE($GET(^DIC(5,$PIECE(INST(0),"^",2),0)),"^",2),1:""
)
+9 SET IBRG=$ORDER(^IBE(363.31,"B",IBNAME,0))
IF IBRG
QUIT IBRG_"^"_IBNAME
+10 ;
+11 KILL D0
SET DLAYGO=363.31
SET DIC="^IBE(363.31,"
SET DIC(0)="L"
SET X=$EXTRACT(IBNAME,1,30)
DO FILE^DICN
IF Y<1
QUIT 0
+12 SET IBRG=Y
DO MSG(" Added Billing Region "_$PIECE(IBRG,"^",2))
+13 ;
+14 KILL DA
SET DIC(0)="L"
SET DA(1)=+IBRG
SET DIC=DIC_DA(1)_",21,"
SET X=+INST
DO FILE^DICN
+15 DO MSG(" with"_$SELECT(Y>0:"",1:"OUT")_" Institution "_$PIECE(INST(0),"^"))
+16 ;
+17 DO MSGP
QUIT IBRG
+18 ;
ACS(RATE,RG,FAC) ; find or add charge set
+1 ; returns IFN of new charge set, 0 otherwise, input is in internal^external format
+2 NEW IBOK,IBNAME,IBEVENT,IBFN,IBBR,IBBE,IBJ,DD,DO,DLAYDO,DINUM,DIC,DA,X,Y,DR,DIE,IBA,IBCSN,MSG
SET IBOK=1
+3 SET RATE=$GET(RATE)
SET RG=$GET(RG)
SET FAC=$GET(FAC)
IF RATE=""
GOTO ACSQ
+4 ;
+5 SET IBNAME="TP-"_$SELECT((+RATE)=1:"INPT ",1:"OPT ")_$SELECT($EXTRACT($PIECE(FAC,"^",2),1,5)="VISN ":$PIECE(FAC,"^",2),1:+FAC)
+6 SET IBEVENT=$SELECT(RATE[" I":"INPATIENT DRG",1:"PROCEDURE")
+7 SET IBFN=$ORDER(^IBE(363.1,"B",$EXTRACT(IBNAME,1,30),0))
IF +IBFN
SET IBOK=0
DO MSG(" *** Charge Set "_$EXTRACT(IBNAME,1,30)_" found")
+8 SET IBBR=$ORDER(^IBE(363.3,"B",$PIECE(RATE,"^",2),0))
IF 'IBBR
SET IBOK=0
DO MSG(" *** Error: "_RATE_" Billing Rate does not exist")
+9 SET IBBE=$$MCCRUTL(IBEVENT,14)
IF 'IBBE
SET IBOK=0
DO MSG(" *** Error: "_IBEVENT_" Billable Event undefined")
+10 IF '$DATA(^IBE(363.3,+RG))
SET IBOK=0
DO MSG(" *** Error: "_$PIECE($EXTRACT(RG,1,30),"^",2)_" Billing Region does not exist")
+11 IF '$GET(IBOK)
GOTO ACSQ
+12 ;
+13 FOR IBJ=1:1
SET IBFN=$GET(^IBE(363.1,IBJ,0))
IF IBFN=""
SET DINUM=IBJ
QUIT
+14 ;
+15 KILL DD,DO
SET DLAYGO=363.1
SET DIC="^IBE(363.1,"
SET DIC(0)="L"
SET X=$EXTRACT(IBNAME,1,30)
DO FILE^DICN
KILL DIC
KILL DIC,DINUM,DLAYGO
IF Y<1
KILL X,Y
QUIT
+16 SET IBFN=+Y
SET IBCSN=$PIECE(Y,U,2)
+17 ;
+18 SET DR=".02////"_IBBR_";.03////"_IBBE_";.07////"_(+RG)
+19 SET DIE="^IBE(363.1,"
SET DA=+IBFN
DO ^DIE
KILL DIE,DA,DR,X,Y
+20 SET IBA(1)=" "_$EXTRACT(IBNAME,1,30)_" Charge Set "_$SELECT('$GET(IBFN):"NOT ",1:"")_"added"
+21 ;
ACSQ DO MSGP
+1 QUIT +$GET(IBFN)
+2 ;
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
+1 NEW IBX,IBY
SET IBY=""
+2 IF $GET(X)'=""
SET IBX=0
FOR
SET IBX=$ORDER(^DGCR(399.1,"B",X,IBX))
if 'IBX
QUIT
IF $PIECE($GET(^DGCR(399.1,IBX,0)),U,+$GET(P))
SET IBY=IBX
+3 QUIT IBY
+4 ;
MSG(X) ; add message to end of message list, reserves IBA(1) for primary message
+1 NEW IBX
SET IBX=$ORDER(IBA(999999),-1)
if 'IBX
SET IBX=1
SET IBX=IBX+1
+2 SET IBA(IBX)=$GET(X)
+3 QUIT
MSGP ; print error messages in IBA
+1 NEW IBX
SET IBX=""
FOR
SET IBX=$ORDER(IBA(IBX))
if 'IBX
QUIT
WRITE !,IBA(IBX)
+2 QUIT
+3 ;
EDITCI(IBCSFN,IBDT) ; Enter/Edit Charge Items
+1 NEW IBCS0,IBBR0,IBBRFN,IBITEM,IBBRBI,IBCIFN,IBX,DIE,DR,DA,X,Y
+2 ;
CS IF '$GET(IBCSFN)
SET IBCSFN=+$$GETCS^IBCRU1
if IBCSFN'>0
QUIT
+1 DO DISPCS^IBCRU7(+IBCSFN)
+2 ;
+3 SET IBCS0=$GET(^IBE(363.1,+IBCSFN,0))
SET IBBRFN=$PIECE(IBCS0,U,2)
+4 SET IBBR0=$GET(^IBE(363.3,+IBBRFN,0))
SET IBBRBI=$PIECE(IBBR0,U,4)
+5 WRITE !!,"Enter/edit a billable item (",$$BITM(IBBRBI),") for Charge Set ",$PIECE(IBCS0,U,1)
+6 ;
CI WRITE !
SET IBITEM=$$GETITEM^IBCRU1(IBCSFN,"",1)
IF +IBITEM<1
QUIT
+1 IF '$$ITFILE^IBCRU2(IBBRBI,+IBITEM)
WRITE !!,$$BITM(IBBRBI)," ",$PIECE(IBITEM,U,2)," CURRENTLY INACTIVE",!
+2 ;
EF DO DISPCI^IBCRU5(+IBCSFN,+IBITEM)
+1 IF IBDT<1
SET IBDT=""
WRITE " ... no change"
GOTO CI
+2 DO SCRNDSPL
+3 ;
+4 SET IBCIFN=$$FINDCI(+IBCSFN,+IBITEM,IBDT)
IF IBCIFN<0
GOTO EF
+5 ;
+6 IF IBCIFN>0
WRITE !,?50,"Editing Charge Item!"
+7 ;
+8 IF 'IBCIFN
Begin DoDot:1
+9 SET IBCIFN=$$ADDCI^IBCREF(+IBCSFN,+IBITEM,IBDT)
WRITE !,?50,"Adding a new Charge Item!"
End DoDot:1
IF 'IBCIFN
WRITE !!,"A charge can not be added for this item!",!
QUIT
+10 ;
+11 SET DR=$$DR01(+$PIECE(IBITEM,U,4))_";.03;.04;.05;"
+12 ;
+13 IF $PIECE(IBITEM,U,4)=81
SET DR=DR_".07"
+14 ;
DIE SET DIDEL=363.2
SET DIE="^IBA(363.2,"
SET DA=+IBCIFN
DO ^DIE
KILL DIE,DR,X,DIDEL
+1 ;
+2 IF $DATA(DA)
IF $DATA(Y)=0
SET IBX=$$RQCI^IBCREU1(+IBCIFN)
IF +IBX
+3 DO DISPCSL^IBCRU7(+IBCSFN)
+4 GOTO CI
+5 QUIT
BITM(X) ; return external form of billable item
+1 SET X=+$GET(X)
SET X=$$EXPAND^IBCRU1(363.3,.04,X)
+2 QUIT X
FINDCI(IBCSFN,IBITEM,IBDT) ; find item to edit returns CIIFN or 0 (new) or -1 (error)
+1 ;
+2 NEW IBY,IBI,IBCNT,DIR,X,Y,IBARR
SET IBY=-1
+3 ; none found
SET IBI=$ORDER(^IBA(363.2,"AIVDTS"_IBCSFN,+IBITEM,-IBDT,0))
IF 'IBI
SET IBY=0
GOTO FCQ
+4 ;
+5 SET (IBI,IBCNT)=0
FOR
SET IBI=$ORDER(^IBA(363.2,"AIVDTS"_IBCSFN,+IBITEM,-IBDT,+IBI))
if 'IBI
QUIT
Begin DoDot:1
+6 SET IBCNT=IBCNT+1
SET IBARR(IBCNT)=IBI
DO DISPCIL^IBCRU5(IBI,IBCNT)
End DoDot:1
+7 IF +IBCNT
SET DIR(0)="NO^1:"_IBCNT
DO ^DIR
IF Y>0
SET IBY=$GET(IBARR(Y))
+8 IF '$DATA(DTOUT)
IF '$DATA(DUOUT)
IF IBY<1
SET DIR(0)="Y"
SET DIR("A")="Add a new Charge Item? "
SET DIR("B")="Y"
DO ^DIR
IF Y=1
SET IBY=0
FCQ QUIT IBY
+1 ;
DR01(FILE) ; return DR string for editing the .01 field of charge item
+1 NEW IBX
SET IBX=""
+2 IF +$GET(FILE)
SET IBX="S DIC(""V"")=""I +Y(0)="_+FILE_""";.01;K DIC(""V"")"
+3 QUIT IBX
+4 ;
SCRNDSPL ; if this edit is called from the screen return the items and dates edited so screen can be
+1 ; redisplayed with the new/edited items
+2 IF $DATA(IBSRNITM)
SET IBSRNITM=IBITEM
+3 IF $DATA(IBSRNBDT)
IF IBSRNBDT>IBDT
SET IBSRNBDT=IBDT
+4 IF $DATA(IBSRNEDT)
IF +IBSRNEDT
IF IBSRNEDT<IBDT
SET IBSRNEDT=IBDT
+5 QUIT
