source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPENE1.m@ 1261

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

initial load of WorldVistAEHR
File size: 6.0 KB
Line 
1PRCPENE1 ;WISC/RFJ,DGL-enter/edit inv parameters (list manager) ;10.7.99
2V ;;5.1;IFCAP;**1**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7ALL ; edit all fields
8 D FULL^VALM1
9 S VALMBCK="R"
10 I '$D(^PRCP(445,PRCPINPT,0)) Q
11 I $P($G(^PRCP(445,PRCPINPT,5)),"^",1)]"" D EDIT("[PRCP INVENTORY POINT (SS)]")
12 E D EDIT("[PRCP INVENTORY POINT (NON SS)]")
13 D INIT^PRCPENLM
14 Q
15 ;
16 ;
17DESCRIP ; edit descriptive parameters
18 N PRCPNM,VALUE
19 D FULL^VALM1
20 S VALMBCK="R"
21 I '$D(^PRCP(445,PRCPINPT,0)) Q
22 I $P($G(^PRCP(445,PRCPINPT,5)),"^",1)]"" D
23 . S PRCPNM=$P(^PRCP(445,PRCPINPT,0),"^",1)
24 . D EN^DDIOL("The inventory point name cannot be edited on a supply station secondary.")
25 . D EDIT(".01////^S X=PRCPNM")
26 . S DIR(0)="445,.8^^",DA=PRCPINPT
27 . D ^DIR K DIR
28 . S VALUE=Y
29 . I $D(DTOUT)!$D(DUOUT) Q
30 . S DA=PRCPINPT,DIE="^PRCP(445,",DR=".8///^S X=VALUE",PRCPPRIV=1
31 . D ^DIE K PRCPPRIV,DIE
32 . W !
33 . D EN^DDIOL("WARNING: A 'NO' RESPONSE MAY CAUSE INTEGRITY PROBLEMS")
34 . D EN^DDIOL("WITH THE SUPPLY STATION INTERFACE.")
35 . S DIR(0)="445,.5^^",DA=PRCPINPT
36 . D ^DIR K DIR
37 . S VALUE=Y
38 . I $D(DTOUT)!$D(DUOUT) Q
39 . S DA=PRCPINPT,DIE="^PRCP(445,",DR=".5///^S X=VALUE",PRCPPRIV=1
40 . D ^DIE K PRCPPRIV,DIE
41 . W !
42 . D EN^DDIOL("WARNING: A 'NO' RESPONSE CAUSES GIP TO IGNORE INFORMATION")
43 . D EN^DDIOL("FROM THE SUPPLY STATION.")
44 . S DIR(0)="445,.6^^",DA=PRCPINPT
45 . D ^DIR K DIR
46 . S VALUE=Y
47 . I $D(DTOUT)!$D(DUOUT) Q
48 . S DA=PRCPINPT,DIE="^PRCP(445,",DR=".6///^S X=VALUE",PRCPPRIV=1
49 . D ^DIE K PRCPPRIV,DIE
50 . W !
51 I $P($G(^PRCP(445,PRCPINPT,5)),"^",1)="" D EDIT(".01;.8;.5;.6")
52 D INIT^PRCPENLM
53 Q
54 ;
55 ;
56SPECIAL ; edit special parameters
57 D FULL^VALM1
58 S VALMBCK="R"
59 I '$D(^PRCP(445,PRCPINPT,0)) Q
60 N DR,ORD,TYPE
61 S ORD=0
62 S TYPE=$P(^PRCP(445,PRCPINPT,0),"^",3)
63 S DR="12;"
64 I TYPE="W" S DR=DR_".9;16"
65 I TYPE="P" S DR=DR_"14;15;I $P(^PRCP(445,DA,0),U,20)'=""S"" S Y=5;16;5;5.5;9"
66 I TYPE="S" D
67 . S ORD=$$SSCHK(PRCPINPT)
68 . I 'ORD S DR=DR_"22"
69 D EDIT(DR)
70 I ORD[1 D EN^DDIOL("Post or delete all regular orders before editing the supply station provider.")
71 I ORD[2 D EN^DDIOL("Change this secondary to be stocked by only 1 primary before adding a "),EN^DDIOL("supply station provider.")
72 I ORD[3 D EN^DDIOL("A supply station IP cannot have a name longer than 10 characters."),EN^DDIOL("Edit the name before linking a supply station to this IP.")
73 I ORD D P^PRCPUREP ; pause to allow user to read message
74 D INIT^PRCPENLM
75 Q
76 ;
77 ;
78FCP ; edit fund control point
79 D FULL^VALM1
80 N %,FCP,FCPNM,INVPTNM,PRCPFLAG
81 S INVPTNM=$$INVNAME^PRCPUX1(PRCPINPT)
82 K X S X(1)="Select the FUND CONTROL POINT that may be used when replenishing "_INVPTNM W ! D DISPLAY^PRCPUX2(3,75,.X)
83 F D Q:$G(PRCPFLAG)
84 . D DISPFCP^PRCPUTIL(PRCPINPT)
85 . S FCP=$$SELECT^PRCPUFCP(PRCPTYPE) I FCP<1 S PRCPFLAG=1 Q
86 . S FCPNM=$P(^PRC(420,PRC("SITE"),1,FCP,0),U)
87 . I $D(^PRC(420,"AE",PRC("SITE"),PRCPINPT,+FCP)) D Q ; if defined
88 . . W ! S XP=" Do you want to unlink inventory point "_INVPTNM
89 . . S XP(1)=" from control point "_FCPNM
90 . . I $$YN^PRCPUYN(2)=1 D DEL^PRCPUFCP(FCP,PRCPINPT)
91 . . I $O(^PRC(420,"AE",PRC("SITE"),PRCPINPT,0)) S PRCPFLAG=1
92 . E D SET^PRCPUFCP(FCP,PRCPINPT) S PRCPFLAG=1
93 . Q
94 D:'$G(PRCP("CONVRT")) INIT^PRCPENLM
95 S VALMBCK="R"
96 Q
97 ;
98 ;
99MISCOST ; edit mis costing
100 D FULL^VALM1
101 S VALMBCK="R"
102 I '$D(^PRCP(445,PRCPINPT,0)) Q
103 I '$D(^PRCP(445,PRCPINPT,3,0)) S ^(0)="^445.011P^^"
104 D EDIT(11)
105 D INIT^PRCPENLM
106 Q
107 ;
108 ;
109USERS ; edit authorized users
110 D FULL^VALM1
111 S VALMBCK="R"
112 I '$D(^PRCP(445,PRCPINPT,0)) Q
113 I '$D(^PRCP(445,PRCPINPT,4,0)) S ^(0)="^445.04P^^"
114 D EDIT(6)
115 I $P(^PRCP(445,PRCPINPT,0),"^",3)'="S" D USERS^PRCPENEU(PRCPINPT)
116 D INIT^PRCPENLM
117 Q
118 ;
119 ;
120FLAGS ; edit flags: emergency stock level, issue schedule, auto purge
121 D FULL^VALM1
122 S VALMBCK="R"
123 N DR,PRCPX1,PRCPX2,PRCPX3
124 ; emergency stock level text
125 S PRCPX1(1)="Set the 'Print Emergency Stock Levels' flag to NO to discontinue the notification that you have items at or below the emergency stock level. The next time the automatically scheduled program which scans the database"
126 S PRCPX1(2)="runs, it will reset the flag and the message will reappear if items are found at or below the emergency stock level."
127 S DR="D DISPLAY^PRCPUX2(5,75,.PRCPX1);7PRINT EMERGENCY STOCK LEVELS;"
128 ; automatic purge text
129 S PRCPX2(1)="Set the 'Automatic Purge' to YES if you want data older than 13 months automatically purged for this inventory point. A background scheduled program will run the first day of each month and automatically purge old"
130 S PRCPX2(2)="data for those inventory points which have the automatic purge turned on."
131 S DR=DR_"D DISPLAY^PRCPUX2(5,75,.PRCPX2);7.9AUTOMATIC PURGE;"
132 ; reg whse issues text
133 S PRCPX3(1)="Delete the 'Regular Whse Issues Due Date' to discontinue the message notifying you that your next request for warehouse issues is due; or change it to a later date, if you wish to be reminded later."
134 I PRCPTYPE="P" S DR=DR_"D DISPLAY^PRCPUX2(5,75,.PRCPX3);10REGULAR WHSE ISSUES DUE DATE;"
135 D EDIT(DR)
136 D INIT^PRCPENLM
137 Q
138 ;
139 ;
140SSCHK(PRCPINPT) N ORD,PRCPSB
141 ;
142 ; returns 1 if a secondary inventory point has outstanding orders
143 ; 2 if it is stocked by multiple points
144 ; 3 if the IP name is too long
145 ; 123 if ALL conditions are true
146 ;
147 ; PRCPINPT is the secondary inventory point's DA
148 ;
149 S ORD=0
150 ; F S ORD=$O(^PRCP(445.3,"AD",PRCPINPT,ORD)) Q:ORD']"" I $P(^PRCP(445.3,ORD,0),"^",8)="R",$P(^(0),"^",6)'="P" D Q
151 ; . S ORD=1
152 S ORD=$$ORDCHK^PRCPUITM(0,PRCPINPT,"R","") ; any outstanding reg orders?
153 I $P($G(^PRCP(445,PRCPINPT,5)),"^",1)']"" D
154 . N PRCPSB S PRCPSB=0
155 . S PRCPSB=$O(^PRCP(445,"AB",PRCPINPT,PRCPSB))
156 . I PRCPSB S PRCPSB=$O(^PRCP(445,"AB",PRCPINPT,PRCPSB)) I PRCPSB D
157 . . S:'ORD ORD=2 I ORD=1 S ORD=12
158 I $L($P($P(^PRCP(445,PRCPINPT,0),"^",1),"-",2))>10 D
159 . I ORD S ORD=ORD_3
160 . I 'ORD S ORD=3
161 QUIT (ORD)
162 ;
163 ;
164EDIT(DR) ; edit inventory parameters fields in dr string
165 I '$D(^PRCP(445,+PRCPINPT,0)) Q
166 N %,D,D0,D1,DA,DI,DIC,DIDEL,DIE,DLAYGO,DQ,X,Y
167 S DA=PRCPINPT,(DIC,DIE)="^PRCP(445,",DIDEL=445,PRCPPRIV=1
168 D ^DIE K PRCPPRIV
169 Q
Note: See TracBrowser for help on using the repository browser.