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

IBECEA3A.m

Go to the documentation of this file. 
  1. IBECEA3A ;EDE/YMG - Cancel/Edit/Add... Add a Charge (cont.); 04/03/2024
  1.  ;;2.0;INTEGRATED BILLING;**729**;21-MAR-94;Build 8
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  Q
  1.  ;
  1. CHKLTC(DFN,IBFR) ; check the LTC billing clock
  1.  ;
  1.  ; DFN - patient's DFN
  1.  ; IBFR - "bill from" date (internal)
  1.  ;
  1.  ; returns "1 ^ LTC clock ien" on success, 0 on error
  1.  ;
  1.  N IBCLDA,IBCLDY,IBCLEDT,IBCLSTDT,IBCLZ,IBDT,IBNOCL,IBRES
  1.  S IBRES=1,IBNOCL=0
  1.  ; get the latest LTC clock
  1.  S (IBCLSTDT,IBCLEDT)=0,IBCLDA=$$FNDOPEN^IBAECU4(DFN)
  1.  I IBCLDA S IBCLZ=^IBA(351.81,IBCLDA,0),IBCLSTDT=$P(IBCLZ,U,3),IBCLEDT=$P(IBCLZ,U,4),IBCLDY=+$P(IBCLZ,U,6)
  1.  ; is IBFR within date range of the LTC clock?
  1.  I IBFR<IBCLSTDT D
  1.  .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
  1.  ..S IBCLDA=+$O(^IBA(351.81,"AE",DFN,IBDT,""),-1) I 'IBCLDA S IBRES=0,IBNOCL=1 Q
  1.  ..S IBCLDY=+$P(^IBA(351.81,IBCLDA,0),U,6)
  1.  ..W !!,"This charge will be applied to the following closed LTC clock:"
  1.  ..W !,"Start Date: ",$$FMTE^XLFDT(IBDT),"  Free Days Remaining: ",IBCLDY
  1.  ..I IBCLDY D LTCFDAYS(IBCLDA) S IBRES=0
  1.  ..Q
  1.  I IBFR>IBCLEDT D
  1.  .; date of service if past exp.date of the clock - ask user if they want to open a new LTC clock
  1.  .I $$ASKLTC() D  Q
  1.  ..S IBCLDA=$$OPTB^IBAECC(DFN,IBCLDA,IBCLEDT,IBFR)
  1.  ..S:'IBCLDA IBRES=0,IBNOCL=1
  1.  ..I IBRES,+$P(^IBA(351.81,IBCLDA,0),U,6) D LTCFDAYS(IBCLDA) S IBRES=0
  1.  ..Q
  1.  .; user didn't want to open a new clock
  1.  .W !!,"The Open LTC Billing Clock detected for the patient has expired."
  1.  .W !,"Please Open a New Clock and apply any available Free Days before"
  1.  .W !,"continuing to charge this copayment.",!
  1.  .D ASKCONT^IBAECC W !
  1.  .S IBRES=0
  1.  .Q
  1.  I IBFR'<IBCLSTDT,IBFR'>IBCLEDT D
  1.  .; use the current LTC clock
  1.  .W !!,"This charge will be applied to the following open LTC clock:"
  1.  .W !,"Start Date: ",$$FMTE^XLFDT(IBCLSTDT),"  Free Days Remaining: ",IBCLDY
  1.  .I IBCLDY D LTCFDAYS(IBCLDA) S IBRES=0
  1.  .Q
  1.  I 'IBRES,IBNOCL W !!,"The patient has no LTC clock active for this date.",!
  1.  Q $S(IBRES>0:IBRES_U_IBCLDA,1:IBRES)
  1.  ;
  1. ASKLTC() ; LTC clock confirmation prompt
  1.  ;
  1.  ; returns 1 for "yes", or 0 otherwise
  1.  ;
  1.  N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
  1.  W !
  1.  S DIR("A",1)="The Date of Service entered is beyond the end of the current clock."
  1.  S DIR("A")="Do you wish to close this LTC clock and start a new LTC clock? (Y/N): "
  1.  S DIR(0)="YAO"
  1.  D ^DIR
  1.  Q $S(+Y=1:1,1:0)
  1.  ; 
  1. LTCFDAYS(IBLTCX) ; edit LTC free days
  1.  ;
  1.  ; IBLTCX - file 351.81 ien, used in FREE^IBAECC
  1.  ;
  1.  N Z
  1.  N IBLTCZ  ; used in FREE^IBAECC
  1.  S Z=$$ASKLTCFR()
  1.  I Z S IBLTCZ=^IBA(351.81,IBLTCX,0) D  Q
  1.  .I '$D(VADM(1)) D DEM^VADPT  ; make sure that VADM(1) is available for FREE^IBAECC
  1.  .D FREE^IBAECC
  1.  .Q
  1.  W !!,"Unable to continue billing this charge. LTC Free days are still available.",!
  1.  Q
  1.  ;
  1. ASKLTCFR() ; LTC clock free days confirmation prompt
  1.  ;
  1.  ; returns 1 for "yes", or 0 otherwise
  1.  ;
  1.  N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT
  1.  W !
  1.  S DIR("A",1)="The patient must use his free days first."
  1.  S DIR("A")="Would you like to enter the patient's Free LTC Days? (Y/N): "
  1.  S DIR(0)="YAO"
  1.  D ^DIR
  1.  Q $S(+Y=1:1,1:0)
  1.  ;
  1. DUP(DFN,IBFR,IBCHG) ; check for duplicate copays
  1.  ;
  1.  ; DFN - patient's DFN
  1.  ; IBFR - "bill from" date (internal)
  1.  ; IBCHG - charge amount
  1.  ;
  1.  ; returns 1 if we should continue adding the charge, 0 otherwise
  1.  ;
  1.  N IBDPAMT,IBDPDATA,IBDPXA,IBDUPIEN
  1.  S IBDUPIEN=$$BFCHK^IBECEAU(DFN,IBFR) I 'IBDUPIEN Q 1
  1.  S IBDPDATA=$$DUPINFO(IBDUPIEN),IBDPXA=$P(IBDPDATA,U,2),IBDPAMT=$P(IBDPDATA,U)
  1.  D PRTWRN
  1.  I IBDPXA'=4,IBDPXA'=8 Q 0  ; If an inpatient Med, warn user and prevent further billing
  1.  I 'IBCHG!(IBCHG>IBDPAMT) Q $$CANDUP(IBDUPIEN)  ; The new Outpatient charge is greater than existing charge.
  1.  Q 0
  1.  ;
  1. DUPINFO(IBIEN) ;Retrieve the needed information from the duplicate bill 
  1.  ;Input - IEN of the Bill already charged on that date
  1.  ;Output - Amount ^ Billing Group
  1.  N IBDATA0,IBDPIEN,IBDPXA
  1.  S IBDATA0=$G(^IB(IBIEN,0))
  1.  S IBDPIEN=$P(IBDATA0,U,3)
  1.  S IBDPXA=$$GET1^DIQ(350.1,IBDPIEN_",",.11,"I")
  1.  Q $P(IBDATA0,U,7)_U_IBDPXA
  1.  ;
  1. PRTWRN ; Print warning message about medical copayment already applied 
  1.  ;
  1.  W !!!,"This patient has already been billed a medical copayment for this date."
  1.  W !,"Please review the associated dates and charges for this patient.",!
  1.  Q
  1.  ;
  1. CANDUP(IBN) ;Cancel the duplicate copay if the user wishes to.
  1.  ;
  1.  ;INPUT -   IBN - IEN for the Copay to be cancelled (File 350)
  1.  ;OUTPUT -  0   - Didn't Cancel the copay
  1.  ;          1   - Cancelled the Copay
  1.  ;
  1.  ;Display Duplicate Copay
  1.  ;Get the info
  1.  N IBFRDT,IBTODT,IBACTY,IBSTCD,IBBLNM,IBSTAT,IBCHRG,IBI
  1.  N DIR,DIRUT,DUOUT,X,Y,IBY
  1.  S IBFRDT=$$GET1^DIQ(350,IBN_",",.14,"I")
  1.  S IBFRDT=$$FMTE^XLFDT(IBFRDT,"2Z")
  1.  S IBTODT=$$GET1^DIQ(350,IBN_",",.15,"I")
  1.  S IBTODT=$$FMTE^XLFDT(IBTODT,"2Z")
  1.  S IBACTY=$$GET1^DIQ(350,IBN_",",.03,"E")
  1.  S IBSTCD=$$GET1^DIQ(350,IBN_",",.2,"E")
  1.  S IBSTAT=$$GET1^DIQ(350,IBN_",",.05,"E")
  1.  S IBBLNM=$$GET1^DIQ(350,IBN_",",.11,"E")
  1.  S IBCHRG=$$GET1^DIQ(350,IBN_",",.07,"E")
  1.  W !,"BILL",?10,"BILL",?40,"STOP",?45,"BILL",!
  1.  W "FROM",?10," TO",?21,"CHARGE TYPE",?40,"CODE",?45,"NUMBER",?60,"STATUS",?70,"CHARGE",!
  1.  F IBI=1:1:80 W "-"
  1.  W !,IBFRDT,?10,IBTODT,?21,$E(IBACTY,1,17),?40,IBSTCD,?45,IBBLNM,?60,IBSTAT,?70,IBCHRG,!
  1.  ;
  1.  W !     ;force a line feed between the messages
  1.  S IBY=-1   ; Default exit value
  1.  S DIR(0)="YA"
  1.  S DIR("A",1)="Do you wish to cancel this existing copayment and continue billing the current",DIR("A")="copayment?  : "
  1.  D ^DIR
  1.  S IBY=+Y
  1.  W !     ;force a line feed between the messages
  1.  ;
  1.  ;Quit if user does not answer yes.
  1.  I +IBY<1 W !,"The existing copayment was not cancelled. " Q 0
  1.  ; Cancel the copay.
  1.  I +$$CANCAPI^IBECEA4(IBN)<0 W !!,"The copayment was not cancelled." Q 0
  1.  W !!,"The copayment was cancelled.  Please continue adding the new copay."
  1.  ;
  1.  R !!,?10,"Press any key to continue.    ",IBX:DTIME
  1.  ;
  1.  Q 1