PRCPESTO ;WISC/RFJ-storage locations ;23 Dec 92
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D ^PRCPUSEL Q:'$G(PRCP("I"))
N %,COUNT,D,D0,DA,DIDEL,PRCPPRIV,DI,DIC,DIE,DLAYGO,DQ,DR,EACHONE,ITEMDA,LASTONE,PRCPFLAG,PRCPINPT,STORE,TOTAL,TOTAL1,X,Y
S PRCPINPT=PRCP("I")
F D Q:$G(PRCPFLAG)
. S DIC="^PRCP(445.4,",DIC("S")="I $P(^(0),U,2)=PRCP(""I"")",DIC(0)="QEALM",DLAYGO=445.4,PRCPPRIV=1 W ! D ^DIC I Y'>0 S PRCPFLAG=1 Q
. S DIE="^PRCP(445.4,",DR=".01;2",(STORE,DA)=+Y,DIDEL=445.4 D ^DIE
. I '$D(^PRCP(445.4,STORE,0)) D
. . W !!,"<<< Removing this storage location from all items in the inventory point"
. . S EACHONE=$$INPERCNT^PRCPUX2(+$P($G(^PRCP(445,PRCP("I"),1,0)),"^",4),"*",PRCP("RV1"),PRCP("RV0"))
. . S (ITEMDA,TOTAL,TOTAL1)=0 F COUNT=1:1 S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S D=$G(^(ITEMDA,0)) D
. . . S LASTONE=$$SHPERCNT^PRCPUX2(COUNT,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
. . . I D'="",$P(D,"^",6)=STORE S $P(^PRCP(445,PRCP("I"),1,ITEMDA,0),"^",6)="",TOTAL=TOTAL+1
. . . I $D(^PRCP(445,PRCP("I"),1,ITEMDA,1,STORE,0)) K ^(0) S %=$P(^PRCP(445,PRCP("I"),1,ITEMDA,1,0),"^",4)-1,TOTAL1=TOTAL1+1 I %'<0 S $P(^(0),"^",4)=%
. . D QPERCNT^PRCPUX2(+$G(LASTONE),"*",PRCP("RV1"),PRCP("RV0"))
. . W !!?10,"Total items with main storage location removed: ",TOTAL
. . W !!?10,"Total items with additional storage location removed: ",TOTAL1
Q
;
;
STORELOC(DA) ; return storage location given entry da
N Y S Y=$P($G(^PRCP(445.4,+DA,0)),"^") I Y="" S Y="?"
Q Y
;
;
STORAGE(INVPT,ITEMDA) ; return main starage location for invpt and item
Q $$STORELOC($P($G(^PRCP(445,+INVPT,1,+ITEMDA,0)),"^",6))
;
;
STORE(INVPT) ; select storage location for inventory point
N %,DIC,PRCPPRIV,X,Y
S DIC="^PRCP(445.4,",DIC("S")="I $P(^(0),U,2)="_INVPT,DIC(0)="QEAM",PRCPPRIV=1
D ^DIC
Q $S(Y'>0:0,1:+Y)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPESTO 1990 printed Sep 23, 2025@19:49:54 Page 2
PRCPESTO ;WISC/RFJ-storage locations ;23 Dec 92
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+4 NEW %,COUNT,D,D0,DA,DIDEL,PRCPPRIV,DI,DIC,DIE,DLAYGO,DQ,DR,EACHONE,ITEMDA,LASTONE,PRCPFLAG,PRCPINPT,STORE,TOTAL,TOTAL1,X,Y
+5 SET PRCPINPT=PRCP("I")
+6 FOR
Begin DoDot:1
+7 SET DIC="^PRCP(445.4,"
SET DIC("S")="I $P(^(0),U,2)=PRCP(""I"")"
SET DIC(0)="QEALM"
SET DLAYGO=445.4
SET PRCPPRIV=1
WRITE !
DO ^DIC
IF Y'>0
SET PRCPFLAG=1
QUIT
+8 SET DIE="^PRCP(445.4,"
SET DR=".01;2"
SET (STORE,DA)=+Y
SET DIDEL=445.4
DO ^DIE
+9 IF '$DATA(^PRCP(445.4,STORE,0))
Begin DoDot:2
+10 WRITE !!,"<<< Removing this storage location from all items in the inventory point"
+11 SET EACHONE=$$INPERCNT^PRCPUX2(+$PIECE($GET(^PRCP(445,PRCP("I"),1,0)),"^",4),"*",PRCP("RV1"),PRCP("RV0"))
+12 SET (ITEMDA,TOTAL,TOTAL1)=0
FOR COUNT=1:1
SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
if 'ITEMDA
QUIT
SET D=$GET(^(ITEMDA,0))
Begin DoDot:3
+13 SET LASTONE=$$SHPERCNT^PRCPUX2(COUNT,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
+14 IF D'=""
IF $PIECE(D,"^",6)=STORE
SET $PIECE(^PRCP(445,PRCP("I"),1,ITEMDA,0),"^",6)=""
SET TOTAL=TOTAL+1
+15 IF $DATA(^PRCP(445,PRCP("I"),1,ITEMDA,1,STORE,0))
KILL ^(0)
SET %=$PIECE(^PRCP(445,PRCP("I"),1,ITEMDA,1,0),"^",4)-1
SET TOTAL1=TOTAL1+1
IF %'<0
SET $PIECE(^(0),"^",4)=%
End DoDot:3
+16 DO QPERCNT^PRCPUX2(+$GET(LASTONE),"*",PRCP("RV1"),PRCP("RV0"))
+17 WRITE !!?10,"Total items with main storage location removed: ",TOTAL
+18 WRITE !!?10,"Total items with additional storage location removed: ",TOTAL1
End DoDot:2
End DoDot:1
if $GET(PRCPFLAG)
QUIT
+19 QUIT
+20 ;
+21 ;
STORELOC(DA) ; return storage location given entry da
+1 NEW Y
SET Y=$PIECE($GET(^PRCP(445.4,+DA,0)),"^")
IF Y=""
SET Y="?"
+2 QUIT Y
+3 ;
+4 ;
STORAGE(INVPT,ITEMDA) ; return main starage location for invpt and item
+1 QUIT $$STORELOC($PIECE($GET(^PRCP(445,+INVPT,1,+ITEMDA,0)),"^",6))
+2 ;
+3 ;
STORE(INVPT) ; select storage location for inventory point
+1 NEW %,DIC,PRCPPRIV,X,Y
+2 SET DIC="^PRCP(445.4,"
SET DIC("S")="I $P(^(0),U,2)="_INVPT
SET DIC(0)="QEAM"
SET PRCPPRIV=1
+3 DO ^DIC
+4 QUIT $SELECT(Y'>0:0,1:+Y)
