| 1 | IBAKAT ;ALB/CPM - CANCEL COPAY CHARGES FOR KATRINA VETS ; 05-MAR-06
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**340**;21-MAR-94
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ;
|
|---|
| 6 | CAN() ; Cancel copayments for Katrina vets
|
|---|
| 7 | N IBCRES,IBBEG,IBEND,IBTOT,IBHIT,IBBUCK,IBD,IBN,IBND,IBCHG,IBIL
|
|---|
| 8 | N DFN,DIE,DA,DR,IBND1,IBH,IBDEC,IBTRAN
|
|---|
| 9 | S IBCRES=$O(^IBE(350.3,"B","KATRINA AFFECTED VETERAN",0)),IBTOT=""
|
|---|
| 10 | I 'IBCRES G CANQ
|
|---|
| 11 | ;
|
|---|
| 12 | S IBBEG=3050829,IBEND=3060228,IBTOT="0^0^0"
|
|---|
| 13 | ;
|
|---|
| 14 | S DFN=0 F S DFN=$O(^IB("APTDT",DFN)) Q:'DFN D
|
|---|
| 15 | .;
|
|---|
| 16 | .; - quit if vet should not have charges cancelled
|
|---|
| 17 | .Q:'$$CHK^RCKATP(DFN) S (IBHIT,IBBUCK)=0 K IBH
|
|---|
| 18 | .;
|
|---|
| 19 | .; - examine all charges billed from 8/29/05 through 2/28/06
|
|---|
| 20 | .S IBD=3050828.9 F S IBD=$O(^IB("APTDT",DFN,IBD)) Q:'IBD D
|
|---|
| 21 | ..S IBN=0 F S IBN=$O(^IB("APTDT",DFN,IBD,IBN)) Q:'IBN D
|
|---|
| 22 | ...;
|
|---|
| 23 | ...S IBND=$G(^IB(IBN,0)),IBND1=$G(^(1))
|
|---|
| 24 | ...;
|
|---|
| 25 | ...; - skip event records
|
|---|
| 26 | ...Q:$P(IBND,"^",8)["ADMISSION"
|
|---|
| 27 | ...;
|
|---|
| 28 | ...; - skip if this is not the last entry for the parent
|
|---|
| 29 | ...Q:'$P(IBND,"^",9)
|
|---|
| 30 | ...Q:IBN'=$$LAST^IBECEAU($P(IBND,"^",9))
|
|---|
| 31 | ...;
|
|---|
| 32 | ...; - skip if entry is cancelled
|
|---|
| 33 | ...Q:$P($G(^IBE(350.1,+$P(IBND,"^",3),0)),"^",5)=2
|
|---|
| 34 | ...I IBN=$P(IBND,"^",9),($P(IBND,"^",5)=10!($P(IBND,"^",10))) Q
|
|---|
| 35 | ...;
|
|---|
| 36 | ...; - skip if rx copay is after 2/28/06
|
|---|
| 37 | ...I '$P(IBND,"^",14),$E(IBD,1,7)>IBEND Q
|
|---|
| 38 | ...;
|
|---|
| 39 | ...; - skip if medical care copay is out of range
|
|---|
| 40 | ...I $P(IBND,"^",14),($P(IBND,"^",15)<IBBEG!($P(IBND,"^",14)>IBEND)) Q
|
|---|
| 41 | ...;
|
|---|
| 42 | ...S IBCHG=+$P(IBND,"^",7),IBIL=$P(IBND,"^",11),IBTRAN=$P(IBND,"^",12)
|
|---|
| 43 | ...;
|
|---|
| 44 | ...; - if charge is not passed to AR, cancel it in IB
|
|---|
| 45 | ...I '$P($G(^IBE(350.21,+$P(IBND,"^",5),0)),"^",4) D Q
|
|---|
| 46 | ....S $P(IBTOT,"^",3)=$P(IBTOT,"^",3)+IBCHG
|
|---|
| 47 | ....S $P(IBTOT,"^",2)=$P(IBTOT,"^",2)+IBCHG,IBHIT=1
|
|---|
| 48 | ....S DIE="^IB(",DA=IBN,DR=".05////10;.1////"_IBCRES D ^DIE
|
|---|
| 49 | ...;
|
|---|
| 50 | ...; - cancel the charge in AR, to the extent possible, if it
|
|---|
| 51 | ...; were never on hold in IB
|
|---|
| 52 | ...I '$P(IBND1,"^",6) D Q
|
|---|
| 53 | ....S $P(IBTOT,"^",2)=$P(IBTOT,"^",2)+IBCHG,IBHIT=1
|
|---|
| 54 | ....S IBBUCK=IBBUCK+$$DEC^RCKATP(IBIL,IBCHG)
|
|---|
| 55 | ...;
|
|---|
| 56 | ...; - for charges once on hold, see if there is "credit" in AR
|
|---|
| 57 | ...; that would preclude our need to cancel the charge. The
|
|---|
| 58 | ...; amount to decrease the charge is in IBDEC.
|
|---|
| 59 | ...S IBDEC=IBCHG D Q:'IBDEC
|
|---|
| 60 | ....N IBAR,IBB
|
|---|
| 61 | ....;
|
|---|
| 62 | ....; - have AR update the credit amount
|
|---|
| 63 | ....S IBAR=$$TPP^RCKATP(IBTRAN,.IBH)
|
|---|
| 64 | ....;
|
|---|
| 65 | ....; - if the receivable in file 430 couldn't be defined, quit
|
|---|
| 66 | ....; and decrease the entire charge amount
|
|---|
| 67 | ....S IBB=$P(IBAR,"^",2) I 'IBB Q
|
|---|
| 68 | ....;
|
|---|
| 69 | ....; - initialize the credit amount for the bill
|
|---|
| 70 | ....I '$G(IBH(IBB)) S IBH(IBB)=0
|
|---|
| 71 | ....;
|
|---|
| 72 | ....; - increment the credit amount by what is returned from AR
|
|---|
| 73 | ....S IBH(IBB)=IBH(IBB)+IBAR
|
|---|
| 74 | ....;
|
|---|
| 75 | ....; - if there is no additional credit, quit and decrease the
|
|---|
| 76 | ....; entire charge amount
|
|---|
| 77 | ....I 'IBH(IBB) Q
|
|---|
| 78 | ....;
|
|---|
| 79 | ....; - if the credit amount is greater than the charge, set the
|
|---|
| 80 | ....; decrease amount to zero; otherwise, set it to the charge
|
|---|
| 81 | ....; amount minus the available credit
|
|---|
| 82 | ....S IBDEC=$S(IBH(IBB)>IBCHG:0,1:IBCHG-IBH(IBB))
|
|---|
| 83 | ....;
|
|---|
| 84 | ....; - if the credit amount is less than the charge, set it to
|
|---|
| 85 | ....; zero; otherwise, offset it by the charge amount
|
|---|
| 86 | ....S IBH(IBB)=$S(IBH(IBB)<IBCHG:0,1:IBH(IBB)-IBCHG)
|
|---|
| 87 | ...;
|
|---|
| 88 | ...;
|
|---|
| 89 | ...; - decrease account by the adjusted amount IBDEC
|
|---|
| 90 | ...S $P(IBTOT,"^",2)=$P(IBTOT,"^",2)+IBDEC,IBHIT=1
|
|---|
| 91 | ...S IBBUCK=IBBUCK+$$DEC^RCKATP(IBIL,IBDEC)
|
|---|
| 92 | .;
|
|---|
| 93 | .;
|
|---|
| 94 | .; - flag each patient in AR, even if no charges are found
|
|---|
| 95 | .D FLAG^RCKATP(DFN)
|
|---|
| 96 | .;
|
|---|
| 97 | .; - update patient counter
|
|---|
| 98 | .I IBHIT S $P(IBTOT,"^")=$P(IBTOT,"^")+1
|
|---|
| 99 | .;
|
|---|
| 100 | .; - if there's anything in the bucket, further reduce account
|
|---|
| 101 | .I IBBUCK D ADJ^RCKATP(DFN,IBBUCK)
|
|---|
| 102 | ;
|
|---|
| 103 | ;
|
|---|
| 104 | CANQ Q IBTOT
|
|---|
| 105 | ;
|
|---|
| 106 | ;
|
|---|
| 107 | ;
|
|---|
| 108 | CANRES ; Patch *340 post-init entry point
|
|---|
| 109 | D BMES^XPDUTL(">>> Adding new cancellation reason into file #350.3...")
|
|---|
| 110 | S IBCR="KATRINA AFFECTED VETERAN^KAT^3"
|
|---|
| 111 | I $O(^IBE(350.3,"B",$P(IBCR,"^"),0)) D G CANRESQ
|
|---|
| 112 | .D MES^XPDUTL(" >> '"_$P(IBCR,"^")_"' is already on file.")
|
|---|
| 113 | S DIC="^IBE(350.3,",DIC(0)="L",DLAYGO=350.3,X=$P(IBCR,"^")
|
|---|
| 114 | K DD,DO D FILE^DICN K DD,DO
|
|---|
| 115 | I Y<0 D MES^XPDUTL(" >> Unable to file this entry!") G CANRESQ
|
|---|
| 116 | S DIE=DIC,DA=+Y,DR=".02///"_$P(IBCR,"^",2)_";.03///"_$P(IBCR,"^",3)
|
|---|
| 117 | D ^DIE,MES^XPDUTL(" >> '"_$P(IBCR,"^")_"' has been filed.")
|
|---|
| 118 | CANRESQ K DA,DIC,DIE,DR,DLAYGO,IBCR,X,Y
|
|---|
| 119 | Q
|
|---|
