87 lines
3.3 KiB
Mathematica
87 lines
3.3 KiB
Mathematica
PRCOVUP ;WISC/DJM/AS-VENDOR UPDATE SERVER ROUTINE ;3/8/05
|
|
V ;;5.1;IFCAP;**81**;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
IN ;THIS ROUTINE WILL BE CALLED FROM THE 'FMS' SERVER VIA FILE 423.5
|
|
;ENTRY FOR THE VENDOR UPDATE TRANSACTION (VUP).
|
|
;PRCDA IS THE INTERNAL ENTRY NUMBER FOR THE RECORD FROM FILE 423.6.
|
|
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
|
|
S LINE=$G(^PRCF(423.6,PRCDA,1,10000,0))
|
|
S MGP=$O(^PRCF(423.5,"B",$P(LINE,U)_"-"_$P(LINE,U,5),0))
|
|
S MGP=$G(^PRCF(423.5,MGP,0))
|
|
S PRCMG=$P($G(^XMB(3.8,$P(MGP,U,2),0)),U)
|
|
S LOOP=10000
|
|
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
|
|
D KILL^PRCOSRV3(PRCDA)
|
|
Q
|
|
;
|
|
FIND S LINE=$G(^PRCF(423.6,PRCDA,1,LOOP,0))
|
|
Q:LINE["{"
|
|
S STATION=$P(LINE,U,4)
|
|
S STCK=$O(^PRC(411,"B",STATION,0))
|
|
I STCK'>0 S PRCXM(1)=$P($T(ERROR+1),";;",2) Q
|
|
K ACTIVE
|
|
S ENTRY=$P(LINE,U,5)
|
|
I ENTRY>0 S ACTIVE=1 D ENCK
|
|
S (ENTRY1,ALTFLG)=0
|
|
S FMS=$P(LINE,U,6)
|
|
I FMS="" S PRCXM(3)=$P($T(ERROR+3),";;",2) Q
|
|
S AAC=$P(LINE,U,7)
|
|
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
|
|
.S VEN3=$G(^PRC(440,ENTRY1,3))
|
|
.I VEN3="" S PRCXM(2)=$P($T(ERROR+2),";;",2),PRCXM(4)=LINE D PERROR^PRCOSRV3 Q
|
|
.S ALTADD=$P(VEN3,U,5) I ALTADD=AAC S ALTFLG=1
|
|
.Q
|
|
Q
|
|
;
|
|
ENCK S ALTFLG=0
|
|
S ENCK=$G(^PRC(440,ENTRY,0))
|
|
I ENCK="" S PRCXM(2)=$P($T(ERROR+2),";;",2) Q
|
|
K ^PRC(440.3,ENTRY)
|
|
S %Y="^PRC(440.3,ENTRY,"
|
|
S %X="^PRC(440,ENTRY,"
|
|
D %XY^%RCR
|
|
S VEN3=$G(^PRC(440,ENTRY,3))
|
|
I $P(LINE,U,7)]"" S $P(VEN3,U,5)=$P(LINE,U,7)
|
|
I $P(LINE,U,14)]"" S $P(VEN3,U,9)=$P(LINE,U,14)
|
|
S $P(VEN3,U,12)="C"
|
|
I $P(LINE,U,15)]"" S $P(VEN3,U,11)=$P(LINE,U,15)
|
|
I $P(LINE,U,16)]"" S $P(VEN3,U,14)=$P(LINE,U,16)
|
|
I $P(LINE,U,17)]"" S $P(VEN3,U,13)=$P(LINE,U,17)
|
|
I $P(LINE,U,19)]"" S $P(VEN3,U,15)=$P(LINE,U,19)
|
|
I $P(LINE,U,20)]"" S $P(VEN3,U,10)=$P(LINE,U,20)
|
|
;set fms vendor name (field is uneditable)
|
|
S NAME=$P(LINE,U,8)
|
|
I NAME]"" D
|
|
.F II=1:1 S AAN=$E(NAME,II) Q:AAN?1AN S NAME=$E(NAME,2,99)
|
|
.S $P(VEN3,U,7)=NAME
|
|
.Q
|
|
S VEN7=$G(^PRC(440,ENTRY,7))
|
|
I $P(LINE,U,9)]"" S $P(VEN7,U,3)=$P(LINE,U,9)
|
|
I $P(LINE,U,10)]"" S $P(VEN7,U,4)=$P(LINE,U,10)
|
|
I $P(LINE,U,11)]"" S $P(VEN7,U,7)=$P(LINE,U,11)
|
|
S ZIP=$P(LINE,U,13) I ZIP]"" D
|
|
.S $P(VEN7,U,9)=$S($L(ZIP)=9:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP)
|
|
.Q
|
|
I $P(LINE,U,12)]"" S $P(VEN7,U,8)=$O(^DIC(5,"C",$P(LINE,U,12),0))
|
|
S ^PRC(440,ENTRY,3)=VEN3
|
|
S ^PRC(440,ENTRY,7)=VEN7
|
|
S DIE="^PRC(440,"
|
|
S DA=ENTRY
|
|
S FMSVC=$P(LINE,U,6)
|
|
S DR="34////^S X=FMSVC"
|
|
S NAME=$P(ENCK,U)
|
|
S MTI="" I $P(LINE,U,19)]"" S MTI=$P(LINE,U,19)
|
|
I MTI="D" S NAME="**"_NAME,DR=DR_";.01////^S X=NAME;31.5////^S X=1;15////@"
|
|
I $G(ACTIVE),"ACF"[MTI,$E(NAME,1,2)="**" S NAME=$E(NAME,3,99),DR=DR_";.01////^S X=NAME;31.5////@;15////@"
|
|
D ^DIE
|
|
D BUL^PRCOVUP4
|
|
; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
|
|
D:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1 ONECHK^PRCVNDR(ENTRY)
|
|
K ^PRC(440.3,ENTRY),ACTIVE
|
|
Q
|
|
;
|
|
ERROR ;HERE IS THE LIST OF ERROR MESSAGES
|
|
;;The STATION number from FMS can not be found at this location.
|
|
;;The VENDOR file entry returned from FMS can not be found.
|
|
;;This FMS transaction has no FMS VENDOR CODE.
|