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

IBAKAT.m

Go to the documentation of this file.
  1. IBAKAT ;ALB/CPM - CANCEL COPAY CHARGES FOR KATRINA VETS ; 05-MAR-06
  1. ;;2.0;INTEGRATED BILLING;**340**;21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ;
  1. CAN() ; Cancel copayments for Katrina vets
  1. N IBCRES,IBBEG,IBEND,IBTOT,IBHIT,IBBUCK,IBD,IBN,IBND,IBCHG,IBIL
  1. N DFN,DIE,DA,DR,IBND1,IBH,IBDEC,IBTRAN
  1. S IBCRES=$O(^IBE(350.3,"B","KATRINA AFFECTED VETERAN",0)),IBTOT=""
  1. I 'IBCRES G CANQ
  1. ;
  1. S IBBEG=3050829,IBEND=3060228,IBTOT="0^0^0"
  1. ;
  1. S DFN=0 F S DFN=$O(^IB("APTDT",DFN)) Q:'DFN D
  1. .;
  1. .; - quit if vet should not have charges cancelled
  1. .Q:'$$CHK^RCKATP(DFN) S (IBHIT,IBBUCK)=0 K IBH
  1. .;
  1. .; - examine all charges billed from 8/29/05 through 2/28/06
  1. .S IBD=3050828.9 F S IBD=$O(^IB("APTDT",DFN,IBD)) Q:'IBD D
  1. ..S IBN=0 F S IBN=$O(^IB("APTDT",DFN,IBD,IBN)) Q:'IBN D
  1. ...;
  1. ...S IBND=$G(^IB(IBN,0)),IBND1=$G(^(1))
  1. ...;
  1. ...; - skip event records
  1. ...Q:$P(IBND,"^",8)["ADMISSION"
  1. ...;
  1. ...; - skip if this is not the last entry for the parent
  1. ...Q:'$P(IBND,"^",9)
  1. ...Q:IBN'=$$LAST^IBECEAU($P(IBND,"^",9))
  1. ...;
  1. ...; - skip if entry is cancelled
  1. ...Q:$P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^",5)=2
  1. ...I IBN=$P(IBND,"^",9),($P(IBND,"^",5)=10!($P(IBND,"^",10))) Q
  1. ...;
  1. ...; - skip if rx copay is after 2/28/06
  1. ...I '$P(IBND,"^",14),$E(IBD,1,7)>IBEND Q
  1. ...;
  1. ...; - skip if medical care copay is out of range
  1. ...I $P(IBND,"^",14),($P(IBND,"^",15)<IBBEG!($P(IBND,"^",14)>IBEND)) Q
  1. ...;
  1. ...S IBCHG=+$P(IBND,"^",7),IBIL=$P(IBND,"^",11),IBTRAN=$P(IBND,"^",12)
  1. ...;
  1. ...; - if charge is not passed to AR, cancel it in IB
  1. ...I '$P($G(^IBE(350.21,+$P(IBND,"^",5),0)),"^",4) D Q
  1. ....S $P(IBTOT,"^",3)=$P(IBTOT,"^",3)+IBCHG
  1. ....S $P(IBTOT,"^",2)=$P(IBTOT,"^",2)+IBCHG,IBHIT=1
  1. ....S DIE="^IB(",DA=IBN,DR=".05////10;.1////"_IBCRES D ^DIE
  1. ...;
  1. ...; - cancel the charge in AR, to the extent possible, if it
  1. ...; were never on hold in IB
  1. ...I '$P(IBND1,"^",6) D Q
  1. ....S $P(IBTOT,"^",2)=$P(IBTOT,"^",2)+IBCHG,IBHIT=1
  1. ....S IBBUCK=IBBUCK+$$DEC^RCKATP(IBIL,IBCHG)
  1. ...;
  1. ...; - for charges once on hold, see if there is "credit" in AR
  1. ...; that would preclude our need to cancel the charge. The
  1. ...; amount to decrease the charge is in IBDEC.
  1. ...S IBDEC=IBCHG D Q:'IBDEC
  1. ....N IBAR,IBB
  1. ....;
  1. ....; - have AR update the credit amount
  1. ....S IBAR=$$TPP^RCKATP(IBTRAN,.IBH)
  1. ....;
  1. ....; - if the receivable in file 430 couldn't be defined, quit
  1. ....; and decrease the entire charge amount
  1. ....S IBB=$P(IBAR,"^",2) I 'IBB Q
  1. ....;
  1. ....; - initialize the credit amount for the bill
  1. ....I '$G(IBH(IBB)) S IBH(IBB)=0
  1. ....;
  1. ....; - increment the credit amount by what is returned from AR
  1. ....S IBH(IBB)=IBH(IBB)+IBAR
  1. ....;
  1. ....; - if there is no additional credit, quit and decrease the
  1. ....; entire charge amount
  1. ....I 'IBH(IBB) Q
  1. ....;
  1. ....; - if the credit amount is greater than the charge, set the
  1. ....; decrease amount to zero; otherwise, set it to the charge
  1. ....; amount minus the available credit
  1. ....S IBDEC=$S(IBH(IBB)>IBCHG:0,1:IBCHG-IBH(IBB))
  1. ....;
  1. ....; - if the credit amount is less than the charge, set it to
  1. ....; zero; otherwise, offset it by the charge amount
  1. ....S IBH(IBB)=$S(IBH(IBB)<IBCHG:0,1:IBH(IBB)-IBCHG)
  1. ...;
  1. ...;
  1. ...; - decrease account by the adjusted amount IBDEC
  1. ...S $P(IBTOT,"^",2)=$P(IBTOT,"^",2)+IBDEC,IBHIT=1
  1. ...S IBBUCK=IBBUCK+$$DEC^RCKATP(IBIL,IBDEC)
  1. .;
  1. .;
  1. .; - flag each patient in AR, even if no charges are found
  1. .D FLAG^RCKATP(DFN)
  1. .;
  1. .; - update patient counter
  1. .I IBHIT S $P(IBTOT,"^")=$P(IBTOT,"^")+1
  1. .;
  1. .; - if there's anything in the bucket, further reduce account
  1. .I IBBUCK D ADJ^RCKATP(DFN,IBBUCK)
  1. ;
  1. ;
  1. CANQ Q IBTOT
  1. ;
  1. ;
  1. ;
  1. CANRES ; Patch *340 post-init entry point
  1. D BMES^XPDUTL(">>> Adding new cancellation reason into file #350.3...")
  1. S IBCR="KATRINA AFFECTED VETERAN^KAT^3"
  1. I $O(^IBE(350.3,"B",$P(IBCR,"^"),0)) D G CANRESQ
  1. .D MES^XPDUTL(" >> '"_$P(IBCR,"^")_"' is already on file.")
  1. S DIC="^IBE(350.3,",DIC(0)="L",DLAYGO=350.3,X=$P(IBCR,"^")
  1. K DD,DO D FILE^DICN K DD,DO
  1. I Y<0 D MES^XPDUTL(" >> Unable to file this entry!") G CANRESQ
  1. S DIE=DIC,DA=+Y,DR=".02///"_$P(IBCR,"^",2)_";.03///"_$P(IBCR,"^",3)
  1. D ^DIE,MES^XPDUTL(" >> '"_$P(IBCR,"^")_"' has been filed.")
  1. CANRESQ K DA,DIC,DIE,DR,DLAYGO,IBCR,X,Y
  1. Q