RCBEUTRA ;WISC/RFJ-utilties for transactions (in file 433) ;1 Jun 00
;;4.5;Accounts Receivable;**153,169,204,326,332**;Mar 20, 1995;Build 40
;;Per VA Directive 6402, this routine should not be modified.
Q
;
;
ADD433(BILLDA,TRANTYPE) ; add a new transaction to file 433 (silent)
; return: ien of 433 transaction or 0^error msg
; : ^prca(433,ien) will be locked if entry selected
; Input - optional variable RCDUZ for the processed by user. SET in ^RCDPEAP from MARKED FOR AUTOPOST USER. PRCA*4.5*326
N %I,DA,DATA0,DD,DIC,DICR,DIE,DINUM,DIW,DLAYGO,DO,I,RCTRANDA,REFCODE,X,Y
;
; find next available transaction number
; add an extra level of locks, some operating systems do not process
; the locks correctly if they happen at the same time.
L +^PRCA(433,"ADDNEWENTRY"):DILOCKTM
I '$T Q "0^Another user is adding an AR Transaction, please try again later."
; start with last entry in file
; -> if no data is in the entry, lock it
; -> if the lock works and no data was added (prior to the lock)
; -> then you have the entry.
; -> otherwise, unlock it and start over
F DINUM=$P(^PRCA(433,0),"^",3)+1:1 I '$D(^PRCA(433,DINUM)) L +^PRCA(433,DINUM):DILOCKTM Q:$T&('$D(^PRCA(433,DINUM))) L -^PRCA(433,DINUM)
L -^PRCA(433,"ADDNEWENTRY")
;
; add entry to file
S RCTRANDA=DINUM,(DIC,DIE)="^PRCA(433,",DIC(0)="L",DLAYGO=433,X=DINUM
; build DR string, 42=processed by (use postmaster if queued)
S DIC("DR")="42////"_$S($G(RCDUZ):RCDUZ,$D(ZTQUEUED):.5,1:DUZ)_";" ; PRCA*4.5*326 Use RCDUZ if defined
S DIC("DR")=DIC("DR")_".03////"_BILLDA_";" ;bill ien
S DIC("DR")=DIC("DR")_"12////"_TRANTYPE_";" ;transaction type
S DATA0=$G(^PRCA(430,BILLDA,0))
; appropriation symbol
I $P(DATA0,"^",18)'="" S DIC("DR")=DIC("DR")_"8////"_$P(DATA0,"^",18)_";"
; segment
I $P(DATA0,"^",21)'="" S DIC("DR")=DIC("DR")_"6////"_$P(DATA0,"^",21)_";"
; test for referral code
S REFCODE=$P($G(^PRCA(430,BILLDA,6)),"^",5)
I REFCODE'="" S REFCODE=$S(REFCODE="DC":"RC",1:REFCODE),DIC("DR")=DIC("DR")_"7////"_REFCODE_";"
; file it
D FILE^DICN
I Y=-1 L -^PRCA(433,RCTRANDA) Q "0^UNABLE TO ADD A NEW ENTRY TO FILE 433"
Q RCTRANDA
;
;
FY433(RCTRANDA) ; transfer fiscal year multiple from 430 to 433
; bill number must be stored in file 433, field .03 before calling
N BILLDA,FY,FYDATA
S BILLDA=+$P($G(^PRCA(433,RCTRANDA,0)),"^",2) I 'BILLDA Q
K ^PRCA(433,RCTRANDA,4)
S FY=0 F S FY=$O(^PRCA(430,BILLDA,2,FY)) Q:'FY D
. S FYDATA=$G(^PRCA(430,BILLDA,2,FY,0)) I $P(FYDATA,"^")="" Q
. S ^PRCA(433,RCTRANDA,4,FY,0)=$P(FYDATA,"^",1,3)_"^1"
. S ^PRCA(433,RCTRANDA,4,"B",$P(FYDATA,"^"),FY)=""
;
S ^PRCA(433,RCTRANDA,4,0)="^433.01I^"_$P($G(^PRCA(430,BILLDA,2,0)),"^",3,4)
Q
;
;
FYMULT(RCTRANDA) ; apply payment to fy multiple, oldest first
N AMOUNT,FYDA,FYAMOUNT
; transfer fy multiple if not there
I '$D(^PRCA(433,RCTRANDA,4)) D FY433(RCTRANDA)
; amount is principal amount
S AMOUNT=$P($$TRANVALU^RCDPBTLM(RCTRANDA),"^",2) I 'AMOUNT Q
;
; the transaction value is minus, decrease principal
I AMOUNT<0 D Q
. S AMOUNT=-AMOUNT
. S FYDA=0 F S FYDA=$O(^PRCA(433,RCTRANDA,4,FYDA)) Q:'FYDA D I 'AMOUNT Q
. . S FYAMOUNT=$P($G(^PRCA(433,RCTRANDA,4,FYDA,0)),"^",2)
. . ; fy amount is greater than transaction amount
. . I FYAMOUNT>AMOUNT D Q
. . . S $P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)=FYAMOUNT-AMOUNT
. . . S $P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",5)=AMOUNT
. . . S AMOUNT=0
. . ; fy amount not greater than total amount
. . S $P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)=0
. . S $P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",5)=FYAMOUNT
. . S AMOUNT=AMOUNT-FYAMOUNT
. ; move back to 430
. D FYMULT^RCBEUBIL(RCTRANDA)
;
; the transaction value is plus, increase principal
S FYDA=$O(^PRCA(433,RCTRANDA,4,999),-1) I 'FYDA Q
S $P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)=$P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)+AMOUNT
S $P(^PRCA(433,RCTRANDA,4,FYDA,0),"^",5)=AMOUNT
; move back to 430
D FYMULT^RCBEUBIL(RCTRANDA)
Q
;
;
EDIT433(RCTRANDA,DR) ; edit the field in 433 with the DR string passed
I '$D(^PRCA(433,RCTRANDA)) Q
N %,D,D0,D1,DA,DDH,DI,DIC,DIE,DQ,J,X,Y
S (DIC,DIE)="^PRCA(433,",DA=RCTRANDA
D ^DIE
; user pressed up-arrow
I $D(Y) Q "0^TRANSACTION NOT COMPLETELY PROCESSED"
Q 1
;
;
PROCESS(RCTRANDA) ; mark transaction as processed
I '$D(^PRCA(433,RCTRANDA,0)) Q
N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
S (DIC,DIE)="^PRCA(433,",DA=RCTRANDA
S DR="3////0;4////2;"
D ^DIE
Q
;
;
INCOMPLE(RCTRANDA) ; opposite of processed, make a transaction incomplete
I '$D(^PRCA(433,RCTRANDA,0)) Q
N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
S (DIC,DIE)="^PRCA(433,",DA=RCTRANDA
S DR="4////1;"
D ^DIE
Q
;
;
DEL433(RCTRANDA,COMMENT,ARCHIVE) ; delete (mark incomplete) in file 433
; comment is the user comment in field 41 (default USER CANCELLED)
; archive is set to 1 if called to archive transaction
I '$D(^PRCA(433,RCTRANDA,0)) Q
N %,D,D0,DA,DI,DIC,DIE,DQ,DR,J,RCBILLDA,X,Y
;
S (DIC,DIE)="^PRCA(433,",DA=RCTRANDA
; build DR string
S DR=""
S DR=DR_"4////1;" ;transaction status incomplete
S DR=DR_"10////1;" ;incomplete transaction flag
S DR=DR_"11///T;" ;transaction date
I $G(COMMENT)="" S COMMENT="USER CANCELLED"
S DR=DR_"41///"_COMMENT_";"
; brief comment
S RCBILLDA=$P($G(^PRCA(433,RCTRANDA,0)),"^",2)
S DR=DR_"5.02////SYSTEM "_$S($G(ARCHIVE):"ARCHIVED",1:"INACTIVATED")_$S(RCBILLDA:" (BILL "_$P($G(^PRCA(430,RCBILLDA,0)),"^")_")",1:"")_";"
D ^DIE
; since the bill number (field .03) is required, it must be manually removed
I RCBILLDA S $P(^PRCA(433,RCTRANDA,0),"^",2)="" K ^PRCA(433,"C",RCBILLDA,RCTRANDA)
; remove fy multiple
K ^PRCA(433,RCTRANDA,4)
Q
;
;
ADDCOMM(RCTRANDA,COMMENT) ; automatically put a comment on a transaction
; comment in the array comment(1)=first line
; comment(2)=second line
N CURRLINE,LINE
; get the last line
S CURRLINE=$O(^PRCA(433,RCTRANDA,7,99999999),-1)
; if comment already on transaction, add a blank line and
; date time of new comment
I CURRLINE D
. S CURRLINE=CURRLINE+1,^PRCA(433,RCTRANDA,7,CURRLINE,0)=" "
. S CURRLINE=CURRLINE+1,^PRCA(433,RCTRANDA,7,CURRLINE,0)="Comment added on: "_$$FMTE^XLFDT($$NOW^XLFDT)
; add new lines
F LINE=1:1 Q:'$D(COMMENT(LINE)) S ^PRCA(433,RCTRANDA,7,CURRLINE+LINE,0)=COMMENT(LINE)
; set the 0th node
S ^PRCA(433,RCTRANDA,7,0)="^^"_(CURRLINE+LINE-1)_"^"_(CURRLINE+LINE-1)_"^"_DT_"^"
Q
FMSDATE(X) ;Finds the next month & year and sets the date for transmission
;of the document to FMS. If DT is after EOAM and the document has not
;been previously transmitted, the date will be set to the first of the
;next month. If the DT is after the EOAM and the document is being
;re-transmitted, the the date of transmission will be DT. The flag REGEN
;is set in the source code if the document is being
;re-transmitted, thus will have a transmission date of DT.
I $G(REFMS) G QUIT
I DT>$$LDATE^RCRJR(DT) S X=$E($$FPS^RCAMFN01(X,1),1,5)_"01"
QUIT Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCBEUTRA 7210 printed Nov 22, 2024@16:53:09 Page 2
RCBEUTRA ;WISC/RFJ-utilties for transactions (in file 433) ;1 Jun 00
+1 ;;4.5;Accounts Receivable;**153,169,204,326,332**;Mar 20, 1995;Build 40
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
ADD433(BILLDA,TRANTYPE) ; add a new transaction to file 433 (silent)
+1 ; return: ien of 433 transaction or 0^error msg
+2 ; : ^prca(433,ien) will be locked if entry selected
+3 ; Input - optional variable RCDUZ for the processed by user. SET in ^RCDPEAP from MARKED FOR AUTOPOST USER. PRCA*4.5*326
+4 NEW %I,DA,DATA0,DD,DIC,DICR,DIE,DINUM,DIW,DLAYGO,DO,I,RCTRANDA,REFCODE,X,Y
+5 ;
+6 ; find next available transaction number
+7 ; add an extra level of locks, some operating systems do not process
+8 ; the locks correctly if they happen at the same time.
+9 LOCK +^PRCA(433,"ADDNEWENTRY"):DILOCKTM
+10 IF '$TEST
QUIT "0^Another user is adding an AR Transaction, please try again later."
+11 ; start with last entry in file
+12 ; -> if no data is in the entry, lock it
+13 ; -> if the lock works and no data was added (prior to the lock)
+14 ; -> then you have the entry.
+15 ; -> otherwise, unlock it and start over
+16 FOR DINUM=$PIECE(^PRCA(433,0),"^",3)+1:1
IF '$DATA(^PRCA(433,DINUM))
LOCK +^PRCA(433,DINUM):DILOCKTM
if $TEST&('$DATA(^PRCA(433,DINUM)))
QUIT
LOCK -^PRCA(433,DINUM)
+17 LOCK -^PRCA(433,"ADDNEWENTRY")
+18 ;
+19 ; add entry to file
+20 SET RCTRANDA=DINUM
SET (DIC,DIE)="^PRCA(433,"
SET DIC(0)="L"
SET DLAYGO=433
SET X=DINUM
+21 ; build DR string, 42=processed by (use postmaster if queued)
+22 ; PRCA*4.5*326 Use RCDUZ if defined
SET DIC("DR")="42////"_$SELECT($GET(RCDUZ):RCDUZ,$DATA(ZTQUEUED):.5,1:DUZ)_";"
+23 ;bill ien
SET DIC("DR")=DIC("DR")_".03////"_BILLDA_";"
+24 ;transaction type
SET DIC("DR")=DIC("DR")_"12////"_TRANTYPE_";"
+25 SET DATA0=$GET(^PRCA(430,BILLDA,0))
+26 ; appropriation symbol
+27 IF $PIECE(DATA0,"^",18)'=""
SET DIC("DR")=DIC("DR")_"8////"_$PIECE(DATA0,"^",18)_";"
+28 ; segment
+29 IF $PIECE(DATA0,"^",21)'=""
SET DIC("DR")=DIC("DR")_"6////"_$PIECE(DATA0,"^",21)_";"
+30 ; test for referral code
+31 SET REFCODE=$PIECE($GET(^PRCA(430,BILLDA,6)),"^",5)
+32 IF REFCODE'=""
SET REFCODE=$SELECT(REFCODE="DC":"RC",1:REFCODE)
SET DIC("DR")=DIC("DR")_"7////"_REFCODE_";"
+33 ; file it
+34 DO FILE^DICN
+35 IF Y=-1
LOCK -^PRCA(433,RCTRANDA)
QUIT "0^UNABLE TO ADD A NEW ENTRY TO FILE 433"
+36 QUIT RCTRANDA
+37 ;
+38 ;
FY433(RCTRANDA) ; transfer fiscal year multiple from 430 to 433
+1 ; bill number must be stored in file 433, field .03 before calling
+2 NEW BILLDA,FY,FYDATA
+3 SET BILLDA=+$PIECE($GET(^PRCA(433,RCTRANDA,0)),"^",2)
IF 'BILLDA
QUIT
+4 KILL ^PRCA(433,RCTRANDA,4)
+5 SET FY=0
FOR
SET FY=$ORDER(^PRCA(430,BILLDA,2,FY))
if 'FY
QUIT
Begin DoDot:1
+6 SET FYDATA=$GET(^PRCA(430,BILLDA,2,FY,0))
IF $PIECE(FYDATA,"^")=""
QUIT
+7 SET ^PRCA(433,RCTRANDA,4,FY,0)=$PIECE(FYDATA,"^",1,3)_"^1"
+8 SET ^PRCA(433,RCTRANDA,4,"B",$PIECE(FYDATA,"^"),FY)=""
End DoDot:1
+9 ;
+10 SET ^PRCA(433,RCTRANDA,4,0)="^433.01I^"_$PIECE($GET(^PRCA(430,BILLDA,2,0)),"^",3,4)
+11 QUIT
+12 ;
+13 ;
FYMULT(RCTRANDA) ; apply payment to fy multiple, oldest first
+1 NEW AMOUNT,FYDA,FYAMOUNT
+2 ; transfer fy multiple if not there
+3 IF '$DATA(^PRCA(433,RCTRANDA,4))
DO FY433(RCTRANDA)
+4 ; amount is principal amount
+5 SET AMOUNT=$PIECE($$TRANVALU^RCDPBTLM(RCTRANDA),"^",2)
IF 'AMOUNT
QUIT
+6 ;
+7 ; the transaction value is minus, decrease principal
+8 IF AMOUNT<0
Begin DoDot:1
+9 SET AMOUNT=-AMOUNT
+10 SET FYDA=0
FOR
SET FYDA=$ORDER(^PRCA(433,RCTRANDA,4,FYDA))
if 'FYDA
QUIT
Begin DoDot:2
+11 SET FYAMOUNT=$PIECE($GET(^PRCA(433,RCTRANDA,4,FYDA,0)),"^",2)
+12 ; fy amount is greater than transaction amount
+13 IF FYAMOUNT>AMOUNT
Begin DoDot:3
+14 SET $PIECE(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)=FYAMOUNT-AMOUNT
+15 SET $PIECE(^PRCA(433,RCTRANDA,4,FYDA,0),"^",5)=AMOUNT
+16 SET AMOUNT=0
End DoDot:3
QUIT
+17 ; fy amount not greater than total amount
+18 SET $PIECE(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)=0
+19 SET $PIECE(^PRCA(433,RCTRANDA,4,FYDA,0),"^",5)=FYAMOUNT
+20 SET AMOUNT=AMOUNT-FYAMOUNT
End DoDot:2
IF 'AMOUNT
QUIT
+21 ; move back to 430
+22 DO FYMULT^RCBEUBIL(RCTRANDA)
End DoDot:1
QUIT
+23 ;
+24 ; the transaction value is plus, increase principal
+25 SET FYDA=$ORDER(^PRCA(433,RCTRANDA,4,999),-1)
IF 'FYDA
QUIT
+26 SET $PIECE(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)=$PIECE(^PRCA(433,RCTRANDA,4,FYDA,0),"^",2)+AMOUNT
+27 SET $PIECE(^PRCA(433,RCTRANDA,4,FYDA,0),"^",5)=AMOUNT
+28 ; move back to 430
+29 DO FYMULT^RCBEUBIL(RCTRANDA)
+30 QUIT
+31 ;
+32 ;
EDIT433(RCTRANDA,DR) ; edit the field in 433 with the DR string passed
+1 IF '$DATA(^PRCA(433,RCTRANDA))
QUIT
+2 NEW %,D,D0,D1,DA,DDH,DI,DIC,DIE,DQ,J,X,Y
+3 SET (DIC,DIE)="^PRCA(433,"
SET DA=RCTRANDA
+4 DO ^DIE
+5 ; user pressed up-arrow
+6 IF $DATA(Y)
QUIT "0^TRANSACTION NOT COMPLETELY PROCESSED"
+7 QUIT 1
+8 ;
+9 ;
PROCESS(RCTRANDA) ; mark transaction as processed
+1 IF '$DATA(^PRCA(433,RCTRANDA,0))
QUIT
+2 NEW D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
+3 SET (DIC,DIE)="^PRCA(433,"
SET DA=RCTRANDA
+4 SET DR="3////0;4////2;"
+5 DO ^DIE
+6 QUIT
+7 ;
+8 ;
INCOMPLE(RCTRANDA) ; opposite of processed, make a transaction incomplete
+1 IF '$DATA(^PRCA(433,RCTRANDA,0))
QUIT
+2 NEW D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
+3 SET (DIC,DIE)="^PRCA(433,"
SET DA=RCTRANDA
+4 SET DR="4////1;"
+5 DO ^DIE
+6 QUIT
+7 ;
+8 ;
DEL433(RCTRANDA,COMMENT,ARCHIVE) ; delete (mark incomplete) in file 433
+1 ; comment is the user comment in field 41 (default USER CANCELLED)
+2 ; archive is set to 1 if called to archive transaction
+3 IF '$DATA(^PRCA(433,RCTRANDA,0))
QUIT
+4 NEW %,D,D0,DA,DI,DIC,DIE,DQ,DR,J,RCBILLDA,X,Y
+5 ;
+6 SET (DIC,DIE)="^PRCA(433,"
SET DA=RCTRANDA
+7 ; build DR string
+8 SET DR=""
+9 ;transaction status incomplete
SET DR=DR_"4////1;"
+10 ;incomplete transaction flag
SET DR=DR_"10////1;"
+11 ;transaction date
SET DR=DR_"11///T;"
+12 IF $GET(COMMENT)=""
SET COMMENT="USER CANCELLED"
+13 SET DR=DR_"41///"_COMMENT_";"
+14 ; brief comment
+15 SET RCBILLDA=$PIECE($GET(^PRCA(433,RCTRANDA,0)),"^",2)
+16 SET DR=DR_"5.02////SYSTEM "_$SELECT($GET(ARCHIVE):"ARCHIVED",1:"INACTIVATED")_$SELECT(RCBILLDA:" (BILL "_$PIECE($GET(^PRCA(430,RCBILLDA,0)),"^")_")",1:"")_";"
+17 DO ^DIE
+18 ; since the bill number (field .03) is required, it must be manually removed
+19 IF RCBILLDA
SET $PIECE(^PRCA(433,RCTRANDA,0),"^",2)=""
KILL ^PRCA(433,"C",RCBILLDA,RCTRANDA)
+20 ; remove fy multiple
+21 KILL ^PRCA(433,RCTRANDA,4)
+22 QUIT
+23 ;
+24 ;
ADDCOMM(RCTRANDA,COMMENT) ; automatically put a comment on a transaction
+1 ; comment in the array comment(1)=first line
+2 ; comment(2)=second line
+3 NEW CURRLINE,LINE
+4 ; get the last line
+5 SET CURRLINE=$ORDER(^PRCA(433,RCTRANDA,7,99999999),-1)
+6 ; if comment already on transaction, add a blank line and
+7 ; date time of new comment
+8 IF CURRLINE
Begin DoDot:1
+9 SET CURRLINE=CURRLINE+1
SET ^PRCA(433,RCTRANDA,7,CURRLINE,0)=" "
+10 SET CURRLINE=CURRLINE+1
SET ^PRCA(433,RCTRANDA,7,CURRLINE,0)="Comment added on: "_$$FMTE^XLFDT($$NOW^XLFDT)
End DoDot:1
+11 ; add new lines
+12 FOR LINE=1:1
if '$DATA(COMMENT(LINE))
QUIT
SET ^PRCA(433,RCTRANDA,7,CURRLINE+LINE,0)=COMMENT(LINE)
+13 ; set the 0th node
+14 SET ^PRCA(433,RCTRANDA,7,0)="^^"_(CURRLINE+LINE-1)_"^"_(CURRLINE+LINE-1)_"^"_DT_"^"
+15 QUIT
FMSDATE(X) ;Finds the next month & year and sets the date for transmission
+1 ;of the document to FMS. If DT is after EOAM and the document has not
+2 ;been previously transmitted, the date will be set to the first of the
+3 ;next month. If the DT is after the EOAM and the document is being
+4 ;re-transmitted, the the date of transmission will be DT. The flag REGEN
+5 ;is set in the source code if the document is being
+6 ;re-transmitted, thus will have a transmission date of DT.
+7 IF $GET(REFMS)
GOTO QUIT
+8 IF DT>$$LDATE^RCRJR(DT)
SET X=$EXTRACT($$FPS^RCAMFN01(X,1),1,5)_"01"
QUIT QUIT X
