PRCASET.m

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 ---PRCASET   2092     printed  Apr 09, 2024@20:50                                                                                                                                                                                                        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