source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBECEA3.m@ 1464

IBECEA3 ;ALB/CPM - Cancel/Edit/Add... Add a Charge ;30-MAR-93

 ;;2.0;INTEGRATED BILLING;**7,57,52,132,150,153,166,156,167,176,198,188,183,202,240,312**;21-MAR-94

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

ADD ; Add a Charge protocol

 N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI()                     ;IB*2.0*312

 N IBGMT,IBGMTR

 S (IBGMT,IBGMTR)=0

 S IBCOMMIT=0,IBEXSTAT=$$RXST^IBARXEU(DFN,DT),IBCATC=$$BILST^DGMTUB(DFN),IBCVAEL=$$CVA^IBAUTL5(DFN),IBLTCST=$$LTCST^IBAECU(DFN,DT,1)

 ;I 'IBCVAEL,'IBCATC,'$G(IBRX),+IBEXSTAT<1 W !!,"This patient has never been Means Test billable." 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

 N IBAFEE S:$P($G(^IBE(350.1,+$G(IBATYP),0)),"^",8)="FEE SERVICE/OUTPATIENT" IBAFEE=IBATYP

 ;

 ; - process CHAMPVA charges

 I IBXA=6 D CHMPVA^IBECEA32 G ADDQ

 ;

 ; - process TRICARE charges

 I IBXA=7 D CUS^IBECEA35 G ADDQ

 ;

 ; - display MT billing clock data

 I IBXA=2,$P($G(^IBE(350.1,+IBATYP,0)),"^",8)'["NHCU",IBCLDAY>90 S IBMED=IBMED/2

 I IBXA=1,IBCLDAY>90 D MED^IBECEA34 G:IBY<0 ADDQ

 I "^1^2^3^"[("^"_IBXA_"^"),IBCLDA W !!,"  ** Active Billing Clock **   # Inpt Days: ",IBCLDAY,"    ",$$INPT^IBECEAU(IBCLDAY)," 90 days: $",+IBCLDOL,!

 ;

 ; - display LTC billing clock data

 I IBXA>7,IBXA<10 D  G:IBCLDA<1 ADDQ

 . N IBCLZ

 . S IBCLDA=$O(^IBA(351.81,"AE",DFN,9999999),-1)

 . S:IBCLDA IBCLDA=$O(^IBA(351.81,"AE",DFN,IBCLDA,0))

 . I 'IBCLDA W !!,"  ** Patient has no LTC billing clock **" Q

 . S IBCLZ=^IBA(351.81,IBCLDA,0)

 . W !!,"  **Last LTC Billing Clock    Start Date: ",$$FMTE^XLFDT($P(IBCLZ,"^",3)),"  Free Days Remaining: ",+$P(IBCLZ,"^",6)

 . I $P(IBCLZ,"^",6) W !,"The patient must use his free days first." S IBCLDA=0

 ;

 ; - ask units for rx copay charge

 I IBXA=5 D UNIT^IBECEAU2(0) G ADDQ:IBY<0 D  G ADDQ:IBY<0 G PROC

 . ;

 . ; has patient been previously tracked for cap info

 . D TRACK^IBARXMN(DFN)

 . ;

 . D CTBB^IBECEAU3

 . ;

 . ; check if above cap

 . I IBY'<0 D

 .. N IBB,IBN,DIR,DIRUT,DUOUT,DTOUT,X,Y

 .. D NEW^IBARXMC(1,IBCHG,DT,.IBB,.IBN) Q:'IBN

 .. ;

 .. ; display message ask to proceed

 .. W !!,"This charge will put the patient > $",$J(IBN,0,2)," above their cap amount."

 .. S DIR(0)="Y",DIR("A")="Okay to proceed" D ^DIR S:'Y IBY=-1

 .. ;

 S IBLIM=$S(IBXA=4!(IBXA=3):DT,1:$$FMADD^XLFDT(DT,-1))

 ;

FR ; - ask 'bill from' date

 D FR^IBECEAU2(0) G:IBY<0 ADDQ

 ; Do NOT PROCESS on VistA if IBFR>=Switch Eff Date          ;CCR-930

 I +IBSWINFO,(IBFR+1)>$P(IBSWINFO,"^",2) D  G FR             ;IB*2.0*312

   .W !!,"The 'Bill From' date cannot be on or AFTER the PFSS Effective Date"

   .W ": ",$$FMTE^XLFDT($P(IBSWINFO,"^",2))

 ;

 S IBGMT=$$ISGMTPT^IBAGMT(DFN,IBFR),IBGMTR=0 ;GMT Copayment Status

 I IBGMT>0,IBXA>0,IBXA<4 W !,"The patient has GMT Copayment Status."

 ; - check the MT billing clock

 I IBXA'=8,IBXA'=9 D CLMSG^IBECEA33 G:IBY<0 ADDQ

 ;Adjust Deductible for GMT patient

 I IBGMT>0,IBXA>0,IBXA<4,$G(IBMED) S IBMED=$$REDUCE^IBAGMT(IBMED) W !,"Medicare Deductible reduced due to GMT Copayment Status ($",$J(IBMED,"",2),")."

 ;

 ; - check the LTC billing clock

 I IBXA>7,IBXA<10 D  I IBY<0 W !!,"The patient has no LTC clock active for the date.",! G ADDQ

 . N IBCLZ S IBCLZ=^IBA(351.81,IBCLDA,0)

 . ;

 . ; is this the clock and within the date range

 . I IBFR'<$P(IBCLZ,"^",3),$$YR^IBAECU($P(IBCLZ,"^",3),IBFR) S IBY=-1 Q

 . ;

 . ; look for another clock that might fit the date

 . I IBFR<$P(IBCLZ,"^",3) S IBCLDA=$O(^IBA(351.81,"AE",DFN,IBFR+1),-1) I 'IBCLDA!($$YR^IBAECU($P($G(^IBA(351.81,+IBCLDA,0)),"^",3),IBFR)) S IBY=-1

 ;

 ; - calculate the MT inpt copay charge

 I IBXA=2 S IBDT=IBFR D COPAY^IBAUTL2 G ADDQ:IBY<0 S:IBGMT>0 IBGMTR=1,IBCHG=$$REDUCE^IBAGMT(IBCHG) I IBCHG+IBCLDOL<IBMED W *7,"   ($",IBCHG,"/day)" W:IBGMTR " GMT Rate"

 ;

 ; - find the correct clock from the 'bill from' date (ignore LTC)

 I IBXA'=8,IBXA'=9,('IBCLDA!(IBCLDA&(IBFR<IBCLDT))) D NOCL^IBECEA33 G:IBY<0 ADDQ

 ;

 ; - perform outpatient edits

 N IBSTOPDA

 I IBXA=4 D  G ADDQ:IBY<0,PROC

 .   ;  for visits prior to 12/6/01 or FEE

 .   I IBFR<3011206!($G(IBAFEE)) D OPT^IBECEA33 Q

 .   ;  for visits on or after 12/5/01

 .   D OPT^IBEMTSCU

 ;

 ; - if LTC outpatient calculate the charge

 I IBXA=8 D  G:IBY<0 ADDQ S (IBDT,IBTO,IBEVDT)=IBFR,IBDESC=$P(^IBE(350.1,IBATYP,0),"^",8),IBUNIT=1,IBEVDA="*" D COST^IBAUTL2,CALC^IBAECO,CTBB^IBECEAU3 G @$S(IBCHG:"PROC",1:"ADDQ")

 . ;

 . ; is this day already a free day

 . I $D(^IBA(351.81,IBCLDA,1,"AC",IBFR)) W !!,"This day is already marked as a Free Day." S IBY=-1

 . ;

 . ; have we already billed for this day

 . I $D(^IB("AFDT",DFN,-IBFR)) W !!,"This patient has already been billed for this date." S IBY=-1

 ;

 ; - 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,IBGMTR=0 D COST^IBAUTL2

 .I IBGMT>0 S IBGMTR=1,IBCHG=$$REDUCE^IBAGMT(IBCHG)

 .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

 ; Do NOT PROCESS on VistA if IBTO>=Switch Eff Date         ;CCR-930

 I +IBSWINFO,(IBTO+1)>$P(IBSWINFO,"^",2) D  G TO            ;IB*2.0*312

  .W !!,"The 'Bill To' date cannot be on or AFTER the PFSS Effective Date"

  .W ": ",$$FMTE^XLFDT($P(IBSWINFO,"^",2))

 ;

 I IBXA>0,IBXA<4,IBGMT'=$$ISGMTPT^IBAGMT(DFN,IBTO) W !!,"The patient's GMT Copayment status changed within the specified period!",! G ADDQ

 ;

 ; - calculate unit charge for LTC inpatient in IBCHG

 I IBXA=9 S IBDT=IBFR,IBEVDA=$$EVF^IBECEA31(DFN,IBFR,IBTO,IBNH),IBEVDT=$E(IBFR,1,5)_"01" D:IBEVDA<1  G ADDQ:IBY<0 D COST^IBAUTL2 I $E(IBFR,1,5)'=$E(IBTO,1,5) W !!,"  LTC Copayment charges cannot go from one month to another." G ADDQ

 . D NOEV^IBECEA31 I '$G(IBDG)!(IBY<0) S IBY=-1 Q

 . ; - build the event record

 . N IBNHLTC S IBNHLTC=1 D ADEV^IBECEA31

 ;

 ;

 ; - calculate units and total charge

 S IBUNIT=$$FMDIFF^XLFDT(IBTO,IBFR) S:IBXA'=3!(IBFR=IBTO) IBUNIT=IBUNIT+1

 I IBXA=1 D:IBGMT>0  D FEPR^IBECEA32 G ADDQ:IBY<0,EV

 . S IBGMTR=1

 . W !,"The patient has GMT Copayment Status! GMT rate must be applied.",!

 S IBCHG=IBCHG*IBUNIT S:IBXA=2 IBCHG=$S(IBCLDOL+IBCHG>IBMED:IBMED-IBCLDOL,1:IBCHG)

 ;

 ; adjust the LTC charge based on the calculated copay cap

 I IBXA=9 D CALC^IBAECI G:IBY<1!('IBCHG) ADDQ S IBDESC="LTC INPATIENT COPAY"

 ;

 D CTBB^IBECEAU3 W:IBXA=3!(IBXA=9) "  (for ",IBUNIT," day",$E("s",IBUNIT>1),")" W:IBGMTR " GMT Rate"

 ;

EV ; - find event record, or select admission for linkage

 I IBXA'=9 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 ",$$TYP(),"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),IBXA'=9 D @("ADEV^IBECEA3"_$S($G(IBFEEV):4,1:1)) G:IBY<0 ADDQ

 ;

 ; - disposition the special inpatient billing case, if necessary

 I $G(IBSIBC) D CEA^IBAMTI1(IBSIBC,IBEVDA)

 ;

 ; - generate entry in file #354.71 and #350

 I IBXA=5 W !!,"Building the new transaction...  " S IBAM=$$ADD^IBARXMN(DFN,"^^"_DT_"^^P^^"_IBUNIT_"^"_IBCHG_"^"_IBDESC_"^^"_IBCHG_"^0^"_IBSITE) G:IBAM<0 ADDQ

 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

 I IBXA'=8,IBXA'=9 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,IBFEEV,IBAM

 K IBX,IBCHG,IBUNIT,IBDESC,IBDT,IBEVDT,IBEVDA,IBSL,IBNOS,IBN,IBTOTL,IBARTYP,IBIL,IBTRAN,IBAFY,IBCVA,IBCLSF,IBDD,IBND,VADM,VA,VAERR,IBADJMED

ADDQ1 K IBEXSTAT,IBCOMMIT,IBCATC,IBCVAEL,IBLTCST

 Q

 ;

 ;

TYP() ; Return descriptive admission type.

 N X S X=""

 I IBNH'=2 G TYPQ

 I $G(IBADJMED) S X=$S(IBADJMED=1:"C",1:"H")

 E  S X=$S($P($G(^IBE(350.1,+IBATYP,0)),"^")["NHCU":"C",1:"H")

 S X=$S(X="C":"CNH ",1:"Contract Hospital ")

TYPQ Q X