PRCVNDR ;WOIFO/AS-SEND VENDOR UPDATE INFOMATION TO DYNAMED ; 2/21/05 5:07pm
;;5.1;IFCAP;**81**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
NITECHK ;
; Once a day check
; Compare checksum and set flag to updated record
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)'=1 Q
N PRCVP,PRCVP2,PRCVAL,PRCVND,PRCVN,NOD,PRCVST,PRCVCNT
S PRCVP=67280421310721,PRCVP2=2147483647,PRCVN=0
S NOD=+$O(^PRCV(414.04,"D","VENDOR",0))
F S PRCVN=$O(^PRC(440,PRCVN)) Q:'PRCVN D
. S PRCVAL=$$CHKSUM()
. ; Compare to existing CheckSum
. ; Set a flag if the not the same
. I PRCVAL,PRCVAL'=$P($G(^PRCV(414.04,NOD,1,PRCVN,0)),"^",2) D
.. S ^PRCV(414.04,NOD,1,PRCVN,0)=PRCVN_"^"_PRCVAL
.. D GETDATA(PRCVN)
.. I $D(^TMP("PRCVNDR",$J,PRCVN)) D EN^PRCVVMF(PRCVN)
.. K ^TMP("PRCVNDR",$J)
Q
ONECHK(PRCVN) ;
; Checksum to one vendor only
N PRCVP,PRCVP2,PRCVAL,PRCVND,NOD,PRCVST,PRCVCNT
S PRCVP=67280421310721,PRCVP2=2147483647
S NOD=+$O(^PRCV(414.04,"D","VENDOR",0))
S PRCVAL=$$CHKSUM
; If checksum not equal to original record, get data to DynaMed
I PRCVAL,PRCVAL'=$P($G(^PRCV(414.04,NOD,1,PRCVN,0)),"^",2) D
. S ^PRCV(414.04,NOD,1,PRCVN,0)=PRCVN_"^"_PRCVAL
. D GETDATA(PRCVN)
. I $D(^TMP("PRCVNDR",$J,PRCVN)) D EN^PRCVVMF(PRCVN)
. K ^TMP("PRCVNDR",$J)
Q
INIT ;
; Initialize checksum global at installation
NEW FDA,RESULT,PRCVN,PRCVP,PRCVP2,PRCVAL,PRCVST,PRCVCNT
S FDA(414.04,"?+1,",.01)="VENDOR"
S FDA(414.04,"?+1,",.02)=440
S FDA(414.04,"?+1,",.03)="Vendor file checksum (on partial field)"
D UPDATE^DIE("E","FDA","RESULT")
S PRCVP=67280421310721,PRCVP2=2147483647,PRCVN=0
F S PRCVN=$O(^PRC(440,PRCVN)) Q:'PRCVN D
. S FDA(414.41,"?+1,"_RESULT(1)_",",.01)=PRCVN
. S FDA(414.41,"?+1,"_RESULT(1)_",",1)=$$CHKSUM()
. D UPDATE^DIE("E","FDA")
Q
CHKSUM() ;
S PRCVAL=0
; Node 0
S PRCVND=$G(^PRC(440,PRCVN,0))
; Vendor Name
S PRCVST=$P(PRCVND,"^",1),PRCVAL=$$CKINC(PRCVAL,PRCVST)
; Ordering Address 1
S PRCVST=$P(PRCVND,"^",2),PRCVAL=$$CKINC(PRCVAL,PRCVST)
; Ordering Address 2
S PRCVST=$P(PRCVND,"^",3),PRCVAL=$$CKINC(PRCVAL,PRCVST)
; Ordering Address 3
S PRCVST=$P(PRCVND,"^",4),PRCVAL=$$CKINC(PRCVAL,PRCVST)
; Ordering Address 4
S PRCVST=$P(PRCVND,"^",5),PRCVAL=$$CKINC(PRCVAL,PRCVST)
; Ordering City
S PRCVST=$P(PRCVND,"^",6),PRCVAL=$$CKINC(PRCVAL,PRCVST)
; Ordering State
S PRCVST=$P(PRCVND,"^",7),PRCVAL=$$CKINC(PRCVAL,PRCVST)
; Ordering Zip Code
S PRCVST=$P(PRCVND,"^",8),PRCVAL=$$CKINC(PRCVAL,PRCVST)
; Contact Person
S PRCVST=$P(PRCVND,"^",9),PRCVAL=$$CKINC(PRCVAL,PRCVST)
; Contact Phone Number
S PRCVST=$P(PRCVND,"^",10),PRCVAL=$$CKINC(PRCVAL,PRCVST)
;
; Node 3
S PRCVND=$G(^PRC(440,PRCVN,3))
; Vendor EDI Indicator
S PRCVST=$P(PRCVND,"^",2),PRCVAL=$$CKINC(PRCVAL,PRCVST)
; EDI Vendor Number
S PRCVST=$P(PRCVND,"^",3),PRCVAL=$$CKINC(PRCVAL,PRCVST)
; FMS Vendor ID
S PRCVST=$P(PRCVND,"^",4),PRCVAL=$$CKINC(PRCVAL,PRCVST)
; Alternate Address Indicator
S PRCVST=$P(PRCVND,"^",5),PRCVAL=$$CKINC(PRCVAL,PRCVST)
;
; Node 10
S PRCVND=$G(^PRC(440,PRCVN,10))
; Contact FAX Number
S PRCVST=$P(PRCVND,"^",6),PRCVAL=$$CKINC(PRCVAL,PRCVST)
; Inactivated Vendor Indicator
S PRCVST=$P(PRCVND,"^",5),PRCVAL=$$CKINC(PRCVAL,PRCVST)
; Date Inactivated
S PRCVST=$P(PRCVND,"^",3),PRCVAL=$$CKINC(PRCVAL,PRCVST)
;
; Dun and Bradstreet Vendor ID
S PRCVST=$P($G(^PRC(440,PRCVN,7)),"^",12),PRCVAL=$$CKINC(PRCVAL,PRCVST)
; Account Number
S PRCVST=$P($G(^PRC(440,PRCVN,2)),"^",1),PRCVAL=$$CKINC(PRCVAL,PRCVST)
;
; Node 4
S PRCVCNT=0 F S PRCVCNT=$O(^PRC(440,PRCVN,4,PRCVCNT)) Q:'PRCVCNT D
. S PRCVND=$G(^PRC(440,PRCVN,4,PRCVCNT,0))
. ; Contract Number
. S PRCVST=$P(PRCVND,"^",1),PRCVAL=$$CKINC(PRCVAL,PRCVST)
. ; Contract Expiration Date
. S PRCVST=$P(PRCVND,"^",2),PRCVAL=$$CKINC(PRCVAL,PRCVST)
. ; Contract Beginning Date
. S PRCVST=$P(PRCVND,"^",3),PRCVAL=$$CKINC(PRCVAL,PRCVST)
Q PRCVAL
;
GETDATA(PRCVNM) ;
; Get all field required,
; Node 0
S PRCVND=$G(^PRC(440,PRCVNM,0))
; State
S $P(PRCVND,"^",7)=$P($G(^DIC(5,+$P(PRCVND,"^",7),0)),"^",2)
; Name, Address 1, 2, 3, 4, City, State, Zip, Contact Person, Phone
S ^TMP("PRCVNDR",$J,PRCVNM,0)=$P(PRCVND,"^",1,10)
; Station number
S $P(^TMP("PRCVNDR",$J,PRCVNM,0),"^",11)=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
;
; Node 3
S PRCVND=$G(^PRC(440,PRCVNM,3))
; Vendor EDI Indicator, EDI Number, FMS ID, ALT address indicator
S ^TMP("PRCVNDR",$J,PRCVNM,1)=$P(PRCVND,"^",2,5)
;
; Node 10
S PRCVND=$G(^PRC(440,PRCVNM,10))
; Date inactivated
S $P(^TMP("PRCVNDR",$J,PRCVNM,2),"^",1)=$P(PRCVND,"^",3)
; Inactivated Vendor Indicator
S $P(^TMP("PRCVNDR",$J,PRCVNM,2),"^",2)=$P(PRCVND,"^",5)
; Contact FAX Number
S $P(^TMP("PRCVNDR",$J,PRCVNM,2),"^",3)=$P(PRCVND,"^",6)
; Dun and Bradstreet Vendor ID
S $P(^TMP("PRCVNDR",$J,PRCVNM,2),"^",4)=$P($G(^PRC(440,PRCVNM,7)),"^",12)
; Account Number
S $P(^TMP("PRCVNDR",$J,PRCVNM,2),"^",5)=$P($G(^PRC(440,PRCVNM,2)),"^")
;
; Node 4
S PRCVCNT=0 F S PRCVCNT=$O(^PRC(440,PRCVNM,4,PRCVCNT)) Q:'PRCVCNT D
. S PRCVND=$G(^PRC(440,PRCVNM,4,PRCVCNT,0))
. ; Contract Number, Expiration Date, Beginning Date
. S ^TMP("PRCVNDR",$J,PRCVNM,3,PRCVCNT)=$P(PRCVND,"^",1,3)
Q
CKINC(PRCVF,PRCVS) ;incremental checksum
N PRCVL,PRCVB,PRCVC,PRCVI,PRCVAL
S PRCVF=+$G(PRCVF)
S PRCVS=$G(PRCVS)
;No change on null input
Q:PRCVS="" PRCVF
S PRCVL=$L(PRCVS)
S PRCVAL=0
S PRCVB(1)=1,PRCVB(2)=1
F PRCVI=1:1:PRCVL D
.S PRCVC=$E(PRCVS,PRCVI)
.S:PRCVI>2 PRCVB(PRCVI)=(PRCVB(PRCVI-1)+PRCVB(PRCVI-2))#PRCVP2
.S PRCVAL=(PRCVF+PRCVAL+($A(PRCVC)*PRCVB(PRCVI)))#PRCVP
Q PRCVAL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCVNDR 5815 printed Sep 23, 2025@19:56:13 Page 2
PRCVNDR ;WOIFO/AS-SEND VENDOR UPDATE INFOMATION TO DYNAMED ; 2/21/05 5:07pm
+1 ;;5.1;IFCAP;**81**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
NITECHK ;
+1 ; Once a day check
+2 ; Compare checksum and set flag to updated record
+3 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)'=1
QUIT
+4 NEW PRCVP,PRCVP2,PRCVAL,PRCVND,PRCVN,NOD,PRCVST,PRCVCNT
+5 SET PRCVP=67280421310721
SET PRCVP2=2147483647
SET PRCVN=0
+6 SET NOD=+$ORDER(^PRCV(414.04,"D","VENDOR",0))
+7 FOR
SET PRCVN=$ORDER(^PRC(440,PRCVN))
if 'PRCVN
QUIT
Begin DoDot:1
+8 SET PRCVAL=$$CHKSUM()
+9 ; Compare to existing CheckSum
+10 ; Set a flag if the not the same
+11 IF PRCVAL
IF PRCVAL'=$PIECE($GET(^PRCV(414.04,NOD,1,PRCVN,0)),"^",2)
Begin DoDot:2
+12 SET ^PRCV(414.04,NOD,1,PRCVN,0)=PRCVN_"^"_PRCVAL
+13 DO GETDATA(PRCVN)
+14 IF $DATA(^TMP("PRCVNDR",$JOB,PRCVN))
DO EN^PRCVVMF(PRCVN)
+15 KILL ^TMP("PRCVNDR",$JOB)
End DoDot:2
End DoDot:1
+16 QUIT
ONECHK(PRCVN) ;
+1 ; Checksum to one vendor only
+2 NEW PRCVP,PRCVP2,PRCVAL,PRCVND,NOD,PRCVST,PRCVCNT
+3 SET PRCVP=67280421310721
SET PRCVP2=2147483647
+4 SET NOD=+$ORDER(^PRCV(414.04,"D","VENDOR",0))
+5 SET PRCVAL=$$CHKSUM
+6 ; If checksum not equal to original record, get data to DynaMed
+7 IF PRCVAL
IF PRCVAL'=$PIECE($GET(^PRCV(414.04,NOD,1,PRCVN,0)),"^",2)
Begin DoDot:1
+8 SET ^PRCV(414.04,NOD,1,PRCVN,0)=PRCVN_"^"_PRCVAL
+9 DO GETDATA(PRCVN)
+10 IF $DATA(^TMP("PRCVNDR",$JOB,PRCVN))
DO EN^PRCVVMF(PRCVN)
+11 KILL ^TMP("PRCVNDR",$JOB)
End DoDot:1
+12 QUIT
INIT ;
+1 ; Initialize checksum global at installation
+2 NEW FDA,RESULT,PRCVN,PRCVP,PRCVP2,PRCVAL,PRCVST,PRCVCNT
+3 SET FDA(414.04,"?+1,",.01)="VENDOR"
+4 SET FDA(414.04,"?+1,",.02)=440
+5 SET FDA(414.04,"?+1,",.03)="Vendor file checksum (on partial field)"
+6 DO UPDATE^DIE("E","FDA","RESULT")
+7 SET PRCVP=67280421310721
SET PRCVP2=2147483647
SET PRCVN=0
+8 FOR
SET PRCVN=$ORDER(^PRC(440,PRCVN))
if 'PRCVN
QUIT
Begin DoDot:1
+9 SET FDA(414.41,"?+1,"_RESULT(1)_",",.01)=PRCVN
+10 SET FDA(414.41,"?+1,"_RESULT(1)_",",1)=$$CHKSUM()
+11 DO UPDATE^DIE("E","FDA")
End DoDot:1
+12 QUIT
CHKSUM() ;
+1 SET PRCVAL=0
+2 ; Node 0
+3 SET PRCVND=$GET(^PRC(440,PRCVN,0))
+4 ; Vendor Name
+5 SET PRCVST=$PIECE(PRCVND,"^",1)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+6 ; Ordering Address 1
+7 SET PRCVST=$PIECE(PRCVND,"^",2)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+8 ; Ordering Address 2
+9 SET PRCVST=$PIECE(PRCVND,"^",3)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+10 ; Ordering Address 3
+11 SET PRCVST=$PIECE(PRCVND,"^",4)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+12 ; Ordering Address 4
+13 SET PRCVST=$PIECE(PRCVND,"^",5)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+14 ; Ordering City
+15 SET PRCVST=$PIECE(PRCVND,"^",6)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+16 ; Ordering State
+17 SET PRCVST=$PIECE(PRCVND,"^",7)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+18 ; Ordering Zip Code
+19 SET PRCVST=$PIECE(PRCVND,"^",8)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+20 ; Contact Person
+21 SET PRCVST=$PIECE(PRCVND,"^",9)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+22 ; Contact Phone Number
+23 SET PRCVST=$PIECE(PRCVND,"^",10)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+24 ;
+25 ; Node 3
+26 SET PRCVND=$GET(^PRC(440,PRCVN,3))
+27 ; Vendor EDI Indicator
+28 SET PRCVST=$PIECE(PRCVND,"^",2)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+29 ; EDI Vendor Number
+30 SET PRCVST=$PIECE(PRCVND,"^",3)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+31 ; FMS Vendor ID
+32 SET PRCVST=$PIECE(PRCVND,"^",4)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+33 ; Alternate Address Indicator
+34 SET PRCVST=$PIECE(PRCVND,"^",5)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+35 ;
+36 ; Node 10
+37 SET PRCVND=$GET(^PRC(440,PRCVN,10))
+38 ; Contact FAX Number
+39 SET PRCVST=$PIECE(PRCVND,"^",6)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+40 ; Inactivated Vendor Indicator
+41 SET PRCVST=$PIECE(PRCVND,"^",5)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+42 ; Date Inactivated
+43 SET PRCVST=$PIECE(PRCVND,"^",3)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+44 ;
+45 ; Dun and Bradstreet Vendor ID
+46 SET PRCVST=$PIECE($GET(^PRC(440,PRCVN,7)),"^",12)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+47 ; Account Number
+48 SET PRCVST=$PIECE($GET(^PRC(440,PRCVN,2)),"^",1)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+49 ;
+50 ; Node 4
+51 SET PRCVCNT=0
FOR
SET PRCVCNT=$ORDER(^PRC(440,PRCVN,4,PRCVCNT))
if 'PRCVCNT
QUIT
Begin DoDot:1
+52 SET PRCVND=$GET(^PRC(440,PRCVN,4,PRCVCNT,0))
+53 ; Contract Number
+54 SET PRCVST=$PIECE(PRCVND,"^",1)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+55 ; Contract Expiration Date
+56 SET PRCVST=$PIECE(PRCVND,"^",2)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
+57 ; Contract Beginning Date
+58 SET PRCVST=$PIECE(PRCVND,"^",3)
SET PRCVAL=$$CKINC(PRCVAL,PRCVST)
End DoDot:1
+59 QUIT PRCVAL
+60 ;
GETDATA(PRCVNM) ;
+1 ; Get all field required,
+2 ; Node 0
+3 SET PRCVND=$GET(^PRC(440,PRCVNM,0))
+4 ; State
+5 SET $PIECE(PRCVND,"^",7)=$PIECE($GET(^DIC(5,+$PIECE(PRCVND,"^",7),0)),"^",2)
+6 ; Name, Address 1, 2, 3, 4, City, State, Zip, Contact Person, Phone
+7 SET ^TMP("PRCVNDR",$JOB,PRCVNM,0)=$PIECE(PRCVND,"^",1,10)
+8 ; Station number
+9 SET $PIECE(^TMP("PRCVNDR",$JOB,PRCVNM,0),"^",11)=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+10 ;
+11 ; Node 3
+12 SET PRCVND=$GET(^PRC(440,PRCVNM,3))
+13 ; Vendor EDI Indicator, EDI Number, FMS ID, ALT address indicator
+14 SET ^TMP("PRCVNDR",$JOB,PRCVNM,1)=$PIECE(PRCVND,"^",2,5)
+15 ;
+16 ; Node 10
+17 SET PRCVND=$GET(^PRC(440,PRCVNM,10))
+18 ; Date inactivated
+19 SET $PIECE(^TMP("PRCVNDR",$JOB,PRCVNM,2),"^",1)=$PIECE(PRCVND,"^",3)
+20 ; Inactivated Vendor Indicator
+21 SET $PIECE(^TMP("PRCVNDR",$JOB,PRCVNM,2),"^",2)=$PIECE(PRCVND,"^",5)
+22 ; Contact FAX Number
+23 SET $PIECE(^TMP("PRCVNDR",$JOB,PRCVNM,2),"^",3)=$PIECE(PRCVND,"^",6)
+24 ; Dun and Bradstreet Vendor ID
+25 SET $PIECE(^TMP("PRCVNDR",$JOB,PRCVNM,2),"^",4)=$PIECE($GET(^PRC(440,PRCVNM,7)),"^",12)
+26 ; Account Number
+27 SET $PIECE(^TMP("PRCVNDR",$JOB,PRCVNM,2),"^",5)=$PIECE($GET(^PRC(440,PRCVNM,2)),"^")
+28 ;
+29 ; Node 4
+30 SET PRCVCNT=0
FOR
SET PRCVCNT=$ORDER(^PRC(440,PRCVNM,4,PRCVCNT))
if 'PRCVCNT
QUIT
Begin DoDot:1
+31 SET PRCVND=$GET(^PRC(440,PRCVNM,4,PRCVCNT,0))
+32 ; Contract Number, Expiration Date, Beginning Date
+33 SET ^TMP("PRCVNDR",$JOB,PRCVNM,3,PRCVCNT)=$PIECE(PRCVND,"^",1,3)
End DoDot:1
+34 QUIT
CKINC(PRCVF,PRCVS) ;incremental checksum
+1 NEW PRCVL,PRCVB,PRCVC,PRCVI,PRCVAL
+2 SET PRCVF=+$GET(PRCVF)
+3 SET PRCVS=$GET(PRCVS)
+4 ;No change on null input
+5 if PRCVS=""
QUIT PRCVF
+6 SET PRCVL=$LENGTH(PRCVS)
+7 SET PRCVAL=0
+8 SET PRCVB(1)=1
SET PRCVB(2)=1
+9 FOR PRCVI=1:1:PRCVL
Begin DoDot:1
+10 SET PRCVC=$EXTRACT(PRCVS,PRCVI)
+11 if PRCVI>2
SET PRCVB(PRCVI)=(PRCVB(PRCVI-1)+PRCVB(PRCVI-2))#PRCVP2
+12 SET PRCVAL=(PRCVF+PRCVAL+($ASCII(PRCVC)*PRCVB(PRCVI)))#PRCVP
End DoDot:1
+13 QUIT PRCVAL
