source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPCSP1.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1PRCPCSP1 ;WISC/RFJ/DXH - convert secondary to primary ;10.14.99
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5CONVRT W !!,"Preparing to convert: "_$$INVNAME^PRCPUX1(INVPT)_" to a primary."
6 K XP,XH S XP="Are you sure this is what you want to do",XH="Enter YES to start converting, NO or ^ to exit."
7 I $$YN^PRCPUYN(2)'=1 S ESCAPE=1 Q
8 ;
9 L +^PRCP(445,INVPT):5 I '$T W !,"Sorry, another user is editing this inventory point. Please try again later." S ESCAPE=1 Q
10 ; store some data in case user decides to 'undo' conversion
11 S ^PRCP(445,INVPT,"SEC")=^PRCP(445,INVPT,0)_"|"_$G(DUZ)_"|"_$G(DT)_"|"_PRCP("I")
12 I $O(^PRCP(445,INVPT,3,0)) S %X="^PRCP(445,"_INVPT_",3,",%Y="^PRCP(445,"_INVPT_",""SECMIS""," D %XY^%RCR ; mis costing sections
13 S DIE="^PRCP(445,",DA=INVPT
14 S DR=".5;.6;.9" D ^DIE K DR I $D(DTOUT)!($D(Y)) D L -^PRCP(445,INVPT) Q
15 . I $D(DTOUT) W *7,!,"You have timed out "
16 . E W *7,!,"You have escaped "
17 . W "and may need to edit this inventory point using the"
18 . W !,"'Enter/Edit Inventory and Distribution Points' option under 'Secondary",!,"Inventory Point Main Menu' to restore order."
19 . W ! D HOLD K ^PRCP(445,INVPT,"SEC"),^("SECMIS")
20 S DR=".7///^S X=""P""" D ^DIE K DR
21 S DIK="^PRCP(445,"_PRCP("I")_",2,",DA(1)=PRCP("I"),DA=INVPT D ^DIK K DIK ; remove the secondary as a distribution point
22 K ^PRCP(445,INVPT,1,"AC") ; sub-file x-ref on mand source
23 S PRCPINPT=INVPT,PRCPTYPE="P",PRCP("CONVRT")=1 D FCP^PRCPENE1
24 ;
25ITEMS W !!!?30,"Converting Items"
26 S EACHONE=$$INPERCNT^PRCPUX2(+$P($G(^PRCP(445,INVPT,1,0)),"^",4),"*",PRCP("RV1"),PRCP("RV0"))
27 S ITEMDA=0 F NUMBER=1:1 S ITEMDA=$O(^PRCP(445,INVPT,1,ITEMDA)) Q:'ITEMDA S DATA=$G(^(ITEMDA,0)) I DATA'="" D Q:$G(ESCAPE) D IPVND Q:$G(ESCAPE)
28 . S LASTONE=$$SHPERCNT^PRCPUX2(NUMBER,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
29 . S ^PRCP(445,INVPT,"SECITM",ITEMDA,0)=$G(^PRCP(445,INVPT,1,ITEMDA,0))
30 . S %X="^PRCP(445,"_INVPT_",1,"_ITEMDA_",5,",%Y="^PRCP(445,"_INVPT_",""SECITM"","_ITEMDA_",5," D %XY^%RCR
31 . K ^PRCP(445,INVPT,1,ITEMDA,5) ; clear data that may not be overwritten
32 . ; by conversion process
33 . S $P(^PRCP(445,INVPT,1,ITEMDA,0),U,12)=$P($G(^PRCP(445,PRCP("I"),1,ITEMDA,0)),U,12) ; mandatory source from prcp("i")
34 . I $P(^PRCP(445,INVPT,1,ITEMDA,0),U,12) D
35 .. S DA=ITEMDA,DA(1)=INVPT,DIK="^PRCP(445,"_DA(1)_",1,",DIK(1)=".4"
36 .. D EN1^DIK K DIK ; re-xref by mand source
37 . I $O(^PRCP(445,PRCP("I"),1,ITEMDA,5,0)) S %X="^PRCP(445,"_PRCP("I")_",1,"_ITEMDA_",5,",%Y="^PRCP(445,"_INVPT_",1,"_ITEMDA_",5," D %XY^%RCR D D MNDSRC Q
38 .. S VENDA=0 F S VENDA=$O(^PRCP(445,INVPT,1,ITEMDA,5,VENDA)) Q:'VENDA S DATA=^(VENDA,0),VENDATA=$G(^PRC(441,ITEMDA,2,VENDA,0)) D
39 ... S UP=$$UNITVAL^PRCPUX1($P(VENDATA,U,8),$P(VENDATA,U,7),""),UR=$$UNITVAL^PRCPUX1($P(DATA,U,3),$P(DATA,U,2),"")
40 ... I UP'=UR,UP'["?" S $P(DATA,U,3)=$P(VENDATA,U,8),$P(DATA,U,2)=$P(VENDATA,U,7)
41 ... I '$P(DATA,U,4) S PRC=$P($G(^PRCP(445,INVPT,1,ITEMDA,0)),U,14) S:PRC="" PRC=1 S $P(DATA,U,4)=($P(DATA,U,3)/PRC)\1 S:'$P(DATA,U,4) $P(DATA,U,4)=1
42 ... S ^PRCP(445,INVPT,1,ITEMDA,5,VENDA,0)=DATA
43 . ;
44 . ; will have to go to the item master
45 . S VENDA=$P($G(^PRC(441,ITEMDA,0)),U,8) I VENDA S $P(^PRCP(445,INVPT,1,ITEMDA,0),U,12)=VENDA_";PRC(440,",VENDATA=$G(^PRC(441,ITEMDA,2,VENDA,0)) D S ESCAPE=1 Q
46 .. D ADDVEN^PRCPUVEN(INVPT,ITEMDA,VENDA_";PRC(440,",$P(VENDATA,U,7),$P(VENDATA,U,8),$P(VENDATA,U,10))
47 .. S DA=ITEMDA,DA(1)=INVPT,DIK="^PRCP(445,"_DA(1)_",1,",DIK(1)=.4 D EN1^DIK K DIK ; x-ref new mandatory source
48 . S VENDA=0 F S VENDA=$O(^PRC(441,ITEMDA,2,VENDA)) Q:'VENDA S VENDATA=$G(^PRC(441,ITEMDA,2,VENDA,0)) D
49 .. D ADDVEN^PRCPUVEN(INVPT,ITEMDA,VENDA_";PRC(440,",$P(VENDATA,U,7),$P(VENDATA,U,8),$P(VENDATA,U,10))
50 ;
51LEVELS ; change the stock levels?
52 W ! S DIR(0)="Y",DIR("A")="Would you like to edit item levels and/or mandatory source",DIR("B")="NO"
53 S DIR("?",1)="Enter 'YES' if you would like to edit the NORMAL STOCK LEVEL, EMERGENCY"
54 S DIR("?",2)="STOCK LEVEL, TEMPORARY STOCK LEVEL, STANDARD REORDER POINT, OPTIONAL REORDER"
55 S DIR("?",3)="POINT, and/or MANDATORY SOURCE for some or all of the items in this"
56 S DIR("?")="inventory point."
57 D ^DIR K DIR I $D(DIRUT) Q
58 I 'Y W !!,"Conversion Completed !" Q ; leave everything as it was when inventory point was secondary
59 ;
60 ; can either step thru the inventory point or prompt for lookups
61 ;
62 S DIR(0)="SOM^1:Prompt for ITEMS that may need changes;2:Display all ITEMS and prompt for changes",DIR("A")="How shall items be presented? "
63 S DIR("B")="1"
64 S DIR("?",1)="Enter '2' if you want the system to step through the inventory point and"
65 S DIR("?")="prompt you for changes to all of the items."
66 D ^DIR K DIR Q:$D(DIRUT)
67 S DIE="^PRCP(445,",DR="[PRCP LEVELS]"
68 I Y=2 D W !!?10,"<Done>" D HOLD Q ; step thru inventory point
69 . S ITEMDA=0 F D:ITEMDA HOLD S ITEMDA=$O(^PRCP(445,INVPT,1,ITEMDA)) Q:'ITEMDA!($G(ESCAPE)) I $D(^(ITEMDA,0)) D EDIT Q:$G(ESCAPE)
70 ; prompt for user lookups
71 S DIC("S")="I $D(^PRCP(445,INVPT,1,+Y,0))"
72 F W !! S DIC="^PRCP(445,"_INVPT_",1,",DIC(0)="AEQM" D ^DIC Q:Y'>0 S ITEMDA=+Y D EDIT Q:$G(ESCAPE)
73 W !!?10,"<Done>" D HOLD
74 Q ; end user lookups
75 ;
76EDIT ; edit stock levels
77 W !!,"ITEM MASTER #: "_ITEMDA,?30,$E($P($G(^PRCP(445,INVPT,1,ITEMDA,6)),U),1,50)
78 W ! S DA=INVPT,PRCPITEM=$C(96)_ITEMDA
79 D ^DIE I $D(DTOUT) S ESCAPE=1
80 Q
81 ;
82IPVND ; add old 'stocked by' inv pt as vendor if appropriate
83 ; try to find it in the vendor file
84 S PRIM(0)=$P(PRIM,"-",2) S IPVND("DA")=$O(^PRC(440,"B",PRIM(0),0)) I '$G(IPVND("DA")) S IPVND("DA")=$O(^PRC(440,"C",PRIM(0),0))
85 Q:'$G(IPVND("DA")) S PRCP("DA")=0 F S PRCP("DA")=$O(^PRCP(445,INVPT,"SECITM",ITEMDA,5,PRCP("DA"))) Q:'PRCP("DA")!(+^PRCP(445,INVPT,"SECITM",ITEMDA,5,PRCP("DA"),0)=PRCP("I"))
86 D:PRCP("DA") ; if it's there, add it
87 . S DATA=$G(^PRCP(445,INVPT,"SECITM",ITEMDA,5,PRCP("DA"),0))
88 . D ADDVEN^PRCPUVEN(INVPT,ITEMDA,IPVND("DA")_";PRC(440,",$P(DATA,U,2),$P(DATA,U,3),$P(DATA,U,4))
89 . I '$D(^PRC(441,ITEMDA,2,"B",IPVND("DA"),0)) D
90 .. N DIC,DA,DLAYGO,DD,DO,DINUM
91 .. S DIC="^PRC(441,ITEMDA,2,",(X,DINUM)=IPVND("DA"),DA(1)=ITEMDA,DIC(0)="L",DLAYGO=441,DIC("P")=$P(^DD(441,6,0),U,2)
92 .. D FILE^DICN
93 Q
94 ;
95MNDSRC ; look for mand srce in imf if not picked up from prcp("i")
96 Q:$P(^PRCP(445,INVPT,1,ITEMDA,0),U,12)]"" ; already have it
97 S PRCP("MS")=$P($G(^PRC(441,ITEMDA,0)),U,8)_";PRC(440,"
98 I +PRCP("MS"),('$D(^PRCP(445,INVPT,1,ITEMDA,5,"B",PRCP("MS")))) D
99 . S IMFDATA=$G(^PRC(441,ITEMDA,2,+PRCP("MS"),0))
100 . D ADDVEN^PRCPUVEN(INVPT,ITEMDA,PRCP("MS"),$P(IMFDATA,U,7),$P(IMFDATA,U,8),$P(IMFDATA,U,10))
101 I +PRCP("MS") S $P(^PRCP(445,INVPT,1,ITEMDA,0),U,12)=PRCP("MS"),DA=ITEMDA,DA(1)=INVPT,DIK="^PRCP(445,"_DA(1)_",1,",DIK(1)=.4 D EN1^DIK K DIK ; set mand srce and x-ref
102 Q
103 ;
104HOLD W !!,"Press <RETURN> to continue, '^' to escape..." R X:DTIME
105 I '$T!($E(X)="^") S ESCAPE=1
106 Q
107 ;PRCPCSP1
Note: See TracBrowser for help on using the repository browser.