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

IBECEA3.m

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