| [613] | 1 | PRCHEC2 ;SF-ISC/TKW-SUPPLEMENTAL ROUTINES CALLED FROM PRCHEC ;7-31-90/10:33
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | LOGDPT S (Z(1),Z(2))="" I $D(^PRC(420,PRC("SITE"),1,+$P(^PRC(442,PRCHPO,0),U,3),0)) S Z(1)=$P(^(0),U,12),Z(2)=$P(^(0),U,18)
|
|---|
| 6 | I Z(1)'=2 S:Z(2)'="" $P(^PRC(442,PRCHPO,17),U,1)=$E(Z(2),1,3) I Z(2)="" W $C(7),!?3,"Fund Control point is missing LOG Department Number!!"
|
|---|
| 7 | K Z
|
|---|
| 8 | Q
|
|---|
| 9 | ;
|
|---|
| 10 | CALTOT ;ACCUMULATE TOTAL NO.OF LINE ITEMS RECEIVED, SAVE LARGEST TRADE DISCOUNT %, AND SAVE EST.SHIP/HANDLING TO BE USED IN CALCULATING DOLLAR AMOUNTS RECEIVED.
|
|---|
| 11 | S PRCHCNT=0 F I=0:0 S I=$O(^PRC(442,PRCHPO,2,"AB",PRCHRD,I)) Q:'I F J=0:0 S J=$O(^PRC(442,PRCHPO,2,"AB",PRCHRD,I,J)) Q:'J I $D(^PRC(442,PRCHPO,2,I,3,J,0)) S PRCHCNT=PRCHCNT+1
|
|---|
| 12 | S PRCHEST=$S(PRCHRPT=1:+$P(^PRC(442,PRCHPO,0),U,13),1:0) I PRCHEST,PRCHCNT S PRCHEST=PRCHEST/PRCHCNT
|
|---|
| 13 | D TM
|
|---|
| 14 | Q
|
|---|
| 15 | ;
|
|---|
| 16 | CAL2 S PRCHCNT=0 F I=0:0 S I=$O(^PRC(442,PRCHPO,2,I)) Q:'I I $D(^(I,2)),^(2) S PRCHCNT=PRCHCNT+1
|
|---|
| 17 | S PRCHEST=+$P(^PRC(442,PRCHPO,0),U,13) I PRCHEST,PRCHCNT S PRCHEST=PRCHEST/PRCHCNT
|
|---|
| 18 | D TM
|
|---|
| 19 | Q
|
|---|
| 20 | ;
|
|---|
| 21 | TM ;CALCULATE TERM DISCOUNT PERCENT
|
|---|
| 22 | S PRCHS("T")=0,Y=0 K I F I=0:0 S I=$O(^PRC(442,PRCHPO,5,I)) Q:'I S X=^(I,0) I +X>0 S I(100-X)=X
|
|---|
| 23 | S:$O(I(0)) PRCHS("T")=I($O(I(0))),Y=$P(PRCHS("T"),U,2),PRCHS("T")=+PRCHS("T")/100
|
|---|
| 24 | ;IF THIS IS A SUPPLY FUND ORDER AND ADJUSTED TERM DISCOUNT LESS THAN 3%, DO NOT USE IT IN THE CALCULATIONS.
|
|---|
| 25 | I PRCHS("T"),$P(^PRC(442,PRCHPO,0),U,19)=2,Y S:PRCHS("T")<.03 PRCHS("T")=0
|
|---|
| 26 | K I,X,Y
|
|---|
| 27 | Q
|
|---|
