PRCPESTO.m

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 ---PRCPESTO   1990     printed  Apr 09, 2024@21:00:33                                                                                                                                                                                                    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)