PRCPPOL0.m

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 ---PRCPPOL0   2005     printed  Mar 13, 2025@21:19:11                                                                                                                                                                                                    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