source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVVMF.m@ 1800

PRCVVMF ;WOIFO/DAP-DYNAMED VENDOR UPDATE HL7 MESSAGING ROUTINE; 03/02/05
 ;;5.1;IFCAP;**81**;Oct 20,2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 Q
 ;
EN(PRCVVN) ;Entry point for API Call
 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 Q
 I $D(PRCVVN)=0 Q
 N HLA
 S PRCVCNT=0,PRCVERG=0
 D HDRBLD
 I PRCVERG=1 K PRCVERG Q
 ;
 D MSGBLD
 ;
 S PRCVDP=""
 D GENERATE^HLMA(PRCVPRO,"LM",1,.PRCVDP)
 I +$P(PRCVDP,"^",2) S PRCVERR(1)="Error generating message through VistA HL7 package for Vendor Update involving vendor # "_PRCVVN D CLIFP
 ;
 K ^TMP("PRCVNDR",$J,PRCVVN)
 ;
 D FIN
 K PRCVERG
 ;
 Q
 ;
HDRBLD ;Generate message header, MFI Segment
 ;
 K HL S PRCVPRO="PRCV_IFCAP_04_EV_VEND_UPD"
 D INIT^HLFNC2(PRCVPRO,.HL)
 I $G(HL) S PRCVERR(1)="Error generating message through VistA HL7 package for Vendor Update involving vendor # "_PRCVVN D CLIFP D FIN Q
 ;
 S PRCVCS=$E(HL("ECH")),PRCVRS=$E(HL("ECH"),2),PRCVSS=$E(HL("ECH"),4),PRCVFS=HL("FS")
 ;
 ;PRCVDT Transaction Date/Time w/offset
 D NOW^%DTC
 S PRCVDT=$$FMTHL7^XLFDT(%)
 ;
 ;Build MFI Segment
 S PRCVCNT=PRCVCNT+1
 S HLA("HLS",PRCVCNT)="MFI"_PRCVFS_"OME"_PRCVFS_"440"_PRCVCS_"VENDOR"_PRCVFS_"UPD"_PRCVFS_PRCVDT_PRCVFS_PRCVFS_"AL"
 ;
 Q
 ;
