BADEHL1.m

BADEHL1 ;IHS/MSC/MGH/PLS/VAC/AMF - Dentrix HL7 interface  ;20-Feb-2013;fje

 ;;1.0;DENTAL/EDR INTERFACE;**1,2,3**;FEB 22, 2010;Build 4

 ;; Modified - IHS/MSC/AMF - 11/23/10 - More descriptive alert messages

 ;; Modified - IHS/MSC/VAC, IHS/SAIC/FJE, IHS/MSC/PLS,AMF - 9/10/10,1/3/11 - Fix for DUZ(2) problem

 ;; Modified - SAIC/FJE Patch 2 Sets LOCK for HLB,HLA,HLC globals, allows inactive patient messages to pass to DENTRIX after upload.

 ;; Modified - GDIT/DMB Patch 3 Remove LOCK for HLB,HLA,HLC globals based on new adapters

 Q

 ; Build Outbound A28 or A31 HL7 segments

NEWMSG(DFN,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  Q

 .D NOTIF(DFN,"Unable to build HL7 message. "_$G(ERR)) ;IHS/MSC/AMF 11/23/10 More descriptive alert

 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(EVNTTYPE)

 I '$D(ERR) D PID(DFN)

 I '$D(ERR) D PD1(DFN)

 I '$D(ERR) D NK1

 I '$D(ERR) D INS^BADEHLI

 I '$D(ERR) D ZP2^BADEHLZ

 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

 .; 06/06/2013 - DMB - TFS8008 - Remove extraneous locks on the HLO globals.

 .I '$$SENDONE^HLOAPI1(.HLST,.APPARMS,.WHO,.ERR) D

 ..D NOTIF(DFN,"Unable to send HL7 message. "_$G(ERR)) ;IHS/MSC/AMF 11/23/10 More descriptive alert

 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(DFN,MSG) ;EP ----- IHS/MSC/AMF 11/23/10 More descriptive alert

 N PVDIEN,RET,X,SAVE,STR,LEN

 N XQA,XQAID,XQADATA,XQAMSG

 S LEN=$L("Patient:  ["_DFN_"]. "_$G(MSG))

 S STR=$P($G(^DPT(DFN,0)),U,1) I ($L(STR)+LEN)>70 S STR=$E(STR,1,(67-LEN))_"..."

 S XQAMSG="Patient: "_STR_" ["_DFN_"]. "_$G(MSG)

 ; ----- end IHS/MSC/AMF 11/23/10 

 S XQAID="ADEN,"_DFN_","_50

 S XQDATA="DFN="_DFN

 S XQA("G.RPMS DENTAL")=""

 D SETUP^XQALERT

 ;Save the DFN in a parameter for correction

 S X=$$GET^XPAR("ALL","BADE EDR TOTAL ERRORS",1,"E")

 S X=X+1

 S SAVE=DFN_" "_MSG

 D EN^XPAR("SYS","BADE EDR ERROR PTS",X,SAVE)

 D EN^XPAR("SYS","BADE 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")

 D SET(.ARY,"EVN",0)

 D SET(.ARY,EVNTTYPE,1)

 S FLD="ADT^"_EVNTTYPE

 F LP=1:1:$L(FLD,$E(HLECH)) S VAL=$P(FLD,$E(HLECH),LP) D

 .D SET(.ARY,VAL,5,LP)

 D SET(.ARY,X,2)

 D SET(.ARY,"01",4)

 S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)

 I $D(ERR) D NOTIF($G(DFN),"Can't create EVN. "_ERR) ;IHS/MSC/AMF 11/23/10 More descriptive alert

 Q

 ; Create PID segment

