PRCAWREA ;WASH-ISC@ALTOONA,PA/TJK-RE-ESTABLISH BILL ;7/24/96 2:35 PM
V ;;4.5;Accounts Receivable;**16,49,153,315,377,371**;Mar 20, 1995;Build 29
;;Per VA Directive 6402, this routine should not be modified.
;;Select bill to make active, cancellation, suspended, coll/clos or write-off
N DA,DIC,DIE,I,PRCABN,PRCATAMT,PRCAEN,PRCA,PRCAWO,PRCAPB,PRCATYPE,PRCATY,X,Y,FMSNUM,FMSAMT,PRCASTAT
D CKSITE^PRCAUDT I '$D(PRCA("CKSITE")) W !,"Your site is not defined." G EXIT
K DIC,DA S PRCAWO="," F I=109,240,111,108 S PRCAWO=$G(PRCAWO)_$O(^PRCA(430.3,"AC",I,0))_","
I $G(PRCAWO)']"" W !,"Transaction Types not defined, please contact IRM." G EXIT
S DIC("S")="I $P(^(0),U,2)'=26,"""_PRCAWO_"""[("",""_$P(^(0),U,8)_"","")" D BILLN^PRCAUTL G:$G(PRCABN)="" EXIT
;
APJ ; Entry point from the ENAP entry point (below) for the Account Profile screen *315
;
L +^PRCA(430,PRCABN):1 I '$T W !!,*7,"ANOTHER USER IS EDITING THIS BILL" G EXIT
S PRCAPB=$G(^PRCA(430,PRCABN,7)),PRCASTAT=$P(^PRCA(430,PRCABN,0),U,8)
S PRCATAMT=0 F I=1:1:5 S PRCATAMT=PRCATAMT+$P(PRCAPB,U,I)
I PRCATAMT=0&('$$ACCK^PRCAACC(PRCABN)) D G EXIT
.W !!,*7,"A bill with ZERO dollars CANNOT BE RE-ESTABLISHED."
.W !!,"Create a new bill."
.L -^PRCA(430,PRCABN) ; *315 bug fix - unlock the bill before exit
.Q
S FMSAMT=PRCATAMT
I PRCATAMT=0 D AMT I PRCATAMT'>0 W !!,"Sorry, no bill amount entered!" L -^PRCA(430,PRCABN) G EXIT ; *315 unlock bill
D SETTR^PRCAUTL,UPCALM^PRCAWO,PATTR^PRCAUTL
S PRCATYPE=$S($P(^PRCA(430,PRCABN,0),"^",8)=$O(^PRCA(430.3,"AC",240,0)):$O(^PRCA(430.3,"AC",18,0)),1:$O(^PRCA(430.3,"AC",250,0)))
K DIC,DIE,DR,DA S (DIC,DIE)="^PRCA(433,",DA=PRCAEN,DR="[PRCA RE-ESTABLISH WRITE-OFF]" D ^DIE K DIC,DA,DIE,DR
S PRCA("SDT")=DT,PRCA("STATUS")=$O(^PRCA(430.3,"AC",102,0)) D UPSTATS^PRCAUT2
S $P(^PRCA(433,PRCAEN,4,$O(^PRCA(433,PRCAEN,4,0)),0),U,5)=PRCATAMT
S $P(^PRCA(433,PRCAEN,0),U,4)=2 L -^PRCA(430,PRCABN)
;
;PRCA*4.5*377 - update Repayment Plan with re-establishment of the bill
D UPDBAL^RCRPU1(PRCABN,PRCAEN)
;
W !!,*7,?5,$P(^PRCA(430,PRCABN,0),U,1)," is in the ",$P(^PRCA(430.3,$P(^PRCA(430,PRCABN,0),U,8),0),U,1)," status for $",$P(^PRCA(433,PRCAEN,1),U,5)
I $P(^PRCA(430,PRCABN,0),U,8)=$O(^PRCA(430.3,"AC",102,"")) D PREPAY^RCBEPAYP(PRCABN)
I FMSAMT>0,PRCASTAT'=40,'$$ACCK^PRCAACC(PRCABN) D
.S FMSNUM=$P($G(^PRCA(430,PRCABN,11)),U,22),MOD=1
.I FMSNUM="" S FMSNUM=$$ENUM^RCMSNUM,MOD=0
.D MODWR^PRCAFWO(PRCABN,FMSAMT,FMSNUM,PRCAEN,MOD)
.Q
EXIT Q
AMT ;
;;Ask for amount to be re-established
N Y
AMTE R !!,"Enter Re-Establish Amount: ",Y:DTIME I '$T!(Y["^") S Y=0 G AMTQ
I Y="" W !,*7,"The amount is required. Enter ""^"" to exit!",!
I Y["?"!(Y'?.N.1".".2N)!(Y>999999.99)!(Y<.01) D AMTH G AMTE
; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
AMTQ S PRCATAMT=+Y
I Y>0 D
. N PRCFDA
. S PRCAPB=PRCATAMT_"^^^^^",PRCFDA(430,PRCABN_",",71)=Y
. S $P(^PRCA(430,PRCABN,2,$O(^PRCA(430,PRCABN,2,0)),0),U,2)=PRCATAMT
. D FILE^DIE(,"PRCFDA")
Q
AMTH W !,"Enter in an amount from .01 to 999999.99, 2 decimal digits"
W !!,"The bill must have an amount inorder to be re-established."
W !,"This amount will be the principal balance of the bill."
Q
;
ENAP(PRCABN) ; Entry point for Re-Establish bill from the Account Profile screen - *315
; originally called from REESTAB^RCDPAPL1. PRCABN is the internal bill# and is required.
;
N PG,PRS,I,PRCAWO,PRCATY,PRCA,PRCATAMT,PRCAEN,PRCAPB,PRCATYPE,PRCASTAT,FMSNUM,FMSAMT,MOD
N DA,DIC,DIE,DR,X,Y
;
; set other variables related to the bill
S PG=$G(^PRCA(430,PRCABN,0))
S PRCATY=$P(PG,U,2) ; ar category ien
S PRCA("SEG")=$S(+$P(PG,U,21)>240:$P(PG,U,21),1:"") ; segment - used in the input template
S PRCA("STATUS")=$P(PG,U,8) ; current status of the bill
S PRCA("APPR")=$P(PG,U,18) ; appropriation symbol
;
; get site stuff
S PRS=+$P($G(^RC(342,1,0)),U,1) ; main AR site
S PRCA("SITE")=+$$GET1^DIQ(4,PRS,99) ; station#
I PRCA("SITE") S PRCA("CKSITE")="" ; station# check flag
;
; build a string of valid internal status ien's (WRITE-OFF, SUSPENDED, CANCELLATION, COLLECTED/CLOSED)
S PRCAWO="," F I=109,240,111,108 S PRCAWO=PRCAWO_$O(^PRCA(430.3,"AC",I,0))_","
I '$F(PRCAWO,","_PRCA("STATUS")_",") D G ENAPX
. W !,"The Re-Establish action is not available for this bill because the current"
. W !,"AR status of this bill is "_$$GET1^DIQ(430,PRCABN,8)_"."
. W !,"Valid statuses are WRITE-OFF, SUSPENDED, CANCELLATION, or COLLECTED/CLOSED."
. Q
;
I PRCATY=26 D G ENAPX
. W !,"The Re-Establish action is not available for this bill because the current"
. W !,"AR category of this bill is "_$$GET1^DIQ(430,PRCABN,2)_". This is the only one not allowed."
. Q
;
G APJ ; jump into the routine at the proper point
;
ENAPX ;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAWREA 4971 printed Oct 16, 2024@17:42:58 Page 2
PRCAWREA ;WASH-ISC@ALTOONA,PA/TJK-RE-ESTABLISH BILL ;7/24/96 2:35 PM
V ;;4.5;Accounts Receivable;**16,49,153,315,377,371**;Mar 20, 1995;Build 29
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 ;;Select bill to make active, cancellation, suspended, coll/clos or write-off
+3 NEW DA,DIC,DIE,I,PRCABN,PRCATAMT,PRCAEN,PRCA,PRCAWO,PRCAPB,PRCATYPE,PRCATY,X,Y,FMSNUM,FMSAMT,PRCASTAT
+4 DO CKSITE^PRCAUDT
IF '$DATA(PRCA("CKSITE"))
WRITE !,"Your site is not defined."
GOTO EXIT
+5 KILL DIC,DA
SET PRCAWO=","
FOR I=109,240,111,108
SET PRCAWO=$GET(PRCAWO)_$ORDER(^PRCA(430.3,"AC",I,0))_","
+6 IF $GET(PRCAWO)']""
WRITE !,"Transaction Types not defined, please contact IRM."
GOTO EXIT
+7 SET DIC("S")="I $P(^(0),U,2)'=26,"""_PRCAWO_"""[("",""_$P(^(0),U,8)_"","")"
DO BILLN^PRCAUTL
if $GET(PRCABN)=""
GOTO EXIT
+8 ;
APJ ; Entry point from the ENAP entry point (below) for the Account Profile screen *315
+1 ;
+2 LOCK +^PRCA(430,PRCABN):1
IF '$TEST
WRITE !!,*7,"ANOTHER USER IS EDITING THIS BILL"
GOTO EXIT
+3 SET PRCAPB=$GET(^PRCA(430,PRCABN,7))
SET PRCASTAT=$PIECE(^PRCA(430,PRCABN,0),U,8)
+4 SET PRCATAMT=0
FOR I=1:1:5
SET PRCATAMT=PRCATAMT+$PIECE(PRCAPB,U,I)
+5 IF PRCATAMT=0&('$$ACCK^PRCAACC(PRCABN))
Begin DoDot:1
+6 WRITE !!,*7,"A bill with ZERO dollars CANNOT BE RE-ESTABLISHED."
+7 WRITE !!,"Create a new bill."
+8 ; *315 bug fix - unlock the bill before exit
LOCK -^PRCA(430,PRCABN)
+9 QUIT
End DoDot:1
GOTO EXIT
+10 SET FMSAMT=PRCATAMT
+11 ; *315 unlock bill
IF PRCATAMT=0
DO AMT
IF PRCATAMT'>0
WRITE !!,"Sorry, no bill amount entered!"
LOCK -^PRCA(430,PRCABN)
GOTO EXIT
+12 DO SETTR^PRCAUTL
DO UPCALM^PRCAWO
DO PATTR^PRCAUTL
+13 SET PRCATYPE=$SELECT($PIECE(^PRCA(430,PRCABN,0),"^",8)=$ORDER(^PRCA(430.3,"AC",240,0)):$ORDER(^PRCA(430.3,"AC",18,0)),1:$ORDER(^PRCA(430.3,"AC",250,0)))
+14 KILL DIC,DIE,DR,DA
SET (DIC,DIE)="^PRCA(433,"
SET DA=PRCAEN
SET DR="[PRCA RE-ESTABLISH WRITE-OFF]"
DO ^DIE
KILL DIC,DA,DIE,DR
+15 SET PRCA("SDT")=DT
SET PRCA("STATUS")=$ORDER(^PRCA(430.3,"AC",102,0))
DO UPSTATS^PRCAUT2
+16 SET $PIECE(^PRCA(433,PRCAEN,4,$ORDER(^PRCA(433,PRCAEN,4,0)),0),U,5)=PRCATAMT
+17 SET $PIECE(^PRCA(433,PRCAEN,0),U,4)=2
LOCK -^PRCA(430,PRCABN)
+18 ;
+19 ;PRCA*4.5*377 - update Repayment Plan with re-establishment of the bill
+20 DO UPDBAL^RCRPU1(PRCABN,PRCAEN)
+21 ;
+22 WRITE !!,*7,?5,$PIECE(^PRCA(430,PRCABN,0),U,1)," is in the ",$PIECE(^PRCA(430.3,$PIECE(^PRCA(430,PRCABN,0),U,8),0),U,1)," status for $",$PIECE(^PRCA(433,PRCAEN,1),U,5)
+23 IF $PIECE(^PRCA(430,PRCABN,0),U,8)=$ORDER(^PRCA(430.3,"AC",102,""))
DO PREPAY^RCBEPAYP(PRCABN)
+24 IF FMSAMT>0
IF PRCASTAT'=40
IF '$$ACCK^PRCAACC(PRCABN)
Begin DoDot:1
+25 SET FMSNUM=$PIECE($GET(^PRCA(430,PRCABN,11)),U,22)
SET MOD=1
+26 IF FMSNUM=""
SET FMSNUM=$$ENUM^RCMSNUM
SET MOD=0
+27 DO MODWR^PRCAFWO(PRCABN,FMSAMT,FMSNUM,PRCAEN,MOD)
+28 QUIT
End DoDot:1
EXIT QUIT
AMT ;
+1 ;;Ask for amount to be re-established
+2 NEW Y
AMTE READ !!,"Enter Re-Establish Amount: ",Y:DTIME
IF '$TEST!(Y["^")
SET Y=0
GOTO AMTQ
+1 IF Y=""
WRITE !,*7,"The amount is required. Enter ""^"" to exit!",!
+2 IF Y["?"!(Y'?.N.1".".2N)!(Y>999999.99)!(Y<.01)
DO AMTH
GOTO AMTE
+3 ; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
AMTQ SET PRCATAMT=+Y
+1 IF Y>0
Begin DoDot:1
+2 NEW PRCFDA
+3 SET PRCAPB=PRCATAMT_"^^^^^"
SET PRCFDA(430,PRCABN_",",71)=Y
+4 SET $PIECE(^PRCA(430,PRCABN,2,$ORDER(^PRCA(430,PRCABN,2,0)),0),U,2)=PRCATAMT
+5 DO FILE^DIE(,"PRCFDA")
End DoDot:1
+6 QUIT
AMTH WRITE !,"Enter in an amount from .01 to 999999.99, 2 decimal digits"
+1 WRITE !!,"The bill must have an amount inorder to be re-established."
+2 WRITE !,"This amount will be the principal balance of the bill."
+3 QUIT
+4 ;
ENAP(PRCABN) ; Entry point for Re-Establish bill from the Account Profile screen - *315
+1 ; originally called from REESTAB^RCDPAPL1. PRCABN is the internal bill# and is required.
+2 ;
+3 NEW PG,PRS,I,PRCAWO,PRCATY,PRCA,PRCATAMT,PRCAEN,PRCAPB,PRCATYPE,PRCASTAT,FMSNUM,FMSAMT,MOD
+4 NEW DA,DIC,DIE,DR,X,Y
+5 ;
+6 ; set other variables related to the bill
+7 SET PG=$GET(^PRCA(430,PRCABN,0))
+8 ; ar category ien
SET PRCATY=$PIECE(PG,U,2)
+9 ; segment - used in the input template
SET PRCA("SEG")=$SELECT(+$PIECE(PG,U,21)>240:$PIECE(PG,U,21),1:"")
+10 ; current status of the bill
SET PRCA("STATUS")=$PIECE(PG,U,8)
+11 ; appropriation symbol
SET PRCA("APPR")=$PIECE(PG,U,18)
+12 ;
+13 ; get site stuff
+14 ; main AR site
SET PRS=+$PIECE($GET(^RC(342,1,0)),U,1)
+15 ; station#
SET PRCA("SITE")=+$$GET1^DIQ(4,PRS,99)
+16 ; station# check flag
IF PRCA("SITE")
SET PRCA("CKSITE")=""
+17 ;
+18 ; build a string of valid internal status ien's (WRITE-OFF, SUSPENDED, CANCELLATION, COLLECTED/CLOSED)
+19 SET PRCAWO=","
FOR I=109,240,111,108
SET PRCAWO=PRCAWO_$ORDER(^PRCA(430.3,"AC",I,0))_","
+20 IF '$FIND(PRCAWO,","_PRCA("STATUS")_",")
Begin DoDot:1
+21 WRITE !,"The Re-Establish action is not available for this bill because the current"
+22 WRITE !,"AR status of this bill is "_$$GET1^DIQ(430,PRCABN,8)_"."
+23 WRITE !,"Valid statuses are WRITE-OFF, SUSPENDED, CANCELLATION, or COLLECTED/CLOSED."
+24 QUIT
End DoDot:1
GOTO ENAPX
+25 ;
+26 IF PRCATY=26
Begin DoDot:1
+27 WRITE !,"The Re-Establish action is not available for this bill because the current"
+28 WRITE !,"AR category of this bill is "_$$GET1^DIQ(430,PRCABN,2)_". This is the only one not allowed."
+29 QUIT
End DoDot:1
GOTO ENAPX
+30 ;
+31 ; jump into the routine at the proper point
GOTO APJ
+32 ;
ENAPX ;
+1 QUIT
+2 ;
