source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPECPS.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 5.3 KB
Line 
1PRCPECPS ;WISC/RFJ-copy items from secondary to secondary;1/4/99 1440
2V ;;5.1;IFCAP;**1**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 D ^PRCPUSEL Q:'$G(PRCP("I"))
5 ;
6 I PRCP("DPTYPE")'="P" D Q
7 . W !,"THIS OPTION SHOULD ONLY BE USED BY A PRIMARY INVENTORY POINT."
8 ;
9 N A,D0,DA,DATA,DELETE,DI,DIC,DIE,DQ,DR,EACHONE,ITEMCNT,ITEMDA
10 N LASTONE,NUMBER,PIECE,PRCPINFR,PRCPINTO,PRCPFLVL,PRCPNL,PRCPSENT,VENDOR,X,Y,PRCPXX
11 ;
12ASKFROM ; ask inventory point to copy from
13 K X S X(1)="Select the SECONDARY inventory point to copy FROM."
14 W ! D DISPLAY^PRCPUX2(1,40,.X)
15 S PRCPINFR=$$TO^PRCPUDPT(PRCP("I")) I 'PRCPINFR Q
16 S ITEMCNT=+$P($G(^PRCP(445,PRCPINFR,1,0)),"^",4) I 'ITEMCNT D G ASKFROM
17 . K X S X(1)="ERROR: THERE ARE NO ITEMS STORED IN THE INVENTORY POINT TO COPY."
18 . D DISPLAY^PRCPUX2(5,75,.X)
19 ;
20 W !?5,"Number of items currently stored: ",ITEMCNT
21 ;
22 ;
23ASKTO ; ask inventory point to copy to
24 K X S X(1)="Select the SECONDARY inventory point to copy TO."
25 W ! D DISPLAY^PRCPUX2(1,40,.X)
26 S PRCPINTO=$$TO^PRCPUDPT(PRCP("I")) I 'PRCPINTO Q
27 ;
28 I PRCPINFR=PRCPINTO D G ASKTO
29 . K X
30 . S X(1)="ERROR: YOU CANNOT COPY ITEMS INTO THE SAME INVENTORY POINT."
31 . D DISPLAY^PRCPUX2(5,75,.X)
32 ;
33 I $P($G(^PRCP(445,PRCPINTO,0)),"^",2)="Y" D G ASKTO
34 . K X S X(1)="ERROR: THE SECONDARY INVENTORY POINT BEING COPIED TO CANNOT BE KEEPING A PERPETUAL INVENTORY."
35 . D DISPLAY^PRCPUX2(5,75,.X)
36 ;
37 I '$D(^PRCP(445,PRCPINTO,4,DUZ)) D G ASKTO
38 . K X S X(1)="ERROR: YOU ARE NOT AN AUTHORIZED USER FOR THIS INVENTORY POINT."
39 . D DISPLAY^PRCPUX2(5,75,.X)
40 ;
41 L +^PRCP(445,PRCPINTO,1):5 I '$T D SHOWWHO^PRCPULOC(445,PRCPINTO_"-1",0) Q
42 D ADD^PRCPULOC(445,PRCPINTO_"-1",0,"Item copying")
43 S ITEMCNT=+$P($G(^PRCP(445,PRCPINTO,1,0)),"^",4)
44 W !?5,"Number of items currently stored: ",ITEMCNT
45 S DELETE=0
46 I ITEMCNT D I 'DELETE G EXIT
47 . I $$ORDCHK^PRCPUITM(0,PRCPINTO,"RCE","") D S DELETE=2 QUIT
48 . . W !,$$INVNAME^PRCPUX1(PRCPINTO)," has outstanding orders. You may overwrite"
49 . . W !,"but cannot delete items already stored here."
50 . I DELETE=2 QUIT
51 . S XP="Since there are already items stored in the secondary inventory point you",XP(1)="are copying TO, do you want to delete ALL items before making the copy"
52 . S XH="Enter YES to remove ALL items from "_$$INVNAME^PRCPUX1(PRCPINTO)_".",XH(1)="Enter NO to OVERWRITE items currently stored in the inventory point.",XH(2)="Enter ^ to exit."
53 . W ! S DELETE=$$YN^PRCPUYN(2)
54 ;
55 ;
56 S PRCPFLVL=0
57 S XP="Do you want to copy the stock levels and reorder points"
58 S XH="Enter YES to copy the normal stock level, emergency stock level, standard"
59 S XH(1)="reorder point, and optional reorder point."
60 W ! I $$YN^PRCPUYN(2)=1 S PRCPFLVL=1
61 ;
62 K X S X(1)="Copying from: "_$$INVNAME^PRCPUX1(PRCPINFR)_" to: "_$$INVNAME^PRCPUX1(PRCPINTO)
63 W !! D DISPLAY^PRCPUX2(5,75,.X)
64 S XP="Are you sure you want to copy the items"
65 S XH="Enter YES to start copying the items, NO or ^ to exit."
66 I $$YN^PRCPUYN(2)'=1 G EXIT
67 ;
68 I $G(DELETE)=1 D
69 . W !!,"Deleting Items. . . ."
70 . ; S EACHONE=$$INPERCNT^PRCPUX2(ITEMCNT,"*",PRCP("RV1"),PRCP("RV0"))
71 . S ITEMDA=0
72 . F NUMBER=1:1 S ITEMDA=$O(^PRCP(445,PRCPINTO,1,ITEMDA)) Q:'ITEMDA D
73 . . D DELITEM^PRCPUITM(PRCPINTO,ITEMDA)
74 . . ; S LASTONE=$$SHPERCNT^PRCPUX2(NUMBER,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
75 . ; D QPERCNT^PRCPUX2(+$G(LASTONE),"*",PRCP("RV1"),PRCP("RV0"))
76 . W !,"Deletions complete",!
77 ;
78 W !!!,"Copying Items. . . ."
79 ; S EACHONE=$$INPERCNT^PRCPUX2(+$P($G(^PRCP(445,PRCPINFR,1,0)),"^",4),"*",PRCP("RV1"),PRCP("RV0"))
80 I '$D(^PRCP(445,PRCPINTO,1,0)) S ^(0)="^445.01IP^^"
81 S ITEMDA=0
82 F NUMBER=1:1 S ITEMDA=$O(^PRCP(445,PRCPINFR,1,ITEMDA)) Q:'ITEMDA S DATA=$G(^(ITEMDA,0)) I DATA'="" D
83 . ; S LASTONE=$$SHPERCNT^PRCPUX2(NUMBER,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
84 . I '$D(^PRCP(445,PRCPINTO,1,ITEMDA,0)) D ADDITEM(PRCPINTO,ITEMDA)
85 . I '$D(^PRCP(445,PRCPINTO,1,ITEMDA,0)) Q
86 . I $G(PRCPFLVL)>0 S PRCPNL=+$P(^PRCP(445,PRCPINTO,1,ITEMDA,0),"^",9)
87 . S DR="" F PIECE=5,14,15 I $P(DATA,"^",PIECE)'="" S DR=DR_$S(PIECE=5:4,PIECE=14:4.5,PIECE=15:4.7,1:PIECE)_"////"_$P(DATA,"^",PIECE)_";"
88 . I $G(PRCPFLVL)>0 F PIECE=4,9,10,11 I $P(DATA,"^",PIECE)'="" S DR=DR_$S(PIECE=4:10.3,1:PIECE)_"////"_$P(DATA,"^",PIECE)_";"
89 . I $P($G(^PRCP(445,PRCPINFR,1,ITEMDA,6)),"^")'="" S PRCPXX=$P(^(6),"^"),DR=DR_".7////^S X=PRCPXX"
90 . S (DIC,DIE)="^PRCP(445,"_PRCPINTO_",1,"
91 . S DA(1)=PRCPINTO,DA=ITEMDA
92 . D ^DIE
93 . S VENDOR=$$GETVEN^PRCPUVEN(PRCPINFR,ITEMDA,PRCP("I")_";PRCP(445,","")
94 . D ADDVEN^PRCPUVEN(PRCPINTO,ITEMDA,PRCP("I")_";PRCP(445,",$P(VENDOR,"^",2),$P(VENDOR,"^",3),$P(VENDOR,"^",4))
95 . I $P(DATA,"^",12)'="" D
96 . . S $P(^PRCP(445,PRCPINTO,1,ITEMDA,0),"^",12)=$P(DATA,"^",12)
97 . . S ^PRCP(445,PRCPINTO,1,"AC",$P(DATA,"^",12),ITEMDA)=""
98 . S PRCPSENT=0
99 . I $G(PRCPFLVL)>0,PRCPNL=0,$P(DATA,"^",9)>0 D
100 . . D BLDSEG^PRCPHLFM(1,ITEMDA,PRCPINTO) ; send transaction to supply station
101 . . S PRCPSENT=1
102 . I 'PRCPSENT,$P(^PRCP(445,PRCPINTO,1,ITEMDA,0),"^",9)>0 D BLDSEG^PRCPHLFM(3,ITEMDA,PRCPINTO) ; send item info to supply station
103 ; D QPERCNT^PRCPUX2(+$G(LASTONE),"*",PRCP("RV1"),PRCP("RV0"))
104 ;
105 W !!,"Copy Completed !"
106EXIT D CLEAR^PRCPULOC(445,PRCPINTO_"-1",0)
107 L -^PRCP(445,PRCPINTO,1)
108 Q
109 ;
110 ;
111ADDITEM(INVPT,ITEMDA) ; automatically adds item to inventory point
112 N DD,D0,DIC,DLAYGO,DA,DINUM,X,Y
113 S DIC="^PRCP(445,"_INVPT_",1,"
114 S DIC(0)="L",DLAYGO=445
115 S DA(1)=INVPT
116 S (X,DINUM)=ITEMDA
117 D FILE^DICN
118 Q
Note: See TracBrowser for help on using the repository browser.