PRCPPOL0 ;WISC/RFJ-receive purchase order (list manager) ;06 Jan 94
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
DISTCOST ; item not in inventory point, cost to distribution point
; needs prcpordr,prcpinpt
D FULL^VALM1
S VALMBCK="R"
N %,C,COSTCNTR,DATA,DISTRPT,I,ITEMDA,LINEDA,X,Y
K X S X(1)="This option allows items which are not stored in the "_$$INVNAME^PRCPUX1(PRCPINPT)_" to be costed to a distribution point."
D DISPLAY^PRCPUX2(5,75,.X)
I '$O(^TMP($J,"PRCPPOLMCOS",0)) K X S X(1)="All items on the purchase order are currently stored in the inventory point." D DISPLAY^PRCPUX2(15,55,.X) D R^PRCPUREP Q
S LINEDA=$$LINEITEM^PRCPPOU1(PRCPORDR) I 'LINEDA Q
S DATA=$G(^TMP($J,"PRCPPOLMCOS",LINEDA)) Q:DATA=""
S ITEMDA=$P(DATA,"^")
K X S X(1)="This item is not stored in the inventory point. You have the option to cost this out as a distribution cost to one of your distribution inventory points."
W ! D DISPLAY^PRCPUX2(5,75,.X)
W !,"Line Number: ",LINEDA,?20,"Master Item Number: ",ITEMDA,!?2,"DESCRIPTION: "
K X S %=0 F I=1:1 S %=$O(^PRC(442,PRCPORDR,2,LINEDA,1,%)) Q:'% S X(I)=^(%,0)
D DISPLAY^PRCPUX2(13,75,.X)
S %=$$INVNAME^PRCPUX1($P(DATA,"^",2))
W !,"COST OUT TO INVPT: ",$S(%="":"<NONE>",1:%),?50,"COST CENTER: ",$S($P(DATA,"^",3)="":"<NONE>",1:$P(DATA,"^",3))
; select distribution point
F S DISTRPT=$$TO^PRCPUDPT(PRCPINPT) Q:'DISTRPT D Q:DISTRPT
. S COSTCNTR=$P($G(^PRCP(445,DISTRPT,0)),"^",7) S:'COSTCNTR COSTCNTR=$P(^PRC(442,PRCPORDR,0),"^",5) I 'COSTCNTR W !?5,"INVENTORY POINT DOES NOT CONTAIN A COST CENTER." S DISTRPT=0 Q
. W !?5,"COSTING TO COST CENTER: ",COSTCNTR
. S ^TMP($J,"PRCPPOLMCOS",LINEDA)=ITEMDA_"^"_DISTRPT_"^"_COSTCNTR
D REBUILD^PRCPPOLB
S VALMBCK="R"
Q
;
;
EEITEMS ; called from protocol file to enter/edit invpt items
D FULL^VALM1
N PRC,PRCP
S PRCP("DPTYPE")="WP"
D ^PRCPEILM
D REBUILD^PRCPPOLB
S VALMBCK="R"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPPOL0 2005 printed Sep 23, 2025@19:50:29 Page 2
PRCPPOL0 ;WISC/RFJ-receive purchase order (list manager) ;06 Jan 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 ;
DISTCOST ; item not in inventory point, cost to distribution point
+1 ; needs prcpordr,prcpinpt
+2 DO FULL^VALM1
+3 SET VALMBCK="R"
+4 NEW %,C,COSTCNTR,DATA,DISTRPT,I,ITEMDA,LINEDA,X,Y
+5 KILL X
SET X(1)="This option allows items which are not stored in the "_$$INVNAME^PRCPUX1(PRCPINPT)_" to be costed to a distribution point."
+6 DO DISPLAY^PRCPUX2(5,75,.X)
+7 IF '$ORDER(^TMP($JOB,"PRCPPOLMCOS",0))
KILL X
SET X(1)="All items on the purchase order are currently stored in the inventory point."
DO DISPLAY^PRCPUX2(15,55,.X)
DO R^PRCPUREP
QUIT
+8 SET LINEDA=$$LINEITEM^PRCPPOU1(PRCPORDR)
IF 'LINEDA
QUIT
+9 SET DATA=$GET(^TMP($JOB,"PRCPPOLMCOS",LINEDA))
if DATA=""
QUIT
+10 SET ITEMDA=$PIECE(DATA,"^")
+11 KILL X
SET X(1)="This item is not stored in the inventory point. You have the option to cost this out as a distribution cost to one of your distribution inventory points."
+12 WRITE !
DO DISPLAY^PRCPUX2(5,75,.X)
+13 WRITE !,"Line Number: ",LINEDA,?20,"Master Item Number: ",ITEMDA,!?2,"DESCRIPTION: "
+14 KILL X
SET %=0
FOR I=1:1
SET %=$ORDER(^PRC(442,PRCPORDR,2,LINEDA,1,%))
if '%
QUIT
SET X(I)=^(%,0)
+15 DO DISPLAY^PRCPUX2(13,75,.X)
+16 SET %=$$INVNAME^PRCPUX1($PIECE(DATA,"^",2))
+17 WRITE !,"COST OUT TO INVPT: ",$SELECT(%="":"<NONE>",1:%),?50,"COST CENTER: ",$SELECT($PIECE(DATA,"^",3)="":"<NONE>",1:$PIECE(DATA,"^",3))
+18 ; select distribution point
+19 FOR
SET DISTRPT=$$TO^PRCPUDPT(PRCPINPT)
if 'DISTRPT
QUIT
Begin DoDot:1
+20 SET COSTCNTR=$PIECE($GET(^PRCP(445,DISTRPT,0)),"^",7)
if 'COSTCNTR
SET COSTCNTR=$PIECE(^PRC(442,PRCPORDR,0),"^",5)
IF 'COSTCNTR
WRITE !?5,"INVENTORY POINT DOES NOT CONTAIN A COST CENTER."
SET DISTRPT=0
QUIT
+21 WRITE !?5,"COSTING TO COST CENTER: ",COSTCNTR
+22 SET ^TMP($JOB,"PRCPPOLMCOS",LINEDA)=ITEMDA_"^"_DISTRPT_"^"_COSTCNTR
End DoDot:1
if DISTRPT
QUIT
+23 DO REBUILD^PRCPPOLB
+24 SET VALMBCK="R"
+25 QUIT
+26 ;
+27 ;
EEITEMS ; called from protocol file to enter/edit invpt items
+1 DO FULL^VALM1
+2 NEW PRC,PRCP
+3 SET PRCP("DPTYPE")="WP"
+4 DO ^PRCPEILM
+5 DO REBUILD^PRCPPOLB
+6 SET VALMBCK="R"
+7 QUIT
