PRCPOPEE ;WISC/RFJ-edit distribution order items ;27 Sep 93
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
EDIT ; edit distribution order
D FULL^VALM1
S VALMBCK="R"
D ITEMS(ORDERDA)
D INIT^PRCPOPL
Q
;
;
ITEMS(ORDERDA) ; edit items on distribution order orderda
I '$D(^PRCP(445.3,ORDERDA,0)) Q
N AFTERQTY,BEFORQTY,CONV,ITEMDA,PRIMITEM,PRCPORD,SECOITEM,UNITCOST,UNITR,VDATA
D VARIABLE^PRCPOPU
;
F S ITEMDA=+$$ITEMSEL^PRCPOPUS(ORDERDA,PRCPPRIM,1) Q:'ITEMDA D
. ;
. ; show inventory data
. S PRIMITEM=^PRCP(445,PRCPPRIM,1,ITEMDA,0)
. S UNITCOST=+$P(PRIMITEM,"^",22) I $P(PRIMITEM,"^",15)>UNITCOST S UNITCOST=+$P(PRIMITEM,"^",15)
. ;
. W !!,"Data for PRIMARY inventory point: ",$P(PRCPORD(0),"^",2)
. W !?5,"Quantity On-Hand: ",+$P(PRIMITEM,"^",7),?40,"Unit per Issue: ",$$UNIT^PRCPUX1(PRCPPRIM,ITEMDA," per ")
. W !?5,"Quantity Due-Out: ",$$GETOUT^PRCPUDUE(PRCPPRIM,ITEMDA),!?5,"Quantity Due-In : ",$$GETIN^PRCPUDUE(PRCPPRIM,ITEMDA),!?12,"Unit Cost: ",UNITCOST
. I $P(PRIMITEM,"^",25) W !?2,"Required Issue Mult: ",$P(PRIMITEM,"^",25)
. I $P(PRIMITEM,"^",17) W !?4,"Minimum Issue Qty: ",$P(PRIMITEM,"^",17)
. ;
. S SECOITEM=$G(^PRCP(445,PRCPSECO,1,ITEMDA,0))
. W !!,"Data for SECONDARY inventory point: ",$P(PRCPORD(0),"^",3)
. I SECOITEM="" S CONV=1 W !?5,"ITEM NOT STORED IN SECONDARY INVENTORY POINT",!
. ;
. I SECOITEM'="" D
. . W !?5,"Quantity On-Hand: ",+$P(SECOITEM,"^",7),?40,"Unit per Issue: ",$$UNIT^PRCPUX1(PRCPSECO,ITEMDA," per ")
. . S VDATA=$$GETVEN^PRCPUVEN(PRCPSECO,ITEMDA,PRCPPRIM_";PRCP(445,",1),UNITR=$$UNITVAL^PRCPUX1(+$P(VDATA,"^",3),$P(VDATA,"^",2)," per "),CONV=$P(VDATA,"^",4)
. . W !?5,"Quantity Due-In : ",$$GETIN^PRCPUDUE(PRCPSECO,ITEMDA),?40,"Unit per Recpt: ",UNITR,!?37,"Conversion Factor: ",CONV
. ;
. ; enter data
. I '$P(^PRCP(445.3,ORDERDA,1,ITEMDA,0),"^",3) S $P(^(0),"^",3)=UNITCOST
. S BEFORQTY=+$P(^PRCP(445.3,ORDERDA,1,ITEMDA,0),"^",2)
. D ITEMEDIT^PRCPOPUS(ORDERDA,ITEMDA,0)
. S AFTERQTY=+$P(^PRCP(445.3,ORDERDA,1,ITEMDA,0),"^",2)
. ;
. ; if status is released and beginning qty '= current qty
. ; update dueins and dueouts
. I $P(PRCPORD(0),"^",6)'="",BEFORQTY'=AFTERQTY D DUEOUTIN^PRCPOPU(PRCPPRIM,PRCPSECO,ITEMDA,$S(AFTERQTY<0:0,1:AFTERQTY)-BEFORQTY,1)
. ;
. I AFTERQTY=0 D DELITEM^PRCPOPD(ORDERDA,ITEMDA) W !!,"** ITEM HAS BEEN DELETED FROM THE ORDER **" Q
. I AFTERQTY>0,AFTERQTY<$P(PRIMITEM,"^",17) W !,"WARNING -- THE QUANTITY IS LESS THAN THE MINIMUM ISSUE QUANTITY"
. I $P(PRIMITEM,"^",25)>0 S %=AFTERQTY/$P(PRIMITEM,"^",25) I $P(%,".",2)>0 W !,"WARNING -- THE QUANTITY IS NOT A CORRECT REQUIRED ISSUE MULTIPLE"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPOPEE 2824 printed Dec 13, 2024@02:14:11 Page 2
PRCPOPEE ;WISC/RFJ-edit distribution order items ;27 Sep 93
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
EDIT ; edit distribution order
+1 DO FULL^VALM1
+2 SET VALMBCK="R"
+3 DO ITEMS(ORDERDA)
+4 DO INIT^PRCPOPL
+5 QUIT
+6 ;
+7 ;
ITEMS(ORDERDA) ; edit items on distribution order orderda
+1 IF '$DATA(^PRCP(445.3,ORDERDA,0))
QUIT
+2 NEW AFTERQTY,BEFORQTY,CONV,ITEMDA,PRIMITEM,PRCPORD,SECOITEM,UNITCOST,UNITR,VDATA
+3 DO VARIABLE^PRCPOPU
+4 ;
+5 FOR
SET ITEMDA=+$$ITEMSEL^PRCPOPUS(ORDERDA,PRCPPRIM,1)
if 'ITEMDA
QUIT
Begin DoDot:1
+6 ;
+7 ; show inventory data
+8 SET PRIMITEM=^PRCP(445,PRCPPRIM,1,ITEMDA,0)
+9 SET UNITCOST=+$PIECE(PRIMITEM,"^",22)
IF $PIECE(PRIMITEM,"^",15)>UNITCOST
SET UNITCOST=+$PIECE(PRIMITEM,"^",15)
+10 ;
+11 WRITE !!,"Data for PRIMARY inventory point: ",$PIECE(PRCPORD(0),"^",2)
+12 WRITE !?5,"Quantity On-Hand: ",+$PIECE(PRIMITEM,"^",7),?40,"Unit per Issue: ",$$UNIT^PRCPUX1(PRCPPRIM,ITEMDA," per ")
+13 WRITE !?5,"Quantity Due-Out: ",$$GETOUT^PRCPUDUE(PRCPPRIM,ITEMDA),!?5,"Quantity Due-In : ",$$GETIN^PRCPUDUE(PRCPPRIM,ITEMDA),!?12,"Unit Cost: ",UNITCOST
+14 IF $PIECE(PRIMITEM,"^",25)
WRITE !?2,"Required Issue Mult: ",$PIECE(PRIMITEM,"^",25)
+15 IF $PIECE(PRIMITEM,"^",17)
WRITE !?4,"Minimum Issue Qty: ",$PIECE(PRIMITEM,"^",17)
+16 ;
+17 SET SECOITEM=$GET(^PRCP(445,PRCPSECO,1,ITEMDA,0))
+18 WRITE !!,"Data for SECONDARY inventory point: ",$PIECE(PRCPORD(0),"^",3)
+19 IF SECOITEM=""
SET CONV=1
WRITE !?5,"ITEM NOT STORED IN SECONDARY INVENTORY POINT",!
+20 ;
+21 IF SECOITEM'=""
Begin DoDot:2
+22 WRITE !?5,"Quantity On-Hand: ",+$PIECE(SECOITEM,"^",7),?40,"Unit per Issue: ",$$UNIT^PRCPUX1(PRCPSECO,ITEMDA," per ")
+23 SET VDATA=$$GETVEN^PRCPUVEN(PRCPSECO,ITEMDA,PRCPPRIM_";PRCP(445,",1)
SET UNITR=$$UNITVAL^PRCPUX1(+$PIECE(VDATA,"^",3),$PIECE(VDATA,"^",2)," per ")
SET CONV=$PIECE(VDATA,"^",4)
+24 WRITE !?5,"Quantity Due-In : ",$$GETIN^PRCPUDUE(PRCPSECO,ITEMDA),?40,"Unit per Recpt: ",UNITR,!?37,"Conversion Factor: ",CONV
End DoDot:2
+25 ;
+26 ; enter data
+27 IF '$PIECE(^PRCP(445.3,ORDERDA,1,ITEMDA,0),"^",3)
SET $PIECE(^(0),"^",3)=UNITCOST
+28 SET BEFORQTY=+$PIECE(^PRCP(445.3,ORDERDA,1,ITEMDA,0),"^",2)
+29 DO ITEMEDIT^PRCPOPUS(ORDERDA,ITEMDA,0)
+30 SET AFTERQTY=+$PIECE(^PRCP(445.3,ORDERDA,1,ITEMDA,0),"^",2)
+31 ;
+32 ; if status is released and beginning qty '= current qty
+33 ; update dueins and dueouts
+34 IF $PIECE(PRCPORD(0),"^",6)'=""
IF BEFORQTY'=AFTERQTY
DO DUEOUTIN^PRCPOPU(PRCPPRIM,PRCPSECO,ITEMDA,$SELECT(AFTERQTY<0:0,1:AFTERQTY)-BEFORQTY,1)
+35 ;
+36 IF AFTERQTY=0
DO DELITEM^PRCPOPD(ORDERDA,ITEMDA)
WRITE !!,"** ITEM HAS BEEN DELETED FROM THE ORDER **"
QUIT
+37 IF AFTERQTY>0
IF AFTERQTY<$PIECE(PRIMITEM,"^",17)
WRITE !,"WARNING -- THE QUANTITY IS LESS THAN THE MINIMUM ISSUE QUANTITY"
+38 IF $PIECE(PRIMITEM,"^",25)>0
SET %=AFTERQTY/$PIECE(PRIMITEM,"^",25)
IF $PIECE(%,".",2)>0
WRITE !,"WARNING -- THE QUANTITY IS NOT A CORRECT REQUIRED ISSUE MULTIPLE"
End DoDot:1
+39 QUIT
