Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCSHLOC

APCSHLOC.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;
  1.  ;ihs/cmi/maw - 9/8/2010 added new segments based on patch 5 requirements
  1.  ;
  1. CERT(LABDA,TYPE) ;EP - for certification
  1.  D BATCH(.HLPARM,TYPE)
  1.  N APCSDA,APCSCNT,APCSREC
  1.  S APCSCNT=0
  1.  S APCSDA=0 F  S APCSDA=$O(LABDA(APCSDA)) Q:'APCSDA  D
  1.  . S APCSCNT=APCSCNT+1
  1.  . D NEWMSG(.HLMSTATE,.HLPARM,APCSDA,"ORU","R01",TYPE)
  1.  I $G(HLMSTATE("IEN")) D GL(HLMSTATE("IEN"),TYPE)  ;ihs/cmi/maw 11/23/2010 added $G
  1.  Q
  1.  ;
  1. BATCH(HLPARM,TYP) ;-- start the message batch here
  1.  S HLPARM("COUNTRY")="USA"
  1.  S HLPARM("VERSION")="2.5.1"
  1.  I '$$NEWBATCH^HLOAPI(.HLPARM,.HLMSTATE,.ERROR) D  Q
  1.  . S ERR=$G(ERR)
  1.  Q
  1.  ;
  1. NEWMSG(HLST,HLPM,RC,MTYPE,EVNTTYPE,TYP) ;EP
  1.  N ARY,HLQ,APPARMS,HLMSGIEN,HLECH,HLFS,ERR,WHO
  1.  N LN,HL1,HRCN,FLD,LP,X,LN
  1.  S LN=0
  1.  S HLPM("MESSAGE TYPE")=MTYPE
  1.  S HLPM("EVENT")=EVNTTYPE
  1.  ;S HLPM("VERSION")="2.5.1"
  1.  I '$$ADDMSG^HLOAPI(.HLST,.HLPM,.ERR) D  Q
  1.  .S ERR=$G(ERR)
  1.  S HLFS=HLPM("FIELD SEPARATOR")
  1.  S HLECH=HLPM("ENCODING CHARACTERS")
  1.  S HL1("ECH")=HLECH
  1.  S HL1("FS")=HLFS
  1.  S HL1("Q")=""
  1.  S HL1("VER")=HLPM("VERSION")
  1.  ;Create segments
  1.  ;
  1.  I TYPE="CERT" D
  1.  . N PAT,VST
  1.  . S PAT=$P($G(^AUPNVLAB(RC,0)),U,2)
  1.  . S VST=$P($G(^AUPNVLAB(RC,0)),U,3)
  1.  . I '$D(ERR) D SFTCERT
  1.  . I '$D(ERR) D PIDCERT(.RC,PAT)
  1.  . I '$D(ERR) D ORCCERT(.RC,PAT,VST)
  1.  . I '$D(ERR) D OBRCERT(.RC,PAT,VST)
  1.  . I '$D(ERR) D OBXCERT(.RC,PAT,VST)
  1.  . I '$D(ERR) D SPMCERT(.RC,PAT,VST)
  1.  I '$D(ERR) D
  1.  .; Define sending and receiving parameters
  1.  .S APPARMS("SENDING APPLICATION")="RPMS-ILI^2.16.840.1.113883.3.72.7.1^HL7"
  1.  .S HLMSTATE("HDR","RECEIVING APPLICATION")="PH Application^2.16.840.1.113883.3.72.7.3^HL7"
  1.  .S APPARMS("SENDING FACILITY")="RPMS Facility^2.16.840.1.113883.3.72.7.2^HL7"
  1.  .S HLMSTATE("HDR","RECEIVING FACILITY",1)="PH Facility"
  1.  .S HLMSTATE("HDR","RECEIVING FACILITY",2)="2.16.840.1.113883.3.72.7.4"
  1.  .S HLMSTATE("HDR","RECEIVING FACILITY",3)="HL7"
  1.  .S HLMSTATE("HDR","MESSAGE TYPE")="ORU"
  1.  .S HLMSTATE("HDR","EVENT")="R01"
  1.  .S HLMSTATE("HDR","MESSAGE STRUCTURE")=MTYPE_"_"_EVNTTYPE  ;ihs/cmi/maw for cert
  1.  .S APPARMS("MSH22")="PHLabReport-Ack^^2.16.840.1.114222.4.10.3^ISO"
  1.  .S APPARMS("ACCEPT ACK TYPE")="AL"  ;Commit ACK type
  1.  .S APPARMS("APP ACK RESPONSE")="AACK^APCLSHL"  ;Callback when 'application ACK' is received
  1.  .S APPARMS("ACCEPT ACK RESPONSE")="CACK^APCLSHL"  ;Callback when 'commit ACK' is received
  1.  .S APPARMS("APP ACK TYPE")="AL"  ;Application ACK type
  1.  .S APPARMS("QUEUE")="ILI ADT"   ;Incoming QUEUE
  1.  .S WHO("RECEIVING APPLICATION")="CDC"
  1.  .S WHO("FACILITY LINK NAME")="ILI"
  1.  .I '$$SENDONE^HLOAPI1(.HLST,.APPARMS,.WHO,.ERR) D
  1.  .. S ERR=$G(ERR)
  1.  Q
  1.  ;
  1. AACK ; EP - Application ACK callback - called when AA, AE or AR is received.
  1.  N DATA,AACK,XQAID,XQDATA,XQA,XQAMSG,MSGID
  1.  Q:'$G(HLMSGIEN)
  1.  S MSGID=$P($G(^HLB(+HLMSGIEN,0)),U)
  1.  S AACK=$G(^HLB(HLMSGIEN,4))
  1.  I $P(AACK,U,3)'["|AA|" D
  1.  .S XQAMSG="ILI message "_MSGID_" did not receive a correct application ack."
  1.  .S XQAID="ILI,"_MSGID_","_50
  1.  .S XQDATA=$P(AACK,U,3)
  1.  .S XQA("G.APCS ILI")=""
  1.  .D SETUP^XQALERT
  1.  Q
  1.  ;
  1. CACK ; EP - Commit ACK callback - called when CA, CE or CR is received.
  1.  N CACK,XQAID,XQAMSG,XQA,XQDATA,MSGID
  1.  S MSGID=$P($G(^HLB(+HLMSGIEN,0)),U)
  1.  S CACK=$G(^HLB(HLMSGIEN,4))
  1.  I $P(CACK,U,3)'["|CA|" D
  1.  .S XQAMSG="ILI message "_MSGID_" did not receive a correct commit acknowledgement."
  1.  .S XQAID="ILI,"_MSGID_","_50
  1.  .S XQDATA=$P(CACK,U,3)
  1.  .S XQA("G.APCS ILI")=""
  1.  .D SETUP^XQALERT
  1.  Q
  1.  ;
  1. ERR ;
  1.  Q
  1.  ;
  1. SFTCERT ;-- create the SFT segment
  1.  N SFT11,SFT2,SFT3,SFT4,SFT61
  1.  N PACK,INSTDT,VERI
  1.  S SFT11="IHS"
  1.  S SFT2="5.2"
  1.  S SFT3="IHS Laboratory"
  1.  S SFT4="5.2.1027"
  1.  S PACK=$O(^DIC(9.4,"B","IHS LABORATORY",0))
  1.  I PACK D
  1.  . S VERI=$O(^DIC(9.4,PACK,22,"B","5.2",0))
  1.  . I VERI D
  1.  .. S INSTDT=$$HLD($P($G(^DIC(9.4,PACK,22,VERI,0)),U,2))
  1.  S SFT61=$S($G(INSTDT):INSTDT,1:20000101)
  1.  D SET(.ARY,"SFT",0)
  1.  D SET(.ARY,SFT11,1)
  1.  D SET(.ARY,SFT2,2)
  1.  D SET(.ARY,SFT3,3)
  1.  D SET(.ARY,SFT4,4)
  1.  D SET(.ARY,SFT61,6)
  1.  S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
  1.  Q
  1.  ;
  1. PIDCERT(R,P) ;EP
  1.  N PID,HRN,NM,ETHCI,ETHC,ETHT,ETHCC,PID34,PID35,RC,RCI,RT,PID341,PID342,PID343
  1.  S HLQ=HL1("Q")
  1.  S PID=$$EN^VAFHLPID(P,"2,3,5,6,7,8,10,11,13,22,",1)
  1.  Q:PID=""
  1.  S HRN=$$HRN^AUPNPAT(P,DUZ(2))
  1.  D SET(.ARY,"PID",0)
  1.  D SET(.ARY,1,1)
  1.  D SET(.ARY,HRN,3,1)  ; Patient HRN
  1.  S PID341="MPI"
  1.  S PID342="2.16.840.1.113883.19.3.2.1"
  1.  S PID343="ISO"
  1.  S PID35="MR"
  1.  S RCI=$$GET1^DIQ(2,P,.06,"I")
  1.  S RC=$S(RCI:$$GET1^DIQ(10,RCI,3),1:"")
  1.  S RCT=$S(RCI:$$GET1^DIQ(10,RCI,.01),1:"")
  1.  D SET(.ARY,PID341,3,4,1)
  1.  D SET(.ARY,PID342,3,4,2)
  1.  D SET(.ARY,PID343,3,4,3)
  1.  D SET(.ARY,PID35,3,5)
  1.  N DOB,SEX,NM,ADD,CTY,ST,STI,ZIP,CTRY,PH
  1.  S DOB=$$HLD($P($G(^DPT(P,0)),U,3))
  1.  S SEX=$P($G(^DPT(P,0)),U,2)
  1.  S LNM=$P($P($G(^DPT(P,0)),U),",")
  1.  S FNM=$P($P($P($G(^DPT(P,0)),U),",",2)," ")
  1.  S ADD=$P($G(^DPT(P,.11)),U)
  1.  S CTY=$P($G(^DPT(P,.11)),U,4)
  1.  S STI=$P($G(^DPT(P,.11)),U,5)
  1.  S ST=$S(STI:$P($G(^DIC(5,STI,0)),U,2),1:"")
  1.  S ZIP=$P($G(^DPT(P,.11)),U,6)
  1.  S CTRY="USA"
  1.  S PH=$P($G(^DPT(P,.13)),U)
  1.  S PH=$TR(PH,"-")
  1.  S PH=$TR(PH,"(")
  1.  S PH=$TR(PH,")")
  1.  D SET(.ARY,LNM,5,1)
  1.  D SET(.ARY,FNM,5,2)
  1.  D SET(.ARY,DOB,7)
  1.  D SET(.ARY,SEX,8)
  1.  D SET(.ARY,ADD,11,1)
  1.  D SET(.ARY,CTY,11,3)
  1.  D SET(.ARY,ST,11,4)
  1.  D SET(.ARY,ZIP,11,5)
  1.  D SET(.ARY,CTRY,11,6)
  1.  D SET(.ARY,"M",11,7)
  1.  D SET(.ARY,PH,13,1)
  1.  D SET(.ARY,"PRN",13,2)
  1.  D SET(.ARY,$E(PH,1,3),13,6)
  1.  D SET(.ARY,$E(PH,4,10),13,7)
  1.  D SET(.ARY,RC,10,1)
  1.  D SET(.ARY,RCT,10,2)
  1.  D SET(.ARY,"HL70005",10,3)
  1.  S ETHCI=$O(^DPT(P,.06,"B",0))
  1.  S ETHCI=$P($G(^DPT(P,.06,+ETHCI,0)),U)
  1.  I ETHCI D
  1.  . S ETHC=$P($G(^DIC(10.2,ETHCI,0)),U,2),ETHT=$P($G(^DIC(10.2,ETHCI,0)),U)
  1.  . D SET(.ARY,ETHC,22,1)
  1.  . D SET(.ARY,ETHT,22,2)
  1.  . D SET(.ARY,"HL70189",22,3)
  1.  S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
  1.  Q
  1.  ;
  1. ORCCERT(R,P,V) ;-- setup the cert ORC segment
  1.  N ID,FN,AANI,AAUI,AAUIT,STR,CTY,ST,ZIP,PH,AT,ORG,ORPI,APCSNAME,STA,LNM,FNM
  1.  S ORPI=$P($G(^AUPNVLAB(R,12)),U,2)
  1.  Q:'ORPI
  1.  S ID=$$GET1^DIQ(200,ORPI,41.99)
  1.  S LNM=$P($P($G(^VA(200,ORPI,0)),U),",")
  1.  S FNM=$P($P($P($G(^VA(200,ORPI,0)),U),",",2)," ")
  1.  S AANI=$$GET1^DIQ(4,DUZ(2),.01)
  1.  S STR=$$GET1^DIQ(4,DUZ(2),1.01)
  1.  S CTY=$$GET1^DIQ(4,DUZ(2),1.03)
  1.  S ST=$$GET1^DIQ(4,DUZ(2),.02)
  1.  S ZIP=$$GET1^DIQ(4,DUZ(2),1.04)
  1.  S STA=$$GET1^DIQ(4,DUZ(2),99)
  1.  S PH=$P($G(^DIC(4,DUZ(2),2,1,0)),U,3)
  1.  D SET(.ARY,"ORC",0)
  1.  D SET(.ARY,"RE",1)
  1.  D SET(.ARY,ID,12,1)
  1.  D SET(.ARY,LNM,12,2)
  1.  D SET(.ARY,FNM,12,3)
  1.  D SET(.ARY,AANI,12,9,1)
  1.  D SET(.ARY,"2.16.840.1.113883.19.4.6",12,9,2)
  1.  D SET(.ARY,"ISO",12,9,3)
  1.  D SET(.ARY,AANI,21,1)
  1.  D SET(.ARY,"L",21,2)
  1.  D SET(.ARY,AANI,21,6,1)
  1.  D SET(.ARY,"2.16.840.1.113883.19.4.6",21,6,2)
  1.  D SET(.ARY,"ISO",21,6,3)
  1.  D SET(.ARY,"XX",21,7)
  1.  D SET(.ARY,ID,21,10)
  1.  D SET(.ARY,STR,22,1)
  1.  D SET(.ARY,CTY,22,3)
  1.  D SET(.ARY,ST,22,4)
  1.  D SET(.ARY,ZIP,22,5)
  1.  D SET(.ARY,"B",22,7)
  1.  D SET(.ARY,PH,23,1)
  1.  D SET(.ARY,"PRN",23,2)
  1.  D SET(.ARY,$E(PH,1,3),23,6)
  1.  D SET(.ARY,$E(PH,4,10),23,7)
  1.  D SET(.ARY,STR,24,1)
  1.  D SET(.ARY,CTY,24,3)
  1.  D SET(.ARY,ST,24,4)
  1.  D SET(.ARY,ZIP,24,5)
  1.  D SET(.ARY,"B",24,7)
  1.  S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
  1.  Q
  1.  ;
  1. OBRCERT(R,P,V) ;-- setup the cert OBR segment
  1.  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
  1.  S ORPI=$P($G(^AUPNVLAB(R,12)),U,2)
  1.  Q:'ORPI
  1.  S LNM=$P($P($G(^VA(200,ORPI,0)),U),",")
  1.  S FNM=$P($P($P($G(^VA(200,ORPI,0)),U),",",2)," ")
  1.  S ACC=$$GET1^DIQ(9000010.09,R,.06)
  1.  S ACCN="Lab"
  1.  S SVC=$$GET1^DIQ(9000010,V,.07,"I")
  1.  S LOINCI=$$GET1^DIQ(9000010.09,R,1113,"I")
  1.  S LOINCO=$$GET1^DIQ(95.3,LOINCI,34)
  1.  S LOINCOI=$S(LOINCO]"":$P(LOINCO,"-"),1:"")
  1.  S LOINC=$$GET1^DIQ(9000010.09,R,1113)
  1.  S LOINCOT=$S($G(LOINCOI):$$GET1^DIQ(95.3,LOINCOI,81),1:"")
  1.  S LOINCT=$S(LOINCI:$$GET1^DIQ(95.3,LOINCI,81),1:"")
  1.  S ALT=$$GET1^DIQ(9000010.09,R,.01,"I")
  1.  S ALTT=$$GET1^DIQ(9000010.09,R,.01)
  1.  S OBSI=$$GET1^DIQ(9000010.09,R,1201,"I")
  1.  S OBS=$S(OBSI:$$HLD(OBSI),1:"")
  1.  S RCI=$$GET1^DIQ(9000010.09,R,1601)
  1.  S ID=$$GET1^DIQ(200,ORPI,41.99)
  1.  S AANI=$$GET1^DIQ(4,DUZ(2),.01)
  1.  S RESI=$$GET1^DIQ(9000010.09,R,1212,"I")
  1.  S RES=$S(RESI:$$HLD(RESI),1:OBS)
  1.  S RESS="F"
  1.  S OBR31=$$BLDOBR31(V)
  1.  I OBR31="",SVC="I" D
  1.  . N NEWV
  1.  . S NEWV=$$FNDH(V)
  1.  . S OBR31=$$BLDOBR31(NEWV)
  1.  S IDENI=$O(^AUPNVPOV("AD",V,0))
  1.  S IDEN=$S(IDENI:$$GET1^DIQ(9000010.07,IDENI,.01),1:"")
  1.  S IDENT=$S(IDENI:$P($G(^ICD9(IDENI,0)),U,3),1:"")
  1.  D SET(.ARY,"OBR",0)
  1.  D SET(.ARY,1,1)
  1.  D SET(.ARY,ACC,3,1)
  1.  D SET(.ARY,ACCN,3,2)
  1.  D SET(.ARY,"2.16.840.1.113883.19.3.1.6",3,3)
  1.  D SET(.ARY,"ISO",3,4)
  1.  D SET(.ARY,$S($G(LOINCO)]"":LOINCO,1:LOINC),4,1)
  1.  D SET(.ARY,$S($G(LOINCOT)]"":LOINCOT,1:LOINCT),4,2)
  1.  D SET(.ARY,"LN",4,3)
  1.  D SET(.ARY,ALT,4,4)
  1.  D SET(.ARY,ALTT,4,5)
  1.  D SET(.ARY,"L",4,6)
  1.  D SET(.ARY,OBS,7)
  1.  D SET(.ARY,RCI,13)
  1.  D SET(.ARY,ID,16,1)
  1.  D SET(.ARY,LNM,16,2)
  1.  D SET(.ARY,FNM,16,3)
  1.  D SET(.ARY,AANI,16,9,1)
  1.  D SET(.ARY,"2.16.840.1.113883.19.4.6",16,9,2)
  1.  D SET(.ARY,"ISO",16,9,3)
  1.  D SET(.ARY,RES,22)
  1.  D SET(.ARY,RESS,25)
  1.  S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
  1.  Q
  1.  ;
  1. FNDH(VP) ;-- find H visit for this I visit
  1.  N IVR,IDAT,DFN,ITYP,ILOC,FND,OLD,HDFN,DVD,HOSP,VDH,SVD,HDFN,HVR,HDAT,HTYP,HLOC,INPD,DCD,FND
  1.  S IVR=$G(^AUPNVSIT(VP,0))
  1.  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
  1.  ; Check for hospitalization prior to (or on same day) as the "I" visit
  1.  S VDH=(9999999-DVD),SVD=(VDH-1)_".9999",HDFN=""
  1.  F  S SVD=$O(^AUPNVSIT("AAH",DFN,SVD)) Q:SVD'=+SVD!($P(SVD,".")<VDH)  D
  1.  . 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
  1.  ..S HVR=^AUPNVSIT(HDFN,0)
  1.  ..S HDAT=+$P(HVR,U),HTYP=$P(HVR,U,3),HLOC=$P(HVR,U,6)
  1.  ..S INPD="",INPD=$S(ITYP="C":$O(^AUPNVCHS("AD",HDFN,"")),1:$O(^AUPNVINP("AD",HDFN,"")))
  1.  ..;Q:INPD=""  ;ihs/cmi/maw at this point we dont care if there is a discharge
  1.  ..;S:ITYP="C" DCD=$P(^AUPNVCHS(INPD,0),U,7)
  1.  ..;S:ITYP'="C" DCD=$P(^AUPNVINP(INPD,0),U)
  1.  ..;I DCD'<DVD S FND=FND+1,HOSP(HDFN)=""
  1.  ..S FND=FND+1
  1.  ..S HOSP(HDFN)=""
  1.  Q $S(FND=1:$O(HOSP("")),1:VP)
  1.  ;
  1. BLDOBR31(VP) ;-- build obr 31
  1.  N PV,IDENI,IDEN,IDENT,CNT,VALUE
  1.  S CNT=0
  1.  S VALUE=""
  1.  S PV=0 F  S PV=$O(^AUPNVPOV("AD",VP,PV)) Q:'PV  D
  1.  . S IDENI=$P($G(^AUPNVPOV(PV,0)),U)
  1.  . S IDEN=$$GET1^DIQ(9000010.07,PV,.01)
  1.  . S IDENT=$P($G(^ICD9(IDENI,0)),U,3)
  1.  . S CNT=CNT+1
  1.  . D SET(.ARY,IDEN,31,1,,CNT)
  1.  . D SET(.ARY,IDENT,31,2,,CNT)
  1.  . D SET(.ARY,"I9",31,3,,CNT)
  1.  . S $P(VALUE,"~",CNT)=IDEN_U_IDENT_U_"I9"
  1.  Q $G(VALUE)
  1.  ;
  1. OBXCERT(R,P,V) ;-- setup the cert OBX segment
  1.  N LOINCI,LOINC,LOINCT,VAL,UNIT,RL,RH,ABN,OBSS,OBS,ANA,ORG,ORGT,OAANI,OST,OCTY,OST,OZIP,OSTA,STYP
  1.  S LOINCI=$$GET1^DIQ(9000010.09,R,1113,"I")
  1.  S LOINC=$$GET1^DIQ(9000010.09,R,1113)
  1.  S LOINCT=$S(LOINCI:$$GET1^DIQ(95.3,LOINCI,81),1:"")
  1.  S STYP=$S($$GET1^DIQ(95.3,LOINCI,37)]"":$$GET1^DIQ(95.3,LOINCI,37),1:"NM")
  1.  S VAL=$$GET1^DIQ(9000010.09,R,.04)
  1.  S UNIT=$$GET1^DIQ(9000010.09,R,1101)
  1.  S RL=$$GET1^DIQ(9000010.09,R,1104)
  1.  S RH=$$GET1^DIQ(9000010.09,R,1105)
  1.  I RL="",RH]"" S RL=RH
  1.  I RL]"",RH]"" S RL=RL_"-"_RH
  1.  S ABN=$$GET1^DIQ(9000010.09,R,.05)
  1.  S OBSS="F"
  1.  S OBS=$S($$GET1^DIQ(9000010.09,R,1201,"I"):$$HLD($$GET1^DIQ(9000010.09,R,1201,"I")),1:"")
  1.  S ANA=$S($$GET1^DIQ(9000010.09,R,1212,"I"):$$HLD($$GET1^DIQ(9000010.09,R,1212,"I")),1:OBS)
  1.  S OAANI=$$GET1^DIQ(4,DUZ(2),.01)
  1.  S OSTR=$$GET1^DIQ(4,DUZ(2),1.01)
  1.  S OCTY=$$GET1^DIQ(4,DUZ(2),1.03)
  1.  S OST=$$GET1^DIQ(4,DUZ(2),.02)
  1.  S OZIP=$$GET1^DIQ(4,DUZ(2),1.04)
  1.  S OSTA=$$GET1^DIQ(4,DUZ(2),99)
  1.  D SET(.ARY,"OBX",0)
  1.  D SET(.ARY,1,1)
  1.  D SET(.ARY,STYP,2)
  1.  D SET(.ARY,LOINC,3,1)
  1.  D SET(.ARY,LOINCT,3,2)
  1.  D SET(.ARY,"LN",3,3)
  1.  D SET(.ARY,1,4)
  1.  D SET(.ARY,VAL,5)
  1.  D SET(.ARY,UNIT,6,1)
  1.  D SET(.ARY,UNIT,6,2)
  1.  D SET(.ARY,"UCUM",6,3)
  1.  D SET(.ARY,RL,7)
  1.  D SET(.ARY,ABN,8)
  1.  D SET(.ARY,OBSS,11)
  1.  D SET(.ARY,OBS,14,1)
  1.  D SET(.ARY,"",17)
  1.  D SET(.ARY,ANA,19)
  1.  D SET(.ARY,OAANI,23,1)
  1.  D SET(.ARY,"L",23,2)
  1.  D SET(.ARY,"CLIA",23,6,1)
  1.  D SET(.ARY,"2.16.840.1.113883.19.4.6",23,6,2)
  1.  D SET(.ARY,"ISO",23,6,3)
  1.  D SET(.ARY,"XX",23,7)
  1.  D SET(.ARY,OSTA,23,10)
  1.  D SET(.ARY,OSTR,24,1)
  1.  D SET(.ARY,OCTY,24,3)
  1.  D SET(.ARY,OST,24,4)
  1.  D SET(.ARY,OZIP,24,5)
  1.  D SET(.ARY,"B",24,7)
  1.  S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
  1.  Q
  1.  ;
  1. SPMCERT(R,P,V) ;--setup the cert SPM segment
  1.  N STI,STT,ST
  1.  S STI=$$GET1^DIQ(9000010.09,R,1103,"I")
  1.  I STI D
  1.  . S STT=$$GET1^DIQ(9000010.09,R,1103)
  1.  . S ST=$P($G(^LAB(61,STI,0)),U,2)
  1.  D SET(.ARY,"SPM",0)
  1.  D SET(.ARY,$G(ST),4,1)
  1.  D SET(.ARY,$G(STT),4,2)
  1.  D SET(.ARY,"SNM",4,3)
  1.  D SET(.ARY,$G(STT),4,4)
  1.  D SET(.ARY,$G(ST),4,5)
  1.  D SET(.ARY,"HL70070",4,6)
  1.  D SET(.ARY,"20080131",4,7)
  1.  D SET(.ARY,"2.5.1",4,8)
  1.  S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
  1.  Q
  1.  ;
  1. SET(ARY,V,F,C,S,R) ;EP
  1.  D SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
  1.  Q
  1.  ; Fix for non-working ZIPCODE Field trigger in File 2
  1. FIXZIP(DFN,ZIP) ;EP
  1.  Q:$G(ZIP) ZIP
  1.  Q $$GET1^DIQ(2,DFN,.116)
  1.  ;
  1. HLD(FDT) ;-- convert to HL7 date
  1.  I $G(FDT)="" Q ""
  1.  S D=$$FMTHL7^XLFDT(FDT)
  1.  Q D
  1.  ;
  1. GL(IN,TYP) ;-- write out the batch to a global for saving in APCSSLAB
  1.  K ^APCSTMP($J)
  1.  N BDA,BDO,HLODAT,MSH,MSGP,MSG
  1.  S APCSCNT=0
  1.  S MSG=$P($G(^HLB(IN,0)),U,2)
  1.  S BDA=0 F  S BDA=$O(^HLB(IN,3,BDA)) Q:'BDA  D
  1.  . S MSH=""
  1.  . S MSGP=$P($G(^HLB(IN,3,BDA,0)),U)
  1.  . S BDO=0 F  S BDO=$O(^HLB(IN,3,BDA,BDO)) Q:'BDO  D
  1.  .. S HLOMSH=$G(^HLB(IN,3,BDA,BDO))
  1.  .. S MSH=MSH_HLOMSH
  1.  . D SETGL(MSH)
  1.  . D REST(MSG,MSGP)
  1.  D WRITE(TYP,APCSCNT)
  1.  Q
  1.  ;
  1. REST(M,MP) ;-- write out the remainder of the segments to the global
  1.  N MDA,DATA,MCNT
  1.  S MCNT=0
  1.  S MDA=0 F  S MDA=$O(^HLA(M,2,MP,1,MDA)) Q:'MDA  D
  1.  . S DATA=$G(^HLA(M,2,MP,1,MDA,0))
  1.  . Q:DATA=""
  1.  . D SETGL(DATA)
  1.  Q
  1.  ;
  1. SETGL(D) ;-- set the temp global
  1.  S APCSCNT=APCSCNT+1
  1.  S ^APCSTMP($J,APCSCNT)=D
  1.  Q
  1.  ;
  1. WRITE(T,COUNT) ; use XBGSAVE to save the temp global (APCSDATA) to a delimited
  1.  ; file that is exported to the IE system
  1.  N XBGL,XBQ,XBQTO,XBNAR,XBMED,XBFLT,XBUF,XBFN
  1.  S XBGL="APCSTMP",XBMED="F",XBQ="N",XBFLT=1,XBF=$J,XBE=$J
  1.  S XBNAR=TYP_"_HL7 EXPORT"
  1.  S APCSASU=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10)  ;asufac for file name
  1.  S XBFN=TYP_"HL7_"_APCSASU_"_"_$$DATE(DT)_$TR($H,",","")_".txt"
  1.  S XBS1="CERTIFICATION LAB EXPORT"
  1.  ;
  1.  D ^XBGSAVE
  1.  ;
  1.  I XBFLG'=0 D
  1.  . I XBFLG(1)="" W:'$D(ZTQUEUED) !!,TYP_" HL7 file successfully created",!!
  1.  . I XBFLG(1)]"" W:'$D(ZTQUEUED) !!,TYP_" HL7 file NOT successfully created",!!
  1.  . W:'$D(ZTQUEUED) !,"File was NOT successfully transferred to IHS/CDC",!,"you will need to manually ftp it.",!
  1.  . W:'$D(ZTQUEUED) !,XBFLG(1),!!
  1.  K ^APCSTMP($J),APCSCNT
  1.  Q
  1. DATE(D) ;EP
  1.  Q (1700+$E(D,1,3))_$E(D,4,5)_$E(D,6,7)
  1.  ;