source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVNDR.m@ 1424

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

initial load of FOIAVistA 6/30/08 version

File size: 5.5 KB
Line 
1PRCVNDR ;WOIFO/AS-SEND VENDOR UPDATE INFOMATION TO DYNAMED ; 2/21/05 5:07pm
2 ;;5.1;IFCAP;**81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5NITECHK ;
6 ; Once a day check
7 ; Compare checksum and set flag to updated record
8 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)'=1 Q
9 N PRCVP,PRCVP2,PRCVAL,PRCVND,PRCVN,NOD,PRCVST,PRCVCNT
10 S PRCVP=67280421310721,PRCVP2=2147483647,PRCVN=0
11 S NOD=+$O(^PRCV(414.04,"D","VENDOR",0))
12 F S PRCVN=$O(^PRC(440,PRCVN)) Q:'PRCVN D
13 . S PRCVAL=$$CHKSUM()
14 . ; Compare to existing CheckSum
15 . ; Set a flag if the not the same
16 . I PRCVAL,PRCVAL'=$P($G(^PRCV(414.04,NOD,1,PRCVN,0)),"^",2) D
17 .. S ^PRCV(414.04,NOD,1,PRCVN,0)=PRCVN_"^"_PRCVAL
18 .. D GETDATA(PRCVN)
19 .. I $D(^TMP("PRCVNDR",$J,PRCVN)) D EN^PRCVVMF(PRCVN)
20 .. K ^TMP("PRCVNDR",$J)
21 Q
22ONECHK(PRCVN) ;
23 ; Checksum to one vendor only
24 N PRCVP,PRCVP2,PRCVAL,PRCVND,NOD,PRCVST,PRCVCNT
25 S PRCVP=67280421310721,PRCVP2=2147483647
26 S NOD=+$O(^PRCV(414.04,"D","VENDOR",0))
27 S PRCVAL=$$CHKSUM
28 ; If checksum not equal to original record, get data to DynaMed
29 I PRCVAL,PRCVAL'=$P($G(^PRCV(414.04,NOD,1,PRCVN,0)),"^",2) D
30 . S ^PRCV(414.04,NOD,1,PRCVN,0)=PRCVN_"^"_PRCVAL
31 . D GETDATA(PRCVN)
32 . I $D(^TMP("PRCVNDR",$J,PRCVN)) D EN^PRCVVMF(PRCVN)
33 . K ^TMP("PRCVNDR",$J)
34 Q
35INIT ;
36 ; Initialize checksum global at installation
37 NEW FDA,RESULT,PRCVN,PRCVP,PRCVP2,PRCVAL,PRCVST,PRCVCNT
38 S FDA(414.04,"?+1,",.01)="VENDOR"
39 S FDA(414.04,"?+1,",.02)=440
40 S FDA(414.04,"?+1,",.03)="Vendor file checksum (on partial field)"
41 D UPDATE^DIE("E","FDA","RESULT")
42 S PRCVP=67280421310721,PRCVP2=2147483647,PRCVN=0
43 F S PRCVN=$O(^PRC(440,PRCVN)) Q:'PRCVN D
44 . S FDA(414.41,"?+1,"_RESULT(1)_",",.01)=PRCVN
45 . S FDA(414.41,"?+1,"_RESULT(1)_",",1)=$$CHKSUM()
46 . D UPDATE^DIE("E","FDA")
47 Q
48CHKSUM() ;
49 S PRCVAL=0
50 ; Node 0
51 S PRCVND=$G(^PRC(440,PRCVN,0))
52 ; Vendor Name
53 S PRCVST=$P(PRCVND,"^",1),PRCVAL=$$CKINC(PRCVAL,PRCVST)
54 ; Ordering Address 1
55 S PRCVST=$P(PRCVND,"^",2),PRCVAL=$$CKINC(PRCVAL,PRCVST)
56 ; Ordering Address 2
57 S PRCVST=$P(PRCVND,"^",3),PRCVAL=$$CKINC(PRCVAL,PRCVST)
58 ; Ordering Address 3
59 S PRCVST=$P(PRCVND,"^",4),PRCVAL=$$CKINC(PRCVAL,PRCVST)
60 ; Ordering Address 4
61 S PRCVST=$P(PRCVND,"^",5),PRCVAL=$$CKINC(PRCVAL,PRCVST)
62 ; Ordering City
63 S PRCVST=$P(PRCVND,"^",6),PRCVAL=$$CKINC(PRCVAL,PRCVST)
64 ; Ordering State
65 S PRCVST=$P(PRCVND,"^",7),PRCVAL=$$CKINC(PRCVAL,PRCVST)
66 ; Ordering Zip Code
67 S PRCVST=$P(PRCVND,"^",8),PRCVAL=$$CKINC(PRCVAL,PRCVST)
68 ; Contact Person
69 S PRCVST=$P(PRCVND,"^",9),PRCVAL=$$CKINC(PRCVAL,PRCVST)
70 ; Contact Phone Number
71 S PRCVST=$P(PRCVND,"^",10),PRCVAL=$$CKINC(PRCVAL,PRCVST)
72 ;
73 ; Node 3
74 S PRCVND=$G(^PRC(440,PRCVN,3))
75 ; Vendor EDI Indicator
76 S PRCVST=$P(PRCVND,"^",2),PRCVAL=$$CKINC(PRCVAL,PRCVST)
77 ; EDI Vendor Number
78 S PRCVST=$P(PRCVND,"^",3),PRCVAL=$$CKINC(PRCVAL,PRCVST)
79 ; FMS Vendor ID
80 S PRCVST=$P(PRCVND,"^",4),PRCVAL=$$CKINC(PRCVAL,PRCVST)
81 ; Alternate Address Indicator
82 S PRCVST=$P(PRCVND,"^",5),PRCVAL=$$CKINC(PRCVAL,PRCVST)
83 ;
84 ; Node 10
85 S PRCVND=$G(^PRC(440,PRCVN,10))
86 ; Contact FAX Number
87 S PRCVST=$P(PRCVND,"^",6),PRCVAL=$$CKINC(PRCVAL,PRCVST)
88 ; Inactivated Vendor Indicator
89 S PRCVST=$P(PRCVND,"^",5),PRCVAL=$$CKINC(PRCVAL,PRCVST)
90 ; Date Inactivated
91 S PRCVST=$P(PRCVND,"^",3),PRCVAL=$$CKINC(PRCVAL,PRCVST)
92 ;
93 ; Dun and Bradstreet Vendor ID
94 S PRCVST=$P($G(^PRC(440,PRCVN,7)),"^",12),PRCVAL=$$CKINC(PRCVAL,PRCVST)
95 ; Account Number
96 S PRCVST=$P($G(^PRC(440,PRCVN,2)),"^",1),PRCVAL=$$CKINC(PRCVAL,PRCVST)
97 ;
98 ; Node 4
99 S PRCVCNT=0 F S PRCVCNT=$O(^PRC(440,PRCVN,4,PRCVCNT)) Q:'PRCVCNT D
100 . S PRCVND=$G(^PRC(440,PRCVN,4,PRCVCNT,0))
101 . ; Contract Number
102 . S PRCVST=$P(PRCVND,"^",1),PRCVAL=$$CKINC(PRCVAL,PRCVST)
103 . ; Contract Expiration Date
104 . S PRCVST=$P(PRCVND,"^",2),PRCVAL=$$CKINC(PRCVAL,PRCVST)
105 . ; Contract Beginning Date
106 . S PRCVST=$P(PRCVND,"^",3),PRCVAL=$$CKINC(PRCVAL,PRCVST)
107 Q PRCVAL
108 ;
109GETDATA(PRCVNM) ;
110 ; Get all field required,
111 ; Node 0
112 S PRCVND=$G(^PRC(440,PRCVNM,0))
113 ; State
114 S $P(PRCVND,"^",7)=$P($G(^DIC(5,+$P(PRCVND,"^",7),0)),"^",2)
115 ; Name, Address 1, 2, 3, 4, City, State, Zip, Contact Person, Phone
116 S ^TMP("PRCVNDR",$J,PRCVNM,0)=$P(PRCVND,"^",1,10)
117 ; Station number
118 S $P(^TMP("PRCVNDR",$J,PRCVNM,0),"^",11)=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
119 ;
120 ; Node 3
121 S PRCVND=$G(^PRC(440,PRCVNM,3))
122 ; Vendor EDI Indicator, EDI Number, FMS ID, ALT address indicator
123 S ^TMP("PRCVNDR",$J,PRCVNM,1)=$P(PRCVND,"^",2,5)
124 ;
125 ; Node 10
126 S PRCVND=$G(^PRC(440,PRCVNM,10))
127 ; Date inactivated
128 S $P(^TMP("PRCVNDR",$J,PRCVNM,2),"^",1)=$P(PRCVND,"^",3)
129 ; Inactivated Vendor Indicator
130 S $P(^TMP("PRCVNDR",$J,PRCVNM,2),"^",2)=$P(PRCVND,"^",5)
131 ; Contact FAX Number
132 S $P(^TMP("PRCVNDR",$J,PRCVNM,2),"^",3)=$P(PRCVND,"^",6)
133 ; Dun and Bradstreet Vendor ID
134 S $P(^TMP("PRCVNDR",$J,PRCVNM,2),"^",4)=$P($G(^PRC(440,PRCVNM,7)),"^",12)
135 ; Account Number
136 S $P(^TMP("PRCVNDR",$J,PRCVNM,2),"^",5)=$P($G(^PRC(440,PRCVNM,2)),"^")
137 ;
138 ; Node 4
139 S PRCVCNT=0 F S PRCVCNT=$O(^PRC(440,PRCVNM,4,PRCVCNT)) Q:'PRCVCNT D
140 . S PRCVND=$G(^PRC(440,PRCVNM,4,PRCVCNT,0))
141 . ; Contract Number, Expiration Date, Beginning Date
142 . S ^TMP("PRCVNDR",$J,PRCVNM,3,PRCVCNT)=$P(PRCVND,"^",1,3)
143 Q
144CKINC(PRCVF,PRCVS) ;incremental checksum
145 N PRCVL,PRCVB,PRCVC,PRCVI,PRCVAL
146 S PRCVF=+$G(PRCVF)
147 S PRCVS=$G(PRCVS)
148 ;No change on null input
149 Q:PRCVS="" PRCVF
150 S PRCVL=$L(PRCVS)
151 S PRCVAL=0
152 S PRCVB(1)=1,PRCVB(2)=1
153 F PRCVI=1:1:PRCVL D
154 .S PRCVC=$E(PRCVS,PRCVI)
155 .S:PRCVI>2 PRCVB(PRCVI)=(PRCVB(PRCVI-1)+PRCVB(PRCVI-2))#PRCVP2
156 .S PRCVAL=(PRCVF+PRCVAL+($A(PRCVC)*PRCVB(PRCVI)))#PRCVP
157 Q PRCVAL
Note: See TracBrowser for help on using the repository browser.