APCSSLAB ; IHS/CMI/LAB - ILI surveillance export ;
;;3.0;IHS PCC REPORTS;**22,23,24,25,26,27,28**;FEB 05, 1997
;
;
START ;
;This option will create an HL7 o output file of all visits in a date range that have a certain lab test.
;
;
D EXIT
;
INFORM ;inform user
W:$D(IOF) @IOF
W !!,$$CJ^XLFSTR("EPI PROGRAM HL7 LAB EXPORT",80)
W !!,"This option is used to create a file of HL7 messages. These messages will"
W !,"be sent to the IHS EPI program. A message will be sent for every visit"
W !,"on which a certain lab test was done. The user will define the date range"
W !,"of visits to export."
W !,"This HL7 export file will be automatically ftp'ed to the EPI program.",!!
DATES ;set date range to T-91 to T-1
S (APCSSD,APCSED)=""
BD ;get beginning date
W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter Beginning Visit Date" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G EXIT
S APCSBD=Y
ED ;get ending date
W ! S DIR(0)="DA^"_APCSBD_":DT:EP",DIR("A")="Enter Ending Visit Date: " S Y=APCSBD D DD^%DT S Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G BD
S APCSED=Y
S X1=APCSBD,X2=-1 D C^%DTC S APCSSD=X_".9999"
;
W !!,"The date range for this export is: ",$$FMTE^XLFDT(APCSBD)," to ",$$FMTE^XLFDT(APCSED),".",!
LABTYPE ;
S APCSLTYP=""
S DIR(0)="S^A:Rapid Test for Influenza A & B;B:Chlamydia Tests;C:Both A & B;D:Any Lab Test or Set of (Taxonomy) Lab Tests",DIR("A")="Which Lab Tests should Trigger an HL7 message to be generated"
KILL DA D ^DIR KILL DIR
I $D(DIRUT) G DATES
S APCSLTYP=Y
S APCLQ=""
I APCSLTYP="A"!(APCSLTYP="C") D A G:APCLQ LABTYPE
I APCSLTYP="B"!(APCSLTYP="C") D B G:APCLQ LABTYPE
I APCSLTYP="D" D D G:APCLQ LABTYPE
CONTINUE ;
W !!
S DIR(0)="Y",DIR("A")="Do you wish to continue and generate this export file",DIR("B")="N" KILL DA D ^DIR KILL DIR
I 'Y D EXIT Q
ZIS ;called xbdbque to see if they want to queue or not
DEMO ;
D DEMO^APCLUTL(.APCLDEMO)
I $G(APCLDEMO) G LABTYPE
S XBRC="PROC^APCSSLAB",XBRP="",XBNS="APCS",XBRX="EXIT^APCSSLAB"
D ^XBDBQUE
D EXIT
Q
A ;
S APCSALBT=$O(^ATXLAB("B","SURVEILLANCE RAPID FLU TESTS",0))
I 'APCSALBT W !!,"The SURVEILLANCE RAPID FLU TESTS lab taxonomy is missing. Cannot continue." S APCLQ=1 Q
S APCSACTT=$O(^ATXAX("B","SURVEILLANCE RAPID FLU CPT",0)) I 'APCSACTT W !!,"The SURVEILLANCE RAPID FLU CPT taxonomy is missing. Cannot continue." S APCLQ=1 Q
S APCSALOT=$O(^ATXAX("B","SURVEILLANCE RAPID FLU LOINC",0))
I 'APCSALOT W !!,"The SURVEILLANCE RAPID FLU LOINC taxonomy is missing. Cannot continue." S APCLQ=1 Q
I '$O(^ATXLAB(APCSALBT,21,0)) W !!,"The SURVEILLANCE RAPID FLU TESTS site populated LAB taxonomy has no entries." S APCLQ=1 Q
Q
B ;
S APCSBLBT=$O(^ATXLAB("B","BGP CHLAMYDIA TESTS TAX",0))
I 'APCSBLBT W !!,"The BGP CHLAMYDIA TESTS TAX lab taxonomy is missing. Cannot continue." S APCLQ=1 Q
S APCSBCTT=$O(^ATXAX("B","BGP CHLAMYDIA CPTS",0)) I 'APCSBCTT W !!,"The CHLAMYDIA CPT taxonomy is missing. Cannot continue." S APCLQ=1 Q
S APCSBLOT=$O(^ATXAX("B","BGP CHLAMYDIA LOINC CODES",0))
I 'APCSBLOT W !!,"The BGP CHLAMYDIA LOINC CODES taxonomy is missing. Cannot continue." S APCLQ=1 Q
I '$O(^ATXLAB(APCSBLBT,21,0)) W !!,"The BGP CHLAMYDIA TESTS TAX site populated LAB taxonomy has no entries." S APCLQ=1 Q
Q
LABTAX ;
S DIC="^ATXLAB(",DIC(0)="AEMQ" D ^DIC
I Y=-1 Q
S X=0 F S X=$O(^ATXLAB(+Y,21,X)) Q:X'=+X S L=$P(^ATXLAB(+Y,21,X,0),U,1) I $D(^LAB(60,L,0)) S APCSLABS(L)=""
Q
INDLAB ;
S DIC=60,DIC(0)="AEMQ" D ^DIC
I Y=-1 Q
S APCSLABS(+Y)=""
G INDLAB
D ;taxonomy or selected
K APCSLABS
S APCSLABS=""
S DIR(0)="S^I:Select Lab Tests Individually by Name;T:Use a Lab Taxonomy",DIR("A")="How do you want to select Lab Tests for Export",DIR("B")="I" KILL DA D ^DIR KILL DIR
I $D(DIRUT) S APCLQ=1 Q
S APCSLABS=Y
I APCSLABS="T" D LABTAX
I APCSLABS="I" D INDLAB
I '$O(APCSLABS(0)) S APCLQ=1 K APCSLABS W !!,"no lab tests selected." Q
W !!,"The following labs and values will be exported:"
S X=0 F S X=$O(APCSLABS(X)) Q:X'=+X W !?5,$P(^LAB(60,X,0),U,1)
W !
Q
PROC ;EP - called from xbdbque
W:'$D(ZTQUEUED) !,"Processing..."
K ^APCSDATA($J)
S APCSVTOT=0
F S APCSSD=$O(^AUPNVSIT("B",APCSSD)) Q:APCSSD'=+APCSSD!($P(APCSSD,".")>APCSED) D
.S APCSV=0 F S APCSV=$O(^AUPNVSIT("B",APCSSD,APCSV)) Q:APCSV'=+APCSV D
..Q:'$D(^AUPNVSIT(APCSV,0)) ;no zero node
..Q:$P(^AUPNVSIT(APCSV,0),U,11) ;deleted visit
..S DFN=$P(^AUPNVSIT(APCSV,0),U,5)
..Q:DFN=""
..Q:'$D(^DPT(DFN,0))
..Q:$P(^DPT(DFN,0),U)["DEMO,PATIENT"
..Q:$$DEMO^APCLUTL(DFN)
..;check for tests
..S APCSGOT="" K APCSLABT
..D LAB
..I APCSGOT D HL7(DFN,APCSV) Q ;don't bother with cpts if found lab
..S APCSGOT=0 K APCSLAB
..D CPT
..I APCSGOT D HL7(DFN,APCSV) Q
..Q
.Q
I APCSVTOT D ILI^APCSHLO("ILILAB") Q
I 'APCSVTOT D
.Q:$D(ZTQUEUED)
.W !!,"There are no lab test results to export."
.D PAUSE^APCLVL01
Q
LAB ;does this visit have A or B or either?
S X=0 F S X=$O(^AUPNVLAB("AD",APCSV,X)) Q:X'=+X D
.Q:'$D(^AUPNVLAB(X,0))
.I '$P(^AUPNVLAB(X,0),U,1) Q
.I APCSLTYP="A"!(APCSLTYP="C") D
..I $D(^ATXLAB(APCSALBT,21,"B",$P(^AUPNVLAB(X,0),U))) S APCSGOT=1,APCSLAB(X)="" Q
..Q:'APCSALOT
..S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
..Q:'$$LOINC(J,APCSALOT)
..S APCSGOT=1,APCSLAB(X)=""
.I APCSLTYP="B"!(APCSLTYP="C") D
..I $D(^ATXLAB(APCSBLBT,21,"B",$P(^AUPNVLAB(X,0),U))) S APCSGOT=1,APCSLAB(X)="" Q
..Q:'APCSBLOT
..S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
..Q:'$$LOINC(J,APCSBLOT)
..S APCSGOT=1,APCSLAB(X)=""
.I APCSLTYP="D" D
..I '$D(APCSLABS($P(^AUPNVLAB(X,0),U))) Q
..S APCSGOT=1,APCSLAB(X)=""
Q
CPT ;
S X=0 F S X=$O(^AUPNVCPT("AD",APCSV,X)) Q:X'=+X!(APCSGOT) D
.Q:'$D(^AUPNVCPT(X,0))
.S Y=$P(^AUPNVCPT(X,0),U,1)
.I APCSLTYP="A"!(APCSLTYP="C"),$$ICD^ATXCHK(Y,APCSACTT,1) S APCSGOT=1 Q
.I APCSLTYP="B"!(APCSLTYP="C"),$$ICD^ATXCHK(Y,APCSBCTT,1) S APCSGOT=1 Q
.Q
Q
HL7(FN,AV) ;export this visit - MARK - this is where you will generate the HL7 message
;APCSV is visit ien
;array APCSLAB is array of lab test entries to send from V LAB
;if array APCSLAB is undefined that means a found a visit with a cpt code and no lab so there will be no OBXs for lab but send the visit
S APCSVTOT=APCSVTOT+1
D BLDPID(FN,AV)
D BLDZID(FN,AV)
D BLDPV1(AV)
D BLDDG1(AV)
D BLDPR1(AV)
S APCSOBXC=0
D BLDOBXTP(AV)
D BLDOBXLB(AV)
W:'$D(ZTQUEUED) ".",AV
Q
BLDPID(F,V) ;
N LOC,HRN,SEX,DOB
S LOC=$P($G(^AUPNVSIT(V,0)),U,6)
S HRN=$S($$HRN^AUPNPAT(F,LOC)]"":$$HRN^AUPNPAT(F,LOC),1:$$HRN^AUPNPAT(F,DUZ(2)))
S SEX=$P($G(^DPT(F,0)),U,2)
S DOB=$$FMTHL7^XLFDT($P($G(^DPT(F,0)),U,3))
S ^APCSDATA($J,V,"PID")=HRN_U_SEX_U_DOB
Q
;
BLDZID(F,V) ;
N AGE
S AGE=$$AGE^AUPNPAT(F)
S ^APCSDATA($J,V,"ZID")=AGE
Q
;
BLDPV1(V) ;
N ASUFAC,UVIEN,VDT,DDT,LOC,CC,CLN
S LOC=$P($G(^AUPNVSIT(V,0)),U,6)
S CLN=$P($G(^AUPNVSIT(V,0)),U,8)
S CC=$S(CLN:$$GET1^DIQ(40.7,CLN,1),1:"")
S ASUFAC=$P(^AUTTLOC(LOC,0),U,10)
S UVIEN=$S($P($G(^AUPNVSIT(V,11)),U,14)]"":$P($G(^AUPNVSIT(V,11)),U,14),1:$$UIDV^AUPNVSIT(V))
S VDT=$$FMTHL7^XLFDT($P($P(^AUPNVSIT(V,0),U),"."))
S DDT=$$FMTHL7^XLFDT($$DSCHDATE^APCLSIL2(V))
S ^APCSDATA($J,V,"PV1")=ASUFAC_U_CC_U_UVIEN_U_VDT_U_DDT
Q
;
BLDDG1(V) ;
N BDA,DX,CNT
S CNT=0
S BDA=0 F S BDA=$O(^AUPNVPOV("AD",V,BDA)) Q:'BDA D
. S DX=$$GET1^DIQ(9000010.07,BDA,.01)
. S CNT=CNT+1
. S ^APCSDATA($J,V,"DG1",CNT)=DX
Q
;
BLDPR1(V) ;
N BDA,CPT,CNT
S CNT=0
S BDA=0 F S BDA=$O(^AUPNVCPT("AD",V,BDA)) Q:'BDA D
. S CPT=$$GET1^DIQ(9000010.18,BDA,.01)
. S CNT=CNT+1
. S ^APCSDATA($J,V,"PR1",CNT)=CPT
Q
;
BLDOBXTP(V) ;
N BDA,TMP,TEMP
S TEMP=""
S BDA=0 F S BDA=$O(^AUPNVMSR("AD",V,BDA)) Q:'BDA D
.Q:$P($G(^AUPNVMSR(BDA,2)),U,1)
.Q:$$VAL^XBDIQ1(9000010.01,BDA,.01)'="TMP" ;not a temperature
.S TMP=$P(^AUPNVMSR(BDA,0),U,4)
.S TEMP=$S(TMP>TEMP:TMP,1:TEMP)
.S APCSOBXC=APCSOBXC+1
.S ^APCSDATA($J,V,"OBX",APCSOBXC)=APCSOBXC_U_"ST"_U_"TMP"_U_TEMP
Q
;
BLDOBXLB(V) ;
N BDA,LABI,LAB,LOINC,RES
S BDA=0 F S BDA=$O(APCSLAB(BDA)) Q:'BDA D
. S LABI=$P($G(^AUPNVLAB(BDA,0)),U)
. S RES=$P($G(^AUPNVLAB(BDA,0)),U,4)
. S LAB=$$GET1^DIQ(9000010.09,BDA,.01)
. S LOINC=$$GET1^DIQ(9000010.09,BDA,1113)
. S APCSOBXC=APCSOBXC+1
. S ^APCSDATA($J,V,"OBX",APCSOBXC)=APCSOBXC_U_"ST"_U_LOINC_"~"_LAB_U_RES
Q
;
LOINC(A,B) ;EP
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
;send file
WRITE ; use XBGSAVE to save the temp global (APCSDATA) to a delimited
; file that is exported to the IE system
N XBGL,XBQ,XBQTO,XBNAR,XBMED,XBFLT,XBUF,XBFN
S XBGL="APCSDATA",XBMED="F",XBQ="N",XBFLT=1,XBF=$J,XBE=$J
S XBNAR="EPI LAB HL7 EXPORT"
S APCSASU=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10) ;asufac for file name
S XBFN="EPILABHL7_"_APCSASU_"_"_$$DATE(DT)_".txt"
S XBS1="SURVEILLANCE ILI SEND"
;
D ^XBGSAVE
;
I XBFLG'=0 D
. I XBFLG(1)="" W:'$D(ZTQUEUED) !!,"LAB HL7 file successfully created",!!
. I XBFLG(1)]"" W:'$D(ZTQUEUED) !!,"LAB 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 ^APCSDATA($J)
Q
;
DATE(D) ;EP
Q (1700+$E(D,1,3))_$E(D,4,5)_$E(D,6,7)
;
JDATE(D) ;EP - get date
I $G(D)="" Q ""
NEW A
S A=$$FMTE^XLFDT(D)
Q $E(D,6,7)_$$UP^XLFSTR($P(A," ",1))_(1700+$E(D,1,3))
;
UID(APCSA) ;Given DFN return unique patient record id.
I '$G(APCSA) Q ""
I '$D(^AUPNPAT(APCSA)) Q ""
;
Q $$GET1^DIQ(9999999.06,$P(^AUTTSITE(1,0),U),.32)_$E("0000000000",1,10-$L(APCSA))_APCSA
;
EXIT ;clean up and exit
D EN^XBVK("APCS")
D ^XBFMK
Q
;
EP ;EP - called from option to create search template using ILI logic
G ^APCLSIL3
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
EOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:$D(ZTQUEUED)!'(IOT["TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR(0)="E" D ^DIR
Q
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
PURGE ;
W:'$D(ZTQUEUED) !!,"Now cleaning up host files older than 7 DAYS"
K APCSFILE,APCSDIR
S APCSDIR=$P($G(^AUTTSITE(1,1)),"^",2)
I APCSDIR="" S APCSDIR=$P($G(^XTV(8989.3,1,"DEV")),"^",1)
I APCSDIR="" Q
S APCSASU=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10)
S APCSDT=$$FMADD^XLFDT(DT,-7)
S APCSDT=$$DATE(APCSDT)
S APCSFLST=$$LIST^%ZISH(APCSDIR,"EPILABHL7"_APCSASU_"*",.APCSFILE)
Q:'$O(APCSFILE(""))
S APCSX=0 F S APCSX=$O(APCSFILE(APCSX)) Q:APCSX'=+APCSX D
.S D=$P($P(APCSFILE(APCSX),"."),"_",3)
.I D<APCSDT S N=APCSFILE(APCSX) S APCSM=$$DEL^%ZISH(APCSDIR,N)
Q
APCSSLAB ; IHS/CMI/LAB - ILI surveillance export ;
+1 ;;3.0;IHS PCC REPORTS;**22,23,24,25,26,27,28**;FEB 05, 1997
+2 ;
+3 ;
START ;
+1 ;This option will create an HL7 o output file of all visits in a date range that have a certain lab test.
+2 ;
+3 ;
+4 DO EXIT
+5 ;
INFORM ;inform user
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !!,$$CJ^XLFSTR("EPI PROGRAM HL7 LAB EXPORT",80)
+3 WRITE !!,"This option is used to create a file of HL7 messages. These messages will"
+4 WRITE !,"be sent to the IHS EPI program. A message will be sent for every visit"
+5 WRITE !,"on which a certain lab test was done. The user will define the date range"
+6 WRITE !,"of visits to export."
+7 WRITE !,"This HL7 export file will be automatically ftp'ed to the EPI program.",!!
DATES ;set date range to T-91 to T-1
+1 SET (APCSSD,APCSED)=""
BD ;get beginning date
+1 WRITE !
SET DIR(0)="D^:DT:EP"
SET DIR("A")="Enter Beginning Visit Date"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO EXIT
+3 SET APCSBD=Y
ED ;get ending date
+1 WRITE !
SET DIR(0)="DA^"_APCSBD_":DT:EP"
SET DIR("A")="Enter Ending Visit Date: "
SET Y=APCSBD
DO DD^%DT
SET Y=""
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO BD
+3 SET APCSED=Y
+4 SET X1=APCSBD
SET X2=-1
DO C^%DTC
SET APCSSD=X_".9999"
+5 ;
+6 WRITE !!,"The date range for this export is: ",$$FMTE^XLFDT(APCSBD)," to ",$$FMTE^XLFDT(APCSED),".",!
LABTYPE ;
+1 SET APCSLTYP=""
+2 SET DIR(0)="S^A:Rapid Test for Influenza A & B;B:Chlamydia Tests;C:Both A & B;D:Any Lab Test or Set of (Taxonomy) Lab Tests"
SET DIR("A")="Which Lab Tests should Trigger an HL7 message to be generated"
+3 KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO DATES
+5 SET APCSLTYP=Y
+6 SET APCLQ=""
+7 IF APCSLTYP="A"!(APCSLTYP="C")
DO A
IF APCLQ
GOTO LABTYPE
+8 IF APCSLTYP="B"!(APCSLTYP="C")
DO B
IF APCLQ
GOTO LABTYPE
+9 IF APCSLTYP="D"
DO D
IF APCLQ
GOTO LABTYPE
CONTINUE ;
+1 WRITE !!
+2 SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue and generate this export file"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+3 IF 'Y
DO EXIT
QUIT
ZIS ;called xbdbque to see if they want to queue or not
DEMO ;
+1 DO DEMO^APCLUTL(.APCLDEMO)
+2 IF $GET(APCLDEMO)
GOTO LABTYPE
+3 SET XBRC="PROC^APCSSLAB"
SET XBRP=""
SET XBNS="APCS"
SET XBRX="EXIT^APCSSLAB"
+4 DO ^XBDBQUE
+5 DO EXIT
+6 QUIT
A ;
+1 SET APCSALBT=$ORDER(^ATXLAB("B","SURVEILLANCE RAPID FLU TESTS",0))
+2 IF 'APCSALBT
WRITE !!,"The SURVEILLANCE RAPID FLU TESTS lab taxonomy is missing. Cannot continue."
SET APCLQ=1
QUIT
+3 SET APCSACTT=$ORDER(^ATXAX("B","SURVEILLANCE RAPID FLU CPT",0))
IF 'APCSACTT
WRITE !!,"The SURVEILLANCE RAPID FLU CPT taxonomy is missing. Cannot continue."
SET APCLQ=1
QUIT
+4 SET APCSALOT=$ORDER(^ATXAX("B","SURVEILLANCE RAPID FLU LOINC",0))
+5 IF 'APCSALOT
WRITE !!,"The SURVEILLANCE RAPID FLU LOINC taxonomy is missing. Cannot continue."
SET APCLQ=1
QUIT
+6 IF '$ORDER(^ATXLAB(APCSALBT,21,0))
WRITE !!,"The SURVEILLANCE RAPID FLU TESTS site populated LAB taxonomy has no entries."
SET APCLQ=1
QUIT
+7 QUIT
B ;
+1 SET APCSBLBT=$ORDER(^ATXLAB("B","BGP CHLAMYDIA TESTS TAX",0))
+2 IF 'APCSBLBT
WRITE !!,"The BGP CHLAMYDIA TESTS TAX lab taxonomy is missing. Cannot continue."
SET APCLQ=1
QUIT
+3 SET APCSBCTT=$ORDER(^ATXAX("B","BGP CHLAMYDIA CPTS",0))
IF 'APCSBCTT
WRITE !!,"The CHLAMYDIA CPT taxonomy is missing. Cannot continue."
SET APCLQ=1
QUIT
+4 SET APCSBLOT=$ORDER(^ATXAX("B","BGP CHLAMYDIA LOINC CODES",0))
+5 IF 'APCSBLOT
WRITE !!,"The BGP CHLAMYDIA LOINC CODES taxonomy is missing. Cannot continue."
SET APCLQ=1
QUIT
+6 IF '$ORDER(^ATXLAB(APCSBLBT,21,0))
WRITE !!,"The BGP CHLAMYDIA TESTS TAX site populated LAB taxonomy has no entries."
SET APCLQ=1
QUIT
+7 QUIT
LABTAX ;
+1 SET DIC="^ATXLAB("
SET DIC(0)="AEMQ"
DO ^DIC
+2 IF Y=-1
QUIT
+3 SET X=0
FOR
SET X=$ORDER(^ATXLAB(+Y,21,X))
IF X'=+X
QUIT
SET L=$PIECE(^ATXLAB(+Y,21,X,0),U,1)
IF $DATA(^LAB(60,L,0))
SET APCSLABS(L)=""
+4 QUIT
INDLAB ;
+1 SET DIC=60
SET DIC(0)="AEMQ"
DO ^DIC
+2 IF Y=-1
QUIT
+3 SET APCSLABS(+Y)=""
+4 GOTO INDLAB
D ;taxonomy or selected
+1 KILL APCSLABS
+2 SET APCSLABS=""
+3 SET DIR(0)="S^I:Select Lab Tests Individually by Name;T:Use a Lab Taxonomy"
SET DIR("A")="How do you want to select Lab Tests for Export"
SET DIR("B")="I"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
SET APCLQ=1
QUIT
+5 SET APCSLABS=Y
+6 IF APCSLABS="T"
DO LABTAX
+7 IF APCSLABS="I"
DO INDLAB
+8 IF '$ORDER(APCSLABS(0))
SET APCLQ=1
KILL APCSLABS
WRITE !!,"no lab tests selected."
QUIT
+9 WRITE !!,"The following labs and values will be exported:"
+10 SET X=0
FOR
SET X=$ORDER(APCSLABS(X))
IF X'=+X
QUIT
WRITE !?5,$PIECE(^LAB(60,X,0),U,1)
+11 WRITE !
+12 QUIT
PROC ;EP - called from xbdbque
+1 IF '$DATA(ZTQUEUED)
WRITE !,"Processing..."
+2 KILL ^APCSDATA($JOB)
+3 SET APCSVTOT=0
+4 FOR
SET APCSSD=$ORDER(^AUPNVSIT("B",APCSSD))
IF APCSSD'=+APCSSD!($PIECE(APCSSD,".")>APCSED)
QUIT
Begin DoDot:1
+5 SET APCSV=0
FOR
SET APCSV=$ORDER(^AUPNVSIT("B",APCSSD,APCSV))
IF APCSV'=+APCSV
QUIT
Begin DoDot:2
+6 ;no zero node
IF '$DATA(^AUPNVSIT(APCSV,0))
QUIT
+7 ;deleted visit
IF $PIECE(^AUPNVSIT(APCSV,0),U,11)
QUIT
+8 SET DFN=$PIECE(^AUPNVSIT(APCSV,0),U,5)
+9 IF DFN=""
QUIT
+10 IF '$DATA(^DPT(DFN,0))
QUIT
+11 IF $PIECE(^DPT(DFN,0),U)["DEMO,PATIENT"
QUIT
+12 IF $$DEMO^APCLUTL(DFN)
QUIT
+13 ;check for tests
+14 SET APCSGOT=""
KILL APCSLABT
+15 DO LAB
+16 ;don't bother with cpts if found lab
IF APCSGOT
DO HL7(DFN,APCSV)
QUIT
+17 SET APCSGOT=0
KILL APCSLAB
+18 DO CPT
+19 IF APCSGOT
DO HL7(DFN,APCSV)
QUIT
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 IF APCSVTOT
DO ILI^APCSHLO("ILILAB")
QUIT
+23 IF 'APCSVTOT
Begin DoDot:1
+24 IF $DATA(ZTQUEUED)
QUIT
+25 WRITE !!,"There are no lab test results to export."
+26 DO PAUSE^APCLVL01
End DoDot:1
+27 QUIT
LAB ;does this visit have A or B or either?
+1 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AD",APCSV,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+3 IF '$PIECE(^AUPNVLAB(X,0),U,1)
QUIT
+4 IF APCSLTYP="A"!(APCSLTYP="C")
Begin DoDot:2
+5 IF $DATA(^ATXLAB(APCSALBT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET APCSGOT=1
SET APCSLAB(X)=""
QUIT
+6 IF 'APCSALOT
QUIT
+7 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+8 IF '$$LOINC(J,APCSALOT)
QUIT
+9 SET APCSGOT=1
SET APCSLAB(X)=""
End DoDot:2
+10 IF APCSLTYP="B"!(APCSLTYP="C")
Begin DoDot:2
+11 IF $DATA(^ATXLAB(APCSBLBT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET APCSGOT=1
SET APCSLAB(X)=""
QUIT
+12 IF 'APCSBLOT
QUIT
+13 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+14 IF '$$LOINC(J,APCSBLOT)
QUIT
+15 SET APCSGOT=1
SET APCSLAB(X)=""
End DoDot:2
+16 IF APCSLTYP="D"
Begin DoDot:2
+17 IF '$DATA(APCSLABS($PIECE(^AUPNVLAB(X,0),U)))
QUIT
+18 SET APCSGOT=1
SET APCSLAB(X)=""
End DoDot:2
End DoDot:1
+19 QUIT
CPT ;
+1 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",APCSV,X))
IF X'=+X!(APCSGOT)
QUIT
Begin DoDot:1
+2 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+3 SET Y=$PIECE(^AUPNVCPT(X,0),U,1)
+4 IF APCSLTYP="A"!(APCSLTYP="C")
IF $$ICD^ATXCHK(Y,APCSACTT,1)
SET APCSGOT=1
QUIT
+5 IF APCSLTYP="B"!(APCSLTYP="C")
IF $$ICD^ATXCHK(Y,APCSBCTT,1)
SET APCSGOT=1
QUIT
+6 QUIT
End DoDot:1
+7 QUIT
HL7(FN,AV) ;export this visit - MARK - this is where you will generate the HL7 message
+1 ;APCSV is visit ien
+2 ;array APCSLAB is array of lab test entries to send from V LAB
+3 ;if array APCSLAB is undefined that means a found a visit with a cpt code and no lab so there will be no OBXs for lab but send the visit
+4 SET APCSVTOT=APCSVTOT+1
+5 DO BLDPID(FN,AV)
+6 DO BLDZID(FN,AV)
+7 DO BLDPV1(AV)
+8 DO BLDDG1(AV)
+9 DO BLDPR1(AV)
+10 SET APCSOBXC=0
+11 DO BLDOBXTP(AV)
+12 DO BLDOBXLB(AV)
+13 IF '$DATA(ZTQUEUED)
WRITE ".",AV
+14 QUIT
BLDPID(F,V) ;
+1 NEW LOC,HRN,SEX,DOB
+2 SET LOC=$PIECE($GET(^AUPNVSIT(V,0)),U,6)
+3 SET HRN=$SELECT($$HRN^AUPNPAT(F,LOC)]"":$$HRN^AUPNPAT(F,LOC),1:$$HRN^AUPNPAT(F,DUZ(2)))
+4 SET SEX=$PIECE($GET(^DPT(F,0)),U,2)
+5 SET DOB=$$FMTHL7^XLFDT($PIECE($GET(^DPT(F,0)),U,3))
+6 SET ^APCSDATA($JOB,V,"PID")=HRN_U_SEX_U_DOB
+7 QUIT
+8 ;
BLDZID(F,V) ;
+1 NEW AGE
+2 SET AGE=$$AGE^AUPNPAT(F)
+3 SET ^APCSDATA($JOB,V,"ZID")=AGE
+4 QUIT
+5 ;
BLDPV1(V) ;
+1 NEW ASUFAC,UVIEN,VDT,DDT,LOC,CC,CLN
+2 SET LOC=$PIECE($GET(^AUPNVSIT(V,0)),U,6)
+3 SET CLN=$PIECE($GET(^AUPNVSIT(V,0)),U,8)
+4 SET CC=$SELECT(CLN:$$GET1^DIQ(40.7,CLN,1),1:"")
+5 SET ASUFAC=$PIECE(^AUTTLOC(LOC,0),U,10)
+6 SET UVIEN=$SELECT($PIECE($GET(^AUPNVSIT(V,11)),U,14)]"":$PIECE($GET(^AUPNVSIT(V,11)),U,14),1:$$UIDV^AUPNVSIT(V))
+7 SET VDT=$$FMTHL7^XLFDT($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
+8 SET DDT=$$FMTHL7^XLFDT($$DSCHDATE^APCLSIL2(V))
+9 SET ^APCSDATA($JOB,V,"PV1")=ASUFAC_U_CC_U_UVIEN_U_VDT_U_DDT
+10 QUIT
+11 ;
BLDDG1(V) ;
+1 NEW BDA,DX,CNT
+2 SET CNT=0
+3 SET BDA=0
FOR
SET BDA=$ORDER(^AUPNVPOV("AD",V,BDA))
IF 'BDA
QUIT
Begin DoDot:1
+4 SET DX=$$GET1^DIQ(9000010.07,BDA,.01)
+5 SET CNT=CNT+1
+6 SET ^APCSDATA($JOB,V,"DG1",CNT)=DX
End DoDot:1
+7 QUIT
+8 ;
BLDPR1(V) ;
+1 NEW BDA,CPT,CNT
+2 SET CNT=0
+3 SET BDA=0
FOR
SET BDA=$ORDER(^AUPNVCPT("AD",V,BDA))
IF 'BDA
QUIT
Begin DoDot:1
+4 SET CPT=$$GET1^DIQ(9000010.18,BDA,.01)
+5 SET CNT=CNT+1
+6 SET ^APCSDATA($JOB,V,"PR1",CNT)=CPT
End DoDot:1
+7 QUIT
+8 ;
BLDOBXTP(V) ;
+1 NEW BDA,TMP,TEMP
+2 SET TEMP=""
+3 SET BDA=0
FOR
SET BDA=$ORDER(^AUPNVMSR("AD",V,BDA))
IF 'BDA
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^AUPNVMSR(BDA,2)),U,1)
QUIT
+5 ;not a temperature
IF $$VAL^XBDIQ1(9000010.01,BDA,.01)'="TMP"
QUIT
+6 SET TMP=$PIECE(^AUPNVMSR(BDA,0),U,4)
+7 SET TEMP=$SELECT(TMP>TEMP:TMP,1:TEMP)
+8 SET APCSOBXC=APCSOBXC+1
+9 SET ^APCSDATA($JOB,V,"OBX",APCSOBXC)=APCSOBXC_U_"ST"_U_"TMP"_U_TEMP
End DoDot:1
+10 QUIT
+11 ;
BLDOBXLB(V) ;
+1 NEW BDA,LABI,LAB,LOINC,RES
+2 SET BDA=0
FOR
SET BDA=$ORDER(APCSLAB(BDA))
IF 'BDA
QUIT
Begin DoDot:1
+3 SET LABI=$PIECE($GET(^AUPNVLAB(BDA,0)),U)
+4 SET RES=$PIECE($GET(^AUPNVLAB(BDA,0)),U,4)
+5 SET LAB=$$GET1^DIQ(9000010.09,BDA,.01)
+6 SET LOINC=$$GET1^DIQ(9000010.09,BDA,1113)
+7 SET APCSOBXC=APCSOBXC+1
+8 SET ^APCSDATA($JOB,V,"OBX",APCSOBXC)=APCSOBXC_U_"ST"_U_LOINC_"~"_LAB_U_RES
End DoDot:1
+9 QUIT
+10 ;
LOINC(A,B) ;EP
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
+7 ;send file
WRITE ; use XBGSAVE to save the temp global (APCSDATA) to a delimited
+1 ; file that is exported to the IE system
+2 NEW XBGL,XBQ,XBQTO,XBNAR,XBMED,XBFLT,XBUF,XBFN
+3 SET XBGL="APCSDATA"
SET XBMED="F"
SET XBQ="N"
SET XBFLT=1
SET XBF=$JOB
SET XBE=$JOB
+4 SET XBNAR="EPI LAB HL7 EXPORT"
+5 ;asufac for file name
SET APCSASU=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0)),U,10)
+6 SET XBFN="EPILABHL7_"_APCSASU_"_"_$$DATE(DT)_".txt"
+7 SET XBS1="SURVEILLANCE ILI SEND"
+8 ;
+9 DO ^XBGSAVE
+10 ;
+11 IF XBFLG'=0
Begin DoDot:1
+12 IF XBFLG(1)=""
IF '$DATA(ZTQUEUED)
WRITE !!,"LAB HL7 file successfully created",!!
+13 IF XBFLG(1)]""
IF '$DATA(ZTQUEUED)
WRITE !!,"LAB HL7 file NOT successfully created",!!
+14 IF '$DATA(ZTQUEUED)
WRITE !,"File was NOT successfully transferred to IHS/CDC",!,"you will need to manually ftp it.",!
+15 IF '$DATA(ZTQUEUED)
WRITE !,XBFLG(1),!!
End DoDot:1
+16 KILL ^APCSDATA($JOB)
+17 QUIT
+18 ;
DATE(D) ;EP
+1 QUIT (1700+$EXTRACT(D,1,3))_$EXTRACT(D,4,5)_$EXTRACT(D,6,7)
+2 ;
JDATE(D) ;EP - get date
+1 IF $GET(D)=""
QUIT ""
+2 NEW A
+3 SET A=$$FMTE^XLFDT(D)
+4 QUIT $EXTRACT(D,6,7)_$$UP^XLFSTR($PIECE(A," ",1))_(1700+$EXTRACT(D,1,3))
+5 ;
UID(APCSA) ;Given DFN return unique patient record id.
+1 IF '$GET(APCSA)
QUIT ""
+2 IF '$DATA(^AUPNPAT(APCSA))
QUIT ""
+3 ;
+4 QUIT $$GET1^DIQ(9999999.06,$PIECE(^AUTTSITE(1,0),U),.32)_$EXTRACT("0000000000",1,10-$LENGTH(APCSA))_APCSA
+5 ;
EXIT ;clean up and exit
+1 DO EN^XBVK("APCS")
+2 DO ^XBFMK
+3 QUIT
+4 ;
EP ;EP - called from option to create search template using ILI logic
+1 GOTO ^APCLSIL3
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF $DATA(ZTQUEUED)!'(IOT["TRM")!$DATA(IO("S"))
QUIT
+3 NEW DIR
+4 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+5 SET DIR(0)="E"
DO ^DIR
+6 QUIT
+7 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
PURGE ;
+1 IF '$DATA(ZTQUEUED)
WRITE !!,"Now cleaning up host files older than 7 DAYS"
+2 KILL APCSFILE,APCSDIR
+3 SET APCSDIR=$PIECE($GET(^AUTTSITE(1,1)),"^",2)
+4 IF APCSDIR=""
SET APCSDIR=$PIECE($GET(^XTV(8989.3,1,"DEV")),"^",1)
+5 IF APCSDIR=""
QUIT
+6 SET APCSASU=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0)),U,10)
+7 SET APCSDT=$$FMADD^XLFDT(DT,-7)
+8 SET APCSDT=$$DATE(APCSDT)
+9 SET APCSFLST=$$LIST^%ZISH(APCSDIR,"EPILABHL7"_APCSASU_"*",.APCSFILE)
+10 IF '$ORDER(APCSFILE(""))
QUIT
+11 SET APCSX=0
FOR
SET APCSX=$ORDER(APCSFILE(APCSX))
IF APCSX'=+APCSX
QUIT
Begin DoDot:1
+12 SET D=$PIECE($PIECE(APCSFILE(APCSX),"."),"_",3)
+13 IF D<APCSDT
SET N=APCSFILE(APCSX)
SET APCSM=$$DEL^%ZISH(APCSDIR,N)
End DoDot:1
+14 QUIT