MSGBLD ;Build Message Body
 ;
 ;PRCVNM Vendor Name
 S PRCVNM=$P(^TMP("PRCVNDR",$J,PRCVVN,0),"^",1)
 ;Address Fields - HL7 String Conversions
 S PRCV1="C",PRCV2=HL("FS")_HL("ECH")
 ;PRCVAD1 Address 1
 S PRCVAD1=$P(^TMP("PRCVNDR",$J,PRCVVN,0),"^",2)
 I PRCVAD1'="" D
 . S PRCVAD1=$$CONV^PRCVUTSC(PRCVAD1,PRCV1,PRCV2)
 . Q
 ;PRCVAD2 Address 2
 S PRCVAD2=$P(^TMP("PRCVNDR",$J,PRCVVN,0),"^",3)
 I PRCVAD2'="" D
 . S PRCVAD2=$$CONV^PRCVUTSC(PRCVAD2,PRCV1,PRCV2)
 . Q
 ;PRCVAD3 Address 3
 S PRCVAD3=$P(^TMP("PRCVNDR",$J,PRCVVN,0),"^",4)
 I PRCVAD3'="" D
 . S PRCVAD3=$$CONV^PRCVUTSC(PRCVAD3,PRCV1,PRCV2)
 . Q
 ;PRCVAD4 Address 4
 S PRCVAD4=$P(^TMP("PRCVNDR",$J,PRCVVN,0),"^",5)
 I PRCVAD4'="" D
 . S PRCVAD4=$$CONV^PRCVUTSC(PRCVAD4,PRCV1,PRCV2)
 . Q
 ;PRCVCT City
 S PRCVCT=$P(^TMP("PRCVNDR",$J,PRCVVN,0),"^",6)
 ;PRCVST State
 S PRCVST=$P(^TMP("PRCVNDR",$J,PRCVVN,0),"^",7)
 ;PRCVZP Zip Code
 S PRCVZP=$P(^TMP("PRCVNDR",$J,PRCVVN,0),"^",8)
 ;PRCVCPS Contact Person
 S PRCVCPS=$P(^TMP("PRCVNDR",$J,PRCVVN,0),"^",9)
 ;PRCVCPH Contact Phone #
 S PRCVCPH=$P(^TMP("PRCVNDR",$J,PRCVVN,0),"^",10)
 ;PRCVSTAT Station #
 S PRCVSTAT=$P(^TMP("PRCVNDR",$J,PRCVVN,0),"^",11)
 ;PRCVEDI Vendor EDI #
 S PRCVEDI=$P(^TMP("PRCVNDR",$J,PRCVVN,1),"^",2)
 ;PRCVFMS Vendor FMS #
 S PRCVFMS=$P(^TMP("PRCVNDR",$J,PRCVVN,1),"^",3)
 ;PRCVALT Alternate Address Indicator
 S PRCVALT=$P(^TMP("PRCVNDR",$J,PRCVVN,1),"^",4)
 ;PRCVINA Inactivation Date
 S PRCVINA=$P(^TMP("PRCVNDR",$J,PRCVVN,2),"^",1)
 I PRCVINA'="" S PRCVINA=$$FMTHL7^XLFDT(PRCVINA)
 ;PRCVCFX Contact FAX #
 S PRCVCFX=$P(^TMP("PRCVNDR",$J,PRCVVN,2),"^",3)
 ;PRCVDNB Dun and Bradstreet #
 S PRCVDNB=$P(^TMP("PRCVNDR",$J,PRCVVN,2),"^",4)
 ;PRCVACN Account Number
 S PRCVACN=$P(^TMP("PRCVNDR",$J,PRCVVN,2),"^",5)
 ;
 ;Handling Repeating Contract Number Array and Building HL7 Field ZVD.6
 S N=0,B=0,PRCVCNA="" F  S N=$O(^TMP("PRCVNDR",$J,PRCVVN,3,N)) Q:+N=0  D
 . S PRCVED=$P(^TMP("PRCVNDR",$J,PRCVVN,3,N),"^",2)
 . S V=$$FMADD^XLFDT(PRCVED,366) I (%<V)!(PRCVED="") D
 .. S B=B+1,PRCVCN=$P(^TMP("PRCVNDR",$J,PRCVVN,3,N),"^",1)
 .. S PRCVBD=$P(^TMP("PRCVNDR",$J,PRCVVN,3,N),"^",3)
 .. I PRCVBD'="" S PRCVBD=$$FMTHL7^XLFDT(PRCVBD)
 .. I PRCVED'="" S PRCVED=$$FMTHL7^XLFDT(PRCVED)
 .. S PRCVCNA(B)=PRCVRS_PRCVCN_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVBD_PRCVCS_PRCVED
 .. Q
 . Q
 ;
 I $D(PRCVCNA(1)) S PRCVCNA(1)=$P(PRCVCNA(1),PRCVRS,2)
 ;
 ;Build MFE Segment
 S PRCVCNT=PRCVCNT+1
 S HLA("HLS",PRCVCNT)="MFE"_PRCVFS_"MUP"_PRCVFS_PRCVVN_PRCVFS_PRCVFS_PRCVVN_PRCVCS_PRCVNM_PRCVCS_PRCVSTAT_PRCVFS_"CE"
 ;
 ;Build ZVD Segment
 S PRCVCNT=PRCVCNT+1,R=0
 S HLA("HLS",PRCVCNT)="ZVD"_PRCVFS_PRCVNM_PRCVCS_PRCVCS_PRCVVN_PRCVCS_PRCVCS_PRCVCS_PRCVCS_"IFCAP"_PRCVCS_PRCVSTAT_PRCVRS_PRCVNM_PRCVCS_PRCVCS_PRCVEDI_PRCVCS_PRCVCS_PRCVCS_PRCVCS_"EDI"_PRCVCS_PRCVSTAT_PRCVRS
 S HLA("HLS",PRCVCNT)=HLA("HLS",PRCVCNT)_PRCVNM_PRCVCS_PRCVCS_PRCVFMS_PRCVCS_PRCVCS_PRCVCS_PRCVCS_"FMS"_PRCVCS_PRCVSTAT_PRCVRS_PRCVNM_PRCVCS_PRCVCS_PRCVDNB_PRCVCS_PRCVCS_PRCVCS_PRCVCS_"Dun and Bradstreet"_PRCVCS_PRCVSTAT
 S HLA("HLS",PRCVCNT,1)=PRCVFS_PRCVAD1_PRCVSS_PRCVAD2_PRCVSS_PRCVAD3_PRCVSS_PRCVAD4_PRCVCS_PRCVCS_PRCVCT_PRCVCS_PRCVST_PRCVCS_PRCVZP_PRCVFS_PRCVACN_PRCVFS_PRCVCPS_PRCVFS
 S HLA("HLS",PRCVCNT,2)=PRCVCPH_PRCVCS_PRCVCS_"PH"_PRCVRS_PRCVCFX_PRCVCS_PRCVCS_"FX"_PRCVFS_PRCVCS_PRCVINA_PRCVFS
 ;
 I $D(PRCVCNA) S W=0,R=2 F  S W=$O(PRCVCNA(W)) Q:+W=0  D
 . S R=R+1
 . S HLA("HLS",PRCVCNT,R)=PRCVCNA(W)
 . Q
 ;
 I R<2 S R=2
 S HLA("HLS",PRCVCNT,R+1)=PRCVFS_PRCVALT
 ;
 Q
 ;
