PRCPEIQT ;WISC/RFJ-edit quantities, dueins, costs ; 5/4/99 3:40pm
V ;;5.1;IFCAP;**124**;Oct 20, 2000;Build 2
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
QTY(PRCPINPT,ITEMDA) ; adjust primary or secondary quantity
N %,ITEMDATA,ORDERNO,PRCPEIQT,PRCPID,QTY,REASON,VALUE,X,Y
S ITEMDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0)) I ITEMDATA="" Q
W !!?3,"QTY ON-HAND (in ",$$UNIT^PRCPUX1(PRCPINPT,ITEMDA," per "),"): ",+$P(ITEMDATA,"^",7)
W !?10,"x",?16,"AVERAGE COST: ",$J(+$P(ITEMDATA,"^",22),0,3)
W !?10,"=",?13,"INVENTORY VALUE: ",$J(+$P(ITEMDATA,"^",27),0,2),!
S QTY=$$QTY^PRCPAWU0(-99999,99999) Q:QTY["^"
W ! S VALUE=$$VALUE^PRCPAWU0(-9999999.99,9999999.99,"",0) Q:VALUE["^"
S QTY=+QTY,VALUE=+VALUE I QTY=0,VALUE=0 Q
W ! S REASON=$$REASON^PRCPAWU0("",1) Q:REASON["^"
S ORDERNO=$$ORDERNO^PRCPUTRX(PRCPINPT)
K PRCPEIQT S PRCPEIQT("QTY")=QTY,PRCPEIQT("INVVAL")=VALUE,PRCPEIQT("SELVAL")=0,PRCPEIQT("REASON")="0:"_REASON,PRCPEIQT("2237PO")=""
D ITEM^PRCPUUIW(PRCPINPT,ITEMDA,"A",ORDERNO,.PRCPEIQT)
Q
;
;
DUEIN(PRCPINPT,ITEMDA) ; change primary or secondary due-ins
N %,%H,D,D0,D1,DA,DD,DDC,DDH,DI,DIC,DIE,DIX,DIY,DIZ,DO,DQ,DR,DZ,ITEMDATA,PRCPTYPE,X,Y,Z
S ITEMDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0)) I ITEMDATA="" Q
S PRCPTYPE=$P(^PRCP(445,PRCPINPT,0),"^",3)
W !!?3,"QTY DUE-IN (in ",$$UNIT^PRCPUX1(PRCPINPT,ITEMDA," per "),"): ",$$GETIN^PRCPUDUE(PRCPINPT,ITEMDA),!
S:'$D(^PRCP(445,PRCPINPT,1,ITEMDA,7,0)) ^(0)="^445.09P^^"
S (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,",DA(1)=PRCPINPT,DA=ITEMDA,DR=$S(PRCPTYPE="S":8.1,1:20)
D ^DIE
I PRCPTYPE="S" Q
S (X,Y)=0 F S X=$O(^PRCP(445,PRCPINPT,1,ITEMDA,7,X)) Q:'X S Y=Y+$P($G(^(X,0)),"^",2)
S X=Y-$$GETIN^PRCPUDUE(PRCPINPT,ITEMDA) I X W !?5,"...total DUE-IN QUANTITY adjusted (by: ",X,") to: ",Y D SETIN^PRCPUDUE(PRCPINPT,ITEMDA,X),R^PRCPUREP
Q
;
;
COSTEDIT(PRCPINPT,ITEMDA) ; edit last cost for invpt and item
N %,D,D0,DA,DI,DIC,DIE,DQ,DR,DZ,X,X1,Y,Y1
CE1 S DA(1)=PRCPINPT,DA=ITEMDA,(DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,",DR="4.7LAST COST;"
D ^DIE
S X1=$P(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",22),X=$P(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",15),Y=X1*1.1,Y1=X1/1.1
I X>Y!(X<Y1) D
. S Y="",DIR(0)="Y",DIR("B")="YES",DIR("A")="Re-Edit Last Cost"
. S DIR("A",1)="** WARNING: Difference between last cost entered "
. S DIR("A",2)="and average cost ("_X1_") is more than 10% **"
. D ^DIR K DIR
. I Y=1 S Y="YES"
. Q
I Y="YES" G CE1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPEIQT 2472 printed Apr 09, 2024@21:12 Page 2
PRCPEIQT ;WISC/RFJ-edit quantities, dueins, costs ; 5/4/99 3:40pm
V ;;5.1;IFCAP;**124**;Oct 20, 2000;Build 2
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;
QTY(PRCPINPT,ITEMDA) ; adjust primary or secondary quantity
+1 NEW %,ITEMDATA,ORDERNO,PRCPEIQT,PRCPID,QTY,REASON,VALUE,X,Y
+2 SET ITEMDATA=$GET(^PRCP(445,PRCPINPT,1,ITEMDA,0))
IF ITEMDATA=""
QUIT
+3 WRITE !!?3,"QTY ON-HAND (in ",$$UNIT^PRCPUX1(PRCPINPT,ITEMDA," per "),"): ",+$PIECE(ITEMDATA,"^",7)
+4 WRITE !?10,"x",?16,"AVERAGE COST: ",$JUSTIFY(+$PIECE(ITEMDATA,"^",22),0,3)
+5 WRITE !?10,"=",?13,"INVENTORY VALUE: ",$JUSTIFY(+$PIECE(ITEMDATA,"^",27),0,2),!
+6 SET QTY=$$QTY^PRCPAWU0(-99999,99999)
if QTY["^"
QUIT
+7 WRITE !
SET VALUE=$$VALUE^PRCPAWU0(-9999999.99,9999999.99,"",0)
if VALUE["^"
QUIT
+8 SET QTY=+QTY
SET VALUE=+VALUE
IF QTY=0
IF VALUE=0
QUIT
+9 WRITE !
SET REASON=$$REASON^PRCPAWU0("",1)
if REASON["^"
QUIT
+10 SET ORDERNO=$$ORDERNO^PRCPUTRX(PRCPINPT)
+11 KILL PRCPEIQT
SET PRCPEIQT("QTY")=QTY
SET PRCPEIQT("INVVAL")=VALUE
SET PRCPEIQT("SELVAL")=0
SET PRCPEIQT("REASON")="0:"_REASON
SET PRCPEIQT("2237PO")=""
+12 DO ITEM^PRCPUUIW(PRCPINPT,ITEMDA,"A",ORDERNO,.PRCPEIQT)
+13 QUIT
+14 ;
+15 ;
DUEIN(PRCPINPT,ITEMDA) ; change primary or secondary due-ins
+1 NEW %,%H,D,D0,D1,DA,DD,DDC,DDH,DI,DIC,DIE,DIX,DIY,DIZ,DO,DQ,DR,DZ,ITEMDATA,PRCPTYPE,X,Y,Z
+2 SET ITEMDATA=$GET(^PRCP(445,PRCPINPT,1,ITEMDA,0))
IF ITEMDATA=""
QUIT
+3 SET PRCPTYPE=$PIECE(^PRCP(445,PRCPINPT,0),"^",3)
+4 WRITE !!?3,"QTY DUE-IN (in ",$$UNIT^PRCPUX1(PRCPINPT,ITEMDA," per "),"): ",$$GETIN^PRCPUDUE(PRCPINPT,ITEMDA),!
+5 if '$DATA(^PRCP(445,PRCPINPT,1,ITEMDA,7,0))
SET ^(0)="^445.09P^^"
+6 SET (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,"
SET DA(1)=PRCPINPT
SET DA=ITEMDA
SET DR=$SELECT(PRCPTYPE="S":8.1,1:20)
+7 DO ^DIE
+8 IF PRCPTYPE="S"
QUIT
+9 SET (X,Y)=0
FOR
SET X=$ORDER(^PRCP(445,PRCPINPT,1,ITEMDA,7,X))
if 'X
QUIT
SET Y=Y+$PIECE($GET(^(X,0)),"^",2)
+10 SET X=Y-$$GETIN^PRCPUDUE(PRCPINPT,ITEMDA)
IF X
WRITE !?5,"...total DUE-IN QUANTITY adjusted (by: ",X,") to: ",Y
DO SETIN^PRCPUDUE(PRCPINPT,ITEMDA,X)
DO R^PRCPUREP
+11 QUIT
+12 ;
+13 ;
COSTEDIT(PRCPINPT,ITEMDA) ; edit last cost for invpt and item
+1 NEW %,D,D0,DA,DI,DIC,DIE,DQ,DR,DZ,X,X1,Y,Y1
CE1 SET DA(1)=PRCPINPT
SET DA=ITEMDA
SET (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,"
SET DR="4.7LAST COST;"
+1 DO ^DIE
+2 SET X1=$PIECE(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",22)
SET X=$PIECE(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",15)
SET Y=X1*1.1
SET Y1=X1/1.1
+3 IF X>Y!(X<Y1)
Begin DoDot:1
+4 SET Y=""
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Re-Edit Last Cost"
+5 SET DIR("A",1)="** WARNING: Difference between last cost entered "
+6 SET DIR("A",2)="and average cost ("_X1_") is more than 10% **"
+7 DO ^DIR
KILL DIR
+8 IF Y=1
SET Y="YES"
+9 QUIT
End DoDot:1
+10 IF Y="YES"
GOTO CE1
+11 QUIT
