Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCOVUP

PRCOVUP.m

Go to the documentation of this file.
  1. PRCOVUP ;WISC/DJM/AS-VENDOR UPDATE SERVER ROUTINE ; 17 Dec 2009 11:05 AM
  1. V ;;5.1;IFCAP;**81,144,211**;Oct 20, 2000;Build 9
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;;
  1. ;PRC*5.1*211 Status update to VR document found in ^GECS(2100.1
  1. ; when 'VUP' record returned and processed by Vista
  1. ;
  1. IN ;THIS ROUTINE WILL BE CALLED FROM THE 'FMS' SERVER VIA FILE 423.5
  1. ;ENTRY FOR THE VENDOR UPDATE TRANSACTION (VUP).
  1. ;PRCDA IS THE INTERNAL ENTRY NUMBER FOR THE RECORD FROM FILE 423.6.
  1. 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
  1. S LINE=$G(^PRCF(423.6,PRCDA,1,10000,0))
  1. S MGP=$O(^PRCF(423.5,"B",$P(LINE,U)_"-"_$P(LINE,U,5),0))
  1. S MGP=$G(^PRCF(423.5,MGP,0))
  1. S PRCMG=$P($G(^XMB(3.8,$P(MGP,U,2),0)),U)
  1. S LOOP=10000
  1. 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
  1. D KILL^PRCOSRV3(PRCDA)
  1. Q
  1. ;
  1. FIND S LINE=$G(^PRCF(423.6,PRCDA,1,LOOP,0))
  1. Q:LINE["{"
  1. S STATION=$P(LINE,U,4)
  1. I STATION="" S PRCXM(1)=$P($T(ERROR+4),";;",2) Q
  1. S STCK=$O(^PRC(411,"B",STATION,0))
  1. I STCK'>0 S PRCXM(1)=$P($T(ERROR+1),";;",2) Q
  1. K ACTIVE
  1. S ENTRY=$P(LINE,U,5)
  1. I ENTRY>0 S ACTIVE=1 D ENCK
  1. S (ENTRY1,ALTFLG)=0
  1. S FMS=$P(LINE,U,6)
  1. I FMS="" S PRCXM(3)=$P($T(ERROR+3),";;",2) Q
  1. S AAC=$P(LINE,U,7)
  1. 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
  1. .S VEN3=$G(^PRC(440,ENTRY1,3))
  1. .I VEN3="" S PRCXM(2)=$P($T(ERROR+2),";;",2),PRCXM(4)=LINE D PERROR Q
  1. .S ALTADD=$P(VEN3,U,5) I ALTADD=AAC S ALTFLG=1
  1. .Q
  1. Q
  1. ;
  1. ENCK S ALTFLG=0
  1. S ENCK=$G(^PRC(440,ENTRY,0))
  1. I ENCK="" S PRCXM(2)=$P($T(ERROR+2),";;",2) Q
  1. K ^PRC(440.3,ENTRY)
  1. S %Y="^PRC(440.3,ENTRY,"
  1. S %X="^PRC(440,ENTRY,"
  1. D %XY^%RCR
  1. S VEN3=$G(^PRC(440,ENTRY,3))
  1. I $P(LINE,U,7)]"" S $P(VEN3,U,5)=$P(LINE,U,7)
  1. I $P(LINE,U,14)]"" S $P(VEN3,U,9)=$P(LINE,U,14)
  1. S $P(VEN3,U,12)="C"
  1. I $P(LINE,U,15)]"" S $P(VEN3,U,11)=$P(LINE,U,15)
  1. I $P(LINE,U,16)]"" S $P(VEN3,U,14)=$P(LINE,U,16)
  1. I $P(LINE,U,17)]"" S $P(VEN3,U,13)=$P(LINE,U,17)
  1. I $P(LINE,U,19)]"" S $P(VEN3,U,15)=$P(LINE,U,19)
  1. I $P(LINE,U,20)]"" S $P(VEN3,U,10)=$P(LINE,U,20)
  1. ;set fms vendor name (field is uneditable)
  1. S NAME=$P(LINE,U,8)
  1. I NAME]"" D
  1. .F II=1:1 S AAN=$E(NAME,II) Q:AAN?1AN S NAME=$E(NAME,2,99)
  1. .S $P(VEN3,U,7)=NAME
  1. .Q
  1. S VEN7=$G(^PRC(440,ENTRY,7))
  1. I $P(LINE,U,9)]"" S $P(VEN7,U,3)=$P(LINE,U,9)
  1. I $P(LINE,U,10)]"" S $P(VEN7,U,4)=$P(LINE,U,10)
  1. I $P(LINE,U,11)]"" S $P(VEN7,U,7)=$P(LINE,U,11)
  1. S ZIP=$P(LINE,U,13) I ZIP]"" D
  1. .S $P(VEN7,U,9)=$S($L(ZIP)=9:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP)
  1. .Q
  1. I $P(LINE,U,12)]"" S $P(VEN7,U,8)=$O(^DIC(5,"C",$P(LINE,U,12),0))
  1. S ^PRC(440,ENTRY,3)=VEN3
  1. S ^PRC(440,ENTRY,7)=VEN7
  1. ;Set file 2100.1 corresponding vendor update doc to accepted PRC*5.1*211
  1. N PRCGEC1,PRCGEC2,PRCGECX
  1. S PRCGEC1="VR-6939999999999",PRCGECEX=0,U="^" ;PRC*5.1*211
  1. F S PRCGEC1=$O(^GECS(2100.1,"B",PRCGEC1),-1) Q:PRCGEC1'["VR"!(PRCGEC1="") D Q:PRCGECEX ;PRC*5.1*211
  1. . S PRCGEC2=$O(^GECS(2100.1,"B",PRCGEC1,0)) Q:'PRCGEC2
  1. . I $P(^GECS(2100.1,PRCGEC2,10,2,0),U,5)'=ENTRY Q
  1. . S PRCGECEX=1
  1. . S DA=PRCGEC2,DR="3///"_"A",DIE="^GECS(2100.1," D ^DIE K DA,DR,DIE
  1. S DIE="^PRC(440,"
  1. S DA=ENTRY
  1. S FMSVC=$P(LINE,U,6)
  1. S DR="34////^S X=FMSVC"
  1. S NAME=$P(ENCK,U)
  1. S MTI="" I $P(LINE,U,19)]"" S MTI=$P(LINE,U,19)
  1. I MTI="D" S NAME="**"_NAME,DR=DR_";.01////^S X=NAME;31.5////^S X=1;15////@"
  1. I $G(ACTIVE),"ACF"[MTI,$E(NAME,1,2)="**" S NAME=$E(NAME,3,99),DR=DR_";.01////^S X=NAME;31.5////@;15////@"
  1. D ^DIE
  1. D BUL^PRCOVUP4
  1. ; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
  1. D:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1 ONECHK^PRCVNDR(ENTRY)
  1. K ^PRC(440.3,ENTRY),ACTIVE
  1. Q
  1. ;
  1. ERROR ;HERE IS THE LIST OF ERROR MESSAGES
  1. ;;The STATION number from FMS cannot be found at this location.
  1. ;;The VENDOR file entry returned from FMS cannot be found.
  1. ;;This FMS transaction has no FMS VENDOR CODE.
  1. ;;The Station number is missing. Possible corrupt record.
  1. ;;There is no mailgroup listed for CTL-VUP in file 423.5.
  1. ;
  1. PERROR ; Process Errors for VUP type records
  1. N PRCEND,XMB,XMCHAN,XMDUN,XMDUZ,XMSUB,XMTEXT,XMY,XMZ
  1. S PRCEND=""
  1. I $D(PRCMG) S:PRCMG'["G." PRCMG="G."_PRCMG
  1. S XMDUZ="IFCAP FMS MESSAGE SERVER",XMCHAN=1
  1. I '$D(PRCMG) S PRCXM(2)=$P($T(ERROR+5),";;",2),XMY(.5)=""
  1. D EMFORM S XMDUN="IFCAP SERVER ERROR"
  1. S XMSUB="Vendor Update Transaction (VUP)"
  1. S XMTEXT="PRCXM(",XMY(PRCMG)=""
  1. D ^XMD
  1. K PRCXM
  1. Q
  1. ;
  1. EMFORM ; Error message formatter
  1. I $D(PRCDA),$D(^PRCF(423.6,PRCDA,1,10000,0)) N I,J D
  1. .N THDR,TDATE,Y S THDR=^PRCF(423.6,PRCDA,1,10000,0)
  1. .S Y=$P(THDR,U,10),Y=($E(Y,1,4)-1700)_$E(Y,5,8) D DD^%DT S TDATE=Y
  1. .F I=1:1 S J=$O(PRCXM(I)) Q:J=""
  1. .S I=I+1,PRCXM(I)=" ",I=I+1,PRCXM(I)=" System ID: "_$P(THDR,U,2),I=I+1
  1. .S PRCXM(I)=" ",I=I+1,PRCXM(I)=" Receiving Station #: "_$P(THDR,U,4)_" "_"Transaction Code : "_$P(THDR,U,5),I=I+1
  1. .S PRCXM(I)=" ",I=I+1,PRCXM(I)=" Transaction Date : "_TDATE_" "_"Transaction Time : "_$E($P(THDR,U,11),1,2)_":"_$E($P(THDR,U,11),3,4)_":"_$E($P(THDR,U,11),5,6),I=I+1
  1. .S PRCXM(I)=" ",I=I+1,PRCXM(I)=" Interface Version #: "_$P(THDR,U,14),I=I+1
  1. .Q
  1. Q