- PRCAEXM ;SF-ISC/YJK-ADMIN.COST CHARGE TRANSACTION ;15 Nov 2018 13:51:18
- ;;4.5;Accounts Receivable;**67,103,196,301,318,315,332,381,371**;Mar 20, 1995;Build 29
- ;Per VA Directive 6402, this routine should not be modified.
- ;
- ;Update Int/adm.balance and Administrative cost charge transaction, is called by ^PRCAWO.
- ;
- D EN1(0) ; Administrative Cost Adjustment [PRCAF ADJ ADMIN] option entry point, PRCA*4.5*332
- Q
- ;
- EN1(KEYCHK) ;Adjustment Interest/admin.cost from an AR - this makes the int/adm.balance
- ; ,marshal fee and court cost zero,0.
- ; KEYCHK (optional) - 1 check for RCDPEAR security key, zero otherwise, defaults to zero
- N PRCAIND,ADMINTOT,PRCAERR,PRCABN0
- I '$D(KEYCHK) N KEYCHK S KEYCHK=0
- I $G(KEYCHK)=1,'$D(^XUSEC("RCDPEAR",DUZ)) D Q ; PRCA*4.5*318 Added security key check
- . W !!,"This action can only be taken by users that have the RCDPEAR security key.",!
- . S VALMBCK="R"
- . D PAUSE^VALM1
- RTRN ; line tag for GOTO return
- D BEGIN^PRCAWO G:('$D(PRCABN))!('$D(PRCAEN)) END G:'$D(^PRCA(430,PRCABN,7)) END
- L +^PRCA(430,PRCABN):1 I '$T W !!,*7,"ANOTHER USER IS EDITING THIS BILL" G RTRN
- S PRCABN0=PRCABN
- S PRCAIND=$G(^PRCA(430,PRCABN,7))
- S PRCAMT=$P(PRCAIND,U,2)+$P(PRCAIND,U,3)+$P(PRCAIND,U,4)+$P(PRCAIND,U,5)
- S %=$P(^PRCA(430,PRCABN,0),U,2) I "PC"'[$P(^PRCA(430.2,%,0),U,6) W *7,!,"This AR may not be appropriate to charge Interest/Administrative cost.",!,"Please check the category of this AR.",! H 3
- K % W !!,"You may exempt the account from all the interest and administrative cost balances - making those balances zero (0),",!,"or adjust them."
- EN011 S %=2 W !!,"Do you want to exempt the account from all the Int/Adm. costs" D YN^DICN I %<0 S PRCACOMM="User Cancelled" D DELETE^PRCAWO1 K PRCACOMM G RTRN
- I %=1 D EN11,END G RTRN
- I %=0 W !,"ANSWER 'YES' OR 'NO' " G EN011
- W !,"Adjusting the administrative/Interest charge ...",!
- D DIEEN^PRCAWO1,END G RTRN
- ;
- ; exempt interest and admin charges
- EN11 S PRCATYPE=14,DIE="^PRCA(433,",DA=PRCAEN
- S DR=".03////^S X="_PRCABN_";11////^S X="_DT_";12////^S X="_PRCATYPE_";15////^S X="_PRCAMT_";"
- S DR=DR_"27////^S X="_+$P(PRCAIND,U,2)_";" ;interest
- S DR=DR_"28////^S X="_+$P(PRCAIND,U,3)_";" ;admin charge
- S DR=DR_"25////^S X="_+$P(PRCAIND,U,4)_";" ;marshal fee
- S DR=DR_"26////^S X="_+$P(PRCAIND,U,5)_";" ;court cost
- S DIC=DIE,PRCA("LOCK")=0 D LOCKF^PRCAWO1 Q:PRCA("LOCK")=1 D ^DIE
- I PRCAEN,$D(^PRCA(430,"TCSP",PRCABN)) D DECADJ^RCTCSPU(PRCABN,PRCAEN) ;prca*4.5*301 add cs 5B flag
- ; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
- N PRCFDA S PRCFDA(430,PRCABN_",",72)=0,PRCFDA(430,PRCABN_",",73)=0,PRCFDA(430,PRCABN_",",74)=0,PRCFDA(430,PRCABN_",",75)=0
- D FILE^DIE(,"PRCFDA"),TRANST^PRCAWO1
- ;
- ;PRCA*4.5*381 - Update Repayment Plan balance, if in a plan.
- D UPDBAL^RCRPU1(PRCABN,PRCAEN)
- ;
- Q
- ;
- ;
- EN2 Q:'$D(PRCAEN) Q:($P(^PRCA(433,PRCAEN,2),U,8)="")&($P(^PRCA(433,PRCAEN,2),U,7)="")
- W !,"MONTHLY ADMIN. CHARGE: ",?25,+$P(^PRCA(433,PRCAEN,2),U,8),?40,"INTEREST CHARGE: ",+$P(^PRCA(433,PRCAEN,2),U,7) Q
- ;
- END L -^PRCA(433,+$G(PRCAEN)),-^PRCA(430,+$G(PRCABN))
- S X(1)=0,X=$G(^PRCA(430,+$G(PRCABN0),7)),X(1)=+X,X(1)=$P(X,"^",2)+X(1),X(1)=$P(X,"^",3)+X(1),X(1)=$P(X,"^",4)+X(1),X(1)=$P(X,"^",5)+X(1)
- K PRCA("STATUS")
- I X(1)=0,$G(PRCABN0) D
- .;Check for payment transactions
- .F X=0:0 S X=$O(^PRCA(433,"C",PRCABN0,X)) Q:'X I ",2,7,20,"[(","_$P($G(^PRCA(430.3,+$P($G(^PRCA(433,X,1)),"^",2),0)),"^",3)_",") S PRCA("STATUS")=$O(^PRCA(430.3,"AC",108,0))
- .S:'$D(PRCA("STATUS")) PRCA("STATUS")=$O(^PRCA(430.3,"AC",111,0))
- .S DA=PRCABN0,DIE="^PRCA(430,",DR="8////"_PRCA("STATUS") D ^DIE
- K PRCATY,PRCA,PRCA2,PRCAD,PRCABN,PRCAEN,PRCATYPE,DA,DIE,DIC,PRCAMT,DR,X,% Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAEXM 3772 printed Feb 18, 2025@23:05:50 Page 2
- PRCAEXM ;SF-ISC/YJK-ADMIN.COST CHARGE TRANSACTION ;15 Nov 2018 13:51:18
- +1 ;;4.5;Accounts Receivable;**67,103,196,301,318,315,332,381,371**;Mar 20, 1995;Build 29
- +2 ;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;Update Int/adm.balance and Administrative cost charge transaction, is called by ^PRCAWO.
- +5 ;
- +6 ; Administrative Cost Adjustment [PRCAF ADJ ADMIN] option entry point, PRCA*4.5*332
- DO EN1(0)
- +7 QUIT
- +8 ;
- EN1(KEYCHK) ;Adjustment Interest/admin.cost from an AR - this makes the int/adm.balance
- +1 ; ,marshal fee and court cost zero,0.
- +2 ; KEYCHK (optional) - 1 check for RCDPEAR security key, zero otherwise, defaults to zero
- +3 NEW PRCAIND,ADMINTOT,PRCAERR,PRCABN0
- +4 IF '$DATA(KEYCHK)
- NEW KEYCHK
- SET KEYCHK=0
- +5 ; PRCA*4.5*318 Added security key check
- IF $GET(KEYCHK)=1
- IF '$DATA(^XUSEC("RCDPEAR",DUZ))
- Begin DoDot:1
- +6 WRITE !!,"This action can only be taken by users that have the RCDPEAR security key.",!
- +7 SET VALMBCK="R"
- +8 DO PAUSE^VALM1
- End DoDot:1
- QUIT
- RTRN ; line tag for GOTO return
- +1 DO BEGIN^PRCAWO
- if ('$DATA(PRCABN))!('$DATA(PRCAEN))
- GOTO END
- if '$DATA(^PRCA(430,PRCABN,7))
- GOTO END
- +2 LOCK +^PRCA(430,PRCABN):1
- IF '$TEST
- WRITE !!,*7,"ANOTHER USER IS EDITING THIS BILL"
- GOTO RTRN
- +3 SET PRCABN0=PRCABN
- +4 SET PRCAIND=$GET(^PRCA(430,PRCABN,7))
- +5 SET PRCAMT=$PIECE(PRCAIND,U,2)+$PIECE(PRCAIND,U,3)+$PIECE(PRCAIND,U,4)+$PIECE(PRCAIND,U,5)
- +6 SET %=$PIECE(^PRCA(430,PRCABN,0),U,2)
- IF "PC"'[$PIECE(^PRCA(430.2,%,0),U,6)
- WRITE *7,!,"This AR may not be appropriate to charge Interest/Administrative cost.",!,"Please check the category of this AR.",!
- HANG 3
- +7 KILL %
- WRITE !!,"You may exempt the account from all the interest and administrative cost balances - making those balances zero (0),",!,"or adjust them."
- EN011 SET %=2
- WRITE !!,"Do you want to exempt the account from all the Int/Adm. costs"
- DO YN^DICN
- IF %<0
- SET PRCACOMM="User Cancelled"
- DO DELETE^PRCAWO1
- KILL PRCACOMM
- GOTO RTRN
- +1 IF %=1
- DO EN11
- DO END
- GOTO RTRN
- +2 IF %=0
- WRITE !,"ANSWER 'YES' OR 'NO' "
- GOTO EN011
- +3 WRITE !,"Adjusting the administrative/Interest charge ...",!
- +4 DO DIEEN^PRCAWO1
- DO END
- GOTO RTRN
- +5 ;
- +6 ; exempt interest and admin charges
- EN11 SET PRCATYPE=14
- SET DIE="^PRCA(433,"
- SET DA=PRCAEN
- +1 SET DR=".03////^S X="_PRCABN_";11////^S X="_DT_";12////^S X="_PRCATYPE_";15////^S X="_PRCAMT_";"
- +2 ;interest
- SET DR=DR_"27////^S X="_+$PIECE(PRCAIND,U,2)_";"
- +3 ;admin charge
- SET DR=DR_"28////^S X="_+$PIECE(PRCAIND,U,3)_";"
- +4 ;marshal fee
- SET DR=DR_"25////^S X="_+$PIECE(PRCAIND,U,4)_";"
- +5 ;court cost
- SET DR=DR_"26////^S X="_+$PIECE(PRCAIND,U,5)_";"
- +6 SET DIC=DIE
- SET PRCA("LOCK")=0
- DO LOCKF^PRCAWO1
- if PRCA("LOCK")=1
- QUIT
- DO ^DIE
- +7 ;prca*4.5*301 add cs 5B flag
- IF PRCAEN
- IF $DATA(^PRCA(430,"TCSP",PRCABN))
- DO DECADJ^RCTCSPU(PRCABN,PRCAEN)
- +8 ; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
- +9 NEW PRCFDA
- SET PRCFDA(430,PRCABN_",",72)=0
- SET PRCFDA(430,PRCABN_",",73)=0
- SET PRCFDA(430,PRCABN_",",74)=0
- SET PRCFDA(430,PRCABN_",",75)=0
- +10 DO FILE^DIE(,"PRCFDA")
- DO TRANST^PRCAWO1
- +11 ;
- +12 ;PRCA*4.5*381 - Update Repayment Plan balance, if in a plan.
- +13 DO UPDBAL^RCRPU1(PRCABN,PRCAEN)
- +14 ;
- +15 QUIT
- +16 ;
- +17 ;
- EN2 if '$DATA(PRCAEN)
- QUIT
- if ($PIECE(^PRCA(433,PRCAEN,2),U,8)="")&($PIECE(^PRCA(433,PRCAEN,2),U,7)="")
- QUIT
- +1 WRITE !,"MONTHLY ADMIN. CHARGE: ",?25,+$PIECE(^PRCA(433,PRCAEN,2),U,8),?40,"INTEREST CHARGE: ",+$PIECE(^PRCA(433,PRCAEN,2),U,7)
- QUIT
- +2 ;
- END LOCK -^PRCA(433,+$GET(PRCAEN)),-^PRCA(430,+$GET(PRCABN))
- +1 SET X(1)=0
- SET X=$GET(^PRCA(430,+$GET(PRCABN0),7))
- SET X(1)=+X
- SET X(1)=$PIECE(X,"^",2)+X(1)
- SET X(1)=$PIECE(X,"^",3)+X(1)
- SET X(1)=$PIECE(X,"^",4)+X(1)
- SET X(1)=$PIECE(X,"^",5)+X(1)
- +2 KILL PRCA("STATUS")
- +3 IF X(1)=0
- IF $GET(PRCABN0)
- Begin DoDot:1
- +4 ;Check for payment transactions
- +5 FOR X=0:0
- SET X=$ORDER(^PRCA(433,"C",PRCABN0,X))
- if 'X
- QUIT
- IF ",2,7,20,"[(","_$PIECE($GET(^PRCA(430.3,+$PIECE($GET(^PRCA(433,X,1)),"^",2),0)),"^",3)_",")
- SET PRCA("STATUS")=$ORDER(^PRCA(430.3,"AC",108,0))
- +6 if '$DATA(PRCA("STATUS"))
- SET PRCA("STATUS")=$ORDER(^PRCA(430.3,"AC",111,0))
- +7 SET DA=PRCABN0
- SET DIE="^PRCA(430,"
- SET DR="8////"_PRCA("STATUS")
- DO ^DIE
- End DoDot:1
- +8 KILL PRCATY,PRCA,PRCA2,PRCAD,PRCABN,PRCAEN,PRCATYPE,DA,DIE,DIC,PRCAMT,DR,X,%
- QUIT
- +9 ;