source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCOVUP.m@ 1638

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

initial load of WorldVistAEHR
File size: 3.3 KB
Line 
1PRCOVUP ;WISC/DJM/AS-VENDOR UPDATE SERVER ROUTINE ;3/8/05
2V ;;5.1;IFCAP;**81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4IN ;THIS ROUTINE WILL BE CALLED FROM THE 'FMS' SERVER VIA FILE 423.5
5 ;ENTRY FOR THE VENDOR UPDATE TRANSACTION (VUP).
6 ;PRCDA IS THE INTERNAL ENTRY NUMBER FOR THE RECORD FROM FILE 423.6.
7 N AAN,AAC,ALTADD,ENTRY1,II,LOOP,PRCMG,PRCXM,LINE,STATION,STCK,ENTRY,ENCK,VEN3,VEN7,MGP,NAME,DIE,DR,DA,MTI,FMSVC,ZIP,%X,%Y,ALTFLG,FMS,ACTIVE
8 S LINE=$G(^PRCF(423.6,PRCDA,1,10000,0))
9 S MGP=$O(^PRCF(423.5,"B",$P(LINE,U)_"-"_$P(LINE,U,5),0))
10 S MGP=$G(^PRCF(423.5,MGP,0))
11 S PRCMG=$P($G(^XMB(3.8,$P(MGP,U,2),0)),U)
12 S LOOP=10000
13 F S LOOP=$O(^PRCF(423.6,PRCDA,1,LOOP)) Q:LOOP'>0 D FIND Q:LINE["{" I $D(PRCXM) S PRCXM(4)=LINE D PERROR^PRCOSRV3
14 D KILL^PRCOSRV3(PRCDA)
15 Q
16 ;
17FIND S LINE=$G(^PRCF(423.6,PRCDA,1,LOOP,0))
18 Q:LINE["{"
19 S STATION=$P(LINE,U,4)
20 S STCK=$O(^PRC(411,"B",STATION,0))
21 I STCK'>0 S PRCXM(1)=$P($T(ERROR+1),";;",2) Q
22 K ACTIVE
23 S ENTRY=$P(LINE,U,5)
24 I ENTRY>0 S ACTIVE=1 D ENCK
25 S (ENTRY1,ALTFLG)=0
26 S FMS=$P(LINE,U,6)
27 I FMS="" S PRCXM(3)=$P($T(ERROR+3),";;",2) Q
28 S AAC=$P(LINE,U,7)
29 F S ENTRY1=$O(^PRC(440,"D",FMS,ENTRY1)) Q:ENTRY1'>0 D Q:$D(PRCXM) I ALTFLG=1 S ENTRY=ENTRY1 D ENCK I $D(PRCXM) S PRCXM(4)=LINE D PERROR^PRCOSRV3
30 .S VEN3=$G(^PRC(440,ENTRY1,3))
31 .I VEN3="" S PRCXM(2)=$P($T(ERROR+2),";;",2),PRCXM(4)=LINE D PERROR^PRCOSRV3 Q
32 .S ALTADD=$P(VEN3,U,5) I ALTADD=AAC S ALTFLG=1
33 .Q
34 Q
35 ;
36ENCK S ALTFLG=0
37 S ENCK=$G(^PRC(440,ENTRY,0))
38 I ENCK="" S PRCXM(2)=$P($T(ERROR+2),";;",2) Q
39 K ^PRC(440.3,ENTRY)
40 S %Y="^PRC(440.3,ENTRY,"
41 S %X="^PRC(440,ENTRY,"
42 D %XY^%RCR
43 S VEN3=$G(^PRC(440,ENTRY,3))
44 I $P(LINE,U,7)]"" S $P(VEN3,U,5)=$P(LINE,U,7)
45 I $P(LINE,U,14)]"" S $P(VEN3,U,9)=$P(LINE,U,14)
46 S $P(VEN3,U,12)="C"
47 I $P(LINE,U,15)]"" S $P(VEN3,U,11)=$P(LINE,U,15)
48 I $P(LINE,U,16)]"" S $P(VEN3,U,14)=$P(LINE,U,16)
49 I $P(LINE,U,17)]"" S $P(VEN3,U,13)=$P(LINE,U,17)
50 I $P(LINE,U,19)]"" S $P(VEN3,U,15)=$P(LINE,U,19)
51 I $P(LINE,U,20)]"" S $P(VEN3,U,10)=$P(LINE,U,20)
52 ;set fms vendor name (field is uneditable)
53 S NAME=$P(LINE,U,8)
54 I NAME]"" D
55 .F II=1:1 S AAN=$E(NAME,II) Q:AAN?1AN S NAME=$E(NAME,2,99)
56 .S $P(VEN3,U,7)=NAME
57 .Q
58 S VEN7=$G(^PRC(440,ENTRY,7))
59 I $P(LINE,U,9)]"" S $P(VEN7,U,3)=$P(LINE,U,9)
60 I $P(LINE,U,10)]"" S $P(VEN7,U,4)=$P(LINE,U,10)
61 I $P(LINE,U,11)]"" S $P(VEN7,U,7)=$P(LINE,U,11)
62 S ZIP=$P(LINE,U,13) I ZIP]"" D
63 .S $P(VEN7,U,9)=$S($L(ZIP)=9:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP)
64 .Q
65 I $P(LINE,U,12)]"" S $P(VEN7,U,8)=$O(^DIC(5,"C",$P(LINE,U,12),0))
66 S ^PRC(440,ENTRY,3)=VEN3
67 S ^PRC(440,ENTRY,7)=VEN7
68 S DIE="^PRC(440,"
69 S DA=ENTRY
70 S FMSVC=$P(LINE,U,6)
71 S DR="34////^S X=FMSVC"
72 S NAME=$P(ENCK,U)
73 S MTI="" I $P(LINE,U,19)]"" S MTI=$P(LINE,U,19)
74 I MTI="D" S NAME="**"_NAME,DR=DR_";.01////^S X=NAME;31.5////^S X=1;15////@"
75 I $G(ACTIVE),"ACF"[MTI,$E(NAME,1,2)="**" S NAME=$E(NAME,3,99),DR=DR_";.01////^S X=NAME;31.5////@;15////@"
76 D ^DIE
77 D BUL^PRCOVUP4
78 ; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
79 D:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1 ONECHK^PRCVNDR(ENTRY)
80 K ^PRC(440.3,ENTRY),ACTIVE
81 Q
82 ;
83ERROR ;HERE IS THE LIST OF ERROR MESSAGES
84 ;;The STATION number from FMS can not be found at this location.
85 ;;The VENDOR file entry returned from FMS can not be found.
86 ;;This FMS transaction has no FMS VENDOR CODE.
Note: See TracBrowser for help on using the repository browser.