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,402,454,563,614,618,646,651,656,663,677,678,682,728,716,704,776,784**;21-MAR-94;Build 8
;;Per VA Directive 6402, this routine should not be modified.
;
ADD ; Add a Charge protocol
N IBGMT,IBGMTR,IBUSNM,IBUC ;IB*2.0*618 Add IBUSNM IB*2.0*646 Add IBUC
N IBDUPIEN,IBDPDATA,IBDPXA,IBDPAMT,IBCONT,IBVST ; IB*2.0*678 added
N IBCLDA,IBCLDY,IBCLEDT,IBCLST,IBCLSTDT,IBCLZ ; IB*2.0*728
N IBSTCD,IBCDCHK,IBCDEDT,IBCDFLG,IBCDSDT,NUMVSTFL ; IB*2.0*784
S (IBCDCHK,NUMVSTFL)="" ; IB*2.0*784
; Check for IB EDIT key. If not present
I '$$IBEDIT^IBECEA36 Q
S (IBGMT,IBGMTR,IBUC)=0
S IBCOMMIT=0,IBEXSTAT=$$RXST^IBARXEU(DFN,DT),IBCATC=$$BILST^DGMTUB(DFN),IBCVAEL=$$CVA^IBAUTL5(DFN),IBLTCST=$$LTCST^IBAECU(DFN,DT,1)
; 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
;
;***IB*2.0*618 change to add more Action Types to this list...
; Allow user to add an extra "co-payment" charge if the Action Type
; selected is an Outpatient FEE BASIS, CHOICE, CC or CCN charge type
N IBAFEE
S IBUSNM=$P($G(^IBE(350.1,+$G(IBATYP),0)),"^",8)
I IBUSNM'="" D
.I IBUSNM="FEE SERVICE/OUTPATIENT" S IBAFEE=IBATYP Q
.I (IBUSNM["CC")!(IBUSNM["CHOICE") D
..I (IBUSNM["OPT")!(IBUSNM["OUTPATIENT")!(IBUSNM["URGENT") S IBAFEE=IBATYP ;IB*2.0*646 added URGENT
;*** END IB*2.0*618 ***
;
; - 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,!
;
; - if LTC OPT (non-institutional) and CD display message of warning
I IBXA=8,$$CDEXMPT^IBAECU(DFN,DT) W !!," ** Patient is currently Catastrophically Disabled",!
;
; - ask date, units and maybe tier for rx copay charge
I IBXA=5 D G ADDQ:IBY<0,PROC
.N IBA,IBB,IBC,IBX
.;; IBREBILL array is defined in REBILL^IBECEA4
.S IBLIM=DT D FR^IBECEAU2($S($G(IBREBILL("EVDT"))'="":IBREBILL("EVDT"),1:0)) Q:IBY<0 ; IB*2.0*682
.S (IBTO,IBEFDT)=IBFR
.;
.;PRCA*4.5*338 - if Community Care RX copay, set event date
.S IBEVDA="*",IBEVDT=IBEFDT
.;
.; ask tier if needed
.S IBTIER=$$TIER^IBECEAU2(IBATYP,IBEFDT) Q:IBY<0
.;
.; ask units
.D UNIT^IBECEAU2(0) Q:IBY<0
.;
.; 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,IBFR,.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($S($G(IBREBILL("BILLFR"))'="":IBREBILL("BILLFR"),1:0)) ; IB*2.0*682
;IB*2.0*646/656
; If Urgent Care copay, skip clock checks, go to prompt for copay amount.
I $G(IBUC),(IBFR<3190606) D G ADDQ
. W !!,"The Urgent Care Copayment/Mission Act legislation went into effect on 6/6/19. "
. W !,"Dates of service prior to this date will need to be billed using other ",!,"outpatient copayment charges."
G:$G(IBUC) UCPAY
; end IB*2.0*646/656
;
;
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 LTC non-institutional (opt) for CD exemption
I IBXA=8,$$CDEXMPT^IBAECU(DFN,IBFR) W !,"Patient is LTC non-institutional exempt, Catastrophically Disabled" G ADDQ
;
; - check the LTC billing clock
I IBXA>7,IBXA<10 D I IBY<0 W !!,"The patient has no LTC clock active for this date.",! G ADDQ
.; IB*2.0*728
.; get the latest LTC clock
.S (IBCLSTDT,IBCLEDT)=0,IBCLDA=$$FNDOPEN^IBAECU4(DFN)
.I IBCLDA S IBCLZ=^IBA(351.81,IBCLDA,0),IBCLSTDT=$P(IBCLZ,U,3),IBCLEDT=$P(IBCLZ,U,4),IBCLDY=+$P(IBCLZ,U,6)
.; is IBFR within date range of the LTC clock?
.I IBFR<IBCLSTDT D Q
..S IBCLSTDT=+$O(^IBA(351.81,"AE",DFN,IBFR),-1) I IBCLSTDT>0 D Q ; found a previous LTC clock, try to use this one
...S IBCLDA=+$O(^IBA(351.81,"AE",DFN,IBCLSTDT,""),-1) I 'IBCLDA S IBY=-1 Q
...S IBCLDY=+$P(^IBA(351.81,IBCLDA,0),U,6)
...W !!,"This charge will be applied to the following closed LTC clock:"
...W !,"Start Date: ",$$FMTE^XLFDT(IBCLSTDT)," Free Days Remaining: ",IBCLDY
...I IBCLDY W !,"The patient must use his free days first." S IBY=-1 Q
...Q
..S IBY=-1
..Q
.I IBFR>IBCLEDT D Q
..; date of service if past exp.date of the clock - ask user if they want to open a new LTC clock
..I $$ASKLTC() S IBCLDA=$$OPTB^IBAECC(DFN,IBCLDA,IBCLEDT,IBFR) S:'IBCLDA IBY=-1 I IBY'<0,+$P(^IBA(351.81,IBCLDA,0),U,6) W !,"The patient must use his free days first." S IBY=-1 Q
..; user didn't want to open a new clock
..W !!,"The Open LTC Billing Clock detected for the patient has expired."
..W !,"Please Open a New Clock and apply any available Free Days before"
..W !,"continuing to charge this copayment.",!
..D ASKCONT^IBAECC W !
..Q
.; we'll be using the current clock if we got here
.W !!,"This charge will be applied to the following open LTC clock:"
.W !,"Start Date: ",$$FMTE^XLFDT(IBCLSTDT)," Free Days Remaining: ",IBCLDY
.I IBCLDY W !,"The patient must use his free days first." S IBY=-1
.Q
I IBY<0 G ADDQ
; end IB*2.0*728
;
; - 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))!'$$GET1^DIQ(351,IBCLDA_",",16,"I")) D NOCL^IBECEA33 G:IBY<0 ADDQ
;
UCPAY ;IB*2.0*646 Added to allow for skip of clock checks - required for Urgent Care Copays
; - perform outpatient edits
N IBSTOPDA
;
;IB*2.0*678 Modified entire section to allow Dup Check to cancel existing lower copays or tell users they can't add a copay
;IB*2.0*663 Added changes for Urgent Care Visit Tracking
I IBXA=4,IBUC D UCCHRG2^IBECEA36(DFN,IBFR) G ADDQ:IBY<0
;end IB*2.0*646
;
I IBXA=4,'IBUC,$$CHKHRFS^IBAMTS3(DFN,IBFR,IBFR) W !!,"This patient is 'Exempt' from Outpatient Visit charges on that date of service.",! G ADDQ ;IB*2.0*614 (no copayment if HRfS flag)
;IB*2.0*776 start
; get the copay amount
I IBXA=4,'IBUC D G ADDQ:IBY<0
.; 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
.I $G(IBUSNM)["OBSERVATION" D Q
..S IBCHG=50,IBUNIT=1 ;initial copay amount
..S IBDESC=IBUSNM,IBTO=IBFR ;ensure that Billed To and Description are defined.
.D OPT^IBEMTSCU
;IB*2.0*776 end
;
S IBDUPIEN=$$BFCHK^IBECEAU(DFN,IBFR)
I IBXA=4,IBDUPIEN D G ADDQ:'IBCONT
.S IBDPDATA=$$DUPINFO(IBDUPIEN),IBDPXA=$P(IBDPDATA,U,2),IBDPAMT=$P(IBDPDATA,U)
.S IBCONT=0
.I IBDPXA'=4,IBDPXA'=8 D PRTWRN Q
.S IBVST=0
.D PRTWRN ;Print warning message
.I IBCHG>IBDPAMT D Q ; The new Outpatient charge is greater than existing charge.
..S IBCONT=1
..I '$$CANDUP(IBDUPIEN) S IBCONT=0 Q
.I IBUC D
..S IBVST=$$VSTCHK()
..I IBVST D ADDVST^IBECEA36(DFN,IBFR,"",4,5)
;
;IB*2.0*784 - Cleland-Dole Benefit Check
S IBCDSDT=$$GET1^DIQ(350.9,"1,",71.03,"I"),IBCDEDT=$$GET1^DIQ(350.9,"1,",71.04,"I")
I IBFR'<IBCDSDT,IBFR'>IBCDEDT,IBUSNM["CC MH" S IBCDFLG=$$ASKMH^IBECEAMH() G:IBCDFLG=-1 ADDQ G:'IBCDFLG PROC S IBCDCHK=1 ;Cleland Dole Copay Type, definitely eligible. IB*2.0*784
I 'IBCDCHK,$G(IBSTOPDA) D ; Check stop code for Cleland-Dole Eligibility
.S IBSTCD=$$GET1^DIQ(352.5,IBSTOPDA_",",.01,"E")
.S IBCDCHK=$$CDCHK^IBECEAMH(IBSTCD,IBFR)
S NUMVSTFL=$$NUMVSTCK^IBECEAMH(DFN,IBFR)
I IBCDCHK,NUMVSTFL D G ADDQ
.D MESS1^IBECEAMH
.I $$ASKCONT^IBECEAMH()'>0 Q
.D ADDVST^IBECEAMH(DFN,IBFR,"",1)
I IBCDCHK,'NUMVSTFL D MESS2^IBECEAMH ;Alert user that Cleland-Dole max for the year has been reached.
;end IB*2.0*784
;
;If outpatient copay and has passed all other checks, go to PROC
G:IBXA=4 PROC
;
;end IB*2.0*678
;
; - 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:'IBCHG 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
;
S IBCONT=0
I IBXA=8 D G:IBY<1 ADDQ
.S IBY=1 ; assume no duplicate
.S IBDUPIEN=$$BFCHK^IBECEAU(DFN,IBFR)
.; If so, either allow removal of duplicate or prevent user from continuing to bill
.I IBDUPIEN D
..S IBY=0 ;Duplicate found
..; Print Warning message
..D PRTWRN
..; get Duplicate Bill info
..S IBDPDATA=$$DUPINFO(IBDUPIEN),IBDPXA=$P(IBDPDATA,U,2),IBDPAMT=$P(IBDPDATA,U)
..; If an Inpatient Med, warn user and prevent further billing
..I (IBDPXA'=4),(IBDPXA'=8) S IBY=-1 Q
..; If potential charge is greater than the amount already billed
..I IBCHG>IBDPAMT D
...I '$$CANDUP(IBDUPIEN) S IBCONT=0 Q
...S IBCONT=1
;
G:IBXA=8 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,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($S($G(IBREBILL("BILLTO"))'="":IBREBILL("BILLTO"),1:0)) G:IBY<0 ADDQ ; IB*2.0*682
;
;Start- IB*2.0*651
;Check to see if there is another medical copay (inpatient or outpatient) on that same day for this patient.
;If there is, print warning message to user and abort copay entry.
I ((IBXA<4)!(IBXA=9)) D G:IBY<1 ADDQ
.S IBDUPIEN=$$BFCHK^IBECEAU(DFN,IBFR)
.; If so, either allow removal of duplicate or prevent user from continuing to bill
.S IBY=1
.I IBDUPIEN D
..S IBY=0 ;Duplicate found
..; Print Warning message
..D PRTWRN
..; get Duplicate Bill info
..S IBDPDATA=$$DUPINFO(IBDUPIEN),IBDPXA=$P(IBDPDATA,U,2),IBDPAMT=$P(IBDPDATA,U)
..; If an Inpatient Med, warn user and prevent further billing
..I IBDPXA'=4,IBDPXA'=8 S IBY=-1 Q
..; Inpatient automatically forces outpatient copays to cancel
..I $$CANDUP(IBDUPIEN) S IBY=1 Q
;end IB*2.0*651
;end IB*2.0*678
;
I IBXA>0,IBXA<4,IBGMT'=$$ISGMTPT^IBAGMT(DFN,IBTO) W !!,"The patient's GMT Copayment status changed within the specified period!",! G ADDQ
;
;- IB*2.0*663 - check for Free days used in this billing period
I IBXA=9 D G ADDQ:IBY<0
.F IBFEDT=IBFR:1:IBTO I $D(^IBA(351.81,IBCLDA,1,"AC",IBFEDT)) W !!,"One or more of the days in this period is marked as a Free Day." S IBY=-1 Q
;end IB*2.0*663
;
; - 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?
N IBRES,IBBILL ; IB*2.0*682
I 'IBUC,IBXA'=9,$$INDCHK^IBINUT1($S($G(IBTO)>0:IBTO,1:IBFR),DFN) D G ADDQ ; IB*2.0*716
.W !!,"The patient is exempt from this copayment due to Indian Attestation."
.W !,"This patient's Indian Attestation Benefit Start date is ",$$FMTE^XLFDT($P($$INDGET^IBINUT1(DFN),U,2),"2Z")
.Q
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 (for VA RX only per IB*2.0*618) and #350
I IBXA=5,(IBUSNM'["CC"),(IBUSNM'["CHOICE") W !!,"Building the new transaction... " S IBAM=$$ADD^IBARXMN(DFN,"^^"_IBEFDT_"^^P^^"_IBUNIT_"^"_IBCHG_"^"_IBDESC_"^^"_IBCHG_"^0^"_IBSITE_"^^^^^^^"_$G(IBTIER)) 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 ;IB*2.0*663 added space before done to correct display issue.
;
I IBUC D
.; Handle re-billing IB*2.0*682
.I $G(IBREBILL("UC")) D Q
..; get bill # or set it to "on hold" if bill status in file 350 = 8 (on hold)
..S IBBILL=$S($$GET1^DIQ(350,$G(IBN)_",",.05,"I")=8:"ON HOLD",1:$$GET1^DIQ(350,IBEVDA_",",.11,"E"))
..S IBRES=$$UPDATE^IBECEA38(IBREBILL("UC"),2,IBBILL,"",1,"IBRES")
..Q
.;
.D ADDVST^IBECEA36(DFN,IBFR,IBEVDA,2)
.Q
;
;IB*2.0*784 - Cleland-Dole - Update MH DB with billed entry
I IBCDCHK,'NUMVSTFL D
.D MESS2B^IBECEAMH
.D ADDVST^IBECEAMH(DFN,IBFR,IBEVDA,2)
;End IB*2.0*784
;
; - review the special inpatient billing case
I $G(IBSIBC1) D CHK^IBAMTI1(IBSIBC1,IBEVDA)
;
; - handle updating of clock
I IBXA'=8,IBXA'=9,'IBUC D CLUPD^IBECEA32 ;IB*2.0*646
;
ADDQ ; - display error, rebuild list, and quit
; IB*2.0*682 skip list rebuild and killing of some variables if we're coming from ^IBECEA4 - it's done in 'Cancel charge' code
I $G(IBREBILL("EVDT"))="" D
.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 IBCHG,IBDESC,IBIL,IBN,IBND,IBSEQNO,IBTOTL,IBUNIT,IBATYP,IBEVDA,IBXA,IBSL,IBFR,IBTO,IBNOS
.Q
;
K IBMED,IBCLDA,IBCLDT,IBCLDOL,IBCLDAY,IBDG,IBNH,IBBS,IBLIM,IBRTED,IBSIBC,IBSIBC1,IBBG,IBFEEV,IBAM
K IBX,IBDT,IBEVDT,IBARTYP,IBTRAN,IBAFY,IBCVA,IBCLSF,IBDD,VADM,VA,VAERR,IBADJMED
ADDQ1 K IBEXSTAT,IBCATC,IBCVAEL,IBLTCST,IBTIER,IBEFDT,IBFEDT
K:$G(IBREBILL("EVDT"))="" IBCOMMIT ; IB*2.0*682
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
;
;IB*2.0*651
PRTWRN ; Print warning message about medical copayment already applied
;
W !!!,"This patient has already been billed a medical copayment for this date."
W !,"Please review the associated dates and charges for this patient.",!
Q
;
;IB*2.0*678
VSTCHK() ; Ask the user to see if they wish to update the UC Visit Tracking DB
;
N DIR,DIRUT,DUOUT,X,Y,IBY
W !
S IBY=-1 ; Default exit value
S DIR(0)="YA",DIR("A")="Do you want this Urgent Care visit added to the Visit Tracking Database? : "
D ^DIR
W ! ;force a line feed between the messages
Q:$D(DIRUT) IBY
Q:$D(DUOUT) IBY
Q:'Y Y ; user selected No
Q 1 ;Otherwise, the answer was yes
;
DUPINFO(IBIEN) ;Retrieve the needed information from the duplicate bill
;Input - IEN of the Bill already charged on that date
;Output - Amount ^ Billing Group
N IBDATA0,IBDPIEN,IBDPXA
S IBDATA0=$G(^IB(IBIEN,0))
S IBDPIEN=$P(IBDATA0,U,3)
S IBDPXA=$$GET1^DIQ(350.1,IBDPIEN_",",.11,"I")
Q $P(IBDATA0,U,7)_U_IBDPXA
;
CANDUP(IBN) ;Cancel the duplicate copay if the user wishes to.
;
;INPUT - IBN - IEN for the Copay to be cancelled (File 350)
;OUTPUT - 0 - Didn't Cancel the copay
; 1 - Cancelled the Copay
;
;Display Duplicate Copay
;Get the info
N IBCNRSLT,IBFRDT,IBTODT,IBACTY,IBSTCD,IBBLNM,IBSTAT,IBCHRG,IBI
N DIR,DIRUT,DUOUT,X,Y,IBY
S IBFRDT=$$GET1^DIQ(350,IBN_",",.14,"I")
S IBFRDT=$$FMTE^XLFDT(IBFRDT,"2Z")
S IBTODT=$$GET1^DIQ(350,IBN_",",.15,"I")
S IBTODT=$$FMTE^XLFDT(IBTODT,"2Z")
S IBACTY=$$GET1^DIQ(350,IBN_",",.03,"E")
S IBSTCD=$$GET1^DIQ(350,IBN_",",.2,"E")
S IBSTAT=$$GET1^DIQ(350,IBN_",",.05,"E")
S IBBLNM=$$GET1^DIQ(350,IBN_",",.11,"E")
S IBCHRG=$$GET1^DIQ(350,IBN_",",.07,"E")
W !,"BILL",?10,"BILL",?40,"STOP",?45,"BILL",!
W "FROM",?10," TO",?21,"CHARGE TYPE",?40,"CODE",?45,"NUMBER",?60,"STATUS",?70,"CHARGE",!
F IBI=1:1:80 W "-"
W !,IBFRDT,?10,IBTODT,?21,$E(IBACTY,1,17),?40,IBSTCD,?45,IBBLNM,?60,IBSTAT,?70,IBCHRG,!
;
N DIR,DIRUT,DUOUT,X,Y,IBY
W ! ;force a line feed between the messages
S IBY=-1 ; Default exit value
S DIR(0)="YA"
S DIR("A",1)="Do you wish to cancel this existing copayment and continue billing the current",DIR("A")="copayment? : "
D ^DIR
S IBY=+Y
W ! ;force a line feed between the messages
;
;Quit if user does not answer yes.
I +IBY<1 D Q 0
.W !,"The existing copayment was not cancelled. "
.Q
; Cancel the copay.
S IBCNRSLT=$$CANCAPI^IBECEA4(IBN)
I +$G(IBCNRSLT)<0 D Q 0
.W !!,"The copayment was not cancelled."
.Q
W !!,"The copayment was cancelled. Please continue adding the new copay."
;
R !!,?10,"Press any key to continue. ",IBX:DTIME
;
Q 1
;
ASKLTC() ; LTC clock confirmation prompt IB*2.0*728
;
; returns 1 for "yes", or 0 otherwise
;
N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
W !
S DIR("A",1)="The Date of Service entered is beyond the end of the current clock."
S DIR("A")="Do you wish to close this LTC clock and start a new LTC clock? (Y/N): "
S DIR(0)="YAO"
D ^DIR
Q $S(+Y=1:1,1:0)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBECEA3 19338 printed Oct 16, 2024@18:21:55 Page 2
IBECEA3 ;ALB/CPM - Cancel/Edit/Add... Add a Charge ;30-MAR-93
+1 ;;2.0;INTEGRATED BILLING;**7,57,52,132,150,153,166,156,167,176,198,188,183,202,240,312,402,454,563,614,618,646,651,656,663,677,678,682,728,716,704,776,784**;21-MAR-94;Build 8
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
ADD ; Add a Charge protocol
+1 ;IB*2.0*618 Add IBUSNM IB*2.0*646 Add IBUC
NEW IBGMT,IBGMTR,IBUSNM,IBUC
+2 ; IB*2.0*678 added
NEW IBDUPIEN,IBDPDATA,IBDPXA,IBDPAMT,IBCONT,IBVST
+3 ; IB*2.0*728
NEW IBCLDA,IBCLDY,IBCLEDT,IBCLST,IBCLSTDT,IBCLZ
+4 ; IB*2.0*784
NEW IBSTCD,IBCDCHK,IBCDEDT,IBCDFLG,IBCDSDT,NUMVSTFL
+5 ; IB*2.0*784
SET (IBCDCHK,NUMVSTFL)=""
+6 ; Check for IB EDIT key. If not present
+7 IF '$$IBEDIT^IBECEA36
QUIT
+8 SET (IBGMT,IBGMTR,IBUC)=0
+9 SET IBCOMMIT=0
SET IBEXSTAT=$$RXST^IBARXEU(DFN,DT)
SET IBCATC=$$BILST^DGMTUB(DFN)
SET IBCVAEL=$$CVA^IBAUTL5(DFN)
SET IBLTCST=$$LTCST^IBAECU(DFN,DT,1)
+10 ; clear screen and begin
+11 DO CLOCK^IBAUTL3
IF 'IBCLDA
SET (IBMED,IBCLDAY,IBCLDOL,IBCLDT)=0
+12 DO HDR^IBECEAU("A D D")
+13 IF IBY<0
DO NODED^IBECEAU3
GOTO ADDQ
+14 ; ask for the charge type
+15 DO CHTYP^IBECEA33
if IBY<0
GOTO ADDQ
+16 ;
+17 ;***IB*2.0*618 change to add more Action Types to this list...
+18 ; Allow user to add an extra "co-payment" charge if the Action Type
+19 ; selected is an Outpatient FEE BASIS, CHOICE, CC or CCN charge type
+20 NEW IBAFEE
+21 SET IBUSNM=$PIECE($GET(^IBE(350.1,+$GET(IBATYP),0)),"^",8)
+22 IF IBUSNM'=""
Begin DoDot:1
+23 IF IBUSNM="FEE SERVICE/OUTPATIENT"
SET IBAFEE=IBATYP
QUIT
+24 IF (IBUSNM["CC")!(IBUSNM["CHOICE")
Begin DoDot:2
+25 ;IB*2.0*646 added URGENT
IF (IBUSNM["OPT")!(IBUSNM["OUTPATIENT")!(IBUSNM["URGENT")
SET IBAFEE=IBATYP
End DoDot:2
End DoDot:1
+26 ;*** END IB*2.0*618 ***
+27 ;
+28 ; - process CHAMPVA charges
+29 IF IBXA=6
DO CHMPVA^IBECEA32
GOTO ADDQ
+30 ;
+31 ; - process TRICARE charges
+32 IF IBXA=7
DO CUS^IBECEA35
GOTO ADDQ
+33 ;
+34 ; - display MT billing clock data
+35 IF IBXA=2
IF $PIECE($GET(^IBE(350.1,+IBATYP,0)),"^",8)'["NHCU"
IF IBCLDAY>90
SET IBMED=IBMED/2
+36 IF IBXA=1
IF IBCLDAY>90
DO MED^IBECEA34
if IBY<0
GOTO ADDQ
+37 IF "^1^2^3^"[("^"_IBXA_"^")
IF IBCLDA
WRITE !!," ** Active Billing Clock ** # Inpt Days: ",IBCLDAY," ",$$INPT^IBECEAU(IBCLDAY)," 90 days: $",+IBCLDOL,!
+38 ;
+39 ; - if LTC OPT (non-institutional) and CD display message of warning
+40 IF IBXA=8
IF $$CDEXMPT^IBAECU(DFN,DT)
WRITE !!," ** Patient is currently Catastrophically Disabled",!
+41 ;
+42 ; - ask date, units and maybe tier for rx copay charge
+43 IF IBXA=5
Begin DoDot:1
+44 NEW IBA,IBB,IBC,IBX
+45 ;; IBREBILL array is defined in REBILL^IBECEA4
+46 ; IB*2.0*682
SET IBLIM=DT
DO FR^IBECEAU2($SELECT($GET(IBREBILL("EVDT"))'="":IBREBILL("EVDT"),1:0))
if IBY<0
QUIT
+47 SET (IBTO,IBEFDT)=IBFR
+48 ;
+49 ;PRCA*4.5*338 - if Community Care RX copay, set event date
+50 SET IBEVDA="*"
SET IBEVDT=IBEFDT
+51 ;
+52 ; ask tier if needed
+53 SET IBTIER=$$TIER^IBECEAU2(IBATYP,IBEFDT)
if IBY<0
QUIT
+54 ;
+55 ; ask units
+56 DO UNIT^IBECEAU2(0)
if IBY<0
QUIT
+57 ;
+58 ; has patient been previously tracked for cap info
+59 DO TRACK^IBARXMN(DFN)
+60 ;
+61 DO CTBB^IBECEAU3
+62 ;
+63 ; check if above cap
+64 IF IBY'<0
Begin DoDot:2
+65 NEW IBB,IBN,DIR,DIRUT,DUOUT,DTOUT,X,Y
+66 DO NEW^IBARXMC(1,IBCHG,IBFR,.IBB,.IBN)
if 'IBN
QUIT
+67 ;
+68 ; display message ask to proceed
+69 WRITE !!,"This charge will put the patient > $",$JUSTIFY(IBN,0,2)," above their cap amount."
+70 SET DIR(0)="Y"
SET DIR("A")="Okay to proceed"
DO ^DIR
if 'Y
SET IBY=-1
+71 ;
End DoDot:2
End DoDot:1
if IBY<0
GOTO ADDQ
GOTO PROC
+72 SET IBLIM=$SELECT(IBXA=4!(IBXA=3):DT,1:$$FMADD^XLFDT(DT,-1))
+73 ;
FR ; - ask 'bill from' date
+1 ; IB*2.0*682
DO FR^IBECEAU2($SELECT($GET(IBREBILL("BILLFR"))'="":IBREBILL("BILLFR"),1:0))
+2 ;IB*2.0*646/656
+3 ; If Urgent Care copay, skip clock checks, go to prompt for copay amount.
+4 IF $GET(IBUC)
IF (IBFR<3190606)
Begin DoDot:1
+5 WRITE !!,"The Urgent Care Copayment/Mission Act legislation went into effect on 6/6/19. "
+6 WRITE !,"Dates of service prior to this date will need to be billed using other ",!,"outpatient copayment charges."
End DoDot:1
GOTO ADDQ
+7 if $GET(IBUC)
GOTO UCPAY
+8 ; end IB*2.0*646/656
+9 ;
+10 ;
+11 ;GMT Copayment Status
SET IBGMT=$$ISGMTPT^IBAGMT(DFN,IBFR)
SET IBGMTR=0
+12 IF IBGMT>0
IF IBXA>0
IF IBXA<4
WRITE !,"The patient has GMT Copayment Status."
+13 ; - check the MT billing clock
+14 IF IBXA'=8
IF IBXA'=9
DO CLMSG^IBECEA33
if IBY<0
GOTO ADDQ
+15 ;Adjust Deductible for GMT patient
+16 IF IBGMT>0
IF IBXA>0
IF IBXA<4
IF $GET(IBMED)
SET IBMED=$$REDUCE^IBAGMT(IBMED)
WRITE !,"Medicare Deductible reduced due to GMT Copayment Status ($",$JUSTIFY(IBMED,"",2),")."
+17 ;
+18 ; - check LTC non-institutional (opt) for CD exemption
+19 IF IBXA=8
IF $$CDEXMPT^IBAECU(DFN,IBFR)
WRITE !,"Patient is LTC non-institutional exempt, Catastrophically Disabled"
GOTO ADDQ
+20 ;
+21 ; - check the LTC billing clock
+22 IF IBXA>7
IF IBXA<10
Begin DoDot:1
+23 ; IB*2.0*728
+24 ; get the latest LTC clock
+25 SET (IBCLSTDT,IBCLEDT)=0
SET IBCLDA=$$FNDOPEN^IBAECU4(DFN)
+26 IF IBCLDA
SET IBCLZ=^IBA(351.81,IBCLDA,0)
SET IBCLSTDT=$PIECE(IBCLZ,U,3)
SET IBCLEDT=$PIECE(IBCLZ,U,4)
SET IBCLDY=+$PIECE(IBCLZ,U,6)
+27 ; is IBFR within date range of the LTC clock?
+28 IF IBFR<IBCLSTDT
Begin DoDot:2
+29 ; found a previous LTC clock, try to use this one
SET IBCLSTDT=+$ORDER(^IBA(351.81,"AE",DFN,IBFR),-1)
IF IBCLSTDT>0
Begin DoDot:3
+30 SET IBCLDA=+$ORDER(^IBA(351.81,"AE",DFN,IBCLSTDT,""),-1)
IF 'IBCLDA
SET IBY=-1
QUIT
+31 SET IBCLDY=+$PIECE(^IBA(351.81,IBCLDA,0),U,6)
+32 WRITE !!,"This charge will be applied to the following closed LTC clock:"
+33 WRITE !,"Start Date: ",$$FMTE^XLFDT(IBCLSTDT)," Free Days Remaining: ",IBCLDY
+34 IF IBCLDY
WRITE !,"The patient must use his free days first."
SET IBY=-1
QUIT
+35 QUIT
End DoDot:3
QUIT
+36 SET IBY=-1
+37 QUIT
End DoDot:2
QUIT
+38 IF IBFR>IBCLEDT
Begin DoDot:2
+39 ; date of service if past exp.date of the clock - ask user if they want to open a new LTC clock
+40 IF $$ASKLTC()
SET IBCLDA=$$OPTB^IBAECC(DFN,IBCLDA,IBCLEDT,IBFR)
if 'IBCLDA
SET IBY=-1
IF IBY'<0
IF +$PIECE(^IBA(351.81,IBCLDA,0),U,6)
WRITE !,"The patient must use his free days first."
SET IBY=-1
QUIT
+41 ; user didn't want to open a new clock
+42 WRITE !!,"The Open LTC Billing Clock detected for the patient has expired."
+43 WRITE !,"Please Open a New Clock and apply any available Free Days before"
+44 WRITE !,"continuing to charge this copayment.",!
+45 DO ASKCONT^IBAECC
WRITE !
+46 QUIT
End DoDot:2
QUIT
+47 ; we'll be using the current clock if we got here
+48 WRITE !!,"This charge will be applied to the following open LTC clock:"
+49 WRITE !,"Start Date: ",$$FMTE^XLFDT(IBCLSTDT)," Free Days Remaining: ",IBCLDY
+50 IF IBCLDY
WRITE !,"The patient must use his free days first."
SET IBY=-1
+51 QUIT
End DoDot:1
IF IBY<0
WRITE !!,"The patient has no LTC clock active for this date.",!
GOTO ADDQ
+52 IF IBY<0
GOTO ADDQ
+53 ; end IB*2.0*728
+54 ;
+55 ; - calculate the MT inpt copay charge
+56 IF IBXA=2
SET IBDT=IBFR
DO COPAY^IBAUTL2
if IBY<0
GOTO ADDQ
if IBGMT>0
SET IBGMTR=1
SET IBCHG=$$REDUCE^IBAGMT(IBCHG)
IF IBCHG+IBCLDOL<IBMED
WRITE *7," ($",IBCHG,"/day)"
if IBGMTR
WRITE " GMT Rate"
+57 ;
+58 ; - find the correct clock from the 'bill from' date (ignore LTC)
+59 IF IBXA'=8
IF IBXA'=9
IF ('IBCLDA!(IBCLDA&(IBFR<IBCLDT))!'$$GET1^DIQ(351,IBCLDA_",",16,"I"))
DO NOCL^IBECEA33
if IBY<0
GOTO ADDQ
+60 ;
UCPAY ;IB*2.0*646 Added to allow for skip of clock checks - required for Urgent Care Copays
+1 ; - perform outpatient edits
+2 NEW IBSTOPDA
+3 ;
+4 ;IB*2.0*678 Modified entire section to allow Dup Check to cancel existing lower copays or tell users they can't add a copay
+5 ;IB*2.0*663 Added changes for Urgent Care Visit Tracking
+6 IF IBXA=4
IF IBUC
DO UCCHRG2^IBECEA36(DFN,IBFR)
if IBY<0
GOTO ADDQ
+7 ;end IB*2.0*646
+8 ;
+9 ;IB*2.0*614 (no copayment if HRfS flag)
IF IBXA=4
IF 'IBUC
IF $$CHKHRFS^IBAMTS3(DFN,IBFR,IBFR)
WRITE !!,"This patient is 'Exempt' from Outpatient Visit charges on that date of service.",!
GOTO ADDQ
+10 ;IB*2.0*776 start
+11 ; get the copay amount
+12 IF IBXA=4
IF 'IBUC
Begin DoDot:1
+13 ; for visits prior to 12/6/01 or FEE
+14 IF IBFR<3011206!($GET(IBAFEE))
DO OPT^IBECEA33
QUIT
+15 ; for visits on or after 12/5/01
+16 IF $GET(IBUSNM)["OBSERVATION"
Begin DoDot:2
+17 ;initial copay amount
SET IBCHG=50
SET IBUNIT=1
+18 ;ensure that Billed To and Description are defined.
SET IBDESC=IBUSNM
SET IBTO=IBFR
End DoDot:2
QUIT
+19 DO OPT^IBEMTSCU
End DoDot:1
if IBY<0
GOTO ADDQ
+20 ;IB*2.0*776 end
+21 ;
+22 SET IBDUPIEN=$$BFCHK^IBECEAU(DFN,IBFR)
+23 IF IBXA=4
IF IBDUPIEN
Begin DoDot:1
+24 SET IBDPDATA=$$DUPINFO(IBDUPIEN)
SET IBDPXA=$PIECE(IBDPDATA,U,2)
SET IBDPAMT=$PIECE(IBDPDATA,U)
+25 SET IBCONT=0
+26 IF IBDPXA'=4
IF IBDPXA'=8
DO PRTWRN
QUIT
+27 SET IBVST=0
+28 ;Print warning message
DO PRTWRN
+29 ; The new Outpatient charge is greater than existing charge.
IF IBCHG>IBDPAMT
Begin DoDot:2
+30 SET IBCONT=1
+31 IF '$$CANDUP(IBDUPIEN)
SET IBCONT=0
QUIT
End DoDot:2
QUIT
+32 IF IBUC
Begin DoDot:2
+33 SET IBVST=$$VSTCHK()
+34 IF IBVST
DO ADDVST^IBECEA36(DFN,IBFR,"",4,5)
End DoDot:2
End DoDot:1
if 'IBCONT
GOTO ADDQ
+35 ;
+36 ;IB*2.0*784 - Cleland-Dole Benefit Check
+37 SET IBCDSDT=$$GET1^DIQ(350.9,"1,",71.03,"I")
SET IBCDEDT=$$GET1^DIQ(350.9,"1,",71.04,"I")
+38 ;Cleland Dole Copay Type, definitely eligible. IB*2.0*784
IF IBFR'<IBCDSDT
IF IBFR'>IBCDEDT
IF IBUSNM["CC MH"
SET IBCDFLG=$$ASKMH^IBECEAMH()
if IBCDFLG=-1
GOTO ADDQ
if 'IBCDFLG
GOTO PROC
SET IBCDCHK=1
+39 ; Check stop code for Cleland-Dole Eligibility
IF 'IBCDCHK
IF $GET(IBSTOPDA)
Begin DoDot:1
+40 SET IBSTCD=$$GET1^DIQ(352.5,IBSTOPDA_",",.01,"E")
+41 SET IBCDCHK=$$CDCHK^IBECEAMH(IBSTCD,IBFR)
End DoDot:1
+42 SET NUMVSTFL=$$NUMVSTCK^IBECEAMH(DFN,IBFR)
+43 IF IBCDCHK
IF NUMVSTFL
Begin DoDot:1
+44 DO MESS1^IBECEAMH
+45 IF $$ASKCONT^IBECEAMH()'>0
QUIT
+46 DO ADDVST^IBECEAMH(DFN,IBFR,"",1)
End DoDot:1
GOTO ADDQ
+47 ;Alert user that Cleland-Dole max for the year has been reached.
IF IBCDCHK
IF 'NUMVSTFL
DO MESS2^IBECEAMH
+48 ;end IB*2.0*784
+49 ;
+50 ;If outpatient copay and has passed all other checks, go to PROC
+51 if IBXA=4
GOTO PROC
+52 ;
+53 ;end IB*2.0*678
+54 ;
+55 ; - if LTC outpatient calculate the charge
+56 IF IBXA=8
Begin DoDot:1
+57 ; is this day already a free day
+58 IF $DATA(^IBA(351.81,IBCLDA,1,"AC",IBFR))
WRITE !!,"This day is already marked as a Free Day."
SET IBY=-1
End DoDot:1
if IBY<0
GOTO ADDQ
SET (IBDT,IBTO,IBEVDT)=IBFR
SET IBDESC=$PIECE(^IBE(350.1,IBATYP,0),"^",8)
SET IBUNIT=1
SET IBEVDA="*"
DO COST^IBAUTL2
DO CALC^IBAECO
DO CTBB^IBECEAU3
if 'IBCHG
GOTO ADDQ
+59 ;
+60 SET IBCONT=0
+61 IF IBXA=8
Begin DoDot:1
+62 ; assume no duplicate
SET IBY=1
+63 SET IBDUPIEN=$$BFCHK^IBECEAU(DFN,IBFR)
+64 ; If so, either allow removal of duplicate or prevent user from continuing to bill
+65 IF IBDUPIEN
Begin DoDot:2
+66 ;Duplicate found
SET IBY=0
+67 ; Print Warning message
+68 DO PRTWRN
+69 ; get Duplicate Bill info
+70 SET IBDPDATA=$$DUPINFO(IBDUPIEN)
SET IBDPXA=$PIECE(IBDPDATA,U,2)
SET IBDPAMT=$PIECE(IBDPDATA,U)
+71 ; If an Inpatient Med, warn user and prevent further billing
+72 IF (IBDPXA'=4)
IF (IBDPXA'=8)
SET IBY=-1
QUIT
+73 ; If potential charge is greater than the amount already billed
+74 IF IBCHG>IBDPAMT
Begin DoDot:3
+75 IF '$$CANDUP(IBDUPIEN)
SET IBCONT=0
QUIT
+76 SET IBCONT=1
End DoDot:3
End DoDot:2
End DoDot:1
if IBY<1
GOTO ADDQ
+77 ;
+78 if IBXA=8
GOTO PROC
+79 ;
+80 ; - find per diem charge and description
+81 IF IBXA=3
Begin DoDot:1
+82 NEW IBDT
SET IBDT=IBFR
SET IBGMTR=0
DO COST^IBAUTL2
+83 IF IBGMT>0
SET IBGMTR=1
SET IBCHG=$$REDUCE^IBAGMT(IBCHG)
+84 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
+85 ;
+86 ; - calculate charge for the inpatient copay
+87 IF IBXA=2
IF IBCHG+IBCLDOL'<IBMED
SET IBCHG=IBMED-IBCLDOL
SET IBUNIT=1
SET IBTO=IBFR
DO CTBB^IBECEAU3
GOTO EV
+88 ;
TO ; - ask 'bill to' date
+1 ; IB*2.0*682
DO TO^IBECEAU2($SELECT($GET(IBREBILL("BILLTO"))'="":IBREBILL("BILLTO"),1:0))
if IBY<0
GOTO ADDQ
+2 ;
+3 ;Start- IB*2.0*651
+4 ;Check to see if there is another medical copay (inpatient or outpatient) on that same day for this patient.
+5 ;If there is, print warning message to user and abort copay entry.
+6 IF ((IBXA<4)!(IBXA=9))
Begin DoDot:1
+7 SET IBDUPIEN=$$BFCHK^IBECEAU(DFN,IBFR)
+8 ; If so, either allow removal of duplicate or prevent user from continuing to bill
+9 SET IBY=1
+10 IF IBDUPIEN
Begin DoDot:2
+11 ;Duplicate found
SET IBY=0
+12 ; Print Warning message
+13 DO PRTWRN
+14 ; get Duplicate Bill info
+15 SET IBDPDATA=$$DUPINFO(IBDUPIEN)
SET IBDPXA=$PIECE(IBDPDATA,U,2)
SET IBDPAMT=$PIECE(IBDPDATA,U)
+16 ; If an Inpatient Med, warn user and prevent further billing
+17 IF IBDPXA'=4
IF IBDPXA'=8
SET IBY=-1
QUIT
+18 ; Inpatient automatically forces outpatient copays to cancel
+19 IF $$CANDUP(IBDUPIEN)
SET IBY=1
QUIT
End DoDot:2
End DoDot:1
if IBY<1
GOTO ADDQ
+20 ;end IB*2.0*651
+21 ;end IB*2.0*678
+22 ;
+23 IF IBXA>0
IF IBXA<4
IF IBGMT'=$$ISGMTPT^IBAGMT(DFN,IBTO)
WRITE !!,"The patient's GMT Copayment status changed within the specified period!",!
GOTO ADDQ
+24 ;
+25 ;- IB*2.0*663 - check for Free days used in this billing period
+26 IF IBXA=9
Begin DoDot:1
+27 FOR IBFEDT=IBFR:1:IBTO
IF $DATA(^IBA(351.81,IBCLDA,1,"AC",IBFEDT))
WRITE !!,"One or more of the days in this period is marked as a Free Day."
SET IBY=-1
QUIT
End DoDot:1
if IBY<0
GOTO ADDQ
+28 ;end IB*2.0*663
+29 ;
+30 ; - calculate unit charge for LTC inpatient in IBCHG
+31 IF IBXA=9
SET IBDT=IBFR
SET IBEVDA=$$EVF^IBECEA31(DFN,IBFR,IBTO,IBNH)
SET IBEVDT=$EXTRACT(IBFR,1,5)_"01"
if IBEVDA<1
Begin DoDot:1
+32 DO NOEV^IBECEA31
IF '$GET(IBDG)!(IBY<0)
SET IBY=-1
QUIT
+33 ; - build the event record
+34 NEW IBNHLTC
SET IBNHLTC=1
DO ADEV^IBECEA31
End DoDot:1
if IBY<0
GOTO ADDQ
DO COST^IBAUTL2
IF $EXTRACT(IBFR,1,5)'=$EXTRACT(IBTO,1,5)
WRITE !!," LTC Copayment charges cannot go from one month to another."
GOTO ADDQ
+35 ;
+36 ; - calculate units and total charge
+37 SET IBUNIT=$$FMDIFF^XLFDT(IBTO,IBFR)
if IBXA'=3!(IBFR=IBTO)
SET IBUNIT=IBUNIT+1
+38 IF IBXA=1
if IBGMT>0
Begin DoDot:1
+39 SET IBGMTR=1
+40 WRITE !,"The patient has GMT Copayment Status! GMT rate must be applied.",!
End DoDot:1
DO FEPR^IBECEA32
if IBY<0
GOTO ADDQ
GOTO EV
+41 SET IBCHG=IBCHG*IBUNIT
if IBXA=2
SET IBCHG=$SELECT(IBCLDOL+IBCHG>IBMED:IBMED-IBCLDOL,1:IBCHG)
+42 ;
+43 ; adjust the LTC charge based on the calculated copay cap
+44 IF IBXA=9
DO CALC^IBAECI
if IBY<1!('IBCHG)
GOTO ADDQ
SET IBDESC="LTC INPATIENT COPAY"
+45 ;
+46 DO CTBB^IBECEAU3
if IBXA=3!(IBXA=9)
WRITE " (for ",IBUNIT," day",$EXTRACT("s",IBUNIT>1),")"
if IBGMTR
WRITE " GMT Rate"
+47 ;
EV ; - find event record, or select admission for linkage
+1 IF IBXA'=9
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 ",$$TYP(),"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 ;
+9 ;
PROC ; - okay to proceed?
+1 ; IB*2.0*682
NEW IBRES,IBBILL
+2 ; IB*2.0*716
IF 'IBUC
IF IBXA'=9
IF $$INDCHK^IBINUT1($SELECT($GET(IBTO)>0:IBTO,1:IBFR),DFN)
Begin DoDot:1
+3 WRITE !!,"The patient is exempt from this copayment due to Indian Attestation."
+4 WRITE !,"This patient's Indian Attestation Benefit Start date is ",$$FMTE^XLFDT($PIECE($$INDGET^IBINUT1(DFN),U,2),"2Z")
+5 QUIT
End DoDot:1
GOTO ADDQ
+6 DO PROC^IBECEAU4("add")
if IBY<0
GOTO ADDQ
+7 ;
+8 ; - build the event record first if necessary
+9 IF $GET(IBDG)
IF IBXA'=9
DO @("ADEV^IBECEA3"_$SELECT($GET(IBFEEV):4,1:1))
if IBY<0
GOTO ADDQ
+10 ;
+11 ; - disposition the special inpatient billing case, if necessary
+12 IF $GET(IBSIBC)
DO CEA^IBAMTI1(IBSIBC,IBEVDA)
+13 ;
+14 ; - generate entry in file #354.71 (for VA RX only per IB*2.0*618) and #350
+15 IF IBXA=5
IF (IBUSNM'["CC")
IF (IBUSNM'["CHOICE")
WRITE !!,"Building the new transaction... "
SET IBAM=$$ADD^IBARXMN(DFN,"^^"_IBEFDT_"^^P^^"_IBUNIT_"^"_IBCHG_"^"_IBDESC_"^^"_IBCHG_"^0^"_IBSITE_"^^^^^^^"_$GET(IBTIER))
if IBAM<0
GOTO ADDQ
+16 DO ADD^IBECEAU3
if IBY<0
GOTO ADDQ
WRITE " done."
+17 ;
+18 ; - pass the charge off to AR on-line
+19 WRITE !,"Passing the charge directly to Accounts Receivable... "
+20 ;IB*2.0*663 added space before done to correct display issue.
DO PASSCH^IBECEA22
if IBY>0
WRITE " done."
if IBY<0
GOTO ADDQ
+21 ;
+22 IF IBUC
Begin DoDot:1
+23 ; Handle re-billing IB*2.0*682
+24 IF $GET(IBREBILL("UC"))
Begin DoDot:2
+25 ; get bill # or set it to "on hold" if bill status in file 350 = 8 (on hold)
+26 SET IBBILL=$SELECT($$GET1^DIQ(350,$GET(IBN)_",",.05,"I")=8:"ON HOLD",1:$$GET1^DIQ(350,IBEVDA_",",.11,"E"))
+27 SET IBRES=$$UPDATE^IBECEA38(IBREBILL("UC"),2,IBBILL,"",1,"IBRES")
+28 QUIT
End DoDot:2
QUIT
+29 ;
+30 DO ADDVST^IBECEA36(DFN,IBFR,IBEVDA,2)
+31 QUIT
End DoDot:1
+32 ;
+33 ;IB*2.0*784 - Cleland-Dole - Update MH DB with billed entry
+34 IF IBCDCHK
IF 'NUMVSTFL
Begin DoDot:1
+35 DO MESS2B^IBECEAMH
+36 DO ADDVST^IBECEAMH(DFN,IBFR,IBEVDA,2)
End DoDot:1
+37 ;End IB*2.0*784
+38 ;
+39 ; - review the special inpatient billing case
+40 IF $GET(IBSIBC1)
DO CHK^IBAMTI1(IBSIBC1,IBEVDA)
+41 ;
+42 ; - handle updating of clock
+43 ;IB*2.0*646
IF IBXA'=8
IF IBXA'=9
IF 'IBUC
DO CLUPD^IBECEA32
+44 ;
ADDQ ; - display error, rebuild list, and quit
+1 ; IB*2.0*682 skip list rebuild and killing of some variables if we're coming from ^IBECEA4 - it's done in 'Cancel charge' code
+2 IF $GET(IBREBILL("EVDT"))=""
Begin DoDot:1
+3 if IBY<0
DO ERR^IBECEAU4
DO PAUSE^IBECEAU
SET VALMBCK="R"
+4 IF IBCOMMIT
SET IBBG=VALMBG
WRITE !,"Rebuilding list of charges..."
DO ARRAY^IBECEA0
SET VALMBG=IBBG
+5 KILL IBCHG,IBDESC,IBIL,IBN,IBND,IBSEQNO,IBTOTL,IBUNIT,IBATYP,IBEVDA,IBXA,IBSL,IBFR,IBTO,IBNOS
+6 QUIT
End DoDot:1
+7 ;
+8 KILL IBMED,IBCLDA,IBCLDT,IBCLDOL,IBCLDAY,IBDG,IBNH,IBBS,IBLIM,IBRTED,IBSIBC,IBSIBC1,IBBG,IBFEEV,IBAM
+9 KILL IBX,IBDT,IBEVDT,IBARTYP,IBTRAN,IBAFY,IBCVA,IBCLSF,IBDD,VADM,VA,VAERR,IBADJMED
ADDQ1 KILL IBEXSTAT,IBCATC,IBCVAEL,IBLTCST,IBTIER,IBEFDT,IBFEDT
+1 ; IB*2.0*682
if $GET(IBREBILL("EVDT"))=""
KILL IBCOMMIT
+2 QUIT
+3 ;
+4 ;
TYP() ; Return descriptive admission type.
+1 NEW X
SET X=""
+2 IF IBNH'=2
GOTO TYPQ
+3 IF $GET(IBADJMED)
SET X=$SELECT(IBADJMED=1:"C",1:"H")
+4 IF '$TEST
SET X=$SELECT($PIECE($GET(^IBE(350.1,+IBATYP,0)),"^")["NHCU":"C",1:"H")
+5 SET X=$SELECT(X="C":"CNH ",1:"Contract Hospital ")
TYPQ QUIT X
+1 ;
+2 ;IB*2.0*651
PRTWRN ; Print warning message about medical copayment already applied
+1 ;
+2 WRITE !!!,"This patient has already been billed a medical copayment for this date."
+3 WRITE !,"Please review the associated dates and charges for this patient.",!
+4 QUIT
+5 ;
+6 ;IB*2.0*678
VSTCHK() ; Ask the user to see if they wish to update the UC Visit Tracking DB
+1 ;
+2 NEW DIR,DIRUT,DUOUT,X,Y,IBY
+3 WRITE !
+4 ; Default exit value
SET IBY=-1
+5 SET DIR(0)="YA"
SET DIR("A")="Do you want this Urgent Care visit added to the Visit Tracking Database? : "
+6 DO ^DIR
+7 ;force a line feed between the messages
WRITE !
+8 if $DATA(DIRUT)
QUIT IBY
+9 if $DATA(DUOUT)
QUIT IBY
+10 ; user selected No
if 'Y
QUIT Y
+11 ;Otherwise, the answer was yes
QUIT 1
+12 ;
DUPINFO(IBIEN) ;Retrieve the needed information from the duplicate bill
+1 ;Input - IEN of the Bill already charged on that date
+2 ;Output - Amount ^ Billing Group
+3 NEW IBDATA0,IBDPIEN,IBDPXA
+4 SET IBDATA0=$GET(^IB(IBIEN,0))
+5 SET IBDPIEN=$PIECE(IBDATA0,U,3)
+6 SET IBDPXA=$$GET1^DIQ(350.1,IBDPIEN_",",.11,"I")
+7 QUIT $PIECE(IBDATA0,U,7)_U_IBDPXA
+8 ;
CANDUP(IBN) ;Cancel the duplicate copay if the user wishes to.
+1 ;
+2 ;INPUT - IBN - IEN for the Copay to be cancelled (File 350)
+3 ;OUTPUT - 0 - Didn't Cancel the copay
+4 ; 1 - Cancelled the Copay
+5 ;
+6 ;Display Duplicate Copay
+7 ;Get the info
+8 NEW IBCNRSLT,IBFRDT,IBTODT,IBACTY,IBSTCD,IBBLNM,IBSTAT,IBCHRG,IBI
+9 NEW DIR,DIRUT,DUOUT,X,Y,IBY
+10 SET IBFRDT=$$GET1^DIQ(350,IBN_",",.14,"I")
+11 SET IBFRDT=$$FMTE^XLFDT(IBFRDT,"2Z")
+12 SET IBTODT=$$GET1^DIQ(350,IBN_",",.15,"I")
+13 SET IBTODT=$$FMTE^XLFDT(IBTODT,"2Z")
+14 SET IBACTY=$$GET1^DIQ(350,IBN_",",.03,"E")
+15 SET IBSTCD=$$GET1^DIQ(350,IBN_",",.2,"E")
+16 SET IBSTAT=$$GET1^DIQ(350,IBN_",",.05,"E")
+17 SET IBBLNM=$$GET1^DIQ(350,IBN_",",.11,"E")
+18 SET IBCHRG=$$GET1^DIQ(350,IBN_",",.07,"E")
+19 WRITE !,"BILL",?10,"BILL",?40,"STOP",?45,"BILL",!
+20 WRITE "FROM",?10," TO",?21,"CHARGE TYPE",?40,"CODE",?45,"NUMBER",?60,"STATUS",?70,"CHARGE",!
+21 FOR IBI=1:1:80
WRITE "-"
+22 WRITE !,IBFRDT,?10,IBTODT,?21,$EXTRACT(IBACTY,1,17),?40,IBSTCD,?45,IBBLNM,?60,IBSTAT,?70,IBCHRG,!
+23 ;
+24 NEW DIR,DIRUT,DUOUT,X,Y,IBY
+25 ;force a line feed between the messages
WRITE !
+26 ; Default exit value
SET IBY=-1
+27 SET DIR(0)="YA"
+28 SET DIR("A",1)="Do you wish to cancel this existing copayment and continue billing the current"
SET DIR("A")="copayment? : "
+29 DO ^DIR
+30 SET IBY=+Y
+31 ;force a line feed between the messages
WRITE !
+32 ;
+33 ;Quit if user does not answer yes.
+34 IF +IBY<1
Begin DoDot:1
+35 WRITE !,"The existing copayment was not cancelled. "
+36 QUIT
End DoDot:1
QUIT 0
+37 ; Cancel the copay.
+38 SET IBCNRSLT=$$CANCAPI^IBECEA4(IBN)
+39 IF +$GET(IBCNRSLT)<0
Begin DoDot:1
+40 WRITE !!,"The copayment was not cancelled."
+41 QUIT
End DoDot:1
QUIT 0
+42 WRITE !!,"The copayment was cancelled. Please continue adding the new copay."
+43 ;
+44 READ !!,?10,"Press any key to continue. ",IBX:DTIME
+45 ;
+46 QUIT 1
+47 ;
ASKLTC() ; LTC clock confirmation prompt IB*2.0*728
+1 ;
+2 ; returns 1 for "yes", or 0 otherwise
+3 ;
+4 NEW X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
+5 WRITE !
+6 SET DIR("A",1)="The Date of Service entered is beyond the end of the current clock."
+7 SET DIR("A")="Do you wish to close this LTC clock and start a new LTC clock? (Y/N): "
+8 SET DIR(0)="YAO"
+9 DO ^DIR
+10 QUIT $SELECT(+Y=1:1,1:0)
