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