PRCHEC2.m

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 ---PRCHEC2   1539     printed  Apr 09, 2024@21:13:16                                                                                                                                                                                                     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