MPIFA40 ;BP/CMC-BUILD A40 MERGE MESSAGE ; 6/12/2010 3:06 PM
;;1.0; MASTER PATIENT INDEX VISTA ;**22,41,51,55**;30 Apr 99;Build 3
;
; Integration Agreements Utilized:
; START, EXC, STOP^RGHLLOG - #2796
; BLDEVN, BLDPD1, BLDPID^VAFCQRY - #3630
;
A40(DFN,DFN2,PICN) ;BUILD AND SEND A40
;PICN should only be passed if the primary icn is different than the one currently stored in DFN
N PID,PD1,EVN,PD1,MRG,MPI,RESLT,CNT,ICN1,ICN2,STN,SITA,TMP
D INIT^HLFNC2("MPIF ADT-A40 SERVER",.HL)
I $O(HL(""))="" Q "-1^"_$P(HL,"^",2)
S HLECH=HL("ECH"),HLFS=HL("FS"),COMP=$E(HL("ECH"),1),REP=$E(HL("ECH"),2),SUBCOMP=$E(HL("ECH"),4)
S ERR=""
D BLDEVN^VAFCQRY(DFN,"1,2",.EVN,.HL,"A40",.ERR)
Q:ERR'="" ERR
D BLDPID^VAFCQRY(DFN,1,"ALL",.PID,.HL,.ERR) ;**41
Q:ERR'="" ERR
I $G(PICN)'="" D
.;RESET ICN IN PID TO BE THIS (PICN) PRIMARY ICN
.I PICN[-1 S PICN=HL("Q")
.I PICN'["V",PICN'=HL("Q") S PICN=PICN_"V"_$$CHECKDG^MPIFSPC(PICN)
.S STN=$P($$SITE^VASITE,"^",3)
.I $E($P(PICN,"^"),1,3)=STN S SITA=STN
.I $E($P(PICN,"^"),1,3)'=STN S SITA="200M"
.S PICN=PICN_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_SITA_SUBCOMP_"L"
.S TMP=$P(PID(1),HLFS,4)
.S $P(TMP,REP,1)=PICN
.S $P(PID(1),HLFS,4)=TMP
.S $P(PID(1),HLFS,3)=PICN
D BLDPD1^VAFCQRY(DFN,"3",.PD1,.HL,.ERR)
Q:ERR'="" ERR
D BLDMRG(DFN2,"1,7",.MRG,.HL,.ERR)
S HLA("HLS",1)=EVN(1)
S HLA("HLS",3)=PD1(1)
S HLA("HLS",4)=MRG
S CNT=0 F S CNT=$O(PID(CNT)) Q:CNT="" D
.I CNT=1 S HLA("HLS",2)=PID(CNT)
.I CNT>1 S HLA("HLS",2,CNT-1)=PID(CNT)
S MPI=$$MPILINK^MPIFAPI()
Q:$P($G(MPI),"^")=-1 "-1^No logical link defined for the MPI"
S HLL("LINKS",1)="MPIF ADT-A40 CLIENT^"_MPI
D GENERATE^HLMA("MPIF ADT-A40 SERVER","LM",1,.MPIFRSLT,"","") ;**41
S RESLT=$S(+MPIFRSLT:MPIFRSLT,1:$P(MPIFRSLT,"^",3))
S ^XTMP("MPIFA40%"_DFN,0)=$$FMADD^XLFDT(DT,5)_"^"_DT_"^"_"MPIA40 msg to MPI for DFN "_DFN
I +RESLT D
.S ICN1=$$GETICN^MPIF001(DFN),ICN2=$$GETICN^MPIF001(DFN2)
.S ^XTMP("MPIFA40%"_DFN,DFN2,"MPI",0)="A"
.S ^XTMP("MPIFA40%"_DFN,DFN2,"MPI",1)=ICN1_"^"_ICN2_"^"_RESLT
K HLA,HLEID,HLL("LINKS"),COMP,REP,SUBCOMP,HLECH,HLFS,HLA("HLA"),HLA("HLS"),MPIFRSLT ;**41
Q RESLT
;
RES ;
N NXT
; MPIC_1109/Patch 55: If the sending or receiving application is not
; MPIF TRIGGER, then just ignore this application acknowledgment. This
; message is not sent from MPI, and was probably sent in error.
Q:$G(HL("SAN"))'="MPIF TRIGGER"!($G(HL("RAN"))'="MPIF TRIGGER") ;**55
F NXT=1:1 X HLNEXT Q:HLQUIT'>0 D
.I $E(HLNODE,1,3)="MSA" S DFN=$P($P(HLNODE,HL("FS"),7),"=",2)
.I $E(HLNODE,1,3)="MSA"&($P(HLNODE,HL("FS"),4)'="") D
..; ERROR RETURNED IN MSA - LOG EXCEPTION
..D START^RGHLLOG(HLMTIEN,"","")
..D EXC^RGHLLOG(208,$P(HLNODE,HL("FS"),4)_" for HL msg# "_HLMTIEN,DFN)
..D STOP^RGHLLOG(0)
K ^XTMP("MPIFA40%"_DFN)
Q
;
BLDMRG(IEN,FLD,SEG,HL,ERR) ; bld MRG segment ONLY FIELDS 2 AND 8 SUPPORTED
N NODE,MPIZN,MG,X,COMP,SUBCOMP,REP,NAME,ICN,SITE
S COMP=$E(HL("ECH"),1),SUBCOMP=$E(HL("ECH"),4),REP=$E(HL("ECH"),2),ICN=""
S MPIZN=$D(^DPT(IEN,0))
I MPIZN="" S ERR="-1^No such DFN entry "_IEN Q
S SEG="MRG"
;repeat prior ID's including ICN and DFN
S NODE=$$MPINODE^MPIFAPI(IEN)
I +NODE=-1 S NODE="" ;**51
I NODE'="" S ICN=$P(NODE,"^",1)_"V"_$P(NODE,"^",2) ;**51
S SITE=$P($$SITE^VASITE(),"^",3) ;**51
I ICN=""!(ICN="V") S ICN=HL("Q") ;**51
S MG(2)=ICN_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_SITE_SUBCOMP_"L"_REP_IEN_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"PI"_COMP_"VA FACILITY ID"_SUBCOMP_SITE_SUBCOMP_"L" ;**41
;NAME
S NAME("FILE")=2,NAME("IENS")=IEN,NAME("FIELD")=.01
S MG(8)=$$HLNAME^XLFNAME(.NAME,"",COMP)
S $P(MG(8),COMP,7)="L"
S $P(SEG,HL("FS"),2)=MG(2)
S $P(SEG,HL("FS"),8)=MG(8)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMPIFA40 3846 printed Dec 13, 2024@02:10:51 Page 2
MPIFA40 ;BP/CMC-BUILD A40 MERGE MESSAGE ; 6/12/2010 3:06 PM
+1 ;;1.0; MASTER PATIENT INDEX VISTA ;**22,41,51,55**;30 Apr 99;Build 3
+2 ;
+3 ; Integration Agreements Utilized:
+4 ; START, EXC, STOP^RGHLLOG - #2796
+5 ; BLDEVN, BLDPD1, BLDPID^VAFCQRY - #3630
+6 ;
A40(DFN,DFN2,PICN) ;BUILD AND SEND A40
+1 ;PICN should only be passed if the primary icn is different than the one currently stored in DFN
+2 NEW PID,PD1,EVN,PD1,MRG,MPI,RESLT,CNT,ICN1,ICN2,STN,SITA,TMP
+3 DO INIT^HLFNC2("MPIF ADT-A40 SERVER",.HL)
+4 IF $ORDER(HL(""))=""
QUIT "-1^"_$PIECE(HL,"^",2)
+5 SET HLECH=HL("ECH")
SET HLFS=HL("FS")
SET COMP=$EXTRACT(HL("ECH"),1)
SET REP=$EXTRACT(HL("ECH"),2)
SET SUBCOMP=$EXTRACT(HL("ECH"),4)
+6 SET ERR=""
+7 DO BLDEVN^VAFCQRY(DFN,"1,2",.EVN,.HL,"A40",.ERR)
+8 if ERR'=""
QUIT ERR
+9 ;**41
DO BLDPID^VAFCQRY(DFN,1,"ALL",.PID,.HL,.ERR)
+10 if ERR'=""
QUIT ERR
+11 IF $GET(PICN)'=""
Begin DoDot:1
+12 ;RESET ICN IN PID TO BE THIS (PICN) PRIMARY ICN
+13 IF PICN[-1
SET PICN=HL("Q")
+14 IF PICN'["V"
IF PICN'=HL("Q")
SET PICN=PICN_"V"_$$CHECKDG^MPIFSPC(PICN)
+15 SET STN=$PIECE($$SITE^VASITE,"^",3)
+16 IF $EXTRACT($PIECE(PICN,"^"),1,3)=STN
SET SITA=STN
+17 IF $EXTRACT($PIECE(PICN,"^"),1,3)'=STN
SET SITA="200M"
+18 SET PICN=PICN_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_SITA_SUBCOMP_"L"
+19 SET TMP=$PIECE(PID(1),HLFS,4)
+20 SET $PIECE(TMP,REP,1)=PICN
+21 SET $PIECE(PID(1),HLFS,4)=TMP
+22 SET $PIECE(PID(1),HLFS,3)=PICN
End DoDot:1
+23 DO BLDPD1^VAFCQRY(DFN,"3",.PD1,.HL,.ERR)
+24 if ERR'=""
QUIT ERR
+25 DO BLDMRG(DFN2,"1,7",.MRG,.HL,.ERR)
+26 SET HLA("HLS",1)=EVN(1)
+27 SET HLA("HLS",3)=PD1(1)
+28 SET HLA("HLS",4)=MRG
+29 SET CNT=0
FOR
SET CNT=$ORDER(PID(CNT))
if CNT=""
QUIT
Begin DoDot:1
+30 IF CNT=1
SET HLA("HLS",2)=PID(CNT)
+31 IF CNT>1
SET HLA("HLS",2,CNT-1)=PID(CNT)
End DoDot:1
+32 SET MPI=$$MPILINK^MPIFAPI()
+33 if $PIECE($GET(MPI),"^")=-1
QUIT "-1^No logical link defined for the MPI"
+34 SET HLL("LINKS",1)="MPIF ADT-A40 CLIENT^"_MPI
+35 ;**41
DO GENERATE^HLMA("MPIF ADT-A40 SERVER","LM",1,.MPIFRSLT,"","")
+36 SET RESLT=$SELECT(+MPIFRSLT:MPIFRSLT,1:$PIECE(MPIFRSLT,"^",3))
+37 SET ^XTMP("MPIFA40%"_DFN,0)=$$FMADD^XLFDT(DT,5)_"^"_DT_"^"_"MPIA40 msg to MPI for DFN "_DFN
+38 IF +RESLT
Begin DoDot:1
+39 SET ICN1=$$GETICN^MPIF001(DFN)
SET ICN2=$$GETICN^MPIF001(DFN2)
+40 SET ^XTMP("MPIFA40%"_DFN,DFN2,"MPI",0)="A"
+41 SET ^XTMP("MPIFA40%"_DFN,DFN2,"MPI",1)=ICN1_"^"_ICN2_"^"_RESLT
End DoDot:1
+42 ;**41
KILL HLA,HLEID,HLL("LINKS"),COMP,REP,SUBCOMP,HLECH,HLFS,HLA("HLA"),HLA("HLS"),MPIFRSLT
+43 QUIT RESLT
+44 ;
RES ;
+1 NEW NXT
+2 ; MPIC_1109/Patch 55: If the sending or receiving application is not
+3 ; MPIF TRIGGER, then just ignore this application acknowledgment. This
+4 ; message is not sent from MPI, and was probably sent in error.
+5 ;**55
if $GET(HL("SAN"))'="MPIF TRIGGER"!($GET(HL("RAN"))'="MPIF TRIGGER")
QUIT
+6 FOR NXT=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+7 IF $EXTRACT(HLNODE,1,3)="MSA"
SET DFN=$PIECE($PIECE(HLNODE,HL("FS"),7),"=",2)
+8 IF $EXTRACT(HLNODE,1,3)="MSA"&($PIECE(HLNODE,HL("FS"),4)'="")
Begin DoDot:2
+9 ; ERROR RETURNED IN MSA - LOG EXCEPTION
+10 DO START^RGHLLOG(HLMTIEN,"","")
+11 DO EXC^RGHLLOG(208,$PIECE(HLNODE,HL("FS"),4)_" for HL msg# "_HLMTIEN,DFN)
+12 DO STOP^RGHLLOG(0)
End DoDot:2
End DoDot:1
+13 KILL ^XTMP("MPIFA40%"_DFN)
+14 QUIT
+15 ;
BLDMRG(IEN,FLD,SEG,HL,ERR) ; bld MRG segment ONLY FIELDS 2 AND 8 SUPPORTED
+1 NEW NODE,MPIZN,MG,X,COMP,SUBCOMP,REP,NAME,ICN,SITE
+2 SET COMP=$EXTRACT(HL("ECH"),1)
SET SUBCOMP=$EXTRACT(HL("ECH"),4)
SET REP=$EXTRACT(HL("ECH"),2)
SET ICN=""
+3 SET MPIZN=$DATA(^DPT(IEN,0))
+4 IF MPIZN=""
SET ERR="-1^No such DFN entry "_IEN
QUIT
+5 SET SEG="MRG"
+6 ;repeat prior ID's including ICN and DFN
+7 SET NODE=$$MPINODE^MPIFAPI(IEN)
+8 ;**51
IF +NODE=-1
SET NODE=""
+9 ;**51
IF NODE'=""
SET ICN=$PIECE(NODE,"^",1)_"V"_$PIECE(NODE,"^",2)
+10 ;**51
SET SITE=$PIECE($$SITE^VASITE(),"^",3)
+11 ;**51
IF ICN=""!(ICN="V")
SET ICN=HL("Q")
+12 ;**41
SET MG(2)=ICN_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"NI"_COMP_"VA FACILITY ID"_SUBCOMP_SITE_SUBCOMP_"L"_REP_IEN_COMP_COMP_COMP_"USVHA"_SUBCOMP_SUBCOMP_"0363"_COMP_"PI"_COMP_"VA FACILITY ID"_SUBCOMP_SITE_SUBCOMP_"L"
+13 ;NAME
+14 SET NAME("FILE")=2
SET NAME("IENS")=IEN
SET NAME("FIELD")=.01
+15 SET MG(8)=$$HLNAME^XLFNAME(.NAME,"",COMP)
+16 SET $PIECE(MG(8),COMP,7)="L"
+17 SET $PIECE(SEG,HL("FS"),2)=MG(2)
+18 SET $PIECE(SEG,HL("FS"),8)=MG(8)
+19 QUIT
