- 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 Feb 18, 2025@23:38:47 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