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.
Q
;
;
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),"^")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPDAPB 1099 printed Dec 13, 2024@02:13:26 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
