- 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 Apr 23, 2025@18:28:15 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
