PRCPUCC ;WISC/RFJ-update distr history file 446 (cost center) ;11 Dec 91
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
COSTCNTR(TOINVPT,FROMINPT,COSTCNTR,COST) ; add/update distribution cost (446)
; toinvpt=primary and frominpt=whse and costcntr=primary
; toinvpt=secondary and frominpt=primary and costcntr=primary
; secondaries do not have costcenters -------------------^
I 'COST!(COSTCNTR="")!('$D(^PRCP(445,+TOINVPT,0)))!('$D(^PRCP(445,+FROMINPT))) Q
N %,%H,%I,D,D0,DA,DI,DIC,DIE,DISYS,DLAYGO,DQ,DR,I,X,Y
L +^PRCP(446)
S DIC="^PRCP(446,",DIC(0)="L",DLAYGO=446
S DIC("S")="I +$P(^(0),U,2)=$E(DT,1,5),$P(^(0),U,3)="_FROMINPT_",+$P(^(0),U,4)="_COSTCNTR
S X=$P($G(^PRCP(445,TOINVPT,0)),"^"),PRCPPRIV=1 D ^DIC K PRCPPRIV
I Y<1 L -^PRCP(446) Q
S DA=+Y
I $P(Y,"^",3) S DIE="^PRCP(446,",DR="1////"_$E(DT,1,5)_";2////"_FROMINPT_";3///"_COSTCNTR D ^DIE
S $P(^PRCP(446,DA,0),"^",7)=$P(^PRCP(446,DA,0),"^",7)+COST
L -^PRCP(446)
Q
;
;
EDIT ; edit distribution costs
D ^PRCPUSEL Q:'$G(PRCP("I"))
I "WP"'[PRCP("DPTYPE") W !,"THIS OPTION CAN ONLY BE USED BY WAREHOUSE AND PRIMARY INVENTORY POINTS." Q
N %,%DT,D0,DA,DI,DIE,DLAYGO,DQ,DR,I,PRCPFLAG,X,Y
S X="" W ! D ESIG^PRCUESIG(DUZ,.X) I X'>0 Q
F D Q:$G(PRCPFLAG)
. S DIC="^PRCP(446,",DLAYGO=446,DIC(0)="QEALM",DIC("A")="Select DISTRIBUTION INVENTORY POINT: ",DIC("S")="I $P(^(0),U,3)=PRCP(""I"")",DIC("DR")="1;3;2////"_PRCP("I"),PRCPPRIV=1 W ! D ^DIC K PRCPPRIV,DIC I +Y<0 S PRCPFLAG=1 Q
. S DA=+Y,D=^PRCP(446,+Y,0),Y=$P(D,"^",2) D DD^%DT
. W !!?5,"Distribution TO : ",$$INVNAME^PRCPUX1(+$P(D,"^")),!?5,"Distribution DATE: ",Y,!?5,"Distribution CC : ",$E($P(D,"^",4),1,55),!?24,$E($P(D,"^",4),56,100)
. S DIE="^PRCP(446,",DR=6 D ^DIE
Q
;
;
SELCOSTS(INVPT) ; select distribution cost entry for inventory point
N %,DIC,I,PRCPPRIV,X,Y
S DIC="^PRCP(446,",DIC(0)="QEAM",DIC("S")="I $P(^(0),U,3)="_INVPT,PRCPPRIV=1
D ^DIC
Q $S(Y'>1:0,1:+Y)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPUCC 2037 printed Dec 13, 2024@02:16:06 Page 2
PRCPUCC ;WISC/RFJ-update distr history file 446 (cost center) ;11 Dec 91
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
COSTCNTR(TOINVPT,FROMINPT,COSTCNTR,COST) ; add/update distribution cost (446)
+1 ; toinvpt=primary and frominpt=whse and costcntr=primary
+2 ; toinvpt=secondary and frominpt=primary and costcntr=primary
+3 ; secondaries do not have costcenters -------------------^
+4 IF 'COST!(COSTCNTR="")!('$DATA(^PRCP(445,+TOINVPT,0)))!('$DATA(^PRCP(445,+FROMINPT)))
QUIT
+5 NEW %,%H,%I,D,D0,DA,DI,DIC,DIE,DISYS,DLAYGO,DQ,DR,I,X,Y
+6 LOCK +^PRCP(446)
+7 SET DIC="^PRCP(446,"
SET DIC(0)="L"
SET DLAYGO=446
+8 SET DIC("S")="I +$P(^(0),U,2)=$E(DT,1,5),$P(^(0),U,3)="_FROMINPT_",+$P(^(0),U,4)="_COSTCNTR
+9 SET X=$PIECE($GET(^PRCP(445,TOINVPT,0)),"^")
SET PRCPPRIV=1
DO ^DIC
KILL PRCPPRIV
+10 IF Y<1
LOCK -^PRCP(446)
QUIT
+11 SET DA=+Y
+12 IF $PIECE(Y,"^",3)
SET DIE="^PRCP(446,"
SET DR="1////"_$EXTRACT(DT,1,5)_";2////"_FROMINPT_";3///"_COSTCNTR
DO ^DIE
+13 SET $PIECE(^PRCP(446,DA,0),"^",7)=$PIECE(^PRCP(446,DA,0),"^",7)+COST
+14 LOCK -^PRCP(446)
+15 QUIT
+16 ;
+17 ;
EDIT ; edit distribution costs
+1 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+2 IF "WP"'[PRCP("DPTYPE")
WRITE !,"THIS OPTION CAN ONLY BE USED BY WAREHOUSE AND PRIMARY INVENTORY POINTS."
QUIT
+3 NEW %,%DT,D0,DA,DI,DIE,DLAYGO,DQ,DR,I,PRCPFLAG,X,Y
+4 SET X=""
WRITE !
DO ESIG^PRCUESIG(DUZ,.X)
IF X'>0
QUIT
+5 FOR
Begin DoDot:1
+6 SET DIC="^PRCP(446,"
SET DLAYGO=446
SET DIC(0)="QEALM"
SET DIC("A")="Select DISTRIBUTION INVENTORY POINT: "
SET DIC("S")="I $P(^(0),U,3)=PRCP(""I"")"
SET DIC("DR")="1;3;2////"_PRCP("I")
SET PRCPPRIV=1
WRITE !
DO ^DIC
KILL PRCPPRIV,DIC
IF +Y<0
SET PRCPFLAG=1
QUIT
+7 SET DA=+Y
SET D=^PRCP(446,+Y,0)
SET Y=$PIECE(D,"^",2)
DO DD^%DT
+8 WRITE !!?5,"Distribution TO : ",$$INVNAME^PRCPUX1(+$PIECE(D,"^")),!?5,"Distribution DATE: ",Y,!?5,"Distribution CC : ",$EXTRACT($PIECE(D,"^",4),1,55),!?24,$EXTRACT($PIECE(D,"^",4),56,100)
+9 SET DIE="^PRCP(446,"
SET DR=6
DO ^DIE
End DoDot:1
if $GET(PRCPFLAG)
QUIT
+10 QUIT
+11 ;
+12 ;
SELCOSTS(INVPT) ; select distribution cost entry for inventory point
+1 NEW %,DIC,I,PRCPPRIV,X,Y
+2 SET DIC="^PRCP(446,"
SET DIC(0)="QEAM"
SET DIC("S")="I $P(^(0),U,3)="_INVPT
SET PRCPPRIV=1
+3 DO ^DIC
+4 QUIT $SELECT(Y'>1:0,1:+Y)
