source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPCSP.m@ 810

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

initial load of WorldVistAEHR

File size: 1.9 KB
RevLine 
[613]1PRCPCSP ;WISC/RFJ/DXH - convert secondary to primary ;9.9.99
2V ;;5.1;IFCAP;**1**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; prcpflvl=1 => accept existing stock levels for some or all
6 ;
7EN D ^PRCPUSEL Q:'$G(PRCP("I"))
8 I PRCP("DPTYPE")'="P" W !,"THIS OPTION SHOULD ONLY BE USED FROM WITHIN A PRIMARY INVENTORY POINT." Q
9 ;
10 N D0,DA,DATA,DELETE,DI,DIC,DIE,DIR,DQ,DR,EACHONE,ESCAPE,ITEMCNT,ITEMDA
11 N IMFDATA,INVPT,IPVND,LASTONE,NUMBER,PIECE,PRIM,PRCPINPT,PRCPITEM
12 N PRCPTYPE,UP,UR,VENDA,VENDATA,VENDOR,XH,XP
13ASKNP ; ask for secondary inventory point to be converted
14 S PRIM=$$INVNAME^PRCPUX1(PRCP("I"))
15 K X
16 S X(1)="Select the SECONDARY inventory point to CONVERT."
17 S X(2)="It must be one of the DISTRIBUTION POINTS for "_PRIM_"."
18 W ! D DISPLAY^PRCPUX2(1,60,.X)
19 S INVPT=$$TO^PRCPUDPT(PRCP("I")) I 'INVPT Q
20 I '$D(^PRCP(445,INVPT,4,DUZ)) D G ASKNP
21 . K X
22 . S X(1)="ERROR: You are not an authorized user for this inventory point."
23 . D DISPLAY^PRCPUX2(5,75,.X)
24 S ITEMCNT=+$P($G(^PRCP(445,INVPT,1,0)),"^",4)
25 I 'ITEMCNT,'$O(^PRCP(445,INVPT,1,0)) D Q:$G(ESCAPE)
26 . K X
27 . S X(1)="There are no items stored in the selected secondary inventory point."
28 . S X(2)="Data base unchanged."
29 . S ESCAPE=1
30 . D DISPLAY^PRCPUX2(5,75,.X)
31 I $P($G(^PRCP(445,INVPT,5)),"^",1)]"" D QUIT
32 . K X
33 . S X(1)="This inventory point is linked to a supply station and cannot be converted."
34 . D DISPLAY^PRCPUX2(5,75,.X)
35 W !!?5,"Number of items currently stored: ",ITEMCNT
36 W !! K X
37 S X(1)="Existing PROCUREMENT and MANDATORY SOURCES for this secondary"
38 S X(2)="will be replaced with data taken from its supplying primary"
39 S X(3)="("_PRIM_") during the conversion. You can change these data"
40 S X(4)="later if you need to."
41 D DISPLAY^PRCPUX2(20,75,.X)
42 ;
43 D CONVRT^PRCPCSP1
44 Q
45 ;
46HOLD ; can get here only from a crt
47 W !,"Press <RETURN> to continue, '^' to escape..." R X:DTIME
48 I '$T!($E(X)="^") S ESCAPE=1
49 Q
50 ;PRCPCSP
Note: See TracBrowser for help on using the repository browser.