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
  1.  I CLC=30 S CD="261QE0002X"  ;er
  1.  Q:CD=""
  1.  S DSC=$$LOOKTABM("","NUCC",CD,HLECH)
  1.  D SET(.ARY,"OBX",0)
  1.  D SET(.ARY,CNT,1)
  1.  D SET(.ARY,"CWE",2)
  1.  D SET(.ARY,"SS003",3,1)  ;this may need to change as well
  1.  D SET(.ARY,"PHINQUESTION",3,3)
  1.  D SET(.ARY,CD,5,1)
  1.  D SET(.ARY,$P(DSC,HLECH,2),5,2)
  1.  D SET(.ARY,"NUCC",5,3)
  1.  D SET(.ARY,"F",11)
  1.  S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
  1.  Q
  1.  ;
  1. OBXUNIT(P,V,CNT) ;-- setup units
  1.  Q:$P($G(^DPT(P,0)),U)'["UNKNOWN"  ;this will need to change once we identify what an unknown patient is
  1.  ;Q:$$GET1^DIQ(40.7,$P($G(^AUPNVSIT(V,0)),U,8),1)=80
  1.  D SET(.ARY,"OBX",0)
  1.  D SET(.ARY,CNT,1)
  1.  D SET(.ARY,"NM",2)
  1.  D SET(.ARY,"21612-7",3,1)
  1.  D SET(.ARY,"LN",3,3)
  1.  D SET(.ARY,"UNK",6,1)
  1.  D SET(.ARY,"NULLFL",6,3)
  1.  D SET(.ARY,"F",11)
  1.  S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
  1.  Q
  1.  ;
  1. OBXAGE(P,V,CNT) ;-- setup the visit OBX
  1.  ;Q:$$GET1^DIQ(40.7,$P($G(^AUPNVSIT(V,0)),U,8),1)=30
  1.  N AGE,UNIT
  1.  S AGE=$$AGE^AUPNPAT(P,DT,"D")
  1.  S UNIT=$S($P(AGE," ",2)="YRS":"Year",$P(AGE," ",2)="MOS":"Month",1:"Day")
  1.  D SET(.ARY,"OBX",0)
  1.  D SET(.ARY,CNT,1)
  1.  D SET(.ARY,"NM",2)
  1.  D SET(.ARY,"21612-7",3,1)
  1.  D SET(.ARY,"LN",3,3)
  1.  D SET(.ARY,$P(AGE," "),5)
  1.  D SET(.ARY,"a",6,1)
  1.  D SET(.ARY,UNIT,6,2)
  1.  D SET(.ARY,"UCUM",6,3)
  1.  D SET(.ARY,"F",11)
  1.  S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
  1.  Q
  1.  ;
  1. OBXCC(V,CNT) ;-- setup the chief complaint OBX
  1.  N LN,CCI,CC,EC,ECE,ECI,VPOVI,CCE
  1.  ;look here in V NARRATIVE TEXT first
  1.  ;S VPOVI=$O(^AUPNVPOV("AD",V,0))
  1.  ;S CCI=$$GET1^DIQ(9000010,V,1107,"I")
  1.  ;S CC=$$GET1^DIQ(80,$$GET1^DIQ(9000010.07,VPOVI,.01,"I"),3)
  1.  ;S LN=$$GET1^DIQ(9000010,V,1401)
  1.  N CDA,TDA,CCE,ICDT,ICDATA
  1.  S CCE=""
  1.  S CDA=0 F  S CDA=$O(^AUPNVNT("AD",V,CDA)) Q:'CDA  D
  1.  . Q:$$GET1^DIQ(9000010.34,CDA,.01)'="CHIEF COMPLAINT"
  1.  . S TDA=0 F  S TDA=$O(^AUPNVNT(CDA,11,TDA)) Q:'TDA  D
  1.  .. S CCE=CCE_$G(^AUPNVNT(CDA,11,TDA,0))_" "
  1.  I CCE="" S CCE=$$GET1^DIQ(9000010,V,1401)
  1.  I CCE="" S CCE=$$GET1^DIQ(9000010,V,1107)
  1.  Q:$G(CCE)=""
  1.  I $G(CCE)]"" S CCI=$O(^ICD9("AB",CCE_" ",0))
  1.  I $G(CCI) S CC=$$GET1^DIQ(80,CCI,3)
  1.  ;S ECI=$$GET1^DIQ(9000010.07,VPOVI,.09,"I")
  1.  I $G(CCI) D
  1.  . S ICDATA=$$ICDDX^APCLSILU($$GET1^DIQ(80,CCI,.01),VDATE)
  1.  . S ICDT=$P(ICDATA,U,20)  ;get the icd type based on the code
  1.  . S EC=$P(ICDATA,U,2)
  1.  . S ECE=$P(ICDATA,U,4)
  1.  D SET(.ARY,"OBX",0)
  1.  D SET(.ARY,CNT,1)
  1.  D SET(.ARY,"CWE",2)
  1.  D SET(.ARY,"8661-1",3,1)  ;this is the chief complaint loinc code
  1.  I $G(CCI) D
  1.  . D SET(.ARY,EC,5,1)
  1.  . D SET(.ARY,ECE,5,2)
  1.  . D SET(.ARY,$S(ICDT="30":"I10",1:"I9CDX"),5,3)
  1.  D SET(.ARY,"LN",3,3)
  1.  D SET(.ARY,$G(CCE),5,9)
  1.  D SET(.ARY,"F",11)
  1.  S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
  1.  Q
  1.  ;
  1. DG1P(EV,V,FL) ;-- set the repeating DG1
  1.  I 'FL Q:EV="A03"
  1.  Q:EV="A01"  ;IN pv2
  1.  ;Q:EV'="A04"!EV'="A08"
  1.  N DX,DXE,DXT,DIEN,ECOD1,ECOD2,ECOD3
  1.  S DXT=$S($G(FL):"F",1:"W")
  1.  I EV="A08" S DXT="W"
  1.  I EV="A04" S DXT="W"
  1.  ;S DX=$TR($$PRIMPOV^APCLV(V,"C"),".")
  1.  S DIEN=$$PRIMPOV^APCLV(V,5)
  1.  S DX=$$PRIMPOV^APCLV(V,"C")
  1.  N ICDT,ICDATA
  1.  S ICDATA=$$ICDDX^APCLSILU(DX,VDATE)
  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.  ;S LEN=$L(DX)
  1.  ;I $E(DX,LEN,LEN)="0" S DX=$E(DX,1,(LEN-1))
  1.  Q:$G(DX)=""
  1.  I $P(DX,".",2)="" S DX=$TR(DX,".")
  1.  S DXE=$S(ICDT=30:$P(ICDATA,U,4),1:$P($$PRIMPOV^APCLV(V,"E"),"|"))
  1.  D SET(.ARY,"DG1",0)
  1.  D SET(.ARY,1,1)
  1.  D SET(.ARY,DX,3,1)
  1.  D SET(.ARY,DXE,3,2)
  1.  D SET(.ARY,$S(ICDT="30":"I10",1:"I9CDX"),3,3)  ;p30
  1.  D SET(.ARY,DXT,6)
  1.  S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
  1.  Q:'$G(DIEN)
  1.  S ECOD1=$$GET1^DIQ(9000010.07,DIEN,.09,"I")
  1.  S ECOD2=$$GET1^DIQ(9000010.07,DIEN,.18,"I")
  1.  S ECOD3=$$GET1^DIQ(9000010.07,DIEN,.19,"I")
  1.  I $G(ECOD1) D ECOD(ECOD1,DXT)
  1.  I $G(ECOD2) D ECOD(ECOD2,DXT)
  1.  I $G(ECOD3) D ECOD(ECOD3,DXT)
  1.  Q
  1.  ;
  1. FNDPPOV(VS) ;--find ien of primary pov
  1.  N PDA,PV
  1.  S PV=""
  1.  S PDA=0 F  S PDA=$O(^AUPNVPOV("AD",VS,PDA)) Q:'PDA  D
  1.  . I $P($G(^AUPNVPOV(PDA,0)),U,12)="P" S PV=PDA
  1.  Q PV
  1.  ;
  1. DG1S(EV,V) ;-- set the secondary DXs
  1.  N DX,DXE,DXT,DXDA,DXI,DXCNT,LEN,CNTR,ECOD1,ECOD2,ECOD3
  1.  S DXCNT=0,CNTR=0
  1.  S CNTR=$$POVS(V)
  1.  I CNTR=1 D DG1P(EV,V,1) Q
  1.  S DXDA=0 F  S DXDA=$O(^AUPNVPOV("AD",V,DXDA)) Q:'DXDA  D
  1.  . ;Q:$P($G(^AUPNVPOV(DXDA,0)),U,12)="P"
  1.  . S DXCNT=DXCNT+1
  1.  . ;Q:DXCNT=1
  1.  . S DXI=$P($G(^AUPNVPOV(DXDA,0)),U)
  1.  . ;S DX=$TR($$GET1^DIQ(80,DXI,.01),".")
  1.  . S DX=$$GET1^DIQ(80,DXI,.01)
  1.  . N ICDT,ICDATA
  1.  . S ICDATA=$$ICDDX^APCLSILU(DX,VDATE)
  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.  . ;S LEN=$L(DX)
  1.  . ;I $E(DX,LEN,LEN)="0" S DX=$E(DX,1,(LEN-1))
  1.  . S DXE=$S(ICDT=30:$P(ICDATA,U,4),1:$$GET1^DIQ(80,DXI,3))
  1.  . S DXT="F"  ;change this once i know the formula
  1.  . I EV="A08" S DXT="W"
  1.  . I EV="A04" S DXT="W"
  1.  . Q:$G(DX)=""
  1.  . D SET(.ARY,"DG1",0)
  1.  . D SET(.ARY,DXCNT,1)
  1.  . ;D SET(.ARY,(DXCNT-1),1)
  1.  . D SET(.ARY,DX,3,1)
  1.  . D SET(.ARY,DXE,3,2)
  1.  . D SET(.ARY,$S(ICDT="30":"I10",1:"I9CDX"),3,3)
  1.  . D SET(.ARY,DXT,6)
  1.  . S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
  1.  . S ECOD1=$$GET1^DIQ(9000010.07,DXDA,.09,"I")
  1.  . S ECOD2=$$GET1^DIQ(9000010.07,DXDA,.18,"I")
  1.  . S ECOD3=$$GET1^DIQ(9000010.07,DXDA,.19,"I")
  1.  . I $G(ECOD1) D ECOD(ECOD1,DXT)
  1.  . I $G(ECOD2) D ECOD(ECOD2,DXT)
  1.  . I $G(ECOD3) D ECOD(ECOD3,DXT)
  1.  Q
  1.  ;
  1. ECOD(EDXI,EDXT) ;-- populate the DG1 segment with Ecodes
  1.  N ICDT,ICDATA,EDX,EDXE
  1.  I '$G(DXCNT) S DXCNT=1
  1.  S DXCNT=DXCNT+1
  1.  S EDX=$$GET1^DIQ(80,EDXI,.01)
  1.  I $G(EDXT)="" S EDXT="W"
  1.  S ICDATA=$$ICDDX^APCLSILU(EDX,VDATE)
  1.  S ICDT=$P(ICDATA,U,20)  ;get the icd type based on the code
  1.  I $P(EDX,".",2)="" S EDX=$TR(EDX,".")
  1.  S EDXE=$S(ICDT=30:$P(ICDATA,U,4),1:$$GET1^DIQ(80,EDXI,3))
  1.  Q:$G(EDX)=""
  1.  D SET(.ARY,"DG1",0)
  1.  D SET(.ARY,DXCNT,1)
  1.  D SET(.ARY,EDX,3,1)
  1.  D SET(.ARY,EDXE,3,2)
  1.  D SET(.ARY,$S(ICDT="30":"I10",1:"I9CDX"),3,3)
  1.  D SET(.ARY,EDXT,6)
  1.  S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
  1.  Q
  1.  ;
  1. POVS(V) ;-- count the POVs
  1.  N DXDA,CN
  1.  S CN=0
  1.  S DXDA=0 F  S DXDA=$O(^AUPNVPOV("AD",V,DXDA)) Q:'DXDA  D
  1.  . S CN=CN+1
  1.  Q $G(CN)
  1.  ;
  1. LOOKTABM(TYPE,TAB,VAL,ECH) ;-- find the value and description in the HL7 tables
  1.  N DESC,IENI,GBL
  1.  S GBL="^APCLMUT"
  1.  I TYPE="" S GBL="^APCLMUT"
  1.  S IENI=$O(@GBL@("AVAL",TAB,VAL,0))
  1.  Q:'IENI
  1.  S DESC=$P($G(@GBL@(IENI,0)),U,3)
  1.  Q VAL_ECH_DESC_ECH_TYPE_TAB
  1.          ;
  1. LOOKTAB(TYPE,TAB,VAL,ECH) ;-- find the value and description in the HL7 tables
  1.  N DESC,IENI,GBL
  1.  S GBL="^BHLTBL"
  1.  I TYPE="" S GBL="^BHLOTBL"
  1.  S IENI=$O(@GBL@("AVAL",TAB,VAL,0))
  1.  Q:'IENI
  1.  S DESC=$P($G(@GBL@(IENI,0)),U,3)
  1.  Q VAL_ECH_DESC_ECH_TYPE_TAB
  1.  ;
  1. LZERO(V,L) ;EP - left zero fill
  1.  NEW %,I
  1.  S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
  1.  Q V
  1.  ;
  1. LOOKDSC(TYPE,TAB,DSC,ECH) ;-- find a reverse value based on description
  1.  N VAL,IENI,GBL
  1.  S GBL="^BHLOTBL"
  1.  I TYPE="" S GBL="^BHLOTBL"
  1.  S IENI=$O(@GBL@("ADSC",TAB,DSC,0))
  1.  Q:'IENI
  1.  S VAL=$P($G(@GBL@(IENI,0)),U,2)
  1.  Q VAL_ECH_ECH_TYPE_TAB
  1.  ;
  1. SET(ARY,V,F,C,S,R) ;EP
  1.  D SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
  1.  Q
  1.  ; Fix for non-working ZIPCODE Field trigger in File 2
  1. FIXZIP(DFN,ZIP) ;EP
  1.  Q:$G(ZIP) ZIP
  1.  Q $$GET1^DIQ(2,DFN,.116)
  1.  ;
  1. HLD(FDT) ;-- convert to HL7 date
  1.  I $G(FDT)="" Q ""
  1.  N D
  1.  S %DT="X"
  1.  S X=FDT D ^%DT
  1.  S D=$$FMTHL7^XLFDT(Y)
  1.  Q D
  1.  ;
  1. GL2(IN) ;-- write out batch
  1.  K ^APCLTMP($J)
  1.  N BDA,BDO,HLODAT,MSH,MSGP,MSG,BT,BT1,BT2,BT3
  1.  S APCLCNT=0
  1.  S MSG=$P($G(^HLB(IN,0)),U,2)
  1.  S BT1=$G(^HLB(IN,1))
  1.  S BT2=$G(^HLB(IN,2))
  1.  S BT3=$G(^HLB(IN,3))
  1.  S BT=BT1_BT2_BT3
  1.  D SETGL2(BT)
  1.  S BDA=0 F  S BDA=$O(^HLB(IN,3,BDA)) Q:'BDA  D
  1.  . S MSH=""
  1.  . S MSGP=$P($G(^HLB(IN,3,BDA,0)),U)
  1.  . S BDO=0 F  S BDO=$O(^HLB(IN,3,BDA,BDO)) Q:'BDO  D
  1.  .. S HLOMSH=$G(^HLB(IN,3,BDA,BDO))
  1.  .. S MSH=MSH_HLOMSH
  1.  . D SETGL2(MSH)
  1.  . D REST2(MSG,MSGP)
  1.  S DIK="^HLB(",DA=IN D ^DIK
  1.  S DIK="^HLA(",DA=MSG D ^DIK
  1.  D WRITE2
  1.  Q
  1.  ;
  1. REST2(M,MP) ;-- write out the remainder of the segments to the global
  1.  N MDA,DATA,MCNT
  1.  S MCNT=0
  1.  S MDA=0 F  S MDA=$O(^HLA(M,2,MP,1,MDA)) Q:'MDA  D
  1.  . S DATA=$G(^HLA(M,2,MP,1,MDA,0))
  1.  . Q:DATA=""
  1.  . D SETGL(DATA)
  1.  Q
  1.  ;
  1. SETGL2(D) ;-- set the temp global
  1.  S APCLCNT=APCLCNT+1
  1.  S ^APCLTMP($J,APCLCNT)=D
  1.  Q
  1.  ;
  1. WRITE2 ; use XBGSAVE to save the temp global (APCLDATA) to a delimited
  1.  N XBGL,XBQ,XBQTO,XBNAR,XBMED,XBFLT,XBUF,XBFN,APCLFN
  1.  NEW TST
  1.  S TST=0
  1.  I $P($G(^APCLILIC(1,0)),U,5)="T" S TST=1
  1.  S XBGL="APCLTMP",XBMED="F",XBQ="N",XBFLT=1,XBF=$J,XBE=$J
  1.  S XBNAR="MU2 SURVEILLANCE HL7 EXPORT"
  1.  S APCLASU=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10)
  1.  ;is this a test system?
  1.  S (XBFN,APCLDFN)=$S($G(TST):"MU2Z",1:"MU2")_"_"_APCLASU_"_"_$$DATE(DT)_"_P30.txt"
  1.  S XBS1="MU2 SURVEILLANCE SEND"
  1.  ;
  1.  D ^XBGSAVE
  1.  ;
  1.  I XBFLG'=0 D
  1.  . I XBFLG(1)="" W:'$D(ZTQUEUED) !!," HL7 file successfully created",!!
  1.  . I XBFLG(1)]"" W:'$D(ZTQUEUED) !!," HL7 file NOT successfully created",!!
  1.  . W:'$D(ZTQUEUED) !,"File was NOT successfully transferred to IHS/CDC",!,"you will need to manually ftp it.",!
  1.  . W:'$D(ZTQUEUED) !,XBFLG(1),!!
  1.  K ^APCLTMP($J),APCLCNT
  1.  Q
  1.  ;
  1. GL(IN,EV,PT,VDD) ;-- write out the batch to a global for saving in APCLSLAB
  1.  K ^APCLTMP($J)
  1.  N BDA,BDO,HLODAT,MSH,MSGP,MSG,BT,BT1,BT2,BT3
  1.  S APCLCNT=0
  1.  S MSG=$P($G(^HLB(IN,0)),U,2)
  1.  D REST(MSG)
  1.  D WRITE(EV,PT,VDD)
  1.  Q
  1.  ;
  1. REST(M) ;-- write out the remainder of the segments to the global
  1.  N MDA,DATA,MCNT
  1.  S MCNT=0
  1.  S MDA=0 F  S MDA=$O(^HLA(M,1,MDA)) Q:'MDA  D
  1.  . S DATA=$G(^HLA(M,1,MDA,0))
  1.  . Q:DATA=""
  1.  . I $E(DATA,1,3)="NSH" D
  1.  .. S $E(DATA,1,4)="MSH"
  1.  .. S $P(DATA,HLFS,2)="^~\&"
  1.  . D SETGL(DATA)
  1.  Q
  1.  ;
  1. SETGL(D) ;-- set the temp global
  1.  S APCLCNT=APCLCNT+1
  1.  S ^APCLTMP($J,APCLCNT)=D
  1.  Q
  1.  ;
  1. WRITE(E,P,VD) ; use XBGSAVE to save the temp global (APCLDATA) to a delimited
  1.  ; file that is exported to the IE system
  1.  N XBGL,XBQ,XBQTO,XBNAR,XBMED,XBFLT,XBUF,XBFN,APCLFN
  1.  S XBGL="APCLTMP",XBMED="F",XBQ="N",XBFLT=1,XBF=$J,XBE=$J
  1.  S XBNAR="MU2 HL7 EXPORT"
  1.  S APCLASU=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10)  ;asufac for file name
  1.  S (XBFN,APCLDFN)="MU2_"_E_"_"_$$HRN^AUPNPAT(P,DUZ(2))_"_"_$$DATET(VD)_".txt"
  1.  S XBS1="SURVEILLANCE MU2 SEND"
  1.  ;
  1.  D ^XBGSAVE
  1.  ;
  1.  I XBFLG'=0 D
  1.  . I XBFLG(1)="" W:'$D(ZTQUEUED) !!,"MU2 HL7 file successfully created",!!
  1.  . I XBFLG(1)]"" W:'$D(ZTQUEUED) !!,"MU2 HL7 file NOT successfully created",!!
  1.  K ^APCLTMP($J),APCLCNT
  1.  K ^APCLDATA($J)
  1.  Q
  1. DATE(D) ;EP
  1.  Q (1700+$E(D,1,3))_$E(D,4,5)_$E(D,6,7)
  1.  ;
  1. DATET(D) ;EP
  1.  Q (1700+$E(D,1,3))_$E(D,4,5)_$E(D,6,7)_$E(D,8,11)
  1.  ;
  1. EOJ ; EP - EOJ HOUSE KEEPING - this ep called by the BVP package (View patient record)
  1.  K AUPNLK("INAC")
  1.  K %,%DT,%X,%Y,C,DIYS,X,Y
  1.  K APCDCLN,APCDCAT,APCDDATE,APCDLOC,APCDPAT,APCDVSIT,APCDLOOK,APCDTYPE
  1.  D KILL^AUPNPAT
  1.  Q
  1.  ;