PRCAFN1.m

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 ---PRCAFN1   1083     printed  Apr 09, 2024@20:54:25                                                                                                                                                                                                     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