PRCAFN1 ;WASH-ISC@ALTOONA,PA/LDB-Functions to return AR data ;8/12/93 10:36 AM
V ;;4.5;Accounts Receivable;**48**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;;
EN(TRAN) ;Input is transaction number
;Variable returned = internal number of debtor^internal bill number
N X,Y
S Y=$P($G(^PRCA(433,+TRAN,0)),"^",2) G NULL:'Y
S X=$P($G(^PRCA(430,+Y,0)),"^",9) G NULL:'X
S $P(X,"^",2)=Y
Q X
;
NULL ;Either no bill or debtor
S X=""
Q X
;
;
CAT(Y) ;Input: Internal Bill #
;Return: Category #^Category name^Category Type or -1
;
I Y>0 S Y=$S('$D(Y)#2:-1,Y="":-1,1:$G(^PRCA(430.2,+$P($G(^PRCA(430,Y,0)),"^",2),0))) S:Y="" Y=-1 S:Y'=-1 Y=$P(Y,"^",7)_"^"_$P(Y,"^")_"^"_$P(Y,"^",6)
Q Y
;
PAID(Y) ;Input: Internal Bill #
;Return: Amount of payments on receivable
N AMT,X
S AMT=0
I 'Y!(Y<0)!('$D(^PRCA(430,Y,0))) S Y="ERROR" G PAIDQ
S X="" F S X=$O(^PRCA(433,"C",+Y,X)) Q:'X D
.S X(1)=$G(^PRCA(433,+X,1))
.S X(2)=$P(X(1),"^",2)
.I "^2^34^"[("^"_X(2)_"^") S AMT=AMT+$P(X(1),"^",5)
S Y=AMT
PAIDQ Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAFN1 1083 printed Dec 13, 2024@01:39:32 Page 2
PRCAFN1 ;WASH-ISC@ALTOONA,PA/LDB-Functions to return AR data ;8/12/93 10:36 AM
V ;;4.5;Accounts Receivable;**48**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;;
EN(TRAN) ;Input is transaction number
+1 ;Variable returned = internal number of debtor^internal bill number
+2 NEW X,Y
+3 SET Y=$PIECE($GET(^PRCA(433,+TRAN,0)),"^",2)
if 'Y
GOTO NULL
+4 SET X=$PIECE($GET(^PRCA(430,+Y,0)),"^",9)
if 'X
GOTO NULL
+5 SET $PIECE(X,"^",2)=Y
+6 QUIT X
+7 ;
NULL ;Either no bill or debtor
+1 SET X=""
+2 QUIT X
+3 ;
+4 ;
CAT(Y) ;Input: Internal Bill #
+1 ;Return: Category #^Category name^Category Type or -1
+2 ;
+3 IF Y>0
SET Y=$SELECT('$DATA(Y)#2:-1,Y="":-1,1:$GET(^PRCA(430.2,+$PIECE($GET(^PRCA(430,Y,0)),"^",2),0)))
if Y=""
SET Y=-1
if Y'=-1
SET Y=$PIECE(Y,"^",7)_"^"_$PIECE(Y,"^")_"^"_$PIECE(Y,"^",6)
+4 QUIT Y
+5 ;
PAID(Y) ;Input: Internal Bill #
+1 ;Return: Amount of payments on receivable
+2 NEW AMT,X
+3 SET AMT=0
+4 IF 'Y!(Y<0)!('$DATA(^PRCA(430,Y,0)))
SET Y="ERROR"
GOTO PAIDQ
+5 SET X=""
FOR
SET X=$ORDER(^PRCA(433,"C",+Y,X))
if 'X
QUIT
Begin DoDot:1
+6 SET X(1)=$GET(^PRCA(433,+X,1))
+7 SET X(2)=$PIECE(X(1),"^",2)
+8 IF "^2^34^"[("^"_X(2)_"^")
SET AMT=AMT+$PIECE(X(1),"^",5)
End DoDot:1
+9 SET Y=AMT
PAIDQ QUIT Y
