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