APCLSMU ;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^APCLSMUN 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
;
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(EVN,VST,PAT) ;EP - create the message based on the event type and visit
N VDATE,UNITFLG
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 '$$NEWMSG^HLOAPI(.HLPM,.HLST,.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)
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
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,"1231231234",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,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
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 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,REC,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)
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
D SET(.ARY,"PV1",0)
D SET(.ARY,1,1)
D SET(.ARY,V,19,1)
D SET(.ARY,"VN",19,5)
I EV="A03" D
. N DDSP,VER
. S DDSP="01"
. I $$GET1^DIQ(2,P,.351,"I") S DDSP="20"
. ;S VER=$O(^AUPNVER("AD",V,0))
. S VER=$O(^AMERVSIT("AD",V,0))
. I VER D
.. N DED
.. ;S DED=$P($G(^AUPNVER(VER,0)),U,11)
.. S DED=$E($$GET1^DIQ(9009080,VER,6.1),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
;find H visit here
S IVDT=(9999999-$P(^AUPNVSIT(V,0),U))
S EVDT=IVDT+2
S HVST=$$FNDH(IVDT,EVDT,PT)
Q:'HVST
;find the admit here and get admitting dx
S ADMT=$O(^DGPM("AVST",PT,HVST,0))
Q:'ADMT
;S VINP=$O(^AUPNVINP("AD",HVST,0))
;Q:'VINP
;S DXI=$$GET1^DIQ(9000010.02,VINP,.12,"I")
;S DX=$$GET1^DIQ(9000010.02,VINP,.12)
S DXI=$O(^ICD9("AB",$P($G(^DGPM(ADMT,0)),U,10)_" ",0))
S DX=$$GET1^DIQ(405,ADMT,.1,"I")
I $G(DXI) S DXE=$$GET1^DIQ(80,DXI,3)
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,".")
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
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
S AGE=$$AGE^AUPNPAT(P)
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,AGE,5)
D SET(.ARY,"a",6,1)
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
;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)
S CCE=$$GET1^DIQ(9000010,V,1401)
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")
S EC=$$GET1^DIQ(80,CCI,.01)
S ECE=$$GET1^DIQ(80,CCI,3)
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,"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
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 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
;
DG1S(EV,V) ;-- set the secondary DXs
N DX,DXE,DXT,DXDA,DXI,DXCNT,LEN,CNTR
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"
. 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)
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
;
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
;
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
;
APCLSMU ;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^APCLSMUN
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 ;
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(EVN,VST,PAT) ;EP - create the message based on the event type and visit
+1 NEW VDATE,UNITFLG
+2 SET VDATE=$PIECE($$GET1^DIQ(9000010,VST,.01,"I"),".")
+3 SET OBXCNT=0
SET DGCNT=0
+4 NEW LN,HL1,HRCN,FLD,LP,X,LN
+5 SET LN=0
+6 SET HLPM("MESSAGE TYPE")="ADT"
+7 SET HLPM("EVENT")=EVN
+8 SET HLPM("VERSION")="2.5.1"
+9 IF '$$NEWMSG^HLOAPI(.HLPM,.HLST,.ERR)
Begin DoDot:1
+10 WRITE !,"Unable to create message"
QUIT
End DoDot:1
QUIT
+11 SET HLFS=HLPM("FIELD SEPARATOR")
+12 SET HLECH=HLPM("ENCODING CHARACTERS")
+13 SET HL1("ECH")=HLECH
+14 SET HL1("FS")=HLFS
+15 SET HL1("Q")=""
+16 SET HL1("VER")=HLPM("VERSION")
+17 DO MSH("ADT",EVN)
+18 DO EVN(EVN)
+19 DO PID(PAT)
+20 DO PV1(EVN,VST,PAT)
+21 IF EVN="A01"
DO PV2(VST,PAT)
+22 IF (EVN="A03")
Begin DoDot:1
+23 SET DGCNT=DGCNT+1
+24 DO DG1S(EVN,VST)
End DoDot:1
+25 SET OBXCNT=OBXCNT+1
+26 DO OBXLOC(VST,OBXCNT)
+27 SET UNITFLG=0
+28 ;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
+29 ;Q:'$$GET1^DIQ(9000010,VST,1601)
+30 IF $PIECE($GET(^DPT(PAT,0)),U)'["UNKNOWN"
QUIT
+31 ;Q:$P($G(^DPT(PAT,0)),U,2)'="U" ;ihs/cmi/maw lets use this if they have an UNKNOWN sex
+32 SET OBXCNT=OBXCNT+1
+33 SET UNITFLG=1
+34 DO OBXUNIT(PAT,VST,OBXCNT)
End DoDot:1
+35 IF '$GET(UNITFLG)
Begin DoDot:1
+36 SET OBXCNT=OBXCNT+1
+37 DO OBXAGE(PAT,VST,OBXCNT)
End DoDot:1
+38 SET OBXCNT=OBXCNT+1
+39 DO OBXCC(VST,OBXCNT)
+40 IF EVN'="A03"
Begin DoDot:1
+41 ;D DG1P(EVN,VST,0)
+42 IF EVN="A01"
QUIT
+43 ;for multiple DX in A08 and primary in A04
DO DG1S(EVN,VST)
End DoDot:1
+44 SET APPARMS("SENDING APPLICATION")="RPMS-ILI"
+45 SET APPARMS("RECEIVING APPLICATION")="ILI"
+46 ;Commit ACK type
SET APPARMS("ACCEPT ACK TYPE")="AL"
+47 ;Callback when 'application ACK' is received
SET APPARMS("APP ACK RESPONSE")="AACK^APCLSHL"
+48 ;Callback when 'commit ACK' is received
SET APPARMS("ACCEPT ACK RESPONSE")="CACK^APCLSHL"
+49 ;Application ACK type
SET APPARMS("APP ACK TYPE")="AL"
+50 ;Incoming QUEUE
SET APPARMS("QUEUE")="ILI ADT"
+51 SET WHO("RECEIVING APPLICATION")="ILI"
+52 SET WHO("FACILITY LINK NAME")="IHS"
+53 SET WHOTO("RECEIVING APPLICATION")="ILI"
+54 IF '$$SENDONE^HLOAPI1(.HLST,.APPARMS,.WHO,.ERR)
Begin DoDot:1
+55 SET ERR=$GET(ERR)
End DoDot:1
+56 DO GL(HLST("IEN"),EVN,PAT,VDATE)
+57 KILL OBXCNT
+58 QUIT
+59 ;
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,"1231231234",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,X,2)
+6 DO SET(.ARY,"RPMS",7,1)
+7 DO SET(.ARY,1231231234,7,2)
+8 DO SET(.ARY,"NPI",7,3)
+9 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+10 QUIT
+11 ; 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
+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 SEX=$PIECE($GET(^DPT(P,0)),U,2)
+6 SET DOB=$$FMTHL7^XLFDT($$GET1^DIQ(2,P,.03,"I"))
+7 SET RACEI=$PIECE($GET(^DPT(P,0)),U,6)
+8 IF '$GET(RACEI)
SET RACEI=$ORDER(^DPT(P,.02,0))
+9 SET RACE=$$GET1^DIQ(10,RACEI,4)
+10 SET ADD=$$GET1^DIQ(2,P,.111)
+11 SET ADD2=$$GET1^DIQ(2,P,.112)
+12 SET CITY=$$GET1^DIQ(2,P,.114)
+13 SET STI=$$GET1^DIQ(2,P,.115,"I")
+14 SET STATE=$SELECT(STI]"":$PIECE($GET(^DIC(5,STI,0)),U,3),1:"")
+15 SET ZIP=$$GET1^DIQ(2,P,.116)
+16 SET CNTY=$$GET1^DIQ(2,P,.117)
+17 IF CNTY=""
Begin DoDot:1
+18 NEW COR,CTY
+19 SET COR=$$GET1^DIQ(9000001,P,1117,"I")
+20 SET CTY=$SELECT(COR:$$GET1^DIQ(9999999.05,COR,.02,"I"),1:"")
+21 IF CTY
SET CNTY=$$GET1^DIQ(9999999.23,CTY,.04)
End DoDot:1
+22 SET EDA=$ORDER(^DPT(P,.06,"B",0))
+23 IF EDA
SET ETHI=$PIECE($GET(^DPT(P,.06,EDA,0)),U)
+24 IF $GET(ETHI)
SET ETH=$$GET1^DIQ(10.2,ETHI,4)
+25 SET DOD=$$GET1^DIQ(2,P,.351,"I")
+26 IF DOD]""
SET DOD=$$FMTHL7^XLFDT(DOD)
+27 DO SET(.ARY,"PID",0)
+28 DO SET(.ARY,1,1)
+29 DO SET(.ARY,REC,3,1)
+30 ; Patient HRN
DO SET(.ARY,"MR",3,5)
+31 ;this needs to be determined
DO SET(.ARY,$SELECT(NTYP]"":NTYP,1:"S"),5,7,,2)
+32 ;D SET(.ARY,DOB,7)
+33 DO SET(.ARY,SEX,8)
+34 DO SET(.ARY,RACE,10,1)
+35 IF $GET(RACE)]""
DO SET(.ARY,"CDCREC",10,3)
+36 DO SET(.ARY,ADD,11,1)
+37 DO SET(.ARY,ADD2,11,2)
+38 DO SET(.ARY,CITY,11,3)
+39 DO SET(.ARY,STATE,11,4)
+40 DO SET(.ARY,ZIP,11,5)
+41 DO SET(.ARY,CNTY,11,9)
+42 DO SET(.ARY,$GET(ETH),22,1)
+43 IF $GET(ETH)]""
DO SET(.ARY,"CDCREC",22,3)
+44 IF EVN="A03"
Begin DoDot:1
+45 DO SET(.ARY,DOD,29)
+46 IF DOD]""
DO SET(.ARY,"Y",30)
End DoDot:1
+47 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+48 QUIT
+49 ;
PV1(EV,V,P) ;-- setup the JVN PV1 segment
+1 DO SET(.ARY,"PV1",0)
+2 DO SET(.ARY,1,1)
+3 DO SET(.ARY,V,19,1)
+4 DO SET(.ARY,"VN",19,5)
+5 IF EV="A03"
Begin DoDot:1
+6 NEW DDSP,VER
+7 SET DDSP="01"
+8 IF $$GET1^DIQ(2,P,.351,"I")
SET DDSP="20"
+9 ;S VER=$O(^AUPNVER("AD",V,0))
+10 SET VER=$ORDER(^AMERVSIT("AD",V,0))
+11 IF VER
Begin DoDot:2
+12 NEW DED
+13 ;S DED=$P($G(^AUPNVER(VER,0)),U,11)
+14 SET DED=$EXTRACT($$GET1^DIQ(9009080,VER,6.1),1)
+15 SET DDSP=$SELECT(DED="A":"09",DED="D":20,DED="E":20,1:"01")
End DoDot:2
+16 DO SET(.ARY,DDSP,36)
End DoDot:1
+17 DO SET(.ARY,$$FMTHL7^XLFDT($$GET1^DIQ(9000010,V,.01,"I")),44)
+18 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+19 QUIT
+20 ;
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 NEW HVST,VINP,DXI,DX,DXE,IVDT,ADMT
+4 ;find H visit here
+5 SET IVDT=(9999999-$PIECE(^AUPNVSIT(V,0),U))
+6 SET EVDT=IVDT+2
+7 SET HVST=$$FNDH(IVDT,EVDT,PT)
+8 IF 'HVST
QUIT
+9 ;find the admit here and get admitting dx
+10 SET ADMT=$ORDER(^DGPM("AVST",PT,HVST,0))
+11 IF 'ADMT
QUIT
+12 ;S VINP=$O(^AUPNVINP("AD",HVST,0))
+13 ;Q:'VINP
+14 ;S DXI=$$GET1^DIQ(9000010.02,VINP,.12,"I")
+15 ;S DX=$$GET1^DIQ(9000010.02,VINP,.12)
+16 SET DXI=$ORDER(^ICD9("AB",$PIECE($GET(^DGPM(ADMT,0)),U,10)_" ",0))
+17 SET DX=$$GET1^DIQ(405,ADMT,.1,"I")
+18 IF $GET(DXI)
SET DXE=$$GET1^DIQ(80,DXI,3)
+19 NEW ICDT,ICDATA
+20 SET ICDATA=$$ICDDX^APCLSILU(DX,VDATE)
+21 ;get the icd type based on the code
SET ICDT=$PIECE(ICDATA,U,20)
+22 IF $PIECE(DX,".",2)=""
SET DX=$TRANSLATE(DX,".")
+23 DO SET(.ARY,"PV2",0)
+24 DO SET(.ARY,DX,3,1)
+25 DO SET(.ARY,$GET(DXE),3,2)
+26 ;D SET(.ARY,"I9CDX",3,3)
+27 ;p30
DO SET(.ARY,$SELECT(ICDT="30":"I10",1:"I9CDX"),3,3)
+28 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+29 QUIT
+30 ;
FNDH(VDT,EDT,P) ;-- find the next H visit within 48 hours
+1 NEW VDA
+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
+3 SET AGE=$$AGE^AUPNPAT(P)
+4 DO SET(.ARY,"OBX",0)
+5 DO SET(.ARY,CNT,1)
+6 DO SET(.ARY,"NM",2)
+7 DO SET(.ARY,"21612-7",3,1)
+8 DO SET(.ARY,"LN",3,3)
+9 DO SET(.ARY,AGE,5)
+10 DO SET(.ARY,"a",6,1)
+11 DO SET(.ARY,"UCUM",6,3)
+12 DO SET(.ARY,"F",11)
+13 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+14 QUIT
+15 ;
OBXCC(V,CNT) ;-- setup the chief complaint OBX
+1 NEW LN,CCI,CC,EC,ECE,ECI,VPOVI,CCE
+2 ;S VPOVI=$O(^AUPNVPOV("AD",V,0))
+3 ;S CCI=$$GET1^DIQ(9000010,V,1107,"I")
+4 ;S CC=$$GET1^DIQ(80,$$GET1^DIQ(9000010.07,VPOVI,.01,"I"),3)
+5 ;S LN=$$GET1^DIQ(9000010,V,1401)
+6 SET CCE=$$GET1^DIQ(9000010,V,1401)
+7 IF $GET(CCE)=""
QUIT
+8 IF $GET(CCE)]""
SET CCI=$ORDER(^ICD9("AB",CCE_" ",0))
+9 IF $GET(CCI)
SET CC=$$GET1^DIQ(80,CCI,3)
+10 ;S ECI=$$GET1^DIQ(9000010.07,VPOVI,.09,"I")
+11 SET EC=$$GET1^DIQ(80,CCI,.01)
+12 SET ECE=$$GET1^DIQ(80,CCI,3)
+13 DO SET(.ARY,"OBX",0)
+14 DO SET(.ARY,CNT,1)
+15 DO SET(.ARY,"CWE",2)
+16 ;this is the chief complaint loinc code
DO SET(.ARY,"8661-1",3,1)
+17 IF $GET(CCI)
Begin DoDot:1
+18 DO SET(.ARY,EC,5,1)
+19 DO SET(.ARY,ECE,5,2)
+20 DO SET(.ARY,"I9CDX",5,3)
End DoDot:1
+21 DO SET(.ARY,"LN",3,3)
+22 DO SET(.ARY,$GET(CCE),5,9)
+23 DO SET(.ARY,"F",11)
+24 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+25 QUIT
+26 ;
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
+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 DX=$$PRIMPOV^APCLV(V,"C")
+10 NEW ICDT,ICDATA
+11 SET ICDATA=$$ICDDX^APCLSILU(DX,VDATE)
+12 ;get the icd type based on the code
SET ICDT=$PIECE(ICDATA,U,20)
+13 IF $PIECE(DX,".",2)=""
SET DX=$TRANSLATE(DX,".")
+14 ;S LEN=$L(DX)
+15 ;I $E(DX,LEN,LEN)="0" S DX=$E(DX,1,(LEN-1))
+16 IF $GET(DX)=""
QUIT
+17 IF $PIECE(DX,".",2)=""
SET DX=$TRANSLATE(DX,".")
+18 SET DXE=$SELECT(ICDT=30:$PIECE(ICDATA,U,4),1:$PIECE($$PRIMPOV^APCLV(V,"E"),"|"))
+19 DO SET(.ARY,"DG1",0)
+20 DO SET(.ARY,1,1)
+21 DO SET(.ARY,DX,3,1)
+22 DO SET(.ARY,DXE,3,2)
+23 ;p30
DO SET(.ARY,$SELECT(ICDT="30":"I10",1:"I9CDX"),3,3)
+24 DO SET(.ARY,DXT,6)
+25 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+26 QUIT
+27 ;
DG1S(EV,V) ;-- set the secondary DXs
+1 NEW DX,DXE,DXT,DXDA,DXI,DXCNT,LEN,CNTR
+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 DO SET(.ARY,"DG1",0)
+23 DO SET(.ARY,DXCNT,1)
+24 ;D SET(.ARY,(DXCNT-1),1)
+25 DO SET(.ARY,DX,3,1)
+26 DO SET(.ARY,DXE,3,2)
+27 DO SET(.ARY,$SELECT(ICDT="30":"I10",1:"I9CDX"),3,3)
+28 DO SET(.ARY,DXT,6)
+29 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
End DoDot:1
+30 QUIT
+31 ;
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 ;
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 ;
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 ;
