APCLSILI ; IHS/CMI/LAB - ILI surveillance export ; 27 Jun 2017 2:26 PM
;;3.0;IHS PCC REPORTS;**22,23,24,25,26,27,28,29,30,31**;FEB 05, 1997;Build 32
;
;
START ;
;ili surveillance export, runs nightly, see design doc from ILI team for
;details
;
;
D EN^XBVK("APCL")
S D=""
S X=$O(^APCLCNTL("B","ILI STOP DATE",0))
I X,$P(^APCLCNTL(X,0),U,3) S D=$P(^APCLCNTL(X,0),U,3) ;if there is a stop date then use it
I D,DT>D Q
;
D EXIT
;
;
PROC ;EP - called from xbdbque
S APCL1ST="",APCLSCOM=""
I $E(DT,6,7)="01" S APCL1ST=1
;I $P($G(^APCLILIC(1,0)),U,2) S APCL1ST=1 ;need to send data first time through after the patch is installed
;if this is between the 15th and 27th then check to see if the user pop export has been run
;if it has run since the 1st of the month then run it.
;get the 1st of this month
S APCL1OM=$E(DT,1,5)_"01"
;get date last one finished.
S (X,L)="" F S X=$O(^APCLILIC(1,11,"B",X)) Q:X'=+X S L=X
I 'L S APCL1ST=1 ;hasn't run before after patch 27 so run it
I 'APCL1ST,$E(DT,6,7)>14,$E(DT,6,7)<27,L<APCL1OM S APCL1ST=1 ;if last time run was before the 1st then run it
I $E(DT,4,7)="0710"!($E(DT,4,7)="1210") S APCLSCOM=1
K APCLLOCT,APCLALLT,APCLHTOT,APCLALL1
K ^TMP($J)
K ^APCLDATA($J)
S APCLCTAX=$O(^ATXAX("B","SURVEILLANCE ILI CLINICS",0))
S APCLDTAX=$O(^ATXAX("B","SURVEILLANCE ILI",0)) ;dx taxonomy
S APCLTTAX=$O(^ATXAX("B","SURVEILLANCE ILI NO TMP NEEDED",0))
I 'APCLCTAX D EXIT Q
I 'APCLDTAX D EXIT Q
;
I '$P($G(^APCLILIC(1,0)),U,4) D I 1
.S (APCLSD,APCLDELD)=3081231.9999,$P(^APCLILIC(1,0),U,4)=1,APCLBDAT=3090101,APCLFLF=1,APCL1ST=1,APCLSCOM=1
E S (APCLSD,APCLDELD)=$$FMADD^XLFDT(DT,-91)_".9999",APCLBDAT=$$FMADD^XLFDT(DT,-90)
S APCLED=$$FMADD^XLFDT(DT,-1)
S APCLZHSD=DT
EP1 ;EP - called from on demand option
;wipe out log? - yes per Deborah
I $G(APCLFLF) D
.S APCLX=0 F S APCLX=$O(^APCLILIL(APCLX)) Q:APCLX'=+APCLX S DA=APCLX,DIK="^APCLILIL(" D ^DIK
D UNFOLDTX^APCLSILU
K ^XTMP("APCLILIV",$J)
I $G(APCLWEXP)="P" G MONUP
S APCLVTOT=0
S APCLBT=$H
S APCLDELD=APCLSD
F S APCLSD=$O(^AUPNVSIT("B",APCLSD)) Q:APCLSD'=+APCLSD!($P(APCLSD,".")>APCLED) D
.S APCLV=0 F S APCLV=$O(^AUPNVSIT("B",APCLSD,APCLV)) Q:APCLV'=+APCLV D PROC1
;now go through ADLM and if exported before and not already dealt with d proc1 SKIP IF THIS IS A FULL BACKLOAD
I $G(APCLFLF) G S
S APCLSD=APCLDELD
F S APCLSD=$O(^AUPNVSIT("ADLM",APCLSD)) Q:APCLSD'=+APCLSD!($P(APCLSD,".")>APCLED) D
.S APCLV=0 F S APCLV=$O(^AUPNVSIT("ADLM",APCLSD,APCLV)) Q:APCLV'=+APCLV D
..Q:$D(^XTMP("APCLILIV",$J,APCLV)) ;already processed
..Q:$$VD^APCLV(APCLV)<3090101 ;only want visits after 1/1/09
..;I '$D(^APCLILIL(APCLV)) Q ;;never sent so no need to process
..D PROC1
;NOW GO THROUGH AVDEL XREF FOR DELETES SKIP IF THIS IS A FULL EXPORT
S APCLSD=APCLDELD
F S APCLSD=$O(^AUPNVSIT("AVDEL",APCLSD)) Q:APCLSD'=+APCLSD!($P(APCLSD,".")>APCLED) D
.S APCLV=0 F S APCLV=$O(^AUPNVSIT("AVDEL",APCLSD,APCLV)) Q:APCLV'=+APCLV D
..I '$D(^APCLILIL(APCLV)) Q ;never exported so no need to send delete
..I $P(^AUPNVSIT(APCLV,0),U,11),$D(^APCLILIL("B",APCLV)) S APCLSTAT="D" D SR("VISIT HAS BEEN DELETED")
..S DFN=$P(^AUPNVSIT(APCLV,0),U,5)
..S APCLLOC=$P(^AUPNVSIT(APCLV,0),U,6)
..S APCLKV=0,APCLH1N1=0,(APCLILI,APCLHVAC,APCLIVAC,APCLADVE,APCLSRD,APCLAVM,APCLAV9)=""
..S APCLLOC=$P(^AUPNVSIT(APCLV,0),U,6) Q:APCLLOC=""
..S APCLDATE=$P($P(^AUPNVSIT(APCLV,0),U),".")
..S APCLASUF=$P($G(^AUTTLOC(APCLLOC,0)),U,10)
..D SETREC^APCLSIL2
S ;NOW SET TOTAL IN PIECE 13
S X=0 F S X=$O(^APCLDATA($J,X)) Q:X'=+X D
.I $P(^APCLDATA($J,X),",",8)="" Q
.Q:$P(^APCLDATA($J,X),",",15)="H"
.S L=$P(^APCLDATA($J,X),",",6),D=$P(^APCLDATA($J,X),",",7)
.S $P(^APCLDATA($J,X),",",13)=+$G(^TMP($J,"APCLLOCT",L,D))
.Q
;NOW SET TOTAL IN PIECE 20
S X=0 F S X=$O(^APCLDATA($J,X)) Q:X'=+X D
.Q:$P(^APCLDATA($J,X),",",15)'="H"
.I $P(^APCLDATA($J,X),",",8)="",$P(^APCLDATA($J,X),U,43)=""
.S L=$P(^APCLDATA($J,X),",",6),D=$P(^APCLDATA($J,X),",",7)
.S $P(^APCLDATA($J,X),",",20)=+$G(^TMP($J,"APCLHTOT",L,D))
.Q
;NOW SET TOTAL IN PIECE 42
S X=0 F S X=$O(^APCLDATA($J,X)) Q:X'=+X D
.Q:$P(^APCLDATA($J,X),",",15)="H"
.I $P(^APCLDATA($J,X),",",43)="" Q ;not an H1N1/ili visit
.S L=$P(^APCLDATA($J,X),",",6),D=$P(^APCLDATA($J,X),",",7)
.S $P(^APCLDATA($J,X),",",42)=+$G(^TMP($J,"APCLALLT",L,D))
.Q
;NOW SET A RECORD FOR EACH DATE and populate 13, 20, 42
;NOW SEND A RECORD FOR EACH APCLALLT, SET PIECE 42,DATE AND LOCATION ONLY
;NOW SET A ZERO FOR EVERY DAY IN THE TIME PERIOD FOR EACH LOCATION IF IT DOESN'T EXIST
S APCLSD=$$FMADD^XLFDT(APCLBDAT,-1)
S L="" F S L=$O(^TMP($J,"APCLALL1",L)) Q:L="" D
.S D=APCLSD
.F S D=$$FMADD^XLFDT(D,1) Q:D>APCLED D
..I '$D(^TMP($J,"APCLALL1",L,D)) S ^TMP($J,"APCLALL1",L,D)=0
;now reorder by date
S L="" F S L=$O(^TMP($J,"APCLALL1",L)) Q:L="" S D="" F S D=$O(^TMP($J,"APCLALL1",L,D)) Q:D="" S ^TMP($J,"APCLX",D,L)=^TMP($J,"APCLALL1",L,D)
S X=0,C=0 F S X=$O(^APCLDATA($J,X)) Q:X'=+X S L=X
S C=L
S D=APCLSD F S D=$O(^TMP($J,"APCLX",D)) Q:D="" D ;IHS/CMI/LAB - "" to APCLSD PATCH 31 06/14/17
.S L="" F S L=$O(^TMP($J,"APCLX",D,L)) Q:L="" D
..S C=C+1
..S ^APCLDATA($J,C)="" D
...S $P(^APCLDATA($J,C),",",6)=L,$P(^APCLDATA($J,C),",",7)=D
...S $P(^APCLDATA($J,C),",",42)=+$G(^TMP($J,"APCLALLT",L,D))
...S $P(^APCLDATA($J,C),",",13)=+$G(^TMP($J,"APCLLOCT",L,D))
...S $P(^APCLDATA($J,C),",",20)=+$G(^TMP($J,"APCLHTOT",L,D))
D ILI^APCLSIHL("ILI") ;parse out the APCLDATA global and create a message
K ^APCLDATA($J),^TMP($J)
K ^XTMP("APCLILIV",$J)
MONUP ;monthly user pop if today is the 1st
I $G(APCLSCOM) D COMM^APCLSILU
I $G(APCL1ST) D
.;create entry with start date of DT
. N APCLFDA,APCLIENS,APCLERR
. S APCLIENS="+2,"_1_","
. S APCLFDA(9001003.311,APCLIENS,.01)=DT
. D UPDATE^DIE("","APCLFDA","APCLIENS","APCLERR(1)")
. ;I $D(APCLERR) S APCLER="0~Add Education Topic" Q
. S APCLEIEN=$G(APCLIENS(2))
. D MONUP^APCLSIL1
. ;ADD END DATE TO MULTIPLE
. S $P(^APCLILIC(1,11,APCLEIEN,0),U,2)=DT
D PURGE
D EXIT
Q
PROC1 ;
S ^XTMP("APCLILIV",$J,APCLV)=""
S APCLSTAT="A",APCLREAS=""
S APCLPRVE=0 I $D(^APCLILIL("B",APCLV)) S APCLPRVE=1,APCLSTAT="C" ;SET PREVIOUS EXPORT FIELD
Q:'$D(^AUPNVSIT(APCLV,0))
I $P(^AUPNVSIT(APCLV,0),U,11),'$D(^APCLILIL("B",APCLV)) Q ;DELETED AND NEVER SENT TO DON'T BOTHER
I $P(^AUPNVSIT(APCLV,0),U,11),$D(^APCLILIL("B",APCLV)) S APCLSTAT="D" D SR("VISIT HAS BEEN DELETED")
S DFN=$P(^AUPNVSIT(APCLV,0),U,5)
Q:DFN=""
Q:'$D(^DPT(DFN,0))
Q:$P(^DPT(DFN,0),U)["DEMO,PATIENT"
Q:$$DEMO^APCLUTL(DFN,"E")
S G=0,X=0 F S X=$O(^BGPSITE(X)) Q:X'=+X I $P($G(^BGPSITE(X,0)),U,12) I $D(^DIBT($P(^BGPSITE(X,0),U,12),1,DFN)) S G=1
Q:G
S APCLKV=0,APCLH1N1=0,(APCLILI,APCLHVAC,APCLIVAC,APCLADVE,APCLSRD,APCLAVM,APCLAV9)=""
S APCLLOC=$P(^AUPNVSIT(APCLV,0),U,6) Q:APCLLOC=""
S APCLDATE=$P($P(^AUPNVSIT(APCLV,0),U),".")
S APCLASUF=$P($G(^AUTTLOC(APCLLOC,0)),U,10)
Q:APCLASUF=""
S ^TMP($J,"APCLALL1",APCLASUF,APCLDATE)=""
I "AORS"[$P(^AUPNVSIT(APCLV,0),U,7) S ^TMP($J,"APCLALLT",APCLASUF,APCLDATE)=$G(^TMP($J,"APCLALLT",APCLASUF,APCLDATE))+1 ;total number of visits
;keep visit?
S G=0 D ILIDX I G S APCLKV=1,APCLILI=G D SR("ILI DX")
S G=0 D H1N1DX I G S APCLKV=1,APCLH1N1=G D SR("H1N1 DX")
S APCLHVAC=$$HASVAC(APCLV) I APCLHVAC S APCLKV=1 D SR("H1N1 VACCINE")
S APCLIVAC=$$HASIVAC(APCLV) I APCLIVAC S APCLKV=1 D SR("SEASONAL FLU VACCINE")
S APCLPVAC=$$HASPVAC^APCLSIL4(APCLV) I APCLPVAC S APCLKV=1 D SR("PNEUMOCOCCAL VACCINE")
S APCLNVAC=$$HASNVAC^APCLSIL4(APCLV) I APCLNVAC S APCLKV=1 D SR("PANDEMIC VACCINE")
I APCLIVAC!(APCLHVAC)!(APCLNVAC) S APCLADVE=$$HASADVN6^APCLSIL4(APCLV,$P(APCLIVAC,U,5),$P(APCLHVAC,U,5)) ;this was changed in patch 29 to only put on flu/h1n1 vaccine records
S APCLOVAC="" I APCLADVE!(APCLPVAC) S APCLOVAC=$$OTHVAC^APCLSIL1(DFN,APCLDATE)
S APCLSRD=$$HASSRD7(APCLV) I APCLSRD S APCLKV=1 D SR("SEVERE RESP DISEASE")
S APCLAVM=$$HASAVM^APCLSIL4(APCLV) I APCLAVM S APCLKV=1 D SR("ANTIVRIAL MEDICATION")
;S APCLAV9=$$HASAV9(APCLV) I APCLAV9 S APCLKV=1
S APCLPCVF="" I APCLPVAC S APCLPCVF=$$PCVFEB^APCLSIL4(APCLV,$P(APCLPVAC,U,5))
S APCLPCVE="" I APCLPVAC S APCLPCVE=$$PCVECPEH^APCLSIL4(APCLV,$P(APCLPVAC,U,5))
S APCLPCVA="" I APCLPVAC S APCLPCVA=$$PCVANGIO^APCLSIL4(APCLV,$P(APCLPVAC,U,5))
S APCLPCVS="" I APCLPVAC S APCLPCVS=$$PCVASTH^APCLSIL4(APCLV,$P(APCLPVAC,U,5))
S APCLPCVI="" I APCLPVAC S APCLPCVI=$$PCVIMMUN^APCLSIL4(APCLV,$P(APCLPVAC,U,5))
I 'APCLKV,'$D(^APCLILIL("B",APCLV)) Q ;not a visit to export and never sent
I 'APCLKV,$D(^APCLILIL("B",APCLV)) S APCLSTAT="D" D SR("NO LONGER MEETS CRITERIA") ;DELETE AS PREVIOUSLY SENT AND NO LONGER TO BE SENT
D SETREC^APCLSIL2 ;set record
Q
SR(R) ;
Q:APCLREAS
S APCLREAS=$O(^APCLILIR("B",R,0))
Q
HASVAC(V) ;EP - get h1n1 vaccine
NEW C,X,Y,Z,T,L,M
S T=$O(^ATXAX("B","SURVEILLANCE H1N1 CVX CODES",0))
S C=0,X=0 F S X=$O(^AUPNVIMM("AD",V,X)) Q:X'=+X!(C) S Y=$P($G(^AUPNVIMM(X,0)),U) D
.Q:'Y
.Q:'$D(^AUTTIMM(Y,0))
.S Z=$P(^AUTTIMM(Y,0),U,3)
.Q:'$D(^ATXAX(T,21,"B",Z))
.S C=1_U_Z_U_$$VAL^XBDIQ1(9000010.11,X,.05) I $P(^AUPNVIMM(X,0),U,5),$D(^AUTTIML($P(^AUPNVIMM(X,0),U,5),0)) S C=C_U_$$VAL^XBDIQ1(9999999.41,$P(^AUPNVIMM(X,0),U,5),.02)
.S Z=$$VALI^XBDIQ1(9000010.11,X,1201)
.S $P(C,U,5)=$S(Z:$P(Z,".",1),1:$$VD^APCLV(V))
.Q
I C Q C
S T=$O(^ATXAX("B","SURVEILLANCE CPT H1N1",0))
S C=0,X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X S Y=$P($G(^AUPNVCPT(X,0)),U) D
.Q:'Y
.Q:'$$ICD^APCLSILU(Y,T,1)
.S C=1_U_$$VAL^XBDIQ1(9000010.18,X,.01)
Q C
HASIVAC(V) ;EP - get flu iz
NEW C,X,Y,Z,T
S T=$O(^ATXAX("B","SURVEILLANCE FLU CVX CODES",0))
S C=0,X=0 F S X=$O(^AUPNVIMM("AD",V,X)) Q:X'=+X S Y=$P($G(^AUPNVIMM(X,0)),U) D
.Q:'Y
.Q:'$D(^AUTTIMM(Y,0))
.S Z=$P(^AUTTIMM(Y,0),U,3)
.Q:'$D(^ATXAX(T,21,"B",Z))
.;
.S C=1_U_Z_U_$$VAL^XBDIQ1(9000010.11,X,.05) I $P(^AUPNVIMM(X,0),U,5),$D(^AUTTIML($P(^AUPNVIMM(X,0),U,5),0)) S C=C_U_$$VAL^XBDIQ1(9999999.41,$P(^AUPNVIMM(X,0),U,5),.02)
.S Z=$$VALI^XBDIQ1(9000010.11,X,1201)
.S $P(C,U,5)=$S(Z:$P(Z,".",1),1:$$VD^APCLV(V))
.Q
I C Q C
S T=$O(^ATXAX("B","BGP FLU IZ CVX CODES",0))
S C=0,X=0 F S X=$O(^AUPNVIMM("AD",V,X)) Q:X'=+X S Y=$P($G(^AUPNVIMM(X,0)),U) D
.Q:'Y
.Q:'$D(^AUTTIMM(Y,0))
.S Z=$P(^AUTTIMM(Y,0),U,3)
.Q:'$D(^ATXAX(T,21,"B",Z))
.;
.S C=1_U_Z_U_$$VAL^XBDIQ1(9000010.11,X,.05) I $P(^AUPNVIMM(X,0),U,5),$D(^AUTTIML($P(^AUPNVIMM(X,0),U,5),0)) S C=C_U_$$VAL^XBDIQ1(9999999.41,$P(^AUPNVIMM(X,0),U,5),.02)
.S Z=$$VALI^XBDIQ1(9000010.11,X,1201)
.S $P(C,U,5)=$S(Z:$P(Z,".",1),1:$$VD^APCLV(V))
.Q
I C Q C
S T=$O(^ATXAX("B","SURVEILLANCE CPT FLU",0))
S T1=$O(^ATXAX("B","BGP CPT FLU",0))
S C=0,X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X S Y=$P($G(^AUPNVCPT(X,0)),U) D
.Q:'Y
.I '$$ICD^APCLSILU(Y,T,1),'$$ICD^APCLSILU(Y,T1,1) Q
.S C=1_U_$$VAL^XBDIQ1(9000010.18,X,.01)
I C Q C
S T=$O(^ATXAX("B","BGP FLU IZ PROCEDURES",0))
S C=0,X=0 F S X=$O(^AUPNVPRC("AD",V,X)) Q:X'=+X S Y=$P($G(^AUPNVPRC(X,0)),U) D
.Q:'Y
.Q:'$$ICD^APCLSILU(Y,T,0)
.S C=1_U_$$VAL^XBDIQ1(9000010.08,X,.01)
I C Q C
S T=$O(^ATXAX("B","BGP FLU IZ DXS",0))
S C=0,X=0 F S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X S Y=$P($G(^AUPNVPOV(X,0)),U) D
.Q:'Y
.Q:'$$ICD^APCLSILU(Y,T,9)
.S C=1_U_$$VAL^XBDIQ1(9000010.07,X,.01)
I C Q C
Q C
ILIDX ;
Q:"AORSH"'[$P(^AUPNVSIT(APCLV,0),U,7)
I $P(^AUPNVSIT(APCLV,0),U,7)="H" S ^TMP($J,"APCLHTOT",APCLASUF,APCLDATE)=$G(^TMP($J,"APCLHTOT",APCLASUF,APCLDATE))+1
S APCLCLIN=$$CLINIC^APCLV(APCLV,"I") ;
S X=0,P=0 F S X=$O(^AUPNVPRV("AD",APCLV,X)) Q:X'=+X!(P) D
.Q:'$D(^AUPNVPRV(X,0))
.S Y=$P(^AUPNVPRV(X,0),U)
.S Z=$$VALI^XBDIQ1(200,Y,53.5)
.Q:'Z
.I $P($G(^DIC(7,Z,9999999)),U,1)=13 S P=1
I P G ILIDX1
I $P(^AUPNVSIT(APCLV,0),U,7)'="H" Q:APCLCLIN=""
I $P(^AUPNVSIT(APCLV,0),U,7)'="H" Q:'$D(^ATXAX(APCLCTAX,21,"B",APCLCLIN)) ;not in clinic taxonomy
ILIDX1 ;
I $P(^AUPNVSIT(APCLV,0),U,7)'="H" S ^TMP($J,"APCLLOCT",APCLASUF,APCLDATE)=$G(^TMP($J,"APCLLOCT",APCLASUF,APCLDATE))+1 ;total number of visits
;CHECK SURVEILLANCE ILI NO TMP NEEDED FIRST
;THEN CHECK SURVEILLANCE ILI AND SEE IF TMP >=100
S C=0
K G,Y,Z S G="",Z=""
S X=0 F S X=$O(^AUPNVPOV("AD",APCLV,X)) Q:X'=+X D
.S T=$P(^AUPNVPOV(X,0),U)
.I $$ICD^APCLSILU(T,APCLTTAX,9) S C=C+1,Y(C)=$$VAL^XBDIQ1(9000010.07,X,.01) Q
.I $$ICD^APCLSILU(T,APCLDTAX,9),$$TMP100(APCLV) S C=C+1,Y(C)=$$VAL^XBDIQ1(9000010.07,X,.01)
Q:'$D(Y)
S X=0 F S X=$O(Y(X)) Q:X'=+X S G=G_U_Y(X)
S $P(G,U,1)=1
Q
TMP100(V) ;EP
NEW %,M,J
S %=""
S M=0 F S M=$O(^AUPNVMSR("AD",V,M)) Q:M'=+M D
.Q:$P($G(^AUPNVMSR(M,2)),U,1)
.Q:$$VAL^XBDIQ1(9000010.01,M,.01)'="TMP"
.S J=$P(^AUPNVMSR(M,0),U,4)
.Q:J<100
.S %=1
Q %
;
H1N1DX ;
Q:"AORSH"'[$P(^AUPNVSIT(APCLV,0),U,7) ;just want outpatient with dx
S APCLCLIN=$$CLINIC^APCLV(APCLV,"I")
S G=0
S X=0 F S X=$O(^AUPNVPOV("AD",APCLV,X)) Q:X'=+X!(G) S T=$P(^AUPNVPOV(X,0),U) I $$ICD^APCLSILU(T,$O(^ATXAX("B","SURVEILLANCE H1N1 DX",0)),9) S G=1,D=$$VAL^XBDIQ1(9000010.07,X,.01)
Q:'G
S G=1_U_D
Q
HASSRD7(APCLV) ;EP
NEW X,P,D,Y,Z,APCLCLIN,T,G,C
I "AORSH"'[$P(^AUPNVSIT(APCLV,0),U,7) Q "" ;just want outpatient with dx
S C=0
K G,Y S G=""
S X=0 F S X=$O(^AUPNVPOV("AD",APCLV,X)) Q:X'=+X S T=$P(^AUPNVPOV(X,0),U) I $$ICD^APCLSILU(T,$O(^ATXAX("B","SURVEILLANCE SEV RESP DIS DXS",0)),9) S C=C+1,Y(C)=$$VAL^XBDIQ1(9000010.07,X,.01)
I '$D(Y) Q ""
S X=0 F S X=$O(Y(X)) Q:X'=+X S G=G_U_Y(X)
S $P(G,U,1)=1
Q G
;
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(APCLA) ;Given DFN return unique patient record id.
I '$G(APCLA) Q ""
I '$D(^AUPNPAT(APCLA)) Q ""
;
Q $$GET1^DIQ(9999999.06,$P(^AUTTSITE(1,0),U),.32)_$E("0000000000",1,10-$L(APCLA))_APCLA
;
EXIT ;clean up and exit
D EN^XBVK("APCL")
D ^XBFMK
K ^XTMP("APCLILITAX",$J)
K ^XTMP("APCLILIV",$J)
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 -
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
STOPD ;EP
D STOPD^APCLSIL3
Q
PURGE ;
D PURGE^APCLSIL3
Q
APCLSILI ; IHS/CMI/LAB - ILI surveillance export ; 27 Jun 2017 2:26 PM
+1 ;;3.0;IHS PCC REPORTS;**22,23,24,25,26,27,28,29,30,31**;FEB 05, 1997;Build 32
+2 ;
+3 ;
START ;
+1 ;ili surveillance export, runs nightly, see design doc from ILI team for
+2 ;details
+3 ;
+4 ;
+5 DO EN^XBVK("APCL")
+6 SET D=""
+7 SET X=$ORDER(^APCLCNTL("B","ILI STOP DATE",0))
+8 ;if there is a stop date then use it
IF X
IF $PIECE(^APCLCNTL(X,0),U,3)
SET D=$PIECE(^APCLCNTL(X,0),U,3)
+9 IF D
IF DT>D
QUIT
+10 ;
+11 DO EXIT
+12 ;
+13 ;
PROC ;EP - called from xbdbque
+1 SET APCL1ST=""
SET APCLSCOM=""
+2 IF $EXTRACT(DT,6,7)="01"
SET APCL1ST=1
+3 ;I $P($G(^APCLILIC(1,0)),U,2) S APCL1ST=1 ;need to send data first time through after the patch is installed
+4 ;if this is between the 15th and 27th then check to see if the user pop export has been run
+5 ;if it has run since the 1st of the month then run it.
+6 ;get the 1st of this month
+7 SET APCL1OM=$EXTRACT(DT,1,5)_"01"
+8 ;get date last one finished.
+9 SET (X,L)=""
FOR
SET X=$ORDER(^APCLILIC(1,11,"B",X))
IF X'=+X
QUIT
SET L=X
+10 ;hasn't run before after patch 27 so run it
IF 'L
SET APCL1ST=1
+11 ;if last time run was before the 1st then run it
IF 'APCL1ST
IF $EXTRACT(DT,6,7)>14
IF $EXTRACT(DT,6,7)<27
IF L<APCL1OM
SET APCL1ST=1
+12 IF $EXTRACT(DT,4,7)="0710"!($EXTRACT(DT,4,7)="1210")
SET APCLSCOM=1
+13 KILL APCLLOCT,APCLALLT,APCLHTOT,APCLALL1
+14 KILL ^TMP($JOB)
+15 KILL ^APCLDATA($JOB)
+16 SET APCLCTAX=$ORDER(^ATXAX("B","SURVEILLANCE ILI CLINICS",0))
+17 ;dx taxonomy
SET APCLDTAX=$ORDER(^ATXAX("B","SURVEILLANCE ILI",0))
+18 SET APCLTTAX=$ORDER(^ATXAX("B","SURVEILLANCE ILI NO TMP NEEDED",0))
+19 IF 'APCLCTAX
DO EXIT
QUIT
+20 IF 'APCLDTAX
DO EXIT
QUIT
+21 ;
+22 IF '$PIECE($GET(^APCLILIC(1,0)),U,4)
Begin DoDot:1
+23 SET (APCLSD,APCLDELD)=3081231.9999
SET $PIECE(^APCLILIC(1,0),U,4)=1
SET APCLBDAT=3090101
SET APCLFLF=1
SET APCL1ST=1
SET APCLSCOM=1
End DoDot:1
IF 1
+24 IF '$TEST
SET (APCLSD,APCLDELD)=$$FMADD^XLFDT(DT,-91)_".9999"
SET APCLBDAT=$$FMADD^XLFDT(DT,-90)
+25 SET APCLED=$$FMADD^XLFDT(DT,-1)
+26 SET APCLZHSD=DT
EP1 ;EP - called from on demand option
+1 ;wipe out log? - yes per Deborah
+2 IF $GET(APCLFLF)
Begin DoDot:1
+3 SET APCLX=0
FOR
SET APCLX=$ORDER(^APCLILIL(APCLX))
IF APCLX'=+APCLX
QUIT
SET DA=APCLX
SET DIK="^APCLILIL("
DO ^DIK
End DoDot:1
+4 DO UNFOLDTX^APCLSILU
+5 KILL ^XTMP("APCLILIV",$JOB)
+6 IF $GET(APCLWEXP)="P"
GOTO MONUP
+7 SET APCLVTOT=0
+8 SET APCLBT=$HOROLOG
+9 SET APCLDELD=APCLSD
+10 FOR
SET APCLSD=$ORDER(^AUPNVSIT("B",APCLSD))
IF APCLSD'=+APCLSD!($PIECE(APCLSD,".")>APCLED)
QUIT
Begin DoDot:1
+11 SET APCLV=0
FOR
SET APCLV=$ORDER(^AUPNVSIT("B",APCLSD,APCLV))
IF APCLV'=+APCLV
QUIT
DO PROC1
End DoDot:1
+12 ;now go through ADLM and if exported before and not already dealt with d proc1 SKIP IF THIS IS A FULL BACKLOAD
+13 IF $GET(APCLFLF)
GOTO S
+14 SET APCLSD=APCLDELD
+15 FOR
SET APCLSD=$ORDER(^AUPNVSIT("ADLM",APCLSD))
IF APCLSD'=+APCLSD!($PIECE(APCLSD,".")>APCLED)
QUIT
Begin DoDot:1
+16 SET APCLV=0
FOR
SET APCLV=$ORDER(^AUPNVSIT("ADLM",APCLSD,APCLV))
IF APCLV'=+APCLV
QUIT
Begin DoDot:2
+17 ;already processed
IF $DATA(^XTMP("APCLILIV",$JOB,APCLV))
QUIT
+18 ;only want visits after 1/1/09
IF $$VD^APCLV(APCLV)<3090101
QUIT
+19 ;I '$D(^APCLILIL(APCLV)) Q ;;never sent so no need to process
+20 DO PROC1
End DoDot:2
End DoDot:1
+21 ;NOW GO THROUGH AVDEL XREF FOR DELETES SKIP IF THIS IS A FULL EXPORT
+22 SET APCLSD=APCLDELD
+23 FOR
SET APCLSD=$ORDER(^AUPNVSIT("AVDEL",APCLSD))
IF APCLSD'=+APCLSD!($PIECE(APCLSD,".")>APCLED)
QUIT
Begin DoDot:1
+24 SET APCLV=0
FOR
SET APCLV=$ORDER(^AUPNVSIT("AVDEL",APCLSD,APCLV))
IF APCLV'=+APCLV
QUIT
Begin DoDot:2
+25 ;never exported so no need to send delete
IF '$DATA(^APCLILIL(APCLV))
QUIT
+26 IF $PIECE(^AUPNVSIT(APCLV,0),U,11)
IF $DATA(^APCLILIL("B",APCLV))
SET APCLSTAT="D"
DO SR("VISIT HAS BEEN DELETED")
+27 SET DFN=$PIECE(^AUPNVSIT(APCLV,0),U,5)
+28 SET APCLLOC=$PIECE(^AUPNVSIT(APCLV,0),U,6)
+29 SET APCLKV=0
SET APCLH1N1=0
SET (APCLILI,APCLHVAC,APCLIVAC,APCLADVE,APCLSRD,APCLAVM,APCLAV9)=""
+30 SET APCLLOC=$PIECE(^AUPNVSIT(APCLV,0),U,6)
IF APCLLOC=""
QUIT
+31 SET APCLDATE=$PIECE($PIECE(^AUPNVSIT(APCLV,0),U),".")
+32 SET APCLASUF=$PIECE($GET(^AUTTLOC(APCLLOC,0)),U,10)
+33 DO SETREC^APCLSIL2
End DoDot:2
End DoDot:1
S ;NOW SET TOTAL IN PIECE 13
+1 SET X=0
FOR
SET X=$ORDER(^APCLDATA($JOB,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 IF $PIECE(^APCLDATA($JOB,X),",",8)=""
QUIT
+3 IF $PIECE(^APCLDATA($JOB,X),",",15)="H"
QUIT
+4 SET L=$PIECE(^APCLDATA($JOB,X),",",6)
SET D=$PIECE(^APCLDATA($JOB,X),",",7)
+5 SET $PIECE(^APCLDATA($JOB,X),",",13)=+$GET(^TMP($JOB,"APCLLOCT",L,D))
+6 QUIT
End DoDot:1
+7 ;NOW SET TOTAL IN PIECE 20
+8 SET X=0
FOR
SET X=$ORDER(^APCLDATA($JOB,X))
IF X'=+X
QUIT
Begin DoDot:1
+9 IF $PIECE(^APCLDATA($JOB,X),",",15)'="H"
QUIT
+10 IF $PIECE(^APCLDATA($JOB,X),",",8)=""
IF $PIECE(^APCLDATA($JOB,X),U,43)=""
+11 SET L=$PIECE(^APCLDATA($JOB,X),",",6)
SET D=$PIECE(^APCLDATA($JOB,X),",",7)
+12 SET $PIECE(^APCLDATA($JOB,X),",",20)=+$GET(^TMP($JOB,"APCLHTOT",L,D))
+13 QUIT
End DoDot:1
+14 ;NOW SET TOTAL IN PIECE 42
+15 SET X=0
FOR
SET X=$ORDER(^APCLDATA($JOB,X))
IF X'=+X
QUIT
Begin DoDot:1
+16 IF $PIECE(^APCLDATA($JOB,X),",",15)="H"
QUIT
+17 ;not an H1N1/ili visit
IF $PIECE(^APCLDATA($JOB,X),",",43)=""
QUIT
+18 SET L=$PIECE(^APCLDATA($JOB,X),",",6)
SET D=$PIECE(^APCLDATA($JOB,X),",",7)
+19 SET $PIECE(^APCLDATA($JOB,X),",",42)=+$GET(^TMP($JOB,"APCLALLT",L,D))
+20 QUIT
End DoDot:1
+21 ;NOW SET A RECORD FOR EACH DATE and populate 13, 20, 42
+22 ;NOW SEND A RECORD FOR EACH APCLALLT, SET PIECE 42,DATE AND LOCATION ONLY
+23 ;NOW SET A ZERO FOR EVERY DAY IN THE TIME PERIOD FOR EACH LOCATION IF IT DOESN'T EXIST
+24 SET APCLSD=$$FMADD^XLFDT(APCLBDAT,-1)
+25 SET L=""
FOR
SET L=$ORDER(^TMP($JOB,"APCLALL1",L))
IF L=""
QUIT
Begin DoDot:1
+26 SET D=APCLSD
+27 FOR
SET D=$$FMADD^XLFDT(D,1)
IF D>APCLED
QUIT
Begin DoDot:2
+28 IF '$DATA(^TMP($JOB,"APCLALL1",L,D))
SET ^TMP($JOB,"APCLALL1",L,D)=0
End DoDot:2
End DoDot:1
+29 ;now reorder by date
+30 SET L=""
FOR
SET L=$ORDER(^TMP($JOB,"APCLALL1",L))
IF L=""
QUIT
SET D=""
FOR
SET D=$ORDER(^TMP($JOB,"APCLALL1",L,D))
IF D=""
QUIT
SET ^TMP($JOB,"APCLX",D,L)=^TMP($JOB,"APCLALL1",L,D)
+31 SET X=0
SET C=0
FOR
SET X=$ORDER(^APCLDATA($JOB,X))
IF X'=+X
QUIT
SET L=X
+32 SET C=L
+33 ;IHS/CMI/LAB - "" to APCLSD PATCH 31 06/14/17
SET D=APCLSD
FOR
SET D=$ORDER(^TMP($JOB,"APCLX",D))
IF D=""
QUIT
Begin DoDot:1
+34 SET L=""
FOR
SET L=$ORDER(^TMP($JOB,"APCLX",D,L))
IF L=""
QUIT
Begin DoDot:2
+35 SET C=C+1
+36 SET ^APCLDATA($JOB,C)=""
Begin DoDot:3
+37 SET $PIECE(^APCLDATA($JOB,C),",",6)=L
SET $PIECE(^APCLDATA($JOB,C),",",7)=D
+38 SET $PIECE(^APCLDATA($JOB,C),",",42)=+$GET(^TMP($JOB,"APCLALLT",L,D))
+39 SET $PIECE(^APCLDATA($JOB,C),",",13)=+$GET(^TMP($JOB,"APCLLOCT",L,D))
+40 SET $PIECE(^APCLDATA($JOB,C),",",20)=+$GET(^TMP($JOB,"APCLHTOT",L,D))
End DoDot:3
End DoDot:2
End DoDot:1
+41 ;parse out the APCLDATA global and create a message
DO ILI^APCLSIHL("ILI")
+42 KILL ^APCLDATA($JOB),^TMP($JOB)
+43 KILL ^XTMP("APCLILIV",$JOB)
MONUP ;monthly user pop if today is the 1st
+1 IF $GET(APCLSCOM)
DO COMM^APCLSILU
+2 IF $GET(APCL1ST)
Begin DoDot:1
+3 ;create entry with start date of DT
+4 NEW APCLFDA,APCLIENS,APCLERR
+5 SET APCLIENS="+2,"_1_","
+6 SET APCLFDA(9001003.311,APCLIENS,.01)=DT
+7 DO UPDATE^DIE("","APCLFDA","APCLIENS","APCLERR(1)")
+8 ;I $D(APCLERR) S APCLER="0~Add Education Topic" Q
+9 SET APCLEIEN=$GET(APCLIENS(2))
+10 DO MONUP^APCLSIL1
+11 ;ADD END DATE TO MULTIPLE
+12 SET $PIECE(^APCLILIC(1,11,APCLEIEN,0),U,2)=DT
End DoDot:1
+13 DO PURGE
+14 DO EXIT
+15 QUIT
PROC1 ;
+1 SET ^XTMP("APCLILIV",$JOB,APCLV)=""
+2 SET APCLSTAT="A"
SET APCLREAS=""
+3 ;SET PREVIOUS EXPORT FIELD
SET APCLPRVE=0
IF $DATA(^APCLILIL("B",APCLV))
SET APCLPRVE=1
SET APCLSTAT="C"
+4 IF '$DATA(^AUPNVSIT(APCLV,0))
QUIT
+5 ;DELETED AND NEVER SENT TO DON'T BOTHER
IF $PIECE(^AUPNVSIT(APCLV,0),U,11)
IF '$DATA(^APCLILIL("B",APCLV))
QUIT
+6 IF $PIECE(^AUPNVSIT(APCLV,0),U,11)
IF $DATA(^APCLILIL("B",APCLV))
SET APCLSTAT="D"
DO SR("VISIT HAS BEEN DELETED")
+7 SET DFN=$PIECE(^AUPNVSIT(APCLV,0),U,5)
+8 IF DFN=""
QUIT
+9 IF '$DATA(^DPT(DFN,0))
QUIT
+10 IF $PIECE(^DPT(DFN,0),U)["DEMO,PATIENT"
QUIT
+11 IF $$DEMO^APCLUTL(DFN,"E")
QUIT
+12 SET G=0
SET X=0
FOR
SET X=$ORDER(^BGPSITE(X))
IF X'=+X
QUIT
IF $PIECE($GET(^BGPSITE(X,0)),U,12)
IF $DATA(^DIBT($PIECE(^BGPSITE(X,0),U,12),1,DFN))
SET G=1
+13 IF G
QUIT
+14 SET APCLKV=0
SET APCLH1N1=0
SET (APCLILI,APCLHVAC,APCLIVAC,APCLADVE,APCLSRD,APCLAVM,APCLAV9)=""
+15 SET APCLLOC=$PIECE(^AUPNVSIT(APCLV,0),U,6)
IF APCLLOC=""
QUIT
+16 SET APCLDATE=$PIECE($PIECE(^AUPNVSIT(APCLV,0),U),".")
+17 SET APCLASUF=$PIECE($GET(^AUTTLOC(APCLLOC,0)),U,10)
+18 IF APCLASUF=""
QUIT
+19 SET ^TMP($JOB,"APCLALL1",APCLASUF,APCLDATE)=""
+20 ;total number of visits
IF "AORS"[$PIECE(^AUPNVSIT(APCLV,0),U,7)
SET ^TMP($JOB,"APCLALLT",APCLASUF,APCLDATE)=$GET(^TMP($JOB,"APCLALLT",APCLASUF,APCLDATE))+1
+21 ;keep visit?
+22 SET G=0
DO ILIDX
IF G
SET APCLKV=1
SET APCLILI=G
DO SR("ILI DX")
+23 SET G=0
DO H1N1DX
IF G
SET APCLKV=1
SET APCLH1N1=G
DO SR("H1N1 DX")
+24 SET APCLHVAC=$$HASVAC(APCLV)
IF APCLHVAC
SET APCLKV=1
DO SR("H1N1 VACCINE")
+25 SET APCLIVAC=$$HASIVAC(APCLV)
IF APCLIVAC
SET APCLKV=1
DO SR("SEASONAL FLU VACCINE")
+26 SET APCLPVAC=$$HASPVAC^APCLSIL4(APCLV)
IF APCLPVAC
SET APCLKV=1
DO SR("PNEUMOCOCCAL VACCINE")
+27 SET APCLNVAC=$$HASNVAC^APCLSIL4(APCLV)
IF APCLNVAC
SET APCLKV=1
DO SR("PANDEMIC VACCINE")
+28 ;this was changed in patch 29 to only put on flu/h1n1 vaccine records
IF APCLIVAC!(APCLHVAC)!(APCLNVAC)
SET APCLADVE=$$HASADVN6^APCLSIL4(APCLV,$PIECE(APCLIVAC,U,5),$PIECE(APCLHVAC,U,5))
+29 SET APCLOVAC=""
IF APCLADVE!(APCLPVAC)
SET APCLOVAC=$$OTHVAC^APCLSIL1(DFN,APCLDATE)
+30 SET APCLSRD=$$HASSRD7(APCLV)
IF APCLSRD
SET APCLKV=1
DO SR("SEVERE RESP DISEASE")
+31 SET APCLAVM=$$HASAVM^APCLSIL4(APCLV)
IF APCLAVM
SET APCLKV=1
DO SR("ANTIVRIAL MEDICATION")
+32 ;S APCLAV9=$$HASAV9(APCLV) I APCLAV9 S APCLKV=1
+33 SET APCLPCVF=""
IF APCLPVAC
SET APCLPCVF=$$PCVFEB^APCLSIL4(APCLV,$PIECE(APCLPVAC,U,5))
+34 SET APCLPCVE=""
IF APCLPVAC
SET APCLPCVE=$$PCVECPEH^APCLSIL4(APCLV,$PIECE(APCLPVAC,U,5))
+35 SET APCLPCVA=""
IF APCLPVAC
SET APCLPCVA=$$PCVANGIO^APCLSIL4(APCLV,$PIECE(APCLPVAC,U,5))
+36 SET APCLPCVS=""
IF APCLPVAC
SET APCLPCVS=$$PCVASTH^APCLSIL4(APCLV,$PIECE(APCLPVAC,U,5))
+37 SET APCLPCVI=""
IF APCLPVAC
SET APCLPCVI=$$PCVIMMUN^APCLSIL4(APCLV,$PIECE(APCLPVAC,U,5))
+38 ;not a visit to export and never sent
IF 'APCLKV
IF '$DATA(^APCLILIL("B",APCLV))
QUIT
+39 ;DELETE AS PREVIOUSLY SENT AND NO LONGER TO BE SENT
IF 'APCLKV
IF $DATA(^APCLILIL("B",APCLV))
SET APCLSTAT="D"
DO SR("NO LONGER MEETS CRITERIA")
+40 ;set record
DO SETREC^APCLSIL2
+41 QUIT
SR(R) ;
+1 IF APCLREAS
QUIT
+2 SET APCLREAS=$ORDER(^APCLILIR("B",R,0))
+3 QUIT
HASVAC(V) ;EP - get h1n1 vaccine
+1 NEW C,X,Y,Z,T,L,M
+2 SET T=$ORDER(^ATXAX("B","SURVEILLANCE H1N1 CVX CODES",0))
+3 SET C=0
SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AD",V,X))
IF X'=+X!(C)
QUIT
SET Y=$PIECE($GET(^AUPNVIMM(X,0)),U)
Begin DoDot:1
+4 IF 'Y
QUIT
+5 IF '$DATA(^AUTTIMM(Y,0))
QUIT
+6 SET Z=$PIECE(^AUTTIMM(Y,0),U,3)
+7 IF '$DATA(^ATXAX(T,21,"B",Z))
QUIT
+8 SET C=1_U_Z_U_$$VAL^XBDIQ1(9000010.11,X,.05)
IF $PIECE(^AUPNVIMM(X,0),U,5)
IF $DATA(^AUTTIML($PIECE(^AUPNVIMM(X,0),U,5),0))
SET C=C_U_$$VAL^XBDIQ1(9999999.41,$PIECE(^AUPNVIMM(X,0),U,5),.02)
+9 SET Z=$$VALI^XBDIQ1(9000010.11,X,1201)
+10 SET $PIECE(C,U,5)=$SELECT(Z:$PIECE(Z,".",1),1:$$VD^APCLV(V))
+11 QUIT
End DoDot:1
+12 IF C
QUIT C
+13 SET T=$ORDER(^ATXAX("B","SURVEILLANCE CPT H1N1",0))
+14 SET C=0
SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
SET Y=$PIECE($GET(^AUPNVCPT(X,0)),U)
Begin DoDot:1
+15 IF 'Y
QUIT
+16 IF '$$ICD^APCLSILU(Y,T,1)
QUIT
+17 SET C=1_U_$$VAL^XBDIQ1(9000010.18,X,.01)
End DoDot:1
+18 QUIT C
HASIVAC(V) ;EP - get flu iz
+1 NEW C,X,Y,Z,T
+2 SET T=$ORDER(^ATXAX("B","SURVEILLANCE FLU CVX CODES",0))
+3 SET C=0
SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AD",V,X))
IF X'=+X
QUIT
SET Y=$PIECE($GET(^AUPNVIMM(X,0)),U)
Begin DoDot:1
+4 IF 'Y
QUIT
+5 IF '$DATA(^AUTTIMM(Y,0))
QUIT
+6 SET Z=$PIECE(^AUTTIMM(Y,0),U,3)
+7 IF '$DATA(^ATXAX(T,21,"B",Z))
QUIT
+8 ;
+9 SET C=1_U_Z_U_$$VAL^XBDIQ1(9000010.11,X,.05)
IF $PIECE(^AUPNVIMM(X,0),U,5)
IF $DATA(^AUTTIML($PIECE(^AUPNVIMM(X,0),U,5),0))
SET C=C_U_$$VAL^XBDIQ1(9999999.41,$PIECE(^AUPNVIMM(X,0),U,5),.02)
+10 SET Z=$$VALI^XBDIQ1(9000010.11,X,1201)
+11 SET $PIECE(C,U,5)=$SELECT(Z:$PIECE(Z,".",1),1:$$VD^APCLV(V))
+12 QUIT
End DoDot:1
+13 IF C
QUIT C
+14 SET T=$ORDER(^ATXAX("B","BGP FLU IZ CVX CODES",0))
+15 SET C=0
SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AD",V,X))
IF X'=+X
QUIT
SET Y=$PIECE($GET(^AUPNVIMM(X,0)),U)
Begin DoDot:1
+16 IF 'Y
QUIT
+17 IF '$DATA(^AUTTIMM(Y,0))
QUIT
+18 SET Z=$PIECE(^AUTTIMM(Y,0),U,3)
+19 IF '$DATA(^ATXAX(T,21,"B",Z))
QUIT
+20 ;
+21 SET C=1_U_Z_U_$$VAL^XBDIQ1(9000010.11,X,.05)
IF $PIECE(^AUPNVIMM(X,0),U,5)
IF $DATA(^AUTTIML($PIECE(^AUPNVIMM(X,0),U,5),0))
SET C=C_U_$$VAL^XBDIQ1(9999999.41,$PIECE(^AUPNVIMM(X,0),U,5),.02)
+22 SET Z=$$VALI^XBDIQ1(9000010.11,X,1201)
+23 SET $PIECE(C,U,5)=$SELECT(Z:$PIECE(Z,".",1),1:$$VD^APCLV(V))
+24 QUIT
End DoDot:1
+25 IF C
QUIT C
+26 SET T=$ORDER(^ATXAX("B","SURVEILLANCE CPT FLU",0))
+27 SET T1=$ORDER(^ATXAX("B","BGP CPT FLU",0))
+28 SET C=0
SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
SET Y=$PIECE($GET(^AUPNVCPT(X,0)),U)
Begin DoDot:1
+29 IF 'Y
QUIT
+30 IF '$$ICD^APCLSILU(Y,T,1)
IF '$$ICD^APCLSILU(Y,T1,1)
QUIT
+31 SET C=1_U_$$VAL^XBDIQ1(9000010.18,X,.01)
End DoDot:1
+32 IF C
QUIT C
+33 SET T=$ORDER(^ATXAX("B","BGP FLU IZ PROCEDURES",0))
+34 SET C=0
SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",V,X))
IF X'=+X
QUIT
SET Y=$PIECE($GET(^AUPNVPRC(X,0)),U)
Begin DoDot:1
+35 IF 'Y
QUIT
+36 IF '$$ICD^APCLSILU(Y,T,0)
QUIT
+37 SET C=1_U_$$VAL^XBDIQ1(9000010.08,X,.01)
End DoDot:1
+38 IF C
QUIT C
+39 SET T=$ORDER(^ATXAX("B","BGP FLU IZ DXS",0))
+40 SET C=0
SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",V,X))
IF X'=+X
QUIT
SET Y=$PIECE($GET(^AUPNVPOV(X,0)),U)
Begin DoDot:1
+41 IF 'Y
QUIT
+42 IF '$$ICD^APCLSILU(Y,T,9)
QUIT
+43 SET C=1_U_$$VAL^XBDIQ1(9000010.07,X,.01)
End DoDot:1
+44 IF C
QUIT C
+45 QUIT C
ILIDX ;
+1 IF "AORSH"'[$PIECE(^AUPNVSIT(APCLV,0),U,7)
QUIT
+2 IF $PIECE(^AUPNVSIT(APCLV,0),U,7)="H"
SET ^TMP($JOB,"APCLHTOT",APCLASUF,APCLDATE)=$GET(^TMP($JOB,"APCLHTOT",APCLASUF,APCLDATE))+1
+3 ;
SET APCLCLIN=$$CLINIC^APCLV(APCLV,"I")
+4 SET X=0
SET P=0
FOR
SET X=$ORDER(^AUPNVPRV("AD",APCLV,X))
IF X'=+X!(P)
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUPNVPRV(X,0))
QUIT
+6 SET Y=$PIECE(^AUPNVPRV(X,0),U)
+7 SET Z=$$VALI^XBDIQ1(200,Y,53.5)
+8 IF 'Z
QUIT
+9 IF $PIECE($GET(^DIC(7,Z,9999999)),U,1)=13
SET P=1
End DoDot:1
+10 IF P
GOTO ILIDX1
+11 IF $PIECE(^AUPNVSIT(APCLV,0),U,7)'="H"
IF APCLCLIN=""
QUIT
+12 ;not in clinic taxonomy
IF $PIECE(^AUPNVSIT(APCLV,0),U,7)'="H"
IF '$DATA(^ATXAX(APCLCTAX,21,"B",APCLCLIN))
QUIT
ILIDX1 ;
+1 ;total number of visits
IF $PIECE(^AUPNVSIT(APCLV,0),U,7)'="H"
SET ^TMP($JOB,"APCLLOCT",APCLASUF,APCLDATE)=$GET(^TMP($JOB,"APCLLOCT",APCLASUF,APCLDATE))+1
+2 ;CHECK SURVEILLANCE ILI NO TMP NEEDED FIRST
+3 ;THEN CHECK SURVEILLANCE ILI AND SEE IF TMP >=100
+4 SET C=0
+5 KILL G,Y,Z
SET G=""
SET Z=""
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",APCLV,X))
IF X'=+X
QUIT
Begin DoDot:1
+7 SET T=$PIECE(^AUPNVPOV(X,0),U)
+8 IF $$ICD^APCLSILU(T,APCLTTAX,9)
SET C=C+1
SET Y(C)=$$VAL^XBDIQ1(9000010.07,X,.01)
QUIT
+9 IF $$ICD^APCLSILU(T,APCLDTAX,9)
IF $$TMP100(APCLV)
SET C=C+1
SET Y(C)=$$VAL^XBDIQ1(9000010.07,X,.01)
End DoDot:1
+10 IF '$DATA(Y)
QUIT
+11 SET X=0
FOR
SET X=$ORDER(Y(X))
IF X'=+X
QUIT
SET G=G_U_Y(X)
+12 SET $PIECE(G,U,1)=1
+13 QUIT
TMP100(V) ;EP
+1 NEW %,M,J
+2 SET %=""
+3 SET M=0
FOR
SET M=$ORDER(^AUPNVMSR("AD",V,M))
IF M'=+M
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^AUPNVMSR(M,2)),U,1)
QUIT
+5 IF $$VAL^XBDIQ1(9000010.01,M,.01)'="TMP"
QUIT
+6 SET J=$PIECE(^AUPNVMSR(M,0),U,4)
+7 IF J<100
QUIT
+8 SET %=1
End DoDot:1
+9 QUIT %
+10 ;
H1N1DX ;
+1 ;just want outpatient with dx
IF "AORSH"'[$PIECE(^AUPNVSIT(APCLV,0),U,7)
QUIT
+2 SET APCLCLIN=$$CLINIC^APCLV(APCLV,"I")
+3 SET G=0
+4 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",APCLV,X))
IF X'=+X!(G)
QUIT
SET T=$PIECE(^AUPNVPOV(X,0),U)
IF $$ICD^APCLSILU(T,$ORDER(^ATXAX("B","SURVEILLANCE H1N1 DX",0)),9)
SET G=1
SET D=$$VAL^XBDIQ1(9000010.07,X,.01)
+5 IF 'G
QUIT
+6 SET G=1_U_D
+7 QUIT
HASSRD7(APCLV) ;EP
+1 NEW X,P,D,Y,Z,APCLCLIN,T,G,C
+2 ;just want outpatient with dx
IF "AORSH"'[$PIECE(^AUPNVSIT(APCLV,0),U,7)
QUIT ""
+3 SET C=0
+4 KILL G,Y
SET G=""
+5 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",APCLV,X))
IF X'=+X
QUIT
SET T=$PIECE(^AUPNVPOV(X,0),U)
IF $$ICD^APCLSILU(T,$ORDER(^ATXAX("B","SURVEILLANCE SEV RESP DIS DXS",0)),9)
SET C=C+1
SET Y(C)=$$VAL^XBDIQ1(9000010.07,X,.01)
+6 IF '$DATA(Y)
QUIT ""
+7 SET X=0
FOR
SET X=$ORDER(Y(X))
IF X'=+X
QUIT
SET G=G_U_Y(X)
+8 SET $PIECE(G,U,1)=1
+9 QUIT G
+10 ;
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(APCLA) ;Given DFN return unique patient record id.
+1 IF '$GET(APCLA)
QUIT ""
+2 IF '$DATA(^AUPNPAT(APCLA))
QUIT ""
+3 ;
+4 QUIT $$GET1^DIQ(9999999.06,$PIECE(^AUTTSITE(1,0),U),.32)_$EXTRACT("0000000000",1,10-$LENGTH(APCLA))_APCLA
+5 ;
EXIT ;clean up and exit
+1 DO EN^XBVK("APCL")
+2 DO ^XBFMK
+3 KILL ^XTMP("APCLILITAX",$JOB)
+4 KILL ^XTMP("APCLILIV",$JOB)
+5 QUIT
+6 ;
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 -
+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 ;----------
STOPD ;EP
+1 DO STOPD^APCLSIL3
+2 QUIT
PURGE ;
+1 DO PURGE^APCLSIL3
+2 QUIT
