source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBAKAT.m@ 1000

Last change on this file since 1000 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.2 KB
Line 
1IBAKAT ;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 ;
6CAN() ; 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 ;
104CANQ Q IBTOT
105 ;
106 ;
107 ;
108CANRES ; 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.")
118CANRESQ K DA,DIC,DIE,DR,DLAYGO,IBCR,X,Y
119 Q
Note: See TracBrowser for help on using the repository browser.