source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPEITE.m@ 1608

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

initial load of FOIAVistA 6/30/08 version
File size: 5.4 KB
Line 
1PRCPEITE ;WISC/RFJ-enter/edit inventory items ; 11/6/06 8:40am
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 ;
6ALL(PRCPINPT,ITEMDA) ; edit all fields option (for new items)
7 I '$D(^PRCP(445,+PRCPINPT,1,+ITEMDA,0)) Q
8 N %,%H,D,D0,D1,D2,DA,DES,DI,DIC,DIE,DLAYGO,DQ,DR,I
9 N PRCPINDA,PRCPITEM,PRCPNL,PRCPQUIT,PRCPPRIV,PRCPTYPE,PRCPUI,PRCPUI1,X,Y
10 D EN^DDIOL("----- Enter Item Descriptive Data -----")
11 S DES=$P($G(^PRCP(445,PRCPINPT,1,ITEMDA,6)),"^")
12 I DES="" S DES=$$DESDEF^PRCPEITF(PRCPINPT,ITEMDA) ; get item description default
13 S PRCPQUIT=0
14 D DESCRIP^PRCPEITF(PRCPINPT,ITEMDA,.PRCPQUIT)
15 I PRCPQUIT Q
16 S DR="[PRCP ITEM ALL FIELDS (NON-SS)]"
17 I $P(^PRCP(445,PRCPINPT,0),"^",3)="S",$P($G(^PRCP(445,PRCPINPT,5)),"^",1)]"" S DR="[PRCP ITEM ALL FIELDS (SS)]" ; supply station monitors normal level value
18 S DA=PRCPINPT
19 S PRCPITEM=$C(96)_ITEMDA
20 S (DIC,DIE)="^PRCP(445,"
21 S DIE("NO^")="BACKOUTOK"
22 S PRCPPRIV=1 D ^DIE
23 Q
24 ;
25 ;
26DESCRIP(PRCPINPT,ITEMDA) ; edit description, category, location fields
27 I '$D(^PRCP(445,+PRCPINPT,1,+ITEMDA,0)) Q
28 N %,D,D0,DA,DES,DI,DIC,DIE,DISYS,DQ,DR,DZ,E,PRCPPRIM,PRCPPRIV,PRCPPRNM,PRCPQUIT,TYPE,X,XH,XP,Y
29 S DES=$P($G(^PRCP(445,PRCPINPT,1,ITEMDA,6)),"^")
30 I DES="" S DES=$$DESDEF^PRCPEITF(PRCPINPT,ITEMDA) ; get default value
31 S PRCPQUIT=0
32 D DESCRIP^PRCPEITF(PRCPINPT,ITEMDA,.PRCPQUIT)
33 I PRCPQUIT Q
34 S DA(1)=PRCPINPT,DA=ITEMDA,(DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,"
35 S DR=".5GROUP CATEGORY;5MAIN STORAGE LOCATION;6"
36 S PRCPPRIV=1
37 D ^DIE K PRCPPRIV
38 Q
39 ;
40 ;
41LEVELS(PRCPINPT,ITEMDA) ; edit stock levels
42 I '$D(^PRCP(445,+PRCPINPT,1,+ITEMDA,0)) Q
43 N %,D,D0,DA,DI,DIC,DIE,DQ,DR,DZ,PRCPDR,PRCPPRIV,PRCPQUIT,UNIT,X,Y
44 S UNIT=$$UNIT^PRCPUX1(PRCPINPT,ITEMDA," per ")
45 S DR="9NORMAL STOCK LEVEL ("_UNIT_")"
46 S PRCPQUIT=0
47 ;
48 ; if the supply station secondary has unposted regular orders,
49 ; restrict editing a non-zero normal level to zero.
50 I $P(^PRCP(445,PRCPINPT,0),"^",3)="S",$P($G(^PRCP(445,PRCPINPT,5)),"^",1)]"" D
51 . D EDNORM(PRCPINPT,ITEMDA,$E(DR,2,99),.PRCPQUIT)
52 . S DR=""
53 . I $D(DUOUT)!$D(DTOUT) Q
54 I PRCPQUIT Q
55 I DR]"" S DR=DR_";"
56 S PRCPPRIV=1
57 S DR=DR_"11EMERGENCY STOCK LEVEL ("_UNIT_");9.5TEMPORARY STOCK LEVEL ("_UNIT_");I 'X S Y=10;9.6;10STANDARD REORDER POINT ("_UNIT_");10.3OPTIONAL REORDER POINT ("_UNIT_");"
58 S DA(1)=PRCPINPT,DA=ITEMDA,(DIC,DIE)="^PRCP(445,"_PRCPINPT_",1," D ^DIE
59 Q
60 ;
61 ;
62SPECIAL(PRCPINPT,ITEMDA) ; special parameters and flags
63 I '$D(^PRCP(445,+PRCPINPT,1,+ITEMDA,0)) Q
64 N %,C,D,D0,D1,DA,DDH,DI,DIC,DIE,DISYS,DIZ,DLAYGO,DQ,DR,I,ISSUE,PRCPITEM,PRCPPRIV,PRCPSET,TYPE,X,Y
65 S (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,",PRCPSET="I PRCPITEM'=X,$D(^PRCP(445,PRCPINPT,1,X,0))",DA(1)=PRCPINPT,(PRCPITEM,DA)=ITEMDA
66 S TYPE=$P($G(^PRCP(445,PRCPINPT,0)),"^",3)
67 ; substitute item multiple
68 I TYPE="W",'$D(^PRCP(445,PRCPINPT,1,ITEMDA,4,0)) S ^(0)="^445.122PI^^"
69 I TYPE="P",$P(^PRCP(445,PRCPINPT,0),"^",10)="S" S ISSUE=1
70 ; removal of fields 14;14.3;14.4 if type = "P" (fields not used)
71 S DR="17;"_$S($G(ISSUE):"14.5;",1:"")_$S(TYPE="W":"22;",1:"")
72 S PRCPPRIV=1
73 D ^DIE I $D(DTOUT)!$D(Y) Q
74 K DIC,DIE,DA,DR
75 I TYPE'="W" D ODI^PRCPEITG(PRCPINPT,ITEMDA) ; ask On-Demand (PRC*5.1*98)
76 Q
77 ;
78 ;
79DISPUNIT(PRCPINPT,ITEMDA) ; drug accountability dispensing units
80 N %,D,D0,DA,DD,DDH,DI,DIC,DIE,DISYS,DIX,DIY,DO,DQ,DR,DZ,X,Y
81 S DA(1)=PRCPINPT,DA=ITEMDA,(DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,",DR="50;51"
82 S PRCPPRIV=1 D ^DIE K PRCPPRIV
83 Q
84 ;
85 ;
86EDNORM(PRCPINPT,ITEMDA,TEXT,PRCPQUIT) ; editing the normal level on supply station secondaries
87 ; ITEMDA = item number requiring the default description
88 ; PRCPINPT = inventory point
89 ; TEXT = text to display when prompting the user
90 ; PRCPQUIT = flag to signify exit desired
91 ;
92 N DA,DIC,DIE,DIR,DR,ORD,PRCPNL,PRCPPRIV,VALUE
93 ; because this is sometimes called from templates, new FileMan variables
94 N D,D0,D1,D2,D3,D4,D5,D6,DB,DC,DD,DE,DG,DH,DI,DIA,DIADD,DICR,DIEC,DIEL
95 N DIFLD,DIK,DIOV,DK,DL,DLAYGO,DM,DO,DOV,DP,DQ,DU,DV,DW,I,J,X,Y
96 I $P(^PRCP(445,PRCPINPT,0),"^",3)'="S" QUIT
97 I '$P($G(^PRCP(445,PRCPINPT,5)),"^",1) QUIT
98 I '$D(^PRCP(445,PRCPINPT,1,ITEMDA,0)) QUIT
99 S PRCPNL=+$P(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",9)
100 S ORD=0
101 S ORD=$$ORDCHK^PRCPUITM(ITEMDA,PRCPINPT,"R","")
102 I ORD D ; this field is also a flag of items on supply station, editing must be restricted if there are outstanding supply station orders.
103 . N DIR
104 . S DIR("A")=TEXT
105 . S DIR("A",1)="There are outstanding regular orders for this item."
106 . S DIR("A",2)="You cannot delete the normal level or make it 0"
107 . S DIR(0)="N^1:999999"
108 . S DIR("B")=PRCPNL
109 . D ^DIR K DIR
110 . I $D(DUOUT)!$D(DTOUT) S PRCPQUIT=1 Q
111 . I X S PRCPNL=X D
112 . . S DA(1)=PRCPINPT,DA=ITEMDA,PRCPPRIV=1
113 . . S (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,"
114 . . S DR="9///^S X=PRCPNL"
115 . . D ^DIE
116 . . K DIC,DIE
117 I 'ORD D
118 . I PRCPNL'>0 W !!,"Changing the level from zero will add the item to the supply station."
119 . I PRCPNL>0 W !!,"Changing the level to zero will delete the item from the supply station."
120 . I $D(DUOUT)!$D(DTOUT) S PRCPQUIT=1 Q
121 . S DIR(0)="445.01,9^^",DA(1)=PRCPINPT,DA=ITEMDA
122 . D ^DIR K DIR
123 . S VALUE=Y
124 . I $D(DTOUT)!$D(DUOUT) S PRCPQUIT=1 Q
125 . S DR="9///^S X=VALUE"
126 . S DA=ITEMDA,DA(1)=PRCPINPT,PRCPPRIV=1
127 . S (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,"
128 . D ^DIE
129 . K DIC,DIE
130 . I PRCPNL,'$P(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",9) D BLDSEG^PRCPHLFM(2,ITEMDA,PRCPINPT)
131 . I 'PRCPNL,$P(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",9) D BLDSEG^PRCPHLFM(1,ITEMDA,PRCPINPT)
132 QUIT
Note: See TracBrowser for help on using the repository browser.