- MPIFA31B ;BP/CMC-BUILD A31 MSGS ;7/15/21 15:04
- ;;1.0;MASTER PATIENT INDEX VISTA;**22,24,27,28,31,25,44,46,54,59,60,64,68,75,78**;30 Apr 99;Build 1
- ;
- ; Integration Agreements Utilized:
- ; START, EXC, STOP^RGHLLOG - #2796
- ; BLDEVN, BLDPD1, BLDPID^VAFCQRY - #3630
- ; $$PV1^VAFCSB, $$RADE^VAFCSB, $$LABE^VAFCSB, $$PHARA^VAFCSB, $$PV2^VAFCSB - #4921
- ;
- TA31 ; Tasked entry point
- N TMP
- S TMP=$$A31(DFN)
- Q
- ;
- A31(DFN) ;BUILD AND SEND A31
- I $P($$SITE^VASITE,"^",3)=200 Q 1
- ; ^ PATCH 25 IF this is the FHIE Host system, don't build A31 messages
- N RESLT,CNT,MPI,EVN,TCNT,ERR,PD1,PID,EN,LAB,PV1,PV2,RAD,PRE,OLD,ZPD
- N ZEL,ZSP,SIDG,NAMECOMP,DODF,DODD,DODNP,DODOPT,DODDISDT,SECLVL,SEXOR,SEXORD,PRON,PROND
- K HLA("HLA"),HLA("HLS")
- Q:$E($$GETICN^MPIF001(DFN),1,3)=$P($$SITE^VASITE(),"^",3) 0
- ; ^ LOCAL ICN DON'T SEND
- Q:+$$GETICN^MPIF001(DFN)=-1 0
- ; ^ NO ICN DON'T SEND
- S CNT=1
- D INIT^HLFNC2("MPIF ADT-A31 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="",TCNT=0
- D BLDEVN^VAFCQRY(DFN,"1,2",.EVN,.HL,"A31",.ERR)
- Q:ERR'="" ERR
- D BLDPID^VAFCQRY(DFN,1,"ALL",.PID,.HL,.ERR) ;**25
- Q:ERR'="" ERR
- D BLDPD1^VAFCQRY(DFN,"3",.PD1,.HL,.ERR) ;**44 NEW PD1 SEGMENT VALUES -- SENDING CMOR AGAIN AS WITHOUT 40 ON THE MPI SIDE THIS IS A PROBLEM.
- ;S PD1=$$PD1^VAFCSB ;**44 NEW PD1 SEGMENT VALUES -- IMDQ DECIDED NOT TO SEND PREFERRED FACILITY 9/7/06
- N X S X="VAFCSB" X ^%ZOSF("TEST") I $T D
- .;**44 VAFCSB coming in with DG*5.3*707
- .S PV1=$$PV1^VAFCSB ;**44 PV1 segment
- .S RAD=$$RADE^VAFCSB ;**44 OBX FOR LAST RADIOLOGY EXAM
- .S LAB=$$LABE^VAFCSB ;**44 OBX FOR LAST LAB EXAM
- .S PRE=$$PHARA^VAFCSB ;**44 OBX FOR ACTIVE PRESCRIPTIONS
- .S SIDG=$$SIG^VAFCSB(DFN) ;**59 OBX FOR SELF ID GENDER
- .S NAMECOMP=$$NAMEOBX^VAFCSB(DFN) ;**59,MVI_3975 (mko): OBX for Patient .01 and Name Components
- .S SECLVL=$$SECLOG^VAFCSB(DFN) ;**68 Story 783361 (ckn) - OBX for Security Level
- .D SEXOR^VAFCSB(DFN,.SEXOR) ;**78, VAMPI-11114 (dri)
- .D SEXORD^VAFCSB(DFN,.SEXORD) ;**78, VAMPI-11114 (dri)
- .D PRON^VAFCSB(DFN,.PRON) ;**78, VAMPI-11118 (dri)
- .D PROND^VAFCSB(DFN,.PROND) ;**78, VAMPI-11118 (dri)
- .S PV2=$$PV2^VAFCSB ;**44 PV2 segment
- S DODF=$$DODF^VAFCSB(DFN) ;**60 OBX for DOD fields
- ;**64 Story 323009 (ckn) : OBX for Additional DOD fields
- S DODD=$$DODD^VAFCSB(DFN) ;Date Of Death Documents
- S DODOPT=$$DODOPT^VAFCSB(DFN) ; Date Of Death Option used
- S DODNP=$$DODNTPRV^VAFCSB(DFN) ; Date Of Death Notification provider
- S OLD=$$OLD ;**54,MVI_913: OBX to mark an older record
- S ZPD=$$EN1^VAFHLZPD(DFN,"1,17,21,34") ;25 ;**44 ADDED PSEUDO SSN REASON (34), 1 and 21 TO ZPD SEGMENT
- S ZSP=$$EN^VAFHLZSP(DFN) ;**59
- S ZEL=$$EN^VAFHLZEL(DFN,"1,8,9",1) ;**59
- S EN=1
- S HLA("HLS",EN)=EVN(1),EN=EN+1
- S CNT=0 F S CNT=$O(PID(CNT)) Q:CNT="" D
- .I CNT=1 S HLA("HLS",EN)=PID(CNT)
- .I CNT>1 S HLA("HLS",EN,CNT-1)=PID(CNT)
- S EN=EN+1
- I $G(PD1(1))'="" S HLA("HLS",EN)=PD1(1),EN=EN+1 ;**44 only pass PD1 segment if has values -- SENDING CMOR AGAIN AS WITHOUT 40 ON MPI SIDE THIS IS A PROBLEM.
- I $G(PV1)'="" S HLA("HLS",EN)=PV1,EN=EN+1 ;**44 only pass PV1 segment if has values
- I $G(PV2)'="" S HLA("HLS",EN)=PV2,EN=EN+1 ;**44 only pass PV2 segment if has values
- I $G(RAD)'="" S HLA("HLS",EN)=RAD,EN=EN+1 ;**44 only pass RADIOLOGY IN OBX segment if has values
- I $G(LAB)'="" S HLA("HLS",EN)=LAB,EN=EN+1 ;**44 only pass LAB IN OBX segment if has values
- I $G(PRE)'="" S HLA("HLS",EN)=PRE,EN=EN+1 ;**44 only pass PRESCRIPTION IN OBX segment if has values
- I $G(OLD)'="" S HLA("HLS",EN)=OLD,EN=EN+1 ;**54,MVI_913: pass OLDER RECORD in OBX if flagged as such
- I $G(SIDG)'="" S HLA("HLS",EN)=SIDG,EN=EN+1 ;**59
- I $G(DODF)'="" S HLA("HLS",EN)=DODF,EN=EN+1 ;**60 MVI_4733 (ckn) Pass DOD fields in OBX
- ;**64 Story 323009 (ckn) : Pass additional DOD fields in OBX
- I $G(DODD)'="" S HLA("HLS",EN)=DODD,EN=EN+1
- I $G(DODOPT)'="" S HLA("HLS",EN)=DODOPT,EN=EN+1
- I $G(DODNP)'="" S HLA("HLS",EN)=DODNP,EN=EN+1
- I $G(NAMECOMP)'="" S HLA("HLS",EN)=NAMECOMP,EN=EN+1 ;**59,MVI_3975 (mko): pass NAME COMPONENTS in OBX
- I $G(SECLVL)'="" S HLA("HLS",EN)=SECLVL,EN=EN+1 ;**68,Story 783361 (ckn)- Security
- I $O(SEXOR(0)) N CNT S CNT=0 F S CNT=$O(SEXOR(CNT)) Q:'CNT S HLA("HLS",EN)=SEXOR(CNT),EN=EN+1 ;**78, VAMPI-11114 (dri)
- I $O(SEXORD(0)) D S EN=EN+1 ;**78, VAMPI-11114 (dri)
- .N CNT,LVL
- .S LVL=1,CNT=0 F S CNT=$O(SEXORD(CNT)) Q:'CNT D
- ..I CNT=1 S HLA("HLS",EN)=SEXORD(CNT)
- ..I CNT>1 S HLA("HLS",EN,LVL)=SEXORD(CNT),LVL=LVL+1
- I $O(PRON(0)) N CNT S CNT=0 F S CNT=$O(PRON(CNT)) Q:'CNT S HLA("HLS",EN)=PRON(CNT),EN=EN+1 ;**78, VAMPI-11118 (dri)
- I $O(PROND(0)) D S EN=EN+1 ;**78, VAMPI-11118 (dri)
- .N CNT,LVL
- .S LVL=1,CNT=0 F S CNT=$O(PROND(CNT)) Q:'CNT D
- ..I CNT=1 S HLA("HLS",EN)=PROND(CNT)
- ..I CNT>1 S HLA("HLS",EN,LVL)=PROND(CNT),LVL=LVL+1
- S HLA("HLS",EN)=ZPD,EN=EN+1 ;**44 ZPD SEGMENT
- I $G(ZSP)'="" S HLA("HLS",EN)=ZSP,EN=EN+1 ;**59 ZSP segment
- I $G(ZEL)'="" S HLA("HLS",EN)=ZEL,EN=EN+1 ;**59 ZEL segment
- S MPI=$$MPILINK^MPIFAPI()
- Q:$P($G(MPI),"^")=-1 "-1^No logical link defined for the MPI"
- ;**75 - Story - 1260465 (ckn) - Include 200M in HLL links for HAC
- S HLL("LINKS",1)="MPIF ADT-A31 CLIENT^"_MPI_$S($P($$SITE^VASITE(),"^",3)=741:"^200M",1:"")
- D GENERATE^HLMA("MPIF ADT-A31 SERVER","LM",1,.MPIFRSLT,"","")
- S RESLT=$S(+MPIFRSLT:MPIFRSLT,1:"-1^"_$P(MPIFRSLT,"^",3)) ;**68 Story 827754 (jfw) - Make Error Data Consistent (-1^msg)
- S ^XTMP("MPIFA31%"_DFN,0)=$$FMADD^XLFDT(DT,5)_"^"_DT_"^"_"MPIA31 msg to MPI for DFN "_DFN
- I +RESLT<0 S ^XTMP("MPIFA31%"_DFN,"MPI",0)="A" ;**68 Story 827754 (jfw) - Check for value < 0 instead of '+RESLT
- K HLA,HLL("LINKS"),COMP,REP,SUBCOMP,HLA("HLA"),HLA("HLS"),MPIFRSLT
- ;**44 REMOVED HLEID, HLECH AND HLFS from Kill line above
- Q RESLT
- ;
- RES ;
- N NXT,DFN,ERROR,CODE S CODE=""
- 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),ERROR=$P(HLNODE,HL("FS"),4),CODE=$P(HLNODE,HL("FS"),2)
- .I $E(HLNODE,1,3)="MSA"&(CODE="AR") D
- ..; ERROR RETURNED IN MSA - LOG EXCEPTION
- ..D START^RGHLLOG(HLMTIEN,"","")
- ..;**44 check which type of exception to be logged
- ..D EXC^RGHLLOG(234,ERROR,DFN) ;**46
- ..D STOP^RGHLLOG(0)
- K:$G(DFN)>0 ^XTMP("MPIF OLD RECORDS",DFN) ;**54,MVI_913: Delete the old record designation
- K ^XTMP("MPIFA31%"_DFN)
- Q
- ;
- OLD() ; Return OBX segment to flag a record as "old"
- ;**54,MVI_913: New subroutine
- Q $S($D(^XTMP("MPIF OLD RECORDS",DFN))#2:"OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"OLDER RECORD"_HL("FS")_HL("FS")_"Y",1:"")
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMPIFA31B 6661 printed Jan 18, 2025@03:11:55 Page 2
- MPIFA31B ;BP/CMC-BUILD A31 MSGS ;7/15/21 15:04
- +1 ;;1.0;MASTER PATIENT INDEX VISTA;**22,24,27,28,31,25,44,46,54,59,60,64,68,75,78**;30 Apr 99;Build 1
- +2 ;
- +3 ; Integration Agreements Utilized:
- +4 ; START, EXC, STOP^RGHLLOG - #2796
- +5 ; BLDEVN, BLDPD1, BLDPID^VAFCQRY - #3630
- +6 ; $$PV1^VAFCSB, $$RADE^VAFCSB, $$LABE^VAFCSB, $$PHARA^VAFCSB, $$PV2^VAFCSB - #4921
- +7 ;
- TA31 ; Tasked entry point
- +1 NEW TMP
- +2 SET TMP=$$A31(DFN)
- +3 QUIT
- +4 ;
- A31(DFN) ;BUILD AND SEND A31
- +1 IF $PIECE($$SITE^VASITE,"^",3)=200
- QUIT 1
- +2 ; ^ PATCH 25 IF this is the FHIE Host system, don't build A31 messages
- +3 NEW RESLT,CNT,MPI,EVN,TCNT,ERR,PD1,PID,EN,LAB,PV1,PV2,RAD,PRE,OLD,ZPD
- +4 NEW ZEL,ZSP,SIDG,NAMECOMP,DODF,DODD,DODNP,DODOPT,DODDISDT,SECLVL,SEXOR,SEXORD,PRON,PROND
- +5 KILL HLA("HLA"),HLA("HLS")
- +6 if $EXTRACT($$GETICN^MPIF001(DFN),1,3)=$PIECE($$SITE^VASITE(),"^",3)
- QUIT 0
- +7 ; ^ LOCAL ICN DON'T SEND
- +8 if +$$GETICN^MPIF001(DFN)=-1
- QUIT 0
- +9 ; ^ NO ICN DON'T SEND
- +10 SET CNT=1
- +11 DO INIT^HLFNC2("MPIF ADT-A31 SERVER",.HL)
- +12 IF $ORDER(HL(""))=""
- QUIT "-1^"_$PIECE(HL,"^",2)
- +13 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)
- +14 SET ERR=""
- SET TCNT=0
- +15 DO BLDEVN^VAFCQRY(DFN,"1,2",.EVN,.HL,"A31",.ERR)
- +16 if ERR'=""
- QUIT ERR
- +17 ;**25
- DO BLDPID^VAFCQRY(DFN,1,"ALL",.PID,.HL,.ERR)
- +18 if ERR'=""
- QUIT ERR
- +19 ;**44 NEW PD1 SEGMENT VALUES -- SENDING CMOR AGAIN AS WITHOUT 40 ON THE MPI SIDE THIS IS A PROBLEM.
- DO BLDPD1^VAFCQRY(DFN,"3",.PD1,.HL,.ERR)
- +20 ;S PD1=$$PD1^VAFCSB ;**44 NEW PD1 SEGMENT VALUES -- IMDQ DECIDED NOT TO SEND PREFERRED FACILITY 9/7/06
- +21 NEW X
- SET X="VAFCSB"
- XECUTE ^%ZOSF("TEST")
- IF $TEST
- Begin DoDot:1
- +22 ;**44 VAFCSB coming in with DG*5.3*707
- +23 ;**44 PV1 segment
- SET PV1=$$PV1^VAFCSB
- +24 ;**44 OBX FOR LAST RADIOLOGY EXAM
- SET RAD=$$RADE^VAFCSB
- +25 ;**44 OBX FOR LAST LAB EXAM
- SET LAB=$$LABE^VAFCSB
- +26 ;**44 OBX FOR ACTIVE PRESCRIPTIONS
- SET PRE=$$PHARA^VAFCSB
- +27 ;**59 OBX FOR SELF ID GENDER
- SET SIDG=$$SIG^VAFCSB(DFN)
- +28 ;**59,MVI_3975 (mko): OBX for Patient .01 and Name Components
- SET NAMECOMP=$$NAMEOBX^VAFCSB(DFN)
- +29 ;**68 Story 783361 (ckn) - OBX for Security Level
- SET SECLVL=$$SECLOG^VAFCSB(DFN)
- +30 ;**78, VAMPI-11114 (dri)
- DO SEXOR^VAFCSB(DFN,.SEXOR)
- +31 ;**78, VAMPI-11114 (dri)
- DO SEXORD^VAFCSB(DFN,.SEXORD)
- +32 ;**78, VAMPI-11118 (dri)
- DO PRON^VAFCSB(DFN,.PRON)
- +33 ;**78, VAMPI-11118 (dri)
- DO PROND^VAFCSB(DFN,.PROND)
- +34 ;**44 PV2 segment
- SET PV2=$$PV2^VAFCSB
- End DoDot:1
- +35 ;**60 OBX for DOD fields
- SET DODF=$$DODF^VAFCSB(DFN)
- +36 ;**64 Story 323009 (ckn) : OBX for Additional DOD fields
- +37 ;Date Of Death Documents
- SET DODD=$$DODD^VAFCSB(DFN)
- +38 ; Date Of Death Option used
- SET DODOPT=$$DODOPT^VAFCSB(DFN)
- +39 ; Date Of Death Notification provider
- SET DODNP=$$DODNTPRV^VAFCSB(DFN)
- +40 ;**54,MVI_913: OBX to mark an older record
- SET OLD=$$OLD
- +41 ;25 ;**44 ADDED PSEUDO SSN REASON (34), 1 and 21 TO ZPD SEGMENT
- SET ZPD=$$EN1^VAFHLZPD(DFN,"1,17,21,34")
- +42 ;**59
- SET ZSP=$$EN^VAFHLZSP(DFN)
- +43 ;**59
- SET ZEL=$$EN^VAFHLZEL(DFN,"1,8,9",1)
- +44 SET EN=1
- +45 SET HLA("HLS",EN)=EVN(1)
- SET EN=EN+1
- +46 SET CNT=0
- FOR
- SET CNT=$ORDER(PID(CNT))
- if CNT=""
- QUIT
- Begin DoDot:1
- +47 IF CNT=1
- SET HLA("HLS",EN)=PID(CNT)
- +48 IF CNT>1
- SET HLA("HLS",EN,CNT-1)=PID(CNT)
- End DoDot:1
- +49 SET EN=EN+1
- +50 ;**44 only pass PD1 segment if has values -- SENDING CMOR AGAIN AS WITHOUT 40 ON MPI SIDE THIS IS A PROBLEM.
- IF $GET(PD1(1))'=""
- SET HLA("HLS",EN)=PD1(1)
- SET EN=EN+1
- +51 ;**44 only pass PV1 segment if has values
- IF $GET(PV1)'=""
- SET HLA("HLS",EN)=PV1
- SET EN=EN+1
- +52 ;**44 only pass PV2 segment if has values
- IF $GET(PV2)'=""
- SET HLA("HLS",EN)=PV2
- SET EN=EN+1
- +53 ;**44 only pass RADIOLOGY IN OBX segment if has values
- IF $GET(RAD)'=""
- SET HLA("HLS",EN)=RAD
- SET EN=EN+1
- +54 ;**44 only pass LAB IN OBX segment if has values
- IF $GET(LAB)'=""
- SET HLA("HLS",EN)=LAB
- SET EN=EN+1
- +55 ;**44 only pass PRESCRIPTION IN OBX segment if has values
- IF $GET(PRE)'=""
- SET HLA("HLS",EN)=PRE
- SET EN=EN+1
- +56 ;**54,MVI_913: pass OLDER RECORD in OBX if flagged as such
- IF $GET(OLD)'=""
- SET HLA("HLS",EN)=OLD
- SET EN=EN+1
- +57 ;**59
- IF $GET(SIDG)'=""
- SET HLA("HLS",EN)=SIDG
- SET EN=EN+1
- +58 ;**60 MVI_4733 (ckn) Pass DOD fields in OBX
- IF $GET(DODF)'=""
- SET HLA("HLS",EN)=DODF
- SET EN=EN+1
- +59 ;**64 Story 323009 (ckn) : Pass additional DOD fields in OBX
- +60 IF $GET(DODD)'=""
- SET HLA("HLS",EN)=DODD
- SET EN=EN+1
- +61 IF $GET(DODOPT)'=""
- SET HLA("HLS",EN)=DODOPT
- SET EN=EN+1
- +62 IF $GET(DODNP)'=""
- SET HLA("HLS",EN)=DODNP
- SET EN=EN+1
- +63 ;**59,MVI_3975 (mko): pass NAME COMPONENTS in OBX
- IF $GET(NAMECOMP)'=""
- SET HLA("HLS",EN)=NAMECOMP
- SET EN=EN+1
- +64 ;**68,Story 783361 (ckn)- Security
- IF $GET(SECLVL)'=""
- SET HLA("HLS",EN)=SECLVL
- SET EN=EN+1
- +65 ;**78, VAMPI-11114 (dri)
- IF $ORDER(SEXOR(0))
- NEW CNT
- SET CNT=0
- FOR
- SET CNT=$ORDER(SEXOR(CNT))
- if 'CNT
- QUIT
- SET HLA("HLS",EN)=SEXOR(CNT)
- SET EN=EN+1
- +66 ;**78, VAMPI-11114 (dri)
- IF $ORDER(SEXORD(0))
- Begin DoDot:1
- +67 NEW CNT,LVL
- +68 SET LVL=1
- SET CNT=0
- FOR
- SET CNT=$ORDER(SEXORD(CNT))
- if 'CNT
- QUIT
- Begin DoDot:2
- +69 IF CNT=1
- SET HLA("HLS",EN)=SEXORD(CNT)
- +70 IF CNT>1
- SET HLA("HLS",EN,LVL)=SEXORD(CNT)
- SET LVL=LVL+1
- End DoDot:2
- End DoDot:1
- SET EN=EN+1
- +71 ;**78, VAMPI-11118 (dri)
- IF $ORDER(PRON(0))
- NEW CNT
- SET CNT=0
- FOR
- SET CNT=$ORDER(PRON(CNT))
- if 'CNT
- QUIT
- SET HLA("HLS",EN)=PRON(CNT)
- SET EN=EN+1
- +72 ;**78, VAMPI-11118 (dri)
- IF $ORDER(PROND(0))
- Begin DoDot:1
- +73 NEW CNT,LVL
- +74 SET LVL=1
- SET CNT=0
- FOR
- SET CNT=$ORDER(PROND(CNT))
- if 'CNT
- QUIT
- Begin DoDot:2
- +75 IF CNT=1
- SET HLA("HLS",EN)=PROND(CNT)
- +76 IF CNT>1
- SET HLA("HLS",EN,LVL)=PROND(CNT)
- SET LVL=LVL+1
- End DoDot:2
- End DoDot:1
- SET EN=EN+1
- +77 ;**44 ZPD SEGMENT
- SET HLA("HLS",EN)=ZPD
- SET EN=EN+1
- +78 ;**59 ZSP segment
- IF $GET(ZSP)'=""
- SET HLA("HLS",EN)=ZSP
- SET EN=EN+1
- +79 ;**59 ZEL segment
- IF $GET(ZEL)'=""
- SET HLA("HLS",EN)=ZEL
- SET EN=EN+1
- +80 SET MPI=$$MPILINK^MPIFAPI()
- +81 if $PIECE($GET(MPI),"^")=-1
- QUIT "-1^No logical link defined for the MPI"
- +82 ;**75 - Story - 1260465 (ckn) - Include 200M in HLL links for HAC
- +83 SET HLL("LINKS",1)="MPIF ADT-A31 CLIENT^"_MPI_$SELECT($PIECE($$SITE^VASITE(),"^",3)=741:"^200M",1:"")
- +84 DO GENERATE^HLMA("MPIF ADT-A31 SERVER","LM",1,.MPIFRSLT,"","")
- +85 ;**68 Story 827754 (jfw) - Make Error Data Consistent (-1^msg)
- SET RESLT=$SELECT(+MPIFRSLT:MPIFRSLT,1:"-1^"_$PIECE(MPIFRSLT,"^",3))
- +86 SET ^XTMP("MPIFA31%"_DFN,0)=$$FMADD^XLFDT(DT,5)_"^"_DT_"^"_"MPIA31 msg to MPI for DFN "_DFN
- +87 ;**68 Story 827754 (jfw) - Check for value < 0 instead of '+RESLT
- IF +RESLT<0
- SET ^XTMP("MPIFA31%"_DFN,"MPI",0)="A"
- +88 KILL HLA,HLL("LINKS"),COMP,REP,SUBCOMP,HLA("HLA"),HLA("HLS"),MPIFRSLT
- +89 ;**44 REMOVED HLEID, HLECH AND HLFS from Kill line above
- +90 QUIT RESLT
- +91 ;
- RES ;
- +1 NEW NXT,DFN,ERROR,CODE
- SET CODE=""
- +2 FOR NXT=1:1
- XECUTE HLNEXT
- if HLQUIT'>0
- QUIT
- Begin DoDot:1
- +3 IF $EXTRACT(HLNODE,1,3)="MSA"
- SET DFN=$PIECE($PIECE(HLNODE,HL("FS"),7),"=",2)
- SET ERROR=$PIECE(HLNODE,HL("FS"),4)
- SET CODE=$PIECE(HLNODE,HL("FS"),2)
- +4 IF $EXTRACT(HLNODE,1,3)="MSA"&(CODE="AR")
- Begin DoDot:2
- +5 ; ERROR RETURNED IN MSA - LOG EXCEPTION
- +6 DO START^RGHLLOG(HLMTIEN,"","")
- +7 ;**44 check which type of exception to be logged
- +8 ;**46
- DO EXC^RGHLLOG(234,ERROR,DFN)
- +9 DO STOP^RGHLLOG(0)
- End DoDot:2
- End DoDot:1
- +10 ;**54,MVI_913: Delete the old record designation
- if $GET(DFN)>0
- KILL ^XTMP("MPIF OLD RECORDS",DFN)
- +11 KILL ^XTMP("MPIFA31%"_DFN)
- +12 QUIT
- +13 ;
- OLD() ; Return OBX segment to flag a record as "old"
- +1 ;**54,MVI_913: New subroutine
- +2 QUIT $SELECT($DATA(^XTMP("MPIF OLD RECORDS",DFN))#2:"OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"OLDER RECORD"_HL("FS")_HL("FS")_"Y",1:"")
- +3 ;