IBECEA3 ;ALB/CPM - Cancel/Edit/Add... Add a Charge ; 30-MAR-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
ADD ; Add a Charge protocol
S IBCOMMIT=0,IBEXSTAT=$$RXST^IBARXEU(DFN,DT),IBCATC=$$BILST^DGMTUB(DFN),IBCVAEL=$$CVA^IBAUTL5(DFN)
I 'IBCVAEL,'IBCATC,'$G(IBRX),+IBEXSTAT<1 W !!,"This patient has never been Category C." S VALMBCK="" D PAUSE^VALM1 G ADDQ1
;
; - clear screen and begin
D CLOCK^IBAUTL3 I 'IBCLDA S (IBMED,IBCLDAY,IBCLDOL,IBCLDT)=0
D HDR^IBECEAU("A D D")
I IBY<0 D NODED^IBECEAU3 G ADDQ
;
; - ask for the charge type
D CHTYP^IBECEA33 G:IBY<0 ADDQ
;
; - process CHAMPVA charges
I IBXA=6 D CHMPVA^IBECEA32 G ADDQ
;
; - display billing clock data
I IBXA=2,$P(Y(0),"^",8)'["NHCU",IBCLDAY>90 S IBMED=IBMED/2
I "^1^2^3^"[("^"_IBXA_"^"),IBCLDA W !!," ** Active Billing Clock ** # Inpt Days: ",IBCLDAY," ",$$INPT^IBECEAU(IBCLDAY)," 90 days: $",+IBCLDOL,!
;
; - ask units for rx copay charge
I IBXA=5 D UNIT^IBECEAU2(0) G ADDQ:IBY<0 D CTBB^IBECEAU3 G PROC
S IBLIM=$S(IBXA=4:DT,1:$$FMADD^XLFDT(DT,-1))
;
FR ; - ask 'bill from' date
D FR^IBECEAU2(0) G:IBY<0 ADDQ
;
; - check the billing clock
D CLMSG^IBECEA33 G:IBY<0 ADDQ
;
; - calculate the inpt copay charge
I IBXA=2 S IBDT=IBFR D COPAY^IBAUTL2 G ADDQ:IBY<0 I IBCHG+IBCLDOL<IBMED W *7," ($",IBCHG,"/day)"
;
; - find the correct clock from the 'bill from' date
I 'IBCLDA!(IBCLDA&(IBFR<IBCLDT)) D NOCL^IBECEA33 G:IBY<0 ADDQ
;
; - perform outpatient edits
I IBXA=4 D OPT^IBECEA33 G ADDQ:IBY<0,PROC
;
; - find per diem charge and description
I IBXA=3 D I 'IBCHG W !!,"Unable to determine the per diem rate. Please check your rate table." G ADDQ
.N IBDT S IBDT=IBFR D COST^IBAUTL2
.S IBDESC="" X:$D(^IBE(350.1,IBATYP,20)) ^(20)
;
; - calculate charge for the inpatient copay
I IBXA=2,IBCHG+IBCLDOL'<IBMED S IBCHG=IBMED-IBCLDOL,IBUNIT=1,IBTO=IBFR D CTBB^IBECEAU3 G EV
;
TO ; - ask 'bill to' date
D TO^IBECEAU2(0) G:IBY<0 ADDQ
;
; - calculate units and total charge
S IBUNIT=$$FMDIFF^XLFDT(IBTO,IBFR) S:IBXA'=3!(IBFR=IBTO) IBUNIT=IBUNIT+1
I IBXA=1 D FEPR^IBECEA32 G ADDQ:IBY<0,PROC
S IBCHG=IBCHG*IBUNIT S:IBXA=2 IBCHG=$S(IBCLDOL+IBCHG>IBMED:IBMED-IBCLDOL,1:IBCHG)
D CTBB^IBECEAU3 W:IBXA=3 " (for ",IBUNIT," day",$E("s",IBUNIT>1),")"
;
EV ; - find event record, or select admission for linkage
S IBEVDA=$$EVF^IBECEA31(DFN,IBFR,IBTO,IBNH)
I IBEVDA'>0 D NOEV^IBECEA31 G ADDQ:IBY<0,PROC
S IBSL=$P($G(^IB(+IBEVDA,0)),"^",4)
W !!,"Linked charge to admission on ",$$DAT1^IBOUTL($P(IBEVDA,"^",2))," ("
W $S($P(IBEVDA,"^",3)=9999999:"Still admitted)",1:"Discharged on "_$$DAT1^IBOUTL($P(IBEVDA,"^",3))_$S($P(IBEVDA,"^",3)>DT:" [pseudo])",1:")"))," ..."
S IBEVDA=+IBEVDA
I '$G(IBSIBC) D SPEC^IBECEA32(0,$O(^IBE(351.2,"AD",IBEVDA,0)))
;
PROC ; - okay to proceed?
D PROC^IBECEAU4("add") G:IBY<0 ADDQ
;
; - build the event record first if necessary
I $G(IBDG) D ADEV^IBECEA31 G:IBY<0 ADDQ
;
; - disposition the special inpatient billing case, if necessary
I $G(IBSIBC) D CEA^IBAMTI1(IBSIBC,IBEVDA)
;
; - generate entry in file #350
W !!,"Building the new transaction... "
D ADD^IBECEAU3 G:IBY<0 ADDQ W "done."
;
; - pass the charge off to AR on-line
W !,"Passing the charge directly to Accounts Receivable... "
D PASSCH^IBECEA22 W:IBY>0 "done." G:IBY<0 ADDQ
;
; - review the special inpatient billing case
I $G(IBSIBC1) D CHK^IBAMTI1(IBSIBC1,IBEVDA)
;
; - handle updating of clock
D CLUPD^IBECEA32
;
ADDQ ; - display error, rebuild list, and quit
D ERR^IBECEAU4:IBY<0,PAUSE^IBECEAU S VALMBCK="R"
I IBCOMMIT S IBBG=VALMBG W !,"Rebuilding list of charges..." D ARRAY^IBECEA0 S VALMBG=IBBG
K IBMED,IBCLDA,IBCLDT,IBCLDOL,IBCLDAY,IBATYP,IBDG,IBSEQNO,IBXA,IBNH,IBBS,IBLIM,IBFR,IBTO,IBRTED,IBSIBC,IBSIBC1,IBBG
K IBX,IBCHG,IBUNIT,IBDESC,IBDT,IBEVDT,IBEVDA,IBSL,IBNOS,IBN,IBTOTL,IBARTYP,IBIL,IBTRAN,IBAFY,IBCVA,IBCLSF,IBDD,IBND,VADM,VA,VAERR
ADDQ1 K IBEXSTAT,IBCOMMIT,IBCATC,IBCVAEL
Q
IBECEA3 ;ALB/CPM - Cancel/Edit/Add... Add a Charge ; 30-MAR-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
ADD ; Add a Charge protocol
+1 SET IBCOMMIT=0
SET IBEXSTAT=$$RXST^IBARXEU(DFN,DT)
SET IBCATC=$$BILST^DGMTUB(DFN)
SET IBCVAEL=$$CVA^IBAUTL5(DFN)
+2 IF 'IBCVAEL
IF 'IBCATC
IF '$GET(IBRX)
IF +IBEXSTAT<1
WRITE !!,"This patient has never been Category C."
SET VALMBCK=""
DO PAUSE^VALM1
GOTO ADDQ1
+3 ;
+4 ; - clear screen and begin
+5 DO CLOCK^IBAUTL3
IF 'IBCLDA
SET (IBMED,IBCLDAY,IBCLDOL,IBCLDT)=0
+6 DO HDR^IBECEAU("A D D")
+7 IF IBY<0
DO NODED^IBECEAU3
GOTO ADDQ
+8 ;
+9 ; - ask for the charge type
+10 DO CHTYP^IBECEA33
IF IBY<0
GOTO ADDQ
+11 ;
+12 ; - process CHAMPVA charges
+13 IF IBXA=6
DO CHMPVA^IBECEA32
GOTO ADDQ
+14 ;
+15 ; - display billing clock data
+16 IF IBXA=2
IF $PIECE(Y(0),"^",8)'["NHCU"
IF IBCLDAY>90
SET IBMED=IBMED/2
+17 IF "^1^2^3^"[("^"_IBXA_"^")
IF IBCLDA
WRITE !!," ** Active Billing Clock ** # Inpt Days: ",IBCLDAY," ",$$INPT^IBECEAU(IBCLDAY)," 90 days: $",+IBCLDOL,!
+18 ;
+19 ; - ask units for rx copay charge
+20 IF IBXA=5
DO UNIT^IBECEAU2(0)
IF IBY<0
GOTO ADDQ
DO CTBB^IBECEAU3
GOTO PROC
+21 SET IBLIM=$SELECT(IBXA=4:DT,1:$$FMADD^XLFDT(DT,-1))
+22 ;
FR ; - ask 'bill from' date
+1 DO FR^IBECEAU2(0)
IF IBY<0
GOTO ADDQ
+2 ;
+3 ; - check the billing clock
+4 DO CLMSG^IBECEA33
IF IBY<0
GOTO ADDQ
+5 ;
+6 ; - calculate the inpt copay charge
+7 IF IBXA=2
SET IBDT=IBFR
DO COPAY^IBAUTL2
IF IBY<0
GOTO ADDQ
IF IBCHG+IBCLDOL<IBMED
WRITE *7," ($",IBCHG,"/day)"
+8 ;
+9 ; - find the correct clock from the 'bill from' date
+10 IF 'IBCLDA!(IBCLDA&(IBFR<IBCLDT))
DO NOCL^IBECEA33
IF IBY<0
GOTO ADDQ
+11 ;
+12 ; - perform outpatient edits
+13 IF IBXA=4
DO OPT^IBECEA33
IF IBY<0
GOTO ADDQ
GOTO PROC
+14 ;
+15 ; - find per diem charge and description
+16 IF IBXA=3
Begin DoDot:1
+17 NEW IBDT
SET IBDT=IBFR
DO COST^IBAUTL2
+18 SET IBDESC=""
IF $DATA(^IBE(350.1,IBATYP,20))
XECUTE ^(20)
End DoDot:1
IF 'IBCHG
WRITE !!,"Unable to determine the per diem rate. Please check your rate table."
GOTO ADDQ
+19 ;
+20 ; - calculate charge for the inpatient copay
+21 IF IBXA=2
IF IBCHG+IBCLDOL'<IBMED
SET IBCHG=IBMED-IBCLDOL
SET IBUNIT=1
SET IBTO=IBFR
DO CTBB^IBECEAU3
GOTO EV
+22 ;
TO ; - ask 'bill to' date
+1 DO TO^IBECEAU2(0)
IF IBY<0
GOTO ADDQ
+2 ;
+3 ; - calculate units and total charge
+4 SET IBUNIT=$$FMDIFF^XLFDT(IBTO,IBFR)
IF IBXA'=3!(IBFR=IBTO)
SET IBUNIT=IBUNIT+1
+5 IF IBXA=1
DO FEPR^IBECEA32
IF IBY<0
GOTO ADDQ
GOTO PROC
+6 SET IBCHG=IBCHG*IBUNIT
IF IBXA=2
SET IBCHG=$SELECT(IBCLDOL+IBCHG>IBMED:IBMED-IBCLDOL,1:IBCHG)
+7 DO CTBB^IBECEAU3
IF IBXA=3
WRITE " (for ",IBUNIT," day",$EXTRACT("s",IBUNIT>1),")"
+8 ;
EV ; - find event record, or select admission for linkage
+1 SET IBEVDA=$$EVF^IBECEA31(DFN,IBFR,IBTO,IBNH)
+2 IF IBEVDA'>0
DO NOEV^IBECEA31
IF IBY<0
GOTO ADDQ
GOTO PROC
+3 SET IBSL=$PIECE($GET(^IB(+IBEVDA,0)),"^",4)
+4 WRITE !!,"Linked charge to admission on ",$$DAT1^IBOUTL($PIECE(IBEVDA,"^",2))," ("
+5 WRITE $SELECT($PIECE(IBEVDA,"^",3)=9999999:"Still admitted)",1:"Discharged on "_$$DAT1^IBOUTL($PIECE(IBEVDA,"^",3))_$SELECT($PIECE(IBEVDA,"^",3)>DT:" [pseudo])",1:")"))," ..."
+6 SET IBEVDA=+IBEVDA
+7 IF '$GET(IBSIBC)
DO SPEC^IBECEA32(0,$ORDER(^IBE(351.2,"AD",IBEVDA,0)))
+8 ;
PROC ; - okay to proceed?
+1 DO PROC^IBECEAU4("add")
IF IBY<0
GOTO ADDQ
+2 ;
+3 ; - build the event record first if necessary
+4 IF $GET(IBDG)
DO ADEV^IBECEA31
IF IBY<0
GOTO ADDQ
+5 ;
+6 ; - disposition the special inpatient billing case, if necessary
+7 IF $GET(IBSIBC)
DO CEA^IBAMTI1(IBSIBC,IBEVDA)
+8 ;
+9 ; - generate entry in file #350
+10 WRITE !!,"Building the new transaction... "
+11 DO ADD^IBECEAU3
IF IBY<0
GOTO ADDQ
WRITE "done."
+12 ;
+13 ; - pass the charge off to AR on-line
+14 WRITE !,"Passing the charge directly to Accounts Receivable... "
+15 DO PASSCH^IBECEA22
IF IBY>0
WRITE "done."
IF IBY<0
GOTO ADDQ
+16 ;
+17 ; - review the special inpatient billing case
+18 IF $GET(IBSIBC1)
DO CHK^IBAMTI1(IBSIBC1,IBEVDA)
+19 ;
+20 ; - handle updating of clock
+21 DO CLUPD^IBECEA32
+22 ;
ADDQ ; - display error, rebuild list, and quit
+1 IF IBY<0
DO ERR^IBECEAU4
DO PAUSE^IBECEAU
SET VALMBCK="R"
+2 IF IBCOMMIT
SET IBBG=VALMBG
WRITE !,"Rebuilding list of charges..."
DO ARRAY^IBECEA0
SET VALMBG=IBBG
+3 KILL IBMED,IBCLDA,IBCLDT,IBCLDOL,IBCLDAY,IBATYP,IBDG,IBSEQNO,IBXA,IBNH,IBBS,IBLIM,IBFR,IBTO,IBRTED,IBSIBC,IBSIBC1,IBBG
+4 KILL IBX,IBCHG,IBUNIT,IBDESC,IBDT,IBEVDT,IBEVDA,IBSL,IBNOS,IBN,IBTOTL,IBARTYP,IBIL,IBTRAN,IBAFY,IBCVA,IBCLSF,IBDD,IBND,VADM,VA,VAERR
ADDQ1 KILL IBEXSTAT,IBCOMMIT,IBCATC,IBCVAEL
+1 QUIT
