APCSHLOC ;cmi/flag/maw - APCL Cert HL7 Export 5/12/2010 9:26:17 AM
;;2.0;IHS PCC SUITE;**6**;MAY 14, 2009;Build 11
;
;
;ihs/cmi/maw - 9/8/2010 added new segments based on patch 5 requirements
;
CERT(LABDA,TYPE) ;EP - for certification
D BATCH(.HLPARM,TYPE)
N APCSDA,APCSCNT,APCSREC
S APCSCNT=0
S APCSDA=0 F S APCSDA=$O(LABDA(APCSDA)) Q:'APCSDA D
. S APCSCNT=APCSCNT+1
. D NEWMSG(.HLMSTATE,.HLPARM,APCSDA,"ORU","R01",TYPE)
I $G(HLMSTATE("IEN")) D GL(HLMSTATE("IEN"),TYPE) ;ihs/cmi/maw 11/23/2010 added $G
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
;
NEWMSG(HLST,HLPM,RC,MTYPE,EVNTTYPE,TYP) ;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
;S HLPM("VERSION")="2.5.1"
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
;
I TYPE="CERT" D
. N PAT,VST
. S PAT=$P($G(^AUPNVLAB(RC,0)),U,2)
. S VST=$P($G(^AUPNVLAB(RC,0)),U,3)
. I '$D(ERR) D SFTCERT
. I '$D(ERR) D PIDCERT(.RC,PAT)
. I '$D(ERR) D ORCCERT(.RC,PAT,VST)
. I '$D(ERR) D OBRCERT(.RC,PAT,VST)
. I '$D(ERR) D OBXCERT(.RC,PAT,VST)
. I '$D(ERR) D SPMCERT(.RC,PAT,VST)
I '$D(ERR) D
.; Define sending and receiving parameters
.S APPARMS("SENDING APPLICATION")="RPMS-ILI^2.16.840.1.113883.3.72.7.1^HL7"
.S HLMSTATE("HDR","RECEIVING APPLICATION")="PH Application^2.16.840.1.113883.3.72.7.3^HL7"
.S APPARMS("SENDING FACILITY")="RPMS Facility^2.16.840.1.113883.3.72.7.2^HL7"
.S HLMSTATE("HDR","RECEIVING FACILITY",1)="PH Facility"
.S HLMSTATE("HDR","RECEIVING FACILITY",2)="2.16.840.1.113883.3.72.7.4"
.S HLMSTATE("HDR","RECEIVING FACILITY",3)="HL7"
.S HLMSTATE("HDR","MESSAGE TYPE")="ORU"
.S HLMSTATE("HDR","EVENT")="R01"
.S HLMSTATE("HDR","MESSAGE STRUCTURE")=MTYPE_"_"_EVNTTYPE ;ihs/cmi/maw for cert
.S APPARMS("MSH22")="PHLabReport-Ack^^2.16.840.1.114222.4.10.3^ISO"
.S APPARMS("ACCEPT ACK TYPE")="AL" ;Commit ACK type
.S APPARMS("APP ACK RESPONSE")="AACK^APCLSHL" ;Callback when 'application ACK' is received
.S APPARMS("ACCEPT ACK RESPONSE")="CACK^APCLSHL" ;Callback when 'commit ACK' is received
.S APPARMS("APP ACK TYPE")="AL" ;Application ACK type
.S APPARMS("QUEUE")="ILI ADT" ;Incoming QUEUE
.S WHO("RECEIVING APPLICATION")="CDC"
.S WHO("FACILITY LINK NAME")="ILI"
.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
;
SFTCERT ;-- create the SFT segment
N SFT11,SFT2,SFT3,SFT4,SFT61
N PACK,INSTDT,VERI
S SFT11="IHS"
S SFT2="5.2"
S SFT3="IHS Laboratory"
S SFT4="5.2.1027"
S PACK=$O(^DIC(9.4,"B","IHS LABORATORY",0))
I PACK D
. S VERI=$O(^DIC(9.4,PACK,22,"B","5.2",0))
. I VERI D
.. S INSTDT=$$HLD($P($G(^DIC(9.4,PACK,22,VERI,0)),U,2))
S SFT61=$S($G(INSTDT):INSTDT,1:20000101)
D SET(.ARY,"SFT",0)
D SET(.ARY,SFT11,1)
D SET(.ARY,SFT2,2)
D SET(.ARY,SFT3,3)
D SET(.ARY,SFT4,4)
D SET(.ARY,SFT61,6)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
PIDCERT(R,P) ;EP
N PID,HRN,NM,ETHCI,ETHC,ETHT,ETHCC,PID34,PID35,RC,RCI,RT,PID341,PID342,PID343
S HLQ=HL1("Q")
S PID=$$EN^VAFHLPID(P,"2,3,5,6,7,8,10,11,13,22,",1)
Q:PID=""
S HRN=$$HRN^AUPNPAT(P,DUZ(2))
D SET(.ARY,"PID",0)
D SET(.ARY,1,1)
D SET(.ARY,HRN,3,1) ; Patient HRN
S PID341="MPI"
S PID342="2.16.840.1.113883.19.3.2.1"
S PID343="ISO"
S PID35="MR"
S RCI=$$GET1^DIQ(2,P,.06,"I")
S RC=$S(RCI:$$GET1^DIQ(10,RCI,3),1:"")
S RCT=$S(RCI:$$GET1^DIQ(10,RCI,.01),1:"")
D SET(.ARY,PID341,3,4,1)
D SET(.ARY,PID342,3,4,2)
D SET(.ARY,PID343,3,4,3)
D SET(.ARY,PID35,3,5)
N DOB,SEX,NM,ADD,CTY,ST,STI,ZIP,CTRY,PH
S DOB=$$HLD($P($G(^DPT(P,0)),U,3))
S SEX=$P($G(^DPT(P,0)),U,2)
S LNM=$P($P($G(^DPT(P,0)),U),",")
S FNM=$P($P($P($G(^DPT(P,0)),U),",",2)," ")
S ADD=$P($G(^DPT(P,.11)),U)
S CTY=$P($G(^DPT(P,.11)),U,4)
S STI=$P($G(^DPT(P,.11)),U,5)
S ST=$S(STI:$P($G(^DIC(5,STI,0)),U,2),1:"")
S ZIP=$P($G(^DPT(P,.11)),U,6)
S CTRY="USA"
S PH=$P($G(^DPT(P,.13)),U)
S PH=$TR(PH,"-")
S PH=$TR(PH,"(")
S PH=$TR(PH,")")
D SET(.ARY,LNM,5,1)
D SET(.ARY,FNM,5,2)
D SET(.ARY,DOB,7)
D SET(.ARY,SEX,8)
D SET(.ARY,ADD,11,1)
D SET(.ARY,CTY,11,3)
D SET(.ARY,ST,11,4)
D SET(.ARY,ZIP,11,5)
D SET(.ARY,CTRY,11,6)
D SET(.ARY,"M",11,7)
D SET(.ARY,PH,13,1)
D SET(.ARY,"PRN",13,2)
D SET(.ARY,$E(PH,1,3),13,6)
D SET(.ARY,$E(PH,4,10),13,7)
D SET(.ARY,RC,10,1)
D SET(.ARY,RCT,10,2)
D SET(.ARY,"HL70005",10,3)
S ETHCI=$O(^DPT(P,.06,"B",0))
S ETHCI=$P($G(^DPT(P,.06,+ETHCI,0)),U)
I ETHCI D
. S ETHC=$P($G(^DIC(10.2,ETHCI,0)),U,2),ETHT=$P($G(^DIC(10.2,ETHCI,0)),U)
. D SET(.ARY,ETHC,22,1)
. D SET(.ARY,ETHT,22,2)
. D SET(.ARY,"HL70189",22,3)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
ORCCERT(R,P,V) ;-- setup the cert ORC segment
N ID,FN,AANI,AAUI,AAUIT,STR,CTY,ST,ZIP,PH,AT,ORG,ORPI,APCSNAME,STA,LNM,FNM
S ORPI=$P($G(^AUPNVLAB(R,12)),U,2)
Q:'ORPI
S ID=$$GET1^DIQ(200,ORPI,41.99)
S LNM=$P($P($G(^VA(200,ORPI,0)),U),",")
S FNM=$P($P($P($G(^VA(200,ORPI,0)),U),",",2)," ")
S AANI=$$GET1^DIQ(4,DUZ(2),.01)
S STR=$$GET1^DIQ(4,DUZ(2),1.01)
S CTY=$$GET1^DIQ(4,DUZ(2),1.03)
S ST=$$GET1^DIQ(4,DUZ(2),.02)
S ZIP=$$GET1^DIQ(4,DUZ(2),1.04)
S STA=$$GET1^DIQ(4,DUZ(2),99)
S PH=$P($G(^DIC(4,DUZ(2),2,1,0)),U,3)
D SET(.ARY,"ORC",0)
D SET(.ARY,"RE",1)
D SET(.ARY,ID,12,1)
D SET(.ARY,LNM,12,2)
D SET(.ARY,FNM,12,3)
D SET(.ARY,AANI,12,9,1)
D SET(.ARY,"2.16.840.1.113883.19.4.6",12,9,2)
D SET(.ARY,"ISO",12,9,3)
D SET(.ARY,AANI,21,1)
D SET(.ARY,"L",21,2)
D SET(.ARY,AANI,21,6,1)
D SET(.ARY,"2.16.840.1.113883.19.4.6",21,6,2)
D SET(.ARY,"ISO",21,6,3)
D SET(.ARY,"XX",21,7)
D SET(.ARY,ID,21,10)
D SET(.ARY,STR,22,1)
D SET(.ARY,CTY,22,3)
D SET(.ARY,ST,22,4)
D SET(.ARY,ZIP,22,5)
D SET(.ARY,"B",22,7)
D SET(.ARY,PH,23,1)
D SET(.ARY,"PRN",23,2)
D SET(.ARY,$E(PH,1,3),23,6)
D SET(.ARY,$E(PH,4,10),23,7)
D SET(.ARY,STR,24,1)
D SET(.ARY,CTY,24,3)
D SET(.ARY,ST,24,4)
D SET(.ARY,ZIP,24,5)
D SET(.ARY,"B",24,7)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
OBRCERT(R,P,V) ;-- setup the cert OBR segment
N ACC,ACCN,LOINCI,LOINC,LOINCT,ALT,ALTT,OBS,OBSI,RESI,RCI,ID,FN,AANI,RES,RESS,IDEN,IDENT,ORPI,APCSNAME,IDENI,OBR31,LNM,FNM,LOINCO,LOINCOI,LOINCOT,SVC
S ORPI=$P($G(^AUPNVLAB(R,12)),U,2)
Q:'ORPI
S LNM=$P($P($G(^VA(200,ORPI,0)),U),",")
S FNM=$P($P($P($G(^VA(200,ORPI,0)),U),",",2)," ")
S ACC=$$GET1^DIQ(9000010.09,R,.06)
S ACCN="Lab"
S SVC=$$GET1^DIQ(9000010,V,.07,"I")
S LOINCI=$$GET1^DIQ(9000010.09,R,1113,"I")
S LOINCO=$$GET1^DIQ(95.3,LOINCI,34)
S LOINCOI=$S(LOINCO]"":$P(LOINCO,"-"),1:"")
S LOINC=$$GET1^DIQ(9000010.09,R,1113)
S LOINCOT=$S($G(LOINCOI):$$GET1^DIQ(95.3,LOINCOI,81),1:"")
S LOINCT=$S(LOINCI:$$GET1^DIQ(95.3,LOINCI,81),1:"")
S ALT=$$GET1^DIQ(9000010.09,R,.01,"I")
S ALTT=$$GET1^DIQ(9000010.09,R,.01)
S OBSI=$$GET1^DIQ(9000010.09,R,1201,"I")
S OBS=$S(OBSI:$$HLD(OBSI),1:"")
S RCI=$$GET1^DIQ(9000010.09,R,1601)
S ID=$$GET1^DIQ(200,ORPI,41.99)
S AANI=$$GET1^DIQ(4,DUZ(2),.01)
S RESI=$$GET1^DIQ(9000010.09,R,1212,"I")
S RES=$S(RESI:$$HLD(RESI),1:OBS)
S RESS="F"
S OBR31=$$BLDOBR31(V)
I OBR31="",SVC="I" D
. N NEWV
. S NEWV=$$FNDH(V)
. S OBR31=$$BLDOBR31(NEWV)
S IDENI=$O(^AUPNVPOV("AD",V,0))
S IDEN=$S(IDENI:$$GET1^DIQ(9000010.07,IDENI,.01),1:"")
S IDENT=$S(IDENI:$P($G(^ICD9(IDENI,0)),U,3),1:"")
D SET(.ARY,"OBR",0)
D SET(.ARY,1,1)
D SET(.ARY,ACC,3,1)
D SET(.ARY,ACCN,3,2)
D SET(.ARY,"2.16.840.1.113883.19.3.1.6",3,3)
D SET(.ARY,"ISO",3,4)
D SET(.ARY,$S($G(LOINCO)]"":LOINCO,1:LOINC),4,1)
D SET(.ARY,$S($G(LOINCOT)]"":LOINCOT,1:LOINCT),4,2)
D SET(.ARY,"LN",4,3)
D SET(.ARY,ALT,4,4)
D SET(.ARY,ALTT,4,5)
D SET(.ARY,"L",4,6)
D SET(.ARY,OBS,7)
D SET(.ARY,RCI,13)
D SET(.ARY,ID,16,1)
D SET(.ARY,LNM,16,2)
D SET(.ARY,FNM,16,3)
D SET(.ARY,AANI,16,9,1)
D SET(.ARY,"2.16.840.1.113883.19.4.6",16,9,2)
D SET(.ARY,"ISO",16,9,3)
D SET(.ARY,RES,22)
D SET(.ARY,RESS,25)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
FNDH(VP) ;-- find H visit for this I visit
N IVR,IDAT,DFN,ITYP,ILOC,FND,OLD,HDFN,DVD,HOSP,VDH,SVD,HDFN,HVR,HDAT,HTYP,HLOC,INPD,DCD,FND
S IVR=$G(^AUPNVSIT(VP,0))
S IDAT=+$P(IVR,U),DFN=$P(IVR,U,5),ITYP=$P(IVR,U,3),ILOC=$P(IVR,U,6),(FND,OLD,HDFN)=0,DVD=$P(IDAT,".") K HOSP
; Check for hospitalization prior to (or on same day) as the "I" visit
S VDH=(9999999-DVD),SVD=(VDH-1)_".9999",HDFN=""
F S SVD=$O(^AUPNVSIT("AAH",DFN,SVD)) Q:SVD'=+SVD!($P(SVD,".")<VDH) D
. S HDFN=0 F S HDFN=$O(^AUPNVSIT("AAH",DFN,SVD,HDFN)) Q:HDFN'=+HDFN I HDFN]"",$D(^AUPNVSIT(HDFN,0)),'$P(^(0),U,11),$P(^(0),U,9) D
..S HVR=^AUPNVSIT(HDFN,0)
..S HDAT=+$P(HVR,U),HTYP=$P(HVR,U,3),HLOC=$P(HVR,U,6)
..S INPD="",INPD=$S(ITYP="C":$O(^AUPNVCHS("AD",HDFN,"")),1:$O(^AUPNVINP("AD",HDFN,"")))
..;Q:INPD="" ;ihs/cmi/maw at this point we dont care if there is a discharge
..;S:ITYP="C" DCD=$P(^AUPNVCHS(INPD,0),U,7)
..;S:ITYP'="C" DCD=$P(^AUPNVINP(INPD,0),U)
..;I DCD'<DVD S FND=FND+1,HOSP(HDFN)=""
..S FND=FND+1
..S HOSP(HDFN)=""
Q $S(FND=1:$O(HOSP("")),1:VP)
;
BLDOBR31(VP) ;-- build obr 31
N PV,IDENI,IDEN,IDENT,CNT,VALUE
S CNT=0
S VALUE=""
S PV=0 F S PV=$O(^AUPNVPOV("AD",VP,PV)) Q:'PV D
. S IDENI=$P($G(^AUPNVPOV(PV,0)),U)
. S IDEN=$$GET1^DIQ(9000010.07,PV,.01)
. S IDENT=$P($G(^ICD9(IDENI,0)),U,3)
. S CNT=CNT+1
. D SET(.ARY,IDEN,31,1,,CNT)
. D SET(.ARY,IDENT,31,2,,CNT)
. D SET(.ARY,"I9",31,3,,CNT)
. S $P(VALUE,"~",CNT)=IDEN_U_IDENT_U_"I9"
Q $G(VALUE)
;
OBXCERT(R,P,V) ;-- setup the cert OBX segment
N LOINCI,LOINC,LOINCT,VAL,UNIT,RL,RH,ABN,OBSS,OBS,ANA,ORG,ORGT,OAANI,OST,OCTY,OST,OZIP,OSTA,STYP
S LOINCI=$$GET1^DIQ(9000010.09,R,1113,"I")
S LOINC=$$GET1^DIQ(9000010.09,R,1113)
S LOINCT=$S(LOINCI:$$GET1^DIQ(95.3,LOINCI,81),1:"")
S STYP=$S($$GET1^DIQ(95.3,LOINCI,37)]"":$$GET1^DIQ(95.3,LOINCI,37),1:"NM")
S VAL=$$GET1^DIQ(9000010.09,R,.04)
S UNIT=$$GET1^DIQ(9000010.09,R,1101)
S RL=$$GET1^DIQ(9000010.09,R,1104)
S RH=$$GET1^DIQ(9000010.09,R,1105)
I RL="",RH]"" S RL=RH
I RL]"",RH]"" S RL=RL_"-"_RH
S ABN=$$GET1^DIQ(9000010.09,R,.05)
S OBSS="F"
S OBS=$S($$GET1^DIQ(9000010.09,R,1201,"I"):$$HLD($$GET1^DIQ(9000010.09,R,1201,"I")),1:"")
S ANA=$S($$GET1^DIQ(9000010.09,R,1212,"I"):$$HLD($$GET1^DIQ(9000010.09,R,1212,"I")),1:OBS)
S OAANI=$$GET1^DIQ(4,DUZ(2),.01)
S OSTR=$$GET1^DIQ(4,DUZ(2),1.01)
S OCTY=$$GET1^DIQ(4,DUZ(2),1.03)
S OST=$$GET1^DIQ(4,DUZ(2),.02)
S OZIP=$$GET1^DIQ(4,DUZ(2),1.04)
S OSTA=$$GET1^DIQ(4,DUZ(2),99)
D SET(.ARY,"OBX",0)
D SET(.ARY,1,1)
D SET(.ARY,STYP,2)
D SET(.ARY,LOINC,3,1)
D SET(.ARY,LOINCT,3,2)
D SET(.ARY,"LN",3,3)
D SET(.ARY,1,4)
D SET(.ARY,VAL,5)
D SET(.ARY,UNIT,6,1)
D SET(.ARY,UNIT,6,2)
D SET(.ARY,"UCUM",6,3)
D SET(.ARY,RL,7)
D SET(.ARY,ABN,8)
D SET(.ARY,OBSS,11)
D SET(.ARY,OBS,14,1)
D SET(.ARY,"",17)
D SET(.ARY,ANA,19)
D SET(.ARY,OAANI,23,1)
D SET(.ARY,"L",23,2)
D SET(.ARY,"CLIA",23,6,1)
D SET(.ARY,"2.16.840.1.113883.19.4.6",23,6,2)
D SET(.ARY,"ISO",23,6,3)
D SET(.ARY,"XX",23,7)
D SET(.ARY,OSTA,23,10)
D SET(.ARY,OSTR,24,1)
D SET(.ARY,OCTY,24,3)
D SET(.ARY,OST,24,4)
D SET(.ARY,OZIP,24,5)
D SET(.ARY,"B",24,7)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
SPMCERT(R,P,V) ;--setup the cert SPM segment
N STI,STT,ST
S STI=$$GET1^DIQ(9000010.09,R,1103,"I")
I STI D
. S STT=$$GET1^DIQ(9000010.09,R,1103)
. S ST=$P($G(^LAB(61,STI,0)),U,2)
D SET(.ARY,"SPM",0)
D SET(.ARY,$G(ST),4,1)
D SET(.ARY,$G(STT),4,2)
D SET(.ARY,"SNM",4,3)
D SET(.ARY,$G(STT),4,4)
D SET(.ARY,$G(ST),4,5)
D SET(.ARY,"HL70070",4,6)
D SET(.ARY,"20080131",4,7)
D SET(.ARY,"2.5.1",4,8)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
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)
;
HLD(FDT) ;-- convert to HL7 date
I $G(FDT)="" Q ""
S D=$$FMTHL7^XLFDT(FDT)
Q D
;
GL(IN,TYP) ;-- write out the batch to a global for saving in APCSSLAB
K ^APCSTMP($J)
N BDA,BDO,HLODAT,MSH,MSGP,MSG
S APCSCNT=0
S MSG=$P($G(^HLB(IN,0)),U,2)
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)
D WRITE(TYP,APCSCNT)
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 APCSCNT=APCSCNT+1
S ^APCSTMP($J,APCSCNT)=D
Q
;
WRITE(T,COUNT) ; use XBGSAVE to save the temp global (APCSDATA) to a delimited
; file that is exported to the IE system
N XBGL,XBQ,XBQTO,XBNAR,XBMED,XBFLT,XBUF,XBFN
S XBGL="APCSTMP",XBMED="F",XBQ="N",XBFLT=1,XBF=$J,XBE=$J
S XBNAR=TYP_"_HL7 EXPORT"
S APCSASU=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10) ;asufac for file name
S XBFN=TYP_"HL7_"_APCSASU_"_"_$$DATE(DT)_$TR($H,",","")_".txt"
S XBS1="CERTIFICATION LAB EXPORT"
;
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),!!
K ^APCSTMP($J),APCSCNT
Q
DATE(D) ;EP
Q (1700+$E(D,1,3))_$E(D,4,5)_$E(D,6,7)
;
APCSHLOC ;cmi/flag/maw - APCL Cert HL7 Export 5/12/2010 9:26:17 AM
+1 ;;2.0;IHS PCC SUITE;**6**;MAY 14, 2009;Build 11
+2 ;
+3 ;
+4 ;ihs/cmi/maw - 9/8/2010 added new segments based on patch 5 requirements
+5 ;
CERT(LABDA,TYPE) ;EP - for certification
+1 DO BATCH(.HLPARM,TYPE)
+2 NEW APCSDA,APCSCNT,APCSREC
+3 SET APCSCNT=0
+4 SET APCSDA=0
FOR
SET APCSDA=$ORDER(LABDA(APCSDA))
IF 'APCSDA
QUIT
Begin DoDot:1
+5 SET APCSCNT=APCSCNT+1
+6 DO NEWMSG(.HLMSTATE,.HLPARM,APCSDA,"ORU","R01",TYPE)
End DoDot:1
+7 ;ihs/cmi/maw 11/23/2010 added $G
IF $GET(HLMSTATE("IEN"))
DO GL(HLMSTATE("IEN"),TYPE)
+8 QUIT
+9 ;
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 ;
NEWMSG(HLST,HLPM,RC,MTYPE,EVNTTYPE,TYP) ;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 ;S HLPM("VERSION")="2.5.1"
+7 IF '$$ADDMSG^HLOAPI(.HLST,.HLPM,.ERR)
Begin DoDot:1
+8 SET ERR=$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 IF TYPE="CERT"
Begin DoDot:1
+18 NEW PAT,VST
+19 SET PAT=$PIECE($GET(^AUPNVLAB(RC,0)),U,2)
+20 SET VST=$PIECE($GET(^AUPNVLAB(RC,0)),U,3)
+21 IF '$DATA(ERR)
DO SFTCERT
+22 IF '$DATA(ERR)
DO PIDCERT(.RC,PAT)
+23 IF '$DATA(ERR)
DO ORCCERT(.RC,PAT,VST)
+24 IF '$DATA(ERR)
DO OBRCERT(.RC,PAT,VST)
+25 IF '$DATA(ERR)
DO OBXCERT(.RC,PAT,VST)
+26 IF '$DATA(ERR)
DO SPMCERT(.RC,PAT,VST)
End DoDot:1
+27 IF '$DATA(ERR)
Begin DoDot:1
+28 ; Define sending and receiving parameters
+29 SET APPARMS("SENDING APPLICATION")="RPMS-ILI^2.16.840.1.113883.3.72.7.1^HL7"
+30 SET HLMSTATE("HDR","RECEIVING APPLICATION")="PH Application^2.16.840.1.113883.3.72.7.3^HL7"
+31 SET APPARMS("SENDING FACILITY")="RPMS Facility^2.16.840.1.113883.3.72.7.2^HL7"
+32 SET HLMSTATE("HDR","RECEIVING FACILITY",1)="PH Facility"
+33 SET HLMSTATE("HDR","RECEIVING FACILITY",2)="2.16.840.1.113883.3.72.7.4"
+34 SET HLMSTATE("HDR","RECEIVING FACILITY",3)="HL7"
+35 SET HLMSTATE("HDR","MESSAGE TYPE")="ORU"
+36 SET HLMSTATE("HDR","EVENT")="R01"
+37 ;ihs/cmi/maw for cert
SET HLMSTATE("HDR","MESSAGE STRUCTURE")=MTYPE_"_"_EVNTTYPE
+38 SET APPARMS("MSH22")="PHLabReport-Ack^^2.16.840.1.114222.4.10.3^ISO"
+39 ;Commit ACK type
SET APPARMS("ACCEPT ACK TYPE")="AL"
+40 ;Callback when 'application ACK' is received
SET APPARMS("APP ACK RESPONSE")="AACK^APCLSHL"
+41 ;Callback when 'commit ACK' is received
SET APPARMS("ACCEPT ACK RESPONSE")="CACK^APCLSHL"
+42 ;Application ACK type
SET APPARMS("APP ACK TYPE")="AL"
+43 ;Incoming QUEUE
SET APPARMS("QUEUE")="ILI ADT"
+44 SET WHO("RECEIVING APPLICATION")="CDC"
+45 SET WHO("FACILITY LINK NAME")="ILI"
+46 IF '$$SENDONE^HLOAPI1(.HLST,.APPARMS,.WHO,.ERR)
Begin DoDot:2
+47 SET ERR=$GET(ERR)
End DoDot:2
End DoDot:1
+48 QUIT
+49 ;
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 ;
SFTCERT ;-- create the SFT segment
+1 NEW SFT11,SFT2,SFT3,SFT4,SFT61
+2 NEW PACK,INSTDT,VERI
+3 SET SFT11="IHS"
+4 SET SFT2="5.2"
+5 SET SFT3="IHS Laboratory"
+6 SET SFT4="5.2.1027"
+7 SET PACK=$ORDER(^DIC(9.4,"B","IHS LABORATORY",0))
+8 IF PACK
Begin DoDot:1
+9 SET VERI=$ORDER(^DIC(9.4,PACK,22,"B","5.2",0))
+10 IF VERI
Begin DoDot:2
+11 SET INSTDT=$$HLD($PIECE($GET(^DIC(9.4,PACK,22,VERI,0)),U,2))
End DoDot:2
End DoDot:1
+12 SET SFT61=$SELECT($GET(INSTDT):INSTDT,1:20000101)
+13 DO SET(.ARY,"SFT",0)
+14 DO SET(.ARY,SFT11,1)
+15 DO SET(.ARY,SFT2,2)
+16 DO SET(.ARY,SFT3,3)
+17 DO SET(.ARY,SFT4,4)
+18 DO SET(.ARY,SFT61,6)
+19 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+20 QUIT
+21 ;
PIDCERT(R,P) ;EP
+1 NEW PID,HRN,NM,ETHCI,ETHC,ETHT,ETHCC,PID34,PID35,RC,RCI,RT,PID341,PID342,PID343
+2 SET HLQ=HL1("Q")
+3 SET PID=$$EN^VAFHLPID(P,"2,3,5,6,7,8,10,11,13,22,",1)
+4 IF PID=""
QUIT
+5 SET HRN=$$HRN^AUPNPAT(P,DUZ(2))
+6 DO SET(.ARY,"PID",0)
+7 DO SET(.ARY,1,1)
+8 ; Patient HRN
DO SET(.ARY,HRN,3,1)
+9 SET PID341="MPI"
+10 SET PID342="2.16.840.1.113883.19.3.2.1"
+11 SET PID343="ISO"
+12 SET PID35="MR"
+13 SET RCI=$$GET1^DIQ(2,P,.06,"I")
+14 SET RC=$SELECT(RCI:$$GET1^DIQ(10,RCI,3),1:"")
+15 SET RCT=$SELECT(RCI:$$GET1^DIQ(10,RCI,.01),1:"")
+16 DO SET(.ARY,PID341,3,4,1)
+17 DO SET(.ARY,PID342,3,4,2)
+18 DO SET(.ARY,PID343,3,4,3)
+19 DO SET(.ARY,PID35,3,5)
+20 NEW DOB,SEX,NM,ADD,CTY,ST,STI,ZIP,CTRY,PH
+21 SET DOB=$$HLD($PIECE($GET(^DPT(P,0)),U,3))
+22 SET SEX=$PIECE($GET(^DPT(P,0)),U,2)
+23 SET LNM=$PIECE($PIECE($GET(^DPT(P,0)),U),",")
+24 SET FNM=$PIECE($PIECE($PIECE($GET(^DPT(P,0)),U),",",2)," ")
+25 SET ADD=$PIECE($GET(^DPT(P,.11)),U)
+26 SET CTY=$PIECE($GET(^DPT(P,.11)),U,4)
+27 SET STI=$PIECE($GET(^DPT(P,.11)),U,5)
+28 SET ST=$SELECT(STI:$PIECE($GET(^DIC(5,STI,0)),U,2),1:"")
+29 SET ZIP=$PIECE($GET(^DPT(P,.11)),U,6)
+30 SET CTRY="USA"
+31 SET PH=$PIECE($GET(^DPT(P,.13)),U)
+32 SET PH=$TRANSLATE(PH,"-")
+33 SET PH=$TRANSLATE(PH,"(")
+34 SET PH=$TRANSLATE(PH,")")
+35 DO SET(.ARY,LNM,5,1)
+36 DO SET(.ARY,FNM,5,2)
+37 DO SET(.ARY,DOB,7)
+38 DO SET(.ARY,SEX,8)
+39 DO SET(.ARY,ADD,11,1)
+40 DO SET(.ARY,CTY,11,3)
+41 DO SET(.ARY,ST,11,4)
+42 DO SET(.ARY,ZIP,11,5)
+43 DO SET(.ARY,CTRY,11,6)
+44 DO SET(.ARY,"M",11,7)
+45 DO SET(.ARY,PH,13,1)
+46 DO SET(.ARY,"PRN",13,2)
+47 DO SET(.ARY,$EXTRACT(PH,1,3),13,6)
+48 DO SET(.ARY,$EXTRACT(PH,4,10),13,7)
+49 DO SET(.ARY,RC,10,1)
+50 DO SET(.ARY,RCT,10,2)
+51 DO SET(.ARY,"HL70005",10,3)
+52 SET ETHCI=$ORDER(^DPT(P,.06,"B",0))
+53 SET ETHCI=$PIECE($GET(^DPT(P,.06,+ETHCI,0)),U)
+54 IF ETHCI
Begin DoDot:1
+55 SET ETHC=$PIECE($GET(^DIC(10.2,ETHCI,0)),U,2)
SET ETHT=$PIECE($GET(^DIC(10.2,ETHCI,0)),U)
+56 DO SET(.ARY,ETHC,22,1)
+57 DO SET(.ARY,ETHT,22,2)
+58 DO SET(.ARY,"HL70189",22,3)
End DoDot:1
+59 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+60 QUIT
+61 ;
ORCCERT(R,P,V) ;-- setup the cert ORC segment
+1 NEW ID,FN,AANI,AAUI,AAUIT,STR,CTY,ST,ZIP,PH,AT,ORG,ORPI,APCSNAME,STA,LNM,FNM
+2 SET ORPI=$PIECE($GET(^AUPNVLAB(R,12)),U,2)
+3 IF 'ORPI
QUIT
+4 SET ID=$$GET1^DIQ(200,ORPI,41.99)
+5 SET LNM=$PIECE($PIECE($GET(^VA(200,ORPI,0)),U),",")
+6 SET FNM=$PIECE($PIECE($PIECE($GET(^VA(200,ORPI,0)),U),",",2)," ")
+7 SET AANI=$$GET1^DIQ(4,DUZ(2),.01)
+8 SET STR=$$GET1^DIQ(4,DUZ(2),1.01)
+9 SET CTY=$$GET1^DIQ(4,DUZ(2),1.03)
+10 SET ST=$$GET1^DIQ(4,DUZ(2),.02)
+11 SET ZIP=$$GET1^DIQ(4,DUZ(2),1.04)
+12 SET STA=$$GET1^DIQ(4,DUZ(2),99)
+13 SET PH=$PIECE($GET(^DIC(4,DUZ(2),2,1,0)),U,3)
+14 DO SET(.ARY,"ORC",0)
+15 DO SET(.ARY,"RE",1)
+16 DO SET(.ARY,ID,12,1)
+17 DO SET(.ARY,LNM,12,2)
+18 DO SET(.ARY,FNM,12,3)
+19 DO SET(.ARY,AANI,12,9,1)
+20 DO SET(.ARY,"2.16.840.1.113883.19.4.6",12,9,2)
+21 DO SET(.ARY,"ISO",12,9,3)
+22 DO SET(.ARY,AANI,21,1)
+23 DO SET(.ARY,"L",21,2)
+24 DO SET(.ARY,AANI,21,6,1)
+25 DO SET(.ARY,"2.16.840.1.113883.19.4.6",21,6,2)
+26 DO SET(.ARY,"ISO",21,6,3)
+27 DO SET(.ARY,"XX",21,7)
+28 DO SET(.ARY,ID,21,10)
+29 DO SET(.ARY,STR,22,1)
+30 DO SET(.ARY,CTY,22,3)
+31 DO SET(.ARY,ST,22,4)
+32 DO SET(.ARY,ZIP,22,5)
+33 DO SET(.ARY,"B",22,7)
+34 DO SET(.ARY,PH,23,1)
+35 DO SET(.ARY,"PRN",23,2)
+36 DO SET(.ARY,$EXTRACT(PH,1,3),23,6)
+37 DO SET(.ARY,$EXTRACT(PH,4,10),23,7)
+38 DO SET(.ARY,STR,24,1)
+39 DO SET(.ARY,CTY,24,3)
+40 DO SET(.ARY,ST,24,4)
+41 DO SET(.ARY,ZIP,24,5)
+42 DO SET(.ARY,"B",24,7)
+43 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+44 QUIT
+45 ;
OBRCERT(R,P,V) ;-- setup the cert OBR segment
+1 NEW ACC,ACCN,LOINCI,LOINC,LOINCT,ALT,ALTT,OBS,OBSI,RESI,RCI,ID,FN,AANI,RES,RESS,IDEN,IDENT,ORPI,APCSNAME,IDENI,OBR31,LNM,FNM,LOINCO,LOINCOI,LOINCOT,SVC
+2 SET ORPI=$PIECE($GET(^AUPNVLAB(R,12)),U,2)
+3 IF 'ORPI
QUIT
+4 SET LNM=$PIECE($PIECE($GET(^VA(200,ORPI,0)),U),",")
+5 SET FNM=$PIECE($PIECE($PIECE($GET(^VA(200,ORPI,0)),U),",",2)," ")
+6 SET ACC=$$GET1^DIQ(9000010.09,R,.06)
+7 SET ACCN="Lab"
+8 SET SVC=$$GET1^DIQ(9000010,V,.07,"I")
+9 SET LOINCI=$$GET1^DIQ(9000010.09,R,1113,"I")
+10 SET LOINCO=$$GET1^DIQ(95.3,LOINCI,34)
+11 SET LOINCOI=$SELECT(LOINCO]"":$PIECE(LOINCO,"-"),1:"")
+12 SET LOINC=$$GET1^DIQ(9000010.09,R,1113)
+13 SET LOINCOT=$SELECT($GET(LOINCOI):$$GET1^DIQ(95.3,LOINCOI,81),1:"")
+14 SET LOINCT=$SELECT(LOINCI:$$GET1^DIQ(95.3,LOINCI,81),1:"")
+15 SET ALT=$$GET1^DIQ(9000010.09,R,.01,"I")
+16 SET ALTT=$$GET1^DIQ(9000010.09,R,.01)
+17 SET OBSI=$$GET1^DIQ(9000010.09,R,1201,"I")
+18 SET OBS=$SELECT(OBSI:$$HLD(OBSI),1:"")
+19 SET RCI=$$GET1^DIQ(9000010.09,R,1601)
+20 SET ID=$$GET1^DIQ(200,ORPI,41.99)
+21 SET AANI=$$GET1^DIQ(4,DUZ(2),.01)
+22 SET RESI=$$GET1^DIQ(9000010.09,R,1212,"I")
+23 SET RES=$SELECT(RESI:$$HLD(RESI),1:OBS)
+24 SET RESS="F"
+25 SET OBR31=$$BLDOBR31(V)
+26 IF OBR31=""
IF SVC="I"
Begin DoDot:1
+27 NEW NEWV
+28 SET NEWV=$$FNDH(V)
+29 SET OBR31=$$BLDOBR31(NEWV)
End DoDot:1
+30 SET IDENI=$ORDER(^AUPNVPOV("AD",V,0))
+31 SET IDEN=$SELECT(IDENI:$$GET1^DIQ(9000010.07,IDENI,.01),1:"")
+32 SET IDENT=$SELECT(IDENI:$PIECE($GET(^ICD9(IDENI,0)),U,3),1:"")
+33 DO SET(.ARY,"OBR",0)
+34 DO SET(.ARY,1,1)
+35 DO SET(.ARY,ACC,3,1)
+36 DO SET(.ARY,ACCN,3,2)
+37 DO SET(.ARY,"2.16.840.1.113883.19.3.1.6",3,3)
+38 DO SET(.ARY,"ISO",3,4)
+39 DO SET(.ARY,$SELECT($GET(LOINCO)]"":LOINCO,1:LOINC),4,1)
+40 DO SET(.ARY,$SELECT($GET(LOINCOT)]"":LOINCOT,1:LOINCT),4,2)
+41 DO SET(.ARY,"LN",4,3)
+42 DO SET(.ARY,ALT,4,4)
+43 DO SET(.ARY,ALTT,4,5)
+44 DO SET(.ARY,"L",4,6)
+45 DO SET(.ARY,OBS,7)
+46 DO SET(.ARY,RCI,13)
+47 DO SET(.ARY,ID,16,1)
+48 DO SET(.ARY,LNM,16,2)
+49 DO SET(.ARY,FNM,16,3)
+50 DO SET(.ARY,AANI,16,9,1)
+51 DO SET(.ARY,"2.16.840.1.113883.19.4.6",16,9,2)
+52 DO SET(.ARY,"ISO",16,9,3)
+53 DO SET(.ARY,RES,22)
+54 DO SET(.ARY,RESS,25)
+55 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+56 QUIT
+57 ;
FNDH(VP) ;-- find H visit for this I visit
+1 NEW IVR,IDAT,DFN,ITYP,ILOC,FND,OLD,HDFN,DVD,HOSP,VDH,SVD,HDFN,HVR,HDAT,HTYP,HLOC,INPD,DCD,FND
+2 SET IVR=$GET(^AUPNVSIT(VP,0))
+3 SET IDAT=+$PIECE(IVR,U)
SET DFN=$PIECE(IVR,U,5)
SET ITYP=$PIECE(IVR,U,3)
SET ILOC=$PIECE(IVR,U,6)
SET (FND,OLD,HDFN)=0
SET DVD=$PIECE(IDAT,".")
KILL HOSP
+4 ; Check for hospitalization prior to (or on same day) as the "I" visit
+5 SET VDH=(9999999-DVD)
SET SVD=(VDH-1)_".9999"
SET HDFN=""
+6 FOR
SET SVD=$ORDER(^AUPNVSIT("AAH",DFN,SVD))
IF SVD'=+SVD!($PIECE(SVD,".")<VDH)
QUIT
Begin DoDot:1
+7 SET HDFN=0
FOR
SET HDFN=$ORDER(^AUPNVSIT("AAH",DFN,SVD,HDFN))
IF HDFN'=+HDFN
QUIT
IF HDFN]""
IF $DATA(^AUPNVSIT(HDFN,0))
IF '$PIECE(^(0),U,11)
IF $PIECE(^(0),U,9)
Begin DoDot:2
+8 SET HVR=^AUPNVSIT(HDFN,0)
+9 SET HDAT=+$PIECE(HVR,U)
SET HTYP=$PIECE(HVR,U,3)
SET HLOC=$PIECE(HVR,U,6)
+10 SET INPD=""
SET INPD=$SELECT(ITYP="C":$ORDER(^AUPNVCHS("AD",HDFN,"")),1:$ORDER(^AUPNVINP("AD",HDFN,"")))
+11 ;Q:INPD="" ;ihs/cmi/maw at this point we dont care if there is a discharge
+12 ;S:ITYP="C" DCD=$P(^AUPNVCHS(INPD,0),U,7)
+13 ;S:ITYP'="C" DCD=$P(^AUPNVINP(INPD,0),U)
+14 ;I DCD'<DVD S FND=FND+1,HOSP(HDFN)=""
+15 SET FND=FND+1
+16 SET HOSP(HDFN)=""
End DoDot:2
End DoDot:1
+17 QUIT $SELECT(FND=1:$ORDER(HOSP("")),1:VP)
+18 ;
BLDOBR31(VP) ;-- build obr 31
+1 NEW PV,IDENI,IDEN,IDENT,CNT,VALUE
+2 SET CNT=0
+3 SET VALUE=""
+4 SET PV=0
FOR
SET PV=$ORDER(^AUPNVPOV("AD",VP,PV))
IF 'PV
QUIT
Begin DoDot:1
+5 SET IDENI=$PIECE($GET(^AUPNVPOV(PV,0)),U)
+6 SET IDEN=$$GET1^DIQ(9000010.07,PV,.01)
+7 SET IDENT=$PIECE($GET(^ICD9(IDENI,0)),U,3)
+8 SET CNT=CNT+1
+9 DO SET(.ARY,IDEN,31,1,,CNT)
+10 DO SET(.ARY,IDENT,31,2,,CNT)
+11 DO SET(.ARY,"I9",31,3,,CNT)
+12 SET $PIECE(VALUE,"~",CNT)=IDEN_U_IDENT_U_"I9"
End DoDot:1
+13 QUIT $GET(VALUE)
+14 ;
OBXCERT(R,P,V) ;-- setup the cert OBX segment
+1 NEW LOINCI,LOINC,LOINCT,VAL,UNIT,RL,RH,ABN,OBSS,OBS,ANA,ORG,ORGT,OAANI,OST,OCTY,OST,OZIP,OSTA,STYP
+2 SET LOINCI=$$GET1^DIQ(9000010.09,R,1113,"I")
+3 SET LOINC=$$GET1^DIQ(9000010.09,R,1113)
+4 SET LOINCT=$SELECT(LOINCI:$$GET1^DIQ(95.3,LOINCI,81),1:"")
+5 SET STYP=$SELECT($$GET1^DIQ(95.3,LOINCI,37)]"":$$GET1^DIQ(95.3,LOINCI,37),1:"NM")
+6 SET VAL=$$GET1^DIQ(9000010.09,R,.04)
+7 SET UNIT=$$GET1^DIQ(9000010.09,R,1101)
+8 SET RL=$$GET1^DIQ(9000010.09,R,1104)
+9 SET RH=$$GET1^DIQ(9000010.09,R,1105)
+10 IF RL=""
IF RH]""
SET RL=RH
+11 IF RL]""
IF RH]""
SET RL=RL_"-"_RH
+12 SET ABN=$$GET1^DIQ(9000010.09,R,.05)
+13 SET OBSS="F"
+14 SET OBS=$SELECT($$GET1^DIQ(9000010.09,R,1201,"I"):$$HLD($$GET1^DIQ(9000010.09,R,1201,"I")),1:"")
+15 SET ANA=$SELECT($$GET1^DIQ(9000010.09,R,1212,"I"):$$HLD($$GET1^DIQ(9000010.09,R,1212,"I")),1:OBS)
+16 SET OAANI=$$GET1^DIQ(4,DUZ(2),.01)
+17 SET OSTR=$$GET1^DIQ(4,DUZ(2),1.01)
+18 SET OCTY=$$GET1^DIQ(4,DUZ(2),1.03)
+19 SET OST=$$GET1^DIQ(4,DUZ(2),.02)
+20 SET OZIP=$$GET1^DIQ(4,DUZ(2),1.04)
+21 SET OSTA=$$GET1^DIQ(4,DUZ(2),99)
+22 DO SET(.ARY,"OBX",0)
+23 DO SET(.ARY,1,1)
+24 DO SET(.ARY,STYP,2)
+25 DO SET(.ARY,LOINC,3,1)
+26 DO SET(.ARY,LOINCT,3,2)
+27 DO SET(.ARY,"LN",3,3)
+28 DO SET(.ARY,1,4)
+29 DO SET(.ARY,VAL,5)
+30 DO SET(.ARY,UNIT,6,1)
+31 DO SET(.ARY,UNIT,6,2)
+32 DO SET(.ARY,"UCUM",6,3)
+33 DO SET(.ARY,RL,7)
+34 DO SET(.ARY,ABN,8)
+35 DO SET(.ARY,OBSS,11)
+36 DO SET(.ARY,OBS,14,1)
+37 DO SET(.ARY,"",17)
+38 DO SET(.ARY,ANA,19)
+39 DO SET(.ARY,OAANI,23,1)
+40 DO SET(.ARY,"L",23,2)
+41 DO SET(.ARY,"CLIA",23,6,1)
+42 DO SET(.ARY,"2.16.840.1.113883.19.4.6",23,6,2)
+43 DO SET(.ARY,"ISO",23,6,3)
+44 DO SET(.ARY,"XX",23,7)
+45 DO SET(.ARY,OSTA,23,10)
+46 DO SET(.ARY,OSTR,24,1)
+47 DO SET(.ARY,OCTY,24,3)
+48 DO SET(.ARY,OST,24,4)
+49 DO SET(.ARY,OZIP,24,5)
+50 DO SET(.ARY,"B",24,7)
+51 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+52 QUIT
+53 ;
SPMCERT(R,P,V) ;--setup the cert SPM segment
+1 NEW STI,STT,ST
+2 SET STI=$$GET1^DIQ(9000010.09,R,1103,"I")
+3 IF STI
Begin DoDot:1
+4 SET STT=$$GET1^DIQ(9000010.09,R,1103)
+5 SET ST=$PIECE($GET(^LAB(61,STI,0)),U,2)
End DoDot:1
+6 DO SET(.ARY,"SPM",0)
+7 DO SET(.ARY,$GET(ST),4,1)
+8 DO SET(.ARY,$GET(STT),4,2)
+9 DO SET(.ARY,"SNM",4,3)
+10 DO SET(.ARY,$GET(STT),4,4)
+11 DO SET(.ARY,$GET(ST),4,5)
+12 DO SET(.ARY,"HL70070",4,6)
+13 DO SET(.ARY,"20080131",4,7)
+14 DO SET(.ARY,"2.5.1",4,8)
+15 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+16 QUIT
+17 ;
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)
+3 ;
HLD(FDT) ;-- convert to HL7 date
+1 IF $GET(FDT)=""
QUIT ""
+2 SET D=$$FMTHL7^XLFDT(FDT)
+3 QUIT D
+4 ;
GL(IN,TYP) ;-- write out the batch to a global for saving in APCSSLAB
+1 KILL ^APCSTMP($JOB)
+2 NEW BDA,BDO,HLODAT,MSH,MSGP,MSG
+3 SET APCSCNT=0
+4 SET MSG=$PIECE($GET(^HLB(IN,0)),U,2)
+5 SET BDA=0
FOR
SET BDA=$ORDER(^HLB(IN,3,BDA))
IF 'BDA
QUIT
Begin DoDot:1
+6 SET MSH=""
+7 SET MSGP=$PIECE($GET(^HLB(IN,3,BDA,0)),U)
+8 SET BDO=0
FOR
SET BDO=$ORDER(^HLB(IN,3,BDA,BDO))
IF 'BDO
QUIT
Begin DoDot:2
+9 SET HLOMSH=$GET(^HLB(IN,3,BDA,BDO))
+10 SET MSH=MSH_HLOMSH
End DoDot:2
+11 DO SETGL(MSH)
+12 DO REST(MSG,MSGP)
End DoDot:1
+13 DO WRITE(TYP,APCSCNT)
+14 QUIT
+15 ;
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 APCSCNT=APCSCNT+1
+2 SET ^APCSTMP($JOB,APCSCNT)=D
+3 QUIT
+4 ;
WRITE(T,COUNT) ; use XBGSAVE to save the temp global (APCSDATA) to a delimited
+1 ; file that is exported to the IE system
+2 NEW XBGL,XBQ,XBQTO,XBNAR,XBMED,XBFLT,XBUF,XBFN
+3 SET XBGL="APCSTMP"
SET XBMED="F"
SET XBQ="N"
SET XBFLT=1
SET XBF=$JOB
SET XBE=$JOB
+4 SET XBNAR=TYP_"_HL7 EXPORT"
+5 ;asufac for file name
SET APCSASU=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0)),U,10)
+6 SET XBFN=TYP_"HL7_"_APCSASU_"_"_$$DATE(DT)_$TRANSLATE($HOROLOG,",","")_".txt"
+7 SET XBS1="CERTIFICATION LAB EXPORT"
+8 ;
+9 DO ^XBGSAVE
+10 ;
+11 IF XBFLG'=0
Begin DoDot:1
+12 IF XBFLG(1)=""
IF '$DATA(ZTQUEUED)
WRITE !!,TYP_" HL7 file successfully created",!!
+13 IF XBFLG(1)]""
IF '$DATA(ZTQUEUED)
WRITE !!,TYP_" HL7 file NOT successfully created",!!
+14 IF '$DATA(ZTQUEUED)
WRITE !,"File was NOT successfully transferred to IHS/CDC",!,"you will need to manually ftp it.",!
+15 IF '$DATA(ZTQUEUED)
WRITE !,XBFLG(1),!!
End DoDot:1
+16 KILL ^APCSTMP($JOB),APCSCNT
+17 QUIT
DATE(D) ;EP
+1 QUIT (1700+$EXTRACT(D,1,3))_$EXTRACT(D,4,5)_$EXTRACT(D,6,7)
+2 ;
