PRCAEIN ;SF-ISC/YJK-EDIT INCOMPLETE ACCOUNTS RECEIVABLE ;10/17/96 1:07 PM
V ;;4.5;Accounts Receivable;**57,67,153,371**;Mar 20, 1995;Build 29
;;Per VHA Directive 6402, this routine should not be modified.
;This edits incomplete accounts receivable. The account is classified
;with category.
;
;===================== EDIT INCOMPLETE AR ===========================
EDIN ;edit incomplete accounts receivable.
K PRCA("CKSITE") D CKSITE G:'$D(PRCA("CKSITE")) END S DIC("S")="S Z0=$S($D(^PRCA(430.3,+$P(^(0),U,8),0)):$P(^(0),U,3),1:0) I Z0=101"
D DIC^PRCAUDT G:'$D(PRCABN) END S PRCADIOK=0,PRCA("MESS1")="THE ACCOUNT IS STILL INCOMPLETE",PRCA("MESS2")="*** EDITED AND RELEASED TO ACCOUNTING TECHNICIAN ***"
K PRCADINO D EDT I $G(PRCABN),$P(^PRCA(430,PRCABN,0),U,8)=$O(^PRCA(430.3,"AC",102,0)) D PREPAY^RCBEPAYP(PRCABN)
D KILLV G EDIN
EDT D DIE I $D(PRCADINO),($P(^PRCA(430,PRCABN,0),U,2)="")!($P(^(0),U,9)="") S PRCADEL=1 Q
;DIS
I $D(PRCADINO) W !!,*7,PRCA("MESS1"),!! Q
DIP S PRCAT=+$P(^PRCA(430,PRCABN,0),U,2) D:$P(^PRCA(430.2,PRCAT,0),U,3)>0 SEGMT^PRCAEOL S PRCAT=$S($D(^PRCA(430.2,PRCAT,0)):$P(^(0),U,6),1:"") D DISPL,DISPLACC^PRCAFUT S PRCAOK=0 D ASK1 G:$D(PRCA("EXIT")) DIP1
I PRCAOK=1 G:'$D(PRCANM) DIP1 S PRCA("STATUS")=$O(^PRCA(430.3,"AC",102,"")),PRCA("SDT")=DT D D UPSEG^PRCAUDT,UPSTATS^PRCAUT2 Q
. I $$ACCK^PRCAACC(PRCABN) D ASTAT Q
. D EN^PRCAFBD(PRCABN,.ERR)
. I +ERR>0 D Q
.. W !!,*7,"Error creating FMS Billing Document:",!,?10,$P(ERR,U,2),!,"Bill status remains 'NEW BILL'",!!
.. S PRCA("STATUS")=$O(^PRCA(430.3,"AC",104,""))
..Q
. S PRCA("STATUS")=$O(^PRCA(430.3,"AC",102,""))
. Q
D ASK2 I PRCAOK=1 D DIE G DIP
DIP1 W !!,PRCA("MESS1"),! D KILLV Q ;end of EDIN
ASTAT ;Set status for accrued bills
S PRCA("DEBTOR")=$P(^PRCA(430,PRCABN,0),"^",9) Q:PRCA("DEBTOR")=""
S PRCA("STATUS")=$O(^PRCA(430.3,"AC",102,"")),PRCA("MESS2")="** ACCRUED BILL, STATUS IS NOW ACTIVE **" Q
KILLV L -^PRCA(430,+$G(PRCABN))
K PRCADIOK,PRCADEL,DIC,DR,DIE,PRCAT,PRCAGLN,PRCA("CKSITE"),PRCADINO,PRCAOK,PRCA("MESS1"),PRCA("MESS2"),PRCA("EXIT"),PRCABN,PRCAT,PRCANM,PRCADEL,PRCATY,Z1,ZZ,J,D0,D1,PRC Q
END D KILLV K PRCA Q
;======================= SUBROUTINES ================================
DIE K PRCAT W ! S DA=PRCABN,DIC="^PRCA(430,",PRCA("LOCK")=0 D LOCKF^PRCAWO1 Q:PRCA("LOCK")=1 S DIE=DIC,DR="[PRCA CAT SET]" D ^DIE K DR,DIE,DA
I ($P(^PRCA(430,PRCABN,0),U,2)="")!($D(Y)) W:$P(^(0),U,2)="" !,*7," You should enter a category.",! S PRCADINO="" Q
S PRCAT=$P(^PRCA(430.2,+$P(^PRCA(430,PRCABN,0),U,2),0),U,6),PRCAGLN=$P(^(0),U,4) S:$P(^(0),U,7)=24 PRCAT("C")=1
D1 S DIE="^PRCA(430,",DA=PRCABN,DR="[PRCA SET]" D ^DIE I $D(Y) S PRCA("EXIT")="",PRCADINO="" Q
D MTIFY I $D(PRCA("EXIT")) S PRCADIN0="" Q
K DR D:'$$ACCK^PRCAACC(PRCABN) CPLK^PRCAFUT(PRCABN) I $D(PRCA("EXIT")) S PRCADINO="" Q
D COMMENTS^PRCAUT3 I $D(PRCA("EXIT")) S PRCADINO="" Q
I +$P(^PRCA(430,PRCABN,0),U,5)'>0 W !,*7,?3,"The 'Bill Resulting From' input does not exist.",! S PRCADINO="" Q
Q
DISPL ;display the accounts receivable data user has entered.
Q:'$D(PRCABN) I '$D(IOF) S IOP="" D ^%ZIS
W @IOF S D0=PRCABN K ^UTILITY($J,"W"),DXS D ^PRCATO2,WOBIL^PRCAUDT1 K DXS Q
ASK2 S %=2 W !!,"DO YOU WANT TO EDIT THE DATA" D YN^DICN I %=0 D M2^PRCAMESG G ASK2
Q:%'=1 S PRCAOK=1 Q
ASK1 S %=2 W !!,"IS THIS DATA CORRECT" D YN^DICN I %<0 S PRCA("EXIT")="" Q
I %=0 D M1^PRCAMESG G ASK1
Q:%'=1 S PRCAOK=1,DA=PRCABN D SIG^PRCASIG,NOW^%DTC
I $D(PRCANM) D ORAMT S PRCANM=$P($G(^VA(200,DUZ,20)),"^",2) D EN^PRCASIG(.PRCANM,DUZ,DA_+$P(^PRCA(430,PRCABN,0),U,3)) S $P(^PRCA(430,PRCABN,9),U,1,3)=+DUZ_U_PRCANM_U_%
Q
CKSITE ;check site parameter and user number.
D:'$D(PRCA("SITE")) CKSITE^PRCAUDT
I ('$D(PRCA("SITE"))) Q
S PRCA("CKSITE")=1 Q
DELETE ;delete new AR without category and debtor field.
S PRCACOMM="USER CANCELED" D DELETE^PRCABIL4 K PRCACOMM
W *7,!,"The entry has been deleted!",! Q
ORAMT ;Update original amount.
Q:'$D(^PRCA(430,PRCABN,2)) S PRCAMT=0,PRCAORA=0
F Z0=0:0 S PRCAORA=$O(^PRCA(430,PRCABN,2,PRCAORA)) Q:+PRCAORA'>0 S PRCAMT=PRCAMT+$P(^(PRCAORA,0),U,2)
N PRCFDA S $P(^PRCA(430,PRCABN,0),U,3)=PRCAMT,PRCFDA(430,PRCABN_",",71)=PRCAMT D FILE^DIE(,"PRCFDA") ; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
K Z0,PRCAORA,PRCAMT Q
RESULT Q:'$D(PRCABN)
I $P(^PRCA(430,PRCABN,0),U,5)>0,$D(^PRCA(430.6,+$P(^(0),U,5),0)) W !!,"BILL RESULTING FROM: ",$P(^(0),U,2) Q
Q
MTIFY ;CHECK TO SEE IF ONE FY IS ENTERED PER BILL
N DA,DIE,DR,PRCAI,PRCAMT,PRCAMT1
MTCHK S PRCAMT1=0 F PRCAI=0:0 S PRCAI=$O(^PRCA(430,PRCABN,2,PRCAI)) Q:'PRCAI S PRCAMT=+$P($G(^(PRCAI,0)),"^",8) I PRCAMT S PRCAMT1=PRCAMT1+1
I PRCAMT1=1 G MTIFYQ
W !!,?3,"** Currently, just one Fiscal Year amount is sent to FMS."
W !,?3,"** Please enter just one Fiscal Year for this bill. (",PRCAMT1,") entered",!!
S DIE="^PRCA(430,",DA=PRCABN,DR="1",DR(2,430.01)=".01;7" D ^DIE
G MTCHK
MTIFYQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAEIN 4998 printed Nov 22, 2024@16:49:37 Page 2
PRCAEIN ;SF-ISC/YJK-EDIT INCOMPLETE ACCOUNTS RECEIVABLE ;10/17/96 1:07 PM
V ;;4.5;Accounts Receivable;**57,67,153,371**;Mar 20, 1995;Build 29
+1 ;;Per VHA Directive 6402, this routine should not be modified.
+2 ;This edits incomplete accounts receivable. The account is classified
+3 ;with category.
+4 ;
+5 ;===================== EDIT INCOMPLETE AR ===========================
EDIN ;edit incomplete accounts receivable.
+1 KILL PRCA("CKSITE")
DO CKSITE
if '$DATA(PRCA("CKSITE"))
GOTO END
SET DIC("S")="S Z0=$S($D(^PRCA(430.3,+$P(^(0),U,8),0)):$P(^(0),U,3),1:0) I Z0=101"
+2 DO DIC^PRCAUDT
if '$DATA(PRCABN)
GOTO END
SET PRCADIOK=0
SET PRCA("MESS1")="THE ACCOUNT IS STILL INCOMPLETE"
SET PRCA("MESS2")="*** EDITED AND RELEASED TO ACCOUNTING TECHNICIAN ***"
+3 KILL PRCADINO
DO EDT
IF $GET(PRCABN)
IF $PIECE(^PRCA(430,PRCABN,0),U,8)=$ORDER(^PRCA(430.3,"AC",102,0))
DO PREPAY^RCBEPAYP(PRCABN)
+4 DO KILLV
GOTO EDIN
EDT DO DIE
IF $DATA(PRCADINO)
IF ($PIECE(^PRCA(430,PRCABN,0),U,2)="")!($PIECE(^(0),U,9)="")
SET PRCADEL=1
QUIT
+1 ;DIS
+2 IF $DATA(PRCADINO)
WRITE !!,*7,PRCA("MESS1"),!!
QUIT
DIP SET PRCAT=+$PIECE(^PRCA(430,PRCABN,0),U,2)
if $PIECE(^PRCA(430.2,PRCAT,0),U,3)>0
DO SEGMT^PRCAEOL
SET PRCAT=$SELECT($DATA(^PRCA(430.2,PRCAT,0)):$PIECE(^(0),U,6),1:"")
DO DISPL
DO DISPLACC^PRCAFUT
SET PRCAOK=0
DO ASK1
if $DATA(PRCA("EXIT"))
GOTO DIP1
+1 IF PRCAOK=1
if '$DATA(PRCANM)
GOTO DIP1
SET PRCA("STATUS")=$ORDER(^PRCA(430.3,"AC",102,""))
SET PRCA("SDT")=DT
Begin DoDot:1
+2 IF $$ACCK^PRCAACC(PRCABN)
DO ASTAT
QUIT
+3 DO EN^PRCAFBD(PRCABN,.ERR)
+4 IF +ERR>0
Begin DoDot:2
+5 WRITE !!,*7,"Error creating FMS Billing Document:",!,?10,$PIECE(ERR,U,2),!,"Bill status remains 'NEW BILL'",!!
+6 SET PRCA("STATUS")=$ORDER(^PRCA(430.3,"AC",104,""))
+7 QUIT
End DoDot:2
QUIT
+8 SET PRCA("STATUS")=$ORDER(^PRCA(430.3,"AC",102,""))
+9 QUIT
End DoDot:1
DO UPSEG^PRCAUDT
DO UPSTATS^PRCAUT2
QUIT
+10 DO ASK2
IF PRCAOK=1
DO DIE
GOTO DIP
DIP1 ;end of EDIN
WRITE !!,PRCA("MESS1"),!
DO KILLV
QUIT
ASTAT ;Set status for accrued bills
+1 SET PRCA("DEBTOR")=$PIECE(^PRCA(430,PRCABN,0),"^",9)
if PRCA("DEBTOR")=""
QUIT
+2 SET PRCA("STATUS")=$ORDER(^PRCA(430.3,"AC",102,""))
SET PRCA("MESS2")="** ACCRUED BILL, STATUS IS NOW ACTIVE **"
QUIT
KILLV LOCK -^PRCA(430,+$GET(PRCABN))
+1 KILL PRCADIOK,PRCADEL,DIC,DR,DIE,PRCAT,PRCAGLN,PRCA("CKSITE"),PRCADINO,PRCAOK,PRCA("MESS1"),PRCA("MESS2"),PRCA("EXIT"),PRCABN,PRCAT,PRCANM,PRCADEL,PRCATY,Z1,ZZ,J,D0,D1,PRC
QUIT
END DO KILLV
KILL PRCA
QUIT
+1 ;======================= SUBROUTINES ================================
DIE KILL PRCAT
WRITE !
SET DA=PRCABN
SET DIC="^PRCA(430,"
SET PRCA("LOCK")=0
DO LOCKF^PRCAWO1
if PRCA("LOCK")=1
QUIT
SET DIE=DIC
SET DR="[PRCA CAT SET]"
DO ^DIE
KILL DR,DIE,DA
+1 IF ($PIECE(^PRCA(430,PRCABN,0),U,2)="")!($DATA(Y))
if $PIECE(^(0),U,2)=""
WRITE !,*7," You should enter a category.",!
SET PRCADINO=""
QUIT
+2 SET PRCAT=$PIECE(^PRCA(430.2,+$PIECE(^PRCA(430,PRCABN,0),U,2),0),U,6)
SET PRCAGLN=$PIECE(^(0),U,4)
if $PIECE(^(0),U,7)=24
SET PRCAT("C")=1
D1 SET DIE="^PRCA(430,"
SET DA=PRCABN
SET DR="[PRCA SET]"
DO ^DIE
IF $DATA(Y)
SET PRCA("EXIT")=""
SET PRCADINO=""
QUIT
+1 DO MTIFY
IF $DATA(PRCA("EXIT"))
SET PRCADIN0=""
QUIT
+2 KILL DR
if '$$ACCK^PRCAACC(PRCABN)
DO CPLK^PRCAFUT(PRCABN)
IF $DATA(PRCA("EXIT"))
SET PRCADINO=""
QUIT
+3 DO COMMENTS^PRCAUT3
IF $DATA(PRCA("EXIT"))
SET PRCADINO=""
QUIT
+4 IF +$PIECE(^PRCA(430,PRCABN,0),U,5)'>0
WRITE !,*7,?3,"The 'Bill Resulting From' input does not exist.",!
SET PRCADINO=""
QUIT
+5 QUIT
DISPL ;display the accounts receivable data user has entered.
+1 if '$DATA(PRCABN)
QUIT
IF '$DATA(IOF)
SET IOP=""
DO ^%ZIS
+2 WRITE @IOF
SET D0=PRCABN
KILL ^UTILITY($JOB,"W"),DXS
DO ^PRCATO2
DO WOBIL^PRCAUDT1
KILL DXS
QUIT
ASK2 SET %=2
WRITE !!,"DO YOU WANT TO EDIT THE DATA"
DO YN^DICN
IF %=0
DO M2^PRCAMESG
GOTO ASK2
+1 if %'=1
QUIT
SET PRCAOK=1
QUIT
ASK1 SET %=2
WRITE !!,"IS THIS DATA CORRECT"
DO YN^DICN
IF %<0
SET PRCA("EXIT")=""
QUIT
+1 IF %=0
DO M1^PRCAMESG
GOTO ASK1
+2 if %'=1
QUIT
SET PRCAOK=1
SET DA=PRCABN
DO SIG^PRCASIG
DO NOW^%DTC
+3 IF $DATA(PRCANM)
DO ORAMT
SET PRCANM=$PIECE($GET(^VA(200,DUZ,20)),"^",2)
DO EN^PRCASIG(.PRCANM,DUZ,DA_+$PIECE(^PRCA(430,PRCABN,0),U,3))
SET $PIECE(^PRCA(430,PRCABN,9),U,1,3)=+DUZ_U_PRCANM_U_%
+4 QUIT
CKSITE ;check site parameter and user number.
+1 if '$DATA(PRCA("SITE"))
DO CKSITE^PRCAUDT
+2 IF ('$DATA(PRCA("SITE")))
QUIT
+3 SET PRCA("CKSITE")=1
QUIT
DELETE ;delete new AR without category and debtor field.
+1 SET PRCACOMM="USER CANCELED"
DO DELETE^PRCABIL4
KILL PRCACOMM
+2 WRITE *7,!,"The entry has been deleted!",!
QUIT
ORAMT ;Update original amount.
+1 if '$DATA(^PRCA(430,PRCABN,2))
QUIT
SET PRCAMT=0
SET PRCAORA=0
+2 FOR Z0=0:0
SET PRCAORA=$ORDER(^PRCA(430,PRCABN,2,PRCAORA))
if +PRCAORA'>0
QUIT
SET PRCAMT=PRCAMT+$PIECE(^(PRCAORA,0),U,2)
+3 ; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
NEW PRCFDA
SET $PIECE(^PRCA(430,PRCABN,0),U,3)=PRCAMT
SET PRCFDA(430,PRCABN_",",71)=PRCAMT
DO FILE^DIE(,"PRCFDA")
+4 KILL Z0,PRCAORA,PRCAMT
QUIT
RESULT if '$DATA(PRCABN)
QUIT
+1 IF $PIECE(^PRCA(430,PRCABN,0),U,5)>0
IF $DATA(^PRCA(430.6,+$PIECE(^(0),U,5),0))
WRITE !!,"BILL RESULTING FROM: ",$PIECE(^(0),U,2)
QUIT
+2 QUIT
MTIFY ;CHECK TO SEE IF ONE FY IS ENTERED PER BILL
+1 NEW DA,DIE,DR,PRCAI,PRCAMT,PRCAMT1
MTCHK SET PRCAMT1=0
FOR PRCAI=0:0
SET PRCAI=$ORDER(^PRCA(430,PRCABN,2,PRCAI))
if 'PRCAI
QUIT
SET PRCAMT=+$PIECE($GET(^(PRCAI,0)),"^",8)
IF PRCAMT
SET PRCAMT1=PRCAMT1+1
+1 IF PRCAMT1=1
GOTO MTIFYQ
+2 WRITE !!,?3,"** Currently, just one Fiscal Year amount is sent to FMS."
+3 WRITE !,?3,"** Please enter just one Fiscal Year for this bill. (",PRCAMT1,") entered",!!
+4 SET DIE="^PRCA(430,"
SET DA=PRCABN
SET DR="1"
SET DR(2,430.01)=".01;7"
DO ^DIE
+5 GOTO MTCHK
MTIFYQ QUIT
