PRCAUT1.m

PRCAUT1 ;SF-ISC/YJK-AR 2ND UTILITY ROUTINE ;4/8/94  1:43 PM

V ;;4.5;Accounts Receivable;;Mar 20, 1995

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

 ;Subroutines for multiple appropriation and mult.care

 ;and calculation of interest and admin.charge.

MULTPAY ;apply the payment to multiple appropriation.- oldest first

 Q:'$D(PRCAEN)!('$D(PRCAMT))  Q:PRCAMT'>0  S PRCAMT1=PRCAMT

 S PRCAKA1=$O(^PRCA(433,PRCAEN,4,"B","")) Q:PRCAKA1=""  S PRCAKA2=$O(^PRCA(433,PRCAEN,4,"B",PRCAKA1,"")) D P1

 F I=0:0 S PRCAKA1=$O(^PRCA(433,PRCAEN,4,"B",PRCAKA1)) Q:(PRCAKA1="")!(PRCAMT1'>0)  S PRCAKA2=$O(^(PRCAKA1,"")) I $D(^PRCA(433,PRCAEN,4,PRCAKA2,0)) D P1

 K PRCAKA1,PRCAKA2,I Q  ;end of MULTPAY

P1 S PRCAUMT=$P(^PRCA(433,PRCAEN,4,PRCAKA2,0),U,2)

 I PRCAUMT>PRCAMT1 S PRCAUMT=PRCAUMT-PRCAMT1,PRCAUMT1=PRCAMT1,PRCAMT1=0

 E  S PRCAMT1=PRCAMT1-PRCAUMT,PRCAUMT1=PRCAUMT,PRCAUMT=0

 S $P(^PRCA(433,PRCAEN,4,PRCAKA2,0),U,2)=PRCAUMT,$P(^(0),U,4)=1,$P(^(0),U,5)=PRCAUMT1 K PRCAUMT,PRCAUMT1 Q

 ;

COMMON ;Edit common number series for AR - 8K#### or K8####

 W !,"This option is no longer supported by the AR package.",!,"Please use the IFCAP option 'Establish Common Numbering Series' under",!,"the IFCAP package coordinator menu." Q

DEVICE ;assign a printer in the AR section for only AR use.

 W !,"This option is no longer supported by the AR package.",!,"Please use the AR Site Parameter option edit." Q

ARPARAM Q

ADDPARM Q

 ;

HOLD W !,"..........PLEASE HOLD ON.............." Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCAUT1   1503     printed  Apr 09, 2024@20:47:29                                                                                                                                                                                                     Page 2

PRCAUT1   ;SF-ISC/YJK-AR 2ND UTILITY ROUTINE ;4/8/94  1:43 PM

V         ;;4.5;Accounts Receivable;;Mar 20, 1995

 +1       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +2       ;Subroutines for multiple appropriation and mult.care

 +3       ;and calculation of interest and admin.charge.

MULTPAY   ;apply the payment to multiple appropriation.- oldest first

 +1        if '$DATA(PRCAEN)!('$DATA(PRCAMT))

               QUIT 

           if PRCAMT'>0

               QUIT 

           SET PRCAMT1=PRCAMT

 +2        SET PRCAKA1=$ORDER(^PRCA(433,PRCAEN,4,"B",""))

           if PRCAKA1=""

               QUIT 

           SET PRCAKA2=$ORDER(^PRCA(433,PRCAEN,4,"B",PRCAKA1,""))

           DO P1

 +3        FOR I=0:0

               SET PRCAKA1=$ORDER(^PRCA(433,PRCAEN,4,"B",PRCAKA1))

               if (PRCAKA1="")!(PRCAMT1'>0)

                   QUIT 

               SET PRCAKA2=$ORDER(^(PRCAKA1,""))

               IF $DATA(^PRCA(433,PRCAEN,4,PRCAKA2,0))

                   DO P1

 +4       ;end of MULTPAY

           KILL PRCAKA1,PRCAKA2,I

           QUIT 

P1         SET PRCAUMT=$PIECE(^PRCA(433,PRCAEN,4,PRCAKA2,0),U,2)

 +1        IF PRCAUMT>PRCAMT1

               SET PRCAUMT=PRCAUMT-PRCAMT1

               SET PRCAUMT1=PRCAMT1

               SET PRCAMT1=0

 +2       IF '$TEST

               SET PRCAMT1=PRCAMT1-PRCAUMT

               SET PRCAUMT1=PRCAUMT

               SET PRCAUMT=0

 +3        SET $PIECE(^PRCA(433,PRCAEN,4,PRCAKA2,0),U,2)=PRCAUMT

           SET $PIECE(^(0),U,4)=1

           SET $PIECE(^(0),U,5)=PRCAUMT1

           KILL PRCAUMT,PRCAUMT1

           QUIT 

 +4       ;

COMMON    ;Edit common number series for AR - 8K#### or K8####

 +1        WRITE !,"This option is no longer supported by the AR package.",!,"Please use the IFCAP option 'Establish Common Numbering Series' under",!,"the IFCAP package coordinator menu."

           QUIT 

DEVICE    ;assign a printer in the AR section for only AR use.

 +1        WRITE !,"This option is no longer supported by the AR package.",!,"Please use the AR Site Parameter option edit."

           QUIT 

ARPARAM    QUIT 

ADDPARM    QUIT 

 +1       ;

HOLD       WRITE !,"..........PLEASE HOLD ON.............."

           QUIT