AGMPIHLO ;IHS/SD/TPF - Patient Registration MPI HLO Interface ALL HLO MESSAGES
;;7.2;IHS PATIENT REGISTRATION;**1,3,5,6**;MAY 20, 2010;Build 23
;BADEHL1 was used as a template for this routine
Q
;FOR PATIENT MERGE A40
;^TMP("XDRFROM",$J,TOMIEN,FROMIEN,FROMIEN_GLOBROOT,TOIEN_GLOBROOT)=FILE
;^TMP("XDRFROM",2804,6364,1991,"6364;DPT(","1991;DPT(")=2
;BPMRY = "^TMP(""XDRFROM"",$J)"
NEWMSG(BPMRY) ;EP - FOR PATIENT MERGE
N AGMPIFR,AGMPITO
S AGMPITO=$O(@BPMRY@(0))
I '$G(AGMPITO) S A40ERR=1 D NOTIF(AGMPITO,"Unable to build HL7 message. ERR:A40: NO TO DFN FOR A40 EVENT") Q
I '$D(^DPT(AGMPITO,0)) S A40ERR=1 D NOTIF(AGMPITO,"Unable to build HL7 message. ERR:A40: NO DPT ENTRY FOR DFN "_AGMPITO) Q
;
S AGMPIFR=$O(@BPMRY@(AGMPITO,0))
I '$G(AGMPIFR) S A40ERR=1 D NOTIF(AGMPIFR,"Unable to build HL7 message. ERR:A40: NO DFN2 FOR A40 EVENT") Q
I '$D(^DPT(AGMPIFR,0)) S A40ERR=1 D NOTIF(AGMPIFR,"Unable to build HL7 message. ERR:A40: NO DPT ENTRY FOR DFN2 "_AGMPIFR) Q
D CREATMSG(AGMPIFR,"A40",AGMPITO,.SUCCESS)
Q
;
;BUILD OUTBOUND MESSAGES
;SEND VTQ TO GET THE OLD VA NON-STANDARD MESSAGE
;SEND VQQ TO GET A REGULAR HL7 MESSAGE
CREATMSG(DFN,EVNTTYPE,DFN2,SUCCESS) ;EP - START FOR MOST PAT REG TRIGGERS
;S AGMPSTOP=1
; 9/07/2017 - GCD - CR 7693 - Disabled VQQ messages.
I $G(EVNTTYPE)="VTQ"!($G(EVNTTYPE)="VQQ") S SUCCESS=0 Q
;MODIFIED 11/28/2016 - SWH
I '($G(AGMPCHKFLG)),$G(^AGMPCHK(0)),'($G(^AGMPCHK(DUZ(2),1))="VALID") D Q ; CHECK TO SEE IF WE HAVE THE GLOBAL BUILT AND IF THE SITE CAN TRIGGER MESSAGES.
.S SUCCESS=0
.I '($G(^AGMPCHK(DUZ(2)))) D NOTIF("","Site "_DUZ(2)_"isn't defined within the ^AGMPCHK global.") Q
.I '($G(DFN2)) S DFN2=""
.D UPDMSGQ^AGMPCHK(DFN,DFN2,EVNTTYPE,DUZ(2))
.I '($G(ZTQUEUED)) W !,"Site "_DUZ(2)_" / "_$G(^AGMPCHK(DUZ(2)))_" is disabled in ^AGMPCHK, the message was not sent!"
.I $D(^AGMPCHK(DUZ(2),"NT")) D
..I (+($P(^AGMPCHK(DUZ(2),"NT"),",")))=(+($p($H,","))) S TCHCK=((+($P($H,",",2)))-(+($P(^AGMPCHK(DUZ(2),"NT"),",",2))))
..I '((+($P(^AGMPCHK(DUZ(2),"NT"),",")))=(+($p($H,",")))) S TCHCK=3600
..I TCHCK>3599 D
...D NOTIF("","The "_DUZ(2)_" / "_$G(^AGMPCHK(DUZ(2),1))_" site is disabled.")
...S ^AGMPCHK(DUZ(2),"NT")=$H
;
I $G(AGMPSTOP) S SUCCESS=1 Q
; 9/13/2017 - GCD - CR 7713 - Don't upload demo patients.
I $$DEMOPAT^AGMPHLU($G(DFN)) S SUCCESS=0 Q
I $G(DFN2)'="",$$DEMOPAT^AGMPHLU(DFN2) S SUCCESS=0 Q
N A40ERR
S SUCCESS=1
S A40ERR=0
I $G(EVNTTYPE)="A40" D Q:$G(A40ERR)
.I '$G(DFN2) S A40ERR=1 D NOTIF(DFN,"Unable to build HL7 message. ERR:A40: NO DFN2 FOR A40 EVENT")
.I '$G(DFN) S A40ERR=1 D NOTIF(DFN,"Unable to build HL7 message. ERR:A40: NO DFN FOR A40 EVENT")
.I '$D(^DPT(DFN2,0)) S A40ERR=1 D NOTIF(DFN,"Unable to build HL7 message. ERR:A40: NO DPT ENTRY FOR DFN2 "_DFN2)
.I '$D(^DPT(DFN,0)) S A40ERR=1 D NOTIF(DFN,"Unable to build HL7 message. ERR:A40: NO DPT ENTRY FOR DFN "_DFN)
N HLPM,HLST,ARY,HLQ,APPARMS,HLPM,HLMSGIEN,HLECH,HLFS,ERR,WHO
N LN,HL1,HRCN,FLD,LP,X,LN
S LN=0
;
I EVNTTYPE="VQQ" D
.W !," THIS IS BOMBING OUT ENSEMBLE"
.W !,"WE WANT TO SEND A NORMAL MESSAGE WHEN DOING VQQ"
.W !,"OR CHANGE THE VTQ EVENT INTO A REGULAR MESSAGE"
I EVNTTYPE'="VTQ",(EVNTTYPE'="M05") D
.S HLPM("MESSAGE TYPE")="ADT"
.S HLPM("EVENT")=EVNTTYPE
E I EVNTTYPE="M05" D
.S HLPM("MESSAGE TYPE")="MFK"
.S HLPM("EVENT")=EVNTTYPE
E D
.S HLPM("MESSAGE TYPE")="VQQ"
.S HLPM("EVENT")="Q02"
;
S HLPM("VERSION")=2.4
S HLPM("FIELD SEPARATOR")="^"
S HLPM("ENCODING CHARACTERS")="~|\&"
I '$$NEWMSG^HLOAPI(.HLPM,.HLST,.ERR) D Q
.D NOTIF(DFN,"Unable to build HL7 message."_$S($D(ERR):" ERR:"_$G(ERR),1:""))
S HLFS=HLPM("FIELD SEPARATOR")
S HLECH=HLPM("ENCODING CHARACTERS")
S HL1("ECH")=HLECH
S COMP=$E(HL1("ECH"))
S SUBCOMP=$E(HL1("ECH"),4)
S HL1("FS")=HLFS
S HL1("Q")=""
S HL1("VER")=HLPM("VERSION")
;Create segments
;
;THIS CREATES THE 'ODD' NON-STANDARD HL7 VA QUERY MESSAGE
;I EVNTTYPE="VTQ" D Q
;.D VTQ^AGMPIHL1(DFN)
;.I '$D(ERR) D RDF^AGMPIHL1(DFN)
;.I '$D(ERR) D DOSEND
;
;
I EVNTTYPE="M05" D Q
.N SEG,TAG
.S SEG=""
.F S SEG=$O(MFK(SEG)) Q:'SEG D Q:$D(ERR)
..S TAG=$G(MFK(SEG,1,1,1,1))
..Q:TAG="ZET"
..I TAG'="" S TAG=TAG_"("_SEG_")"
..E S TAG="MFA("_SEG_")"
..D @TAG
..I $D(ERR) D NOTIF(DFN,$P(TAG,"(")_"segment could not be created") Q
.D DOSEND
;
;REGULAR MESSSAGES
D EVN(EVNTTYPE)
I '$D(ERR) D PID^AGMPIHL1(DFN)
I '$D(ERR),(EVNTTYPE="A08")!(EVNTTYPE="A01")!(EVNTTYPE="A03") D PD1(DFN)
I '$D(ERR),(EVNTTYPE="A08")!(EVNTTYPE="A01")!(EVNTTYPE="A03") D
.D PV1(DFN)
.;I '$D(ERR),(EVNTTYPE'="A01"),(EVNTTYPE'="A03") D OBX(DFN)
;
I '$D(ERR),($G(EVNTTYPE)'="A40") D ZPD^AGMPIHL1(DFN) ;RPMS SPECIFIC DATA
;
I '$D(ERR),($G(EVNTTYPE)="A40") D MRG^AGMPIHL1(DFN2) ; DO A40 MERGE SEGMENT
I '$D(ERR),(EVNTTYPE="A28") D NK1(DFN)
;
DOSEND ;EP
I '$D(ERR) D
.; Define sending and receiving parameters
.;SEE PG71 HLO TECH MANUAL FOR SOME OF THESE PARAMETERS
.S APPARMS("SENDING APPLICATION")="RPMS-MPI"
.S APPARMS("ACCEPT ACK TYPE")="AL" ;Commit ACK type
.I EVNTTYPE="A28" D
..S APPARMS("APP ACK RESPONSE")="RES^AGMPHIACK"
..S APPARMS("ACCEPT ACK RESPONSE")="RES^AGMPHIACK"
.E D
..S APPARMS("APP ACK RESPONSE")="AACK^AGMPIHLO" ;Callback when 'application ACK' is received
..S APPARMS("ACCEPT ACK RESPONSE")="CACK^AGMPIHLO" ;Callback when 'commit ACK' is received
.S APPARMS("APP ACK TYPE")="NE" ;(FIELD 16) Application ACK type ;TPF - CHANGED TO THIS BECAUSE OF "SE" ERROR
.S APPARMS("QUEUE")="MPI RPMS" ;Incoming QUEUE
.S APPARMS("RECEIVING APPLICATION")="MPI RPMS"
.S WHO("RECEIVING APPLICATION")="MPI" ;THIS DOES OVERRIDE LINE ABOVE MSH-5
.S WHO("FACILITY LINK NAME")="MPI"
.S WHO("STATION NUMBER")="8990" ;IHS/SD/TPF MPI TEST SET MSH-6 RECEIVING FACILITY (MPI SERVER)
.S WHO("IE LINK NAME")="MPI" ;FOR HLO TESTING
.S APPARMS("SENDING FACILITY")=$$GET1^DIQ(4,DUZ(2)_",",99,"E")
.S WHO("SENDING FACILITY")=$$GET1^DIQ(4,DUZ(2)_",",99,"E")
.;S WHO("PORT")=5200 ; THIS SETS THE PORT WE ARE SENDING FROM THIS IS ALSO SET BY THE MPI HL LOGICAL LINK
.S WHO("STATION")=$$GET1^DIQ(4,DUZ(2)_",",99,"E")
.S HLST("SYSTEM","PORT")=$$GET1^DIQ(9009061,DUZ(2)_",",2203) ;LOCAL LISTENER PORT FOR MPI FIELD
.S HLST("SYSTEM","STATION")=$$GET1^DIQ(4,DUZ(2)_",",99,"E")
.;MPI HAS BEEN ASSIGNED PORTS BETWEEN 5200:5299 TO USE
.;5200 FOR TEST SENDER 5201 FOR TEST LISTENER
.;5202 FOR PRD SENDER 5203 FOR PRD LISTENER
.I HLST("SYSTEM","PORT")="" D Q
..S SUCCESS=0
..D NOTIF(DFN,"LISTENER PORT NULL IN REG. PARAMETER FILE")
.I HLST("SYSTEM","STATION")="" D Q
..S SUCCESS=0
..D NOTIF(DFN,"STATION NUMBER NULL IN FILE 4 ")
.; 05/24/2013 - KJH - TFS8008 - Remove extraneous locks on the HLO globals.
.S SUCCESS=$$SENDONE^HLOAPI1(.HLST,.APPARMS,.WHO,.ERR)
.;I EVNTTYPE="A40" D NOTIF(DFN,"AN A40 MESSAGE HAS BEEN CREATED "_SUCCESS) ; AG*7.2*5/CR 7718 - NOTIF sets SUCCESS to 0 and we don't need this call.
.I 'SUCCESS D
..D NOTIF(DFN,"Unable to create HL7 message."_$S($D(ERR):" ERR:"_$G(ERR),1:""))
I $D(ERR) D
.I ERR[("NOT DEFINED IN PID^AGMPIHL1") S SUCCESS=1_U_ERR Q ;THIS IS A TIMING ISSUE THAT SEEMS TO RESOLVE ITSELF FOR A08
.S SUCCESS=0
.D NOTIF($G(DFN),"Unable to send HL7 message."_$S($D(ERR):" ERR:"_$G(ERR),1:""))
Q
;THIS IS FOR HLO APP USE. NOT BEING USED HOWEVER
AACK ; EP - Application ACK callback - called when AA, AE or AR is received.
N DATA,AACK,XQAID,XQDATA,XQA,XQAMSG,MSGID
Q:'$G(HLMSGIEN)
S MSGID=$P($G(^HLB(+HLMSGIEN,0)),U)
S AACK=$G(^HLB(HLMSGIEN,4))
I $P(AACK,U,3)'["|AA|" D
.S XQAMSG="AGMPI message "_MSGID_" did not receive a correct application ack."
.S XQAID="AGMPI,"_MSGID_","_50
.S XQDATA=$P(AACK,U,3)
.S XQA("G.AGMPI MPI")=""
.D SETUP^XQALERT
Q
;THIS IS FOR HLO APP USE. NOT BEING USED HOWEVER
CACK ; EP - Commit ACK callback - called when CA, CE or CR is received.
N CACK,XQAID,XQAMSG,XQA,XQDATA,MSGID
S MSGID=$P($G(^HLB(+HLMSGIEN,0)),U)
S CACK=$G(^HLB(HLMSGIEN,4))
I $P(CACK,U,3)'["|CA|" D
.S XQAMSG="AGMPI message "_MSGID_" did not receive a correct commit acknowledgement."
.S XQAID="AGMPI,"_MSGID_","_50
.S XQDATA=$P(CACK,U,3)
.S XQA("G.AGMPI MPI")=""
.D SETUP^XQALERT
Q
;
; Send Notification to group
; Input: DFN = Patient
; MSG = Main message
NOTIF(DFN,MSG) ;EP
N PNAM,PVDIEN,RET,X,SAVE
N XQA,XQAID,XQADATA,XQAMSG
S SUCCESS=0
S PNAM=""
S:$G(DFN)'="" PNAM=$P($G(^DPT(DFN,0)),U)
I $L(PNAM)>15 S PNAM=$E(PNAM,1,15)
S XQAMSG=PNAM_" "
S XQAMSG=XQAMSG_$G(MSG)
S XQAID="ADEN,"_DFN_","_50
S XQDATA="DFN="_DFN
S XQA("G.AGMP MPI")=""
D SETUP^XQALERT
;Save the DFN in a parameter for correction
S X=$$GET^XPAR("ALL","AGMP MPI TOTAL ERRORS",1,"E")
S X=X+1
S SAVE=DFN_" "_MSG
D EN^XPAR("SYS","AGMP MPI ERROR PTS",X,SAVE)
D EN^XPAR("SYS","AGMP EDR TOTAL ERRORS",1,X)
Q
;
ERR ;
Q
;
EVN(EVNTTYPE) ;Create the EVN segment
N %,X,FLD,VAL
D NOW^%DTC
S X=$$HLDATE^HLFNC(%,"TS")
S FACNAME=$$GET1^DIQ(9999999.06,DUZ(2)_",",.01,"E")
;GOT DATA FROM OLD V1.6 BLDEVT^VAFCQRY2
S USERNAME=DUZ
S USERNAME=$$GET1^DIQ(200,+USERNAME_",",.01)
S USERNAME=$$HLNAME^HLFNC(USERNAME,HL1("ECH"))
;SET(SEG,VALUE,FIELD,COMP,SUBCOMP,REP)
D MYSET(.ARY,"EVN",0)
D MYSET(.ARY,$S(EVNTTYPE="A01":"A1",EVNTTYPE="A03":"A2",1:EVNTTYPE),1,1,1,1) ;A1 AND A2 MATCH UP TO ENTRIES IN THE 'ADT/HL7 EVENT REASON' FILE
D MYSET(.ARY,DUZ,5,1,1,1)
D MYSET(.ARY,$P(USERNAME,COMP),5,1,2,1)
D MYSET(.ARY,$P(USERNAME,COMP,2),5,1,3,1)
D MYSET(.ARY,"USIHS",5,1,9,1)
D MYSET(.ARY,"0363",5,1,9,3)
D MYSET(.ARY,"L",5,1,10,1)
D MYSET(.ARY,"NI",5,1,13,1)
D MYSET(.ARY,"IHS FACILITY ID -"_FACNAME,5,1,14,1)
D MYSET(.ARY,$P($$SITE^VASITE,"^",3),5,1,14,2)
D MYSET(.ARY,"L",5,1,14,3)
D MYSET(.ARY,$P($$SITE^VASITE,"^",3),7,1,1,1)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
I $D(ERR) D NOTIF(DFN,"EVT segment could not be created")
Q
;
PD1(DFN) ;EP
Q:'$G(DFN)
N PD1
S VAFCMN=$$MPINODE^AGMPIPID(DFN)
S CMOR=$P(VAFCMN,"^",3)
I CMOR'="" S SITE=$$NS^XUAF4(CMOR)
E S SITE=""
;
D MYSET(.ARY,"PD1",0)
D MYSET(.ARY,$P(SITE,U),3,1,1,1)
D MYSET(.ARY,$P(SITE,U),3,1,1,1)
D MYSET(.ARY,"D",3,1,2,1)
D MYSET(.ARY,$P(SITE,"^",2),3,1,3,1)
S PD1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
I $D(ERR) D NOTIF(DFN,ERR)
Q
;
PV1(DFN) ;EP - PATIENT VISIT
Q:'$G(DFN)
N PV1
;
D MYSET(.ARY,"PV1",0)
D MYSET(.ARY,1,1,1,1,1)
D MYSET(.ARY,$G(SDT),44,1,1,1)
S PV1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
I $D(ERR) D NOTIF(DFN,ERR)
Q
;
OBX(DFN) ;EP - OBSERVATION/RESULT
Q:'$G(DFN)
N OBX
;
D MYSET(.ARY,"OBX",0)
D MYSET(.ARY,1,1,1,1,1)
S OBX=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
I $D(ERR) D NOTIF(DFN,ERR)
Q
;
;NOT USED; MAY USE IN FUTURE
NK1(DFN) ;EP
Q
N ADDR,NK1,NODE,PHONE,DGNAME,FLD,K,CNT,SHIP,REL,HLQ
S CNT=0
S HLQ=HL1("Q")
F K="EC","NOK" D
.I K="EC" S NODE=$G(^DPT(DFN,.33))
.I K="NOK" S NODE=$G(^DPT(DFN,.21))
.Q:NODE=""
.S CNT=CNT+1
.D MYSET(.ARY,"NK1",0)
.D MYSET(.ARY,CNT,1)
.S DGNAME("FILE")=2,DGNAME("IENS")=DFN
.S DGNAME("FIELD")=$S(K="NOK":.211,K="EC":.331)
.;Name of next of kin
.S FLD=$$HLNAME^XLFNAME(.DGNAME,"","^")
.F LP=1:1:$L(FLD,$E(HLECH)) S VAL=$P(FLD,$E(HLECH),LP) D
..D MYSET(.ARY,VAL,2,LP)
.;Relationship
.S SHIP=$S(K="EC":$P($G(^AUPNPAT(DFN,31)),U,2),K="NOK":$P($G(^AUPNPAT(DFN,28)),U,2))
.I SHIP'="" D
..S X=$P($G(^AUTTRLSH(SHIP,0)),U,2)_"^"_$P($G(^AUTTRLSH(SHIP,0)),U,1)_"^UB-92"
..F LP=1:1:$L(X,$E(HLECH)) S VAL=$P(X,$E(HLECH),LP) D
...D MYSET(.ARY,VAL,3,LP)
.S ADDR=$$ADDR^VAFHLFNC($P(NODE,U,3,8))
.F LP=1:1:$L(ADDR,$E(HLECH)) S VAL=$P(ADDR,$E(HLECH),LP) D
..D MYSET(.ARY,VAL,4,LP) ;Address
.S PHONE=$$HLPHONE^HLFNC($P(NODE,U,9))
.I $L(PHONE) D
..D MYSET(.ARY,PHONE,5) ;Home phone
..D MYSET(.ARY,"PRN",5,2)
..D MYSET(.ARY,"PH",5,3)
.S PHONE=$$HLPHONE^HLFNC($P(NODE,U,11))
.I $L(PHONE) D
..D MYSET(.ARY,PHONE,6) ;Work phone
..D MYSET(.ARY,"WPH",6,2)
..D MYSET(.ARY,"PH",6,3)
.D MYSET(.ARY,K,7)
.D MYSET(.ARY,$S(K="EC":"Emergency Contact",K="NOK":"Next of Kin",1:""),7,2)
.S NK1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
.I $D(ERR) D NOTIF(DFN,ERR)
Q
;
MFI(SEG) ;EP - FOR MFK RESPONSE TO MFN
N MFI
D MYSET(.ARY,"MFI",0)
I ($G(MFK(SEG,2,1,1,1))="")!($G(MFK(SEG,4,1,1,1))="")!($G(MFK(SEG,7,1,1,1))="") S ERR=1 Q
D MYSET(.ARY,MFK(SEG,2,1,1,1),1,1,1,1)
D MYSET(.ARY,MFK(SEG,4,1,1,1),3,1,1,1)
D MYSET(.ARY,MFK(SEG,7,1,1,1),6,1,1,1)
;D MYSET(.ARY,MFK(SEG,8,1,2,1),7,1,2,1)
S MFI=$$ADDSEG^HLOAPI(.HLST,.ARY)
Q
;
MFA(SEG) ;EP - FOR MFK RESPONSE TO MFN
N MFA,MFASEG
S MFASEG=SEG
;S MFASEG=SEG+.5
D MYSET(.ARY,"MFA",0)
D MYSET(.ARY,$P(MFK(MFASEG),HL1("FS"),2),1)
D MYSET(.ARY,$P(MFK(MFASEG),HL1("FS"),3),2)
D MYSET(.ARY,$P(MFK(MFASEG),HL1("FS"),4),3)
D MYSET(.ARY,$P(MFK(MFASEG),HL1("FS"),5),4)
S MFA=$$ADDSEG^HLOAPI(.HLST,.ARY)
Q
;
MFE(SEG) ;EP - FOR MFK RESPONSE TO MFN
N MFE
D MYSET(.ARY,"MFE",0)
I ($G(MFK(SEG,2,1,1,1))="")!($G(MFK(SEG,3,1,1,1))="")!($G(MFK(SEG,4,1,1,1))="")!($G(MFK(SEG,5,1,1,1))="") S ERR=1 Q
I ($G(MFK(SEG,5,1,2,1))="")!($G(MFK(SEG,5,1,4,1))="")!($G(MFK(SEG,5,1,5,1))="") S ERR=1 Q
D MYSET(.ARY,MFK(SEG,2,1,1,1),1,1,1,1)
D MYSET(.ARY,MFK(SEG,3,1,1,1),2,1,1,1)
D MYSET(.ARY,MFK(SEG,4,1,1,1),3,1,1,1)
D MYSET(.ARY,MFK(SEG,5,1,1,1),4,1,1,1)
D MYSET(.ARY,MFK(SEG,5,1,2,1),4,1,2,1)
D MYSET(.ARY,MFK(SEG,5,1,4,1),4,1,4,1)
D MYSET(.ARY,MFK(SEG,5,1,5,1),4,1,5,1)
S MFE=$$ADDSEG^HLOAPI(.HLST,.ARY)
Q
;SET(SEG,VALUE,FIELD,REP,COMP,SUBCOMP)
;THIS LOOKS MORE LIKE HOW THE ARRAY WILL APPEAR
;IT ALSO MATCHES THE AGMPPARS V1.6 MESSAGE PARSER'S GENERIC OUTPUT
MYSET(ARY,V,F,R,C,S) ;EP
D SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
Q
AGMPIHLO ;IHS/SD/TPF - Patient Registration MPI HLO Interface ALL HLO MESSAGES
+1 ;;7.2;IHS PATIENT REGISTRATION;**1,3,5,6**;MAY 20, 2010;Build 23
+2 ;BADEHL1 was used as a template for this routine
+3 QUIT
+4 ;FOR PATIENT MERGE A40
+5 ;^TMP("XDRFROM",$J,TOMIEN,FROMIEN,FROMIEN_GLOBROOT,TOIEN_GLOBROOT)=FILE
+6 ;^TMP("XDRFROM",2804,6364,1991,"6364;DPT(","1991;DPT(")=2
+7 ;BPMRY = "^TMP(""XDRFROM"",$J)"
NEWMSG(BPMRY) ;EP - FOR PATIENT MERGE
+1 NEW AGMPIFR,AGMPITO
+2 SET AGMPITO=$ORDER(@BPMRY@(0))
+3 IF '$GET(AGMPITO)
SET A40ERR=1
DO NOTIF(AGMPITO,"Unable to build HL7 message. ERR:A40: NO TO DFN FOR A40 EVENT")
QUIT
+4 IF '$DATA(^DPT(AGMPITO,0))
SET A40ERR=1
DO NOTIF(AGMPITO,"Unable to build HL7 message. ERR:A40: NO DPT ENTRY FOR DFN "_AGMPITO)
QUIT
+5 ;
+6 SET AGMPIFR=$ORDER(@BPMRY@(AGMPITO,0))
+7 IF '$GET(AGMPIFR)
SET A40ERR=1
DO NOTIF(AGMPIFR,"Unable to build HL7 message. ERR:A40: NO DFN2 FOR A40 EVENT")
QUIT
+8 IF '$DATA(^DPT(AGMPIFR,0))
SET A40ERR=1
DO NOTIF(AGMPIFR,"Unable to build HL7 message. ERR:A40: NO DPT ENTRY FOR DFN2 "_AGMPIFR)
QUIT
+9 DO CREATMSG(AGMPIFR,"A40",AGMPITO,.SUCCESS)
+10 QUIT
+11 ;
+12 ;BUILD OUTBOUND MESSAGES
+13 ;SEND VTQ TO GET THE OLD VA NON-STANDARD MESSAGE
+14 ;SEND VQQ TO GET A REGULAR HL7 MESSAGE
CREATMSG(DFN,EVNTTYPE,DFN2,SUCCESS) ;EP - START FOR MOST PAT REG TRIGGERS
+1 ;S AGMPSTOP=1
+2 ; 9/07/2017 - GCD - CR 7693 - Disabled VQQ messages.
+3 IF $GET(EVNTTYPE)="VTQ"!($GET(EVNTTYPE)="VQQ")
SET SUCCESS=0
QUIT
+4 ;MODIFIED 11/28/2016 - SWH
+5 ; CHECK TO SEE IF WE HAVE THE GLOBAL BUILT AND IF THE SITE CAN TRIGGER MESSAGES.
IF '($GET(AGMPCHKFLG))
IF $GET(^AGMPCHK(0))
IF '($GET(^AGMPCHK(DUZ(2),1))="VALID")
Begin DoDot:1
+6 SET SUCCESS=0
+7 IF '($GET(^AGMPCHK(DUZ(2))))
DO NOTIF("","Site "_DUZ(2)_"isn't defined within the ^AGMPCHK global.")
QUIT
+8 IF '($GET(DFN2))
SET DFN2=""
+9 DO UPDMSGQ^AGMPCHK(DFN,DFN2,EVNTTYPE,DUZ(2))
+10 IF '($GET(ZTQUEUED))
WRITE !,"Site "_DUZ(2)_" / "_$GET(^AGMPCHK(DUZ(2)))_" is disabled in ^AGMPCHK, the message was not sent!"
+11 IF $DATA(^AGMPCHK(DUZ(2),"NT"))
Begin DoDot:2
+12
*** ERROR ***
IF (+($PIECE(^AGMPCHK(DUZ(2),"NT"),",")))=(+($p($HOROLOG,",")))
SET TCHCK=((+($PIECE($HOROLOG,",",2)))-(+($PIECE(^AGMPCHK(DUZ(2),"NT"),",",2))))
+13
*** ERROR ***
IF '((+($PIECE(^AGMPCHK(DUZ(2),"NT"),",")))=(+($p($HOROLOG,","))))
SET TCHCK=3600
+14 IF TCHCK>3599
Begin DoDot:3
+15 DO NOTIF("","The "_DUZ(2)_" / "_$GET(^AGMPCHK(DUZ(2),1))_" site is disabled.")
+16 SET ^AGMPCHK(DUZ(2),"NT")=$HOROLOG
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+17 ;
+18 IF $GET(AGMPSTOP)
SET SUCCESS=1
QUIT
+19 ; 9/13/2017 - GCD - CR 7713 - Don't upload demo patients.
+20 IF $$DEMOPAT^AGMPHLU($GET(DFN))
SET SUCCESS=0
QUIT
+21 IF $GET(DFN2)'=""
IF $$DEMOPAT^AGMPHLU(DFN2)
SET SUCCESS=0
QUIT
+22 NEW A40ERR
+23 SET SUCCESS=1
+24 SET A40ERR=0
+25 IF $GET(EVNTTYPE)="A40"
Begin DoDot:1
+26 IF '$GET(DFN2)
SET A40ERR=1
DO NOTIF(DFN,"Unable to build HL7 message. ERR:A40: NO DFN2 FOR A40 EVENT")
+27 IF '$GET(DFN)
SET A40ERR=1
DO NOTIF(DFN,"Unable to build HL7 message. ERR:A40: NO DFN FOR A40 EVENT")
+28 IF '$DATA(^DPT(DFN2,0))
SET A40ERR=1
DO NOTIF(DFN,"Unable to build HL7 message. ERR:A40: NO DPT ENTRY FOR DFN2 "_DFN2)
+29 IF '$DATA(^DPT(DFN,0))
SET A40ERR=1
DO NOTIF(DFN,"Unable to build HL7 message. ERR:A40: NO DPT ENTRY FOR DFN "_DFN)
End DoDot:1
IF $GET(A40ERR)
QUIT
+30 NEW HLPM,HLST,ARY,HLQ,APPARMS,HLPM,HLMSGIEN,HLECH,HLFS,ERR,WHO
+31 NEW LN,HL1,HRCN,FLD,LP,X,LN
+32 SET LN=0
+33 ;
+34 IF EVNTTYPE="VQQ"
Begin DoDot:1
+35 WRITE !," THIS IS BOMBING OUT ENSEMBLE"
+36 WRITE !,"WE WANT TO SEND A NORMAL MESSAGE WHEN DOING VQQ"
+37 WRITE !,"OR CHANGE THE VTQ EVENT INTO A REGULAR MESSAGE"
End DoDot:1
+38 IF EVNTTYPE'="VTQ"
IF (EVNTTYPE'="M05")
Begin DoDot:1
+39 SET HLPM("MESSAGE TYPE")="ADT"
+40 SET HLPM("EVENT")=EVNTTYPE
End DoDot:1
+41 IF '$TEST
IF EVNTTYPE="M05"
Begin DoDot:1
+42 SET HLPM("MESSAGE TYPE")="MFK"
+43 SET HLPM("EVENT")=EVNTTYPE
End DoDot:1
+44 IF '$TEST
Begin DoDot:1
+45 SET HLPM("MESSAGE TYPE")="VQQ"
+46 SET HLPM("EVENT")="Q02"
End DoDot:1
+47 ;
+48 SET HLPM("VERSION")=2.4
+49 SET HLPM("FIELD SEPARATOR")="^"
+50 SET HLPM("ENCODING CHARACTERS")="~|\&"
+51 IF '$$NEWMSG^HLOAPI(.HLPM,.HLST,.ERR)
Begin DoDot:1
+52 DO NOTIF(DFN,"Unable to build HL7 message."_$SELECT($DATA(ERR):" ERR:"_$GET(ERR),1:""))
End DoDot:1
QUIT
+53 SET HLFS=HLPM("FIELD SEPARATOR")
+54 SET HLECH=HLPM("ENCODING CHARACTERS")
+55 SET HL1("ECH")=HLECH
+56 SET COMP=$EXTRACT(HL1("ECH"))
+57 SET SUBCOMP=$EXTRACT(HL1("ECH"),4)
+58 SET HL1("FS")=HLFS
+59 SET HL1("Q")=""
+60 SET HL1("VER")=HLPM("VERSION")
+61 ;Create segments
+62 ;
+63 ;THIS CREATES THE 'ODD' NON-STANDARD HL7 VA QUERY MESSAGE
+64 ;I EVNTTYPE="VTQ" D Q
+65 ;.D VTQ^AGMPIHL1(DFN)
+66 ;.I '$D(ERR) D RDF^AGMPIHL1(DFN)
+67 ;.I '$D(ERR) D DOSEND
+68 ;
+69 ;
+70 IF EVNTTYPE="M05"
Begin DoDot:1
+71 NEW SEG,TAG
+72 SET SEG=""
+73 FOR
SET SEG=$ORDER(MFK(SEG))
IF 'SEG
QUIT
Begin DoDot:2
+74 SET TAG=$GET(MFK(SEG,1,1,1,1))
+75 IF TAG="ZET"
QUIT
+76 IF TAG'=""
SET TAG=TAG_"("_SEG_")"
+77 IF '$TEST
SET TAG="MFA("_SEG_")"
+78 DO @TAG
+79 IF $DATA(ERR)
DO NOTIF(DFN,$PIECE(TAG,"(")_"segment could not be created")
QUIT
End DoDot:2
IF $DATA(ERR)
QUIT
+80 DO DOSEND
End DoDot:1
QUIT
+81 ;
+82 ;REGULAR MESSSAGES
+83 DO EVN(EVNTTYPE)
+84 IF '$DATA(ERR)
DO PID^AGMPIHL1(DFN)
+85 IF '$DATA(ERR)
IF (EVNTTYPE="A08")!(EVNTTYPE="A01")!(EVNTTYPE="A03")
DO PD1(DFN)
+86 IF '$DATA(ERR)
IF (EVNTTYPE="A08")!(EVNTTYPE="A01")!(EVNTTYPE="A03")
Begin DoDot:1
+87 DO PV1(DFN)
+88 ;I '$D(ERR),(EVNTTYPE'="A01"),(EVNTTYPE'="A03") D OBX(DFN)
End DoDot:1
+89 ;
+90 ;RPMS SPECIFIC DATA
IF '$DATA(ERR)
IF ($GET(EVNTTYPE)'="A40")
DO ZPD^AGMPIHL1(DFN)
+91 ;
+92 ; DO A40 MERGE SEGMENT
IF '$DATA(ERR)
IF ($GET(EVNTTYPE)="A40")
DO MRG^AGMPIHL1(DFN2)
+93 IF '$DATA(ERR)
IF (EVNTTYPE="A28")
DO NK1(DFN)
+94 ;
DOSEND ;EP
+1 IF '$DATA(ERR)
Begin DoDot:1
+2 ; Define sending and receiving parameters
+3 ;SEE PG71 HLO TECH MANUAL FOR SOME OF THESE PARAMETERS
+4 SET APPARMS("SENDING APPLICATION")="RPMS-MPI"
+5 ;Commit ACK type
SET APPARMS("ACCEPT ACK TYPE")="AL"
+6 IF EVNTTYPE="A28"
Begin DoDot:2
+7 SET APPARMS("APP ACK RESPONSE")="RES^AGMPHIACK"
+8 SET APPARMS("ACCEPT ACK RESPONSE")="RES^AGMPHIACK"
End DoDot:2
+9 IF '$TEST
Begin DoDot:2
+10 ;Callback when 'application ACK' is received
SET APPARMS("APP ACK RESPONSE")="AACK^AGMPIHLO"
+11 ;Callback when 'commit ACK' is received
SET APPARMS("ACCEPT ACK RESPONSE")="CACK^AGMPIHLO"
End DoDot:2
+12 ;(FIELD 16) Application ACK type ;TPF - CHANGED TO THIS BECAUSE OF "SE" ERROR
SET APPARMS("APP ACK TYPE")="NE"
+13 ;Incoming QUEUE
SET APPARMS("QUEUE")="MPI RPMS"
+14 SET APPARMS("RECEIVING APPLICATION")="MPI RPMS"
+15 ;THIS DOES OVERRIDE LINE ABOVE MSH-5
SET WHO("RECEIVING APPLICATION")="MPI"
+16 SET WHO("FACILITY LINK NAME")="MPI"
+17 ;IHS/SD/TPF MPI TEST SET MSH-6 RECEIVING FACILITY (MPI SERVER)
SET WHO("STATION NUMBER")="8990"
+18 ;FOR HLO TESTING
SET WHO("IE LINK NAME")="MPI"
+19 SET APPARMS("SENDING FACILITY")=$$GET1^DIQ(4,DUZ(2)_",",99,"E")
+20 SET WHO("SENDING FACILITY")=$$GET1^DIQ(4,DUZ(2)_",",99,"E")
+21 ;S WHO("PORT")=5200 ; THIS SETS THE PORT WE ARE SENDING FROM THIS IS ALSO SET BY THE MPI HL LOGICAL LINK
+22 SET WHO("STATION")=$$GET1^DIQ(4,DUZ(2)_",",99,"E")
+23 ;LOCAL LISTENER PORT FOR MPI FIELD
SET HLST("SYSTEM","PORT")=$$GET1^DIQ(9009061,DUZ(2)_",",2203)
+24 SET HLST("SYSTEM","STATION")=$$GET1^DIQ(4,DUZ(2)_",",99,"E")
+25 ;MPI HAS BEEN ASSIGNED PORTS BETWEEN 5200:5299 TO USE
+26 ;5200 FOR TEST SENDER 5201 FOR TEST LISTENER
+27 ;5202 FOR PRD SENDER 5203 FOR PRD LISTENER
+28 IF HLST("SYSTEM","PORT")=""
Begin DoDot:2
+29 SET SUCCESS=0
+30 DO NOTIF(DFN,"LISTENER PORT NULL IN REG. PARAMETER FILE")
End DoDot:2
QUIT
+31 IF HLST("SYSTEM","STATION")=""
Begin DoDot:2
+32 SET SUCCESS=0
+33 DO NOTIF(DFN,"STATION NUMBER NULL IN FILE 4 ")
End DoDot:2
QUIT
+34 ; 05/24/2013 - KJH - TFS8008 - Remove extraneous locks on the HLO globals.
+35 SET SUCCESS=$$SENDONE^HLOAPI1(.HLST,.APPARMS,.WHO,.ERR)
+36 ;I EVNTTYPE="A40" D NOTIF(DFN,"AN A40 MESSAGE HAS BEEN CREATED "_SUCCESS) ; AG*7.2*5/CR 7718 - NOTIF sets SUCCESS to 0 and we don't need this call.
+37 IF 'SUCCESS
Begin DoDot:2
+38 DO NOTIF(DFN,"Unable to create HL7 message."_$SELECT($DATA(ERR):" ERR:"_$GET(ERR),1:""))
End DoDot:2
End DoDot:1
+39 IF $DATA(ERR)
Begin DoDot:1
+40 ;THIS IS A TIMING ISSUE THAT SEEMS TO RESOLVE ITSELF FOR A08
IF ERR[("NOT DEFINED IN PID^AGMPIHL1")
SET SUCCESS=1_U_ERR
QUIT
+41 SET SUCCESS=0
+42 DO NOTIF($GET(DFN),"Unable to send HL7 message."_$SELECT($DATA(ERR):" ERR:"_$GET(ERR),1:""))
End DoDot:1
+43 QUIT
+44 ;THIS IS FOR HLO APP USE. NOT BEING USED HOWEVER
AACK ; EP - Application ACK callback - called when AA, AE or AR is received.
+1 NEW DATA,AACK,XQAID,XQDATA,XQA,XQAMSG,MSGID
+2 IF '$GET(HLMSGIEN)
QUIT
+3 SET MSGID=$PIECE($GET(^HLB(+HLMSGIEN,0)),U)
+4 SET AACK=$GET(^HLB(HLMSGIEN,4))
+5 IF $PIECE(AACK,U,3)'["|AA|"
Begin DoDot:1
+6 SET XQAMSG="AGMPI message "_MSGID_" did not receive a correct application ack."
+7 SET XQAID="AGMPI,"_MSGID_","_50
+8 SET XQDATA=$PIECE(AACK,U,3)
+9 SET XQA("G.AGMPI MPI")=""
+10 DO SETUP^XQALERT
End DoDot:1
+11 QUIT
+12 ;THIS IS FOR HLO APP USE. NOT BEING USED HOWEVER
CACK ; EP - Commit ACK callback - called when CA, CE or CR is received.
+1 NEW CACK,XQAID,XQAMSG,XQA,XQDATA,MSGID
+2 SET MSGID=$PIECE($GET(^HLB(+HLMSGIEN,0)),U)
+3 SET CACK=$GET(^HLB(HLMSGIEN,4))
+4 IF $PIECE(CACK,U,3)'["|CA|"
Begin DoDot:1
+5 SET XQAMSG="AGMPI message "_MSGID_" did not receive a correct commit acknowledgement."
+6 SET XQAID="AGMPI,"_MSGID_","_50
+7 SET XQDATA=$PIECE(CACK,U,3)
+8 SET XQA("G.AGMPI MPI")=""
+9 DO SETUP^XQALERT
End DoDot:1
+10 QUIT
+11 ;
+12 ; Send Notification to group
+13 ; Input: DFN = Patient
+14 ; MSG = Main message
NOTIF(DFN,MSG) ;EP
+1 NEW PNAM,PVDIEN,RET,X,SAVE
+2 NEW XQA,XQAID,XQADATA,XQAMSG
+3 SET SUCCESS=0
+4 SET PNAM=""
+5 IF $GET(DFN)'=""
SET PNAM=$PIECE($GET(^DPT(DFN,0)),U)
+6 IF $LENGTH(PNAM)>15
SET PNAM=$EXTRACT(PNAM,1,15)
+7 SET XQAMSG=PNAM_" "
+8 SET XQAMSG=XQAMSG_$GET(MSG)
+9 SET XQAID="ADEN,"_DFN_","_50
+10 SET XQDATA="DFN="_DFN
+11 SET XQA("G.AGMP MPI")=""
+12 DO SETUP^XQALERT
+13 ;Save the DFN in a parameter for correction
+14 SET X=$$GET^XPAR("ALL","AGMP MPI TOTAL ERRORS",1,"E")
+15 SET X=X+1
+16 SET SAVE=DFN_" "_MSG
+17 DO EN^XPAR("SYS","AGMP MPI ERROR PTS",X,SAVE)
+18 DO EN^XPAR("SYS","AGMP EDR TOTAL ERRORS",1,X)
+19 QUIT
+20 ;
ERR ;
+1 QUIT
+2 ;
EVN(EVNTTYPE) ;Create the EVN segment
+1 NEW %,X,FLD,VAL
+2 DO NOW^%DTC
+3 SET X=$$HLDATE^HLFNC(%,"TS")
+4 SET FACNAME=$$GET1^DIQ(9999999.06,DUZ(2)_",",.01,"E")
+5 ;GOT DATA FROM OLD V1.6 BLDEVT^VAFCQRY2
+6 SET USERNAME=DUZ
+7 SET USERNAME=$$GET1^DIQ(200,+USERNAME_",",.01)
+8 SET USERNAME=$$HLNAME^HLFNC(USERNAME,HL1("ECH"))
+9 ;SET(SEG,VALUE,FIELD,COMP,SUBCOMP,REP)
+10 DO MYSET(.ARY,"EVN",0)
+11 ;A1 AND A2 MATCH UP TO ENTRIES IN THE 'ADT/HL7 EVENT REASON' FILE
DO MYSET(.ARY,$SELECT(EVNTTYPE="A01":"A1",EVNTTYPE="A03":"A2",1:EVNTTYPE),1,1,1,1)
+12 DO MYSET(.ARY,DUZ,5,1,1,1)
+13 DO MYSET(.ARY,$PIECE(USERNAME,COMP),5,1,2,1)
+14 DO MYSET(.ARY,$PIECE(USERNAME,COMP,2),5,1,3,1)
+15 DO MYSET(.ARY,"USIHS",5,1,9,1)
+16 DO MYSET(.ARY,"0363",5,1,9,3)
+17 DO MYSET(.ARY,"L",5,1,10,1)
+18 DO MYSET(.ARY,"NI",5,1,13,1)
+19 DO MYSET(.ARY,"IHS FACILITY ID -"_FACNAME,5,1,14,1)
+20 DO MYSET(.ARY,$PIECE($$SITE^VASITE,"^",3),5,1,14,2)
+21 DO MYSET(.ARY,"L",5,1,14,3)
+22 DO MYSET(.ARY,$PIECE($$SITE^VASITE,"^",3),7,1,1,1)
+23 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+24 IF $DATA(ERR)
DO NOTIF(DFN,"EVT segment could not be created")
+25 QUIT
+26 ;
PD1(DFN) ;EP
+1 IF '$GET(DFN)
QUIT
+2 NEW PD1
+3 SET VAFCMN=$$MPINODE^AGMPIPID(DFN)
+4 SET CMOR=$PIECE(VAFCMN,"^",3)
+5 IF CMOR'=""
SET SITE=$$NS^XUAF4(CMOR)
+6 IF '$TEST
SET SITE=""
+7 ;
+8 DO MYSET(.ARY,"PD1",0)
+9 DO MYSET(.ARY,$PIECE(SITE,U),3,1,1,1)
+10 DO MYSET(.ARY,$PIECE(SITE,U),3,1,1,1)
+11 DO MYSET(.ARY,"D",3,1,2,1)
+12 DO MYSET(.ARY,$PIECE(SITE,"^",2),3,1,3,1)
+13 SET PD1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+14 IF $DATA(ERR)
DO NOTIF(DFN,ERR)
+15 QUIT
+16 ;
PV1(DFN) ;EP - PATIENT VISIT
+1 IF '$GET(DFN)
QUIT
+2 NEW PV1
+3 ;
+4 DO MYSET(.ARY,"PV1",0)
+5 DO MYSET(.ARY,1,1,1,1,1)
+6 DO MYSET(.ARY,$GET(SDT),44,1,1,1)
+7 SET PV1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+8 IF $DATA(ERR)
DO NOTIF(DFN,ERR)
+9 QUIT
+10 ;
OBX(DFN) ;EP - OBSERVATION/RESULT
+1 IF '$GET(DFN)
QUIT
+2 NEW OBX
+3 ;
+4 DO MYSET(.ARY,"OBX",0)
+5 DO MYSET(.ARY,1,1,1,1,1)
+6 SET OBX=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+7 IF $DATA(ERR)
DO NOTIF(DFN,ERR)
+8 QUIT
+9 ;
+10 ;NOT USED; MAY USE IN FUTURE
NK1(DFN) ;EP
+1 QUIT
+2 NEW ADDR,NK1,NODE,PHONE,DGNAME,FLD,K,CNT,SHIP,REL,HLQ
+3 SET CNT=0
+4 SET HLQ=HL1("Q")
+5 FOR K="EC","NOK"
Begin DoDot:1
+6 IF K="EC"
SET NODE=$GET(^DPT(DFN,.33))
+7 IF K="NOK"
SET NODE=$GET(^DPT(DFN,.21))
+8 IF NODE=""
QUIT
+9 SET CNT=CNT+1
+10 DO MYSET(.ARY,"NK1",0)
+11 DO MYSET(.ARY,CNT,1)
+12 SET DGNAME("FILE")=2
SET DGNAME("IENS")=DFN
+13 SET DGNAME("FIELD")=$SELECT(K="NOK":.211,K="EC":.331)
+14 ;Name of next of kin
+15 SET FLD=$$HLNAME^XLFNAME(.DGNAME,"","^")
+16 FOR LP=1:1:$LENGTH(FLD,$EXTRACT(HLECH))
SET VAL=$PIECE(FLD,$EXTRACT(HLECH),LP)
Begin DoDot:2
+17 DO MYSET(.ARY,VAL,2,LP)
End DoDot:2
+18 ;Relationship
+19 SET SHIP=$SELECT(K="EC":$PIECE($GET(^AUPNPAT(DFN,31)),U,2),K="NOK":$PIECE($GET(^AUPNPAT(DFN,28)),U,2))
+20 IF SHIP'=""
Begin DoDot:2
+21 SET X=$PIECE($GET(^AUTTRLSH(SHIP,0)),U,2)_"^"_$PIECE($GET(^AUTTRLSH(SHIP,0)),U,1)_"^UB-92"
+22 FOR LP=1:1:$LENGTH(X,$EXTRACT(HLECH))
SET VAL=$PIECE(X,$EXTRACT(HLECH),LP)
Begin DoDot:3
+23 DO MYSET(.ARY,VAL,3,LP)
End DoDot:3
End DoDot:2
+24 SET ADDR=$$ADDR^VAFHLFNC($PIECE(NODE,U,3,8))
+25 FOR LP=1:1:$LENGTH(ADDR,$EXTRACT(HLECH))
SET VAL=$PIECE(ADDR,$EXTRACT(HLECH),LP)
Begin DoDot:2
+26 ;Address
DO MYSET(.ARY,VAL,4,LP)
End DoDot:2
+27 SET PHONE=$$HLPHONE^HLFNC($PIECE(NODE,U,9))
+28 IF $LENGTH(PHONE)
Begin DoDot:2
+29 ;Home phone
DO MYSET(.ARY,PHONE,5)
+30 DO MYSET(.ARY,"PRN",5,2)
+31 DO MYSET(.ARY,"PH",5,3)
End DoDot:2
+32 SET PHONE=$$HLPHONE^HLFNC($PIECE(NODE,U,11))
+33 IF $LENGTH(PHONE)
Begin DoDot:2
+34 ;Work phone
DO MYSET(.ARY,PHONE,6)
+35 DO MYSET(.ARY,"WPH",6,2)
+36 DO MYSET(.ARY,"PH",6,3)
End DoDot:2
+37 DO MYSET(.ARY,K,7)
+38 DO MYSET(.ARY,$SELECT(K="EC":"Emergency Contact",K="NOK":"Next of Kin",1:""),7,2)
+39 SET NK1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+40 IF $DATA(ERR)
DO NOTIF(DFN,ERR)
End DoDot:1
+41 QUIT
+42 ;
MFI(SEG) ;EP - FOR MFK RESPONSE TO MFN
+1 NEW MFI
+2 DO MYSET(.ARY,"MFI",0)
+3 IF ($GET(MFK(SEG,2,1,1,1))="")!($GET(MFK(SEG,4,1,1,1))="")!($GET(MFK(SEG,7,1,1,1))="")
SET ERR=1
QUIT
+4 DO MYSET(.ARY,MFK(SEG,2,1,1,1),1,1,1,1)
+5 DO MYSET(.ARY,MFK(SEG,4,1,1,1),3,1,1,1)
+6 DO MYSET(.ARY,MFK(SEG,7,1,1,1),6,1,1,1)
+7 ;D MYSET(.ARY,MFK(SEG,8,1,2,1),7,1,2,1)
+8 SET MFI=$$ADDSEG^HLOAPI(.HLST,.ARY)
+9 QUIT
+10 ;
MFA(SEG) ;EP - FOR MFK RESPONSE TO MFN
+1 NEW MFA,MFASEG
+2 SET MFASEG=SEG
+3 ;S MFASEG=SEG+.5
+4 DO MYSET(.ARY,"MFA",0)
+5 DO MYSET(.ARY,$PIECE(MFK(MFASEG),HL1("FS"),2),1)
+6 DO MYSET(.ARY,$PIECE(MFK(MFASEG),HL1("FS"),3),2)
+7 DO MYSET(.ARY,$PIECE(MFK(MFASEG),HL1("FS"),4),3)
+8 DO MYSET(.ARY,$PIECE(MFK(MFASEG),HL1("FS"),5),4)
+9 SET MFA=$$ADDSEG^HLOAPI(.HLST,.ARY)
+10 QUIT
+11 ;
MFE(SEG) ;EP - FOR MFK RESPONSE TO MFN
+1 NEW MFE
+2 DO MYSET(.ARY,"MFE",0)
+3 IF ($GET(MFK(SEG,2,1,1,1))="")!($GET(MFK(SEG,3,1,1,1))="")!($GET(MFK(SEG,4,1,1,1))="")!($GET(MFK(SEG,5,1,1,1))="")
SET ERR=1
QUIT
+4 IF ($GET(MFK(SEG,5,1,2,1))="")!($GET(MFK(SEG,5,1,4,1))="")!($GET(MFK(SEG,5,1,5,1))="")
SET ERR=1
QUIT
+5 DO MYSET(.ARY,MFK(SEG,2,1,1,1),1,1,1,1)
+6 DO MYSET(.ARY,MFK(SEG,3,1,1,1),2,1,1,1)
+7 DO MYSET(.ARY,MFK(SEG,4,1,1,1),3,1,1,1)
+8 DO MYSET(.ARY,MFK(SEG,5,1,1,1),4,1,1,1)
+9 DO MYSET(.ARY,MFK(SEG,5,1,2,1),4,1,2,1)
+10 DO MYSET(.ARY,MFK(SEG,5,1,4,1),4,1,4,1)
+11 DO MYSET(.ARY,MFK(SEG,5,1,5,1),4,1,5,1)
+12 SET MFE=$$ADDSEG^HLOAPI(.HLST,.ARY)
+13 QUIT
+14 ;SET(SEG,VALUE,FIELD,REP,COMP,SUBCOMP)
+15 ;THIS LOOKS MORE LIKE HOW THE ARRAY WILL APPEAR
+16 ;IT ALSO MATCHES THE AGMPPARS V1.6 MESSAGE PARSER'S GENERIC OUTPUT
MYSET(ARY,V,F,R,C,S) ;EP
+1 DO SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
+2 QUIT
