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