MFKPROC ;Process MFK^M01 response message
 ;
 ;Uses HLNEXT twice to bypass the MSH segment and go directly to the MSA segment
 X HLNEXT
 ;
 X HLNEXT
 S VAL=$$FLD^HLCSUTL(HLNODE,2)
 I VAL'="AA" D ERROR
 ;
 D FIN
 ;
 Q
 ;
ERROR ;Process ERR Segments
 S PRCVERC=2,PRCVERR(1)="Unable to update Vendor in DynaMed."
 S PRCVERR(2)="During a Vendor Update to DynaMed the following errors occurred:"
 F M=1:1 X HLNEXT Q:HLQUIT'>0  D
 . S VAL=$$FLD^HLCSUTL(HLNODE,1)
 . I VAL="MFA" S PRCVME=$$FLD^HLCSUTL(HLNODE,3)
 . I VAL="ERR" D
 .. S PRCVERC=PRCVERC+1,PRCVERM=$$FLD^HLCSUTL(HLNODE,6)
 .. S PRCVERR(PRCVERC)=$P(PRCVERM,"^",2)
 .. Q
 . Q
 ;
 D CLIFP
 ;
 Q
 ;
CLIFP ;Call partner app w/ mail message for users on error
 N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
 S XMSUB="DynaMed Vendor # "_PRCVME_" Update Errors "_$$HTE^XLFDT($H)
 S XMDUZ="IFCAP/COTS Inventory Interface"
 S XMTEXT="PRCVERR("
 S XMY("G.PRCV Item Vendor Edits")=""
 ;
 D ^XMD
 S PRCVERG=1
 ;
 Q
 ;
FIN ;Clean up variables
 K PRCVVN,PRCVCNT,PRCVDP,PRCVPRO,HL,PRCVCS,PRCVRS,PRCVFS,PRCVDT,%,PRCVNM,PRCVAD1,PRCVAD2,PRCVAD3,PRCVAD4,PRCVME
 K PRCVCT,PRCVST,PRCVZP,PRCVCPS,PRCVCPH,PRCVSTAT,PRCVEDI,PRCVFMS,PRCVALT,PRCVINA,PRCVCFX,PRCVDNB,PRCVACN
 K N,PRCVCNA,PRCVCN,PRCVBD,PRCVED,VAL,PRCVERC,PRCVERM,PRCVERR,PRCV1,PRCV2,STR1,PRCVSS,V,W,R,B,M
 ;
 Q