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

PRCPEITE.m

Go to the documentation of this file. 
  1. PRCPEITE ;WISC/RFJ-enter/edit inventory items                       ; 11/6/06 8:40am
  1. V ;;5.1;IFCAP;**1,98**;Oct 20, 2000;Build 37
  1.  ;Per VHA Directive 2004-038, this routine should not be modified.
  1.  Q
  1.  ;
  1. ALL(PRCPINPT,ITEMDA) ;  edit all fields option (for new items)
  1.  I '$D(^PRCP(445,+PRCPINPT,1,+ITEMDA,0)) Q
  1.  N %,%H,D,D0,D1,D2,DA,DES,DI,DIC,DIE,DLAYGO,DQ,DR,I
  1.  N PRCPINDA,PRCPITEM,PRCPNL,PRCPQUIT,PRCPPRIV,PRCPTYPE,PRCPUI,PRCPUI1,X,Y
  1.  D EN^DDIOL("----- Enter Item Descriptive Data -----")
  1.  S DES=$P($G(^PRCP(445,PRCPINPT,1,ITEMDA,6)),"^")
  1.  I DES="" S DES=$$DESDEF^PRCPEITF(PRCPINPT,ITEMDA) ; get item description default
  1.  S PRCPQUIT=0
  1.  D DESCRIP^PRCPEITF(PRCPINPT,ITEMDA,.PRCPQUIT)
  1.  I PRCPQUIT Q
  1.  S DR="[PRCP ITEM ALL FIELDS (NON-SS)]"
  1.  I $P(^PRCP(445,PRCPINPT,0),"^",3)="S",$P($G(^PRCP(445,PRCPINPT,5)),"^",1)]"" S DR="[PRCP ITEM ALL FIELDS (SS)]" ; supply station monitors normal level value
  1.  S DA=PRCPINPT
  1.  S PRCPITEM=$C(96)_ITEMDA
  1.  S (DIC,DIE)="^PRCP(445,"
  1.  S DIE("NO^")="BACKOUTOK"
  1.  S PRCPPRIV=1 D ^DIE
  1.  Q
  1.  ;
  1.  ;
  1. DESCRIP(PRCPINPT,ITEMDA) ;  edit description, category, location fields
  1.  I '$D(^PRCP(445,+PRCPINPT,1,+ITEMDA,0)) Q
  1.  N %,D,D0,DA,DES,DI,DIC,DIE,DISYS,DQ,DR,DZ,E,PRCPPRIM,PRCPPRIV,PRCPPRNM,PRCPQUIT,TYPE,X,XH,XP,Y
  1.  S DES=$P($G(^PRCP(445,PRCPINPT,1,ITEMDA,6)),"^")
  1.  I DES="" S DES=$$DESDEF^PRCPEITF(PRCPINPT,ITEMDA) ; get default value
  1.  S PRCPQUIT=0
  1.  D DESCRIP^PRCPEITF(PRCPINPT,ITEMDA,.PRCPQUIT)
  1.  I PRCPQUIT Q
  1.  S DA(1)=PRCPINPT,DA=ITEMDA,(DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,"
  1.  S DR=".5GROUP CATEGORY;5MAIN STORAGE LOCATION;6"
  1.  S PRCPPRIV=1
  1.  D ^DIE K PRCPPRIV
  1.  Q
  1.  ;
  1.  ;
  1. LEVELS(PRCPINPT,ITEMDA) ;  edit stock levels
  1.  I '$D(^PRCP(445,+PRCPINPT,1,+ITEMDA,0)) Q
  1.  N %,D,D0,DA,DI,DIC,DIE,DQ,DR,DZ,PRCPDR,PRCPPRIV,PRCPQUIT,UNIT,X,Y
  1.  S UNIT=$$UNIT^PRCPUX1(PRCPINPT,ITEMDA," per ")
  1.  S DR="9NORMAL STOCK LEVEL     ("_UNIT_")"
  1.  S PRCPQUIT=0
  1.  ;
  1.  ; if the supply station secondary has unposted regular orders,
  1.  ; restrict editing a non-zero normal level to zero.
  1.  I $P(^PRCP(445,PRCPINPT,0),"^",3)="S",$P($G(^PRCP(445,PRCPINPT,5)),"^",1)]"" D
  1.  . D EDNORM(PRCPINPT,ITEMDA,$E(DR,2,99),.PRCPQUIT)
  1.  . S DR=""
  1.  . I $D(DUOUT)!$D(DTOUT) Q
  1.  I PRCPQUIT Q
  1.  I DR]"" S DR=DR_";"
  1.  S PRCPPRIV=1
  1.  S DR=DR_"11EMERGENCY STOCK LEVEL  ("_UNIT_");9.5TEMPORARY STOCK LEVEL  ("_UNIT_");I 'X S Y=10;9.6;10STANDARD REORDER POINT ("_UNIT_");10.3OPTIONAL REORDER POINT ("_UNIT_");"
  1.  S DA(1)=PRCPINPT,DA=ITEMDA,(DIC,DIE)="^PRCP(445,"_PRCPINPT_",1," D ^DIE
  1.  Q
  1.  ;
  1.  ;
  1. SPECIAL(PRCPINPT,ITEMDA) ;  special parameters and flags
  1.  I '$D(^PRCP(445,+PRCPINPT,1,+ITEMDA,0)) Q
  1.  N %,C,D,D0,D1,DA,DDH,DI,DIC,DIE,DISYS,DIZ,DLAYGO,DQ,DR,I,ISSUE,PRCPITEM,PRCPPRIV,PRCPSET,TYPE,X,Y
  1.  S (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,",PRCPSET="I PRCPITEM'=X,$D(^PRCP(445,PRCPINPT,1,X,0))",DA(1)=PRCPINPT,(PRCPITEM,DA)=ITEMDA
  1.  S TYPE=$P($G(^PRCP(445,PRCPINPT,0)),"^",3)
  1.  ;  substitute item multiple
  1.  I TYPE="W",'$D(^PRCP(445,PRCPINPT,1,ITEMDA,4,0)) S ^(0)="^445.122PI^^"
  1.  I TYPE="P",$P(^PRCP(445,PRCPINPT,0),"^",10)="S" S ISSUE=1
  1.  ;  removal of fields 14;14.3;14.4 if type = "P" (fields not used)
  1.  S DR="17;"_$S($G(ISSUE):"14.5;",1:"")_$S(TYPE="W":"22;",1:"")
  1.  S PRCPPRIV=1
  1.  D ^DIE I $D(DTOUT)!$D(Y) Q
  1.  K DIC,DIE,DA,DR
  1.  I TYPE'="W" D ODI^PRCPEITG(PRCPINPT,ITEMDA) ; ask On-Demand (PRC*5.1*98)
  1.  Q
  1.  ;
  1.  ;
  1. DISPUNIT(PRCPINPT,ITEMDA) ;  drug accountability dispensing units
  1.  N %,D,D0,DA,DD,DDH,DI,DIC,DIE,DISYS,DIX,DIY,DO,DQ,DR,DZ,X,Y
  1.  S DA(1)=PRCPINPT,DA=ITEMDA,(DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,",DR="50;51"
  1.  S PRCPPRIV=1 D ^DIE K PRCPPRIV
  1.  Q
  1.  ;
  1.  ;
  1. EDNORM(PRCPINPT,ITEMDA,TEXT,PRCPQUIT) ; editing the normal level on supply station secondaries
  1.  ; ITEMDA   = item number requiring the default description
  1.  ; PRCPINPT = inventory point
  1.  ; TEXT = text to display when prompting the user
  1.  ; PRCPQUIT = flag to signify exit desired
  1.  ;
  1.  N DA,DIC,DIE,DIR,DR,ORD,PRCPNL,PRCPPRIV,VALUE
  1.  ; because this is sometimes called from templates, new FileMan variables
  1.  N D,D0,D1,D2,D3,D4,D5,D6,DB,DC,DD,DE,DG,DH,DI,DIA,DIADD,DICR,DIEC,DIEL
  1.  N DIFLD,DIK,DIOV,DK,DL,DLAYGO,DM,DO,DOV,DP,DQ,DU,DV,DW,I,J,X,Y
  1.  I $P(^PRCP(445,PRCPINPT,0),"^",3)'="S" QUIT
  1.  I '$P($G(^PRCP(445,PRCPINPT,5)),"^",1) QUIT
  1.  I '$D(^PRCP(445,PRCPINPT,1,ITEMDA,0)) QUIT
  1.  S PRCPNL=+$P(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",9)
  1.  S ORD=0
  1.  S ORD=$$ORDCHK^PRCPUITM(ITEMDA,PRCPINPT,"R","")
  1.  I ORD D  ; this field is also a flag of items on supply station, editing must be restricted if there are outstanding supply station orders.
  1.  . N DIR
  1.  . S DIR("A")=TEXT
  1.  . S DIR("A",1)="There are outstanding regular orders for this item."
  1.  . S DIR("A",2)="You cannot delete the normal level or make it 0"
  1.  . S DIR(0)="N^1:999999"
  1.  . S DIR("B")=PRCPNL
  1.  . D ^DIR K DIR
  1.  . I $D(DUOUT)!$D(DTOUT) S PRCPQUIT=1 Q
  1.  . I X S PRCPNL=X D
  1.  . . S DA(1)=PRCPINPT,DA=ITEMDA,PRCPPRIV=1
  1.  . . S (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,"
  1.  . . S DR="9///^S X=PRCPNL"
  1.  . . D ^DIE
  1.  . . K DIC,DIE
  1.  I 'ORD D
  1.  . I PRCPNL'>0 W !!,"Changing the level from zero will add the item to the supply station."
  1.  . I PRCPNL>0 W !!,"Changing the level to zero will delete the item from the supply station."
  1.  . I $D(DUOUT)!$D(DTOUT) S PRCPQUIT=1 Q
  1.  . S DIR(0)="445.01,9^^",DA(1)=PRCPINPT,DA=ITEMDA
  1.  . D ^DIR K DIR
  1.  . S VALUE=Y
  1.  . I $D(DTOUT)!$D(DUOUT) S PRCPQUIT=1 Q
  1.  . S DR="9///^S X=VALUE"
  1.  . S DA=ITEMDA,DA(1)=PRCPINPT,PRCPPRIV=1
  1.  . S (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,"
  1.  . D ^DIE
  1.  . K DIC,DIE
  1.  . I PRCPNL,'$P(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",9) D BLDSEG^PRCPHLFM(2,ITEMDA,PRCPINPT)
  1.  . I 'PRCPNL,$P(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",9) D BLDSEG^PRCPHLFM(1,ITEMDA,PRCPINPT)
  1.  QUIT