PRCPENE2 ;WISC/RFJ-enter/edit inv parameters (list manager) ;06 Jan 94
V ;;5.1;IFCAP;**1**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
DISTRPTS ; edit distribution points
D FULL^VALM1
N CLREND,COLUMN,INVPT,FLAG,LINE,PRCPDATA
F W ! S INVPT=$$INVPT^PRCPUINV(PRC("SITE"),$S(PRCPTYPE="W":"P",1:"S"),1,1,"") Q:'INVPT D
. I '$D(^PRCP(445,PRCPINPT,2,INVPT)) D I %<1 Q
. . S FLAG=0
. . I PRCPTYPE="P" D I FLAG Q
. . . N PRCPSB S PRCPSB=0
. . . S PRCPSB=$O(^PRCP(445,"AB",INVPT,PRCPSB))
. . . I PRCPSB D EN^DDIOL("This secondary is already stocked by "_$$INVNAME^PRCPUX1(PRCPSB)_".") S FLAG=1,%=0 Q
. . S XP="THIS INVENTORY IS NOT BEING STOCKED BY "_$$INVNAME^PRCPUX1(PRCPINPT)_".",XP(1)="DO YOU WANT TO MAKE IT A DISTRIBUTION POINT"
. . W ! S %=$$YN^PRCPUYN(2) I %'=1 Q
. . D ADD^PRCPENU1(PRCPINPT,INVPT) S %=1
. N PRCPINPT,PRCPTYPE
. S PRCPINPT=INVPT,PRCPTYPE=$P($G(^PRCP(445,PRCPINPT,0)),"^",3)
. I '$D(^PRCP(445,PRCPINPT,4,DUZ,0)) W !,"YOU ARE NOT AN AUTHORIZED USER FOR THIS INVENTORY POINT." Q
. I '$$KEY^PRCPUREP("PRCP"_$TR(PRCPTYPE,"WSP","W2")_" MGRKEY",DUZ)
. L +^PRCP(445,PRCPINPT,0):1 I '$T D SHOWWHO^PRCPULOC(445,PRCPINPT_"-0",0)
. I PRCPTYPE="S" L +^PRCP(445,PRCPINPT,5):1 I '$T D Q
. . D SHOWWHO^PRCPULOC(445,PRCPINPT_"-0",5)
. . L -^PRCP(445,PRCPINPT,0)
. D ADD^PRCPULOC(445,PRCPINPT_"-0",0,"Enter/Edit Inventory Parameters")
. I PRCPTYPE="S" D ADD^PRCPULOC(445,PRCPINPT_"-5",0,"Enter/Edit Inventory Parameters")
. D EN^VALM("PRCP INVENTORY PARAMETERS")
. D CLEAR^PRCPULOC(445,PRCPINPT_"-0",0)
. I PRCPTYPE="S" D CLEAR^PRCPULOC(445,PRCPINPT_"-5",0)
. L -^PRCP(445,PRCPINPT,0)
. I PRCPTYPE="S" L -^PRCP(445,PRCPINPT,5)
D INIT^PRCPENLM
S VALMBCK="R"
Q
;
;
STOCKED ; edit who stocks inventory point
D FULL^VALM1
N DA,DATA,DINUM,INVPT,INVPTNM,PRCPINNM,PRCPFLAG,SCREEN,X
S PRCPINNM=$$INVNAME^PRCPUX1(PRCPINPT)
W !!,"CHECKING INVENTORY POINTS DISTRIBUTING TO '",PRCPINNM,"':" W:PRCPTYPE="W" !,"(THERE SHOULD NOT BE ANY)"
S SCREEN=$P($G(^DD(445.03,.01,0)),"^",5,99)
S DA=0 F S DA=$O(^PRCP(445,"AB",PRCPINPT,DA)) Q:'DA S DATA=$G(^PRCP(445,DA,0)) I DATA D
. W !?5,$P(DATA,"^"),?40,"TYPE: ",$S($P(DATA,"^",3)="W":"WAREHOUSE",$P(DATA,"^",3)="P":"PRIMARY",$P(DATA,"^",3)="S":"SECONDARY",1:"??")
. I SCREEN="" Q
. S X=PRCPINPT X SCREEN I $D(X) Q
. D DELETE^PRCPENU1(DA,PRCPINPT)
;
I PRCPTYPE="P" W ! S INVPT=0 F S INVPT=$O(^PRCP(445,"AC","W",INVPT)) Q:'INVPT!($G(PRCPFLAG)) S INVPTNM=$$INVNAME^PRCPUX1(INVPT) I +INVPTNM=PRC("SITE") D
. I $D(^PRCP(445,INVPT,2,PRCPINPT)) D Q
. . S XP="THIS PRIMARY INVENTORY POINT '"_PRCPINNM_"' IS CURRENTLY DISTRIBUTED",XP(1)="TO BY THE WAREHOUSE INVENTORY POINT '"_INVPTNM_"'.",XP(2)=" DO YOU WANT TO REMOVE IT AS A WAREHOUSE DISTRIBUTION POINT"
. . S XH="ENTER 'YES' TO REMOVE IT, 'NO' TO LEAVE IT AS A DISTRIBUTION POINT."
. . W ! S %=$$YN^PRCPUYN(2) I '% S PRCPFLAG=1 Q
. . I %=1 D DELETE^PRCPENU1(INVPT,PRCPINPT)
. ;
. S XP="WILL THIS PRIMARY INVENTORY POINT '"_PRCPINNM_"' BE A",XP(1)="DISTRIBUTION POINT FOR THE WAREHOUSE INVENTORY POINT '"_INVPTNM_"'",XH="ENTER 'YES' TO ADD THE PRIMARY AS A WAREHOUSE DISTRIBUTION POINT."
. W ! S %=$$YN^PRCPUYN(1) I '% S PRCPFLAG=1 Q
. I %=1 D ADD^PRCPENU1(INVPT,PRCPINPT)
;
I PRCPTYPE="S" D
. ; restrict update if supply station IP has regular orders
. S SCREEN=$P($G(^PRCP(445,PRCPINPT,5)),"^",1) ; supply station?
. I SCREEN]"" S SCREEN=$$ORDCHK^PRCPUITM(0,PRCPINPT,"R","")
. I 'SCREEN D
. . W ! S INVPT=0
. . F S INVPT=$O(^PRCP(445,"AB",PRCPINPT,INVPT)) Q:'INVPT!($G(PRCPFLAG)) D
. . . S INVPTNM=$$INVNAME^PRCPUX1(INVPT)
. . . S XP="THIS SECONDARY INVENTORY POINT, '"_PRCPINNM_"', IS CURRENTLY DISTRIBUTED"
. . . S XP(1)="TO BY THE PRIMARY INVENTORY POINT, '"_INVPTNM_"'."
. . . S XP(2)=" DO YOU WANT TO REMOVE IT AS A PRIMARY DISTRIBUTION POINT"
. . . S XH="ENTER 'YES' TO REMOVE IT, 'NO' TO LEAVE IT AS A DISTRIBUTION POINT."
. . . W ! S %=$$YN^PRCPUYN(2) I '% S PRCPFLAG=1 Q
. . . I %=1 D DELETE^PRCPENU1(INVPT,PRCPINPT)
. I SCREEN D
. . W ! S INVPT=0
. . S INVPT=$O(^PRCP(445,"AB",PRCPINPT,INVPT)),INVPTNM=$$INVNAME^PRCPUX1(INVPT)
. . D EN^DDIOL("THIS SECONDARY INVENTORY POINT, '"_PRCPINNM_"', IS STOCKED BY THE PRIMARY")
. . D EN^DDIOL("INVENTORY POINT, '"_INVPTNM_"', AND HAS OUTSTANDING REGULAR ORDERS.")
. . D EN^DDIOL(" You must post or delete these orders before removing the primary")
. . D EN^DDIOL(" distribution point.")
. . D P^PRCPUREP ; pause to allow user to see message
;
D INIT^PRCPENLM
S VALMBCK="R"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPENE2 4841 printed Dec 13, 2024@02:13:45 Page 2
PRCPENE2 ;WISC/RFJ-enter/edit inv parameters (list manager) ;06 Jan 94
V ;;5.1;IFCAP;**1**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;
DISTRPTS ; edit distribution points
+1 DO FULL^VALM1
+2 NEW CLREND,COLUMN,INVPT,FLAG,LINE,PRCPDATA
+3 FOR
WRITE !
SET INVPT=$$INVPT^PRCPUINV(PRC("SITE"),$SELECT(PRCPTYPE="W":"P",1:"S"),1,1,"")
if 'INVPT
QUIT
Begin DoDot:1
+4 IF '$DATA(^PRCP(445,PRCPINPT,2,INVPT))
Begin DoDot:2
+5 SET FLAG=0
+6 IF PRCPTYPE="P"
Begin DoDot:3
+7 NEW PRCPSB
SET PRCPSB=0
+8 SET PRCPSB=$ORDER(^PRCP(445,"AB",INVPT,PRCPSB))
+9 IF PRCPSB
DO EN^DDIOL("This secondary is already stocked by "_$$INVNAME^PRCPUX1(PRCPSB)_".")
SET FLAG=1
SET %=0
QUIT
End DoDot:3
IF FLAG
QUIT
+10 SET XP="THIS INVENTORY IS NOT BEING STOCKED BY "_$$INVNAME^PRCPUX1(PRCPINPT)_"."
SET XP(1)="DO YOU WANT TO MAKE IT A DISTRIBUTION POINT"
+11 WRITE !
SET %=$$YN^PRCPUYN(2)
IF %'=1
QUIT
+12 DO ADD^PRCPENU1(PRCPINPT,INVPT)
SET %=1
End DoDot:2
IF %<1
QUIT
+13 NEW PRCPINPT,PRCPTYPE
+14 SET PRCPINPT=INVPT
SET PRCPTYPE=$PIECE($GET(^PRCP(445,PRCPINPT,0)),"^",3)
+15 IF '$DATA(^PRCP(445,PRCPINPT,4,DUZ,0))
WRITE !,"YOU ARE NOT AN AUTHORIZED USER FOR THIS INVENTORY POINT."
QUIT
+16 IF '$$KEY^PRCPUREP("PRCP"_$TRANSLATE(PRCPTYPE,"WSP","W2")_" MGRKEY",DUZ)
+17 LOCK +^PRCP(445,PRCPINPT,0):1
IF '$TEST
DO SHOWWHO^PRCPULOC(445,PRCPINPT_"-0",0)
+18 IF PRCPTYPE="S"
LOCK +^PRCP(445,PRCPINPT,5):1
IF '$TEST
Begin DoDot:2
+19 DO SHOWWHO^PRCPULOC(445,PRCPINPT_"-0",5)
+20 LOCK -^PRCP(445,PRCPINPT,0)
End DoDot:2
QUIT
+21 DO ADD^PRCPULOC(445,PRCPINPT_"-0",0,"Enter/Edit Inventory Parameters")
+22 IF PRCPTYPE="S"
DO ADD^PRCPULOC(445,PRCPINPT_"-5",0,"Enter/Edit Inventory Parameters")
+23 DO EN^VALM("PRCP INVENTORY PARAMETERS")
+24 DO CLEAR^PRCPULOC(445,PRCPINPT_"-0",0)
+25 IF PRCPTYPE="S"
DO CLEAR^PRCPULOC(445,PRCPINPT_"-5",0)
+26 LOCK -^PRCP(445,PRCPINPT,0)
+27 IF PRCPTYPE="S"
LOCK -^PRCP(445,PRCPINPT,5)
End DoDot:1
+28 DO INIT^PRCPENLM
+29 SET VALMBCK="R"
+30 QUIT
+31 ;
+32 ;
STOCKED ; edit who stocks inventory point
+1 DO FULL^VALM1
+2 NEW DA,DATA,DINUM,INVPT,INVPTNM,PRCPINNM,PRCPFLAG,SCREEN,X
+3 SET PRCPINNM=$$INVNAME^PRCPUX1(PRCPINPT)
+4 WRITE !!,"CHECKING INVENTORY POINTS DISTRIBUTING TO '",PRCPINNM,"':"
if PRCPTYPE="W"
WRITE !,"(THERE SHOULD NOT BE ANY)"
+5 SET SCREEN=$PIECE($GET(^DD(445.03,.01,0)),"^",5,99)
+6 SET DA=0
FOR
SET DA=$ORDER(^PRCP(445,"AB",PRCPINPT,DA))
if 'DA
QUIT
SET DATA=$GET(^PRCP(445,DA,0))
IF DATA
Begin DoDot:1
+7 WRITE !?5,$PIECE(DATA,"^"),?40,"TYPE: ",$SELECT($PIECE(DATA,"^",3)="W":"WAREHOUSE",$PIECE(DATA,"^",3)="P":"PRIMARY",$PIECE(DATA,"^",3)="S":"SECONDARY",1:"??")
+8 IF SCREEN=""
QUIT
+9 SET X=PRCPINPT
XECUTE SCREEN
IF $DATA(X)
QUIT
+10 DO DELETE^PRCPENU1(DA,PRCPINPT)
End DoDot:1
+11 ;
+12 IF PRCPTYPE="P"
WRITE !
SET INVPT=0
FOR
SET INVPT=$ORDER(^PRCP(445,"AC","W",INVPT))
if 'INVPT!($GET(PRCPFLAG))
QUIT
SET INVPTNM=$$INVNAME^PRCPUX1(INVPT)
IF +INVPTNM=PRC("SITE")
Begin DoDot:1
+13 IF $DATA(^PRCP(445,INVPT,2,PRCPINPT))
Begin DoDot:2
+14 SET XP="THIS PRIMARY INVENTORY POINT '"_PRCPINNM_"' IS CURRENTLY DISTRIBUTED"
SET XP(1)="TO BY THE WAREHOUSE INVENTORY POINT '"_INVPTNM_"'."
SET XP(2)=" DO YOU WANT TO REMOVE IT AS A WAREHOUSE DISTRIBUTION POINT"
+15 SET XH="ENTER 'YES' TO REMOVE IT, 'NO' TO LEAVE IT AS A DISTRIBUTION POINT."
+16 WRITE !
SET %=$$YN^PRCPUYN(2)
IF '%
SET PRCPFLAG=1
QUIT
+17 IF %=1
DO DELETE^PRCPENU1(INVPT,PRCPINPT)
End DoDot:2
QUIT
+18 ;
+19 SET XP="WILL THIS PRIMARY INVENTORY POINT '"_PRCPINNM_"' BE A"
SET XP(1)="DISTRIBUTION POINT FOR THE WAREHOUSE INVENTORY POINT '"_INVPTNM_"'"
SET XH="ENTER 'YES' TO ADD THE PRIMARY AS A WAREHOUSE DISTRIBUTION POINT."
+20 WRITE !
SET %=$$YN^PRCPUYN(1)
IF '%
SET PRCPFLAG=1
QUIT
+21 IF %=1
DO ADD^PRCPENU1(INVPT,PRCPINPT)
End DoDot:1
+22 ;
+23 IF PRCPTYPE="S"
Begin DoDot:1
+24 ; restrict update if supply station IP has regular orders
+25 ; supply station?
SET SCREEN=$PIECE($GET(^PRCP(445,PRCPINPT,5)),"^",1)
+26 IF SCREEN]""
SET SCREEN=$$ORDCHK^PRCPUITM(0,PRCPINPT,"R","")
+27 IF 'SCREEN
Begin DoDot:2
+28 WRITE !
SET INVPT=0
+29 FOR
SET INVPT=$ORDER(^PRCP(445,"AB",PRCPINPT,INVPT))
if 'INVPT!($GET(PRCPFLAG))
QUIT
Begin DoDot:3
+30 SET INVPTNM=$$INVNAME^PRCPUX1(INVPT)
+31 SET XP="THIS SECONDARY INVENTORY POINT, '"_PRCPINNM_"', IS CURRENTLY DISTRIBUTED"
+32 SET XP(1)="TO BY THE PRIMARY INVENTORY POINT, '"_INVPTNM_"'."
+33 SET XP(2)=" DO YOU WANT TO REMOVE IT AS A PRIMARY DISTRIBUTION POINT"
+34 SET XH="ENTER 'YES' TO REMOVE IT, 'NO' TO LEAVE IT AS A DISTRIBUTION POINT."
+35 WRITE !
SET %=$$YN^PRCPUYN(2)
IF '%
SET PRCPFLAG=1
QUIT
+36 IF %=1
DO DELETE^PRCPENU1(INVPT,PRCPINPT)
End DoDot:3
End DoDot:2
+37 IF SCREEN
Begin DoDot:2
+38 WRITE !
SET INVPT=0
+39 SET INVPT=$ORDER(^PRCP(445,"AB",PRCPINPT,INVPT))
SET INVPTNM=$$INVNAME^PRCPUX1(INVPT)
+40 DO EN^DDIOL("THIS SECONDARY INVENTORY POINT, '"_PRCPINNM_"', IS STOCKED BY THE PRIMARY")
+41 DO EN^DDIOL("INVENTORY POINT, '"_INVPTNM_"', AND HAS OUTSTANDING REGULAR ORDERS.")
+42 DO EN^DDIOL(" You must post or delete these orders before removing the primary")
+43 DO EN^DDIOL(" distribution point.")
+44 ; pause to allow user to see message
DO P^PRCPUREP
End DoDot:2
End DoDot:1
+45 ;
+46 DO INIT^PRCPENLM
+47 SET VALMBCK="R"
+48 QUIT
