- 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 Feb 18, 2025@23:13:30 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