PID(DFN) ;EP

 N PID,HRCN,FLD,LP,VAL,ASU

 ;Q:'$G(DFN)

 I '$G(DFN) S ERR="PID ERROR" D NOTIF(DFN,"Can't create PID for:  "_DFN) Q  ;SAIC/FJE 08/04/2011

 ;Q:$G(^DPT(DFN,0))=""

 I $G(^DPT(DFN,0))="" S ERR="PID ERROR" D NOTIF(DFN,"Can't create PID for:  "_DFN) Q  ;SAIC/FJE 08/04/2011

 ;Q:$P($G(^DPT(DFN,0)),U,1)=""

 I $P($G(^DPT(DFN,0)),U,1)="" S ERR="PID ERROR" D NOTIF(DFN,"Can't create PID for:  "_DFN) Q  ;SAIC/FJE 08/04/2011

 N ASU,PID,SGM,X,LP,VAL,HLQ,MSTS

 S HLQ=HL1("Q")

 S PID=$$EN^VAFHLPID(DFN,"2,3,5,6,7,8,11,13,14,16,17,19,",1)

 ;Q:PID=""

 I PID="" S ERR="PID ERROR" D NOTIF(DFN,"Can't create PID for:  "_DFN) Q  ;SAIC/FJE 08/04/2011

 D SET(.ARY,"PID",0)

 D SET(.ARY,1,1)

 D SET(.ARY,DFN,2)

 ;IHS/MSC/PLS,AMF 1/3/11 Fix for DUZ problem

 ;S HRCN=$$HRCNF^BDGF2(DFN,DUZ(2))

 ;S HRCN=$$GETCHART(DFN,DUZ(2))

 S HRCN=$$FINDHRN(DFN,$S($G(AGDUZ2):AGDUZ2,1:DUZ(2)))

 ;end fix for DUZ problem

 S ASU=0

 S ASU=$$ASUFAC^BADEHL1(DFN)

 I ASU=0 I '$G(BADELOAD) S ERR="PID ERROR" D NOTIF(DFN,"No ASUFAC.  Can't create PID.") Q  ;SAIC/FJE 08/04/2011;IHS/MSC/AMF 11/23/10 More descriptive alert

 I HRCN="" S HRCN=$$HRN(DFN,$S($G(AGDUZ2):AGDUZ2,1:DUZ(2)))  ;FJE 1/1/2013 Patch 02 If no active HRCN find first inactive to allow inactive patients to go to DENTRIX 

 I '$G(BADELOAD) I '+HRCN S ERR="PID ERROR" D NOTIF(DFN,"No HRN.  Can't create PID.") Q  ;SAIC/FJE 08/04/2011;IHS/MSC/AMF 11/23/10 More descriptive alert

 D SET(.ARY,$P(HRCN,U),3,1) ; Patient HRN IHS/MSC/AMF 1/3/11 DUZ problem

 ;D SET(.ARY,"MR",3,5)  ; Medical Record

 ;S ASU=$$ASUFAC^BADEHL1(DFN)  ;Get all HRCNs for this patient

 S FLD=$P(PID,HLFS,6)  ; Patient Name

 I FLD="" S ERR="PID ERROR" D NOTIF(DFN,"No name.  Can't create PID.") Q  ;SAIC/FJE 08/04/2011;IHS/MSC/AMF 11/23/10 More descriptive alert

 F LP=1:1:$L(FLD,$E(HLECH)) S VAL=$P(FLD,$E(HLECH),LP) D

 .D SET(.ARY,VAL,5,LP)

 D SET(.ARY,"L",5,7)

 D ALIAS(DFN)

 I $P(PID,HLFS,8)="" S ERR="PID ERROR" D NOTIF(DFN,"No Date of Birth.  Can't create PID.") Q  ;SAIC/FJE 08/04/2011;IHS/MSC/AMF 11/23/10 More descriptive alert

 S FLD=$$HLNAME^XLFNAME($$GET1^DIQ(2,DFN,.2403))  ; Mother's Maiden Name

 F LP=1:1:$L(FLD,$E(HLECH)) S VAL=$P(FLD,$E(HLECH),LP) D

 .D SET(.ARY,VAL,6,LP)

 D SET(.ARY,"M",6,7)

 D SET(.ARY,$P(PID,HLFS,8),7)  ; Date of Birth

 D SET(.ARY,$P(PID,HLFS,9),8)  ; Gender

 S FLD=$P(PID,HLFS,12)  ; Patient Address

 F LP=1:1:$L(FLD,$E(HLECH)) S VAL=$P(FLD,$E(HLECH),LP) D

 .;Fix for zipcode

 .S:LP=5 VAL=$$FIXZIP(DFN,VAL)

 .D SET(.ARY,VAL,11,LP)

 I $L($P(PID,HLFS,14)) D

 .D SET(.ARY,$P(PID,HLFS,14),13)  ; Patient Home Phone

 .D SET(.ARY,"PRN",13,2)

 .D SET(.ARY,"PH",13,3)

 I $L($P(PID,HLFS,15)) D

 .D SET(.ARY,$P(PID,HLFS,15),14)  ; Patient Work Phone

 .D SET(.ARY,"WPH",14,2)

 .D SET(.ARY,"PH",14,3)

 ; PID-15 (Language) not captured in RPMS

 S MSTS=$$GET1^DIQ(2,DFN,.05,"I")

 D SET(.ARY,$$GET1^DIQ(11,MSTS,90001),16,1)  ; Marital Status HL7 Code

 D SET(.ARY,$$GET1^DIQ(2,DFN,.05),16,2)  ; Marital Status Text

 D SET(.ARY,$$GET1^DIQ(2,DFN,.08),17,2)  ; Religion

 ; PID-18 (Patient Account #) not captured in RPMS

 D SET(.ARY,$P(PID,HLFS,20),19)  ; Patient SSN

 D SET(.ARY,$$HLDATE^HLFNC($$GET1^DIQ(2,DFN,.351,"I"),"TS"),29)  ; Patient Date of Death

 S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)

 I $D(ERR) D NOTIF(DFN,"Can't create PID. "_ERR) ;IHS/MSC/AMF 11/23/10 More descriptive alert

 Q

 ;Add Aliases to segment

