- 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 ---[H[J[2J[HPRCAUT1 1503 printed Feb 18, 2025@23:08:24 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
