source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPESTO.m@ 897

Last change on this file since 897 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 1.9 KB
Line 
1PRCPESTO ;WISC/RFJ-storage locations ;23 Dec 92
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 D ^PRCPUSEL Q:'$G(PRCP("I"))
5 N %,COUNT,D,D0,DA,DIDEL,PRCPPRIV,DI,DIC,DIE,DLAYGO,DQ,DR,EACHONE,ITEMDA,LASTONE,PRCPFLAG,PRCPINPT,STORE,TOTAL,TOTAL1,X,Y
6 S PRCPINPT=PRCP("I")
7 F D Q:$G(PRCPFLAG)
8 . 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
9 . S DIE="^PRCP(445.4,",DR=".01;2",(STORE,DA)=+Y,DIDEL=445.4 D ^DIE
10 . I '$D(^PRCP(445.4,STORE,0)) D
11 . . W !!,"<<< Removing this storage location from all items in the inventory point"
12 . . S EACHONE=$$INPERCNT^PRCPUX2(+$P($G(^PRCP(445,PRCP("I"),1,0)),"^",4),"*",PRCP("RV1"),PRCP("RV0"))
13 . . 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
14 . . . S LASTONE=$$SHPERCNT^PRCPUX2(COUNT,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
15 . . . I D'="",$P(D,"^",6)=STORE S $P(^PRCP(445,PRCP("I"),1,ITEMDA,0),"^",6)="",TOTAL=TOTAL+1
16 . . . 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)=%
17 . . D QPERCNT^PRCPUX2(+$G(LASTONE),"*",PRCP("RV1"),PRCP("RV0"))
18 . . W !!?10,"Total items with main storage location removed: ",TOTAL
19 . . W !!?10,"Total items with additional storage location removed: ",TOTAL1
20 Q
21 ;
22 ;
23STORELOC(DA) ; return storage location given entry da
24 N Y S Y=$P($G(^PRCP(445.4,+DA,0)),"^") I Y="" S Y="?"
25 Q Y
26 ;
27 ;
28STORAGE(INVPT,ITEMDA) ; return main starage location for invpt and item
29 Q $$STORELOC($P($G(^PRCP(445,+INVPT,1,+ITEMDA,0)),"^",6))
30 ;
31 ;
32STORE(INVPT) ; select storage location for inventory point
33 N %,DIC,PRCPPRIV,X,Y
34 S DIC="^PRCP(445.4,",DIC("S")="I $P(^(0),U,2)="_INVPT,DIC(0)="QEAM",PRCPPRIV=1
35 D ^DIC
36 Q $S(Y'>0:0,1:+Y)
Note: See TracBrowser for help on using the repository browser.