source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHE1.m@ 1150

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

initial load of WorldVistAEHR
File size: 4.4 KB
RevLine 
[613]1PRCHE1 ;WISC/DJM/BGJ/AS-IFCAP EDIT VENDOR FILE ;3/8/05
2V ;;5.1;IFCAP;**7,59,55,81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;NEW ENTER/EDIT VENDOR FILE CALLED FROM PRCHPC VEN EDIT OPTION
5 N %,%X,%Y,DIE,DIK,DIR,DIRUT,DR,PRCF,SITE,DA,PRCHV3,FLAGN,FLAG
6 N DIC,DLAYGO,IEN,Y,FISCAL,VRQ,STOP,INACT,NAME,EDIT,NEW
7 ;
8VEDIT I '$D(PRC("PARAM")) D Q:'%
9 . S PRCF("X")="AS"
10 . D ^PRCFSITE
11 . Q
12 ; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
13 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1,$D(IEN) D ONECHK^PRCVNDR(IEN)
14 S SITE=PRC("SITE")
15 S DIC="^PRC(440,"
16 S DIC(0)="AELMQ"
17 S DLAYGO=440
18 S PRCHDA=-1
19 K PRCHPO
20 D ^DIC
21 Q:Y<0
22 S (IEN,DA)=+Y
23 S (FLAGN,NEW)=$P(Y,U,3)
24 G:'$D(DA) VEDIT
25 D G:'$D(DA) VEDIT
26 . L +^PRC(440,DA):0
27 . E W !,$C(7),"ANOTHER USER IS EDITING THIS ENTRY!" K DA
28 . Q
29 D I FLAG=0 L -^PRC(440,IEN) G VEDIT
30 . S PRCHV3=$G(^PRC(440,DA,3))
31 . S FLAG=0
32 . ;
33 . ;NO FMS VENDOR CODE - DO 'ADD' VENDOR REQUEST
34 . I $P(PRCHV3,U,4)="" S FLAG=1
35 . ;
36 . ;FMS VENDOR CODE - DO 'CHANGE' VENDOR REQUEST
37 . I $P(PRCHV3,U,4)]"" S FLAG=2
38 . ;
39 . I $P(PRCHV3,U,12)="P" D
40 . . W !!,"There is a FMS Vendor Request pending for this vendor."
41 . . W !,"Any changes you make now may be overwritten when the Vendor"
42 . . W !,"Update is received.",!!
43 . . Q
44 . Q
45 K ^PRC(440.3,DA)
46 I FLAGN="" D
47 . S %X="^PRC(440,DA,"
48 . S %Y="^PRC(440.3,DA,"
49 . D %XY^%RCR
50 . Q
51 ;
52 S EDIT="[PRCHVENDOR1]"
53 ;
54 ; NOW LETS FIND OUT IF USER WANTS TO 'REACTIVATE VENDOR', IF
55 ; APPROPRIATE.
56 ;
57 S INACT=$P($G(^PRC(440,DA,10)),U,5)
58 I INACT=1 D
59 . S DIR("A")="Do you want to 'Reactivate' this vendor"
60 . S DIR("A",1)=" "
61 . S DIR("A",2)=" "
62 . S DIR(0)="Y"
63 . S DIR("B")="NO"
64 . D ^DIR
65 . I Y'=1 S EDIT="[PRCHVENDORNOREACT]" Q
66 . ; OK USER WANTS TO REACTIVATE VENDOR.
67 . S DIE="^PRC(440,"
68 . S NAME=$P($G(^PRC(440,DA,0)),U,1)
69 . I $E(NAME,1,2)="**" S NAME=$E(NAME,3,99)
70 . S DR=".01////^S X=NAME;15////@;31.5////@"
71 . D ^DIE
72 . W !!
73 . Q
74 . ; NOW THE VENDOR IS REACTIVATED.
75 ;
76 S DR=EDIT
77 S DIE=DIC
78 D ^DIE
79 ; $D(Y)=TRUE (1) -- USER '^' OUT OF TEMPLATE
80 I $D(Y) D I FLAG=0 L -^PRC(440,IEN) G VEDIT
81 . ; CHECK TO SEE IF BUSINESS TYPE (FPDS) FIELD HAS BEEN ENTERED
82 . I $P($G(^PRC(440,DA,2)),"^",3)="" D
83 . . W $C(7),!!,"*** NOT ALL REQUIRED FIELDS HAVE BEEN ENTERED ***"
84 . . W !,"Failure to enter required data may affect Purchase Order"
85 . . W " processing",!
86 . . ;
87 . . ;See NOIS:V13-0802-N1396
88 . I $P($G(^PRC(440,DA,1.1,0)),"^",3)="" D
89 . . KILL ^PRC(440,DA,1.1)
90 . . W $C(7),!!,"*** SOCIOECONOMIC GROUP IS MISSING ***"
91 . . W !,"Failure to enter required data may affect Purchase Order"
92 . . W " processing",!
93 . ;
94 . S DIR("A")="Do you want to keep the VENDOR changes"
95 . S DIR(0)="Y"
96 . S DIR("B")="YES"
97 . D ^DIR
98 . ; KILL VARIABLES SET TO USE THE READER
99 . K DIR
100 . ; DIRUT SET IF USER TIMES OUT OR ENTERS '^'.
101 . Q:$D(DIRUT)
102 . ; Y=1 -- USER WANTS TO KEEP VENDOR CHANGES
103 . Q:Y=1
104 . ; USER DECIDED **NOT** TO KEEP VENDOR CHANGES
105 . ; FLAGN=1 MEANS THIS IS A NEW VENDOR (NEW DURING THIS EDIT SESSION)
106 . I FLAGN=1 S DIK="^PRC(440," D ^DIK S FLAG=0 Q
107 . S %X="^PRC(440.3,DA,"
108 . S %Y="^PRC(440,DA,"
109 . D %XY^%RCR
110 . S FLAG=0
111 . W !!
112 . K ^PRC(440.3,DA)
113 . S NAME=$P($G(^PRC(440,DA,0)),U,1)
114 . W "Name: "_NAME,!,"DA: "_DA,!
115 . S N1=$E(NAME,1,2)
116 . Q:N1'["**"
117 . S N1=$E(NAME,3,99)
118 . K ^PRC(440,"B",N1,DA)
119 . S ^PRC(440,"B",NAME,DA)=""
120 . Q
121 S FISCAL=$G(^PRC(411,PRC("SITE"),9))
122 I $P(FISCAL,U,3)="Y" D G VEDIT
123 . Q:$$NEW^PRCOVTST(DA,PRC("SITE"),FLAG)
124 . ;
125 . ; SEE IF THIS IS A NEW VENDOR -- IF SO NOW MOVE THE ENTRY
126 . ; OVER TO FILE 440.3
127 . ;
128 . I NEW D
129 . . S %X="^PRC(440,DA,"
130 . . S %Y="^PRC(440.3,DA,"
131 . . D %XY^%RCR
132 . . Q
133 . ;
134 . ; NOW SET UP TO REVIEW THIS NEW VENDOR
135 . ;
136 . S DIE="^PRC(440.3,"
137 . S DR="47///^S X=FLAG;48///^S X=DA;49///^S X=PRC(""SITE"")"
138 . D ^DIE
139 . Q
140 ;
141GENERATE ;GO CREATE A VRQ ANS SEND IT TO AUSTIN
142 D Q:$G(STOP)=1
143 . I FLAG=1 D NEW^PRCOVRQ(DA,SITE) Q
144 . I FLAG=2 D UPDATE^PRCOVRQ1(DA,SITE) Q
145 G VEDIT
146 ;
147 ;
148SEND(IEN) ;SEND OFF THE VRQ TO AUSTIN -- CALLED FROM SEND^PRCORV1
149 S VRQ=$G(^PRC(440.3,IEN,"VRQ"))
150 S FLAG=$P(VRQ,U)
151 S DA=$P(VRQ,U,2)
152 S SITE=$P(VRQ,U,3)
153 S STOP=1
154 D GENERATE
155 Q:$G(^PRC(440.3,IEN,0))]""
156 S VRQ=$O(^PRCF(422.2,"B","123-VRQ-01",0))
157 S COUNT=$P(^PRCF(422.2,VRQ,0),U,2)
158 S COUNT=$S(COUNT-1>0:COUNT-1,1:0)
159 S $P(^PRCF(422.2,VRQ,0),U,2)=COUNT
160 K ^PRC(440.3,"AD",IEN,IEN)
161 Q
Note: See TracBrowser for help on using the repository browser.