BADEMRG1.m

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