APCLSIHL ;cmi/flag/maw - APCL ILI CDC HL7 Export 5/12/2010 9:26:17 AM
;;3.0;IHS PCC REPORTS;**29,30,31**;FEB 05, 1997;Build 32
;
ILI(TYPE) ;EP - lets create the ILI HL7 export here
N APCLLAST
D BATCH(.HLPARM,TYPE)
S APCLLAST=$$GETLAST()
D APCLDATA(.HLMSTATE,.HLPARM,TYPE)
I $G(HLMSTATE("IEN")) D GL(HLMSTATE("IEN"),TYPE)
K HLMSTATE,HLPARM
Q
;
BATCH(HLPARM,TYP) ;-- start the message batch here
S HLPARM("COUNTRY")="USA"
S HLPARM("VERSION")="2.5.1"
I '$$NEWBATCH^HLOAPI(.HLPARM,.HLMSTATE,.ERROR) D Q
. S ERR=$G(ERR)
Q
;
GETLAST() ;-- get the last record
N BDA,LAST
S BDA=0 F S BDA=$O(^APCLDATA($J,BDA)) Q:'BDA!($G(LAST)) D
. I $P(^APCLDATA($J,BDA),",",1)="" S LAST=(BDA-1)
Q $G(LAST)
;
ZHS(TYP) ;-- lets create the ZHS segment
N ZHS,ZHS1,ZHS2,ZHS3,ZHS4,ZHS5,ZHS6
I TYP="ILI" D
. N DBIDI,DBID,ILII,PT,LOC,ASUFAC,LAST,LASTDT,TOT
. S DBIDI=$P($G(^AUTTSITE(1,0)),U)
. S DBID=$P($G(^AUTTLOC(DBIDI,1)),U,3)
. S ILII=$O(^APCLILIC("B",0))
. S PT="P"
. I $P($G(^APCLILIC(ILII,0)),U,5)="T" S PT="T"
. S LOC=$P($G(^DIC(4,DBIDI,0)),U)
. S LASTDT=$O(^APCLILIC(ILII,12,"B",""),-1)
. S LAST=$S($G(LASTDT):$O(^APCLILIC(ILII,12,"B",LASTDT,""),-1),1:"")
. S ASUFAC=$P($G(^AUTTLOC(DBIDI,0)),U,10)_$$FMTHL7^XLFDT(APCLZHSD)
. S TOT=$S($G(LAST):$P($G(^APCLILIC(ILII,12,LAST,0)),U,4),1:0)
. D SET(.ARY,"ZHS",0)
. D SET(.ARY,DBID,1)
. D SET(.ARY,PT,2)
. D SET(.ARY,APCLVTOT,3)
. D SET(.ARY,$$FMTHL7^XLFDT(APCLZHSD),4)
. D SET(.ARY,LOC,5)
. D SET(.ARY,ASUFAC,6)
. S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
ZTS(TYP,LA) ;-- lets create the ZTS segment
N ZTS,ZTS1,ZTS2,ZTS3,ZTS4,ZTS5
I TYP="ILI" D
. N CNT,RDA,RDATA,RLOC,RDT,RCNT1,RCNT2,RCNT3
. S CNT=0
. S RDA=LA F S RDA=$O(^APCLDATA($J,RDA)) Q:'RDA D
.. Q:$P(^APCLDATA($J,RDA),",",1)]""
.. S CNT=CNT+1
.. S RDATA=$G(^APCLDATA($J,RDA))
.. S RLOC=$P(RDATA,",",6)
.. S RDT=$$FMTHL7^XLFDT($P(RDATA,",",7))
.. S RCNT1=$P(RDATA,",",13)
.. S RCNT2=$P(RDATA,",",20)
.. S RCNT3=$P(RDATA,",",42)
.. D SET(.ARY,"ZTS",0)
.. D SET(.ARY,CNT,1)
.. D SET(.ARY,RDT,2)
.. D SET(.ARY,RLOC,3)
.. D SET(.ARY,RCNT1,4)
.. D SET(.ARY,RCNT2,5)
.. D SET(.ARY,RCNT3,6)
.. S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
APCLDATA(HLMSTATE,HLPARM,TYP) ;-- loop through ^APCLDATA here and create each message
N APCLDA,APCLCNT,APCLREC
S APCLCNT=0
S APCLDA=0 F S APCLDA=$O(^APCLDATA($J,APCLDA)) Q:'APCLDA Q:$P(^APCLDATA($J,APCLDA),",",1)="" D
. S APCLCNT=APCLCNT+1
. S APCLREC=$G(^APCLDATA($J,APCLDA))
. S DFN=$P(APCLREC,",",1)
. S DFN=+$E(DFN,6,15)
. N I
. I TYP="ILI" F I=1:1:300 S APCLREC(I)=$P(APCLREC,",",I)
. D NEWMSG(.HLMSTATE,.HLPARM,.APCLREC,"ADT","A08",TYP,APCLDA)
Q
;
NEWMSG(HLST,HLPM,RC,MTYPE,EVNTTYPE,TYP,LDA) ;EP
N ARY,HLQ,APPARMS,HLMSGIEN,HLECH,HLFS,ERR,WHO
N LN,HL1,HRCN,FLD,LP,X,LN
S LN=0
S HLPM("MESSAGE TYPE")=MTYPE
S HLPM("EVENT")=EVNTTYPE
I '$$ADDMSG^HLOAPI(.HLST,.HLPM,.ERR) D Q
.S ERR=$G(ERR)
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(MTYPE,EVNTTYPE)
I TYP="ILI" D
. I '$D(ERR) D PID(.RC)
. I '$D(ERR) D PV1(.RC)
. I '$D(ERR),$G(RC(8))]"" D DG1(.RC,1,RC(8))
. I '$D(ERR),$G(RC(9))]"" D DG1(.RC,2,RC(9))
. I '$D(ERR),$G(RC(10))]"" D DG1(.RC,3,RC(10))
. I '$D(ERR) D OBXMSR(.RC)
. I '$D(ERR) D ZLI(.RC)
. I '$D(ERR),$G(RC(45))]"" D ZSR(.RC,1,RC(45))
. I '$D(ERR),$G(RC(46))]"" D ZSR(.RC,2,RC(46))
. I '$D(ERR),$G(RC(47))]"" D ZSR(.RC,3,RC(47))
. I '$D(ERR),$G(RC(48))]"" D ZSR(.RC,4,RC(48))
. I '$D(ERR),$G(RC(66))]"" D ZAN(.RC)
. I $$ZPCCHK(.RC) D ZPC(.RC)
. D ZCV
. I LDA=+$G(APCLLAST) D
.. D ZHS(TYP)
.. D ZTS(TYP,LDA)
I '$D(ERR) D
.S APPARMS("SENDING APPLICATION")="RPMS-ILI"
.S APPARMS("ACCEPT ACK TYPE")="AL"
.S APPARMS("APP ACK RESPONSE")="AACK^APCLSHL"
.S APPARMS("ACCEPT ACK RESPONSE")="CACK^APCLSHL"
.S APPARMS("APP ACK TYPE")="AL"
.S APPARMS("QUEUE")="ILI ADT"
.S WHO("RECEIVING APPLICATION")="ILI"
.S WHO("FACILITY LINK NAME")="IHS"
.S WHOTO("RECEIVING APPLICATION")="IHS"
.I '$$SENDONE^HLOAPI1(.HLST,.APPARMS,.WHO,.ERR) D
.. S ERR=$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="ILI message "_MSGID_" did not receive a correct application ack."
.S XQAID="ILI,"_MSGID_","_50
.S XQDATA=$P(AACK,U,3)
.S XQA("G.APCS ILI")=""
.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="ILI message "_MSGID_" did not receive a correct commit acknowledgement."
.S XQAID="ILI,"_MSGID_","_50
.S XQDATA=$P(CACK,U,3)
.S XQA("G.APCS ILI")=""
.D SETUP^XQALERT
Q
;
ERR ;
Q
;
EVN(MTYPE,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)
D SET(.ARY,X,2)
S X=$$ADDSEG^HLOAPI(.HLMSTATE,.ARY,.ERR)
Q
; Create PID segment
PID(R) ;EP
S HLQ=HL1("Q")
D SET(.ARY,"PID",0)
D SET(.ARY,1,1)
D SET(.ARY,R(1),2)
D SET(.ARY,R(2),3) ; Patient HRN
D SET(.ARY,R(3),8)
D SET(.ARY,$$HLD(R(4)),7)
D SET(.ARY,R(5),11,8)
S X=$$ADDSEG^HLOAPI(.HLMSTATE,.ARY,.ERR)
Q
;
;
PIDLAB(R) ;EP
D PIDLAB^APCLSIH1(R)
Q
;
ZIDLAB(R) ;
D ZIDLAB^APCLSIH1(R)
Q
;
PV1(R) ;-- setup the PV1 segment
N PRVI,PRV,LNM,FNM,MI,NPI
D SET(.ARY,"PV1",0)
D SET(.ARY,1,1)
D SET(.ARY,R(6),3,1)
D SET(.ARY,R(41),3,2)
;add attending doctor to PV1-7 with NPI in the format NPI^LAST^FIRST^MIDDLE^^^^N
S PRVI=$G(R(138))
I $G(PRVI) D
. S NPI=$$GET1^DIQ(200,PRVI,41.99)
. S PRV=$$GET1^DIQ(200,PRVI,.01)
. D SET(.ARY,NPI,7,1)
. D SET(.ARY,"N",7,8)
D SET(.ARY,R(12),19)
D SET(.ARY,R(16),36)
D SET(.ARY,R(132),41) ;p30 visit status
D SET(.ARY,$$HLD(R(7)),44)
D SET(.ARY,$$HLD(R(17)),45)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
PV1LAB(R) ;-- setup the PV1 LAB segment
D PV1LAB^APCLSIH1(R)
Q
;
DG1(R,SQ,DG13) ;-- set the repeating DG1
N ICDT
S ICDT=$P($$ICDDX^APCLSILU(DG13,R(7)),U,20) ;get the icd type based on the code
D SET(.ARY,"DG1",0)
D SET(.ARY,SQ,1)
D SET(.ARY,"ICD",2)
D SET(.ARY,DG13,3)
D SET(.ARY,$S(ICDT="30":"I10",1:"I9"),3,3) ;set the diagnosis type here
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
DG1LAB(R) ;EP
D DG1LAB^APCLSIH1(R)
Q
;
PR1LAB(R) ;EP
D PR1LAB^APCLSIH1(R)
Q
;
OBX(R) ;-- setup the ILI OBX segment
D SET(.ARY,"OBX",0)
D SET(.ARY,1,1)
D SET(.ARY,"ST",2)
D SET(.ARY,"TMP",3)
D SET(.ARY,R(11),5)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
OBXMSR(R) ;-- setup the ILI OBX HT/WT segment
N I,CNT
S CNT=0
F I=11,125,126 D
. Q:R(I)=""
. S CNT=CNT+1
. D SET(.ARY,"OBX",0)
. D SET(.ARY,CNT,1)
. D SET(.ARY,"ST",2)
. D SET(.ARY,$P(R(I),U,1),3)
. D SET(.ARY,$P(R(I),U,2),5)
. D SET(.ARY,$$HLD($P(R(I),U,3)),14)
. S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
F I=37 D
. Q:R(I)=""
. S CNT=CNT+1
. D SET(.ARY,"OBX",0)
. D SET(.ARY,CNT,1)
. D SET(.ARY,"ST",2)
. D SET(.ARY,"BMI",3)
. D SET(.ARY,$P(R(I),U,1),5)
. D SET(.ARY,$$HLD(R(38)),14)
. S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
. ;
Q
;
OBXLAB(R) ;
D OBXLAB^APCLSIH1(R)
Q
;
ZLI(R) ;-- setup the ILI ZLI segment
D SET(.ARY,"ZLI",0)
D SET(.ARY,1,1)
D SET(.ARY,$$HLD(R(14)),3)
D SET(.ARY,R(15),4)
D SET(.ARY,R(18),5)
D SET(.ARY,$$HLD(R(19)),6)
D SET(.ARY,R(21),8)
D SET(.ARY,R(22),9)
I $G(R(22))["." D
. N ICDTA
. S ICDTA=$P($$ICDDX^APCLSILU(R(22),R(7)),U,20) ;get the icd type based on the code
. D SET(.ARY,$S(ICDTA="30":"I10",1:"I9"),9,3)
D SET(.ARY,R(33),10)
D SET(.ARY,R(34),11)
D SET(.ARY,R(35),12)
D SET(.ARY,R(36),13)
I $G(R(39))["." D ;ihs/cmi/maw p31
. N ICDTB
. S ICDTB=$P($$ICDDX^APCLSILU(R(39),R(7)),U,20)
. D SET(.ARY,R(39),16,1)
. D SET(.ARY,$S(ICDTB="30":"I10",1:"I9"),16,3)
I $L($G(R(39)))=5,$G(R(39))'["." D
. D SET(.ARY,R(39),16,1)
. D SET(.ARY,"C4",16,3)
I $G(R(39))'[".",$L($G(R(39)))<4 D SET(.ARY,R(39),16)
D SET(.ARY,$$HLD(R(40)),17)
N ICDT
S ICDT=$P($$ICDDX^APCLSILU(R(43),R(7)),U,20) ;get the icd type based on the code
D SET(.ARY,R(43),19)
I $G(R(43))]"" D SET(.ARY,$S(ICDT="30":"I10",1:"I9"),19,3)
D SET(.ARY,R(44),20)
D SET(.ARY,R(59),21)
D SET(.ARY,R(60),22)
D SET(.ARY,R(61),23)
D SET(.ARY,R(62),24)
D SET(.ARY,R(63),25)
D SET(.ARY,R(64),26)
D SET(.ARY,R(65),27)
D SET(.ARY,$$HLD(R(123)),28)
D SET(.ARY,$$HLD(R(124)),29)
D SET(.ARY,R(133),30)
D SET(.ARY,R(134),31)
D SET(.ARY,R(135),32)
D SET(.ARY,$$HLD(R(136)),33)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
ZPCCHK(R) ;-- do we need to create a ZPC
I R(107) Q 1
F I=113:1:122 I R(I) Q 1
Q 0
;
ZPC(R) ;-- setup the ZPC segment
D SET(.ARY,"ZPC",0)
D SET(.ARY,R(107),1)
D SET(.ARY,R(113),2)
N ICDT
S ICDT=$P($$ICDDX^APCLSILU(R(113),R(7)),U,20) ;get the icd type based on the code
I $G(R(113))]"" D SET(.ARY,$S(ICDT="30":"I10",1:"I9"),2,3)
D SET(.ARY,$$HLD(R(114)),3)
D SET(.ARY,R(115),4)
N ICDTA
S ICDTA=$P($$ICDDX^APCLSILU(R(115),R(7)),U,20) ;get the icd type based on the code
I $G(R(115))]"" D SET(.ARY,$S(ICDTA="30":"I10",1:"I9"),4,3)
D SET(.ARY,$$HLD(R(116)),5)
D SET(.ARY,R(117),6)
N ICDTB
S ICDTB=$P($$ICDDX^APCLSILU(R(117),R(7)),U,20) ;get the icd type based on the code
I $G(R(117))]"" D SET(.ARY,$S(ICDTB="30":"I10",1:"I9"),6,3)
D SET(.ARY,$$HLD(R(118)),7)
D SET(.ARY,R(119),8)
N ICDTC
S ICDTC=$P($$ICDDX^APCLSILU(R(119),R(7)),U,20) ;get the icd type based on the code
I $G(R(119))]"" D SET(.ARY,$S(ICDTC="30":"I10",1:"I9"),8,3)
D SET(.ARY,$$HLD(R(120)),9)
D SET(.ARY,R(121),10)
N ICDTD
S ICDTD=$P($$ICDDX^APCLSILU(R(121),R(7)),U,20) ;get the icd type based on the code
I $G(R(121))]"" D SET(.ARY,$S(ICDTD="30":"I10",1:"I9"),10,3)
D SET(.ARY,$$HLD(R(122)),11)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
ZAV(R,SQ,ZAV2,ZAV3) ;-- setup the ILI ZAV segment
D SET(.ARY,"ZAV",0)
D SET(.ARY,SQ,1)
D SET(.ARY,$$HLD(ZAV2),2)
D SET(.ARY,ZAV3,3)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
ZSR(R,SQ,ZSR2) ;-- setup the ILI ZSR segment
N ICDT
S ICDT=$P($$ICDDX^APCLSILU(ZSR2,R(7)),U,20) ;get the icd type based on the code
D SET(.ARY,"ZSR",0)
D SET(.ARY,SQ,1)
D SET(.ARY,ZSR2,2)
D SET(.ARY,$S(ICDT="30":"I10",1:"I9"),2,3) ;set the diagnosis type here
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
ZAE(R,SQ,ZAE2) ;-- setup the ILI ZAE segment
D SET(.ARY,"ZAE",0)
D SET(.ARY,SQ,1)
D SET(.ARY,ZAE2,2)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
ZAS(R,SQ,ZAS2,ZAS3) ;-- setup the ILI ZAS segment
D SET(.ARY,"ZAS",0)
D SET(.ARY,SQ,1)
D SET(.ARY,ZAS2,2)
D SET(.ARY,$$HLD(ZAS3),3)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
ZAN(R) ;-- setup the ILI ZAN segment
N I,ZANC,VAL,VALD
S ZANC=1
F I=66:1:70 D
. I $G(R(I))]"" D
.. S VAL=$G(R(I))
.. S VALD=$$FMTHL7^XLFDT($G(R(I+42)))
.. D SET(.ARY,"ZAN",0)
.. D SET(.ARY,ZANC,1)
.. N ICDT
.. S ICDT=$P($$ICDDX^APCLSILU(VAL,R(7)),U,20) ;get the icd type based on the code
.. D SET(.ARY,VAL,2)
.. D SET(.ARY,$S(ICDT="30":"I10",1:"I9"),2,3)
.. D SET(.ARY,VALD,3)
.. S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
.. S ZANC=ZANC+1
Q
;
ZCV(R) ;-- setup the ILI ZCV segment
N J,ZCVC,VALC,VALD,ARBD,X,D
S ZCVC=0
S J=0 F S J=$O(^AUPNVIMM("AC",DFN,J)) Q:J'=+J D
. Q:'$D(^AUPNVIMM(J,0)) ;bad xref
. Q:$P(^AUPNVIMM(J,0),U,1)=""
. S VALD=""
. I $P($G(^AUPNVIMM(J,12)),U,1) S VALD=$P($P(^AUPNVIMM(J,12),U,1),".")
. I VALD="" S VALD=$$VD^APCLV($P(^AUPNVIMM(J,0),U,3))
. S VALC=$$GET1^DIQ(9999999.14,$P(^AUPNVIMM(J,0),U,1),.03)
. S ARBD(9999999-VALD,J)=VALC
S D=0 F S D=$O(ARBD(D)) Q:D'=+D D
.S J=0 F S J=$O(ARBD(D,J)) Q:J'=+J D
.. S VALD=$$FMTHL7^XLFDT(9999999-D),VALC=ARBD(D,J),ZCVC=ZCVC+1
.. D SET(.ARY,"ZCV",0)
.. D SET(.ARY,ZCVC,1)
.. D SET(.ARY,VALC,2)
.. D SET(.ARY,VALD,3)
.. S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.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)
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
FIXZIP(DFN,ZIP) ;EP
Q:$G(ZIP) ZIP
Q $$GET1^DIQ(2,DFN,.116)
;
HLD(FDT) ;-- convert to HL7 date
I $G(FDT)="" Q ""
N D
S %DT="X"
S X=FDT D ^%DT
S D=$$FMTHL7^XLFDT(Y)
Q D
;
GL(IN,TYP) ;-- write out batch
K ^APCLTMP($J)
N BDA,BDO,HLODAT,MSH,MSGP,MSG,BT,BT1,BT2,BT3
S APCLCNT=0
S MSG=$P($G(^HLB(IN,0)),U,2)
S BT1=$G(^HLB(IN,1))
S BT2=$G(^HLB(IN,2))
S BT3=$G(^HLB(IN,3))
S BT=BT1_BT2_BT3
D SETGL(BT)
S BDA=0 F S BDA=$O(^HLB(IN,3,BDA)) Q:'BDA D
. S MSH=""
. S MSGP=$P($G(^HLB(IN,3,BDA,0)),U)
. S BDO=0 F S BDO=$O(^HLB(IN,3,BDA,BDO)) Q:'BDO D
.. S HLOMSH=$G(^HLB(IN,3,BDA,BDO))
.. S MSH=MSH_HLOMSH
. D SETGL(MSH)
. D REST(MSG,MSGP)
S DIK="^HLB(",DA=IN D ^DIK
S DIK="^HLA(",DA=MSG D ^DIK
D WRITE(TYP)
Q
;
REST(M,MP) ;-- write out the remainder of the segments to the global
N MDA,DATA,MCNT
S MCNT=0
S MDA=0 F S MDA=$O(^HLA(M,2,MP,1,MDA)) Q:'MDA D
. S DATA=$G(^HLA(M,2,MP,1,MDA,0))
. Q:DATA=""
. D SETGL(DATA)
Q
;
SETGL(D) ;-- set the temp global
S APCLCNT=APCLCNT+1
S ^APCLTMP($J,APCLCNT)=D
Q
;
WRITE(T) ; use XBGSAVE to save the temp global (APCLDATA) to a delimited
N XBGL,XBQ,XBQTO,XBNAR,XBMED,XBFLT,XBUF,XBFN,APCLFN
S XBGL="APCLTMP",XBMED="F",XBQ="N",XBFLT=1,XBF=$J,XBE=$J
S XBNAR="ILI FLU "_TYP_"_HL7 EXPORT"
S APCLASU=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10)
;is this a test system?
NEW TST
S TST=0
I $P($G(^APCLILIC(1,0)),U,5)="T" S TST=1
S (XBFN,APCLDFN)=$S(TST:"FLZ",$G(APCLFLF):"FLF",$G(APCLFLFN):"FLF",1:"FLU")_"_"_APCLASU_"_"_$$DATE(DT)_"_P31.txt" ;IHS/CMI/LAB - PATCH 31 FILENAME AND PATCH #
S XBS1="SURVEILLANCE ILI SEND"
;
D ^XBGSAVE
;
I XBFLG'=0 D
. I XBFLG(1)="" W:'$D(ZTQUEUED) !!,TYP_" HL7 file successfully created",!!
. I XBFLG(1)]"" W:'$D(ZTQUEUED) !!,TYP_" HL7 file NOT successfully created",!!
. W:'$D(ZTQUEUED) !,"File was NOT successfully transferred to IHS/CDC",!,"you will need to manually ftp it.",!
. W:'$D(ZTQUEUED) !,XBFLG(1),!!
D SETLOG
K ^APCLTMP($J),APCLCNT
K ^APCLDATA($J)
Q
DATE(D) ;EP
Q (1700+$E(D,1,3))_$E(D,4,5)_$E(D,6,7)
;
SETLOG ;EP
D SET^APCLSIL4
Q
APCLSIHL ;cmi/flag/maw - APCL ILI CDC HL7 Export 5/12/2010 9:26:17 AM
+1 ;;3.0;IHS PCC REPORTS;**29,30,31**;FEB 05, 1997;Build 32
+2 ;
ILI(TYPE) ;EP - lets create the ILI HL7 export here
+1 NEW APCLLAST
+2 DO BATCH(.HLPARM,TYPE)
+3 SET APCLLAST=$$GETLAST()
+4 DO APCLDATA(.HLMSTATE,.HLPARM,TYPE)
+5 IF $GET(HLMSTATE("IEN"))
DO GL(HLMSTATE("IEN"),TYPE)
+6 KILL HLMSTATE,HLPARM
+7 QUIT
+8 ;
BATCH(HLPARM,TYP) ;-- start the message batch here
+1 SET HLPARM("COUNTRY")="USA"
+2 SET HLPARM("VERSION")="2.5.1"
+3 IF '$$NEWBATCH^HLOAPI(.HLPARM,.HLMSTATE,.ERROR)
Begin DoDot:1
+4 SET ERR=$GET(ERR)
End DoDot:1
QUIT
+5 QUIT
+6 ;
GETLAST() ;-- get the last record
+1 NEW BDA,LAST
+2 SET BDA=0
FOR
SET BDA=$ORDER(^APCLDATA($JOB,BDA))
IF 'BDA!($GET(LAST))
QUIT
Begin DoDot:1
+3 IF $PIECE(^APCLDATA($JOB,BDA),",",1)=""
SET LAST=(BDA-1)
End DoDot:1
+4 QUIT $GET(LAST)
+5 ;
ZHS(TYP) ;-- lets create the ZHS segment
+1 NEW ZHS,ZHS1,ZHS2,ZHS3,ZHS4,ZHS5,ZHS6
+2 IF TYP="ILI"
Begin DoDot:1
+3 NEW DBIDI,DBID,ILII,PT,LOC,ASUFAC,LAST,LASTDT,TOT
+4 SET DBIDI=$PIECE($GET(^AUTTSITE(1,0)),U)
+5 SET DBID=$PIECE($GET(^AUTTLOC(DBIDI,1)),U,3)
+6 SET ILII=$ORDER(^APCLILIC("B",0))
+7 SET PT="P"
+8 IF $PIECE($GET(^APCLILIC(ILII,0)),U,5)="T"
SET PT="T"
+9 SET LOC=$PIECE($GET(^DIC(4,DBIDI,0)),U)
+10 SET LASTDT=$ORDER(^APCLILIC(ILII,12,"B",""),-1)
+11 SET LAST=$SELECT($GET(LASTDT):$ORDER(^APCLILIC(ILII,12,"B",LASTDT,""),-1),1:"")
+12 SET ASUFAC=$PIECE($GET(^AUTTLOC(DBIDI,0)),U,10)_$$FMTHL7^XLFDT(APCLZHSD)
+13 SET TOT=$SELECT($GET(LAST):$PIECE($GET(^APCLILIC(ILII,12,LAST,0)),U,4),1:0)
+14 DO SET(.ARY,"ZHS",0)
+15 DO SET(.ARY,DBID,1)
+16 DO SET(.ARY,PT,2)
+17 DO SET(.ARY,APCLVTOT,3)
+18 DO SET(.ARY,$$FMTHL7^XLFDT(APCLZHSD),4)
+19 DO SET(.ARY,LOC,5)
+20 DO SET(.ARY,ASUFAC,6)
+21 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
End DoDot:1
+22 QUIT
+23 ;
ZTS(TYP,LA) ;-- lets create the ZTS segment
+1 NEW ZTS,ZTS1,ZTS2,ZTS3,ZTS4,ZTS5
+2 IF TYP="ILI"
Begin DoDot:1
+3 NEW CNT,RDA,RDATA,RLOC,RDT,RCNT1,RCNT2,RCNT3
+4 SET CNT=0
+5 SET RDA=LA
FOR
SET RDA=$ORDER(^APCLDATA($JOB,RDA))
IF 'RDA
QUIT
Begin DoDot:2
+6 IF $PIECE(^APCLDATA($JOB,RDA),",",1)]""
QUIT
+7 SET CNT=CNT+1
+8 SET RDATA=$GET(^APCLDATA($JOB,RDA))
+9 SET RLOC=$PIECE(RDATA,",",6)
+10 SET RDT=$$FMTHL7^XLFDT($PIECE(RDATA,",",7))
+11 SET RCNT1=$PIECE(RDATA,",",13)
+12 SET RCNT2=$PIECE(RDATA,",",20)
+13 SET RCNT3=$PIECE(RDATA,",",42)
+14 DO SET(.ARY,"ZTS",0)
+15 DO SET(.ARY,CNT,1)
+16 DO SET(.ARY,RDT,2)
+17 DO SET(.ARY,RLOC,3)
+18 DO SET(.ARY,RCNT1,4)
+19 DO SET(.ARY,RCNT2,5)
+20 DO SET(.ARY,RCNT3,6)
+21 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
APCLDATA(HLMSTATE,HLPARM,TYP) ;-- loop through ^APCLDATA here and create each message
+1 NEW APCLDA,APCLCNT,APCLREC
+2 SET APCLCNT=0
+3 SET APCLDA=0
FOR
SET APCLDA=$ORDER(^APCLDATA($JOB,APCLDA))
IF 'APCLDA
QUIT
IF $PIECE(^APCLDATA($JOB,APCLDA),",",1)=""
QUIT
Begin DoDot:1
+4 SET APCLCNT=APCLCNT+1
+5 SET APCLREC=$GET(^APCLDATA($JOB,APCLDA))
+6 SET DFN=$PIECE(APCLREC,",",1)
+7 SET DFN=+$EXTRACT(DFN,6,15)
+8 NEW I
+9 IF TYP="ILI"
FOR I=1:1:300
SET APCLREC(I)=$PIECE(APCLREC,",",I)
+10 DO NEWMSG(.HLMSTATE,.HLPARM,.APCLREC,"ADT","A08",TYP,APCLDA)
End DoDot:1
+11 QUIT
+12 ;
NEWMSG(HLST,HLPM,RC,MTYPE,EVNTTYPE,TYP,LDA) ;EP
+1 NEW ARY,HLQ,APPARMS,HLMSGIEN,HLECH,HLFS,ERR,WHO
+2 NEW LN,HL1,HRCN,FLD,LP,X,LN
+3 SET LN=0
+4 SET HLPM("MESSAGE TYPE")=MTYPE
+5 SET HLPM("EVENT")=EVNTTYPE
+6 IF '$$ADDMSG^HLOAPI(.HLST,.HLPM,.ERR)
Begin DoDot:1
+7 SET ERR=$GET(ERR)
End DoDot:1
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(MTYPE,EVNTTYPE)
+17 IF TYP="ILI"
Begin DoDot:1
+18 IF '$DATA(ERR)
DO PID(.RC)
+19 IF '$DATA(ERR)
DO PV1(.RC)
+20 IF '$DATA(ERR)
IF $GET(RC(8))]""
DO DG1(.RC,1,RC(8))
+21 IF '$DATA(ERR)
IF $GET(RC(9))]""
DO DG1(.RC,2,RC(9))
+22 IF '$DATA(ERR)
IF $GET(RC(10))]""
DO DG1(.RC,3,RC(10))
+23 IF '$DATA(ERR)
DO OBXMSR(.RC)
+24 IF '$DATA(ERR)
DO ZLI(.RC)
+25 IF '$DATA(ERR)
IF $GET(RC(45))]""
DO ZSR(.RC,1,RC(45))
+26 IF '$DATA(ERR)
IF $GET(RC(46))]""
DO ZSR(.RC,2,RC(46))
+27 IF '$DATA(ERR)
IF $GET(RC(47))]""
DO ZSR(.RC,3,RC(47))
+28 IF '$DATA(ERR)
IF $GET(RC(48))]""
DO ZSR(.RC,4,RC(48))
+29 IF '$DATA(ERR)
IF $GET(RC(66))]""
DO ZAN(.RC)
+30 IF $$ZPCCHK(.RC)
DO ZPC(.RC)
+31 DO ZCV
+32 IF LDA=+$GET(APCLLAST)
Begin DoDot:2
+33 DO ZHS(TYP)
+34 DO ZTS(TYP,LDA)
End DoDot:2
End DoDot:1
+35 IF '$DATA(ERR)
Begin DoDot:1
+36 SET APPARMS("SENDING APPLICATION")="RPMS-ILI"
+37 SET APPARMS("ACCEPT ACK TYPE")="AL"
+38 SET APPARMS("APP ACK RESPONSE")="AACK^APCLSHL"
+39 SET APPARMS("ACCEPT ACK RESPONSE")="CACK^APCLSHL"
+40 SET APPARMS("APP ACK TYPE")="AL"
+41 SET APPARMS("QUEUE")="ILI ADT"
+42 SET WHO("RECEIVING APPLICATION")="ILI"
+43 SET WHO("FACILITY LINK NAME")="IHS"
+44 SET WHOTO("RECEIVING APPLICATION")="IHS"
+45 IF '$$SENDONE^HLOAPI1(.HLST,.APPARMS,.WHO,.ERR)
Begin DoDot:2
+46 SET ERR=$GET(ERR)
End DoDot:2
End DoDot:1
+47 QUIT
+48 ;
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="ILI message "_MSGID_" did not receive a correct application ack."
+7 SET XQAID="ILI,"_MSGID_","_50
+8 SET XQDATA=$PIECE(AACK,U,3)
+9 SET XQA("G.APCS ILI")=""
+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="ILI message "_MSGID_" did not receive a correct commit acknowledgement."
+6 SET XQAID="ILI,"_MSGID_","_50
+7 SET XQDATA=$PIECE(CACK,U,3)
+8 SET XQA("G.APCS ILI")=""
+9 DO SETUP^XQALERT
End DoDot:1
+10 QUIT
+11 ;
ERR ;
+1 QUIT
+2 ;
EVN(MTYPE,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 DO SET(.ARY,X,2)
+7 SET X=$$ADDSEG^HLOAPI(.HLMSTATE,.ARY,.ERR)
+8 QUIT
+9 ; Create PID segment
PID(R) ;EP
+1 SET HLQ=HL1("Q")
+2 DO SET(.ARY,"PID",0)
+3 DO SET(.ARY,1,1)
+4 DO SET(.ARY,R(1),2)
+5 ; Patient HRN
DO SET(.ARY,R(2),3)
+6 DO SET(.ARY,R(3),8)
+7 DO SET(.ARY,$$HLD(R(4)),7)
+8 DO SET(.ARY,R(5),11,8)
+9 SET X=$$ADDSEG^HLOAPI(.HLMSTATE,.ARY,.ERR)
+10 QUIT
+11 ;
+12 ;
PIDLAB(R) ;EP
+1 DO PIDLAB^APCLSIH1(R)
+2 QUIT
+3 ;
ZIDLAB(R) ;
+1 DO ZIDLAB^APCLSIH1(R)
+2 QUIT
+3 ;
PV1(R) ;-- setup the PV1 segment
+1 NEW PRVI,PRV,LNM,FNM,MI,NPI
+2 DO SET(.ARY,"PV1",0)
+3 DO SET(.ARY,1,1)
+4 DO SET(.ARY,R(6),3,1)
+5 DO SET(.ARY,R(41),3,2)
+6 ;add attending doctor to PV1-7 with NPI in the format NPI^LAST^FIRST^MIDDLE^^^^N
+7 SET PRVI=$GET(R(138))
+8 IF $GET(PRVI)
Begin DoDot:1
+9 SET NPI=$$GET1^DIQ(200,PRVI,41.99)
+10 SET PRV=$$GET1^DIQ(200,PRVI,.01)
+11 DO SET(.ARY,NPI,7,1)
+12 DO SET(.ARY,"N",7,8)
End DoDot:1
+13 DO SET(.ARY,R(12),19)
+14 DO SET(.ARY,R(16),36)
+15 ;p30 visit status
DO SET(.ARY,R(132),41)
+16 DO SET(.ARY,$$HLD(R(7)),44)
+17 DO SET(.ARY,$$HLD(R(17)),45)
+18 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+19 QUIT
+20 ;
PV1LAB(R) ;-- setup the PV1 LAB segment
+1 DO PV1LAB^APCLSIH1(R)
+2 QUIT
+3 ;
DG1(R,SQ,DG13) ;-- set the repeating DG1
+1 NEW ICDT
+2 ;get the icd type based on the code
SET ICDT=$PIECE($$ICDDX^APCLSILU(DG13,R(7)),U,20)
+3 DO SET(.ARY,"DG1",0)
+4 DO SET(.ARY,SQ,1)
+5 DO SET(.ARY,"ICD",2)
+6 DO SET(.ARY,DG13,3)
+7 ;set the diagnosis type here
DO SET(.ARY,$SELECT(ICDT="30":"I10",1:"I9"),3,3)
+8 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+9 QUIT
+10 ;
DG1LAB(R) ;EP
+1 DO DG1LAB^APCLSIH1(R)
+2 QUIT
+3 ;
PR1LAB(R) ;EP
+1 DO PR1LAB^APCLSIH1(R)
+2 QUIT
+3 ;
OBX(R) ;-- setup the ILI OBX segment
+1 DO SET(.ARY,"OBX",0)
+2 DO SET(.ARY,1,1)
+3 DO SET(.ARY,"ST",2)
+4 DO SET(.ARY,"TMP",3)
+5 DO SET(.ARY,R(11),5)
+6 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+7 QUIT
+8 ;
OBXMSR(R) ;-- setup the ILI OBX HT/WT segment
+1 NEW I,CNT
+2 SET CNT=0
+3 FOR I=11,125,126
Begin DoDot:1
+4 IF R(I)=""
QUIT
+5 SET CNT=CNT+1
+6 DO SET(.ARY,"OBX",0)
+7 DO SET(.ARY,CNT,1)
+8 DO SET(.ARY,"ST",2)
+9 DO SET(.ARY,$PIECE(R(I),U,1),3)
+10 DO SET(.ARY,$PIECE(R(I),U,2),5)
+11 DO SET(.ARY,$$HLD($PIECE(R(I),U,3)),14)
+12 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
End DoDot:1
+13 FOR I=37
Begin DoDot:1
+14 IF R(I)=""
QUIT
+15 SET CNT=CNT+1
+16 DO SET(.ARY,"OBX",0)
+17 DO SET(.ARY,CNT,1)
+18 DO SET(.ARY,"ST",2)
+19 DO SET(.ARY,"BMI",3)
+20 DO SET(.ARY,$PIECE(R(I),U,1),5)
+21 DO SET(.ARY,$$HLD(R(38)),14)
+22 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+23 ;
End DoDot:1
+24 QUIT
+25 ;
OBXLAB(R) ;
+1 DO OBXLAB^APCLSIH1(R)
+2 QUIT
+3 ;
ZLI(R) ;-- setup the ILI ZLI segment
+1 DO SET(.ARY,"ZLI",0)
+2 DO SET(.ARY,1,1)
+3 DO SET(.ARY,$$HLD(R(14)),3)
+4 DO SET(.ARY,R(15),4)
+5 DO SET(.ARY,R(18),5)
+6 DO SET(.ARY,$$HLD(R(19)),6)
+7 DO SET(.ARY,R(21),8)
+8 DO SET(.ARY,R(22),9)
+9 IF $GET(R(22))["."
Begin DoDot:1
+10 NEW ICDTA
+11 ;get the icd type based on the code
SET ICDTA=$PIECE($$ICDDX^APCLSILU(R(22),R(7)),U,20)
+12 DO SET(.ARY,$SELECT(ICDTA="30":"I10",1:"I9"),9,3)
End DoDot:1
+13 DO SET(.ARY,R(33),10)
+14 DO SET(.ARY,R(34),11)
+15 DO SET(.ARY,R(35),12)
+16 DO SET(.ARY,R(36),13)
+17 ;ihs/cmi/maw p31
IF $GET(R(39))["."
Begin DoDot:1
+18 NEW ICDTB
+19 SET ICDTB=$PIECE($$ICDDX^APCLSILU(R(39),R(7)),U,20)
+20 DO SET(.ARY,R(39),16,1)
+21 DO SET(.ARY,$SELECT(ICDTB="30":"I10",1:"I9"),16,3)
End DoDot:1
+22 IF $LENGTH($GET(R(39)))=5
IF $GET(R(39))'["."
Begin DoDot:1
+23 DO SET(.ARY,R(39),16,1)
+24 DO SET(.ARY,"C4",16,3)
End DoDot:1
+25 IF $GET(R(39))'["."
IF $LENGTH($GET(R(39)))<4
DO SET(.ARY,R(39),16)
+26 DO SET(.ARY,$$HLD(R(40)),17)
+27 NEW ICDT
+28 ;get the icd type based on the code
SET ICDT=$PIECE($$ICDDX^APCLSILU(R(43),R(7)),U,20)
+29 DO SET(.ARY,R(43),19)
+30 IF $GET(R(43))]""
DO SET(.ARY,$SELECT(ICDT="30":"I10",1:"I9"),19,3)
+31 DO SET(.ARY,R(44),20)
+32 DO SET(.ARY,R(59),21)
+33 DO SET(.ARY,R(60),22)
+34 DO SET(.ARY,R(61),23)
+35 DO SET(.ARY,R(62),24)
+36 DO SET(.ARY,R(63),25)
+37 DO SET(.ARY,R(64),26)
+38 DO SET(.ARY,R(65),27)
+39 DO SET(.ARY,$$HLD(R(123)),28)
+40 DO SET(.ARY,$$HLD(R(124)),29)
+41 DO SET(.ARY,R(133),30)
+42 DO SET(.ARY,R(134),31)
+43 DO SET(.ARY,R(135),32)
+44 DO SET(.ARY,$$HLD(R(136)),33)
+45 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+46 QUIT
+47 ;
ZPCCHK(R) ;-- do we need to create a ZPC
+1 IF R(107)
QUIT 1
+2 FOR I=113:1:122
IF R(I)
QUIT 1
+3 QUIT 0
+4 ;
ZPC(R) ;-- setup the ZPC segment
+1 DO SET(.ARY,"ZPC",0)
+2 DO SET(.ARY,R(107),1)
+3 DO SET(.ARY,R(113),2)
+4 NEW ICDT
+5 ;get the icd type based on the code
SET ICDT=$PIECE($$ICDDX^APCLSILU(R(113),R(7)),U,20)
+6 IF $GET(R(113))]""
DO SET(.ARY,$SELECT(ICDT="30":"I10",1:"I9"),2,3)
+7 DO SET(.ARY,$$HLD(R(114)),3)
+8 DO SET(.ARY,R(115),4)
+9 NEW ICDTA
+10 ;get the icd type based on the code
SET ICDTA=$PIECE($$ICDDX^APCLSILU(R(115),R(7)),U,20)
+11 IF $GET(R(115))]""
DO SET(.ARY,$SELECT(ICDTA="30":"I10",1:"I9"),4,3)
+12 DO SET(.ARY,$$HLD(R(116)),5)
+13 DO SET(.ARY,R(117),6)
+14 NEW ICDTB
+15 ;get the icd type based on the code
SET ICDTB=$PIECE($$ICDDX^APCLSILU(R(117),R(7)),U,20)
+16 IF $GET(R(117))]""
DO SET(.ARY,$SELECT(ICDTB="30":"I10",1:"I9"),6,3)
+17 DO SET(.ARY,$$HLD(R(118)),7)
+18 DO SET(.ARY,R(119),8)
+19 NEW ICDTC
+20 ;get the icd type based on the code
SET ICDTC=$PIECE($$ICDDX^APCLSILU(R(119),R(7)),U,20)
+21 IF $GET(R(119))]""
DO SET(.ARY,$SELECT(ICDTC="30":"I10",1:"I9"),8,3)
+22 DO SET(.ARY,$$HLD(R(120)),9)
+23 DO SET(.ARY,R(121),10)
+24 NEW ICDTD
+25 ;get the icd type based on the code
SET ICDTD=$PIECE($$ICDDX^APCLSILU(R(121),R(7)),U,20)
+26 IF $GET(R(121))]""
DO SET(.ARY,$SELECT(ICDTD="30":"I10",1:"I9"),10,3)
+27 DO SET(.ARY,$$HLD(R(122)),11)
+28 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+29 QUIT
+30 ;
ZAV(R,SQ,ZAV2,ZAV3) ;-- setup the ILI ZAV segment
+1 DO SET(.ARY,"ZAV",0)
+2 DO SET(.ARY,SQ,1)
+3 DO SET(.ARY,$$HLD(ZAV2),2)
+4 DO SET(.ARY,ZAV3,3)
+5 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+6 QUIT
+7 ;
ZSR(R,SQ,ZSR2) ;-- setup the ILI ZSR segment
+1 NEW ICDT
+2 ;get the icd type based on the code
SET ICDT=$PIECE($$ICDDX^APCLSILU(ZSR2,R(7)),U,20)
+3 DO SET(.ARY,"ZSR",0)
+4 DO SET(.ARY,SQ,1)
+5 DO SET(.ARY,ZSR2,2)
+6 ;set the diagnosis type here
DO SET(.ARY,$SELECT(ICDT="30":"I10",1:"I9"),2,3)
+7 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+8 QUIT
+9 ;
ZAE(R,SQ,ZAE2) ;-- setup the ILI ZAE segment
+1 DO SET(.ARY,"ZAE",0)
+2 DO SET(.ARY,SQ,1)
+3 DO SET(.ARY,ZAE2,2)
+4 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+5 QUIT
+6 ;
ZAS(R,SQ,ZAS2,ZAS3) ;-- setup the ILI ZAS segment
+1 DO SET(.ARY,"ZAS",0)
+2 DO SET(.ARY,SQ,1)
+3 DO SET(.ARY,ZAS2,2)
+4 DO SET(.ARY,$$HLD(ZAS3),3)
+5 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+6 QUIT
+7 ;
ZAN(R) ;-- setup the ILI ZAN segment
+1 NEW I,ZANC,VAL,VALD
+2 SET ZANC=1
+3 FOR I=66:1:70
Begin DoDot:1
+4 IF $GET(R(I))]""
Begin DoDot:2
+5 SET VAL=$GET(R(I))
+6 SET VALD=$$FMTHL7^XLFDT($GET(R(I+42)))
+7 DO SET(.ARY,"ZAN",0)
+8 DO SET(.ARY,ZANC,1)
+9 NEW ICDT
+10 ;get the icd type based on the code
SET ICDT=$PIECE($$ICDDX^APCLSILU(VAL,R(7)),U,20)
+11 DO SET(.ARY,VAL,2)
+12 DO SET(.ARY,$SELECT(ICDT="30":"I10",1:"I9"),2,3)
+13 DO SET(.ARY,VALD,3)
+14 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+15 SET ZANC=ZANC+1
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
ZCV(R) ;-- setup the ILI ZCV segment
+1 NEW J,ZCVC,VALC,VALD,ARBD,X,D
+2 SET ZCVC=0
+3 SET J=0
FOR
SET J=$ORDER(^AUPNVIMM("AC",DFN,J))
IF J'=+J
QUIT
Begin DoDot:1
+4 ;bad xref
IF '$DATA(^AUPNVIMM(J,0))
QUIT
+5 IF $PIECE(^AUPNVIMM(J,0),U,1)=""
QUIT
+6 SET VALD=""
+7 IF $PIECE($GET(^AUPNVIMM(J,12)),U,1)
SET VALD=$PIECE($PIECE(^AUPNVIMM(J,12),U,1),".")
+8 IF VALD=""
SET VALD=$$VD^APCLV($PIECE(^AUPNVIMM(J,0),U,3))
+9 SET VALC=$$GET1^DIQ(9999999.14,$PIECE(^AUPNVIMM(J,0),U,1),.03)
+10 SET ARBD(9999999-VALD,J)=VALC
End DoDot:1
+11 SET D=0
FOR
SET D=$ORDER(ARBD(D))
IF D'=+D
QUIT
Begin DoDot:1
+12 SET J=0
FOR
SET J=$ORDER(ARBD(D,J))
IF J'=+J
QUIT
Begin DoDot:2
+13 SET VALD=$$FMTHL7^XLFDT(9999999-D)
SET VALC=ARBD(D,J)
SET ZCVC=ZCVC+1
+14 DO SET(.ARY,"ZCV",0)
+15 DO SET(.ARY,ZCVC,1)
+16 DO SET(.ARY,VALC,2)
+17 DO SET(.ARY,VALD,3)
+18 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
+21 ; 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 SET MSA=$$ADDSEG^HLOAPI(.HLST,.ARY)
+7 QUIT
+8 ; Create MSH segment
+9 ;EP
+10 NEW MSH
+11 DO SET(.ARY,"MSH",0)
+12 SET MSH=$$ADDSEG^HLOAPI(.HLST,.ARY)
+13 QUIT
SET(ARY,V,F,C,S,R) ;EP
+1 DO SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
+2 QUIT
FIXZIP(DFN,ZIP) ;EP
+1 IF $GET(ZIP)
QUIT ZIP
+2 QUIT $$GET1^DIQ(2,DFN,.116)
+3 ;
HLD(FDT) ;-- convert to HL7 date
+1 IF $GET(FDT)=""
QUIT ""
+2 NEW D
+3 SET %DT="X"
+4 SET X=FDT
DO ^%DT
+5 SET D=$$FMTHL7^XLFDT(Y)
+6 QUIT D
+7 ;
GL(IN,TYP) ;-- write out batch
+1 KILL ^APCLTMP($JOB)
+2 NEW BDA,BDO,HLODAT,MSH,MSGP,MSG,BT,BT1,BT2,BT3
+3 SET APCLCNT=0
+4 SET MSG=$PIECE($GET(^HLB(IN,0)),U,2)
+5 SET BT1=$GET(^HLB(IN,1))
+6 SET BT2=$GET(^HLB(IN,2))
+7 SET BT3=$GET(^HLB(IN,3))
+8 SET BT=BT1_BT2_BT3
+9 DO SETGL(BT)
+10 SET BDA=0
FOR
SET BDA=$ORDER(^HLB(IN,3,BDA))
IF 'BDA
QUIT
Begin DoDot:1
+11 SET MSH=""
+12 SET MSGP=$PIECE($GET(^HLB(IN,3,BDA,0)),U)
+13 SET BDO=0
FOR
SET BDO=$ORDER(^HLB(IN,3,BDA,BDO))
IF 'BDO
QUIT
Begin DoDot:2
+14 SET HLOMSH=$GET(^HLB(IN,3,BDA,BDO))
+15 SET MSH=MSH_HLOMSH
End DoDot:2
+16 DO SETGL(MSH)
+17 DO REST(MSG,MSGP)
End DoDot:1
+18 SET DIK="^HLB("
SET DA=IN
DO ^DIK
+19 SET DIK="^HLA("
SET DA=MSG
DO ^DIK
+20 DO WRITE(TYP)
+21 QUIT
+22 ;
REST(M,MP) ;-- write out the remainder of the segments to the global
+1 NEW MDA,DATA,MCNT
+2 SET MCNT=0
+3 SET MDA=0
FOR
SET MDA=$ORDER(^HLA(M,2,MP,1,MDA))
IF 'MDA
QUIT
Begin DoDot:1
+4 SET DATA=$GET(^HLA(M,2,MP,1,MDA,0))
+5 IF DATA=""
QUIT
+6 DO SETGL(DATA)
End DoDot:1
+7 QUIT
+8 ;
SETGL(D) ;-- set the temp global
+1 SET APCLCNT=APCLCNT+1
+2 SET ^APCLTMP($JOB,APCLCNT)=D
+3 QUIT
+4 ;
WRITE(T) ; use XBGSAVE to save the temp global (APCLDATA) to a delimited
+1 NEW XBGL,XBQ,XBQTO,XBNAR,XBMED,XBFLT,XBUF,XBFN,APCLFN
+2 SET XBGL="APCLTMP"
SET XBMED="F"
SET XBQ="N"
SET XBFLT=1
SET XBF=$JOB
SET XBE=$JOB
+3 SET XBNAR="ILI FLU "_TYP_"_HL7 EXPORT"
+4 SET APCLASU=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0)),U,10)
+5 ;is this a test system?
+6 NEW TST
+7 SET TST=0
+8 IF $PIECE($GET(^APCLILIC(1,0)),U,5)="T"
SET TST=1
+9 ;IHS/CMI/LAB - PATCH 31 FILENAME AND PATCH #
SET (XBFN,APCLDFN)=$SELECT(TST:"FLZ",$GET(APCLFLF):"FLF",$GET(APCLFLFN):"FLF",1:"FLU")_"_"_APCLASU_"_"_$$DATE(DT)_"_P31.txt"
+10 SET XBS1="SURVEILLANCE ILI SEND"
+11 ;
+12 DO ^XBGSAVE
+13 ;
+14 IF XBFLG'=0
Begin DoDot:1
+15 IF XBFLG(1)=""
IF '$DATA(ZTQUEUED)
WRITE !!,TYP_" HL7 file successfully created",!!
+16 IF XBFLG(1)]""
IF '$DATA(ZTQUEUED)
WRITE !!,TYP_" HL7 file NOT successfully created",!!
+17 IF '$DATA(ZTQUEUED)
WRITE !,"File was NOT successfully transferred to IHS/CDC",!,"you will need to manually ftp it.",!
+18 IF '$DATA(ZTQUEUED)
WRITE !,XBFLG(1),!!
End DoDot:1
+19 DO SETLOG
+20 KILL ^APCLTMP($JOB),APCLCNT
+21 KILL ^APCLDATA($JOB)
+22 QUIT
DATE(D) ;EP
+1 QUIT (1700+$EXTRACT(D,1,3))_$EXTRACT(D,4,5)_$EXTRACT(D,6,7)
+2 ;
SETLOG ;EP
+1 DO SET^APCLSIL4
+2 QUIT
