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

PRCPENE1.m

Go to the documentation of this file. 
  1. PRCPENE1 ;WISC/RFJ,DGL-enter/edit inv parameters (list manager) ;10.7.99
  1. V ;;5.1;IFCAP;**1**;Oct 20, 2000
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  Q
  1.  ;
  1.  ;
  1. ALL ;  edit all fields
  1.  D FULL^VALM1
  1.  S VALMBCK="R"
  1.  I '$D(^PRCP(445,PRCPINPT,0)) Q
  1.  I $P($G(^PRCP(445,PRCPINPT,5)),"^",1)]"" D EDIT("[PRCP INVENTORY POINT (SS)]")
  1.  E  D EDIT("[PRCP INVENTORY POINT (NON SS)]")
  1.  D INIT^PRCPENLM
  1.  Q
  1.  ;
  1.  ;
  1. DESCRIP ;  edit descriptive parameters
  1.  N PRCPNM,VALUE
  1.  D FULL^VALM1
  1.  S VALMBCK="R"
  1.  I '$D(^PRCP(445,PRCPINPT,0)) Q
  1.  I $P($G(^PRCP(445,PRCPINPT,5)),"^",1)]"" D 
  1.  . S PRCPNM=$P(^PRCP(445,PRCPINPT,0),"^",1)
  1.  . D EN^DDIOL("The inventory point name cannot be edited on a supply station secondary.")
  1.  . D EDIT(".01////^S X=PRCPNM")
  1.  . S DIR(0)="445,.8^^",DA=PRCPINPT
  1.  . D ^DIR K DIR
  1.  . S VALUE=Y
  1.  . I $D(DTOUT)!$D(DUOUT) Q
  1.  . S DA=PRCPINPT,DIE="^PRCP(445,",DR=".8///^S X=VALUE",PRCPPRIV=1
  1.  . D ^DIE K PRCPPRIV,DIE
  1.  . W !
  1.  . D EN^DDIOL("WARNING: A 'NO' RESPONSE MAY CAUSE INTEGRITY PROBLEMS")
  1.  . D EN^DDIOL("WITH THE SUPPLY STATION INTERFACE.")
  1.  . S DIR(0)="445,.5^^",DA=PRCPINPT
  1.  . D ^DIR K DIR
  1.  . S VALUE=Y
  1.  . I $D(DTOUT)!$D(DUOUT) Q
  1.  . S DA=PRCPINPT,DIE="^PRCP(445,",DR=".5///^S X=VALUE",PRCPPRIV=1
  1.  . D ^DIE K PRCPPRIV,DIE
  1.  . W !
  1.  . D EN^DDIOL("WARNING: A 'NO' RESPONSE CAUSES GIP TO IGNORE INFORMATION")
  1.  . D EN^DDIOL("FROM THE SUPPLY STATION.")
  1.  . S DIR(0)="445,.6^^",DA=PRCPINPT
  1.  . D ^DIR K DIR
  1.  . S VALUE=Y
  1.  . I $D(DTOUT)!$D(DUOUT) Q
  1.  . S DA=PRCPINPT,DIE="^PRCP(445,",DR=".6///^S X=VALUE",PRCPPRIV=1
  1.  . D ^DIE K PRCPPRIV,DIE
  1.  . W !
  1.  I $P($G(^PRCP(445,PRCPINPT,5)),"^",1)="" D EDIT(".01;.8;.5;.6")
  1.  D INIT^PRCPENLM
  1.  Q
  1.  ;
  1.  ;
  1. SPECIAL ;  edit special parameters
  1.  D FULL^VALM1
  1.  S VALMBCK="R"
  1.  I '$D(^PRCP(445,PRCPINPT,0)) Q
  1.  N DR,ORD,TYPE
  1.  S ORD=0
  1.  S TYPE=$P(^PRCP(445,PRCPINPT,0),"^",3)
  1.  S DR="12;"
  1.  I TYPE="W" S DR=DR_".9;16"
  1.  I TYPE="P" S DR=DR_"14;15;I $P(^PRCP(445,DA,0),U,20)'=""S"" S Y=5;16;5;5.5;9"
  1.  I TYPE="S" D
  1.  .   S ORD=$$SSCHK(PRCPINPT)
  1.  .   I 'ORD S DR=DR_"22"
  1.  D EDIT(DR)
  1.  I ORD[1 D EN^DDIOL("Post or delete all regular orders before editing the supply station provider.")
  1.  I ORD[2 D EN^DDIOL("Change this secondary to be stocked by only 1 primary before adding a "),EN^DDIOL("supply station provider.")
  1.  I ORD[3 D EN^DDIOL("A supply station IP cannot have a name longer than 10 characters."),EN^DDIOL("Edit the name before linking a supply station to this IP.")
  1.  I ORD D P^PRCPUREP ; pause to allow user to read message
  1.  D INIT^PRCPENLM
  1.  Q
  1.  ;
  1.  ;
  1. FCP ;  edit fund control point
  1.  D FULL^VALM1
  1.  N %,FCP,FCPNM,INVPTNM,PRCPFLAG
  1.  S INVPTNM=$$INVNAME^PRCPUX1(PRCPINPT)
  1.  K X S X(1)="Select the FUND CONTROL POINT that may be used when replenishing "_INVPTNM W ! D DISPLAY^PRCPUX2(3,75,.X)
  1.  F  D  Q:$G(PRCPFLAG)
  1.  .   D DISPFCP^PRCPUTIL(PRCPINPT)
  1.  .   S FCP=$$SELECT^PRCPUFCP(PRCPTYPE) I FCP<1 S PRCPFLAG=1 Q
  1.  .   S FCPNM=$P(^PRC(420,PRC("SITE"),1,FCP,0),U)
  1.  .   I $D(^PRC(420,"AE",PRC("SITE"),PRCPINPT,+FCP)) D  Q  ; if defined
  1.  .   .   W ! S XP="   Do you want to unlink inventory point "_INVPTNM
  1.  .   .   S XP(1)="   from control point "_FCPNM
  1.  .   .   I $$YN^PRCPUYN(2)=1 D DEL^PRCPUFCP(FCP,PRCPINPT)
  1.  .   .   I $O(^PRC(420,"AE",PRC("SITE"),PRCPINPT,0)) S PRCPFLAG=1
  1.  .   E  D SET^PRCPUFCP(FCP,PRCPINPT) S PRCPFLAG=1
  1.  .   Q
  1.  D:'$G(PRCP("CONVRT")) INIT^PRCPENLM
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1.  ;
  1. MISCOST ;  edit mis costing
  1.  D FULL^VALM1
  1.  S VALMBCK="R"
  1.  I '$D(^PRCP(445,PRCPINPT,0)) Q
  1.  I '$D(^PRCP(445,PRCPINPT,3,0)) S ^(0)="^445.011P^^"
  1.  D EDIT(11)
  1.  D INIT^PRCPENLM
  1.  Q
  1.  ;
  1.  ;
  1. USERS ;  edit authorized users
  1.  D FULL^VALM1
  1.  S VALMBCK="R"
  1.  I '$D(^PRCP(445,PRCPINPT,0)) Q
  1.  I '$D(^PRCP(445,PRCPINPT,4,0)) S ^(0)="^445.04P^^"
  1.  D EDIT(6)
  1.  I $P(^PRCP(445,PRCPINPT,0),"^",3)'="S" D USERS^PRCPENEU(PRCPINPT)
  1.  D INIT^PRCPENLM
  1.  Q
  1.  ;
  1.  ;
  1. FLAGS ;  edit flags: emergency stock level, issue schedule, auto purge
  1.  D FULL^VALM1
  1.  S VALMBCK="R"
  1.  N DR,PRCPX1,PRCPX2,PRCPX3
  1.  ;  emergency stock level text
  1.  S PRCPX1(1)="Set the 'Print Emergency Stock Levels' flag to NO to discontinue the notification that you have items at or below the emergency stock level.  The next time the automatically scheduled program which scans the database"
  1.  S PRCPX1(2)="runs, it will reset the flag and the message will reappear if items are found at or below the emergency stock level."
  1.  S DR="D DISPLAY^PRCPUX2(5,75,.PRCPX1);7PRINT EMERGENCY STOCK LEVELS;"
  1.  ;  automatic purge text
  1.  S PRCPX2(1)="Set the 'Automatic Purge' to YES if you want data older than 13 months automatically purged for this inventory point.  A background scheduled program will run the first day of each month and automatically purge old"
  1.  S PRCPX2(2)="data for those inventory points which have the automatic purge turned on."
  1.  S DR=DR_"D DISPLAY^PRCPUX2(5,75,.PRCPX2);7.9AUTOMATIC PURGE;"
  1.  ;  reg whse issues text
  1.  S PRCPX3(1)="Delete the 'Regular Whse Issues Due Date' to discontinue the message notifying you that your next request for warehouse issues is due; or change it to a later date, if you wish to be reminded later."
  1.  I PRCPTYPE="P" S DR=DR_"D DISPLAY^PRCPUX2(5,75,.PRCPX3);10REGULAR WHSE ISSUES DUE DATE;"
  1.  D EDIT(DR)
  1.  D INIT^PRCPENLM
  1.  Q
  1.  ;
  1.  ;
  1. SSCHK(PRCPINPT) N ORD,PRCPSB
  1.  ;
  1.  ; returns 1 if a secondary inventory point has outstanding orders
  1.  ;         2 if it is stocked by multiple points
  1.  ;         3 if the IP name is too long
  1.  ;       123 if ALL conditions are true
  1.  ;
  1.  ; PRCPINPT is the secondary inventory point's DA
  1.  ;
  1.  S ORD=0
  1.  ; F  S ORD=$O(^PRCP(445.3,"AD",PRCPINPT,ORD)) Q:ORD']""  I $P(^PRCP(445.3,ORD,0),"^",8)="R",$P(^(0),"^",6)'="P" D  Q
  1.  ; .   S ORD=1
  1.  S ORD=$$ORDCHK^PRCPUITM(0,PRCPINPT,"R","") ; any outstanding reg orders?
  1.  I $P($G(^PRCP(445,PRCPINPT,5)),"^",1)']"" D
  1.  .   N PRCPSB S PRCPSB=0
  1.  .   S PRCPSB=$O(^PRCP(445,"AB",PRCPINPT,PRCPSB))
  1.  .   I PRCPSB S PRCPSB=$O(^PRCP(445,"AB",PRCPINPT,PRCPSB)) I PRCPSB D
  1.  .   .   S:'ORD ORD=2 I ORD=1 S ORD=12
  1.  I $L($P($P(^PRCP(445,PRCPINPT,0),"^",1),"-",2))>10 D
  1.  . I ORD S ORD=ORD_3
  1.  . I 'ORD S ORD=3
  1.  QUIT (ORD)
  1.  ;
  1.  ;
  1. EDIT(DR) ;  edit inventory parameters fields in dr string
  1.  I '$D(^PRCP(445,+PRCPINPT,0)) Q
  1.  N %,D,D0,D1,DA,DI,DIC,DIDEL,DIE,DLAYGO,DQ,X,Y
  1.  S DA=PRCPINPT,(DIC,DIE)="^PRCP(445,",DIDEL=445,PRCPPRIV=1
  1.  D ^DIE K PRCPPRIV
  1.  Q