source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPECPP.m@ 1093

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

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