Routine: PRCPDAPB

PRCPDAPB ;WISC/RFJ-drug accountability/prime vendor (build RILs)    ;15 Mar 94

 ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

BUILDRIL ;  build repetitive item lists

 N %,DA,DATA,ITEMDA,LINEITEM,QTY,STCTRL,TOTAL,UNITCOST,X

 S STCTRL="" F  S STCTRL=$O(^TMP($J,"PRCPDAPV SET",STCTRL)) Q:STCTRL=""!($G(PRCPFLAG))  D

 .   S DA=+$$NEWRIL^PRCPAGPR(0,PRCPREPN) I 'DA K X S X(1)="SYSTEM ERROR - UNABLE TO ADD A NEW REPETITIVE ITEM LIST" D DISPLAY^PRCPUX2(1,80,.X) S PRCPFLAG=1 Q

 .   L +^PRCS(410.3,DA)

 .   S (LINEITEM,TOTAL)=0 F  S LINEITEM=$O(^TMP($J,"PRCPDAPV SET",STCTRL,"IT",LINEITEM)) Q:'LINEITEM  S DATA=^(LINEITEM) D

 .   .   S ITEMDA=+$P(DATA,"^",6),QTY=+$P(DATA,"^"),UNITCOST=+$P(DATA,"^",3),TOTAL=TOTAL+$J(QTY*UNITCOST,0,2)

 .   .   S %=$$ADDITEM^PRCPAGPR(DA,ITEMDA,QTY,PRCPVEND,UNITCOST)

 .   S $P(^PRCS(410.3,DA,0),"^",2)=TOTAL

 .   L -^PRCS(410.3,DA)

 .   W !,"* * * * *   R E P E T I T I V E   I T E M   L I S T : ",$P(^PRCS(410.3,DA,0),"^")

 .   S ^TMP($J,"PRCPDAPV SET",STCTRL,"RIL")=$P(^PRCS(410.3,DA,0),"^")

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPDAPB   1099     printed  Feb 18, 2025@23:39:49                                                                                                                                                                                                    Page 2

PRCPDAPB  ;WISC/RFJ-drug accountability/prime vendor (build RILs)    ;15 Mar 94

 +1       ;;5.1;IFCAP;;Oct 20, 2000

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +3        QUIT

 +4       ;

 +5       ;

BUILDRIL  ;  build repetitive item lists

 +1        NEW %,DA,DATA,ITEMDA,LINEITEM,QTY,STCTRL,TOTAL,UNITCOST,X

 +2        SET STCTRL=""

FOR

               SET STCTRL=$ORDER(^TMP($JOB,"PRCPDAPV SET",STCTRL))

               if STCTRL=""!($GET(PRCPFLAG))

                   QUIT

               Begin DoDot:1

 +3                SET DA=+$$NEWRIL^PRCPAGPR(0,PRCPREPN)

                   IF 'DA

                       KILL X

                       SET X(1)="SYSTEM ERROR - UNABLE TO ADD A NEW REPETITIVE ITEM LIST"

                       DO DISPLAY^PRCPUX2(1,80,.X)

                       SET PRCPFLAG=1

                       QUIT

 +4                LOCK +^PRCS(410.3,DA)

 +5                SET (LINEITEM,TOTAL)=0

FOR

                       SET LINEITEM=$ORDER(^TMP($JOB,"PRCPDAPV SET",STCTRL,"IT",LINEITEM))

                       if 'LINEITEM

                           QUIT

                       SET DATA=^(LINEITEM)

                       Begin DoDot:2

 +6                        SET ITEMDA=+$PIECE(DATA,"^",6)

                           SET QTY=+$PIECE(DATA,"^")

                           SET UNITCOST=+$PIECE(DATA,"^",3)

                           SET TOTAL=TOTAL+$JUSTIFY(QTY*UNITCOST,0,2)

 +7                        SET %=$$ADDITEM^PRCPAGPR(DA,ITEMDA,QTY,PRCPVEND,UNITCOST)

                       End DoDot:2

 +8                SET $PIECE(^PRCS(410.3,DA,0),"^",2)=TOTAL

 +9                LOCK -^PRCS(410.3,DA)

 +10               WRITE !,"* * * * *   R E P E T I T I V E   I T E M   L I S T : ",$PIECE(^PRCS(410.3,DA,0),"^")

 +11               SET ^TMP($JOB,"PRCPDAPV SET",STCTRL,"RIL")=$PIECE(^PRCS(410.3,DA,0),"^")

               End DoDot:1

 +12       QUIT

PRCPDAPB.m