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,729**;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 IBCLDA,IBCLST ; IB*2.0*728
N IBSTCD,IBCDCHK,IBCDEDT,IBCDFLG,IBCDSDT,NUMVSTFL ; IB*2.0*784
N Z ; IB*2.0*729
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
I IBY<0 G ADDQ ; IB*2.0*729
;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 S Z=$$CHKLTC^IBECEA3A(DFN,IBFR) S:+Z IBCLDA=$P(Z,U,2) I '+Z S IBY=-1 G ADDQ ; IB*2.0*729
;
; - 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*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
;
I IBXA=4,'$$DUP^IBECEA3A(DFN,IBFR,+$G(IBCHG)) D:IBUC&$$VSTCHK() ADDVST^IBECEA36(DFN,IBFR,"",4,5) G ADDQ ; IB*2.0*729
;
;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
;
I IBXA=8 G:'$$DUP^IBECEA3A(DFN,IBFR,+$G(IBCHG)) ADDQ G PROC ; IB*2.0*729
;
; - 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
;
;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) G:'$$DUP^IBECEA3A(DFN,IBFR,+$G(IBCHG)) ADDQ ; IB*2.0*729
;
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 AI/AN Attestation." ; IB*2.0*729
.W !,"This patient's AI/AN Attestation Benefit Start date is ",$$FMTE^XLFDT($P($$INDGET^IBINUT1(DFN),U,2),"2Z") ; IB*2.0*729
.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 MESS2B^IBECEAMH,ADDVST^IBECEAMH(DFN,IBFR,IBEVDA,2)
;
; - 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*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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBECEA3 13341 printed Sep 23, 2025@19:57:32 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,729**;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*728
NEW IBCLDA,IBCLST
+3 ; IB*2.0*784
NEW IBSTCD,IBCDCHK,IBCDEDT,IBCDFLG,IBCDSDT,NUMVSTFL
+4 ; IB*2.0*729
NEW Z
+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*729
IF IBY<0
GOTO ADDQ
+3 ;IB*2.0*646/656
+4 ; If Urgent Care copay, skip clock checks, go to prompt for copay amount.
+5 IF $GET(IBUC)
IF (IBFR<3190606)
Begin DoDot:1
+6 WRITE !!,"The Urgent Care Copayment/Mission Act legislation went into effect on 6/6/19. "
+7 WRITE !,"Dates of service prior to this date will need to be billed using other ",!,"outpatient copayment charges."
End DoDot:1
GOTO ADDQ
+8 if $GET(IBUC)
GOTO UCPAY
+9 ; end IB*2.0*646/656
+10 ;
+11 ;
+12 ;GMT Copayment Status
SET IBGMT=$$ISGMTPT^IBAGMT(DFN,IBFR)
SET IBGMTR=0
+13 IF IBGMT>0
IF IBXA>0
IF IBXA<4
WRITE !,"The patient has GMT Copayment Status."
+14 ; - check the MT billing clock
+15 IF IBXA'=8
IF IBXA'=9
DO CLMSG^IBECEA33
if IBY<0
GOTO ADDQ
+16 ;Adjust Deductible for GMT patient
+17 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),")."
+18 ;
+19 ; - check LTC non-institutional (opt) for CD exemption
+20 IF IBXA=8
IF $$CDEXMPT^IBAECU(DFN,IBFR)
WRITE !,"Patient is LTC non-institutional exempt, Catastrophically Disabled"
GOTO ADDQ
+21 ;
+22 ; - check the LTC billing clock
+23 ; IB*2.0*729
IF IBXA>7
IF IBXA<10
SET Z=$$CHKLTC^IBECEA3A(DFN,IBFR)
if +Z
SET IBCLDA=$PIECE(Z,U,2)
IF '+Z
SET IBY=-1
GOTO ADDQ
+24 ;
+25 ; - calculate the MT inpt copay charge
+26 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"
+27 ;
+28 ; - find the correct clock from the 'bill from' date (ignore LTC)
+29 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
+30 ;
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*663 Added changes for Urgent Care Visit Tracking
+5 IF IBXA=4
IF IBUC
DO UCCHRG2^IBECEA36(DFN,IBFR)
if IBY<0
GOTO ADDQ
+6 ;end IB*2.0*646
+7 ;
+8 ;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
+9 ;IB*2.0*776 start
+10 ; get the copay amount
+11 IF IBXA=4
IF 'IBUC
Begin DoDot:1
+12 ; for visits prior to 12/6/01 or FEE
+13 IF IBFR<3011206!($GET(IBAFEE))
DO OPT^IBECEA33
QUIT
+14 ; for visits on or after 12/5/01
+15 IF $GET(IBUSNM)["OBSERVATION"
Begin DoDot:2
+16 ;initial copay amount
SET IBCHG=50
SET IBUNIT=1
+17 ;ensure that Billed To and Description are defined.
SET IBDESC=IBUSNM
SET IBTO=IBFR
End DoDot:2
QUIT
+18 DO OPT^IBEMTSCU
End DoDot:1
if IBY<0
GOTO ADDQ
+19 ;IB*2.0*776 end
+20 ;
+21 ; IB*2.0*729
IF IBXA=4
IF '$$DUP^IBECEA3A(DFN,IBFR,+$GET(IBCHG))
if IBUC&$$VSTCHK()
DO ADDVST^IBECEA36(DFN,IBFR,"",4,5)
GOTO ADDQ
+22 ;
+23 ;IB*2.0*784 - Cleland-Dole Benefit Check
+24 SET IBCDSDT=$$GET1^DIQ(350.9,"1,",71.03,"I")
SET IBCDEDT=$$GET1^DIQ(350.9,"1,",71.04,"I")
+25 ;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
+26 ; Check stop code for Cleland-Dole Eligibility
IF 'IBCDCHK
IF $GET(IBSTOPDA)
Begin DoDot:1
+27 SET IBSTCD=$$GET1^DIQ(352.5,IBSTOPDA_",",.01,"E")
+28 SET IBCDCHK=$$CDCHK^IBECEAMH(IBSTCD,IBFR)
End DoDot:1
+29 SET NUMVSTFL=$$NUMVSTCK^IBECEAMH(DFN,IBFR)
+30 IF IBCDCHK
IF NUMVSTFL
Begin DoDot:1
+31 DO MESS1^IBECEAMH
+32 IF $$ASKCONT^IBECEAMH()'>0
QUIT
+33 DO ADDVST^IBECEAMH(DFN,IBFR,"",1)
End DoDot:1
GOTO ADDQ
+34 ;Alert user that Cleland-Dole max for the year has been reached.
IF IBCDCHK
IF 'NUMVSTFL
DO MESS2^IBECEAMH
+35 ;end IB*2.0*784
+36 ;
+37 ;If outpatient copay and has passed all other checks, go to PROC
+38 if IBXA=4
GOTO PROC
+39 ;
+40 ;end IB*2.0*678
+41 ;
+42 ; - if LTC outpatient calculate the charge
+43 IF IBXA=8
Begin DoDot:1
+44 ; is this day already a free day
+45 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
+46 ;
+47 ; IB*2.0*729
IF IBXA=8
if '$$DUP^IBECEA3A(DFN,IBFR,+$GET(IBCHG))
GOTO ADDQ
GOTO PROC
+48 ;
+49 ; - find per diem charge and description
+50 IF IBXA=3
Begin DoDot:1
+51 NEW IBDT
SET IBDT=IBFR
SET IBGMTR=0
DO COST^IBAUTL2
+52 IF IBGMT>0
SET IBGMTR=1
SET IBCHG=$$REDUCE^IBAGMT(IBCHG)
+53 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
+54 ;
+55 ; - calculate charge for the inpatient copay
+56 IF IBXA=2
IF IBCHG+IBCLDOL'<IBMED
SET IBCHG=IBMED-IBCLDOL
SET IBUNIT=1
SET IBTO=IBFR
DO CTBB^IBECEAU3
GOTO EV
+57 ;
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 ;Check to see if there is another medical copay (inpatient or outpatient) on that same day for this patient.
+4 ;If there is, print warning message to user and abort copay entry.
+5 ; IB*2.0*729
IF (IBXA<4)!(IBXA=9)
if '$$DUP^IBECEA3A(DFN,IBFR,+$GET(IBCHG))
GOTO ADDQ
+6 ;
+7 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
+8 ;
+9 ;- IB*2.0*663 - check for Free days used in this billing period
+10 IF IBXA=9
Begin DoDot:1
+11 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
+12 ;end IB*2.0*663
+13 ;
+14 ; - calculate unit charge for LTC inpatient in IBCHG
+15 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
+16 DO NOEV^IBECEA31
IF '$GET(IBDG)!(IBY<0)
SET IBY=-1
QUIT
+17 ; - build the event record
+18 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
+19 ;
+20 ; - calculate units and total charge
+21 SET IBUNIT=$$FMDIFF^XLFDT(IBTO,IBFR)
if IBXA'=3!(IBFR=IBTO)
SET IBUNIT=IBUNIT+1
+22 IF IBXA=1
if IBGMT>0
Begin DoDot:1
+23 SET IBGMTR=1
+24 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
+25 SET IBCHG=IBCHG*IBUNIT
if IBXA=2
SET IBCHG=$SELECT(IBCLDOL+IBCHG>IBMED:IBMED-IBCLDOL,1:IBCHG)
+26 ;
+27 ; adjust the LTC charge based on the calculated copay cap
+28 IF IBXA=9
DO CALC^IBAECI
if IBY<1!('IBCHG)
GOTO ADDQ
SET IBDESC="LTC INPATIENT COPAY"
+29 ;
+30 DO CTBB^IBECEAU3
if IBXA=3!(IBXA=9)
WRITE " (for ",IBUNIT," day",$EXTRACT("s",IBUNIT>1),")"
if IBGMTR
WRITE " GMT Rate"
+31 ;
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 ; IB*2.0*729
WRITE !!,"The patient is exempt from this copayment due to AI/AN Attestation."
+4 ; IB*2.0*729
WRITE !,"This patient's AI/AN 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
DO MESS2B^IBECEAMH
DO ADDVST^IBECEAMH(DFN,IBFR,IBEVDA,2)
+35 ;
+36 ; - review the special inpatient billing case
+37 IF $GET(IBSIBC1)
DO CHK^IBAMTI1(IBSIBC1,IBEVDA)
+38 ;
+39 ; - handle updating of clock
+40 ;IB*2.0*646
IF IBXA'=8
IF IBXA'=9
IF 'IBUC
DO CLUPD^IBECEA32
+41 ;
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*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
