source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPUINV.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: 4.6 KB
Line 
1PRCPUINV ;WISC/RFJ/DGL-inventory point selection ; 9/20/06 11:04am
2V ;;5.1;IFCAP;**1,98**;Oct 20, 2000;Build 37
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 Q
5 ;
6 ;
7INVPT(PRCPSITE,PRCPTYPE,ADDNEW,PRCPUSER,DEFAULT) ; select inventory point
8 ; prcptype=w or p or s
9 ; addnew =1 to add new inventory points
10 ; prcpuser=1 to screen and set user
11 ; default =default inventory point
12 ; return da; 0 no item selected; ^ for ^ entered or timeout
13 I 'PRCPSITE!("WPS"'[PRCPTYPE) Q ""
14 N %,D0,DA,DI,DIE,DG,DIC,DISYS,DLAYGO,DQ,DR,PRC,PRCPPRIV,X,Y
15 S PRC("SITE")=PRCPSITE
16 ; do not allow adding new entries for whse if defined
17 I PRCPTYPE="W" F %=0:0 S %=$O(^PRCP(445,"AC","W",%)) Q:'% I +$G(^PRCP(445,%,0))=PRCPSITE S ADDNEW=0 Q
18 S DIC="^PRCP(445,",DIC(0)="QEAM",DIC("A")="Select a '"_$S(PRCPTYPE="W":"Warehouse",PRCPTYPE="P":"Primary",1:"Secondary")_"' Type Inventory Point: "
19 I DEFAULT'="" S DIC("B")=DEFAULT
20 I ADDNEW S DIC(0)="QEALM",DLAYGO=445,DIC("DR")=".8;.7///"_PRCPTYPE_";.5//"_$S(PRCPTYPE="S":"NO",1:"YES")_";.6//"_$S(PRCPTYPE="S":"NO",1:"YES")_";"_$S(PRCPTYPE="S":"",1:".9;")
21 S DIC("S")="I +^(0)=PRCPSITE,$P(^(0),U,3)=PRCPTYPE"_$S(PRCPUSER:",$D(^PRCP(445,+Y,4,+$G(DUZ),0))",1:""),PRCPPRIV=1
22 W ! D ^DIC
23 ; if new entry added, add authorized user
24 I $P(Y,"^",3),$G(DUZ),PRCPUSER D
25 . D ADDUSER^PRCPXTRM(+Y,DUZ)
26 . W !?2,"TYPE OF INVENTORY POINT: ",$S(PRCPTYPE="W":"WAREHOUSE",PRCPTYPE="P":"PRIMARY",1:"SECONDARY")
27 Q $S($G(DUOUT):"^",$G(DTOUT):"^",Y<1:0,1:+Y)
28 ;
29 ;
30TYPE ; called from 445,.7 input transform. you cannot have
31 ; multiple warehouses with the same station number
32 N STATION,%
33 S STATION=+$G(^PRCP(445,DA,0)),%=0
34 F S %=$O(^PRCP(445,"AC","W",%)) Q:'% I %'=DA,+$G(^PRCP(445,%,0))=STATION W !?2,"YOU CANNOT HAVE MULTIPLE WAREHOUSES WITH THE SAME STATION NUMBER." K X Q
35 Q
36 ;
37 ;
38KILL(INVPT) ; update all pointers when deleting an inventory point
39 ; (invoked from 'DEL' node in .01 field of file 445)
40 ;
41 N %,DATA,NAME,OUTORD,X
42 S XP(1)="You cannot delete inventory points after they are created."
43 S XP(2)="This action removes all the items, distribution points, users,"
44 S XP(3)="etc., for the inventory point and changes the name to"
45 S XP(4)="STATIONNUMBER-'***INACTIVE_#***' where # is the internal entry number."
46 S XP="",XP(5)="",XP(6)=" ARE YOU SURE YOU WANT TO PROCEED"
47 I $$YN^PRCPUYN(2)'=1 Q
48 ;
49 ; quit if this inventory point has outstanding distribution orders
50 S DATA=$P(^PRCP(445,INVPT,0),"^",3) ; search for primary or secondary
51 I DATA="P"!(DATA="S") D I OUTORD Q
52 . S OUTORD=$$ORDCHK^PRCPUITM(0,INVPT,"REC","")
53 . I OUTORD D Q
54 . . D EN^DDIOL("You must first post or delete outstanding orders for this inventory point.")
55 . . I +$G(DQ) S DE(+$G(DQ))=$P($G(^PRCP(445,INVPT,0)),"^",1)
56 . . W !!
57 ;
58 ; if the inventory point is linked to a supply station
59 I $P($G(^PRCP(445,INVPT,5)),"^",1)]"" D Q
60 . D EN^DDIOL("This inventory point is linked to a supply station.")
61 . D EN^DDIOL("You must first delete the Supply Station Provider.")
62 ;
63 W !?3,"Wait, deleting data, changing name, etc..."
64 S DATA=$P($G(^PRCP(445,INVPT,5)),"^",1) ; supply station
65 I DATA K ^PRCP(445,"AI",DATA,INVPT)
66 ; remove x-ref on inventory points
67 S %=0 F S %=$O(^PRCP(445,INVPT,2,%)) Q:'% K ^PRCP(445,"AB",%,INVPT,%)
68 ; remove x-ref on inventory,ODI users ("AJ" (ODI) from PRC*5.1*98)
69 S %=0 F S %=$O(^PRCP(445,INVPT,4,%)) Q:'% K ^PRCP(445,"AD",%,INVPT,%)
70 S %=0 F S %=$O(^PRCP(445,INVPT,9,%)) Q:'% K ^PRCP(445,"AJ",%,INVPT,%)
71 ; remove x-ref on items
72 S %=0 F S %=$O(^PRCP(445,INVPT,1,%)) Q:'% D
73 . K ^PRCP(445,"AE",%,INVPT,%)
74 . I DATA K ^PRCP(445,"AH",%,DATA,INVPT)
75 ; change name, etc
76 S X=^PRCP(445,INVPT,0),NAME=$P(X,"^")
77 S:$P(NAME,"-",2,99)="" $P(NAME,"-",2,99)=" "
78 S:$P(X,"^",5)="" $P(X,"^",5)=" "
79 K ^PRCP(445,"AF",+X,$P(X,"^",5),INVPT)
80 K ^PRCP(445,"B",$P(X,"^"),INVPT)
81 K ^PRCP(445,"C",$P(NAME,"-",2,99),INVPT)
82 K ^PRCP(445,INVPT)
83 S $P(NAME,"-",2,99)="***INACTIVE_"_INVPT_"***"
84 S ^PRCP(445,"B",NAME,INVPT)=""
85 S ^PRCP(445,"C",$P(NAME,"-",2),INVPT)=""
86 S ^PRCP(445,INVPT,0)=NAME_"^N^"_$P(X,"^",3)_"^^^N"
87 W !?5,"Name changed to: ",NAME
88 ;
89 W !?3,"Removing as a distribution point for the following inventory points:"
90 S %=0 F S %=$O(^PRCP(445,"AB",INVPT,%)) Q:'% I $D(^PRCP(445,%,2,INVPT)) W !?5,$$INVNAME^PRCPUX1(%) K ^PRCP(445,%,2,INVPT) I $D(^PRCP(445,%,2,0)) S X=^(0) D
91 . S $P(X,"^",4)=$P(X,"^",4)-1 S:$P(X,"^",4)<0 $P(X,"^",4)=0 S:$P(X,"^",3)=INVPT $P(X,"^",3)="" S ^PRCP(445,%,2,0)=X
92 K ^PRCP(445,"AB",INVPT)
93 ;
94 W !?3,"Removing link to the following fund control points:"
95 S %=0 F S %=$O(^PRC(420,"AE",%)) Q:'% S PRC("SITE")=%,X=0 F S X=$O(^PRC(420,"AE",%,INVPT,X)) Q:'X W !?5,%,"-",X D DEL^PRCPUFCP(X,INVPT)
96 I +$G(DQ) S DE(+$G(DQ))=NAME
97 W !!
98 Q
99 ;
100 ;PRCPUINV
Note: See TracBrowser for help on using the repository browser.