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

APCLSMU2.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. OPT ;EP - option to export via date range or patient
  1.  N TYPE
  1.  S TYPE=$$EXPTYP()
  1.  Q:TYPE=""
  1.  I TYPE="P" D PATEXP Q
  1.  I TYPE="D" D DATEXP Q
  1.  Q
  1.  ;
  1. EXPTYP() ;-- get the export type
  1.  S DIR(0)="S^P:One Patient's Visit;D:Date Range of Visits"
  1.  S DIR("A")="Export Type"
  1.  D ^DIR
  1.  I $D(DIRUT) Q ""
  1.  Q $G(Y)
  1.  ;
  1. PATEXP ;-- ask the patient and visit date
  1.  D GETPAT
  1.  I APCDPAT="" W !!,"No PATIENT selected!" D EOJ Q
  1.  D GETVISIT
  1.  I APCDVSIT="" W !!,"No VISIT selected!" D EOJ Q
  1.  F I="A04","A03","A08","A01" D MSG(I,APCDVSIT,APCDPAT)
  1.  Q
  1.  ;
  1. HL7 ;-- generate the HL7 file
  1.  D BATCH(.HLPARM)
  1.  S APCLDA=0 F  S APCLDA=$O(^XTMP("APCLMUSS",$J,APCLDA)) Q:'APCLDA  D
  1.  . N APCLRST,APCLINP
  1.  . S APCLVCNT=APCLVCNT+1
  1.  . S APCLRST=$P($G(^XTMP("APCLMUSS",$J,APCLDA)),U)
  1.  . S APCLINP=$P($G(^XTMP("APCLMUSS",$J,APCLDA)),U,2)
  1.  . S APCLSEVN=$S(APCLRST="A":"A04",APCLRST="D":"A11",1:"A08")
  1.  . S APCLPAT=$P($G(^AUPNVSIT(APCLDA,0)),U,5)
  1.  . Q:'APCLPAT
  1.  . D MSG(.HLMSTATE,.HLPARM,APCLSEVN,APCLDA,APCLPAT)
  1.  . N ER
  1.  . S ER=$O(^AMERVSIT("AD",APCLDA,0))
  1.  . I '$G(ER) S ER=$O(^AUPNVER("AD",APCLDA,0))
  1.  . I $G(ER) D MSG(.HLMSTATE,.HLPARM,"A03",APCLDA,APCLPAT)
  1.  . ;N IVDT,EVDT,HVST
  1.  . ;S IVDT=(9999999-$P($P(^AUPNVSIT(APCLDA,0),U),"."))
  1.  . ;S IVDT=IVDT_"."_$P($P(^AUPNVSIT(APCLDA,0),U),".",2)
  1.  . ;S EVDT=IVDT+2
  1.  . ;S HVST=$$FNDH(IVDT,EVDT,APCLPAT)
  1.  . I $G(APCLINP) D MSG(.HLMSTATE,.HLPARM,"A01",APCLDA,APCLPAT)
  1.  . D LOG^APCLSMUN(APCLLOG,APCLDA,APCLRST)
  1.  I $G(HLMSTATE("IEN")) D GL2(HLMSTATE("IEN"))
  1.  Q
  1.  ;
  1. BATCH(HLPARM) ;-- 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. DATEXP ;-- ask the date range
  1.  N BDT,EDT,DADA,DIEN,PAT
  1.  S %DT="AE",%DT("A")="Begin Date: "
  1.  D ^%DT
  1.  I Y<0 D EOJ Q
  1.  S BDT=+Y
  1.  S %DT="AE",%DT("A")="End Date: "
  1.  D ^%DT
  1.  I Y<0 D EOJ Q
  1.  S EDT=+Y
  1.  S DADA=BDT-.0001 F  S DADA=$O(^AUPNVSIT("B",DADA)) Q:DADA>(EDT+.9999)!'DADA  D
  1.  . S DIEN=0 F  S DIEN=$O(^AUPNVSIT("B",DADA,DIEN)) Q:'DIEN  D
  1.  .. S PAT=$P($G(^AUPNVSIT(DIEN,0)),U,5)
  1.  .. F I="A04","A03","A08","A01" D MSG(I,DIEN,PAT)
  1.  Q
  1.  ;
  1. GETPAT ;EP GET-  PATIENT
  1.  W !
  1.  S AUPNLK("INAC")=""
  1.  S APCDPAT=""
  1.  S DIC("A")="Enter PATIENT NAME: ",DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC
  1.  Q:Y<0
  1.  S APCDPAT=+Y
  1.  Q
  1.  ;
  1. GETVISIT ;EP - this entry point called by the BVP package (View patient record)
  1.  S APCDLOOK="",APCDVSIT=""
  1.  K APCDVLK
  1.  D ^APCDVLK
  1.  K APCDLOOK
  1.  Q
  1.  ;
  1. MSG(HLST,HLPM,EVN,VST,PAT) ;EP - create the message based on the event type and visit
  1.  N VDATE,UNITFLG
  1.  Q:'$G(VST)
  1.  S VDATE=$P($$GET1^DIQ(9000010,VST,.01,"I"),".")
  1.  S OBXCNT=0,DGCNT=0
  1.  N LN,HL1,HRCN,FLD,LP,X,LN
  1.  S LN=0
  1.  S HLPM("MESSAGE TYPE")="ADT"
  1.  S HLPM("EVENT")=EVN
  1.  S HLPM("VERSION")="2.5.1"
  1.  I '$$ADDMSG^HLOAPI(.HLST,.HLPM,.ERR) D  Q
  1.  .W !,"Unable to create message" Q
  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.  ;D MSH("ADT",EVN)
  1.  D EVN(EVN)
  1.  D PID(PAT)
  1.  D PV1(EVN,VST,PAT)
  1.  I EVN="A01" D PV2(VST,PAT)
  1.  I (EVN="A03") D
  1.  . S DGCNT=DGCNT+1
  1.  . D DG1S(EVN,VST)
  1.  . D ECOD(VST)
  1.  S OBXCNT=OBXCNT+1
  1.  D OBXLOC(VST,OBXCNT)
  1.  S UNITFLG=0
  1.  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
  1.  . ;Q:'$$GET1^DIQ(9000010,VST,1601)
  1.  . Q:$P($G(^DPT(PAT,0)),U)'["UNKNOWN"
  1.  . ;Q:$P($G(^DPT(PAT,0)),U,2)'="U"  ;ihs/cmi/maw lets use this if they have an UNKNOWN sex
  1.  . S OBXCNT=OBXCNT+1
  1.  . S UNITFLG=1
  1.  . D OBXUNIT(PAT,VST,OBXCNT)
  1.  I '$G(UNITFLG) D
  1.  . S OBXCNT=OBXCNT+1
  1.  . D OBXAGE(PAT,VST,OBXCNT)
  1.  S OBXCNT=OBXCNT+1
  1.  D OBXCC(VST,OBXCNT)
  1.  I EVN'="A03" D
  1.  . ;D DG1P(EVN,VST,0)
  1.  . Q:EVN="A01"
  1.  . D DG1S(EVN,VST)  ;for multiple DX in A08 and primary in A04
  1.  . D ECOD(VST)
  1.  S APPARMS("SENDING APPLICATION")="RPMS-ILI"
  1.  S APPARMS("RECEIVING APPLICATION")="ILI"
  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")="ILI"
  1.  S WHO("FACILITY LINK NAME")="IHS"
  1.  S WHOTO("RECEIVING APPLICATION")="ILI"
  1.  I '$$SENDONE^HLOAPI1(.HLST,.APPARMS,.WHO,.ERR) D
  1.  . S ERR=$G(ERR)
  1.  ;D GL(HLST("IEN"),EVN,PAT,VDATE)
  1.  K OBXCNT
  1.  Q
  1.  ;
  1. SETHL(MTYPE,EVNTTYPE) ;-- setup HLO variables
  1.  ;N HLPM,HLST,ARY,HLQ,APPARMS,HLPM,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 '$$NEWMSG^HLOAPI(.HLPM,.HLST,.ERR) D  Q
  1.  .;D NOTIF(DFN,"Unable to build HL7 message."_$S($D(ERR):" ERR:"_$G(ERR),1:""))
  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.  Q
  1.  ;
  1. ERR ;
  1.  Q
  1.  ;
  1.  ; Create MSH segment
  1. MSH(MS,EV) ;EP
  1.  N MSH,%,X,FLD,VAL
  1.  D NOW^%DTC
  1.  S X=$$HLDATE^HLFNC(%,"TS")
  1.  D SET(.ARY,"NSH",0)
  1.  D SET(.ARY,"RPMS",4,1)
  1.  D SET(.ARY,APCLDBID,4,2)  ;
  1.  D SET(.ARY,"NPI",4,3)
  1.  D SET(.ARY,X,7)
  1.  D SET(.ARY,MS,9,1)
  1.  D SET(.ARY,EV,9,2)
  1.  D SET(.ARY,MS_"_"_$S(EV="A04":"A01",EV="A08":"A01",1:EV),9,3)
  1.  D SET(.ARY,"IHS-"_$R(999999999),10)
  1.  D SET(.ARY,"P",11)
  1.  D SET(.ARY,"2.5.1",12)
  1.  D SET(.ARY,"PH_SS-NoAck",21,1)
  1.  D SET(.ARY,"SS Sender",21,2)
  1.  D SET(.ARY,"2.16.840.1.114222.4.10.3",21,3)
  1.  D SET(.ARY,"ISO",21,4)
  1.  S MSH=$$ADDSEG^HLOAPI(.HLST,.ARY)
  1.  Q
  1. EVN(EVNTTYPE) ;Create the EVN segment
  1.  N %,X,FLD,VAL
  1.  D NOW^%DTC
  1.  S X=$$HLDATE^HLFNC(%,"TS")
  1.  D SET(.ARY,"EVN",0)
  1.  D SET(.ARY,EVNTTYPE,1)
  1.  D SET(.ARY,X,2)
  1.  D SET(.ARY,"RPMS",7,1)
  1.  D SET(.ARY,1231231234,7,2)
  1.  D SET(.ARY,"NPI",7,3)
  1.  S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
  1.  Q
  1.  ; Create PID segment
  1. PID(P) ;EP
  1.  S HLQ=HL1("Q")
  1.  N REC,SEX,RACEI,RACE,ZIP,CNTY,EDA,ETH,ETHI,NTYP,DOD,ADD,CITY,STI,STATE,ADD2,DOB,UID
  1.  S NTYP=$S($P($G(^DPT(P,0)),U)["UNKNOWN":"U",1:"S")  ;this needs to be determined
  1.  S REC=$$HRN^AUPNPAT(P,DUZ(2))
  1.  S UID=$$GET1^DIQ(9999999.06,$P(^AUTTSITE(1,0),U),.32)_$E("0000000000",1,10-$L(P))_P
  1.  S SEX=$P($G(^DPT(P,0)),U,2)
  1.  S DOB=$$FMTHL7^XLFDT($$GET1^DIQ(2,P,.03,"I"))
  1.  S RACEI=$P($G(^DPT(P,0)),U,6)
  1.  I '$G(RACEI) S RACEI=$O(^DPT(P,.02,0))
  1.  S RACE=$$GET1^DIQ(10,RACEI,4)
  1.  S ADD=$$GET1^DIQ(2,P,.111)
  1.  S ADD2=$$GET1^DIQ(2,P,.112)
  1.  S CITY=$$GET1^DIQ(2,P,.114)
  1.  S STI=$$GET1^DIQ(2,P,.115,"I")
  1.  S STATE=$S(STI]"":$P($G(^DIC(5,STI,0)),U,3),1:"")
  1.  S ZIP=$$GET1^DIQ(2,P,.116)
  1.  S CNTY=$$GET1^DIQ(2,P,.117)
  1.  I CNTY="" D
  1.  . N COR,CTY
  1.  . S COR=$$GET1^DIQ(9000001,P,1117,"I")
  1.  . S CTY=$S(COR:$$GET1^DIQ(9999999.05,COR,.02,"I"),1:"")
  1.  . I CTY S CNTY=$$GET1^DIQ(9999999.23,CTY,.04)
  1.  S EDA=$O(^DPT(P,.06,"B",0))
  1.  I EDA S ETHI=$P($G(^DPT(P,.06,EDA,0)),U)
  1.  I $G(ETHI) S ETH=$$GET1^DIQ(10.2,ETHI,4)
  1.  S DOD=$$GET1^DIQ(2,P,.351,"I")
  1.  I DOD]"" S DOD=$$FMTHL7^XLFDT(DOD)
  1.  D SET(.ARY,"PID",0)
  1.  D SET(.ARY,1,1)
  1.  D SET(.ARY,UID,3,1)
  1.  D SET(.ARY,"MR",3,5)  ; Patient HRN
  1.  D SET(.ARY,$S(NTYP]"":NTYP,1:"S"),5,7,,2)  ;this needs to be determined
  1.  ;D SET(.ARY,DOB,7)
  1.  D SET(.ARY,SEX,8)
  1.  D SET(.ARY,RACE,10,1)
  1.  I $G(RACE)]"" D SET(.ARY,"CDCREC",10,3)
  1.  D SET(.ARY,ADD,11,1)
  1.  D SET(.ARY,ADD2,11,2)
  1.  D SET(.ARY,CITY,11,3)
  1.  D SET(.ARY,STATE,11,4)
  1.  D SET(.ARY,ZIP,11,5)
  1.  D SET(.ARY,CNTY,11,9)
  1.  D SET(.ARY,$G(ETH),22,1)
  1.  I $G(ETH)]"" D SET(.ARY,"CDCREC",22,3)
  1.  ;ihs/cmi/maw 04/8/2015 p30 do for all events
  1.  ;I EVN="A03" D
  1.  D SET(.ARY,DOD,29)
  1.  I DOD]"" D SET(.ARY,"Y",30)
  1.  S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
  1.  Q
  1.  ;
  1. PV1(EV,V,P) ;-- setup the JVN PV1 segment
  1.  N PRV,NPI,LOC,UVID
  1.  S PRV=$$PRIMPROV^APCLV(V,"I")
  1.  S NPI=$$GET1^DIQ(200,PRV,41.99)
  1.  S LOC=$$GET1^DIQ(9999999.06,$P(^AUTTSITE(1,0),U),.32)
  1.  S UVID=LOC_$$LZERO(V,10)
  1.  D SET(.ARY,"PV1",0)
  1.  D SET(.ARY,1,1)
  1.  D SET(.ARY,$S(EV="A01":"I",1:"O"),2,1)
  1.  D SET(.ARY,APCLDBID,3,1)
  1.  D SET(.ARY,NPI,7,1)
  1.  D SET(.ARY,"NPI",7,3) 
  1.  D SET(.ARY,UVID,19,1)
  1.  D SET(.ARY,"VN",19,5)
  1.  I EV="A03" D
  1.  . N DDSP,VER,DED
  1.  . S DDSP="01"
  1.  . I $$GET1^DIQ(2,P,.351,"I") S DDSP="20"
  1.  . S VER=$O(^AMERVSIT("AD",V,0))
  1.  . I VER D
  1.  .. S DED=$E($$GET1^DIQ(9009080,VER,6.1),1)
  1.  .. S DDSP=$S(DED="A":"09",DED="D":20,DED="E":20,1:"01")
  1.  . I '$G(VER) D
  1.  .. S VER=$O(^AUPNVER("AD",V,0))
  1.  .. I VER D
  1.  ... S DED=$E($$GET1^DIQ(9000010.29,VER,.11),1)
  1.  ... S DDSP=$S(DED="A":"09",DED="D":20,DED="E":20,1:"01")
  1.  . D SET(.ARY,DDSP,36)
  1.  D SET(.ARY,$$FMTHL7^XLFDT($$GET1^DIQ(9000010,V,.01,"I")),44)
  1.  S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
  1.  Q
  1.  ;
  1. PV2(V,PT) ;-- setup the PV2 segment
  1.  ;this may need to be changed to look at the admitting dx in ADT
  1.  Q:'$G(V)
  1.  ;N HVST,VINP,DXI,DX,DXE,IVDT,ADMT,EVDT
  1.  ;find H visit here
  1.  ;S IVDT=(9999999-$P($P(^AUPNVSIT(APCLDA,0),U),"."))
  1.  ;S IVDT=IVDT_"."_$P($P(^AUPNVSIT(APCLDA,0),U),".",2)
  1.  ;S EVDT=IVDT+2
  1.  ;S HVST=$$FNDH(IVDT,EVDT,APCLPAT)
  1.  ;Q:'HVST
  1.  ;find the admit here and get admitting dx
  1.  N HVST
  1.  S HVST=$G(APCLINP)
  1.  Q:'$G(HVST)
  1.  S ADMT=$O(^DGPM("AVST",PT,HVST,0))
  1.  Q:'ADMT
  1.  S VINP=$O(^AUPNVINP("AD",HVST,0))
  1.  I $G(VINP) D
  1.  . S DXI=$$GET1^DIQ(9000010.02,VINP,.12,"I")
  1.  . S DX=$$GET1^DIQ(9000010.02,VINP,.12)
  1.  I '$G(DXI) S DXI=$O(^ICD9("AB",$P($G(^DGPM(ADMT,0)),U,10)_" ",0))
  1.  I $G(DX)="" S DX=$$GET1^DIQ(405,ADMT,.1,"I")
  1.  N ICDT,ICDATA
  1.  S ICDATA=$$ICDDX^APCLSILU(DX,VDATE)
  1.  S DX=$P(ICDATA,U,2)
  1.  S DXE=$P(ICDATA,U,4)
  1.  S ICDT=$P(ICDATA,U,20)  ;get the icd type based on the code
  1.  I $P(DX,".",2)="" S DX=$TR(DX,".")
  1.  D SET(.ARY,"PV2",0)
  1.  D SET(.ARY,DX,3,1)
  1.  D SET(.ARY,$G(DXE),3,2)
  1.  ;D SET(.ARY,"I9CDX",3,3)
  1.  D SET(.ARY,$S(ICDT="30":"I10",1:"I9CDX"),3,3)  ;p30
  1.  S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
  1.  Q
  1.  ;
  1. FNDH(VDT,EDT,P) ;-- find the next H visit within 48 hours
  1.  N VDA,VIN
  1.  S VDA=VDT F  S VDA=$O(^AUPNVSIT("AAH",P,VDA)) Q:'VDA  D
  1.  . S VIEN=0 F  S VIEN=$O(^AUPNVSIT("AAH",P,VDA,VIEN)) Q:'VIEN  D
  1.  .. I VDA<EDT S VIN=VIEN Q
  1.  Q $G(VIN)
  1.  ;
  1. OBXLOC(V,CNT) ;-- setup the location OBX
  1.  N CL,CLC,CD,DSC
  1.  S CL=$P($G(^AUPNVSIT(V,0)),U,8)
  1.  S CLC=$$GET1^DIQ(40.7,CL,1)
  1.  S CD=""
  1.  ;we will need to do a more dynamic clinic map here
  1.  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

 ;