APCLSMU2 ;cmi/flag/maw - APCL MU2 MESSAGE GENERATOR 5/12/2010 9:26:17 AM
;;3.0;IHS PCC REPORTS;**29,30**;FEB 05, 1997;Build 27
;
OPT ;EP - option to export via date range or patient
N TYPE
S TYPE=$$EXPTYP()
Q:TYPE=""
I TYPE="P" D PATEXP Q
I TYPE="D" D DATEXP Q
Q
;
EXPTYP() ;-- get the export type
S DIR(0)="S^P:One Patient's Visit;D:Date Range of Visits"
S DIR("A")="Export Type"
D ^DIR
I $D(DIRUT) Q ""
Q $G(Y)
;
PATEXP ;-- ask the patient and visit date
D GETPAT
I APCDPAT="" W !!,"No PATIENT selected!" D EOJ Q
D GETVISIT
I APCDVSIT="" W !!,"No VISIT selected!" D EOJ Q
F I="A04","A03","A08","A01" D MSG(I,APCDVSIT,APCDPAT)
Q
;
HL7 ;-- generate the HL7 file
D BATCH(.HLPARM)
S APCLDA=0 F S APCLDA=$O(^XTMP("APCLMUSS",$J,APCLDA)) Q:'APCLDA D
. N APCLRST,APCLINP
. S APCLVCNT=APCLVCNT+1
. S APCLRST=$P($G(^XTMP("APCLMUSS",$J,APCLDA)),U)
. S APCLINP=$P($G(^XTMP("APCLMUSS",$J,APCLDA)),U,2)
. S APCLSEVN=$S(APCLRST="A":"A04",APCLRST="D":"A11",1:"A08")
. S APCLPAT=$P($G(^AUPNVSIT(APCLDA,0)),U,5)
. Q:'APCLPAT
. D MSG(.HLMSTATE,.HLPARM,APCLSEVN,APCLDA,APCLPAT)
. N ER
. S ER=$O(^AMERVSIT("AD",APCLDA,0))
. I '$G(ER) S ER=$O(^AUPNVER("AD",APCLDA,0))
. I $G(ER) D MSG(.HLMSTATE,.HLPARM,"A03",APCLDA,APCLPAT)
. ;N IVDT,EVDT,HVST
. ;S IVDT=(9999999-$P($P(^AUPNVSIT(APCLDA,0),U),"."))
. ;S IVDT=IVDT_"."_$P($P(^AUPNVSIT(APCLDA,0),U),".",2)
. ;S EVDT=IVDT+2
. ;S HVST=$$FNDH(IVDT,EVDT,APCLPAT)
. I $G(APCLINP) D MSG(.HLMSTATE,.HLPARM,"A01",APCLDA,APCLPAT)
. D LOG^APCLSMUN(APCLLOG,APCLDA,APCLRST)
I $G(HLMSTATE("IEN")) D GL2(HLMSTATE("IEN"))
Q
;
BATCH(HLPARM) ;-- 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
;
DATEXP ;-- ask the date range
N BDT,EDT,DADA,DIEN,PAT
S %DT="AE",%DT("A")="Begin Date: "
D ^%DT
I Y<0 D EOJ Q
S BDT=+Y
S %DT="AE",%DT("A")="End Date: "
D ^%DT
I Y<0 D EOJ Q
S EDT=+Y
S DADA=BDT-.0001 F S DADA=$O(^AUPNVSIT("B",DADA)) Q:DADA>(EDT+.9999)!'DADA D
. S DIEN=0 F S DIEN=$O(^AUPNVSIT("B",DADA,DIEN)) Q:'DIEN D
.. S PAT=$P($G(^AUPNVSIT(DIEN,0)),U,5)
.. F I="A04","A03","A08","A01" D MSG(I,DIEN,PAT)
Q
;
GETPAT ;EP GET- PATIENT
W !
S AUPNLK("INAC")=""
S APCDPAT=""
S DIC("A")="Enter PATIENT NAME: ",DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC
Q:Y<0
S APCDPAT=+Y
Q
;
GETVISIT ;EP - this entry point called by the BVP package (View patient record)
S APCDLOOK="",APCDVSIT=""
K APCDVLK
D ^APCDVLK
K APCDLOOK
Q
;
MSG(HLST,HLPM,EVN,VST,PAT) ;EP - create the message based on the event type and visit
N VDATE,UNITFLG
Q:'$G(VST)
S VDATE=$P($$GET1^DIQ(9000010,VST,.01,"I"),".")
S OBXCNT=0,DGCNT=0
N LN,HL1,HRCN,FLD,LP,X,LN
S LN=0
S HLPM("MESSAGE TYPE")="ADT"
S HLPM("EVENT")=EVN
S HLPM("VERSION")="2.5.1"
I '$$ADDMSG^HLOAPI(.HLST,.HLPM,.ERR) D Q
.W !,"Unable to create message" Q
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")
;D MSH("ADT",EVN)
D EVN(EVN)
D PID(PAT)
D PV1(EVN,VST,PAT)
I EVN="A01" D PV2(VST,PAT)
I (EVN="A03") D
. S DGCNT=DGCNT+1
. D DG1S(EVN,VST)
. D ECOD(VST)
S OBXCNT=OBXCNT+1
D OBXLOC(VST,OBXCNT)
S UNITFLG=0
I $$GET1^DIQ(40.7,$P($G(^AUPNVSIT(VST,0)),U,8),1)=30,EVN="A04" D ;this may not work but we will see if they accept another OBX
. ;Q:'$$GET1^DIQ(9000010,VST,1601)
. Q:$P($G(^DPT(PAT,0)),U)'["UNKNOWN"
. ;Q:$P($G(^DPT(PAT,0)),U,2)'="U" ;ihs/cmi/maw lets use this if they have an UNKNOWN sex
. S OBXCNT=OBXCNT+1
. S UNITFLG=1
. D OBXUNIT(PAT,VST,OBXCNT)
I '$G(UNITFLG) D
. S OBXCNT=OBXCNT+1
. D OBXAGE(PAT,VST,OBXCNT)
S OBXCNT=OBXCNT+1
D OBXCC(VST,OBXCNT)
I EVN'="A03" D
. ;D DG1P(EVN,VST,0)
. Q:EVN="A01"
. D DG1S(EVN,VST) ;for multiple DX in A08 and primary in A04
. D ECOD(VST)
S APPARMS("SENDING APPLICATION")="RPMS-ILI"
S APPARMS("RECEIVING APPLICATION")="ILI"
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")="ILI"
S WHO("FACILITY LINK NAME")="IHS"
S WHOTO("RECEIVING APPLICATION")="ILI"
I '$$SENDONE^HLOAPI1(.HLST,.APPARMS,.WHO,.ERR) D
. S ERR=$G(ERR)
;D GL(HLST("IEN"),EVN,PAT,VDATE)
K OBXCNT
Q
;
SETHL(MTYPE,EVNTTYPE) ;-- setup HLO variables
;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")=MTYPE
S HLPM("EVENT")=EVNTTYPE
S HLPM("VERSION")="2.5.1"
I '$$NEWMSG^HLOAPI(.HLPM,.HLST,.ERR) D Q
.;D NOTIF(DFN,"Unable to build HL7 message."_$S($D(ERR):" ERR:"_$G(ERR),1:""))
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")
Q
;
ERR ;
Q
;
; Create MSH segment
MSH(MS,EV) ;EP
N MSH,%,X,FLD,VAL
D NOW^%DTC
S X=$$HLDATE^HLFNC(%,"TS")
D SET(.ARY,"NSH",0)
D SET(.ARY,"RPMS",4,1)
D SET(.ARY,APCLDBID,4,2) ;
D SET(.ARY,"NPI",4,3)
D SET(.ARY,X,7)
D SET(.ARY,MS,9,1)
D SET(.ARY,EV,9,2)
D SET(.ARY,MS_"_"_$S(EV="A04":"A01",EV="A08":"A01",1:EV),9,3)
D SET(.ARY,"IHS-"_$R(999999999),10)
D SET(.ARY,"P",11)
D SET(.ARY,"2.5.1",12)
D SET(.ARY,"PH_SS-NoAck",21,1)
D SET(.ARY,"SS Sender",21,2)
D SET(.ARY,"2.16.840.1.114222.4.10.3",21,3)
D SET(.ARY,"ISO",21,4)
S MSH=$$ADDSEG^HLOAPI(.HLST,.ARY)
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)
D SET(.ARY,X,2)
D SET(.ARY,"RPMS",7,1)
D SET(.ARY,1231231234,7,2)
D SET(.ARY,"NPI",7,3)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
; Create PID segment
PID(P) ;EP
S HLQ=HL1("Q")
N REC,SEX,RACEI,RACE,ZIP,CNTY,EDA,ETH,ETHI,NTYP,DOD,ADD,CITY,STI,STATE,ADD2,DOB,UID
S NTYP=$S($P($G(^DPT(P,0)),U)["UNKNOWN":"U",1:"S") ;this needs to be determined
S REC=$$HRN^AUPNPAT(P,DUZ(2))
S UID=$$GET1^DIQ(9999999.06,$P(^AUTTSITE(1,0),U),.32)_$E("0000000000",1,10-$L(P))_P
S SEX=$P($G(^DPT(P,0)),U,2)
S DOB=$$FMTHL7^XLFDT($$GET1^DIQ(2,P,.03,"I"))
S RACEI=$P($G(^DPT(P,0)),U,6)
I '$G(RACEI) S RACEI=$O(^DPT(P,.02,0))
S RACE=$$GET1^DIQ(10,RACEI,4)
S ADD=$$GET1^DIQ(2,P,.111)
S ADD2=$$GET1^DIQ(2,P,.112)
S CITY=$$GET1^DIQ(2,P,.114)
S STI=$$GET1^DIQ(2,P,.115,"I")
S STATE=$S(STI]"":$P($G(^DIC(5,STI,0)),U,3),1:"")
S ZIP=$$GET1^DIQ(2,P,.116)
S CNTY=$$GET1^DIQ(2,P,.117)
I CNTY="" D
. N COR,CTY
. S COR=$$GET1^DIQ(9000001,P,1117,"I")
. S CTY=$S(COR:$$GET1^DIQ(9999999.05,COR,.02,"I"),1:"")
. I CTY S CNTY=$$GET1^DIQ(9999999.23,CTY,.04)
S EDA=$O(^DPT(P,.06,"B",0))
I EDA S ETHI=$P($G(^DPT(P,.06,EDA,0)),U)
I $G(ETHI) S ETH=$$GET1^DIQ(10.2,ETHI,4)
S DOD=$$GET1^DIQ(2,P,.351,"I")
I DOD]"" S DOD=$$FMTHL7^XLFDT(DOD)
D SET(.ARY,"PID",0)
D SET(.ARY,1,1)
D SET(.ARY,UID,3,1)
D SET(.ARY,"MR",3,5) ; Patient HRN
D SET(.ARY,$S(NTYP]"":NTYP,1:"S"),5,7,,2) ;this needs to be determined
;D SET(.ARY,DOB,7)
D SET(.ARY,SEX,8)
D SET(.ARY,RACE,10,1)
I $G(RACE)]"" D SET(.ARY,"CDCREC",10,3)
D SET(.ARY,ADD,11,1)
D SET(.ARY,ADD2,11,2)
D SET(.ARY,CITY,11,3)
D SET(.ARY,STATE,11,4)
D SET(.ARY,ZIP,11,5)
D SET(.ARY,CNTY,11,9)
D SET(.ARY,$G(ETH),22,1)
I $G(ETH)]"" D SET(.ARY,"CDCREC",22,3)
;ihs/cmi/maw 04/8/2015 p30 do for all events
;I EVN="A03" D
D SET(.ARY,DOD,29)
I DOD]"" D SET(.ARY,"Y",30)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
PV1(EV,V,P) ;-- setup the JVN PV1 segment
N PRV,NPI,LOC,UVID
S PRV=$$PRIMPROV^APCLV(V,"I")
S NPI=$$GET1^DIQ(200,PRV,41.99)
S LOC=$$GET1^DIQ(9999999.06,$P(^AUTTSITE(1,0),U),.32)
S UVID=LOC_$$LZERO(V,10)
D SET(.ARY,"PV1",0)
D SET(.ARY,1,1)
D SET(.ARY,$S(EV="A01":"I",1:"O"),2,1)
D SET(.ARY,APCLDBID,3,1)
D SET(.ARY,NPI,7,1)
D SET(.ARY,"NPI",7,3)
D SET(.ARY,UVID,19,1)
D SET(.ARY,"VN",19,5)
I EV="A03" D
. N DDSP,VER,DED
. S DDSP="01"
. I $$GET1^DIQ(2,P,.351,"I") S DDSP="20"
. S VER=$O(^AMERVSIT("AD",V,0))
. I VER D
.. S DED=$E($$GET1^DIQ(9009080,VER,6.1),1)
.. S DDSP=$S(DED="A":"09",DED="D":20,DED="E":20,1:"01")
. I '$G(VER) D
.. S VER=$O(^AUPNVER("AD",V,0))
.. I VER D
... S DED=$E($$GET1^DIQ(9000010.29,VER,.11),1)
... S DDSP=$S(DED="A":"09",DED="D":20,DED="E":20,1:"01")
. D SET(.ARY,DDSP,36)
D SET(.ARY,$$FMTHL7^XLFDT($$GET1^DIQ(9000010,V,.01,"I")),44)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
PV2(V,PT) ;-- setup the PV2 segment
;this may need to be changed to look at the admitting dx in ADT
Q:'$G(V)
;N HVST,VINP,DXI,DX,DXE,IVDT,ADMT,EVDT
;find H visit here
;S IVDT=(9999999-$P($P(^AUPNVSIT(APCLDA,0),U),"."))
;S IVDT=IVDT_"."_$P($P(^AUPNVSIT(APCLDA,0),U),".",2)
;S EVDT=IVDT+2
;S HVST=$$FNDH(IVDT,EVDT,APCLPAT)
;Q:'HVST
;find the admit here and get admitting dx
N HVST
S HVST=$G(APCLINP)
Q:'$G(HVST)
S ADMT=$O(^DGPM("AVST",PT,HVST,0))
Q:'ADMT
S VINP=$O(^AUPNVINP("AD",HVST,0))
I $G(VINP) D
. S DXI=$$GET1^DIQ(9000010.02,VINP,.12,"I")
. S DX=$$GET1^DIQ(9000010.02,VINP,.12)
I '$G(DXI) S DXI=$O(^ICD9("AB",$P($G(^DGPM(ADMT,0)),U,10)_" ",0))
I $G(DX)="" S DX=$$GET1^DIQ(405,ADMT,.1,"I")
N ICDT,ICDATA
S ICDATA=$$ICDDX^APCLSILU(DX,VDATE)
S DX=$P(ICDATA,U,2)
S DXE=$P(ICDATA,U,4)
S ICDT=$P(ICDATA,U,20) ;get the icd type based on the code
I $P(DX,".",2)="" S DX=$TR(DX,".")
D SET(.ARY,"PV2",0)
D SET(.ARY,DX,3,1)
D SET(.ARY,$G(DXE),3,2)
;D SET(.ARY,"I9CDX",3,3)
D SET(.ARY,$S(ICDT="30":"I10",1:"I9CDX"),3,3) ;p30
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
FNDH(VDT,EDT,P) ;-- find the next H visit within 48 hours
N VDA,VIN
S VDA=VDT F S VDA=$O(^AUPNVSIT("AAH",P,VDA)) Q:'VDA D
. S VIEN=0 F S VIEN=$O(^AUPNVSIT("AAH",P,VDA,VIEN)) Q:'VIEN D
.. I VDA<EDT S VIN=VIEN Q
Q $G(VIN)
;
OBXLOC(V,CNT) ;-- setup the location OBX
N CL,CLC,CD,DSC
S CL=$P($G(^AUPNVSIT(V,0)),U,8)
S CLC=$$GET1^DIQ(40.7,CL,1)
S CD=""
;we will need to do a more dynamic clinic map here
I CLC=80 S CD="261QU0200X" ;urgent care
I CLC=30 S CD="261QE0002X" ;er
Q:CD=""
S DSC=$$LOOKTABM("","NUCC",CD,HLECH)
D SET(.ARY,"OBX",0)
D SET(.ARY,CNT,1)
D SET(.ARY,"CWE",2)
D SET(.ARY,"SS003",3,1) ;this may need to change as well
D SET(.ARY,"PHINQUESTION",3,3)
D SET(.ARY,CD,5,1)
D SET(.ARY,$P(DSC,HLECH,2),5,2)
D SET(.ARY,"NUCC",5,3)
D SET(.ARY,"F",11)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
OBXUNIT(P,V,CNT) ;-- setup units
Q:$P($G(^DPT(P,0)),U)'["UNKNOWN" ;this will need to change once we identify what an unknown patient is
;Q:$$GET1^DIQ(40.7,$P($G(^AUPNVSIT(V,0)),U,8),1)=80
D SET(.ARY,"OBX",0)
D SET(.ARY,CNT,1)
D SET(.ARY,"NM",2)
D SET(.ARY,"21612-7",3,1)
D SET(.ARY,"LN",3,3)
D SET(.ARY,"UNK",6,1)
D SET(.ARY,"NULLFL",6,3)
D SET(.ARY,"F",11)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
OBXAGE(P,V,CNT) ;-- setup the visit OBX
;Q:$$GET1^DIQ(40.7,$P($G(^AUPNVSIT(V,0)),U,8),1)=30
N AGE,UNIT
S AGE=$$AGE^AUPNPAT(P,DT,"D")
S UNIT=$S($P(AGE," ",2)="YRS":"Year",$P(AGE," ",2)="MOS":"Month",1:"Day")
D SET(.ARY,"OBX",0)
D SET(.ARY,CNT,1)
D SET(.ARY,"NM",2)
D SET(.ARY,"21612-7",3,1)
D SET(.ARY,"LN",3,3)
D SET(.ARY,$P(AGE," "),5)
D SET(.ARY,"a",6,1)
D SET(.ARY,UNIT,6,2)
D SET(.ARY,"UCUM",6,3)
D SET(.ARY,"F",11)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
OBXCC(V,CNT) ;-- setup the chief complaint OBX
N LN,CCI,CC,EC,ECE,ECI,VPOVI,CCE
;look here in V NARRATIVE TEXT first
;S VPOVI=$O(^AUPNVPOV("AD",V,0))
;S CCI=$$GET1^DIQ(9000010,V,1107,"I")
;S CC=$$GET1^DIQ(80,$$GET1^DIQ(9000010.07,VPOVI,.01,"I"),3)
;S LN=$$GET1^DIQ(9000010,V,1401)
N CDA,TDA,CCE,ICDT,ICDATA
S CCE=""
S CDA=0 F S CDA=$O(^AUPNVNT("AD",V,CDA)) Q:'CDA D
. Q:$$GET1^DIQ(9000010.34,CDA,.01)'="CHIEF COMPLAINT"
. S TDA=0 F S TDA=$O(^AUPNVNT(CDA,11,TDA)) Q:'TDA D
.. S CCE=CCE_$G(^AUPNVNT(CDA,11,TDA,0))_" "
I CCE="" S CCE=$$GET1^DIQ(9000010,V,1401)
I CCE="" S CCE=$$GET1^DIQ(9000010,V,1107)
Q:$G(CCE)=""
I $G(CCE)]"" S CCI=$O(^ICD9("AB",CCE_" ",0))
I $G(CCI) S CC=$$GET1^DIQ(80,CCI,3)
;S ECI=$$GET1^DIQ(9000010.07,VPOVI,.09,"I")
I $G(CCI) D
. S ICDATA=$$ICDDX^APCLSILU($$GET1^DIQ(80,CCI,.01),VDATE)
. S ICDT=$P(ICDATA,U,20) ;get the icd type based on the code
. S EC=$P(ICDATA,U,2)
. S ECE=$P(ICDATA,U,4)
D SET(.ARY,"OBX",0)
D SET(.ARY,CNT,1)
D SET(.ARY,"CWE",2)
D SET(.ARY,"8661-1",3,1) ;this is the chief complaint loinc code
I $G(CCI) D
. D SET(.ARY,EC,5,1)
. D SET(.ARY,ECE,5,2)
. D SET(.ARY,$S(ICDT="30":"I10",1:"I9CDX"),5,3)
D SET(.ARY,"LN",3,3)
D SET(.ARY,$G(CCE),5,9)
D SET(.ARY,"F",11)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
DG1P(EV,V,FL) ;-- set the repeating DG1
I 'FL Q:EV="A03"
Q:EV="A01" ;IN pv2
;Q:EV'="A04"!EV'="A08"
N DX,DXE,DXT,DIEN,ECOD1,ECOD2,ECOD3
S DXT=$S($G(FL):"F",1:"W")
I EV="A08" S DXT="W"
I EV="A04" S DXT="W"
;S DX=$TR($$PRIMPOV^APCLV(V,"C"),".")
S DIEN=$$PRIMPOV^APCLV(V,5)
S DX=$$PRIMPOV^APCLV(V,"C")
N ICDT,ICDATA
S ICDATA=$$ICDDX^APCLSILU(DX,VDATE)
S ICDT=$P(ICDATA,U,20) ;get the icd type based on the code
I $P(DX,".",2)="" S DX=$TR(DX,".")
;S LEN=$L(DX)
;I $E(DX,LEN,LEN)="0" S DX=$E(DX,1,(LEN-1))
Q:$G(DX)=""
I $P(DX,".",2)="" S DX=$TR(DX,".")
S DXE=$S(ICDT=30:$P(ICDATA,U,4),1:$P($$PRIMPOV^APCLV(V,"E"),"|"))
D SET(.ARY,"DG1",0)
D SET(.ARY,1,1)
D SET(.ARY,DX,3,1)
D SET(.ARY,DXE,3,2)
D SET(.ARY,$S(ICDT="30":"I10",1:"I9CDX"),3,3) ;p30
D SET(.ARY,DXT,6)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q:'$G(DIEN)
S ECOD1=$$GET1^DIQ(9000010.07,DIEN,.09,"I")
S ECOD2=$$GET1^DIQ(9000010.07,DIEN,.18,"I")
S ECOD3=$$GET1^DIQ(9000010.07,DIEN,.19,"I")
I $G(ECOD1) D ECOD(ECOD1,DXT)
I $G(ECOD2) D ECOD(ECOD2,DXT)
I $G(ECOD3) D ECOD(ECOD3,DXT)
Q
;
FNDPPOV(VS) ;--find ien of primary pov
N PDA,PV
S PV=""
S PDA=0 F S PDA=$O(^AUPNVPOV("AD",VS,PDA)) Q:'PDA D
. I $P($G(^AUPNVPOV(PDA,0)),U,12)="P" S PV=PDA
Q PV
;
DG1S(EV,V) ;-- set the secondary DXs
N DX,DXE,DXT,DXDA,DXI,DXCNT,LEN,CNTR,ECOD1,ECOD2,ECOD3
S DXCNT=0,CNTR=0
S CNTR=$$POVS(V)
I CNTR=1 D DG1P(EV,V,1) Q
S DXDA=0 F S DXDA=$O(^AUPNVPOV("AD",V,DXDA)) Q:'DXDA D
. ;Q:$P($G(^AUPNVPOV(DXDA,0)),U,12)="P"
. S DXCNT=DXCNT+1
. ;Q:DXCNT=1
. S DXI=$P($G(^AUPNVPOV(DXDA,0)),U)
. ;S DX=$TR($$GET1^DIQ(80,DXI,.01),".")
. S DX=$$GET1^DIQ(80,DXI,.01)
. N ICDT,ICDATA
. S ICDATA=$$ICDDX^APCLSILU(DX,VDATE)
. S ICDT=$P(ICDATA,U,20) ;get the icd type based on the code
. I $P(DX,".",2)="" S DX=$TR(DX,".")
. ;S LEN=$L(DX)
. ;I $E(DX,LEN,LEN)="0" S DX=$E(DX,1,(LEN-1))
. S DXE=$S(ICDT=30:$P(ICDATA,U,4),1:$$GET1^DIQ(80,DXI,3))
. S DXT="F" ;change this once i know the formula
. I EV="A08" S DXT="W"
. I EV="A04" S DXT="W"
. Q:$G(DX)=""
. D SET(.ARY,"DG1",0)
. D SET(.ARY,DXCNT,1)
. ;D SET(.ARY,(DXCNT-1),1)
. D SET(.ARY,DX,3,1)
. D SET(.ARY,DXE,3,2)
. D SET(.ARY,$S(ICDT="30":"I10",1:"I9CDX"),3,3)
. D SET(.ARY,DXT,6)
. S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
. S ECOD1=$$GET1^DIQ(9000010.07,DXDA,.09,"I")
. S ECOD2=$$GET1^DIQ(9000010.07,DXDA,.18,"I")
. S ECOD3=$$GET1^DIQ(9000010.07,DXDA,.19,"I")
. I $G(ECOD1) D ECOD(ECOD1,DXT)
. I $G(ECOD2) D ECOD(ECOD2,DXT)
. I $G(ECOD3) D ECOD(ECOD3,DXT)
Q
;
ECOD(EDXI,EDXT) ;-- populate the DG1 segment with Ecodes
N ICDT,ICDATA,EDX,EDXE
I '$G(DXCNT) S DXCNT=1
S DXCNT=DXCNT+1
S EDX=$$GET1^DIQ(80,EDXI,.01)
I $G(EDXT)="" S EDXT="W"
S ICDATA=$$ICDDX^APCLSILU(EDX,VDATE)
S ICDT=$P(ICDATA,U,20) ;get the icd type based on the code
I $P(EDX,".",2)="" S EDX=$TR(EDX,".")
S EDXE=$S(ICDT=30:$P(ICDATA,U,4),1:$$GET1^DIQ(80,EDXI,3))
Q:$G(EDX)=""
D SET(.ARY,"DG1",0)
D SET(.ARY,DXCNT,1)
D SET(.ARY,EDX,3,1)
D SET(.ARY,EDXE,3,2)
D SET(.ARY,$S(ICDT="30":"I10",1:"I9CDX"),3,3)
D SET(.ARY,EDXT,6)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
POVS(V) ;-- count the POVs
N DXDA,CN
S CN=0
S DXDA=0 F S DXDA=$O(^AUPNVPOV("AD",V,DXDA)) Q:'DXDA D
. S CN=CN+1
Q $G(CN)
;
LOOKTABM(TYPE,TAB,VAL,ECH) ;-- find the value and description in the HL7 tables
N DESC,IENI,GBL
S GBL="^APCLMUT"
I TYPE="" S GBL="^APCLMUT"
S IENI=$O(@GBL@("AVAL",TAB,VAL,0))
Q:'IENI
S DESC=$P($G(@GBL@(IENI,0)),U,3)
Q VAL_ECH_DESC_ECH_TYPE_TAB
;
LOOKTAB(TYPE,TAB,VAL,ECH) ;-- find the value and description in the HL7 tables
N DESC,IENI,GBL
S GBL="^BHLTBL"
I TYPE="" S GBL="^BHLOTBL"
S IENI=$O(@GBL@("AVAL",TAB,VAL,0))
Q:'IENI
S DESC=$P($G(@GBL@(IENI,0)),U,3)
Q VAL_ECH_DESC_ECH_TYPE_TAB
;
LZERO(V,L) ;EP - left zero fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
Q V
;
LOOKDSC(TYPE,TAB,DSC,ECH) ;-- find a reverse value based on description
N VAL,IENI,GBL
S GBL="^BHLOTBL"
I TYPE="" S GBL="^BHLOTBL"
S IENI=$O(@GBL@("ADSC",TAB,DSC,0))
Q:'IENI
S VAL=$P($G(@GBL@(IENI,0)),U,2)
Q VAL_ECH_ECH_TYPE_TAB
;
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 ""
N D
S %DT="X"
S X=FDT D ^%DT
S D=$$FMTHL7^XLFDT(Y)
Q D
;
GL2(IN) ;-- 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 SETGL2(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 SETGL2(MSH)
. D REST2(MSG,MSGP)
S DIK="^HLB(",DA=IN D ^DIK
S DIK="^HLA(",DA=MSG D ^DIK
D WRITE2
Q
;
REST2(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
;
SETGL2(D) ;-- set the temp global
S APCLCNT=APCLCNT+1
S ^APCLTMP($J,APCLCNT)=D
Q
;
WRITE2 ; use XBGSAVE to save the temp global (APCLDATA) to a delimited
N XBGL,XBQ,XBQTO,XBNAR,XBMED,XBFLT,XBUF,XBFN,APCLFN
NEW TST
S TST=0
I $P($G(^APCLILIC(1,0)),U,5)="T" S TST=1
S XBGL="APCLTMP",XBMED="F",XBQ="N",XBFLT=1,XBF=$J,XBE=$J
S XBNAR="MU2 SURVEILLANCE HL7 EXPORT"
S APCLASU=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10)
;is this a test system?
S (XBFN,APCLDFN)=$S($G(TST):"MU2Z",1:"MU2")_"_"_APCLASU_"_"_$$DATE(DT)_"_P30.txt"
S XBS1="MU2 SURVEILLANCE SEND"
;
D ^XBGSAVE
;
I XBFLG'=0 D
. I XBFLG(1)="" W:'$D(ZTQUEUED) !!," HL7 file successfully created",!!
. I XBFLG(1)]"" W:'$D(ZTQUEUED) !!," 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 ^APCLTMP($J),APCLCNT
Q
;
GL(IN,EV,PT,VDD) ;-- write out the batch to a global for saving in APCLSLAB
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)
D REST(MSG)
D WRITE(EV,PT,VDD)
Q
;
REST(M) ;-- 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,1,MDA)) Q:'MDA D
. S DATA=$G(^HLA(M,1,MDA,0))
. Q:DATA=""
. I $E(DATA,1,3)="NSH" D
.. S $E(DATA,1,4)="MSH"
.. S $P(DATA,HLFS,2)="^~\&"
. D SETGL(DATA)
Q
;
SETGL(D) ;-- set the temp global
S APCLCNT=APCLCNT+1
S ^APCLTMP($J,APCLCNT)=D
Q
;
WRITE(E,P,VD) ; use XBGSAVE to save the temp global (APCLDATA) to a delimited
; file that is exported to the IE system
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="MU2 HL7 EXPORT"
S APCLASU=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10) ;asufac for file name
S (XBFN,APCLDFN)="MU2_"_E_"_"_$$HRN^AUPNPAT(P,DUZ(2))_"_"_$$DATET(VD)_".txt"
S XBS1="SURVEILLANCE MU2 SEND"
;
D ^XBGSAVE
;
I XBFLG'=0 D
. I XBFLG(1)="" W:'$D(ZTQUEUED) !!,"MU2 HL7 file successfully created",!!
. I XBFLG(1)]"" W:'$D(ZTQUEUED) !!,"MU2 HL7 file NOT successfully created",!!
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)
;
DATET(D) ;EP
Q (1700+$E(D,1,3))_$E(D,4,5)_$E(D,6,7)_$E(D,8,11)
;
EOJ ; EP - EOJ HOUSE KEEPING - this ep called by the BVP package (View patient record)
K AUPNLK("INAC")
K %,%DT,%X,%Y,C,DIYS,X,Y
K APCDCLN,APCDCAT,APCDDATE,APCDLOC,APCDPAT,APCDVSIT,APCDLOOK,APCDTYPE
D KILL^AUPNPAT
Q
;
APCLSMU2 ;cmi/flag/maw - APCL MU2 MESSAGE GENERATOR 5/12/2010 9:26:17 AM
+1 ;;3.0;IHS PCC REPORTS;**29,30**;FEB 05, 1997;Build 27
+2 ;
OPT ;EP - option to export via date range or patient
+1 NEW TYPE
+2 SET TYPE=$$EXPTYP()
+3 IF TYPE=""
QUIT
+4 IF TYPE="P"
DO PATEXP
QUIT
+5 IF TYPE="D"
DO DATEXP
QUIT
+6 QUIT
+7 ;
EXPTYP() ;-- get the export type
+1 SET DIR(0)="S^P:One Patient's Visit;D:Date Range of Visits"
+2 SET DIR("A")="Export Type"
+3 DO ^DIR
+4 IF $DATA(DIRUT)
QUIT ""
+5 QUIT $GET(Y)
+6 ;
PATEXP ;-- ask the patient and visit date
+1 DO GETPAT
+2 IF APCDPAT=""
WRITE !!,"No PATIENT selected!"
DO EOJ
QUIT
+3 DO GETVISIT
+4 IF APCDVSIT=""
WRITE !!,"No VISIT selected!"
DO EOJ
QUIT
+5 FOR I="A04","A03","A08","A01"
DO MSG(I,APCDVSIT,APCDPAT)
+6 QUIT
+7 ;
HL7 ;-- generate the HL7 file
+1 DO BATCH(.HLPARM)
+2 SET APCLDA=0
FOR
SET APCLDA=$ORDER(^XTMP("APCLMUSS",$JOB,APCLDA))
IF 'APCLDA
QUIT
Begin DoDot:1
+3 NEW APCLRST,APCLINP
+4 SET APCLVCNT=APCLVCNT+1
+5 SET APCLRST=$PIECE($GET(^XTMP("APCLMUSS",$JOB,APCLDA)),U)
+6 SET APCLINP=$PIECE($GET(^XTMP("APCLMUSS",$JOB,APCLDA)),U,2)
+7 SET APCLSEVN=$SELECT(APCLRST="A":"A04",APCLRST="D":"A11",1:"A08")
+8 SET APCLPAT=$PIECE($GET(^AUPNVSIT(APCLDA,0)),U,5)
+9 IF 'APCLPAT
QUIT
+10 DO MSG(.HLMSTATE,.HLPARM,APCLSEVN,APCLDA,APCLPAT)
+11 NEW ER
+12 SET ER=$ORDER(^AMERVSIT("AD",APCLDA,0))
+13 IF '$GET(ER)
SET ER=$ORDER(^AUPNVER("AD",APCLDA,0))
+14 IF $GET(ER)
DO MSG(.HLMSTATE,.HLPARM,"A03",APCLDA,APCLPAT)
+15 ;N IVDT,EVDT,HVST
+16 ;S IVDT=(9999999-$P($P(^AUPNVSIT(APCLDA,0),U),"."))
+17 ;S IVDT=IVDT_"."_$P($P(^AUPNVSIT(APCLDA,0),U),".",2)
+18 ;S EVDT=IVDT+2
+19 ;S HVST=$$FNDH(IVDT,EVDT,APCLPAT)
+20 IF $GET(APCLINP)
DO MSG(.HLMSTATE,.HLPARM,"A01",APCLDA,APCLPAT)
+21 DO LOG^APCLSMUN(APCLLOG,APCLDA,APCLRST)
End DoDot:1
+22 IF $GET(HLMSTATE("IEN"))
DO GL2(HLMSTATE("IEN"))
+23 QUIT
+24 ;
BATCH(HLPARM) ;-- 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 ;
DATEXP ;-- ask the date range
+1 NEW BDT,EDT,DADA,DIEN,PAT
+2 SET %DT="AE"
SET %DT("A")="Begin Date: "
+3 DO ^%DT
+4 IF Y<0
DO EOJ
QUIT
+5 SET BDT=+Y
+6 SET %DT="AE"
SET %DT("A")="End Date: "
+7 DO ^%DT
+8 IF Y<0
DO EOJ
QUIT
+9 SET EDT=+Y
+10 SET DADA=BDT-.0001
FOR
SET DADA=$ORDER(^AUPNVSIT("B",DADA))
IF DADA>(EDT+.9999)!'DADA
QUIT
Begin DoDot:1
+11 SET DIEN=0
FOR
SET DIEN=$ORDER(^AUPNVSIT("B",DADA,DIEN))
IF 'DIEN
QUIT
Begin DoDot:2
+12 SET PAT=$PIECE($GET(^AUPNVSIT(DIEN,0)),U,5)
+13 FOR I="A04","A03","A08","A01"
DO MSG(I,DIEN,PAT)
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
GETPAT ;EP GET- PATIENT
+1 WRITE !
+2 SET AUPNLK("INAC")=""
+3 SET APCDPAT=""
+4 SET DIC("A")="Enter PATIENT NAME: "
SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+5 IF Y<0
QUIT
+6 SET APCDPAT=+Y
+7 QUIT
+8 ;
GETVISIT ;EP - this entry point called by the BVP package (View patient record)
+1 SET APCDLOOK=""
SET APCDVSIT=""
+2 KILL APCDVLK
+3 DO ^APCDVLK
+4 KILL APCDLOOK
+5 QUIT
+6 ;
MSG(HLST,HLPM,EVN,VST,PAT) ;EP - create the message based on the event type and visit
+1 NEW VDATE,UNITFLG
+2 IF '$GET(VST)
QUIT
+3 SET VDATE=$PIECE($$GET1^DIQ(9000010,VST,.01,"I"),".")
+4 SET OBXCNT=0
SET DGCNT=0
+5 NEW LN,HL1,HRCN,FLD,LP,X,LN
+6 SET LN=0
+7 SET HLPM("MESSAGE TYPE")="ADT"
+8 SET HLPM("EVENT")=EVN
+9 SET HLPM("VERSION")="2.5.1"
+10 IF '$$ADDMSG^HLOAPI(.HLST,.HLPM,.ERR)
Begin DoDot:1
+11 WRITE !,"Unable to create message"
QUIT
End DoDot:1
QUIT
+12 SET HLFS=HLPM("FIELD SEPARATOR")
+13 SET HLECH=HLPM("ENCODING CHARACTERS")
+14 SET HL1("ECH")=HLECH
+15 SET HL1("FS")=HLFS
+16 SET HL1("Q")=""
+17 SET HL1("VER")=HLPM("VERSION")
+18 ;D MSH("ADT",EVN)
+19 DO EVN(EVN)
+20 DO PID(PAT)
+21 DO PV1(EVN,VST,PAT)
+22 IF EVN="A01"
DO PV2(VST,PAT)
+23 IF (EVN="A03")
Begin DoDot:1
+24 SET DGCNT=DGCNT+1
+25 DO DG1S(EVN,VST)
+26 DO ECOD(VST)
End DoDot:1
+27 SET OBXCNT=OBXCNT+1
+28 DO OBXLOC(VST,OBXCNT)
+29 SET UNITFLG=0
+30 ;this may not work but we will see if they accept another OBX
IF $$GET1^DIQ(40.7,$PIECE($GET(^AUPNVSIT(VST,0)),U,8),1)=30
IF EVN="A04"
Begin DoDot:1
+31 ;Q:'$$GET1^DIQ(9000010,VST,1601)
+32 IF $PIECE($GET(^DPT(PAT,0)),U)'["UNKNOWN"
QUIT
+33 ;Q:$P($G(^DPT(PAT,0)),U,2)'="U" ;ihs/cmi/maw lets use this if they have an UNKNOWN sex
+34 SET OBXCNT=OBXCNT+1
+35 SET UNITFLG=1
+36 DO OBXUNIT(PAT,VST,OBXCNT)
End DoDot:1
+37 IF '$GET(UNITFLG)
Begin DoDot:1
+38 SET OBXCNT=OBXCNT+1
+39 DO OBXAGE(PAT,VST,OBXCNT)
End DoDot:1
+40 SET OBXCNT=OBXCNT+1
+41 DO OBXCC(VST,OBXCNT)
+42 IF EVN'="A03"
Begin DoDot:1
+43 ;D DG1P(EVN,VST,0)
+44 IF EVN="A01"
QUIT
+45 ;for multiple DX in A08 and primary in A04
DO DG1S(EVN,VST)
+46 DO ECOD(VST)
End DoDot:1
+47 SET APPARMS("SENDING APPLICATION")="RPMS-ILI"
+48 SET APPARMS("RECEIVING APPLICATION")="ILI"
+49 ;Commit ACK type
SET APPARMS("ACCEPT ACK TYPE")="AL"
+50 ;Callback when 'application ACK' is received
SET APPARMS("APP ACK RESPONSE")="AACK^APCLSHL"
+51 ;Callback when 'commit ACK' is received
SET APPARMS("ACCEPT ACK RESPONSE")="CACK^APCLSHL"
+52 ;Application ACK type
SET APPARMS("APP ACK TYPE")="AL"
+53 ;Incoming QUEUE
SET APPARMS("QUEUE")="ILI ADT"
+54 SET WHO("RECEIVING APPLICATION")="ILI"
+55 SET WHO("FACILITY LINK NAME")="IHS"
+56 SET WHOTO("RECEIVING APPLICATION")="ILI"
+57 IF '$$SENDONE^HLOAPI1(.HLST,.APPARMS,.WHO,.ERR)
Begin DoDot:1
+58 SET ERR=$GET(ERR)
End DoDot:1
+59 ;D GL(HLST("IEN"),EVN,PAT,VDATE)
+60 KILL OBXCNT
+61 QUIT
+62 ;
SETHL(MTYPE,EVNTTYPE) ;-- setup HLO variables
+1 ;N 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")=MTYPE
+5 SET HLPM("EVENT")=EVNTTYPE
+6 SET HLPM("VERSION")="2.5.1"
+7 IF '$$NEWMSG^HLOAPI(.HLPM,.HLST,.ERR)
Begin DoDot:1
+8 ;D NOTIF(DFN,"Unable to build HL7 message."_$S($D(ERR):" ERR:"_$G(ERR),1:""))
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 QUIT
+16 ;
ERR ;
+1 QUIT
+2 ;
+3 ; Create MSH segment
MSH(MS,EV) ;EP
+1 NEW MSH,%,X,FLD,VAL
+2 DO NOW^%DTC
+3 SET X=$$HLDATE^HLFNC(%,"TS")
+4 DO SET(.ARY,"NSH",0)
+5 DO SET(.ARY,"RPMS",4,1)
+6 ;
DO SET(.ARY,APCLDBID,4,2)
+7 DO SET(.ARY,"NPI",4,3)
+8 DO SET(.ARY,X,7)
+9 DO SET(.ARY,MS,9,1)
+10 DO SET(.ARY,EV,9,2)
+11 DO SET(.ARY,MS_"_"_$SELECT(EV="A04":"A01",EV="A08":"A01",1:EV),9,3)
+12 DO SET(.ARY,"IHS-"_$RANDOM(999999999),10)
+13 DO SET(.ARY,"P",11)
+14 DO SET(.ARY,"2.5.1",12)
+15 DO SET(.ARY,"PH_SS-NoAck",21,1)
+16 DO SET(.ARY,"SS Sender",21,2)
+17 DO SET(.ARY,"2.16.840.1.114222.4.10.3",21,3)
+18 DO SET(.ARY,"ISO",21,4)
+19 SET MSH=$$ADDSEG^HLOAPI(.HLST,.ARY)
+20 QUIT
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 DO SET(.ARY,X,2)
+7 DO SET(.ARY,"RPMS",7,1)
+8 DO SET(.ARY,1231231234,7,2)
+9 DO SET(.ARY,"NPI",7,3)
+10 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+11 QUIT
+12 ; Create PID segment
PID(P) ;EP
+1 SET HLQ=HL1("Q")
+2 NEW REC,SEX,RACEI,RACE,ZIP,CNTY,EDA,ETH,ETHI,NTYP,DOD,ADD,CITY,STI,STATE,ADD2,DOB,UID
+3 ;this needs to be determined
SET NTYP=$SELECT($PIECE($GET(^DPT(P,0)),U)["UNKNOWN":"U",1:"S")
+4 SET REC=$$HRN^AUPNPAT(P,DUZ(2))
+5 SET UID=$$GET1^DIQ(9999999.06,$PIECE(^AUTTSITE(1,0),U),.32)_$EXTRACT("0000000000",1,10-$LENGTH(P))_P
+6 SET SEX=$PIECE($GET(^DPT(P,0)),U,2)
+7 SET DOB=$$FMTHL7^XLFDT($$GET1^DIQ(2,P,.03,"I"))
+8 SET RACEI=$PIECE($GET(^DPT(P,0)),U,6)
+9 IF '$GET(RACEI)
SET RACEI=$ORDER(^DPT(P,.02,0))
+10 SET RACE=$$GET1^DIQ(10,RACEI,4)
+11 SET ADD=$$GET1^DIQ(2,P,.111)
+12 SET ADD2=$$GET1^DIQ(2,P,.112)
+13 SET CITY=$$GET1^DIQ(2,P,.114)
+14 SET STI=$$GET1^DIQ(2,P,.115,"I")
+15 SET STATE=$SELECT(STI]"":$PIECE($GET(^DIC(5,STI,0)),U,3),1:"")
+16 SET ZIP=$$GET1^DIQ(2,P,.116)
+17 SET CNTY=$$GET1^DIQ(2,P,.117)
+18 IF CNTY=""
Begin DoDot:1
+19 NEW COR,CTY
+20 SET COR=$$GET1^DIQ(9000001,P,1117,"I")
+21 SET CTY=$SELECT(COR:$$GET1^DIQ(9999999.05,COR,.02,"I"),1:"")
+22 IF CTY
SET CNTY=$$GET1^DIQ(9999999.23,CTY,.04)
End DoDot:1
+23 SET EDA=$ORDER(^DPT(P,.06,"B",0))
+24 IF EDA
SET ETHI=$PIECE($GET(^DPT(P,.06,EDA,0)),U)
+25 IF $GET(ETHI)
SET ETH=$$GET1^DIQ(10.2,ETHI,4)
+26 SET DOD=$$GET1^DIQ(2,P,.351,"I")
+27 IF DOD]""
SET DOD=$$FMTHL7^XLFDT(DOD)
+28 DO SET(.ARY,"PID",0)
+29 DO SET(.ARY,1,1)
+30 DO SET(.ARY,UID,3,1)
+31 ; Patient HRN
DO SET(.ARY,"MR",3,5)
+32 ;this needs to be determined
DO SET(.ARY,$SELECT(NTYP]"":NTYP,1:"S"),5,7,,2)
+33 ;D SET(.ARY,DOB,7)
+34 DO SET(.ARY,SEX,8)
+35 DO SET(.ARY,RACE,10,1)
+36 IF $GET(RACE)]""
DO SET(.ARY,"CDCREC",10,3)
+37 DO SET(.ARY,ADD,11,1)
+38 DO SET(.ARY,ADD2,11,2)
+39 DO SET(.ARY,CITY,11,3)
+40 DO SET(.ARY,STATE,11,4)
+41 DO SET(.ARY,ZIP,11,5)
+42 DO SET(.ARY,CNTY,11,9)
+43 DO SET(.ARY,$GET(ETH),22,1)
+44 IF $GET(ETH)]""
DO SET(.ARY,"CDCREC",22,3)
+45 ;ihs/cmi/maw 04/8/2015 p30 do for all events
+46 ;I EVN="A03" D
+47 DO SET(.ARY,DOD,29)
+48 IF DOD]""
DO SET(.ARY,"Y",30)
+49 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+50 QUIT
+51 ;
PV1(EV,V,P) ;-- setup the JVN PV1 segment
+1 NEW PRV,NPI,LOC,UVID
+2 SET PRV=$$PRIMPROV^APCLV(V,"I")
+3 SET NPI=$$GET1^DIQ(200,PRV,41.99)
+4 SET LOC=$$GET1^DIQ(9999999.06,$PIECE(^AUTTSITE(1,0),U),.32)
+5 SET UVID=LOC_$$LZERO(V,10)
+6 DO SET(.ARY,"PV1",0)
+7 DO SET(.ARY,1,1)
+8 DO SET(.ARY,$SELECT(EV="A01":"I",1:"O"),2,1)
+9 DO SET(.ARY,APCLDBID,3,1)
+10 DO SET(.ARY,NPI,7,1)
+11 DO SET(.ARY,"NPI",7,3)
+12 DO SET(.ARY,UVID,19,1)
+13 DO SET(.ARY,"VN",19,5)
+14 IF EV="A03"
Begin DoDot:1
+15 NEW DDSP,VER,DED
+16 SET DDSP="01"
+17 IF $$GET1^DIQ(2,P,.351,"I")
SET DDSP="20"
+18 SET VER=$ORDER(^AMERVSIT("AD",V,0))
+19 IF VER
Begin DoDot:2
+20 SET DED=$EXTRACT($$GET1^DIQ(9009080,VER,6.1),1)
+21 SET DDSP=$SELECT(DED="A":"09",DED="D":20,DED="E":20,1:"01")
End DoDot:2
+22 IF '$GET(VER)
Begin DoDot:2
+23 SET VER=$ORDER(^AUPNVER("AD",V,0))
+24 IF VER
Begin DoDot:3
+25 SET DED=$EXTRACT($$GET1^DIQ(9000010.29,VER,.11),1)
+26 SET DDSP=$SELECT(DED="A":"09",DED="D":20,DED="E":20,1:"01")
End DoDot:3
End DoDot:2
+27 DO SET(.ARY,DDSP,36)
End DoDot:1
+28 DO SET(.ARY,$$FMTHL7^XLFDT($$GET1^DIQ(9000010,V,.01,"I")),44)
+29 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+30 QUIT
+31 ;
PV2(V,PT) ;-- setup the PV2 segment
+1 ;this may need to be changed to look at the admitting dx in ADT
+2 IF '$GET(V)
QUIT
+3 ;N HVST,VINP,DXI,DX,DXE,IVDT,ADMT,EVDT
+4 ;find H visit here
+5 ;S IVDT=(9999999-$P($P(^AUPNVSIT(APCLDA,0),U),"."))
+6 ;S IVDT=IVDT_"."_$P($P(^AUPNVSIT(APCLDA,0),U),".",2)
+7 ;S EVDT=IVDT+2
+8 ;S HVST=$$FNDH(IVDT,EVDT,APCLPAT)
+9 ;Q:'HVST
+10 ;find the admit here and get admitting dx
+11 NEW HVST
+12 SET HVST=$GET(APCLINP)
+13 IF '$GET(HVST)
QUIT
+14 SET ADMT=$ORDER(^DGPM("AVST",PT,HVST,0))
+15 IF 'ADMT
QUIT
+16 SET VINP=$ORDER(^AUPNVINP("AD",HVST,0))
+17 IF $GET(VINP)
Begin DoDot:1
+18 SET DXI=$$GET1^DIQ(9000010.02,VINP,.12,"I")
+19 SET DX=$$GET1^DIQ(9000010.02,VINP,.12)
End DoDot:1
+20 IF '$GET(DXI)
SET DXI=$ORDER(^ICD9("AB",$PIECE($GET(^DGPM(ADMT,0)),U,10)_" ",0))
+21 IF $GET(DX)=""
SET DX=$$GET1^DIQ(405,ADMT,.1,"I")
+22 NEW ICDT,ICDATA
+23 SET ICDATA=$$ICDDX^APCLSILU(DX,VDATE)
+24 SET DX=$PIECE(ICDATA,U,2)
+25 SET DXE=$PIECE(ICDATA,U,4)
+26 ;get the icd type based on the code
SET ICDT=$PIECE(ICDATA,U,20)
+27 IF $PIECE(DX,".",2)=""
SET DX=$TRANSLATE(DX,".")
+28 DO SET(.ARY,"PV2",0)
+29 DO SET(.ARY,DX,3,1)
+30 DO SET(.ARY,$GET(DXE),3,2)
+31 ;D SET(.ARY,"I9CDX",3,3)
+32 ;p30
DO SET(.ARY,$SELECT(ICDT="30":"I10",1:"I9CDX"),3,3)
+33 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+34 QUIT
+35 ;
FNDH(VDT,EDT,P) ;-- find the next H visit within 48 hours
+1 NEW VDA,VIN
+2 SET VDA=VDT
FOR
SET VDA=$ORDER(^AUPNVSIT("AAH",P,VDA))
IF 'VDA
QUIT
Begin DoDot:1
+3 SET VIEN=0
FOR
SET VIEN=$ORDER(^AUPNVSIT("AAH",P,VDA,VIEN))
IF 'VIEN
QUIT
Begin DoDot:2
+4 IF VDA<EDT
SET VIN=VIEN
QUIT
End DoDot:2
End DoDot:1
+5 QUIT $GET(VIN)
+6 ;
OBXLOC(V,CNT) ;-- setup the location OBX
+1 NEW CL,CLC,CD,DSC
+2 SET CL=$PIECE($GET(^AUPNVSIT(V,0)),U,8)
+3 SET CLC=$$GET1^DIQ(40.7,CL,1)
+4 SET CD=""
+5 ;we will need to do a more dynamic clinic map here
+6 ;urgent care
IF CLC=80
SET CD="261QU0200X"
+7 ;er
IF CLC=30
SET CD="261QE0002X"
+8 IF CD=""
QUIT
+9 SET DSC=$$LOOKTABM("","NUCC",CD,HLECH)
+10 DO SET(.ARY,"OBX",0)
+11 DO SET(.ARY,CNT,1)
+12 DO SET(.ARY,"CWE",2)
+13 ;this may need to change as well
DO SET(.ARY,"SS003",3,1)
+14 DO SET(.ARY,"PHINQUESTION",3,3)
+15 DO SET(.ARY,CD,5,1)
+16 DO SET(.ARY,$PIECE(DSC,HLECH,2),5,2)
+17 DO SET(.ARY,"NUCC",5,3)
+18 DO SET(.ARY,"F",11)
+19 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+20 QUIT
+21 ;
OBXUNIT(P,V,CNT) ;-- setup units
+1 ;this will need to change once we identify what an unknown patient is
IF $PIECE($GET(^DPT(P,0)),U)'["UNKNOWN"
QUIT
+2 ;Q:$$GET1^DIQ(40.7,$P($G(^AUPNVSIT(V,0)),U,8),1)=80
+3 DO SET(.ARY,"OBX",0)
+4 DO SET(.ARY,CNT,1)
+5 DO SET(.ARY,"NM",2)
+6 DO SET(.ARY,"21612-7",3,1)
+7 DO SET(.ARY,"LN",3,3)
+8 DO SET(.ARY,"UNK",6,1)
+9 DO SET(.ARY,"NULLFL",6,3)
+10 DO SET(.ARY,"F",11)
+11 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+12 QUIT
+13 ;
OBXAGE(P,V,CNT) ;-- setup the visit OBX
+1 ;Q:$$GET1^DIQ(40.7,$P($G(^AUPNVSIT(V,0)),U,8),1)=30
+2 NEW AGE,UNIT
+3 SET AGE=$$AGE^AUPNPAT(P,DT,"D")
+4 SET UNIT=$SELECT($PIECE(AGE," ",2)="YRS":"Year",$PIECE(AGE," ",2)="MOS":"Month",1:"Day")
+5 DO SET(.ARY,"OBX",0)
+6 DO SET(.ARY,CNT,1)
+7 DO SET(.ARY,"NM",2)
+8 DO SET(.ARY,"21612-7",3,1)
+9 DO SET(.ARY,"LN",3,3)
+10 DO SET(.ARY,$PIECE(AGE," "),5)
+11 DO SET(.ARY,"a",6,1)
+12 DO SET(.ARY,UNIT,6,2)
+13 DO SET(.ARY,"UCUM",6,3)
+14 DO SET(.ARY,"F",11)
+15 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+16 QUIT
+17 ;
OBXCC(V,CNT) ;-- setup the chief complaint OBX
+1 NEW LN,CCI,CC,EC,ECE,ECI,VPOVI,CCE
+2 ;look here in V NARRATIVE TEXT first
+3 ;S VPOVI=$O(^AUPNVPOV("AD",V,0))
+4 ;S CCI=$$GET1^DIQ(9000010,V,1107,"I")
+5 ;S CC=$$GET1^DIQ(80,$$GET1^DIQ(9000010.07,VPOVI,.01,"I"),3)
+6 ;S LN=$$GET1^DIQ(9000010,V,1401)
+7 NEW CDA,TDA,CCE,ICDT,ICDATA
+8 SET CCE=""
+9 SET CDA=0
FOR
SET CDA=$ORDER(^AUPNVNT("AD",V,CDA))
IF 'CDA
QUIT
Begin DoDot:1
+10 IF $$GET1^DIQ(9000010.34,CDA,.01)'="CHIEF COMPLAINT"
QUIT
+11 SET TDA=0
FOR
SET TDA=$ORDER(^AUPNVNT(CDA,11,TDA))
IF 'TDA
QUIT
Begin DoDot:2
+12 SET CCE=CCE_$GET(^AUPNVNT(CDA,11,TDA,0))_" "
End DoDot:2
End DoDot:1
+13 IF CCE=""
SET CCE=$$GET1^DIQ(9000010,V,1401)
+14 IF CCE=""
SET CCE=$$GET1^DIQ(9000010,V,1107)
+15 IF $GET(CCE)=""
QUIT
+16 IF $GET(CCE)]""
SET CCI=$ORDER(^ICD9("AB",CCE_" ",0))
+17 IF $GET(CCI)
SET CC=$$GET1^DIQ(80,CCI,3)
+18 ;S ECI=$$GET1^DIQ(9000010.07,VPOVI,.09,"I")
+19 IF $GET(CCI)
Begin DoDot:1
+20 SET ICDATA=$$ICDDX^APCLSILU($$GET1^DIQ(80,CCI,.01),VDATE)
+21 ;get the icd type based on the code
SET ICDT=$PIECE(ICDATA,U,20)
+22 SET EC=$PIECE(ICDATA,U,2)
+23 SET ECE=$PIECE(ICDATA,U,4)
End DoDot:1
+24 DO SET(.ARY,"OBX",0)
+25 DO SET(.ARY,CNT,1)
+26 DO SET(.ARY,"CWE",2)
+27 ;this is the chief complaint loinc code
DO SET(.ARY,"8661-1",3,1)
+28 IF $GET(CCI)
Begin DoDot:1
+29 DO SET(.ARY,EC,5,1)
+30 DO SET(.ARY,ECE,5,2)
+31 DO SET(.ARY,$SELECT(ICDT="30":"I10",1:"I9CDX"),5,3)
End DoDot:1
+32 DO SET(.ARY,"LN",3,3)
+33 DO SET(.ARY,$GET(CCE),5,9)
+34 DO SET(.ARY,"F",11)
+35 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+36 QUIT
+37 ;
DG1P(EV,V,FL) ;-- set the repeating DG1
+1 IF 'FL
IF EV="A03"
QUIT
+2 ;IN pv2
IF EV="A01"
QUIT
+3 ;Q:EV'="A04"!EV'="A08"
+4 NEW DX,DXE,DXT,DIEN,ECOD1,ECOD2,ECOD3
+5 SET DXT=$SELECT($GET(FL):"F",1:"W")
+6 IF EV="A08"
SET DXT="W"
+7 IF EV="A04"
SET DXT="W"
+8 ;S DX=$TR($$PRIMPOV^APCLV(V,"C"),".")
+9 SET DIEN=$$PRIMPOV^APCLV(V,5)
+10 SET DX=$$PRIMPOV^APCLV(V,"C")
+11 NEW ICDT,ICDATA
+12 SET ICDATA=$$ICDDX^APCLSILU(DX,VDATE)
+13 ;get the icd type based on the code
SET ICDT=$PIECE(ICDATA,U,20)
+14 IF $PIECE(DX,".",2)=""
SET DX=$TRANSLATE(DX,".")
+15 ;S LEN=$L(DX)
+16 ;I $E(DX,LEN,LEN)="0" S DX=$E(DX,1,(LEN-1))
+17 IF $GET(DX)=""
QUIT
+18 IF $PIECE(DX,".",2)=""
SET DX=$TRANSLATE(DX,".")
+19 SET DXE=$SELECT(ICDT=30:$PIECE(ICDATA,U,4),1:$PIECE($$PRIMPOV^APCLV(V,"E"),"|"))
+20 DO SET(.ARY,"DG1",0)
+21 DO SET(.ARY,1,1)
+22 DO SET(.ARY,DX,3,1)
+23 DO SET(.ARY,DXE,3,2)
+24 ;p30
DO SET(.ARY,$SELECT(ICDT="30":"I10",1:"I9CDX"),3,3)
+25 DO SET(.ARY,DXT,6)
+26 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+27 IF '$GET(DIEN)
QUIT
+28 SET ECOD1=$$GET1^DIQ(9000010.07,DIEN,.09,"I")
+29 SET ECOD2=$$GET1^DIQ(9000010.07,DIEN,.18,"I")
+30 SET ECOD3=$$GET1^DIQ(9000010.07,DIEN,.19,"I")
+31 IF $GET(ECOD1)
DO ECOD(ECOD1,DXT)
+32 IF $GET(ECOD2)
DO ECOD(ECOD2,DXT)
+33 IF $GET(ECOD3)
DO ECOD(ECOD3,DXT)
+34 QUIT
+35 ;
FNDPPOV(VS) ;--find ien of primary pov
+1 NEW PDA,PV
+2 SET PV=""
+3 SET PDA=0
FOR
SET PDA=$ORDER(^AUPNVPOV("AD",VS,PDA))
IF 'PDA
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^AUPNVPOV(PDA,0)),U,12)="P"
SET PV=PDA
End DoDot:1
+5 QUIT PV
+6 ;
DG1S(EV,V) ;-- set the secondary DXs
+1 NEW DX,DXE,DXT,DXDA,DXI,DXCNT,LEN,CNTR,ECOD1,ECOD2,ECOD3
+2 SET DXCNT=0
SET CNTR=0
+3 SET CNTR=$$POVS(V)
+4 IF CNTR=1
DO DG1P(EV,V,1)
QUIT
+5 SET DXDA=0
FOR
SET DXDA=$ORDER(^AUPNVPOV("AD",V,DXDA))
IF 'DXDA
QUIT
Begin DoDot:1
+6 ;Q:$P($G(^AUPNVPOV(DXDA,0)),U,12)="P"
+7 SET DXCNT=DXCNT+1
+8 ;Q:DXCNT=1
+9 SET DXI=$PIECE($GET(^AUPNVPOV(DXDA,0)),U)
+10 ;S DX=$TR($$GET1^DIQ(80,DXI,.01),".")
+11 SET DX=$$GET1^DIQ(80,DXI,.01)
+12 NEW ICDT,ICDATA
+13 SET ICDATA=$$ICDDX^APCLSILU(DX,VDATE)
+14 ;get the icd type based on the code
SET ICDT=$PIECE(ICDATA,U,20)
+15 IF $PIECE(DX,".",2)=""
SET DX=$TRANSLATE(DX,".")
+16 ;S LEN=$L(DX)
+17 ;I $E(DX,LEN,LEN)="0" S DX=$E(DX,1,(LEN-1))
+18 SET DXE=$SELECT(ICDT=30:$PIECE(ICDATA,U,4),1:$$GET1^DIQ(80,DXI,3))
+19 ;change this once i know the formula
SET DXT="F"
+20 IF EV="A08"
SET DXT="W"
+21 IF EV="A04"
SET DXT="W"
+22 IF $GET(DX)=""
QUIT
+23 DO SET(.ARY,"DG1",0)
+24 DO SET(.ARY,DXCNT,1)
+25 ;D SET(.ARY,(DXCNT-1),1)
+26 DO SET(.ARY,DX,3,1)
+27 DO SET(.ARY,DXE,3,2)
+28 DO SET(.ARY,$SELECT(ICDT="30":"I10",1:"I9CDX"),3,3)
+29 DO SET(.ARY,DXT,6)
+30 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+31 SET ECOD1=$$GET1^DIQ(9000010.07,DXDA,.09,"I")
+32 SET ECOD2=$$GET1^DIQ(9000010.07,DXDA,.18,"I")
+33 SET ECOD3=$$GET1^DIQ(9000010.07,DXDA,.19,"I")
+34 IF $GET(ECOD1)
DO ECOD(ECOD1,DXT)
+35 IF $GET(ECOD2)
DO ECOD(ECOD2,DXT)
+36 IF $GET(ECOD3)
DO ECOD(ECOD3,DXT)
End DoDot:1
+37 QUIT
+38 ;
ECOD(EDXI,EDXT) ;-- populate the DG1 segment with Ecodes
+1 NEW ICDT,ICDATA,EDX,EDXE
+2 IF '$GET(DXCNT)
SET DXCNT=1
+3 SET DXCNT=DXCNT+1
+4 SET EDX=$$GET1^DIQ(80,EDXI,.01)
+5 IF $GET(EDXT)=""
SET EDXT="W"
+6 SET ICDATA=$$ICDDX^APCLSILU(EDX,VDATE)
+7 ;get the icd type based on the code
SET ICDT=$PIECE(ICDATA,U,20)
+8 IF $PIECE(EDX,".",2)=""
SET EDX=$TRANSLATE(EDX,".")
+9 SET EDXE=$SELECT(ICDT=30:$PIECE(ICDATA,U,4),1:$$GET1^DIQ(80,EDXI,3))
+10 IF $GET(EDX)=""
QUIT
+11 DO SET(.ARY,"DG1",0)
+12 DO SET(.ARY,DXCNT,1)
+13 DO SET(.ARY,EDX,3,1)
+14 DO SET(.ARY,EDXE,3,2)
+15 DO SET(.ARY,$SELECT(ICDT="30":"I10",1:"I9CDX"),3,3)
+16 DO SET(.ARY,EDXT,6)
+17 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+18 QUIT
+19 ;
POVS(V) ;-- count the POVs
+1 NEW DXDA,CN
+2 SET CN=0
+3 SET DXDA=0
FOR
SET DXDA=$ORDER(^AUPNVPOV("AD",V,DXDA))
IF 'DXDA
QUIT
Begin DoDot:1
+4 SET CN=CN+1
End DoDot:1
+5 QUIT $GET(CN)
+6 ;
LOOKTABM(TYPE,TAB,VAL,ECH) ;-- find the value and description in the HL7 tables
+1 NEW DESC,IENI,GBL
+2 SET GBL="^APCLMUT"
+3 IF TYPE=""
SET GBL="^APCLMUT"
+4 SET IENI=$ORDER(@GBL@("AVAL",TAB,VAL,0))
+5 IF 'IENI
QUIT
+6 SET DESC=$PIECE($GET(@GBL@(IENI,0)),U,3)
+7 QUIT VAL_ECH_DESC_ECH_TYPE_TAB
+8 ;
LOOKTAB(TYPE,TAB,VAL,ECH) ;-- find the value and description in the HL7 tables
+1 NEW DESC,IENI,GBL
+2 SET GBL="^BHLTBL"
+3 IF TYPE=""
SET GBL="^BHLOTBL"
+4 SET IENI=$ORDER(@GBL@("AVAL",TAB,VAL,0))
+5 IF 'IENI
QUIT
+6 SET DESC=$PIECE($GET(@GBL@(IENI,0)),U,3)
+7 QUIT VAL_ECH_DESC_ECH_TYPE_TAB
+8 ;
LZERO(V,L) ;EP - left zero fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V="0"_V
+3 QUIT V
+4 ;
LOOKDSC(TYPE,TAB,DSC,ECH) ;-- find a reverse value based on description
+1 NEW VAL,IENI,GBL
+2 SET GBL="^BHLOTBL"
+3 IF TYPE=""
SET GBL="^BHLOTBL"
+4 SET IENI=$ORDER(@GBL@("ADSC",TAB,DSC,0))
+5 IF 'IENI
QUIT
+6 SET VAL=$PIECE($GET(@GBL@(IENI,0)),U,2)
+7 QUIT VAL_ECH_ECH_TYPE_TAB
+8 ;
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 NEW D
+3 SET %DT="X"
+4 SET X=FDT
DO ^%DT
+5 SET D=$$FMTHL7^XLFDT(Y)
+6 QUIT D
+7 ;
GL2(IN) ;-- 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 SETGL2(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 SETGL2(MSH)
+17 DO REST2(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 WRITE2
+21 QUIT
+22 ;
REST2(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 ;
SETGL2(D) ;-- set the temp global
+1 SET APCLCNT=APCLCNT+1
+2 SET ^APCLTMP($JOB,APCLCNT)=D
+3 QUIT
+4 ;
WRITE2 ; use XBGSAVE to save the temp global (APCLDATA) to a delimited
+1 NEW XBGL,XBQ,XBQTO,XBNAR,XBMED,XBFLT,XBUF,XBFN,APCLFN
+2 NEW TST
+3 SET TST=0
+4 IF $PIECE($GET(^APCLILIC(1,0)),U,5)="T"
SET TST=1
+5 SET XBGL="APCLTMP"
SET XBMED="F"
SET XBQ="N"
SET XBFLT=1
SET XBF=$JOB
SET XBE=$JOB
+6 SET XBNAR="MU2 SURVEILLANCE HL7 EXPORT"
+7 SET APCLASU=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0)),U,10)
+8 ;is this a test system?
+9 SET (XBFN,APCLDFN)=$SELECT($GET(TST):"MU2Z",1:"MU2")_"_"_APCLASU_"_"_$$DATE(DT)_"_P30.txt"
+10 SET XBS1="MU2 SURVEILLANCE SEND"
+11 ;
+12 DO ^XBGSAVE
+13 ;
+14 IF XBFLG'=0
Begin DoDot:1
+15 IF XBFLG(1)=""
IF '$DATA(ZTQUEUED)
WRITE !!," HL7 file successfully created",!!
+16 IF XBFLG(1)]""
IF '$DATA(ZTQUEUED)
WRITE !!," 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 KILL ^APCLTMP($JOB),APCLCNT
+20 QUIT
+21 ;
GL(IN,EV,PT,VDD) ;-- write out the batch to a global for saving in APCLSLAB
+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 DO REST(MSG)
+6 DO WRITE(EV,PT,VDD)
+7 QUIT
+8 ;
REST(M) ;-- 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,1,MDA))
IF 'MDA
QUIT
Begin DoDot:1
+4 SET DATA=$GET(^HLA(M,1,MDA,0))
+5 IF DATA=""
QUIT
+6 IF $EXTRACT(DATA,1,3)="NSH"
Begin DoDot:2
+7 SET $EXTRACT(DATA,1,4)="MSH"
+8 SET $PIECE(DATA,HLFS,2)="^~\&"
End DoDot:2
+9 DO SETGL(DATA)
End DoDot:1
+10 QUIT
+11 ;
SETGL(D) ;-- set the temp global
+1 SET APCLCNT=APCLCNT+1
+2 SET ^APCLTMP($JOB,APCLCNT)=D
+3 QUIT
+4 ;
WRITE(E,P,VD) ; use XBGSAVE to save the temp global (APCLDATA) to a delimited
+1 ; file that is exported to the IE system
+2 NEW XBGL,XBQ,XBQTO,XBNAR,XBMED,XBFLT,XBUF,XBFN,APCLFN
+3 SET XBGL="APCLTMP"
SET XBMED="F"
SET XBQ="N"
SET XBFLT=1
SET XBF=$JOB
SET XBE=$JOB
+4 SET XBNAR="MU2 HL7 EXPORT"
+5 ;asufac for file name
SET APCLASU=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0)),U,10)
+6 SET (XBFN,APCLDFN)="MU2_"_E_"_"_$$HRN^AUPNPAT(P,DUZ(2))_"_"_$$DATET(VD)_".txt"
+7 SET XBS1="SURVEILLANCE MU2 SEND"
+8 ;
+9 DO ^XBGSAVE
+10 ;
+11 IF XBFLG'=0
Begin DoDot:1
+12 IF XBFLG(1)=""
IF '$DATA(ZTQUEUED)
WRITE !!,"MU2 HL7 file successfully created",!!
+13 IF XBFLG(1)]""
IF '$DATA(ZTQUEUED)
WRITE !!,"MU2 HL7 file NOT successfully created",!!
End DoDot:1
+14 KILL ^APCLTMP($JOB),APCLCNT
+15 KILL ^APCLDATA($JOB)
+16 QUIT
DATE(D) ;EP
+1 QUIT (1700+$EXTRACT(D,1,3))_$EXTRACT(D,4,5)_$EXTRACT(D,6,7)
+2 ;
DATET(D) ;EP
+1 QUIT (1700+$EXTRACT(D,1,3))_$EXTRACT(D,4,5)_$EXTRACT(D,6,7)_$EXTRACT(D,8,11)
+2 ;
EOJ ; EP - EOJ HOUSE KEEPING - this ep called by the BVP package (View patient record)
+1 KILL AUPNLK("INAC")
+2 KILL %,%DT,%X,%Y,C,DIYS,X,Y
+3 KILL APCDCLN,APCDCAT,APCDDATE,APCDLOC,APCDPAT,APCDVSIT,APCDLOOK,APCDTYPE
+4 DO KILL^AUPNPAT
+5 QUIT
+6 ;
