BADEMRG1 ;IHS/MSC/MGH/PLS - Dentrix HL7 interface ;28-Jun-2010 16:59;MGH
;;1.0;DENTAL/EDR INTERFACE;**1**;AUG 22, 2011
Q
; Build Outbound A40
NEWMSG(FROM,TO,EVNTTYPE) ;EP
N HLPM,HLST,ARY,HLQ,APPARMS,HLPM,HLMSGIEN,HLECH,HLFS,ERR,WHO
N LN,HL1,HRCN,FLD,LP,X,LN
S LN=0
S HLPM("MESSAGE TYPE")="ADT"
S HLPM("EVENT")=EVNTTYPE
S HLPM("VERSION")=2.4
I '$$NEWMSG^HLOAPI(.HLPM,.HLST,.ERR) D NOTIF^BADEHL1(DFN,"Unable to build HL7 message. "_$G(ERR)) Q
S HLFS=HLPM("FIELD SEPARATOR")
S HLECH=HLPM("ENCODING CHARACTERS")
S HL1("ECH")=HLECH
S HL1("FS")=HLFS
S HL1("Q")=""
S HL1("VER")=HLPM("VERSION")
;Create segments
;
D EVN^BADEHL1(EVNTTYPE)
I '$D(ERR) D PID^BADEHL1(TO)
I '$D(ERR) D MRG(FROM)
I '$D(ERR) D
.; Define sending and receiving parameters
.S APPARMS("SENDING APPLICATION")="RPMS-DEN"
.S APPARMS("ACCEPT ACK TYPE")="AL" ;Commit ACK type
.S APPARMS("APP ACK RESPONSE")="AACK^BADEHL1" ;Callback when 'application ACK' is received
.S APPARMS("ACCEPT ACK RESPONSE")="CACK^BADEHL1" ;Callback when 'commit ACK' is received
.S APPARMS("APP ACK TYPE")="AL" ;Application ACK type
.S APPARMS("QUEUE")="DENT ADT" ;Incoming QUEUE
.;S APPARMS("RECEIVING APPLICATION")="DENTRIX"
.;S APPARMS("FACILITY LINK NAME")="DENTRIX"
.;S APPARMS("FAILURE RESPONSE")="FAILURE^DENTHL1" ;Callback for transmission failures (i.e. - No 'commit ACK' received or message not sendable.
.S WHO("RECEIVING APPLICATION")="DENTRIX"
.S WHO("FACILITY LINK NAME")="DENTRIX"
.S WHO("STATION NUMBER")=11555 ;Used for testing on external RPMS system
.I '$$SENDONE^HLOAPI1(.HLST,.APPARMS,.WHO,.ERR) D NOTIF^BADEHL1(DFN,"Unable to send HL7 message. "_$G(ERR))
Q
;
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="EDR message "_MSGID_" did not receive a correct application ack."
.S XQAID="ADEN,"_MSGID_","_50
.S XQDATA=$P(AACK,U,3)
.S XQA("G.RPMS DENTAL")=""
.D SETUP^XQALERT
Q
;
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="EDR message "_MSGID_" did not receive a correct commit acknowledgement."
.S XQAID="ADEN,"_MSGID_","_50
.S XQDATA=$P(CACK,U,3)
.S XQA("G.RPMS DENTAL")=""
.D SETUP^XQALERT
Q
;
; Send Notification to group
; Input: DFN = Patient
; MSG = Main message
NOTIF(TO,FROM,MSG) ;EP
N PNAM,PVDIEN,RET,X,SAVE,FNAME
N XQA,XQAID,XQADATA,XQAMSG
S PNAM=$P($G(^DPT(TO,0)),U,1)
S FNAME=$P($G(^DPT(FROM,0)),U,1)
I $L(PNAM)>15 S PNAM=$E(PNAM,1,15)
I $L(FNAME)>15 S FNAME=$E(FNAME,1,15)
S XQAMSG=PNAM_" "
S XQAMSG=XQAMSG_$G(MSG)
S XQAID="ADEN,"_TO_","_50
S XQDATA="FROM="_FNAME_" TO="_PNAM
S XQA("G.RPMS DENTAL")=""
D SETUP^XQALERT
;Save the DFN in a parameter for correction
S X=$$GET^XPAR("ALL","BADE EDR MRG PTS ERRORS",1,"E")
S X=X+1
S SAVE="From: "_FROM_" to: "_TO_" "_MSG
D EN^XPAR("SYS","BADE EDR MRG PTS ERRORS",X,SAVE)
Q
;
ERR ;
Q
MRG(FROM) ;EP
N MRG,NAME,VAL
D SET(.ARY,"MRG",0)
D SET(.ARY,FROM,1)
S NAME=$P(^DPT(FROM,0),U,1)
S FLD=$$HLNAME^XLFNAME(NAME)
F LP=1:1:$L(FLD,$E(HLECH)) S VAL=$P(FLD,$E(HLECH),LP) D
.D SET(.ARY,VAL,7,LP)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
I $D(ERR) D NOTIF^BADEHL1(DFN,"Can't create MRG. "_ERR)
Q
; Create MSA segment
MSA ;EP
N MSA
D SET(.ARY,"MSA",0)
D SET(.ARY,"AA",1)
D SET(.ARY,"TODO-MSGID",2)
D SET(.ARY,"Transaction Successful",3)
D SET(.ARY,"todo-010",4)
S MSA=$$ADDSEG^HLOAPI(.HLST,.ARY)
Q
; Create MSH segment
;EP
N MSH
D SET(.ARY,"MSH",0)
S MSH=$$ADDSEG^HLOAPI(.HLST,.ARY)
Q
SET(ARY,V,F,C,S,R) ;EP
D SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
Q
BADEMRG1 ;IHS/MSC/MGH/PLS - Dentrix HL7 interface ;28-Jun-2010 16:59;MGH
+1 ;;1.0;DENTAL/EDR INTERFACE;**1**;AUG 22, 2011
+2 QUIT
+3 ; Build Outbound A40
NEWMSG(FROM,TO,EVNTTYPE) ;EP
+1 NEW HLPM,HLST,ARY,HLQ,APPARMS,HLPM,HLMSGIEN,HLECH,HLFS,ERR,WHO
+2 NEW LN,HL1,HRCN,FLD,LP,X,LN
+3 SET LN=0
+4 SET HLPM("MESSAGE TYPE")="ADT"
+5 SET HLPM("EVENT")=EVNTTYPE
+6 SET HLPM("VERSION")=2.4
+7 IF '$$NEWMSG^HLOAPI(.HLPM,.HLST,.ERR)
DO NOTIF^BADEHL1(DFN,"Unable to build HL7 message. "_$GET(ERR))
QUIT
+8 SET HLFS=HLPM("FIELD SEPARATOR")
+9 SET HLECH=HLPM("ENCODING CHARACTERS")
+10 SET HL1("ECH")=HLECH
+11 SET HL1("FS")=HLFS
+12 SET HL1("Q")=""
+13 SET HL1("VER")=HLPM("VERSION")
+14 ;Create segments
+15 ;
+16 DO EVN^BADEHL1(EVNTTYPE)
+17 IF '$DATA(ERR)
DO PID^BADEHL1(TO)
+18 IF '$DATA(ERR)
DO MRG(FROM)
+19 IF '$DATA(ERR)
Begin DoDot:1
+20 ; Define sending and receiving parameters
+21 SET APPARMS("SENDING APPLICATION")="RPMS-DEN"
+22 ;Commit ACK type
SET APPARMS("ACCEPT ACK TYPE")="AL"
+23 ;Callback when 'application ACK' is received
SET APPARMS("APP ACK RESPONSE")="AACK^BADEHL1"
+24 ;Callback when 'commit ACK' is received
SET APPARMS("ACCEPT ACK RESPONSE")="CACK^BADEHL1"
+25 ;Application ACK type
SET APPARMS("APP ACK TYPE")="AL"
+26 ;Incoming QUEUE
SET APPARMS("QUEUE")="DENT ADT"
+27 ;S APPARMS("RECEIVING APPLICATION")="DENTRIX"
+28 ;S APPARMS("FACILITY LINK NAME")="DENTRIX"
+29 ;S APPARMS("FAILURE RESPONSE")="FAILURE^DENTHL1" ;Callback for transmission failures (i.e. - No 'commit ACK' received or message not sendable.
+30 SET WHO("RECEIVING APPLICATION")="DENTRIX"
+31 SET WHO("FACILITY LINK NAME")="DENTRIX"
+32 ;Used for testing on external RPMS system
SET WHO("STATION NUMBER")=11555
+33 IF '$$SENDONE^HLOAPI1(.HLST,.APPARMS,.WHO,.ERR)
DO NOTIF^BADEHL1(DFN,"Unable to send HL7 message. "_$GET(ERR))
End DoDot:1
+34 QUIT
+35 ;
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="EDR message "_MSGID_" did not receive a correct application ack."
+7 SET XQAID="ADEN,"_MSGID_","_50
+8 SET XQDATA=$PIECE(AACK,U,3)
+9 SET XQA("G.RPMS DENTAL")=""
+10 DO SETUP^XQALERT
End DoDot:1
+11 QUIT
+12 ;
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="EDR message "_MSGID_" did not receive a correct commit acknowledgement."
+6 SET XQAID="ADEN,"_MSGID_","_50
+7 SET XQDATA=$PIECE(CACK,U,3)
+8 SET XQA("G.RPMS DENTAL")=""
+9 DO SETUP^XQALERT
End DoDot:1
+10 QUIT
+11 ;
+12 ; Send Notification to group
+13 ; Input: DFN = Patient
+14 ; MSG = Main message
NOTIF(TO,FROM,MSG) ;EP
+1 NEW PNAM,PVDIEN,RET,X,SAVE,FNAME
+2 NEW XQA,XQAID,XQADATA,XQAMSG
+3 SET PNAM=$PIECE($GET(^DPT(TO,0)),U,1)
+4 SET FNAME=$PIECE($GET(^DPT(FROM,0)),U,1)
+5 IF $LENGTH(PNAM)>15
SET PNAM=$EXTRACT(PNAM,1,15)
+6 IF $LENGTH(FNAME)>15
SET FNAME=$EXTRACT(FNAME,1,15)
+7 SET XQAMSG=PNAM_" "
+8 SET XQAMSG=XQAMSG_$GET(MSG)
+9 SET XQAID="ADEN,"_TO_","_50
+10 SET XQDATA="FROM="_FNAME_" TO="_PNAM
+11 SET XQA("G.RPMS DENTAL")=""
+12 DO SETUP^XQALERT
+13 ;Save the DFN in a parameter for correction
+14 SET X=$$GET^XPAR("ALL","BADE EDR MRG PTS ERRORS",1,"E")
+15 SET X=X+1
+16 SET SAVE="From: "_FROM_" to: "_TO_" "_MSG
+17 DO EN^XPAR("SYS","BADE EDR MRG PTS ERRORS",X,SAVE)
+18 QUIT
+19 ;
ERR ;
+1 QUIT
MRG(FROM) ;EP
+1 NEW MRG,NAME,VAL
+2 DO SET(.ARY,"MRG",0)
+3 DO SET(.ARY,FROM,1)
+4 SET NAME=$PIECE(^DPT(FROM,0),U,1)
+5 SET FLD=$$HLNAME^XLFNAME(NAME)
+6 FOR LP=1:1:$LENGTH(FLD,$EXTRACT(HLECH))
SET VAL=$PIECE(FLD,$EXTRACT(HLECH),LP)
Begin DoDot:1
+7 DO SET(.ARY,VAL,7,LP)
End DoDot:1
+8 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+9 IF $DATA(ERR)
DO NOTIF^BADEHL1(DFN,"Can't create MRG. "_ERR)
+10 QUIT
+11 ; Create MSA segment
MSA ;EP
+1 NEW MSA
+2 DO SET(.ARY,"MSA",0)
+3 DO SET(.ARY,"AA",1)
+4 DO SET(.ARY,"TODO-MSGID",2)
+5 DO SET(.ARY,"Transaction Successful",3)
+6 DO SET(.ARY,"todo-010",4)
+7 SET MSA=$$ADDSEG^HLOAPI(.HLST,.ARY)
+8 QUIT
+9 ; Create MSH segment
+10 ;EP
+11 NEW MSH
+12 DO SET(.ARY,"MSH",0)
+13 SET MSH=$$ADDSEG^HLOAPI(.HLST,.ARY)
+14 QUIT
SET(ARY,V,F,C,S,R) ;EP
+1 DO SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
+2 QUIT
