| 1 | PRCAUT1 ;SF-ISC/YJK-AR 2ND UTILITY ROUTINE ;4/8/94 1:43 PM
|
|---|
| 2 | V ;;4.5;Accounts Receivable;;Mar 20, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;Subroutines for multiple appropriation and mult.care
|
|---|
| 5 | ;and calculation of interest and admin.charge.
|
|---|
| 6 | MULTPAY ;apply the payment to multiple appropriation.- oldest first
|
|---|
| 7 | Q:'$D(PRCAEN)!('$D(PRCAMT)) Q:PRCAMT'>0 S PRCAMT1=PRCAMT
|
|---|
| 8 | S PRCAKA1=$O(^PRCA(433,PRCAEN,4,"B","")) Q:PRCAKA1="" S PRCAKA2=$O(^PRCA(433,PRCAEN,4,"B",PRCAKA1,"")) D P1
|
|---|
| 9 | 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
|
|---|
| 10 | K PRCAKA1,PRCAKA2,I Q ;end of MULTPAY
|
|---|
| 11 | P1 S PRCAUMT=$P(^PRCA(433,PRCAEN,4,PRCAKA2,0),U,2)
|
|---|
| 12 | I PRCAUMT>PRCAMT1 S PRCAUMT=PRCAUMT-PRCAMT1,PRCAUMT1=PRCAMT1,PRCAMT1=0
|
|---|
| 13 | E S PRCAMT1=PRCAMT1-PRCAUMT,PRCAUMT1=PRCAUMT,PRCAUMT=0
|
|---|
| 14 | 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
|
|---|
| 15 | ;
|
|---|
| 16 | COMMON ;Edit common number series for AR - 8K#### or K8####
|
|---|
| 17 | 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
|
|---|
| 18 | DEVICE ;assign a printer in the AR section for only AR use.
|
|---|
| 19 | W !,"This option is no longer supported by the AR package.",!,"Please use the AR Site Parameter option edit." Q
|
|---|
| 20 | ARPARAM Q
|
|---|
| 21 | ADDPARM Q
|
|---|
| 22 | ;
|
|---|
| 23 | HOLD W !,"..........PLEASE HOLD ON.............." Q
|
|---|
