- MPIFBT2 ;SLC/ARS-BATCH RESPONSE FROM MPI ;FEB 4, 1997
- ;;1.0; MASTER PATIENT INDEX VISTA ;**1,3,10,17,21,31,43,53**;30 Apr 99;Build 1
- ;
- ; Integration Agreements Utilized:
- ; ^DGCN(391.91 - #2751
- ; EXC, START, STOP ^RGHLLOG - #2796
- ; XMITFLAG^VAFCDD01 - #3493
- ; $$PIVNW^VAFHPIVT - #3494
- ;
- ADDPAT ;Called when response from MPI is received for messages sent.
- K ^XTMP($J,"MPIF") D NOW^%DTC S ST=%,X1=ST,X2=20 D C^%DTC
- S STP=X,^XTMP($J,"MPIF","MPIIN",0)=STP_"^"_ST_"^"_"MPI BATCH JOB"
- K %,X,Y,X1,X2,ST,STP N RGLOG,MPIMSG S MPIMSG=HLMTIEN
- D START^RGHLLOG(HLMTIEN,"","ADDPAT^MPIFBT2")
- D PREPMSG,PROCESS(MPIMSG),STOP^RGHLLOG(0)
- K ACK1,ACK2,ACK3,ACK4,HDR,MPICKG,MPIIN,MPIIPPF,MPIIT,MPINUM,MPIPPF,DA
- K CNTR,COM,ENC,ESC,LOCAL,MSHDR,PATID,REP,SCOM,SEP,SITE,MPIDTH,VISTDTH,MPITMP,MPICNTR,MPIFOK,^XTMP($J,"MPIF"),DGSENFLG
- Q
- PREPMSG ;prepare for response
- N I,J,X F I=1:1 X HLNEXT Q:HLQUIT'>0 D
- .S ^XTMP($J,"MPIF","MPIIN",I)=HLNODE,J=0
- .F S J=$O(HLNODE(J)) Q:'J S ^XTMP($J,"MPIF","MPIIN",I,J)=HLNODE(J)
- Q
- PROCESS(MPIMSG) ;Process mesage out of array
- N HDR,MPICNTR S MPICNTR=1,HDR=^XTMP($J,"MPIF","MPIIN",1) ;check hdr here
- D CHDR(HDR,.SEP,MPICNTR,MPIMSG)
- Q:$D(^XTMP($J,"MPIF","MSHERR"))
- F S MPICNTR=$O(^XTMP($J,"MPIF","MPIIN",MPICNTR)) Q:'MPICNTR D LOOPS(.MPICNTR,SEP,MPIMSG)
- Q
- LOOPS(CNTR,SEP,MPIMSG) ;Loop in the batch
- K ^XTMP($J,"MPIF","MSHERR") N MSHDR,ACK1,ACK2,ACK3,ACK4,ACK5,PATID,LOCAL,MPITMP,LICN
- S MSHDR=^XTMP($J,"MPIF","MPIIN",+CNTR)
- D CHKMSH(MSHDR,.SITE,SEP,MPIMSG)
- Q:$D(^XTMP($J,"MPIF","MSHERR"))
- S CNTR=$O(^XTMP($J,"MPIF","MPIIN",CNTR)) Q:CNTR'>0
- S ACK1=^XTMP($J,"MPIF","MPIIN",CNTR)
- I $P(ACK1,SEP)'="MSA" S ^XTMP($J,"MPIF","MSHERR")="NOT AN MSA SEGMENT" D EXC^RGHLLOG(203,"Around line number "_(CNTR*2)_" of message "_MPIMSG_".")
- Q:$D(^XTMP($J,"MPIF","MSHERR"))
- I ACK1["AR" S ^XTMP($J,"MPIF","MSHERR")="APP REJECT ERROR" D EXC^RGHLLOG(207,"Around line number "_(CNTR*2)_" of message "_MPIMSG_".")
- Q:$D(^XTMP($J,"MPIF","MSHERR"))
- I ACK1["AE" S ^XTMP($J,"MPIF","MSHERR")="APP ERROR" D EXC^RGHLLOG(208,"Around line number "_(CNTR*2)_" of message "_MPIMSG_".")
- ;ACK1 must be an AA
- Q:$D(^XTMP($J,"MPIF","MSHERR"))
- S CNTR=$O(^XTMP($J,"MPIF","MPIIN",CNTR)) Q:CNTR'>0
- S ACK2=^XTMP($J,"MPIF","MPIIN",CNTR)
- I $P(ACK2,SEP)'="QAK" S ^XTMP($J,"MPIF","MSHERR")="NOT A QAK SEGMENT" D EXC^RGHLLOG(202,"Around line number "_(CNTR*2)_" of message "_MPIMSG_".")
- Q:$D(^XTMP($J,"MPIF","MSHERR"))
- I ACK2["NO DATA" D
- .S ^XTMP($J,"MPIF","MSHERR")="NO DATA in MPI "
- .;**43 NO DATA FOUND TRIGGER ADD
- .S MPIFRPC=1 D A28^MPIFQ3($P(ACK2,SEP,2)) K MPIFRPC
- .;I ACK2["POTENTIAL MATCHES" D EXC^RGHLLOG(218,"Potential matches found, please review via MPI/PD Exception Handler",$P(ACK2,SEP,2)) ;**53 MPIC_1853 Remove 218 references
- .;D EXC^RGHLLOG(218,"For Patient DFN="_$P(ACK2,SEP,2)_". Use Single Patient Initialization to MPI option to manually process.",$P(ACK2,SEP,2))
- .;I $D(^DPT($P(ACK2,SEP,2),0)) S LICN=$$ICNLC^MPIF001($P(ACK2,SEP,2))
- .; ^ create a local ICN
- .;I ACK2'["POTENTIAL MATCHES" D
- .;D EXC^RGHLLOG(209,"For Patient DFN="_$P(ACK2,SEP,2)_". Need required fields before patient can be processed again the MPI.",$P(ACK2,SEP,2))
- .;I $D(^DPT($P(ACK2,SEP,2),0)) S LICN=$$ICNLC^MPIF001($P(ACK2,SEP,2))
- .; ^ create a local ICN
- .N TACK,TCNTR S TCNTR=CNTR,CNTR=$O(^XTMP($J,"MPIF","MPIIN",CNTR)),TACK=^XTMP($J,"MPIF","MPIIN",CNTR)
- .I $P(TACK,SEP)="MSH" S CNTR=TCNTR
- Q:$D(^XTMP($J,"MPIF","MSHERR"))
- S PATID=$P(ACK2,SEP,2),LOCAL=$G(^DPT(PATID,0)) ;Verify patient is in database
- I LOCAL']"" S ^XTMP($J,"MPIF","MSHERR")="PATIENT DFN NOT IN DATABASE- BAD " D EXC^RGHLLOG(210,"Around line number "_(CNTR*2)_" DFN= "_PATID_" MESSAGE# "_MPIMSG,PATID)
- S CNTR=$O(^XTMP($J,"MPIF","MPIIN",CNTR)) Q:CNTR'>0
- ; **43 MOVED CNTR INCREASE TO GET TO NEXT MSH
- Q:$D(^XTMP($J,"MPIF","MSHERR"))
- S ACK3=^XTMP($J,"MPIF","MPIIN",CNTR) ;RDF DEFINITION SEGMENT NO-OP
- I $P(ACK3,SEP)'="RDF" S ^XTMP($J,"MPIF","MSHERR")="NOT RDF SEGMENT" D EXC^RGHLLOG(204,"Around line number "_(CNTR*2)_" of message "_MPIMSG_".",PATID)
- Q:$D(^XTMP($J,"MPIF","MSHERR"))
- S CNTR=$O(^XTMP($J,"MPIF","MPIIN",CNTR)) Q:CNTR'>0
- S RDTSEQ=1
- S ACK4(RDTSEQ)=^XTMP($J,"MPIF","MPIIN",CNTR)
- I $P(ACK4(RDTSEQ),SEP)'="RDT" S ^XTMP($J,"MPIF","MSHERR")="NOT RDT SEGMENT" D EXC^RGHLLOG(205,"Around line number "_(CNTR*2)_" of message "_MPIMSG_".",PATID)
- ;
- N RDTSQ S RDTSQ=0
- F S RDTSQ=$O(^XTMP($J,"MPIF","MPIIN",CNTR,RDTSQ)) Q:'RDTSQ D
- .S ACK4(RDTSEQ+1)=^XTMP($J,"MPIF","MPIIN",CNTR,RDTSQ),RDTSEQ=RDTSEQ+1
- Q:$D(^XTMP($J,"MPIF","MSHERR"))
- S MPITMP=$O(^XTMP($J,"MPIF","MPIIN",CNTR))
- I MPITMP'>0 S:$E($G(^XTMP($J,"MPIF","MPIIN",MPITMP)),1,3)="BTS" CNTR=$O(^XTMP($J,"MPIF","MPIIN",CNTR))
- Q:CNTR'>0
- D VFYRDT^MPIFBT3(.ACK4,SEP,CNTR,PATID,SITE,MPIMSG)
- S MPITMP=$O(^XTMP($J,"MPIF","MPIIN",CNTR))
- Q:MPITMP'>0
- S ACK5=^XTMP($J,"MPIF","MPIIN",MPITMP)
- I $P(ACK5,SEP)="RDT" D MULT^MPIFBT3(.CNTR,ACK5,SEP,MPIMSG,PATID)
- K RDTSEQ
- Q
- TFLIST(TFSITE,PATID) ;adding TFSITE site for patient to Treating Facility List (#391.91)
- I $G(TFSITE)="" S ^XTMP($J,"MPIF","MSHERR")="Treating Facility = null" D EXC^RGHLLOG(212,"DFN = "_PATID_" Treating Facility = Null",PATID) Q
- S TFSITE=$$LKUP^XUAF4(TFSITE)
- Q:+TFSITE'>0
- Q:$D(^DGCN(391.91,"APAT",PATID,TFSITE))
- K DD,DO N DIC,X,Y L +^DGCN(391.91,0):60
- I '$T D EXC^RGHLLOG(212,"Unable to Lock Treating Facility file to add patient DFN="_PATID_" Facility= "_TFSITE,PATID) Q
- S DIC="^DGCN(391.91,",DIC("DR")=".02///`"_TFSITE,X=PATID,DIC(0)="LQZ"
- I $D(^DGCN(391.91,"APAT",PATID,TFSITE)) L -^DGCN(391.91,0) Q
- D FILE^DICN L -^DGCN(391.91,0)
- I +Y=-1,'$D(^DGCN(391.91,"APAT",PATID,TFSITE)) S ^XTMP($J,"MPIF","MSHERR")="Treating Facility Add Failed" D EXC^RGHLLOG(212,"DFN= "_PATID_" Treating Facility= "_TFSITE_" failed when adding an entry to the Treating Facility file.",PATID)
- K DD,DO,DIC,X,Y
- Q
- TFUPDT(PATID,MPIMSG,CNTR) ;treating facility update message to pivot file
- N ERR,TRANS,EVDT,X,Y,%
- D NOW^%DTC S EVDT=% K %,X,Y
- S ERR=$$PIVNW^VAFHPIVT(PATID,EVDT,5,PATID_";DPT(")
- I +ERR<1 D EXC^RGHLLOG(212,"When trying to add Patient (DFN)"_PATID_" message# "_MPIMSG_" around line number "_(CNTR*2),PATID)
- Q:+ERR<1
- D XMITFLAG^VAFCDD01("",+ERR)
- Q
- CHDR(HDR,SEP,CNTR,MPIMSG) ;Only process Batch message responses
- I $P(HDR,"^")'="BHS" S ^XTMP($J,"MPIF","MSHERR")="BHS SEGMENT MISSING" D EXC^RGHLLOG(200,"for message "_MPIMSG_". The segment contains "_HDR)
- Q:$D(^XTMP($J,"MPIF","MSHERR"))
- S SEP=$G(HL("FS")) ;get field sep, and encoding characters
- I SEP="" S ^XTMP($J,"MPIF","MSHERR")="Missing field seperator" D EXC^RGHLLOG(200,"Missing field seperator")
- Q
- CHKMSH(MSHDR,SITE,SEP,MPIMSG) ;VERIFY MSH
- I $P(MSHDR,SEP)="BTS" S ^XTMP($J,"MPIF","MSHERR")="BTS FOUND" Q
- S:$P(MSHDR,SEP)'="MSH" ^XTMP($J,"MPIF","MSHERR")="NOT MSH HEADER MESSAGE# "_MPIMSG
- S:$E(MSHDR,4)'=SEP ^XTMP($J,"MPIF","MSHERR")="FIELD SEPARATOR MISMATCH MESSAGE# "_MPIMSG
- I $D(^XTMP($J,"MPIF","MSHERR")) D EXC^RGHLLOG(201,$G(^XTMP($J,"MPIF","MSHERR")))
- Q:$D(^XTMP($J,"MPIF","MSHERR"))
- S SITE=$P(MSHDR,SEP,6)
- I SITE="" S ^XTMP($J,"MPIF","MSHERR")="SITE NOT IN MSH"
- I $D(^XTMP($J,"MPIF","MSHERR")) D EXC^RGHLLOG(8,"MSH Doesn't Have SITE as 6th piece. MESSAGE# "_MPIMSG)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMPIFBT2 7305 printed Feb 18, 2025@23:37:14 Page 2
- MPIFBT2 ;SLC/ARS-BATCH RESPONSE FROM MPI ;FEB 4, 1997
- +1 ;;1.0; MASTER PATIENT INDEX VISTA ;**1,3,10,17,21,31,43,53**;30 Apr 99;Build 1
- +2 ;
- +3 ; Integration Agreements Utilized:
- +4 ; ^DGCN(391.91 - #2751
- +5 ; EXC, START, STOP ^RGHLLOG - #2796
- +6 ; XMITFLAG^VAFCDD01 - #3493
- +7 ; $$PIVNW^VAFHPIVT - #3494
- +8 ;
- ADDPAT ;Called when response from MPI is received for messages sent.
- +1 KILL ^XTMP($JOB,"MPIF")
- DO NOW^%DTC
- SET ST=%
- SET X1=ST
- SET X2=20
- DO C^%DTC
- +2 SET STP=X
- SET ^XTMP($JOB,"MPIF","MPIIN",0)=STP_"^"_ST_"^"_"MPI BATCH JOB"
- +3 KILL %,X,Y,X1,X2,ST,STP
- NEW RGLOG,MPIMSG
- SET MPIMSG=HLMTIEN
- +4 DO START^RGHLLOG(HLMTIEN,"","ADDPAT^MPIFBT2")
- +5 DO PREPMSG
- DO PROCESS(MPIMSG)
- DO STOP^RGHLLOG(0)
- +6 KILL ACK1,ACK2,ACK3,ACK4,HDR,MPICKG,MPIIN,MPIIPPF,MPIIT,MPINUM,MPIPPF,DA
- +7 KILL CNTR,COM,ENC,ESC,LOCAL,MSHDR,PATID,REP,SCOM,SEP,SITE,MPIDTH,VISTDTH,MPITMP,MPICNTR,MPIFOK,^XTMP($JOB,"MPIF"),DGSENFLG
- +8 QUIT
- PREPMSG ;prepare for response
- +1 NEW I,J,X
- FOR I=1:1
- XECUTE HLNEXT
- if HLQUIT'>0
- QUIT
- Begin DoDot:1
- +2 SET ^XTMP($JOB,"MPIF","MPIIN",I)=HLNODE
- SET J=0
- +3 FOR
- SET J=$ORDER(HLNODE(J))
- if 'J
- QUIT
- SET ^XTMP($JOB,"MPIF","MPIIN",I,J)=HLNODE(J)
- End DoDot:1
- +4 QUIT
- PROCESS(MPIMSG) ;Process mesage out of array
- +1 ;check hdr here
- NEW HDR,MPICNTR
- SET MPICNTR=1
- SET HDR=^XTMP($JOB,"MPIF","MPIIN",1)
- +2 DO CHDR(HDR,.SEP,MPICNTR,MPIMSG)
- +3 if $DATA(^XTMP($JOB,"MPIF","MSHERR"))
- QUIT
- +4 FOR
- SET MPICNTR=$ORDER(^XTMP($JOB,"MPIF","MPIIN",MPICNTR))
- if 'MPICNTR
- QUIT
- DO LOOPS(.MPICNTR,SEP,MPIMSG)
- +5 QUIT
- LOOPS(CNTR,SEP,MPIMSG) ;Loop in the batch
- +1 KILL ^XTMP($JOB,"MPIF","MSHERR")
- NEW MSHDR,ACK1,ACK2,ACK3,ACK4,ACK5,PATID,LOCAL,MPITMP,LICN
- +2 SET MSHDR=^XTMP($JOB,"MPIF","MPIIN",+CNTR)
- +3 DO CHKMSH(MSHDR,.SITE,SEP,MPIMSG)
- +4 if $DATA(^XTMP($JOB,"MPIF","MSHERR"))
- QUIT
- +5 SET CNTR=$ORDER(^XTMP($JOB,"MPIF","MPIIN",CNTR))
- if CNTR'>0
- QUIT
- +6 SET ACK1=^XTMP($JOB,"MPIF","MPIIN",CNTR)
- +7 IF $PIECE(ACK1,SEP)'="MSA"
- SET ^XTMP($JOB,"MPIF","MSHERR")="NOT AN MSA SEGMENT"
- DO EXC^RGHLLOG(203,"Around line number "_(CNTR*2)_" of message "_MPIMSG_".")
- +8 if $DATA(^XTMP($JOB,"MPIF","MSHERR"))
- QUIT
- +9 IF ACK1["AR"
- SET ^XTMP($JOB,"MPIF","MSHERR")="APP REJECT ERROR"
- DO EXC^RGHLLOG(207,"Around line number "_(CNTR*2)_" of message "_MPIMSG_".")
- +10 if $DATA(^XTMP($JOB,"MPIF","MSHERR"))
- QUIT
- +11 IF ACK1["AE"
- SET ^XTMP($JOB,"MPIF","MSHERR")="APP ERROR"
- DO EXC^RGHLLOG(208,"Around line number "_(CNTR*2)_" of message "_MPIMSG_".")
- +12 ;ACK1 must be an AA
- +13 if $DATA(^XTMP($JOB,"MPIF","MSHERR"))
- QUIT
- +14 SET CNTR=$ORDER(^XTMP($JOB,"MPIF","MPIIN",CNTR))
- if CNTR'>0
- QUIT
- +15 SET ACK2=^XTMP($JOB,"MPIF","MPIIN",CNTR)
- +16 IF $PIECE(ACK2,SEP)'="QAK"
- SET ^XTMP($JOB,"MPIF","MSHERR")="NOT A QAK SEGMENT"
- DO EXC^RGHLLOG(202,"Around line number "_(CNTR*2)_" of message "_MPIMSG_".")
- +17 if $DATA(^XTMP($JOB,"MPIF","MSHERR"))
- QUIT
- +18 IF ACK2["NO DATA"
- Begin DoDot:1
- +19 SET ^XTMP($JOB,"MPIF","MSHERR")="NO DATA in MPI "
- +20 ;**43 NO DATA FOUND TRIGGER ADD
- +21 SET MPIFRPC=1
- DO A28^MPIFQ3($PIECE(ACK2,SEP,2))
- KILL MPIFRPC
- +22 ;I ACK2["POTENTIAL MATCHES" D EXC^RGHLLOG(218,"Potential matches found, please review via MPI/PD Exception Handler",$P(ACK2,SEP,2)) ;**53 MPIC_1853 Remove 218 references
- +23 ;D EXC^RGHLLOG(218,"For Patient DFN="_$P(ACK2,SEP,2)_". Use Single Patient Initialization to MPI option to manually process.",$P(ACK2,SEP,2))
- +24 ;I $D(^DPT($P(ACK2,SEP,2),0)) S LICN=$$ICNLC^MPIF001($P(ACK2,SEP,2))
- +25 ; ^ create a local ICN
- +26 ;I ACK2'["POTENTIAL MATCHES" D
- +27 ;D EXC^RGHLLOG(209,"For Patient DFN="_$P(ACK2,SEP,2)_". Need required fields before patient can be processed again the MPI.",$P(ACK2,SEP,2))
- +28 ;I $D(^DPT($P(ACK2,SEP,2),0)) S LICN=$$ICNLC^MPIF001($P(ACK2,SEP,2))
- +29 ; ^ create a local ICN
- +30 NEW TACK,TCNTR
- SET TCNTR=CNTR
- SET CNTR=$ORDER(^XTMP($JOB,"MPIF","MPIIN",CNTR))
- SET TACK=^XTMP($JOB,"MPIF","MPIIN",CNTR)
- +31 IF $PIECE(TACK,SEP)="MSH"
- SET CNTR=TCNTR
- End DoDot:1
- +32 if $DATA(^XTMP($JOB,"MPIF","MSHERR"))
- QUIT
- +33 ;Verify patient is in database
- SET PATID=$PIECE(ACK2,SEP,2)
- SET LOCAL=$GET(^DPT(PATID,0))
- +34 IF LOCAL']""
- SET ^XTMP($JOB,"MPIF","MSHERR")="PATIENT DFN NOT IN DATABASE- BAD "
- DO EXC^RGHLLOG(210,"Around line number "_(CNTR*2)_" DFN= "_PATID_" MESSAGE# "_MPIMSG,PATID)
- +35 SET CNTR=$ORDER(^XTMP($JOB,"MPIF","MPIIN",CNTR))
- if CNTR'>0
- QUIT
- +36 ; **43 MOVED CNTR INCREASE TO GET TO NEXT MSH
- +37 if $DATA(^XTMP($JOB,"MPIF","MSHERR"))
- QUIT
- +38 ;RDF DEFINITION SEGMENT NO-OP
- SET ACK3=^XTMP($JOB,"MPIF","MPIIN",CNTR)
- +39 IF $PIECE(ACK3,SEP)'="RDF"
- SET ^XTMP($JOB,"MPIF","MSHERR")="NOT RDF SEGMENT"
- DO EXC^RGHLLOG(204,"Around line number "_(CNTR*2)_" of message "_MPIMSG_".",PATID)
- +40 if $DATA(^XTMP($JOB,"MPIF","MSHERR"))
- QUIT
- +41 SET CNTR=$ORDER(^XTMP($JOB,"MPIF","MPIIN",CNTR))
- if CNTR'>0
- QUIT
- +42 SET RDTSEQ=1
- +43 SET ACK4(RDTSEQ)=^XTMP($JOB,"MPIF","MPIIN",CNTR)
- +44 IF $PIECE(ACK4(RDTSEQ),SEP)'="RDT"
- SET ^XTMP($JOB,"MPIF","MSHERR")="NOT RDT SEGMENT"
- DO EXC^RGHLLOG(205,"Around line number "_(CNTR*2)_" of message "_MPIMSG_".",PATID)
- +45 ;
- +46 NEW RDTSQ
- SET RDTSQ=0
- +47 FOR
- SET RDTSQ=$ORDER(^XTMP($JOB,"MPIF","MPIIN",CNTR,RDTSQ))
- if 'RDTSQ
- QUIT
- Begin DoDot:1
- +48 SET ACK4(RDTSEQ+1)=^XTMP($JOB,"MPIF","MPIIN",CNTR,RDTSQ)
- SET RDTSEQ=RDTSEQ+1
- End DoDot:1
- +49 if $DATA(^XTMP($JOB,"MPIF","MSHERR"))
- QUIT
- +50 SET MPITMP=$ORDER(^XTMP($JOB,"MPIF","MPIIN",CNTR))
- +51 IF MPITMP'>0
- if $EXTRACT($GET(^XTMP($JOB,"MPIF","MPIIN",MPITMP)),1,3)="BTS"
- SET CNTR=$ORDER(^XTMP($JOB,"MPIF","MPIIN",CNTR))
- +52 if CNTR'>0
- QUIT
- +53 DO VFYRDT^MPIFBT3(.ACK4,SEP,CNTR,PATID,SITE,MPIMSG)
- +54 SET MPITMP=$ORDER(^XTMP($JOB,"MPIF","MPIIN",CNTR))
- +55 if MPITMP'>0
- QUIT
- +56 SET ACK5=^XTMP($JOB,"MPIF","MPIIN",MPITMP)
- +57 IF $PIECE(ACK5,SEP)="RDT"
- DO MULT^MPIFBT3(.CNTR,ACK5,SEP,MPIMSG,PATID)
- +58 KILL RDTSEQ
- +59 QUIT
- TFLIST(TFSITE,PATID) ;adding TFSITE site for patient to Treating Facility List (#391.91)
- +1 IF $GET(TFSITE)=""
- SET ^XTMP($JOB,"MPIF","MSHERR")="Treating Facility = null"
- DO EXC^RGHLLOG(212,"DFN = "_PATID_" Treating Facility = Null",PATID)
- QUIT
- +2 SET TFSITE=$$LKUP^XUAF4(TFSITE)
- +3 if +TFSITE'>0
- QUIT
- +4 if $DATA(^DGCN(391.91,"APAT",PATID,TFSITE))
- QUIT
- +5 KILL DD,DO
- NEW DIC,X,Y
- LOCK +^DGCN(391.91,0):60
- +6 IF '$TEST
- DO EXC^RGHLLOG(212,"Unable to Lock Treating Facility file to add patient DFN="_PATID_" Facility= "_TFSITE,PATID)
- QUIT
- +7 SET DIC="^DGCN(391.91,"
- SET DIC("DR")=".02///`"_TFSITE
- SET X=PATID
- SET DIC(0)="LQZ"
- +8 IF $DATA(^DGCN(391.91,"APAT",PATID,TFSITE))
- LOCK -^DGCN(391.91,0)
- QUIT
- +9 DO FILE^DICN
- LOCK -^DGCN(391.91,0)
- +10 IF +Y=-1
- IF '$DATA(^DGCN(391.91,"APAT",PATID,TFSITE))
- SET ^XTMP($JOB,"MPIF","MSHERR")="Treating Facility Add Failed"
- DO EXC^RGHLLOG(212,"DFN= "_PATID_" Treating Facility= "_TFSITE_" failed when adding an entry to the Treating Facility file.",PATID)
- +11 KILL DD,DO,DIC,X,Y
- +12 QUIT
- TFUPDT(PATID,MPIMSG,CNTR) ;treating facility update message to pivot file
- +1 NEW ERR,TRANS,EVDT,X,Y,%
- +2 DO NOW^%DTC
- SET EVDT=%
- KILL %,X,Y
- +3 SET ERR=$$PIVNW^VAFHPIVT(PATID,EVDT,5,PATID_";DPT(")
- +4 IF +ERR<1
- DO EXC^RGHLLOG(212,"When trying to add Patient (DFN)"_PATID_" message# "_MPIMSG_" around line number "_(CNTR*2),PATID)
- +5 if +ERR<1
- QUIT
- +6 DO XMITFLAG^VAFCDD01("",+ERR)
- +7 QUIT
- CHDR(HDR,SEP,CNTR,MPIMSG) ;Only process Batch message responses
- +1 IF $PIECE(HDR,"^")'="BHS"
- SET ^XTMP($JOB,"MPIF","MSHERR")="BHS SEGMENT MISSING"
- DO EXC^RGHLLOG(200,"for message "_MPIMSG_". The segment contains "_HDR)
- +2 if $DATA(^XTMP($JOB,"MPIF","MSHERR"))
- QUIT
- +3 ;get field sep, and encoding characters
- SET SEP=$GET(HL("FS"))
- +4 IF SEP=""
- SET ^XTMP($JOB,"MPIF","MSHERR")="Missing field seperator"
- DO EXC^RGHLLOG(200,"Missing field seperator")
- +5 QUIT
- CHKMSH(MSHDR,SITE,SEP,MPIMSG) ;VERIFY MSH
- +1 IF $PIECE(MSHDR,SEP)="BTS"
- SET ^XTMP($JOB,"MPIF","MSHERR")="BTS FOUND"
- QUIT
- +2 if $PIECE(MSHDR,SEP)'="MSH"
- SET ^XTMP($JOB,"MPIF","MSHERR")="NOT MSH HEADER MESSAGE# "_MPIMSG
- +3 if $EXTRACT(MSHDR,4)'=SEP
- SET ^XTMP($JOB,"MPIF","MSHERR")="FIELD SEPARATOR MISMATCH MESSAGE# "_MPIMSG
- +4 IF $DATA(^XTMP($JOB,"MPIF","MSHERR"))
- DO EXC^RGHLLOG(201,$GET(^XTMP($JOB,"MPIF","MSHERR")))
- +5 if $DATA(^XTMP($JOB,"MPIF","MSHERR"))
- QUIT
- +6 SET SITE=$PIECE(MSHDR,SEP,6)
- +7 IF SITE=""
- SET ^XTMP($JOB,"MPIF","MSHERR")="SITE NOT IN MSH"
- +8 IF $DATA(^XTMP($JOB,"MPIF","MSHERR"))
- DO EXC^RGHLLOG(8,"MSH Doesn't Have SITE as 6th piece. MESSAGE# "_MPIMSG)
- +9 QUIT
