RCKATP ;ALB/CPM - ADJUST ACCOUNTS FOR KATRINA VETS ; 28-FEB-06
;;4.5;Accounts Receivable;**241,246**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
POST ; Queue PRCA*4.5*241 post-init job.
;
D BMES^XPDUTL(">>> Queuing the post-initialization to run now...")
S ZTDTH=$H,ZTRTN="EN^RCKATP",ZTIO=""
S ZTDESC="RC - PATCH PRCA*4.5*241 POST INITIALIZATION"
D ^%ZTLOAD
I $D(ZTSK) D MES^XPDUTL(" >> Queued as task #"_ZTSK_".")
I '$D(ZTSK) D MES^XPDUTL(" >> Unable to queue task - contact EVS.")
K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO
Q
;
;
EN ; Queued entry point to run the PRCA*4.5*241 post init.
;
D EX ; exempt interest - return RCTOTAL
;
S RCRES=$$CAN^IBAKAT() ; cancel copay charges
;
D BULL ; generate bulletin with results
;
I $D(ZTQUEUED) S ZTREQ="@"
K RCTOTAL,RCRES
Q
;
;
EX ; Entry point to exempt interest/admin charges
;
; - get all 'Katrina' vets based on interest/admin charges
K ^TMP("RCKATP",$J)
S RCCOM(1)="INTEREST ADJUSTMENT FOR HURRICANE KATRINA VETERAN"
S RCD=3050828.9
F S RCD=$O(^PRCA(433,"AT",13,RCD)) Q:'RCD!($P(RCD,".")>3060430) D
.S RCT=0 F S RCT=$O(^PRCA(433,"AT",13,RCD,RCT)) Q:'RCT D
..S RCB=+$P($G(^PRCA(433,RCT,0)),"^",2) Q:'RCB
..I '$P($G(^PRCA(430,RCB,0)),"^",12) Q
..S RCDPT=+$P($G(^PRCA(430,RCB,0)),"^",9)
..S RCDEB=$G(^RCD(340,RCDPT,0))
..Q:$P(RCDEB,"^")'["DPT" Q:'RCDEB
..;Q:$$EMERES^PRCAUTL(+RCDEB)=""
..Q:$$EMGRES^DGUTL(+RCDEB)=""
..Q:$P(RCDEB,"^",8) ; vet has been already been processed
..;
..; - store the vet and bill
..S ^TMP("RCKATP",$J,RCDPT,RCB)=""
;
; - look for extra interest exemptions to create
S RCTOTAL="0^0"
S RCDEB=0 F S RCDEB=$O(^TMP("RCKATP",$J,RCDEB)) Q:'RCDEB D
.;
.; - initialize bucket and new patient flag
.S (RCBUCK,RCNEWP)=0
.S RCB=0 F S RCB=$O(^TMP("RCKATP",$J,RCDEB,RCB)) Q:'RCB D
..;
..; - review transactions to find interest added/exempted
..S RCCB=$$GETTRANS^RCDPBTLM(RCB),RCH=0,RCHOLD=""
..S RCDT=3050828.9 F S RCDT=$O(RCLIST(RCDT)) Q:'RCDT D
...S RCT=0 F S RCT=$O(RCLIST(RCDT,RCT)) Q:'RCT D
....S RCV=RCLIST(RCDT,RCT)
....;
....; - if transaction is an interest charge, save off amount
....I RCV["INTEREST/ADM. CHARGE",RCDT<3060501 S RCH=1 D Q
.....S $P(RCHOLD,"^")=$P(RCHOLD,"^")+$P(RCV,"^",3)
.....S $P(RCHOLD,"^",2)=$P(RCHOLD,"^",2)+$P(RCV,"^",4)
....;
....; - if transaction is an interest exemption, save off (+) amount
....I RCV["EXEMPT INT/ADM. COST",RCH D Q
.....S $P(RCHOLD,"^",3)=$P(RCHOLD,"^",3)-$P(RCV,"^",3)
.....S $P(RCHOLD,"^",4)=$P(RCHOLD,"^",4)-$P(RCV,"^",4)
..;
..; - get total amounts of interest added and exempted
..S RCINT=$P(RCHOLD,"^")+$P(RCHOLD,"^",2)
..S RCEXEM=$P(RCHOLD,"^",3)+$P(RCHOLD,"^",4)
..;
..; - quit if interest added less than or equal to exemptions
..S RCAPPLY=RCINT-RCEXEM
..Q:RCAPPLY'>0
..;
..; - get bill's interest balance
..S RCNEWP=1
..S X=$G(^PRCA(430,RCB,7)),RCINTB=$P(X,"^",2)+$P(X,"^",3)
..;
..; - if no balance, put in bucket and quit
..I 'RCINTB S RCBUCK=RCBUCK+RCAPPLY Q
..;
..; - adjust bucket and amount to apply
..S RCAMT=$S(RCAPPLY'<RCINTB:RCINTB,1:RCAPPLY)
..S RCBUCK=$S(RCAPPLY>RCINTB:RCBUCK+(RCAPPLY-RCINTB),1:RCBUCK)
..;
..; - will apply RCAMT - spread over admin then interest.
..S RCAPA=$S(RCAMT'<$P(X,"^",3):$P(X,"^",3),1:RCAMT)
..S RCAPI=RCAMT-RCAPA
..S RC=$$EXEMPT^RCBEUTR2(RCB,RCAPI_"^"_RCAPA,.RCCOM,0)
..;
..; - update total amount exempted
..S $P(RCTOTAL,"^",2)=$P(RCTOTAL,"^",2)+RCAMT
.;
.;
.; - set debtor as having been processed
.S $P(^RCD(340,RCDEB,0),"^",8)=1
.;
.; - if an amount is left in the bucket, process it,
.; update total exempted, and the number of vets exempted
.I RCBUCK D
..D EN^RCKATPD($P($G(^RCD(340,RCDEB,0)),"^"),RCBUCK,RCCOM(1))
..S $P(RCTOTAL,"^",2)=$P(RCTOTAL,"^",2)+RCBUCK
.I RCNEWP S $P(RCTOTAL,"^")=$P(RCTOTAL,"^")+1
;
;
K ^TMP("RCKATP",$J)
K RCD,RCT,RCB,RCDPT,RCDEB,RCBUCK,RCNEWP,RC,RCCB,RCH,RCHOLD,RCDT
K RCLIST,RCV,RCINT,RCINTB,RCEXEM,RCAPPLY,RCAMT,RCAPA,RCAPI,RCCOM,X
Q
;
;
CHK(DFN) ; Check to see if vet should have charges cancelled
; Input: DFN -- Pointer to patient in file 2
; Output: 0 -- No, don't cancel charges
; 1 -- Yes, cancel charges
N RCDEB,RCH
S RCH=0
;I $$EMERES^PRCAUTL(DFN)="" G CHKQ
I $$EMGRES^DGUTL(DFN)="" G CHKQ
S RCDEB=$O(^RCD(340,"B",DFN_";DPT(",0))
;
; - if a Katrina vet is not in file #340, must look for held charges
I 'RCDEB S RCH=1 G CHKQ
;
; - make sure charges have not yet been canceled
I '$P($G(^RCD(340,RCDEB,0)),"^",9) S RCH=1
CHKQ Q RCH
;
;
TPP(RCTI,RCH) ; Identify decreases that are credits for third party payments
; Input: RCTI -- Pointer to AR Transaction in file 433
; RCH -- Array of 'counted' transactions passed by reference
; Output: RCRES -- 1^2, where
; 1 = total amount of credit adjustments
; 2 = pointer to the affected bill in file #430
;
N RCRES,RCB,RCAMT,RCT,RCTD,RCQ,RCI,RCS
S RCRES="",RCAMT=0
I '$G(RCTI) G TPPQ
S RCB=+$P($G(^PRCA(433,RCTI,0)),"^",2) I 'RCB G TPPQ
S RCAMT=0
S RCT=RCTI F S RCT=$O(^PRCA(433,"C",RCB,RCT)) Q:'RCT D
.Q:$D(RCH(RCB,RCT)) ; transaction has been counted
.S RCTD=$G(^PRCA(433,RCT,1))
.Q:$P(RCTD,"^",2)'=35 ; not a decrease
.;
.; - check for a potential 'Katrina decrease'
.S RCQ=0,RCS="HURRICANE KATRINA VETERAN" D Q:RCQ
..S RCI=0 F S RCI=$O(^PRCA(433,RCT,7,RCI)) Q:'RCI D Q:RCQ
...I $G(^PRCA(433,RCT,7,RCI,0))[RCS S RCQ=1
.;
.; - increment the credit amount
.S RCAMT=RCAMT+$P(RCTD,"^",5),RCH(RCB,RCT)=""
;
S RCRES=RCAMT_"^"_RCB
TPPQ Q RCRES
;
;
DEC(RCBILL,RCAMT) ; Decrease a bill
; Input: RCBILL -- Bill Number of a bill in file 430
; RCAMT -- Amount to decrease bill
; Output: RCBUCK -- Amount not decreased, to go to bucket
;
N RCBUCK,RCMSG,RCT
S RCBUCK=RCAMT
S RCB=$O(^PRCA(430,"B",RCBILL,0))
I RCB D
.S RCMSG="CANCEL COPAYMENTS FOR HURRICANE KATRINA VETERAN"
.D DEC^PRCASER1(RCB,.RCBUCK,DUZ,RCMSG,"",.RCT)
DECQ Q RCBUCK
;
;
FLAG(DFN) ; Flag veteran as having had copay charges cancelled
; Input: DFN -- Pointer to patient in file 2
;
N RCDEB
S RCDEB=$O(^RCD(340,"B",DFN_";DPT(",0))
I 'RCDEB D
.S DIC="^RCD(340,",DIC(0)="QL",X=DFN_";DPT(",DLAYGO=340
.K DD,DO D FILE^DICN K DIC,DLAYGO,DO,DD S RCDEB=+Y
I RCDEB>0 S $P(^RCD(340,RCDEB,0),"^",9)=1
Q
;
;
ADJ(DFN,RCAMT) ; Make final credit adjustments to the vet's account
; Input: DFN -- Pointer to patient in file 2
; RCAMT -- Amount to decrease from account
;
N RCDEBN,RCMSG
S RCDEBN=DFN_";DPT("
S RCMSG="CANCEL COPAYMENTS FOR HURRICANE KATRINA VETERAN"
D EN^RCKATPD(RCDEBN,RCAMT,RCMSG)
Q
;
;
BULL ; Send job completion bulletin
N XMSUB,XMTEXT,XMY,XMDUZ,RCT,RCN
S RCT(1)="The patch PRCA*4.5*241 post initialization has completed."
S RCT(2)=" "
S RCT(3)="Number of Veterans with Interest Exempted: "_+RCTOTAL
S RCT(4)=" Total Amount of Interest Exempted: $"_$J($P(RCTOTAL,"^",2),0,2)
S RCT(5)=" "
I RCRES="" S RCT(6)="*** Note: Copay Charges were not cancelled - contact EVS ***"
I RCRES'="" D
.S RCT(6)="Number of Veterans with Charges Cancelled: "_+RCRES
.S RCT(7)=" Total Amount of Charges Cancelled: $"_$J($P(RCRES,"^",2),0,2)
.S RCT(8)=" Total Amount of Held Charges Cancelled: $"_$J($P(RCRES,"^",3),0,2)
;
S XMSUB="Job Completion - PRCA*4.5*241 Post Initialization"
S XMTEXT="RCT("
S XMY("G.PRCA ADJUSTMENT TRANS")="",XMY(DUZ)=""
S XMDUZ="ACCOUNTS RECEIVABLE"
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCKATP 7749 printed Sep 23, 2025@19:23:15 Page 2
RCKATP ;ALB/CPM - ADJUST ACCOUNTS FOR KATRINA VETS ; 28-FEB-06
+1 ;;4.5;Accounts Receivable;**241,246**;Mar 20, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
POST ; Queue PRCA*4.5*241 post-init job.
+1 ;
+2 DO BMES^XPDUTL(">>> Queuing the post-initialization to run now...")
+3 SET ZTDTH=$HOROLOG
SET ZTRTN="EN^RCKATP"
SET ZTIO=""
+4 SET ZTDESC="RC - PATCH PRCA*4.5*241 POST INITIALIZATION"
+5 DO ^%ZTLOAD
+6 IF $DATA(ZTSK)
DO MES^XPDUTL(" >> Queued as task #"_ZTSK_".")
+7 IF '$DATA(ZTSK)
DO MES^XPDUTL(" >> Unable to queue task - contact EVS.")
+8 KILL ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO
+9 QUIT
+10 ;
+11 ;
EN ; Queued entry point to run the PRCA*4.5*241 post init.
+1 ;
+2 ; exempt interest - return RCTOTAL
DO EX
+3 ;
+4 ; cancel copay charges
SET RCRES=$$CAN^IBAKAT()
+5 ;
+6 ; generate bulletin with results
DO BULL
+7 ;
+8 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+9 KILL RCTOTAL,RCRES
+10 QUIT
+11 ;
+12 ;
EX ; Entry point to exempt interest/admin charges
+1 ;
+2 ; - get all 'Katrina' vets based on interest/admin charges
+3 KILL ^TMP("RCKATP",$JOB)
+4 SET RCCOM(1)="INTEREST ADJUSTMENT FOR HURRICANE KATRINA VETERAN"
+5 SET RCD=3050828.9
+6 FOR
SET RCD=$ORDER(^PRCA(433,"AT",13,RCD))
if 'RCD!($PIECE(RCD,".")>3060430)
QUIT
Begin DoDot:1
+7 SET RCT=0
FOR
SET RCT=$ORDER(^PRCA(433,"AT",13,RCD,RCT))
if 'RCT
QUIT
Begin DoDot:2
+8 SET RCB=+$PIECE($GET(^PRCA(433,RCT,0)),"^",2)
if 'RCB
QUIT
+9 IF '$PIECE($GET(^PRCA(430,RCB,0)),"^",12)
QUIT
+10 SET RCDPT=+$PIECE($GET(^PRCA(430,RCB,0)),"^",9)
+11 SET RCDEB=$GET(^RCD(340,RCDPT,0))
+12 if $PIECE(RCDEB,"^")'["DPT"
QUIT
if 'RCDEB
QUIT
+13 ;Q:$$EMERES^PRCAUTL(+RCDEB)=""
+14 if $$EMGRES^DGUTL(+RCDEB)=""
QUIT
+15 ; vet has been already been processed
if $PIECE(RCDEB,"^",8)
QUIT
+16 ;
+17 ; - store the vet and bill
+18 SET ^TMP("RCKATP",$JOB,RCDPT,RCB)=""
End DoDot:2
End DoDot:1
+19 ;
+20 ; - look for extra interest exemptions to create
+21 SET RCTOTAL="0^0"
+22 SET RCDEB=0
FOR
SET RCDEB=$ORDER(^TMP("RCKATP",$JOB,RCDEB))
if 'RCDEB
QUIT
Begin DoDot:1
+23 ;
+24 ; - initialize bucket and new patient flag
+25 SET (RCBUCK,RCNEWP)=0
+26 SET RCB=0
FOR
SET RCB=$ORDER(^TMP("RCKATP",$JOB,RCDEB,RCB))
if 'RCB
QUIT
Begin DoDot:2
+27 ;
+28 ; - review transactions to find interest added/exempted
+29 SET RCCB=$$GETTRANS^RCDPBTLM(RCB)
SET RCH=0
SET RCHOLD=""
+30 SET RCDT=3050828.9
FOR
SET RCDT=$ORDER(RCLIST(RCDT))
if 'RCDT
QUIT
Begin DoDot:3
+31 SET RCT=0
FOR
SET RCT=$ORDER(RCLIST(RCDT,RCT))
if 'RCT
QUIT
Begin DoDot:4
+32 SET RCV=RCLIST(RCDT,RCT)
+33 ;
+34 ; - if transaction is an interest charge, save off amount
+35 IF RCV["INTEREST/ADM. CHARGE"
IF RCDT<3060501
SET RCH=1
Begin DoDot:5
+36 SET $PIECE(RCHOLD,"^")=$PIECE(RCHOLD,"^")+$PIECE(RCV,"^",3)
+37 SET $PIECE(RCHOLD,"^",2)=$PIECE(RCHOLD,"^",2)+$PIECE(RCV,"^",4)
End DoDot:5
QUIT
+38 ;
+39 ; - if transaction is an interest exemption, save off (+) amount
+40 IF RCV["EXEMPT INT/ADM. COST"
IF RCH
Begin DoDot:5
+41 SET $PIECE(RCHOLD,"^",3)=$PIECE(RCHOLD,"^",3)-$PIECE(RCV,"^",3)
+42 SET $PIECE(RCHOLD,"^",4)=$PIECE(RCHOLD,"^",4)-$PIECE(RCV,"^",4)
End DoDot:5
QUIT
End DoDot:4
End DoDot:3
+43 ;
+44 ; - get total amounts of interest added and exempted
+45 SET RCINT=$PIECE(RCHOLD,"^")+$PIECE(RCHOLD,"^",2)
+46 SET RCEXEM=$PIECE(RCHOLD,"^",3)+$PIECE(RCHOLD,"^",4)
+47 ;
+48 ; - quit if interest added less than or equal to exemptions
+49 SET RCAPPLY=RCINT-RCEXEM
+50 if RCAPPLY'>0
QUIT
+51 ;
+52 ; - get bill's interest balance
+53 SET RCNEWP=1
+54 SET X=$GET(^PRCA(430,RCB,7))
SET RCINTB=$PIECE(X,"^",2)+$PIECE(X,"^",3)
+55 ;
+56 ; - if no balance, put in bucket and quit
+57 IF 'RCINTB
SET RCBUCK=RCBUCK+RCAPPLY
QUIT
+58 ;
+59 ; - adjust bucket and amount to apply
+60 SET RCAMT=$SELECT(RCAPPLY'<RCINTB:RCINTB,1:RCAPPLY)
+61 SET RCBUCK=$SELECT(RCAPPLY>RCINTB:RCBUCK+(RCAPPLY-RCINTB),1:RCBUCK)
+62 ;
+63 ; - will apply RCAMT - spread over admin then interest.
+64 SET RCAPA=$SELECT(RCAMT'<$PIECE(X,"^",3):$PIECE(X,"^",3),1:RCAMT)
+65 SET RCAPI=RCAMT-RCAPA
+66 SET RC=$$EXEMPT^RCBEUTR2(RCB,RCAPI_"^"_RCAPA,.RCCOM,0)
+67 ;
+68 ; - update total amount exempted
+69 SET $PIECE(RCTOTAL,"^",2)=$PIECE(RCTOTAL,"^",2)+RCAMT
End DoDot:2
+70 ;
+71 ;
+72 ; - set debtor as having been processed
+73 SET $PIECE(^RCD(340,RCDEB,0),"^",8)=1
+74 ;
+75 ; - if an amount is left in the bucket, process it,
+76 ; update total exempted, and the number of vets exempted
+77 IF RCBUCK
Begin DoDot:2
+78 DO EN^RCKATPD($PIECE($GET(^RCD(340,RCDEB,0)),"^"),RCBUCK,RCCOM(1))
+79 SET $PIECE(RCTOTAL,"^",2)=$PIECE(RCTOTAL,"^",2)+RCBUCK
End DoDot:2
+80 IF RCNEWP
SET $PIECE(RCTOTAL,"^")=$PIECE(RCTOTAL,"^")+1
End DoDot:1
+81 ;
+82 ;
+83 KILL ^TMP("RCKATP",$JOB)
+84 KILL RCD,RCT,RCB,RCDPT,RCDEB,RCBUCK,RCNEWP,RC,RCCB,RCH,RCHOLD,RCDT
+85 KILL RCLIST,RCV,RCINT,RCINTB,RCEXEM,RCAPPLY,RCAMT,RCAPA,RCAPI,RCCOM,X
+86 QUIT
+87 ;
+88 ;
CHK(DFN) ; Check to see if vet should have charges cancelled
+1 ; Input: DFN -- Pointer to patient in file 2
+2 ; Output: 0 -- No, don't cancel charges
+3 ; 1 -- Yes, cancel charges
+4 NEW RCDEB,RCH
+5 SET RCH=0
+6 ;I $$EMERES^PRCAUTL(DFN)="" G CHKQ
+7 IF $$EMGRES^DGUTL(DFN)=""
GOTO CHKQ
+8 SET RCDEB=$ORDER(^RCD(340,"B",DFN_";DPT(",0))
+9 ;
+10 ; - if a Katrina vet is not in file #340, must look for held charges
+11 IF 'RCDEB
SET RCH=1
GOTO CHKQ
+12 ;
+13 ; - make sure charges have not yet been canceled
+14 IF '$PIECE($GET(^RCD(340,RCDEB,0)),"^",9)
SET RCH=1
CHKQ QUIT RCH
+1 ;
+2 ;
TPP(RCTI,RCH) ; Identify decreases that are credits for third party payments
+1 ; Input: RCTI -- Pointer to AR Transaction in file 433
+2 ; RCH -- Array of 'counted' transactions passed by reference
+3 ; Output: RCRES -- 1^2, where
+4 ; 1 = total amount of credit adjustments
+5 ; 2 = pointer to the affected bill in file #430
+6 ;
+7 NEW RCRES,RCB,RCAMT,RCT,RCTD,RCQ,RCI,RCS
+8 SET RCRES=""
SET RCAMT=0
+9 IF '$GET(RCTI)
GOTO TPPQ
+10 SET RCB=+$PIECE($GET(^PRCA(433,RCTI,0)),"^",2)
IF 'RCB
GOTO TPPQ
+11 SET RCAMT=0
+12 SET RCT=RCTI
FOR
SET RCT=$ORDER(^PRCA(433,"C",RCB,RCT))
if 'RCT
QUIT
Begin DoDot:1
+13 ; transaction has been counted
if $DATA(RCH(RCB,RCT))
QUIT
+14 SET RCTD=$GET(^PRCA(433,RCT,1))
+15 ; not a decrease
if $PIECE(RCTD,"^",2)'=35
QUIT
+16 ;
+17 ; - check for a potential 'Katrina decrease'
+18 SET RCQ=0
SET RCS="HURRICANE KATRINA VETERAN"
Begin DoDot:2
+19 SET RCI=0
FOR
SET RCI=$ORDER(^PRCA(433,RCT,7,RCI))
if 'RCI
QUIT
Begin DoDot:3
+20 IF $GET(^PRCA(433,RCT,7,RCI,0))[RCS
SET RCQ=1
End DoDot:3
if RCQ
QUIT
End DoDot:2
if RCQ
QUIT
+21 ;
+22 ; - increment the credit amount
+23 SET RCAMT=RCAMT+$PIECE(RCTD,"^",5)
SET RCH(RCB,RCT)=""
End DoDot:1
+24 ;
+25 SET RCRES=RCAMT_"^"_RCB
TPPQ QUIT RCRES
+1 ;
+2 ;
DEC(RCBILL,RCAMT) ; Decrease a bill
+1 ; Input: RCBILL -- Bill Number of a bill in file 430
+2 ; RCAMT -- Amount to decrease bill
+3 ; Output: RCBUCK -- Amount not decreased, to go to bucket
+4 ;
+5 NEW RCBUCK,RCMSG,RCT
+6 SET RCBUCK=RCAMT
+7 SET RCB=$ORDER(^PRCA(430,"B",RCBILL,0))
+8 IF RCB
Begin DoDot:1
+9 SET RCMSG="CANCEL COPAYMENTS FOR HURRICANE KATRINA VETERAN"
+10 DO DEC^PRCASER1(RCB,.RCBUCK,DUZ,RCMSG,"",.RCT)
End DoDot:1
DECQ QUIT RCBUCK
+1 ;
+2 ;
FLAG(DFN) ; Flag veteran as having had copay charges cancelled
+1 ; Input: DFN -- Pointer to patient in file 2
+2 ;
+3 NEW RCDEB
+4 SET RCDEB=$ORDER(^RCD(340,"B",DFN_";DPT(",0))
+5 IF 'RCDEB
Begin DoDot:1
+6 SET DIC="^RCD(340,"
SET DIC(0)="QL"
SET X=DFN_";DPT("
SET DLAYGO=340
+7 KILL DD,DO
DO FILE^DICN
KILL DIC,DLAYGO,DO,DD
SET RCDEB=+Y
End DoDot:1
+8 IF RCDEB>0
SET $PIECE(^RCD(340,RCDEB,0),"^",9)=1
+9 QUIT
+10 ;
+11 ;
ADJ(DFN,RCAMT) ; Make final credit adjustments to the vet's account
+1 ; Input: DFN -- Pointer to patient in file 2
+2 ; RCAMT -- Amount to decrease from account
+3 ;
+4 NEW RCDEBN,RCMSG
+5 SET RCDEBN=DFN_";DPT("
+6 SET RCMSG="CANCEL COPAYMENTS FOR HURRICANE KATRINA VETERAN"
+7 DO EN^RCKATPD(RCDEBN,RCAMT,RCMSG)
+8 QUIT
+9 ;
+10 ;
BULL ; Send job completion bulletin
+1 NEW XMSUB,XMTEXT,XMY,XMDUZ,RCT,RCN
+2 SET RCT(1)="The patch PRCA*4.5*241 post initialization has completed."
+3 SET RCT(2)=" "
+4 SET RCT(3)="Number of Veterans with Interest Exempted: "_+RCTOTAL
+5 SET RCT(4)=" Total Amount of Interest Exempted: $"_$JUSTIFY($PIECE(RCTOTAL,"^",2),0,2)
+6 SET RCT(5)=" "
+7 IF RCRES=""
SET RCT(6)="*** Note: Copay Charges were not cancelled - contact EVS ***"
+8 IF RCRES'=""
Begin DoDot:1
+9 SET RCT(6)="Number of Veterans with Charges Cancelled: "_+RCRES
+10 SET RCT(7)=" Total Amount of Charges Cancelled: $"_$JUSTIFY($PIECE(RCRES,"^",2),0,2)
+11 SET RCT(8)=" Total Amount of Held Charges Cancelled: $"_$JUSTIFY($PIECE(RCRES,"^",3),0,2)
End DoDot:1
+12 ;
+13 SET XMSUB="Job Completion - PRCA*4.5*241 Post Initialization"
+14 SET XMTEXT="RCT("
+15 SET XMY("G.PRCA ADJUSTMENT TRANS")=""
SET XMY(DUZ)=""
+16 SET XMDUZ="ACCOUNTS RECEIVABLE"
+17 DO ^XMD
+18 QUIT
