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)
+42 ; Patient Address
SET FLD=$PIECE(PID,HLFS,12)
+43 FOR LP=1:1:$LENGTH(FLD,$EXTRACT(HLECH))
SET VAL=$PIECE(FLD,$EXTRACT(HLECH),LP)
Begin DoDot:1
+44 ;Fix for zipcode
+45 IF LP=5
SET VAL=$$FIXZIP(DFN,VAL)
+46 DO SET(.ARY,VAL,11,LP)
End DoDot:1
+47 IF $LENGTH($PIECE(PID,HLFS,14))
Begin DoDot:1
+48 ; Patient Home Phone
DO SET(.ARY,$PIECE(PID,HLFS,14),13)
+49 DO SET(.ARY,"PRN",13,2)
+50 DO SET(.ARY,"PH",13,3)
End DoDot:1
+51 IF $LENGTH($PIECE(PID,HLFS,15))
Begin DoDot:1
+52 ; Patient Work Phone
DO SET(.ARY,$PIECE(PID,HLFS,15),14)
+53 DO SET(.ARY,"WPH",14,2)
+54 DO SET(.ARY,"PH",14,3)
End DoDot:1
+55 ; PID-15 (Language) not captured in RPMS
+56 SET MSTS=$$GET1^DIQ(2,DFN,.05,"I")
+57 ; Marital Status HL7 Code
DO SET(.ARY,$$GET1^DIQ(11,MSTS,90001),16,1)
+58 ; Marital Status Text
DO SET(.ARY,$$GET1^DIQ(2,DFN,.05),16,2)
+59 ; Religion
DO SET(.ARY,$$GET1^DIQ(2,DFN,.08),17,2)
+60 ; PID-18 (Patient Account #) not captured in RPMS
+61 ; Patient SSN
DO SET(.ARY,$PIECE(PID,HLFS,20),19)
+62 ; Patient Date of Death
DO SET(.ARY,$$HLDATE^HLFNC($$GET1^DIQ(2,DFN,.351,"I"),"TS"),29)
+63 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+64 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF $DATA(ERR)
DO NOTIF(DFN,"Can't create PID. "_ERR)
+65 QUIT
+66 ;Add Aliases to segment
ALIAS(DFN) ;EP
+1 NEW AL,FLD,LP,ALN,CNT
+2 ;Q:'$G(DFN)
+3 ;SAIC/FJE 08/04/2011
IF '$GET(DFN)
SET ERR="ALAIS ERROR"
DO NOTIF(DFN,"Can't create PID for: "_DFN)
QUIT
+4 SET CNT=2
+5 SET AL=0
FOR
SET AL=$ORDER(^DPT(DFN,.01,AL))
IF 'AL
QUIT
Begin DoDot:1
+6 SET ALN=$PIECE(^DPT(DFN,.01,AL,0),U)
+7 SET FLD=$$HLNAME^HLFNC(ALN)
+8 FOR LP=1:1:$LENGTH(FLD,$EXTRACT(HLECH))
SET VAL=$PIECE(FLD,$EXTRACT(HLECH),LP)
Begin DoDot:2
+9 DO SET(.ARY,VAL,5,LP,1,CNT)
End DoDot:2
+10 DO SET(.ARY,"A",5,7,1,CNT)
+11 SET CNT=CNT+1
End DoDot:1
+12 QUIT
+13 ; Create Primary Provider segment
PD1(DFN) ;EP
+1 ;Q:'$G(DFN)
+2 ;SAIC/FJE 08/04/2011
IF '$GET(DFN)
SET ERR="PID ERROR"
DO NOTIF(DFN,"Can't create PID for: "_DFN)
QUIT
+3 NEW PPRV,FLD,LP,PD1
+4 DO SET(.ARY,"PD1",0)
+5 SET PPRV=$$GET1^DIQ(9000001,DFN,.14,"I")
+6 SET FLD=PPRV_$EXTRACT(HLECH)_$$HLNAME^HLFNC($$GET1^DIQ(9000001,DFN,.14))
+7 FOR LP=1:1:$LENGTH(FLD,$EXTRACT(HLECH))
SET VAL=$PIECE(FLD,$EXTRACT(HLECH),LP)
Begin DoDot:1
+8 DO SET(.ARY,VAL,4,LP)
End DoDot:1
+9 SET PD1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+10 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF $DATA(ERR)
DO NOTIF(DFN,"Can't create PD1. "_ERR)
+11 QUIT
+12 ; Create next of kin and emergency contact segment
NK1 ;EP
+1 NEW ADDR,NK1,NODE,PHONE,DGNAME,FLD,K,CNT,SHIP,REL,HLQ
+2 SET CNT=0
+3 SET HLQ=HL1("Q")
+4 FOR K="EC","NOK"
Begin DoDot:1
+5 IF K="EC"
SET NODE=$GET(^DPT(DFN,.33))
+6 IF K="NOK"
SET NODE=$GET(^DPT(DFN,.21))
+7 IF NODE=""
QUIT
+8 SET CNT=CNT+1
+9 DO SET(.ARY,"NK1",0)
+10 DO SET(.ARY,CNT,1)
+11 SET DGNAME("FILE")=2
SET DGNAME("IENS")=DFN
+12 SET DGNAME("FIELD")=$SELECT(K="NOK":.211,K="EC":.331)
+13 ;Name of next of kin
+14 SET FLD=$$HLNAME^XLFNAME(.DGNAME,"","^")
+15 FOR LP=1:1:$LENGTH(FLD,$EXTRACT(HLECH))
SET VAL=$PIECE(FLD,$EXTRACT(HLECH),LP)
Begin DoDot:2
+16 DO SET(.ARY,VAL,2,LP)
End DoDot:2
+17 ;Relationship
+18 SET SHIP=$SELECT(K="EC":$PIECE($GET(^AUPNPAT(DFN,31)),U,2),K="NOK":$PIECE($GET(^AUPNPAT(DFN,28)),U,2))
+19 IF SHIP'=""
Begin DoDot:2
+20 SET X=$PIECE($GET(^AUTTRLSH(SHIP,0)),U,2)_"^"_$PIECE($GET(^AUTTRLSH(SHIP,0)),U,1)_"^UB-92"
+21 FOR LP=1:1:$LENGTH(X,$EXTRACT(HLECH))
SET VAL=$PIECE(X,$EXTRACT(HLECH),LP)
Begin DoDot:3
+22 DO SET(.ARY,VAL,3,LP)
End DoDot:3
End DoDot:2
+23 SET ADDR=$$ADDR^VAFHLFNC($PIECE(NODE,U,3,8))
+24 FOR LP=1:1:$LENGTH(ADDR,$EXTRACT(HLECH))
SET VAL=$PIECE(ADDR,$EXTRACT(HLECH),LP)
Begin DoDot:2
+25 ;Address
DO SET(.ARY,VAL,4,LP)
End DoDot:2
+26 SET PHONE=$$HLPHONE^HLFNC($PIECE(NODE,U,9))
+27 IF $LENGTH(PHONE)
Begin DoDot:2
+28 ;Home phone
DO SET(.ARY,PHONE,5)
+29 DO SET(.ARY,"PRN",5,2)
+30 DO SET(.ARY,"PH",5,3)
End DoDot:2
+31 SET PHONE=$$HLPHONE^HLFNC($PIECE(NODE,U,11))
+32 IF $LENGTH(PHONE)
Begin DoDot:2
+33 ;Work phone
DO SET(.ARY,PHONE,6)
+34 DO SET(.ARY,"WPH",6,2)
+35 DO SET(.ARY,"PH",6,3)
End DoDot:2
+36 DO SET(.ARY,K,7)
+37 DO SET(.ARY,$SELECT(K="EC":"Emergency Contact",K="NOK":"Next of Kin",1:""),7,2)
+38 SET NK1=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+39 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF $DATA(ERR)
DO NOTIF(DFN,"Can't create NK1. "_ERR)
End DoDot:1
+40 QUIT
ASUFAC(DFN) ;Set up all the ASUFAC numbers for this patient
+1 NEW IEN,DATA,LOC,HRN,DATE,ASUFAC,FAC,LP,VAL,REP,PART
+2 SET IEN=0
SET FAC=""
+3 FOR
SET IEN=$ORDER(^AUPNPAT(DFN,41,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+4 SET DATA=$GET(^AUPNPAT(DFN,41,IEN,0))
+5 SET LOC=$PIECE(DATA,U,1)
SET DATE=$$HLDATE^HLFNC($PIECE(DATA,U,3))
+6 SET ASUFAC=$$GETCHART(DFN,LOC)
+7 IF FAC=""
SET FAC=ASUFAC_"^"_DATE
+8 IF '$TEST
SET FAC=FAC_"~"_ASUFAC_"^"_DATE
End DoDot:1
+9 IF FAC=""
QUIT 0
+10 FOR REP=1:1:$LENGTH(FAC,$EXTRACT(HLECH,2,2))
SET PART=$PIECE(FAC,$EXTRACT(HLECH,2,2),REP)
Begin DoDot:1
+11 FOR LP=1:1:$LENGTH(PART,$EXTRACT(HLECH))
SET VAL=$PIECE(PART,$EXTRACT(HLECH),LP)
Begin DoDot:2
+12 DO SET(.ARY,VAL,4,LP,,REP)
+13 DO SET(.ARY,"ASUFAC",4,LP+1,,REP)
End DoDot:2
End DoDot:1
+14 QUIT 1
GETCHART(P,L) ;
+1 NEW S,C,%
+2 ; ----- IHS/SAIC/FJE 11/5/2010
+3 SET (X,LL)=0
FOR
SET X=$ORDER(^AUPNPAT(P,41,X))
IF +X=0!(LL=L)
QUIT
Begin DoDot:1
+4 SET Y=$GET(^AUPNPAT(P,41,X,0))
+5 IF $LENGTH($PIECE(Y,"^",3))
QUIT
+6 IF '$LENGTH($PIECE(Y,"^",2))
QUIT
+7 SET LL=$PIECE(Y,"^",1)
End DoDot:1
+8 IF +LL
IF LL'=L
SET L=LL
+9 KILL LL,X,Y
+10 ; ----- end IHS/SAIC/FJE 11/5/2010
+11 SET S=$PIECE(^AUTTLOC(L,0),U,10)
+12 IF S=""
QUIT S
+13 SET S=$EXTRACT("000000",1,6-$LENGTH(S))_S
+14 SET C=$PIECE($GET(^AUPNPAT(P,41,L,0)),U,2)
+15 IF C=""
QUIT C
+16 SET C=$EXTRACT("000000",1,6-$LENGTH(C))_C
+17 SET %=S_C
+18 QUIT %
+19 ; Create MSA segment
+20 ; ----- IHS/MSC/PLS,AMF 1/3/2011
FINDHRN(PAT,LOC) ;DD
+1 NEW L,RET,X
+2 SET RET=""
+3 SET X=$GET(^AUPNPAT(PAT,41,LOC,0))
+4 IF $LENGTH($PIECE(X,U,2))
IF '$PIECE(X,U,3)
SET RET=$$FMTHRN(LOC,$PIECE(X,U,2))
+5 IF RET=""
Begin DoDot:1
+6 SET L=0
FOR
SET L=$ORDER(^AUPNPAT(PAT,41,L))
IF 'L
QUIT
Begin DoDot:2
+7 SET X=$GET(^AUPNPAT(PAT,41,L,0))
+8 ;Inactivated entry
IF $PIECE(X,U,3)
QUIT
+9 ;No HRN
IF '$LENGTH($PIECE(X,U,2))
QUIT
+10 SET RET=$$FMTHRN(L,$PIECE(X,U,2))_U_-1_U_LOC
End DoDot:2
IF $LENGTH(RET)
QUIT
End DoDot:1
+11 QUIT RET
+12 ;
HRN(PAT,LOC) ;;FJE 1/1/2013 Patch 02 Finds an HRCN active or inactive
+1 NEW L,RETHRN,X
+2 SET RETHRN=""
+3 SET X=$GET(^AUPNPAT(PAT,41,LOC,0))
+4 IF $LENGTH($PIECE(X,U,2))
SET RETHRN=$$FMTHRN(LOC,$PIECE(X,U,2))
+5 IF RETHRN=""
Begin DoDot:1
+6 SET L=0
FOR
SET L=$ORDER(^AUPNPAT(PAT,41,L))
IF 'L
QUIT
Begin DoDot:2
+7 SET X=$GET(^AUPNPAT(PAT,41,L,0))
+8 ;No HRN
IF '$LENGTH($PIECE(X,U,2))
QUIT
+9 SET RETHRN=$$FMTHRN(L,$PIECE(X,U,2))_U_-1_U_LOC
End DoDot:2
IF $LENGTH(RETHRN)
QUIT
End DoDot:1
+10 QUIT RETHRN
+11 ;
FMTHRN(L,HRN) ;
+1 NEW S
+2 SET S=$PIECE(^AUTTLOC(L,0),U,10)
+3 IF S=""
QUIT S
+4 SET S=$EXTRACT("000000",1,6-$LENGTH(S))_S
+5 IF '$LENGTH(HRN)
QUIT HRN
+6 SET HRN=$EXTRACT("000000",1,6-$LENGTH(HRN))_HRN
+7 QUIT S_HRN
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
+3 ; Fix for non-working ZIPCODE Field trigger in File 2
FIXZIP(DFN,ZIP) ;EP
+1 IF $GET(ZIP)
QUIT ZIP
+2 QUIT $$GET1^DIQ(2,DFN,.116)
