IBECEA3A ;EDE/YMG - Cancel/Edit/Add... Add a Charge (cont.); 04/03/2024
;;2.0;INTEGRATED BILLING;**729**;21-MAR-94;Build 8
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
CHKLTC(DFN,IBFR) ; check the LTC billing clock
;
; DFN - patient's DFN
; IBFR - "bill from" date (internal)
;
; returns "1 ^ LTC clock ien" on success, 0 on error
;
N IBCLDA,IBCLDY,IBCLEDT,IBCLSTDT,IBCLZ,IBDT,IBNOCL,IBRES
S IBRES=1,IBNOCL=0
; 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
.S IBDT=+$O(^IBA(351.81,"AE",DFN,IBFR),-1) I IBDT>0 D Q ; found a previous LTC clock, try to use this one
..S IBCLDA=+$O(^IBA(351.81,"AE",DFN,IBDT,""),-1) I 'IBCLDA S IBRES=0,IBNOCL=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(IBDT)," Free Days Remaining: ",IBCLDY
..I IBCLDY D LTCFDAYS(IBCLDA) S IBRES=0
..Q
I IBFR>IBCLEDT D
.; date of service if past exp.date of the clock - ask user if they want to open a new LTC clock
.I $$ASKLTC() D Q
..S IBCLDA=$$OPTB^IBAECC(DFN,IBCLDA,IBCLEDT,IBFR)
..S:'IBCLDA IBRES=0,IBNOCL=1
..I IBRES,+$P(^IBA(351.81,IBCLDA,0),U,6) D LTCFDAYS(IBCLDA) S IBRES=0
..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 !
.S IBRES=0
.Q
I IBFR'<IBCLSTDT,IBFR'>IBCLEDT D
.; use the current LTC clock
.W !!,"This charge will be applied to the following open LTC clock:"
.W !,"Start Date: ",$$FMTE^XLFDT(IBCLSTDT)," Free Days Remaining: ",IBCLDY
.I IBCLDY D LTCFDAYS(IBCLDA) S IBRES=0
.Q
I 'IBRES,IBNOCL W !!,"The patient has no LTC clock active for this date.",!
Q $S(IBRES>0:IBRES_U_IBCLDA,1:IBRES)
;
ASKLTC() ; LTC clock confirmation prompt
;
; 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)
;
LTCFDAYS(IBLTCX) ; edit LTC free days
;
; IBLTCX - file 351.81 ien, used in FREE^IBAECC
;
N Z
N IBLTCZ ; used in FREE^IBAECC
S Z=$$ASKLTCFR()
I Z S IBLTCZ=^IBA(351.81,IBLTCX,0) D Q
.I '$D(VADM(1)) D DEM^VADPT ; make sure that VADM(1) is available for FREE^IBAECC
.D FREE^IBAECC
.Q
W !!,"Unable to continue billing this charge. LTC Free days are still available.",!
Q
;
ASKLTCFR() ; LTC clock free days confirmation prompt
;
; returns 1 for "yes", or 0 otherwise
;
N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
W !
S DIR("A",1)="The patient must use his free days first."
S DIR("A")="Would you like to enter the patient's Free LTC Days? (Y/N): "
S DIR(0)="YAO"
D ^DIR
Q $S(+Y=1:1,1:0)
;
DUP(DFN,IBFR,IBCHG) ; check for duplicate copays
;
; DFN - patient's DFN
; IBFR - "bill from" date (internal)
; IBCHG - charge amount
;
; returns 1 if we should continue adding the charge, 0 otherwise
;
N IBDPAMT,IBDPDATA,IBDPXA,IBDUPIEN
S IBDUPIEN=$$BFCHK^IBECEAU(DFN,IBFR) I 'IBDUPIEN Q 1
S IBDPDATA=$$DUPINFO(IBDUPIEN),IBDPXA=$P(IBDPDATA,U,2),IBDPAMT=$P(IBDPDATA,U)
D PRTWRN
I IBDPXA'=4,IBDPXA'=8 Q 0 ; If an inpatient Med, warn user and prevent further billing
I 'IBCHG!(IBCHG>IBDPAMT) Q $$CANDUP(IBDUPIEN) ; The new Outpatient charge is greater than existing charge.
Q 0
;
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
;
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
;
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 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,!
;
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 W !,"The existing copayment was not cancelled. " Q 0
; Cancel the copay.
I +$$CANCAPI^IBECEA4(IBN)<0 W !!,"The copayment was not cancelled." Q 0
W !!,"The copayment was cancelled. Please continue adding the new copay."
;
R !!,?10,"Press any key to continue. ",IBX:DTIME
;
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBECEA3A 5994 printed Dec 13, 2024@02:21:25 Page 2
IBECEA3A ;EDE/YMG - Cancel/Edit/Add... Add a Charge (cont.); 04/03/2024
+1 ;;2.0;INTEGRATED BILLING;**729**;21-MAR-94;Build 8
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
CHKLTC(DFN,IBFR) ; check the LTC billing clock
+1 ;
+2 ; DFN - patient's DFN
+3 ; IBFR - "bill from" date (internal)
+4 ;
+5 ; returns "1 ^ LTC clock ien" on success, 0 on error
+6 ;
+7 NEW IBCLDA,IBCLDY,IBCLEDT,IBCLSTDT,IBCLZ,IBDT,IBNOCL,IBRES
+8 SET IBRES=1
SET IBNOCL=0
+9 ; get the latest LTC clock
+10 SET (IBCLSTDT,IBCLEDT)=0
SET IBCLDA=$$FNDOPEN^IBAECU4(DFN)
+11 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)
+12 ; is IBFR within date range of the LTC clock?
+13 IF IBFR<IBCLSTDT
Begin DoDot:1
+14 ; found a previous LTC clock, try to use this one
SET IBDT=+$ORDER(^IBA(351.81,"AE",DFN,IBFR),-1)
IF IBDT>0
Begin DoDot:2
+15 SET IBCLDA=+$ORDER(^IBA(351.81,"AE",DFN,IBDT,""),-1)
IF 'IBCLDA
SET IBRES=0
SET IBNOCL=1
QUIT
+16 SET IBCLDY=+$PIECE(^IBA(351.81,IBCLDA,0),U,6)
+17 WRITE !!,"This charge will be applied to the following closed LTC clock:"
+18 WRITE !,"Start Date: ",$$FMTE^XLFDT(IBDT)," Free Days Remaining: ",IBCLDY
+19 IF IBCLDY
DO LTCFDAYS(IBCLDA)
SET IBRES=0
+20 QUIT
End DoDot:2
QUIT
End DoDot:1
+21 IF IBFR>IBCLEDT
Begin DoDot:1
+22 ; date of service if past exp.date of the clock - ask user if they want to open a new LTC clock
+23 IF $$ASKLTC()
Begin DoDot:2
+24 SET IBCLDA=$$OPTB^IBAECC(DFN,IBCLDA,IBCLEDT,IBFR)
+25 if 'IBCLDA
SET IBRES=0
SET IBNOCL=1
+26 IF IBRES
IF +$PIECE(^IBA(351.81,IBCLDA,0),U,6)
DO LTCFDAYS(IBCLDA)
SET IBRES=0
+27 QUIT
End DoDot:2
QUIT
+28 ; user didn't want to open a new clock
+29 WRITE !!,"The Open LTC Billing Clock detected for the patient has expired."
+30 WRITE !,"Please Open a New Clock and apply any available Free Days before"
+31 WRITE !,"continuing to charge this copayment.",!
+32 DO ASKCONT^IBAECC
WRITE !
+33 SET IBRES=0
+34 QUIT
End DoDot:1
+35 IF IBFR'<IBCLSTDT
IF IBFR'>IBCLEDT
Begin DoDot:1
+36 ; use the current LTC clock
+37 WRITE !!,"This charge will be applied to the following open LTC clock:"
+38 WRITE !,"Start Date: ",$$FMTE^XLFDT(IBCLSTDT)," Free Days Remaining: ",IBCLDY
+39 IF IBCLDY
DO LTCFDAYS(IBCLDA)
SET IBRES=0
+40 QUIT
End DoDot:1
+41 IF 'IBRES
IF IBNOCL
WRITE !!,"The patient has no LTC clock active for this date.",!
+42 QUIT $SELECT(IBRES>0:IBRES_U_IBCLDA,1:IBRES)
+43 ;
ASKLTC() ; LTC clock confirmation prompt
+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)
+11 ;
LTCFDAYS(IBLTCX) ; edit LTC free days
+1 ;
+2 ; IBLTCX - file 351.81 ien, used in FREE^IBAECC
+3 ;
+4 NEW Z
+5 ; used in FREE^IBAECC
NEW IBLTCZ
+6 SET Z=$$ASKLTCFR()
+7 IF Z
SET IBLTCZ=^IBA(351.81,IBLTCX,0)
Begin DoDot:1
+8 ; make sure that VADM(1) is available for FREE^IBAECC
IF '$DATA(VADM(1))
DO DEM^VADPT
+9 DO FREE^IBAECC
+10 QUIT
End DoDot:1
QUIT
+11 WRITE !!,"Unable to continue billing this charge. LTC Free days are still available.",!
+12 QUIT
+13 ;
ASKLTCFR() ; LTC clock free days confirmation prompt
+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 patient must use his free days first."
+7 SET DIR("A")="Would you like to enter the patient's Free LTC Days? (Y/N): "
+8 SET DIR(0)="YAO"
+9 DO ^DIR
+10 QUIT $SELECT(+Y=1:1,1:0)
+11 ;
DUP(DFN,IBFR,IBCHG) ; check for duplicate copays
+1 ;
+2 ; DFN - patient's DFN
+3 ; IBFR - "bill from" date (internal)
+4 ; IBCHG - charge amount
+5 ;
+6 ; returns 1 if we should continue adding the charge, 0 otherwise
+7 ;
+8 NEW IBDPAMT,IBDPDATA,IBDPXA,IBDUPIEN
+9 SET IBDUPIEN=$$BFCHK^IBECEAU(DFN,IBFR)
IF 'IBDUPIEN
QUIT 1
+10 SET IBDPDATA=$$DUPINFO(IBDUPIEN)
SET IBDPXA=$PIECE(IBDPDATA,U,2)
SET IBDPAMT=$PIECE(IBDPDATA,U)
+11 DO PRTWRN
+12 ; If an inpatient Med, warn user and prevent further billing
IF IBDPXA'=4
IF IBDPXA'=8
QUIT 0
+13 ; The new Outpatient charge is greater than existing charge.
IF 'IBCHG!(IBCHG>IBDPAMT)
QUIT $$CANDUP(IBDUPIEN)
+14 QUIT 0
+15 ;
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 ;
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 ;
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 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 ;force a line feed between the messages
WRITE !
+25 ; Default exit value
SET IBY=-1
+26 SET DIR(0)="YA"
+27 SET DIR("A",1)="Do you wish to cancel this existing copayment and continue billing the current"
SET DIR("A")="copayment? : "
+28 DO ^DIR
+29 SET IBY=+Y
+30 ;force a line feed between the messages
WRITE !
+31 ;
+32 ;Quit if user does not answer yes.
+33 IF +IBY<1
WRITE !,"The existing copayment was not cancelled. "
QUIT 0
+34 ; Cancel the copay.
+35 IF +$$CANCAPI^IBECEA4(IBN)<0
WRITE !!,"The copayment was not cancelled."
QUIT 0
+36 WRITE !!,"The copayment was cancelled. Please continue adding the new copay."
+37 ;
+38 READ !!,?10,"Press any key to continue. ",IBX:DTIME
+39 ;
+40 QUIT 1
