| 1 | PRCPDAPB ;WISC/RFJ-drug accountability/prime vendor (build RILs) ;15 Mar 94
|
|---|
| 2 | ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | Q
|
|---|
| 5 | ;
|
|---|
| 6 | ;
|
|---|
| 7 | BUILDRIL ; build repetitive item lists
|
|---|
| 8 | N %,DA,DATA,ITEMDA,LINEITEM,QTY,STCTRL,TOTAL,UNITCOST,X
|
|---|
| 9 | S STCTRL="" F S STCTRL=$O(^TMP($J,"PRCPDAPV SET",STCTRL)) Q:STCTRL=""!($G(PRCPFLAG)) D
|
|---|
| 10 | . 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
|
|---|
| 11 | . L +^PRCS(410.3,DA)
|
|---|
| 12 | . S (LINEITEM,TOTAL)=0 F S LINEITEM=$O(^TMP($J,"PRCPDAPV SET",STCTRL,"IT",LINEITEM)) Q:'LINEITEM S DATA=^(LINEITEM) D
|
|---|
| 13 | . . S ITEMDA=+$P(DATA,"^",6),QTY=+$P(DATA,"^"),UNITCOST=+$P(DATA,"^",3),TOTAL=TOTAL+$J(QTY*UNITCOST,0,2)
|
|---|
| 14 | . . S %=$$ADDITEM^PRCPAGPR(DA,ITEMDA,QTY,PRCPVEND,UNITCOST)
|
|---|
| 15 | . S $P(^PRCS(410.3,DA,0),"^",2)=TOTAL
|
|---|
| 16 | . L -^PRCS(410.3,DA)
|
|---|
| 17 | . 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),"^")
|
|---|
| 18 | . S ^TMP($J,"PRCPDAPV SET",STCTRL,"RIL")=$P(^PRCS(410.3,DA,0),"^")
|
|---|
| 19 | Q
|
|---|
