source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPCSPX.m@ 1078

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

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1PRCPCSPX ;WISC/DXH - undo secondary to primary conversion ;10.7.99
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; expects prcp("i") as ien of inv pt to be undone
6EN ;
7 N D0,DA,DATA,DI,DIC,DIE,DIR,DQ,DR,EACHONE,ITEMCNT,ITEMDA,LASTONE,NUMBER,PIECE,INVPT,VENDOR,X,Y,XP,XH,ESCAPE,PRIM,VENDA,VENDATA,STKDBY,FCPDA,NODEDA
8 S PRIM=$$INVNAME^PRCPUX1(PRCP("I"))
9 I '$D(^PRCP(445,PRCP("I"),"SEC")) W !!,"Inventory Point "_PRIM_" was never converted.",!,"Data base unchanged.",*7 D HOLD Q
10 S PRC=^PRCP(445,PRCP("I"),"SEC"),USER=$P(PRC,"|",2),DATE=$P(PRC,"|",3),NODE=$P(PRC,"|"),STCKDBY=$P(PRC,"|",4)
11 I USER,$G(^VA(200,USER,0))]"" S USERNM=$$GET1^DIQ(200,USER,.01)
12 I $G(USERNM)]"" D
13 . I DATE S Y=DATE X ^DD("DD") S DATEXT=Y
14 . W !!,"Inventory Point "_PRIM_" was converted to a primary by "
15 . W !,USERNM W:$G(DATEXT)]"" " on "_DATEXT W "."
16 S DA=0 F S DA=$O(^PRCP(445,PRCP("I"),1,DA)) Q:$G(ESCAPE)!('DA) D
17 . I $O(^PRCP(445,PRCP("I"),1,DA,7,0)) S ESCAPE=1
18 I $G(ESCAPE) W !!,"Inventory Point "_PRIM_" has at least one OUTSTANDING REQUEST",!,"It can not be converted and the data base remains unchanged.",*7 D HOLD Q
19 W !! K X S X(1)="This option will change "_PRIM_" from a primary to a secondary.",X(2)="INVENTORY PARAMETERS, STOCK LEVELS, MANDATORY SOURCES, and PROCUREMENT SOURCES"
20 S X(3)="will be restored to whatever they were when this Inventory Point was converted"
21 I $G(DATEXT)]"" S X(4)="on "_DATEXT_"."
22 E S X(3)=X(3)_"."
23 D DISPLAY^PRCPUX2(10,75,.X)
24 W !!,"Preparing to convert "_PRIM_" back to a secondary."
25 K XP,XH S XP="Are you sure you want to do that",XH="Enter 'YES' to start the conversion, NO or '^' to escape."
26 I $$YN^PRCPUYN(2)'=1 Q
27 ;
28CONVRT W !!!?20,"Converting "_PRIM_"."
29 S EACHONE=$$INPERCNT^PRCPUX2(+$P($G(^PRCP(445,PRCP("I"),1,0)),U,4),"*",PRCP("RV1"),PRCP("RV0"))
30 S DIE="^PRCP(445,",DA=PRCP("I"),DR=".7///^S X=""S""" D ^DIE K DR
31 S ^PRCP(445,PRCP("I"),0)=NODE ; it's a secondary again
32 K ^PRCP(445,PRCP("I"),1,"AC") ; existing x-ref won't work for secondary
33 S ITEMDA=0 F NUMBER=1:1 S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA I $G(^(ITEMDA,0))'="" D
34 . S LASTONE=$$SHPERCNT^PRCPUX2(NUMBER,EACHONE,"*",PRCP("RV1"),PRCP("RV0"))
35 . I '$D(^PRCP(445,PRCP("I"),"SECITM",ITEMDA)) D Q
36 .. ; delete line items added since conversion
37 .. S DIK="^PRCP(445,"_PRCP("I")_",1,",DA(1)=PRCP("I"),DA=ITEMDA
38 .. D ^DIK K DIK
39 . K ^PRCP(445,PRCP("I"),1,ITEMDA,5) ; won't work for secondary
40 . S ^PRCP(445,PRCP("I"),1,ITEMDA,0)=^PRCP(445,PRCP("I"),"SECITM",ITEMDA,0)
41 . S %X="^PRCP(445,"_PRCP("I")_",""SECITM"","_ITEMDA_",5,",%Y="^PRCP(445,"_PRCP("I")_",1,"_ITEMDA_",5," D %XY^%RCR
42 . ; x-ref by mandatory source
43 . I $P(^PRCP(445,PRCP("I"),1,ITEMDA,0),U,12)]"" S DA=ITEMDA,DA(1)=PRCP("I"),DIK="^PRCP(445,"_PRCP("I")_",1,",DIK(1)=.4 D EN1^DIK K DIK
44 ; restore mis costing
45 I $D(^PRCP(445,PRCP("I"),"SECMIS")) K ^PRCP(445,PRCP("I"),3) S %X="^PRCP(445,"_PRCP("I")_",""SECMIS"",",%Y="^PRCP(445,"_PRCP("I")_",3," D %XY^%RCR
46 ; restore prcp(i) as distribution point for stckdby
47 I $G(STCKDBY) D
48 . N DIC,DA,DD,DO,DLAYGO,DINUM
49 . S DIC="^PRCP(445,"_STCKDBY_",2,",DIC(0)="L",DA(1)=STCKDBY,(X,DINUM)=PRCP("I"),DIC("P")=$P(^DD(445.03,.01,0),U,2),DLAYGO=445
50 . D FILE^DICN
51 ; delete any dist points
52 I $D(^PRCP(445,PRCP("I"),2)) D K DIK
53 . N DA
54 . S DIK="^PRCP(445,PRCP(""I""),2,",DA(1)=PRCP("I"),DA=0
55 . F S DA=$O(^PRCP(445,PRCP("I"),2,DA)) Q:'DA D ^DIK
56 S PRCP("DPTYPE")="S" ; just like in the old days
57 ; unlink fcp(s)
58FCP S FCPDA=0 F S FCPDA=$O(^PRC(420,"AE",PRC("SITE"),PRCP("I"),FCPDA)) Q:'FCPDA D DEL^PRCPUFCP(FCPDA,PRCP("I"))
59 ; destroy the evidence
60 F NODEDA="SEC","SECITM","SECMIS" K ^PRCP(445,PRCP("I"),NODEDA)
61 D HOLD
62 Q
63 ;
64HOLD ; can get here only from a crt
65 W !!,"Press <RETURN> to continue..." R X:DTIME
66 I '$T!($E(X)="^") S ESCAPE=1
67 Q
68 ;PRCPCSPX
Note: See TracBrowser for help on using the repository browser.