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

IBECEAU2.m

Go to the documentation of this file.
  1. IBECEAU2 ;ALB/CPM - Cancel/Edit/Add... User Prompts ; 19-APR-93
  1. ;;2.0;INTEGRATED BILLING;**7,52,153,176,545,563,614,618,646,663,671,669,653,678,715,734,772,797**;21-MAR-94;Build 2
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. REAS(IBX) ; Ask for the cancellation reason.
  1. ; Input: IBX -- "C" (Cancel a charge), "E" (Edit a Charge)
  1. N IBEVDT,IBUC
  1. ;
  1. ;start IB*2.0*678
  1. ;Check the Brief Description field of the copay being cancelled to see if it is an Urgent Care Copay
  1. S IBUC=""
  1. S:$P(IBND,U,8)["URGENT" IBUC=1
  1. ;end IB*2.0*678
  1. ;
  1. S DIC="^IBE(350.3,",DIC(0)="AEMQZ",DIC("A")="Select "_$S(IBX="E":"EDIT",1:"CANCELLATION")_" REASON: "
  1. ;
  1. ;IB*2.0*678 added an Inactive screen to most of the Copays. Built a new Screen for the UC copays.
  1. S:'IBUC DIC("S")=$S(IBXA=7:"I 1",IBXA=6:"I $P(^(0),U,3)=3",IBXA=5:"I ($P(^(0),U,3)=1)!($P(^(0),U,3)=3)",1:"I ($P(^(0),U,3)=2)!($P(^(0),U,3)=3)")_",(+($P(^(0),U,6))=0)"_",$E($P(^(0),U),1,4)'=""UC -""" ; IB*2.0*734
  1. S:IBUC DIC("S")="I ($P(^(0),U,4)=1),(+($P(^(0),U,6))=0)"
  1. ;end IB*2.0*678
  1. S IBEVDT=$P(IBND,U,14) ; IB*2.0*797
  1. S DIC("S")=DIC("S")_",+$P(^(0),U,9)'>IBEVDT,+$P(^(0),U,10)=0!(+$P(^(0),U,10)'<IBEVDT)" ; IB*2.0*797
  1. ;
  1. D ^DIC K DIC
  1. S IBCRES=+Y
  1. ;
  1. Q
  1. ;
  1. UNIT(DEF) ; Ask for units for Rx copay charges
  1. ; Input: DEF -- Default value if previous charge is to be displayed
  1. N DA,DIR,DIRUT,DUOUT,DTOUT,X,X1,Y
  1. S DA=IBATYP,IBDESC="RX COPAYMENT" D COST^IBAUTL S IBCHG=X1
  1. ;IB*2.0*653 removed the functionality added (we formerly ask days supply) in IB*2.0*614 no longer needed
  1. S DIR(0)="N^::0^K:X<1!(X>12) X",DIR("A")="Units",DIR("?")="^D HUN^IBECEAU2"
  1. S:DEF DIR("B")=DEF D ^DIR I Y S IBUNIT=Y,IBCHG=IBCHG*Y
  1. I 'Y W !!,"Units not entered - transaction cannot be completed." S IBY=-1
  1. Q
  1. ;
  1. FR(DEF) ; Ask Bill From Date
  1. ; Input: DEF -- Default value if previous charge is to be displayed
  1. N DA,DIR,DIRUT,DUOUT,DTOUT,X,X1,Y
  1. N IBDOD ; IB*2.0*772
  1. FRA S:$G(DEF) DIR("B")=$$DAT2^IBOUTL(DEF)
  1. S DIR(0)="DA^2901001:"_IBLIM_":EX"
  1. ; IB*2.0*715
  1. ; IBATYPN is defined in CUS^IBECEA35
  1. S DIR("A")="Charge for services from: "
  1. I IBXA=4 S DIR("A")="Visit Date: "
  1. I IBXA=5 S DIR("A")="Rx Date: "
  1. I IBXA=7,$G(IBATYPN)'="DG TRICARE INPT COPAY NEW" S DIR("A")=$S($G(IBATYPN)="DG TRICARE RX COPAY NEW":"Rx Date: ",1:"Visit Date: ")
  1. S DIR("?")="^D HFR^IBECEAU2"
  1. ;
  1. D ^DIR K DIR S IBFR=Y I 'Y W !!,$S(IBXA=4!(IBXA=7):"Visit",IBXA=5:"Rx",1:"Bill From")," Date not entered - transaction cannot be completed." S IBY=-1 G FRQ
  1. ; check date of death
  1. S IBDOD=$$GETDOD(DFN) I IBDOD>0,IBFR>IBDOD W !!,"This date is after patient's recorded date of death." G FRA ; IB*2.0*772
  1. I IBXA=7 G FRQ
  1. I IBXA'=8,IBXA'=9,IBXA'=5,'IBUC,'$$BIL^DGMTUB(DFN,IBFR+.24) D CATC G FRA ;IB*2.0*646 - added UC check.
  1. I IBXA>7,IBXA<10,$$LTCST^IBAECU(DFN,IBFR,1)<2 W !,"This patient is not LTC billable on this date.",! G FRA
  1. ;IB*2.0*678 Moved Dup check to IBECEA3 because of additional functionality for Dup checks.
  1. ;I IBXA=4,$$BFO^IBECEAU(DFN,IBFR) W !!,"This patient has already been billed the outpatient copay charge for ",$$DAT1^IBOUTL(IBFR),".",! G FRA
  1. FRQ Q
  1. ;
  1. TO(DEF) ; Ask Bill To Date
  1. ; Input: DEF -- Default value if previous charge is to be displayed
  1. N DA,DIR,DIRUT,DUOUT,DTOUT,X,X1,Y
  1. TOA S:$G(DEF) DIR("B")=$$DAT2^IBOUTL(DEF)
  1. S DIR(0)="DA^"_IBFR_":"_IBLIM_":EX",DIR("A")=" Charge for services to: ",DIR("?")="^D HTO^IBECEAU2"
  1. D ^DIR K DIR S IBTO=Y I 'Y W !!,"Bill To date not entered - transaction cannot be completed." S IBY=-1 G TOQ
  1. I IBTO'=IBFR,'$$BIL^DGMTUB(DFN,$S(IBXA=3&'$G(DEF):$$FMADD^XLFDT(IBTO,-1),1:IBTO)+.24),IBXA'=8,IBXA'=9 D CATC G TOA
  1. TOQ Q
  1. ;
  1. FEE(DEF) ; Ask for Fee Amount
  1. ; Input: DEF -- Default value if previous charge is to be displayed
  1. N DIR,DIRUT,DUOUT,DTOUT,X,Y
  1. S:$G(DEF) DIR("B")=DEF
  1. S DIR(0)="NA^::2^K:X<0!(X>(IBMED-IBCLDOL)) X",DIR("A")=" Charge Amount: ",DIR("?")="^D HFEE^IBECEAU2"
  1. D ^DIR S IBCHG=Y I 'Y W !!,"Charge not entered - transaction cannot be completed." S IBY=-1
  1. Q
  1. ;
  1. AMT ; Ask for Charge Amount
  1. N DIR,DIRUT,DUOUT,DTOUT,X,Y
  1. S DIR(0)="NA^::2^K:X<0!(X>99999) X",DIR("A")="Charge Amount: ",DIR("?")="^D HAMT^IBECEAU2"
  1. D ^DIR S IBCHG=Y I 'Y W !!,"Charge not entered - transaction cannot be completed." S IBY=-1
  1. Q
  1. ;
  1. CATC ; Display that patient is not Means Test billable.
  1. W !!,"The patient ",$S(IBFR<DT:"was",1:"is")," not Means Test billable on this date.",!
  1. Q
  1. ;
  1. HUN ; Help for units
  1. W !!,"Please enter 1, 2, 3, ...,12 to denote a 30, 60, 90, ...,360 days supply of"
  1. W !,"medication, or '^' to quit."
  1. Q
  1. ;
  1. HFR ; Help for Bill From date
  1. N STR
  1. ; IB*2.0*715
  1. ; IBATYPN is defined in CUS^IBECEA35
  1. S STR="'Bill From' date for this charge"
  1. I IBXA=4 S STR="patient's outpatient visit date"
  1. I IBXA=5 S STR="patient's prescription date"
  1. I IBXA=7 S STR=$S($G(IBATYPN)="DG TRICARE RX COPAY NEW":"patient's prescription date",1:"patient's outpatient visit date")
  1. W !!,"Please enter the ",STR
  1. W $S(IBXA'=5:", which must follow",1:"")
  1. ;
  1. W !,$S(IBXA=5:"today or prior to today",1:"10/1/90"_$S(IBXA=4!(IBXA=7):"",1:" (and be prior to today)")),", or '^' to quit."
  1. Q
  1. ;
  1. HTO ; Help for Bill To date
  1. W !!,"Please enter the 'Bill To' date for this charge, which may not precede"
  1. W !,$$DAT1^IBOUTL(IBFR),", or '^' to quit."
  1. Q
  1. ;
  1. HFEE ; Help for Fee Amount
  1. W !!,"Please enter the charge for this Fee Service, which may not be greater than"
  1. W !,"the difference between the Medicare Deductible amount and the "
  1. W $$INPT^IBECEAU(IBCLDAY)," 90 days",!,"copay billed ($",IBMED-IBCLDOL,"), or '^' to quit."
  1. Q
  1. ;
  1. HAMT ; Help for Charge Amount
  1. W !!,"Please enter the charge for this copayment."
  1. Q
  1. ;
  1. TIER(IBATYP,IBEFDT,TIER) ; Prompt if needed for copay tier
  1. ; IBATYP - 350.1 IB Action Type
  1. ; IBEFDT - Date for possible tier choice or not if only one tier available
  1. ; TIER - {optional) default tier, if none specified, then 2 used
  1. N IB,IBN,IBD,IBEND,IBFTIER,IBLTIER,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIR,IBTIER
  1. S IBD=-($G(IBEFDT,DT)+.9),IBD=$O(^IBE(350.2,"AIVDT",IBATYP,IBD)),IBEND=$O(^IBE(350.2,"AIVDT",IBATYP,IBD))
  1. I IBD="" D Q 0
  1. . W !!,"Rx Date entered is invalid for the charge type. Please confirm",!
  1. . W "the date and re-enter."
  1. . S IBY=-1
  1. S IBEND=$O(^IBE(350.2,"AIVDT",IBATYP,IBD))
  1. S IBN=0 F S IBN=$O(^IBE(350.2,"AIVDT",IBATYP,IBD,IBN)) Q:'IBN S IB=$G(^IBE(350.2,IBN,0)) I IB]"",'$P(IB,"^",5)!($P(IB,"^",5)>IBEFDT) S IBTIER($P(IB,"^",7))=""
  1. ; if only one tier don't prompt just use it
  1. S IBFTIER=$O(IBTIER(0)) I '$O(IBTIER(IBFTIER)) Q IBFTIER
  1. S IBLTIER=$O(IBTIER(1000),-1)
  1. S DIR(0)="N^"_IBFTIER_":"_IBLTIER_":0"
  1. S DIR("A")="ENTER THE COPAY TIER"
  1. S DIR("B")=$S($G(TIER):TIER,1:2)
  1. S DIR("?")="Enter the copayment tier for this charge, it will be used to determine the per unit rate."
  1. D ^DIR
  1. I $D(DIRUT) S IBY=-1 Q 0
  1. Q Y
  1. ;
  1. GETDOD(DFN) ; get patient's date of death IB*2.0*772
  1. ;
  1. ; DFN - patient's DFN
  1. ;
  1. ; returns patient's date of death (internal format) if available, or 0 otherwise.
  1. ;
  1. N VADM
  1. I +DFN'>0 Q 0
  1. D DEM^VADPT
  1. Q +$P($G(VADM(6)),U)