ALIAS(DFN) ;EP

 N AL,FLD,LP,ALN,CNT

 ;Q:'$G(DFN)

 I '$G(DFN) S ERR="ALAIS ERROR" D NOTIF(DFN,"Can't create PID for:  "_DFN) Q  ;SAIC/FJE 08/04/2011

 S CNT=2

 S AL=0 F  S AL=$O(^DPT(DFN,.01,AL)) Q:'AL  D

 .S ALN=$P(^DPT(DFN,.01,AL,0),U)

 .S FLD=$$HLNAME^HLFNC(ALN)

 .F LP=1:1:$L(FLD,$E(HLECH)) S VAL=$P(FLD,$E(HLECH),LP) D

 ..D SET(.ARY,VAL,5,LP,1,CNT)

 .D SET(.ARY,"A",5,7,1,CNT)

 .S CNT=CNT+1

 Q

 ; Create Primary Provider segment

PD1(DFN) ;EP

 ;Q:'$G(DFN)

 I '$G(DFN) S ERR="PID ERROR" D NOTIF(DFN,"Can't create PID for:  "_DFN) Q  ;SAIC/FJE 08/04/2011

 N PPRV,FLD,LP,PD1

 D SET(.ARY,"PD1",0)

 S PPRV=$$GET1^DIQ(9000001,DFN,.14,"I")

 S FLD=PPRV_$E(HLECH)_$$HLNAME^HLFNC($$GET1^DIQ(9000001,DFN,.14))

 F LP=1:1:$L(FLD,$E(HLECH)) S VAL=$P(FLD,$E(HLECH),LP) D

 .D SET(.ARY,VAL,4,LP)

 S PD1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)

 I $D(ERR) D NOTIF(DFN,"Can't create PD1. "_ERR) ;IHS/MSC/AMF 11/23/10 More descriptive alert

 Q

 ; Create next of kin and emergency contact segment

