Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPEIL1

PRCPEIL1.m

Go to the documentation of this file. 
  1. PRCPEIL1 ;WISC/RFJ-edit inventory item (list manager) calls         ;01 Dec 93
  1. V ;;5.1;IFCAP;**1,142**;Oct 20, 2000;Build 5
  1.  ;Per VHA Directive 2004-038, this routine should not be modified.
  1.  Q
  1.  ;
  1.  ;
  1. DESCRIP ;  edit descriptive elements
  1.  D FULL^VALM1
  1.  D DESCRIP^PRCPEITE(PRCPINPT,ITEMDA)
  1.  ;  rebuild array
  1.  D DIQ^PRCPEILM(".5;.7;5")
  1.  D DESCRIP^PRCPEILM
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1.  ;
  1. COST ;  edit costing elements
  1.  D COSTEDIT^PRCPEIQT(PRCPINPT,ITEMDA)
  1.  ;  rebuild array
  1.  D DIQ^PRCPEILM("4.7;4.8;4.81")
  1.  D COSTS^PRCPEIL0
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1.  ;
  1. ISSUNITS ;  edit issue units
  1.  D FULL^VALM1
  1.  D SETUNITS^PRCPEIUI(PRCPINPT,ITEMDA)
  1.  D EDITUI^PRCPEIUI(PRCPINPT,ITEMDA)
  1.  ;  rebuild array
  1.  D DIQ^PRCPEILM("16;16.5")
  1.  D ISSUNITS^PRCPEIL0
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1.  ;
  1. LEVELS ;  edit levels
  1.  D LEVELS^PRCPEITE(PRCPINPT,ITEMDA)
  1.  ;  rebuild array
  1.  D DIQ^PRCPEILM("9:11")
  1.  D LEVELS^PRCPEIL0
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1.  ;
  1. QUANTITY ;  edit quantities
  1. Q1 D FULL^VALM1
  1.  D QTY^PRCPEIQT(PRCPINPT,ITEMDA)
  1.  ;  rebuild array
  1.  D DIQ^PRCPEILM("7;4.8;4.81")
  1.  N ERR S ERR=0
  1.  I $G(PRCPDATA("445.01",ITEMDA,"7","E"))>0,($G(PRCPDATA("445.01",ITEMDA,"4.8","E"))<".01"!($G(PRCPDATA("445.01",ITEMDA,"4.81","E"))<".01")) D  G:ERR=1 Q1
  1.  . W !!,"** Result ON-HAND greater than 0 CANNOT have an average cost of zero."
  1.  . W !,"   You MUST modify Inventory Value to something greater than zero. You cannot"
  1.  . W !,"   have on-hand with an inventory value of zero and no average cost. If you"
  1.  . W !,"   cannot enter an inventory value (not sure what to enter) then you must "
  1.  . W !,"   MINUS the quantity originally entered to exit the QT action.",!
  1.  . W !!,"=>> PLEASE OK IF THE ZERO INVENTORY VALUE IS DUE TO A ZERO VALUE INVENTORY ITEM",!
  1.  . W $C(7) S %A="Is this a zero value inventory item",%B="",%=2 D ^PRCFYN I %'=1 S ERR=1
  1.  I $G(PRCPDATA("445.01",ITEMDA,"4.81","E"))<0!($G(PRCPDATA("445.01",ITEMDA,"4.81","E"))<0) D  G Q1
  1.  . W !!,"** Resulting Inventory Value or Average Cost CANNOT be negative. If you are"
  1.  . W !,"   unsure what the inventory value should be then you MUST adjust the "
  1.  . W !,"   quantity and inventory value back to original (zero or greater) values to "
  1.  . W !,"   exit the QT action."
  1.  D QUANTITY^PRCPEIL0
  1.  D COSTS^PRCPEIL0
  1.  S VALMBCK="R"
  1.  K ERR,%,%A,%B
  1.  Q
  1.  ;
  1.  ;
  1. DUEIN ;  edit due-ins
  1.  D FULL^VALM1
  1.  D DUEIN^PRCPEIQT(PRCPINPT,ITEMDA)
  1.  ;  rebuild array
  1.  D DIQ^PRCPEILM(8)
  1.  D QUANTITY^PRCPEIL0
  1.  D OUTSTRAN^PRCPEIL0
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1.  ;
  1. SPECIAL ;  edit special parameters
  1.  I PRCPTYPE="W" D FULL^VALM1
  1.  D SPECIAL^PRCPEITE(PRCPINPT,ITEMDA)
  1.  ;  rebuild array
  1.  D DIQ^PRCPEILM(17)
  1.  D SPECIAL^PRCPEIL0
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1.  ;
  1. SOURCES ;  edit procurement sources
  1.  D FULL^VALM1
  1.  D SOURCES^PRCPEIPS(PRCPINPT,ITEMDA)
  1.  D SOURCES0(PRCPINPT,ITEMDA) ; restrict editing if oustanding orders
  1.  ;  rebuild array
  1.  D DIQ^PRCPEILM(.4)
  1.  D SOURCES^PRCPEIL0
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. SOURCES0(PRCPINPT,ITEMDA) ; allow editing of source info if no orders
  1.  N ORD S ORD=0
  1.  ; because this is sometimes called from templates, new FileMan variables
  1.  N D,D0,D1,D2,D3,D4,D5,D6,DA,DB,DC,DD,DE,DG,DH,DI,DIA,DIADD,DIC,DICR,DIE
  1.  N DIEC,DIEL,DIFLD,DIK,DIOV,DIR,DK,DL,DLAYGO,DM,DO,DOV,DP,DR,DQ,DU,DV,DW
  1.  N I,J,X,Y
  1.  I $P(^PRCP(445,PRCPINPT,0),"^",3)="S" D  Q:ORD
  1.  . W !,"Checking the released orders for this item..."
  1.  . S ORD=$$ORDCHK^PRCPUITM(ITEMDA,PRCPINPT,"RCE","R")
  1.  . Q:'ORD
  1.  . I ORD D EN^DDIOL("To edit these values, you must first post or delete the following order(s):")
  1.  . D LISTOO^PRCPUITM(ITEMDA,PRCPINPT,"R")
  1.  . D P^PRCPUREP ; pause to allow user read information
  1.  W !!?25,"*----------------------------*",!,"You will now have the option to override the changes I made, be careful though!",!?25,"*----------------------------*",!
  1.  D EDITSOUR^PRCPEIPU(PRCPINPT,ITEMDA)
  1.  Q
  1.  ;
  1.  ;
  1. DRUGACCT ;  edit drug accountability parameters
  1.  D DISPUNIT^PRCPEITE(PRCPINPT,ITEMDA)
  1.  ;  rebuild array
  1.  D DIQ^PRCPEILM("50;51")
  1.  D DRUGACCT^PRCPEIL0
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1.  ;
  1. ALL ;  edit all fields
  1.  D FULL^VALM1
  1.  D ALL^PRCPEITE(PRCPINPT,ITEMDA)
  1.  ;  rebuild array
  1.  D INIT^PRCPEILM
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1.  ;
  1. DELETE ;  remove item from inventory point
  1.  D DELETE^PRCPUITM(PRCPINPT,ITEMDA)
  1.  D R^PRCPUREP
  1.  S VALMBCK="R"
  1.  I '$D(^PRCP(445,PRCPINPT,1,ITEMDA,0)) K VALMBCK Q
  1.  Q
  1.  ;
  1.  ;
  1. SECOND ;  edit secondary item
  1.  D FULL^VALM1
  1.  S VALMBCK="R"
  1.  N PRCPSECO
  1.  S PRCPSECO=$$TO^PRCPUDPT(PRCPINPT) I 'PRCPSECO  Q
  1.  I '$D(^PRCP(445,PRCPSECO,4,+$G(DUZ),0)) S VALMSG="NOT AN AUTHORIZED USER FOR SECONDARY INVENTORY POINT" Q
  1.  D
  1.  .   N ITEMDA,PRCPINPT,PRCPTYPE
  1.  .   S PRCPINPT=PRCPSECO,PRCPTYPE=$P($G(^PRCP(445,PRCPSECO,0)),"^",3)
  1.  .   F  W !! S ITEMDA=$$ITEM^PRCPUITM(PRCPINPT,1,"","") Q:'ITEMDA  D
  1.  .   .   L +^PRCP(445,PRCPINPT,1,ITEMDA):1 I '$T D SHOWWHO^PRCPULOC(445,PRCPINPT_"-1",0) Q
  1.  .   .   D ADD^PRCPULOC(445,PRCPINPT_"-1",0,"Enter/Edit Inventory Item Data")
  1.  .   .   D EN^VALM("PRCP EDIT ITEMS")
  1.  .   .   I $D(^PRCP(445,PRCPINPT,1,ITEMDA)) D BLDSEG^PRCPHLFM(3,ITEMDA,PRCPINPT) ; send supply station an update of any changes to the item
  1.  .   .   D CLEAR^PRCPULOC(445,PRCPINPT_"-1",0)
  1.  .   .   L -^PRCP(445,PRCPINPT,1,ITEMDA)
  1.  .   Q
  1.  D INIT^PRCPEILM
  1.  S VALMBCK="R"
  1.  Q