- PRCHEC2 ;SF-ISC/TKW-SUPPLEMENTAL ROUTINES CALLED FROM PRCHEC ;7-31-90/10:33
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- 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)
- 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!!"
- K Z
- Q
- ;
- 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.
- 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
- S PRCHEST=$S(PRCHRPT=1:+$P(^PRC(442,PRCHPO,0),U,13),1:0) I PRCHEST,PRCHCNT S PRCHEST=PRCHEST/PRCHCNT
- D TM
- Q
- ;
- 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
- S PRCHEST=+$P(^PRC(442,PRCHPO,0),U,13) I PRCHEST,PRCHCNT S PRCHEST=PRCHEST/PRCHCNT
- D TM
- Q
- ;
- TM ;CALCULATE TERM DISCOUNT PERCENT
- 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
- S:$O(I(0)) PRCHS("T")=I($O(I(0))),Y=$P(PRCHS("T"),U,2),PRCHS("T")=+PRCHS("T")/100
- ;IF THIS IS A SUPPLY FUND ORDER AND ADJUSTED TERM DISCOUNT LESS THAN 3%, DO NOT USE IT IN THE CALCULATIONS.
- I PRCHS("T"),$P(^PRC(442,PRCHPO,0),U,19)=2,Y S:PRCHS("T")<.03 PRCHS("T")=0
- K I,X,Y
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHEC2 1539 printed Mar 13, 2025@21:11:57 Page 2
- PRCHEC2 ;SF-ISC/TKW-SUPPLEMENTAL ROUTINES CALLED FROM PRCHEC ;7-31-90/10:33
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- LOGDPT SET (Z(1),Z(2))=""
- IF $DATA(^PRC(420,PRC("SITE"),1,+$PIECE(^PRC(442,PRCHPO,0),U,3),0))
- SET Z(1)=$PIECE(^(0),U,12)
- SET Z(2)=$PIECE(^(0),U,18)
- +1 IF Z(1)'=2
- if Z(2)'=""
- SET $PIECE(^PRC(442,PRCHPO,17),U,1)=$EXTRACT(Z(2),1,3)
- IF Z(2)=""
- WRITE $CHAR(7),!?3,"Fund Control point is missing LOG Department Number!!"
- +2 KILL Z
- +3 QUIT
- +4 ;
- 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.
- +1 SET PRCHCNT=0
- FOR I=0:0
- SET I=$ORDER(^PRC(442,PRCHPO,2,"AB",PRCHRD,I))
- if 'I
- QUIT
- FOR J=0:0
- SET J=$ORDER(^PRC(442,PRCHPO,2,"AB",PRCHRD,I,J))
- if 'J
- QUIT
- IF $DATA(^PRC(442,PRCHPO,2,I,3,J,0))
- SET PRCHCNT=PRCHCNT+1
- +2 SET PRCHEST=$SELECT(PRCHRPT=1:+$PIECE(^PRC(442,PRCHPO,0),U,13),1:0)
- IF PRCHEST
- IF PRCHCNT
- SET PRCHEST=PRCHEST/PRCHCNT
- +3 DO TM
- +4 QUIT
- +5 ;
- CAL2 SET PRCHCNT=0
- FOR I=0:0
- SET I=$ORDER(^PRC(442,PRCHPO,2,I))
- if 'I
- QUIT
- IF $DATA(^(I,2))
- IF ^(2)
- SET PRCHCNT=PRCHCNT+1
- +1 SET PRCHEST=+$PIECE(^PRC(442,PRCHPO,0),U,13)
- IF PRCHEST
- IF PRCHCNT
- SET PRCHEST=PRCHEST/PRCHCNT
- +2 DO TM
- +3 QUIT
- +4 ;
- TM ;CALCULATE TERM DISCOUNT PERCENT
- +1 SET PRCHS("T")=0
- SET Y=0
- KILL I
- FOR I=0:0
- SET I=$ORDER(^PRC(442,PRCHPO,5,I))
- if 'I
- QUIT
- SET X=^(I,0)
- IF +X>0
- SET I(100-X)=X
- +2 if $ORDER(I(0))
- SET PRCHS("T")=I($ORDER(I(0)))
- SET Y=$PIECE(PRCHS("T"),U,2)
- SET PRCHS("T")=+PRCHS("T")/100
- +3 ;IF THIS IS A SUPPLY FUND ORDER AND ADJUSTED TERM DISCOUNT LESS THAN 3%, DO NOT USE IT IN THE CALCULATIONS.
- +4 IF PRCHS("T")
- IF $PIECE(^PRC(442,PRCHPO,0),U,19)=2
- IF Y
- if PRCHS("T")<.03
- SET PRCHS("T")=0
- +5 KILL I,X,Y
- +6 QUIT