NK1 ;EP

 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 SET(.ARY,"NK1",0)

 .D SET(.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 SET(.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 SET(.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 SET(.ARY,VAL,4,LP)   ;Address

 .S PHONE=$$HLPHONE^HLFNC($P(NODE,U,9))

 .I $L(PHONE) D

 ..D SET(.ARY,PHONE,5)    ;Home phone

 ..D SET(.ARY,"PRN",5,2)

 ..D SET(.ARY,"PH",5,3)

 .S PHONE=$$HLPHONE^HLFNC($P(NODE,U,11))

 .I $L(PHONE) D

 ..D SET(.ARY,PHONE,6)  ;Work phone

 ..D SET(.ARY,"WPH",6,2)

 ..D SET(.ARY,"PH",6,3)

 .D SET(.ARY,K,7)

 .D SET(.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,"Can't create NK1. "_ERR) ;IHS/MSC/AMF 11/23/10 More descriptive alert

 Q

ASUFAC(DFN) ;Set up all the ASUFAC numbers for this patient

 N IEN,DATA,LOC,HRN,DATE,ASUFAC,FAC,LP,VAL,REP,PART

 S IEN=0,FAC=""

 F  S IEN=$O(^AUPNPAT(DFN,41,IEN)) Q:'IEN  D

 .S DATA=$G(^AUPNPAT(DFN,41,IEN,0))

 .S LOC=$P(DATA,U,1),DATE=$$HLDATE^HLFNC($P(DATA,U,3))

 .S ASUFAC=$$GETCHART(DFN,LOC)

 .I FAC="" S FAC=ASUFAC_"^"_DATE

 .E  S FAC=FAC_"~"_ASUFAC_"^"_DATE

 I FAC="" Q 0

 F REP=1:1:$L(FAC,$E(HLECH,2,2)) S PART=$P(FAC,$E(HLECH,2,2),REP) D

 .F LP=1:1:$L(PART,$E(HLECH)) S VAL=$P(PART,$E(HLECH),LP) D

 ..D SET(.ARY,VAL,4,LP,,REP)

 ..D SET(.ARY,"ASUFAC",4,LP+1,,REP)

 Q 1

GETCHART(P,L) ;

 N S,C,%

 ; ----- IHS/SAIC/FJE 11/5/2010 

 S (X,LL)=0 F  S X=$O(^AUPNPAT(P,41,X)) Q:+X=0!(LL=L)  D

 .S Y=$G(^AUPNPAT(P,41,X,0))

 .Q:$L($P(Y,"^",3))

 .Q:'$L($P(Y,"^",2))

 .S LL=$P(Y,"^",1)

 I +LL I LL'=L S L=LL

 K LL,X,Y

 ; ----- end IHS/SAIC/FJE 11/5/2010

 S S=$P(^AUTTLOC(L,0),U,10)

 I S="" Q S

 S S=$E("000000",1,6-$L(S))_S

 S C=$P($G(^AUPNPAT(P,41,L,0)),U,2)

 I C="" Q C

 S C=$E("000000",1,6-$L(C))_C

 S %=S_C

 Q %

 ; Create MSA segment

 ; ----- IHS/MSC/PLS,AMF 1/3/2011 

FINDHRN(PAT,LOC) ;DD

 N L,RET,X

 S RET=""

 S X=$G(^AUPNPAT(PAT,41,LOC,0))

 I $L($P(X,U,2)),'$P(X,U,3) S RET=$$FMTHRN(LOC,$P(X,U,2))

 I RET="" D

 .S L=0 F  S L=$O(^AUPNPAT(PAT,41,L)) Q:'L  D  Q:$L(RET)

 ..S X=$G(^AUPNPAT(PAT,41,L,0))

 ..Q:$P(X,U,3)  ;Inactivated entry

 ..Q:'$L($P(X,U,2))  ;No HRN

 ..S RET=$$FMTHRN(L,$P(X,U,2))_U_-1_U_LOC

 Q RET

 ;

HRN(PAT,LOC) ;;FJE 1/1/2013 Patch 02 Finds an HRCN active or inactive

 N L,RETHRN,X

 S RETHRN=""

 S X=$G(^AUPNPAT(PAT,41,LOC,0))

 I $L($P(X,U,2)) S RETHRN=$$FMTHRN(LOC,$P(X,U,2))

 I RETHRN="" D

 .S L=0 F  S L=$O(^AUPNPAT(PAT,41,L)) Q:'L  D  Q:$L(RETHRN)

 ..S X=$G(^AUPNPAT(PAT,41,L,0))

 ..Q:'$L($P(X,U,2))  ;No HRN

 ..S RETHRN=$$FMTHRN(L,$P(X,U,2))_U_-1_U_LOC

 Q RETHRN

 ;

FMTHRN(L,HRN) ;

 N S

 S S=$P(^AUTTLOC(L,0),U,10)

 I S="" Q S

 S S=$E("000000",1,6-$L(S))_S

 Q:'$L(HRN) HRN

 S HRN=$E("000000",1,6-$L(HRN))_HRN

 Q S_HRN

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

 ; Fix for non-working ZIPCODE Field trigger in File 2

FIXZIP(DFN,ZIP) ;EP

 Q:$G(ZIP) ZIP

 Q $$GET1^DIQ(2,DFN,.116)

BADEHL1   ;IHS/MSC/MGH/PLS/VAC/AMF - Dentrix HL7 interface  ;20-Feb-2013;fje

 +1       ;;1.0;DENTAL/EDR INTERFACE;**1,2,3**;FEB 22, 2010;Build 4

 +2       ;; Modified - IHS/MSC/AMF - 11/23/10 - More descriptive alert messages

 +3       ;; Modified - IHS/MSC/VAC, IHS/SAIC/FJE, IHS/MSC/PLS,AMF - 9/10/10,1/3/11 - Fix for DUZ(2) problem

 +4       ;; Modified - SAIC/FJE Patch 2 Sets LOCK for HLB,HLA,HLC globals, allows inactive patient messages to pass to DENTRIX after upload.

 +5       ;; Modified - GDIT/DMB Patch 3 Remove LOCK for HLB,HLA,HLC globals based on new adapters

 +6        QUIT 

 +7       ; Build Outbound A28 or A31 HL7 segments

NEWMSG(DFN,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)

               Begin DoDot:1

 +8       ;IHS/MSC/AMF 11/23/10 More descriptive alert

                   DO NOTIF(DFN,"Unable to build HL7 message. "_$GET(ERR))

               End DoDot:1

               QUIT 

 +9        SET HLFS=HLPM("FIELD SEPARATOR")

 +10       SET HLECH=HLPM("ENCODING CHARACTERS")

 +11       SET HL1("ECH")=HLECH

 +12       SET HL1("FS")=HLFS

 +13       SET HL1("Q")=""

 +14       SET HL1("VER")=HLPM("VERSION")

 +15      ;Create segments

 +16      ;

 +17       DO EVN(EVNTTYPE)

 +18       IF '$DATA(ERR)

               DO PID(DFN)

 +19       IF '$DATA(ERR)

               DO PD1(DFN)

 +20       IF '$DATA(ERR)

               DO NK1

 +21       IF '$DATA(ERR)

               DO INS^BADEHLI

 +22       IF '$DATA(ERR)

               DO ZP2^BADEHLZ

 +23       IF '$DATA(ERR)

               Begin DoDot:1

 +24      ; Define sending and receiving parameters

 +25               SET APPARMS("SENDING APPLICATION")="RPMS-DEN"

 +26      ;Commit ACK type

                   SET APPARMS("ACCEPT ACK TYPE")="AL"

 +27      ;Callback when 'application ACK' is received

                   SET APPARMS("APP ACK RESPONSE")="AACK^BADEHL1"

 +28      ;Callback when 'commit ACK' is received

                   SET APPARMS("ACCEPT ACK RESPONSE")="CACK^BADEHL1"

 +29      ;Application ACK type

                   SET APPARMS("APP ACK TYPE")="AL"

 +30      ;Incoming QUEUE

                   SET APPARMS("QUEUE")="DENT ADT"

 +31      ;S APPARMS("RECEIVING APPLICATION")="DENTRIX"

 +32      ;S APPARMS("FACILITY LINK NAME")="DENTRIX"

 +33      ;S APPARMS("FAILURE RESPONSE")="FAILURE^DENTHL1"  ;Callback for transmission failures (i.e. - No 'commit ACK' received or message not sendable.

 +34               SET WHO("RECEIVING APPLICATION")="DENTRIX"

 +35               SET WHO("FACILITY LINK NAME")="DENTRIX"

 +36      ;S WHO("STATION NUMBER")=11555  ;Used for testing on external RPMS system

 +37      ; 06/06/2013 - DMB - TFS8008 - Remove extraneous locks on the HLO globals.

 +38               IF '$$SENDONE^HLOAPI1(.HLST,.APPARMS,.WHO,.ERR)

                       Begin DoDot:2

 +39      ;IHS/MSC/AMF 11/23/10 More descriptive alert

                           DO NOTIF(DFN,"Unable to send HL7 message. "_$GET(ERR))

                       End DoDot:2

               End DoDot:1

 +40       QUIT 

 +41      ;

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(DFN,MSG) ;EP ----- IHS/MSC/AMF 11/23/10 More descriptive alert

 +1        NEW PVDIEN,RET,X,SAVE,STR,LEN

 +2        NEW XQA,XQAID,XQADATA,XQAMSG

 +3        SET LEN=$LENGTH("Patient:  ["_DFN_"]. "_$GET(MSG))

 +4        SET STR=$PIECE($GET(^DPT(DFN,0)),U,1)

           IF ($LENGTH(STR)+LEN)>70

               SET STR=$EXTRACT(STR,1,(67-LEN))_"..."

 +5        SET XQAMSG="Patient: "_STR_" ["_DFN_"]. "_$GET(MSG)

 +6       ; ----- end IHS/MSC/AMF 11/23/10 

 +7        SET XQAID="ADEN,"_DFN_","_50

 +8        SET XQDATA="DFN="_DFN

 +9        SET XQA("G.RPMS DENTAL")=""

 +10       DO SETUP^XQALERT

 +11      ;Save the DFN in a parameter for correction

 +12       SET X=$$GET^XPAR("ALL","BADE EDR TOTAL ERRORS",1,"E")

 +13       SET X=X+1

 +14       SET SAVE=DFN_" "_MSG

 +15       DO EN^XPAR("SYS","BADE EDR ERROR PTS",X,SAVE)

 +16       DO EN^XPAR("SYS","BADE EDR TOTAL ERRORS",1,X)

 +17       QUIT 

 +18      ;

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        DO SET(.ARY,"EVN",0)

 +5        DO SET(.ARY,EVNTTYPE,1)

 +6        SET FLD="ADT^"_EVNTTYPE

 +7        FOR LP=1:1:$LENGTH(FLD,$EXTRACT(HLECH))

               SET VAL=$PIECE(FLD,$EXTRACT(HLECH),LP)

               Begin DoDot:1

 +8                DO SET(.ARY,VAL,5,LP)

               End DoDot:1

 +9        DO SET(.ARY,X,2)

 +10       DO SET(.ARY,"01",4)

 +11       SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)

 +12      ;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF $DATA(ERR)

               DO NOTIF($GET(DFN),"Can't create EVN. "_ERR)

 +13       QUIT 

 +14      ; Create PID segment

PID(DFN)  ;EP

 +1        NEW PID,HRCN,FLD,LP,VAL,ASU

 +2       ;Q:'$G(DFN)

 +3       ;SAIC/FJE 08/04/2011

           IF '$GET(DFN)

               SET ERR="PID ERROR"

               DO NOTIF(DFN,"Can't create PID for:  "_DFN)

               QUIT 

 +4       ;Q:$G(^DPT(DFN,0))=""

 +5       ;SAIC/FJE 08/04/2011

           IF $GET(^DPT(DFN,0))=""

               SET ERR="PID ERROR"

               DO NOTIF(DFN,"Can't create PID for:  "_DFN)

               QUIT 

 +6       ;Q:$P($G(^DPT(DFN,0)),U,1)=""

 +7       ;SAIC/FJE 08/04/2011

           IF $PIECE($GET(^DPT(DFN,0)),U,1)=""

               SET ERR="PID ERROR"

               DO NOTIF(DFN,"Can't create PID for:  "_DFN)

               QUIT 

 +8        NEW ASU,PID,SGM,X,LP,VAL,HLQ,MSTS

 +9        SET HLQ=HL1("Q")

 +10       SET PID=$$EN^VAFHLPID(DFN,"2,3,5,6,7,8,11,13,14,16,17,19,",1)

 +11      ;Q:PID=""

 +12      ;SAIC/FJE 08/04/2011

           IF PID=""

               SET ERR="PID ERROR"

               DO NOTIF(DFN,"Can't create PID for:  "_DFN)

               QUIT 

 +13       DO SET(.ARY,"PID",0)

 +14       DO SET(.ARY,1,1)

 +15       DO SET(.ARY,DFN,2)

 +16      ;IHS/MSC/PLS,AMF 1/3/11 Fix for DUZ problem

 +17      ;S HRCN=$$HRCNF^BDGF2(DFN,DUZ(2))

 +18      ;S HRCN=$$GETCHART(DFN,DUZ(2))

 +19       SET HRCN=$$FINDHRN(DFN,$SELECT($GET(AGDUZ2):AGDUZ2,1:DUZ(2)))

 +20      ;end fix for DUZ problem

 +21       SET ASU=0

 +22       SET ASU=$$ASUFAC^BADEHL1(DFN)

 +23      ;SAIC/FJE 08/04/2011;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF ASU=0

               IF '$GET(BADELOAD)

                   SET ERR="PID ERROR"

                   DO NOTIF(DFN,"No ASUFAC.  Can't create PID.")

                   QUIT 

 +24      ;FJE 1/1/2013 Patch 02 If no active HRCN find first inactive to allow inactive patients to go to DENTRIX 

           IF HRCN=""

               SET HRCN=$$HRN(DFN,$SELECT($GET(AGDUZ2):AGDUZ2,1:DUZ(2)))

 +25      ;SAIC/FJE 08/04/2011;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF '$GET(BADELOAD)

               IF '+HRCN

                   SET ERR="PID ERROR"

                   DO NOTIF(DFN,"No HRN.  Can't create PID.")

                   QUIT 

 +26      ; Patient HRN IHS/MSC/AMF 1/3/11 DUZ problem

           DO SET(.ARY,$PIECE(HRCN,U),3,1)

 +27      ;D SET(.ARY,"MR",3,5)  ; Medical Record

 +28      ;S ASU=$$ASUFAC^BADEHL1(DFN)  ;Get all HRCNs for this patient

 +29      ; Patient Name

           SET FLD=$PIECE(PID,HLFS,6)

 +30      ;SAIC/FJE 08/04/2011;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF FLD=""

               SET ERR="PID ERROR"

               DO NOTIF(DFN,"No name.  Can't create PID.")

               QUIT 

 +31       FOR LP=1:1:$LENGTH(FLD,$EXTRACT(HLECH))

               SET VAL=$PIECE(FLD,$EXTRACT(HLECH),LP)

               Begin DoDot:1

 +32               DO SET(.ARY,VAL,5,LP)

               End DoDot:1

 +33       DO SET(.ARY,"L",5,7)

 +34       DO ALIAS(DFN)

 +35      ;SAIC/FJE 08/04/2011;IHS/MSC/AMF 11/23/10 More descriptive alert

           IF $PIECE(PID,HLFS,8)=""

               SET ERR="PID ERROR"

               DO NOTIF(DFN,"No Date of Birth.  Can't create PID.")

               QUIT 

 +36      ; Mother's Maiden Name

           SET FLD=$$HLNAME^XLFNAME($$GET1^DIQ(2,DFN,.2403))

 +37       FOR LP=1:1:$LENGTH(FLD,$EXTRACT(HLECH))

               SET VAL=$PIECE(FLD,$EXTRACT(HLECH),LP)

               Begin DoDot:1

 +38               DO SET(.ARY,VAL,6,LP)

               End DoDot:1

 +39       DO SET(.ARY,"M",6,7)

 +40      ; Date of Birth

           DO SET(.ARY,$PIECE(PID,HLFS,8),7)

 +41      ; Gender

           DO SET(.ARY,$PIECE(PID,HLFS,9),8)