PRCASET ;SF-ISC/YJK-SETUP A NEW ACCOUNTS RECEIVABLE ;4/1/96 2:24 PM
;;4.5;Accounts Receivable;**16,25,40,51,67,158,153,300**;Mar 20, 1995;Build 11
;;Per VHA Directive 10-93-142, this routine should not be modified.
;This sets up a new account for A/R. The account is classified
;with category.
;
;======================= SET UP NEW AR ==============================
SETBIL K PRCABT D CKSITE^PRCAUDT Q:('$D(PRCA("CKSITE"))) D LOOK G:X="" END D ENT G SETBIL
;
LOOK S:'$D(^PRCA(430,0)) ^(0)="ACCOUNTS RECEIVABLE^430I^^"
R !!,"ACCOUNTS RECEIVABLE BILL NO. : ",X:DTIME Q:('$T)!(X="") I X["^" S X="" Q
I "Nn"[$E(X) D I $P(X,"^")=-1 W *7,!!,$P(X,"^",2),! G LOOK
. S X=$$BNUM^RCMSNUM
. I $P(X,"^")'=-1 S X=$P(X,"-",2)
;WCJ;PRCA*300;making help match the actual check
;I (X'?1UN1UN4.5UN) W *7,!!,"Please enter 7 character bill number.",!,"It must be in the following format: K400001, K481234 or '(N)ew' to get",!,"the next available number. (Enter ""^"" to exit)",! G LOOK
I (X'?1UN1UN4.5UN) W *7,!!,"Please enter a 6-7 character (only uppercase or numeric) bill number.",!,"It must be in the following format: K400001, K481234 or '(N)ew' to get",!,"the next available number. (Enter ""^"" to exit)",! G LOOK
;WCJ;PRCA*300
I ($D(^PRCA(430,"D",X)))!($D(^PRCA(430,"B",PRCA("SITE")_"-"_X))) W *7,!!,"SORRY ! THIS NUMBER HAS BEEN ALREADY ASSIGNED TO A BILL. IT MUST BE NEW ENTRY",! G LOOK
Q
ENT S X=PRCA("SITE")_"-"_X W " ",X S DIC="^PRCA(430,",DIC(0)="XL",DLAYGO=430,DIC("DR")="97////^S X=DUZ" D ^DIC K DLAYGO,DIC
Q:Y<0 S (X,D0,PRCABN)=+Y,PRCA("MESS1")="THE ACCOUNT WILL BE INCOMPLETE.",PRCA("MESS2")="*** APPROVED AND RELEASED TO ACCOUNTING ***"
W " ...Bill Number '",$P(^PRCA(430,PRCABN,0),"^"),"' assigned!"
K PRCADEL,PRCADINO D EDT^PRCAEIN
DELETE I $D(PRCADEL) S PRCACOMM="USER CANCELED" D DELETE^PRCABIL4 K PRCACOMM W !,*7,"DELETED",!
END I $G(PRCABN),$P($G(^PRCA(430,PRCABN,0)),U,8)=$O(^PRCA(430.3,"AC",102,"")) D PREPAY^RCBEPAYP(PRCABN)
L -^PRCA(430,+$G(PRCABN)) K PRCADINO,PRCA("MESS1"),PRCA("MESS2"),PRCABN,PRCADEL,PRCA("CKSITE"),DIC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCASET 2092 printed Dec 13, 2024@01:41:20 Page 2
PRCASET ;SF-ISC/YJK-SETUP A NEW ACCOUNTS RECEIVABLE ;4/1/96 2:24 PM
+1 ;;4.5;Accounts Receivable;**16,25,40,51,67,158,153,300**;Mar 20, 1995;Build 11
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;This sets up a new account for A/R. The account is classified
+4 ;with category.
+5 ;
+6 ;======================= SET UP NEW AR ==============================
SETBIL KILL PRCABT
DO CKSITE^PRCAUDT
if ('$DATA(PRCA("CKSITE")))
QUIT
DO LOOK
if X=""
GOTO END
DO ENT
GOTO SETBIL
+1 ;
LOOK if '$DATA(^PRCA(430,0))
SET ^(0)="ACCOUNTS RECEIVABLE^430I^^"
+1 READ !!,"ACCOUNTS RECEIVABLE BILL NO. : ",X:DTIME
if ('$TEST)!(X="")
QUIT
IF X["^"
SET X=""
QUIT
+2 IF "Nn"[$EXTRACT(X)
Begin DoDot:1
+3 SET X=$$BNUM^RCMSNUM
+4 IF $PIECE(X,"^")'=-1
SET X=$PIECE(X,"-",2)
End DoDot:1
IF $PIECE(X,"^")=-1
WRITE *7,!!,$PIECE(X,"^",2),!
GOTO LOOK
+5 ;WCJ;PRCA*300;making help match the actual check
+6 ;I (X'?1UN1UN4.5UN) W *7,!!,"Please enter 7 character bill number.",!,"It must be in the following format: K400001, K481234 or '(N)ew' to get",!,"the next available number. (Enter ""^"" to exit)",! G LOOK
+7 IF (X'?1UN1UN4.5UN)
WRITE *7,!!,"Please enter a 6-7 character (only uppercase or numeric) bill number.",!,"It must be in the following format: K400001, K481234 or '(N)ew' to get",!,"the next available number. (Enter ""^"" to exit)",!
GOTO LOOK
+8 ;WCJ;PRCA*300
+9 IF ($DATA(^PRCA(430,"D",X)))!($DATA(^PRCA(430,"B",PRCA("SITE")_"-"_X)))
WRITE *7,!!,"SORRY ! THIS NUMBER HAS BEEN ALREADY ASSIGNED TO A BILL. IT MUST BE NEW ENTRY",!
GOTO LOOK
+10 QUIT
ENT SET X=PRCA("SITE")_"-"_X
WRITE " ",X
SET DIC="^PRCA(430,"
SET DIC(0)="XL"
SET DLAYGO=430
SET DIC("DR")="97////^S X=DUZ"
DO ^DIC
KILL DLAYGO,DIC
+1 if Y<0
QUIT
SET (X,D0,PRCABN)=+Y
SET PRCA("MESS1")="THE ACCOUNT WILL BE INCOMPLETE."
SET PRCA("MESS2")="*** APPROVED AND RELEASED TO ACCOUNTING ***"
+2 WRITE " ...Bill Number '",$PIECE(^PRCA(430,PRCABN,0),"^"),"' assigned!"
+3 KILL PRCADEL,PRCADINO
DO EDT^PRCAEIN
DELETE IF $DATA(PRCADEL)
SET PRCACOMM="USER CANCELED"
DO DELETE^PRCABIL4
KILL PRCACOMM
WRITE !,*7,"DELETED",!
END IF $GET(PRCABN)
IF $PIECE($GET(^PRCA(430,PRCABN,0)),U,8)=$ORDER(^PRCA(430.3,"AC",102,""))
DO PREPAY^RCBEPAYP(PRCABN)
+1 LOCK -^PRCA(430,+$GET(PRCABN))
KILL PRCADINO,PRCA("MESS1"),PRCA("MESS2"),PRCABN,PRCADEL,PRCA("CKSITE"),DIC
+2 QUIT
