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

IBECEAU3.m

Go to the documentation of this file.
  1. IBECEAU3 ;ALB/CPM - Cancel/Edit/Add... Add New IB Action; 11-MAR-93
  1. ;;2.0;INTEGRATED BILLING;**132,150,167,183,341,563,618,656,663,653,682**;21-MAR-94;Build 15
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ADD ; Add a new Integrated Billing Action entry.
  1. ; Input: DFN -- Pointer to patient in file #2
  1. ; IBATYP -- Pointer to Action Type in file #350.1
  1. ; IBUNIT -- Number of units of charge
  1. ; IBCHG -- Total charge
  1. ; IBDESC -- Charge description
  1. ; IBSITE -- Pointer to the facility in file #4
  1. ; IBFAC -- Facility number
  1. ; IBFR -- Bill From date
  1. ; IBTO -- Bill To date
  1. ; IBEFDT -- Bill Effective Date [OPTIONAL Rx Only]
  1. ; IBSL -- Softlink [OPTIONAL]
  1. ; IBPARNT -- Pointer to parent entry in #350 [OPTIONAL]
  1. ; IBEVDA -- Pointer to parent event in #350 [OPTIONAL], or
  1. ; -- "*" to set ibevda=ibn
  1. ; IBEVDT -- Event Date [OPTIONAL]
  1. ; IBIL -- Bill Number [OPTIONAL]
  1. ; IBCRES -- Pointer to canc. reason in #350.3 [OPTIONAL]
  1. ; IBXA -- IB Action billing group [OPTIONAL]
  1. ; IBJOB -- Option being executed [OPTIONAL]
  1. ; IBCVA -- CHAMPVA Admission date [OPTIONAL]
  1. ; IBSTOPDA -- Pointer to clinic stop entry in #352.5 [OPTIONAL]
  1. ; (used for new outpatient appts created in IB)
  1. ; IBGMTR -- GMT Related flag [OPTIONAL]
  1. ; IBTIER -- Copay Tier [OPTIONAL]
  1. ;
  1. ; Output: IBN -- Internal number of new entry in file #350
  1. ;
  1. N DA,DIK,IBASTR,IBND,Y
  1. D ADD^IBAUTL I Y<1 S IBY=Y G ADDQ
  1. S:$G(IBEVDA)="*" IBEVDA=IBN
  1. S:$G(IBEVDA)="" IBEVDA=IBN ;check for the NULL scenario IB*2.0*656
  1. S IBND=DFN_"^"_IBATYP_"^"_$S($G(IBSL):IBSL,1:"350:"_IBN)_"^1^"_IBUNIT_"^"_IBCHG_"^"_IBDESC_"^"_$S($D(IBPARNT):IBPARNT,1:IBN)_"^"_$G(IBCRES)_"^"_$G(IBIL)_"^^"_IBFAC
  1. I IBDESC["RX COPAY",$D(IBAM) S $P(IBND,"^",18)=IBAM,$P(^IBAM(354.71,IBAM,0),"^",6)="350:"_IBN ; mark 354.71 entry back and forth
  1. I IBDESC["RX COPAY",$G(IBEFDT) S $P(IBND,"^",13,14)=IBEFDT_"^"_IBEFDT
  1. I IBDESC'["RX COPAY" S IBND=IBND_"^"_IBFR_"^"_IBTO_"^"_$G(IBEVDA)_$S($G(IBEVDT):"^"_IBEVDT,$G(IBXA)=1!($G(IBXA)=4)!($G(IBJOB)=5):"^"_IBFR,1:"")
  1. I $G(IBSTOPDA) S $P(IBND,"^",19)=IBSTOPDA
  1. I $G(IBTIER) S $P(IBND,"^",21)=IBTIER
  1. S $P(^IB(IBN,0),"^",2,20)=IBND
  1. ; IB*2.0*618 Allow Event date to File for Community Care RX
  1. ; IB*2.0*656 Correct a potential Undefined error
  1. I IBDESC["RX COPAY",$G(IBEVDT) D
  1. . N DIE,DR,DTOUT
  1. . S DA=IBN,DIE="^IB("
  1. . S DR=".16///"_$G(IBEVDA)_";.17///"_IBEVDT ;IB*2.0*656
  1. . D ^DIE
  1. ; end IB*2.0*618
  1. ;
  1. I $G(IBGMTR) S $P(^IB(IBN,0),"^",21)=1 ; GMT Related
  1. ; DUZ may be null if this code is called by a process started by an HL7 multi-threaded listener
  1. ; if this condition occurs the approved fix is to use the Postmaster IEN. 2/27/06, IB*2.0*341
  1. D NOW^%DTC S $P(^IB(IBN,1),"^")=$S(DUZ:DUZ,1:.5),$P(^(1),"^",3,5)=$S(DUZ:DUZ,1:.5)_"^"_%_$S($G(IBCVA):"^"_IBCVA,1:"")
  1. S DIK="^IB(",DA=IBN D IX1^DIK
  1. ADDQ Q
  1. ;
  1. CTBB ; Charge to be billed
  1. ; Check Outpat. Fee Service less than 20% Outpat Co Pay
  1. S:$G(IBREBILL("CHRGAMT"))'="" IBCHG=IBREBILL("CHRGAMT") ; IB*2.0*682
  1. D:$G(IBAFEE) FEE^IBECEAU5 Q:IBY<1
  1. I $G(IBDESC)["RX COPAY",$$CHKHRFS^IBAMTS3(DFN,$G(IBEFDT)) S IBCHG=IBUNIT*2 ;IB*2.0*653 charge $2.00 per unit ( 1 Unit = 30 day supply), no Tier rates.
  1. W !!,"Charge to be billed --> $",$J(IBCHG,0,2)
  1. Q
  1. ;
  1. NODED ; Could not determine the Medicare Deductible amount.
  1. W !,*7,"The Medicare Deductible Amount for ",$$DAT1^IBOUTL(IBCLDT)," could not be determined."
  1. W !,"You should determine the cause of this problem before proceeding."
  1. S IBY=-1
  1. Q