- 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 Feb 18, 2025@23:32:47 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