APCSSIL1 ;IHS/CMI/LAB - ILI SURVEILLANCE;
;;2.0;IHS PCC SUITE;**5**;MAY 14, 2009
;
PN(P,V) ;EP
I $P(^DPT(P,0),U,2)'="F" Q ""
NEW T,X,Y,Q,ED,BD,APCS,LPD,%,G
S ED=$$VD^APCLV(V)
S BD=$$FMADD^XLFDT(ED,-60)
S G=""
S T=$O(^ATXAX("B","SURVEILLANCE H1N1 PREGNANCY DX",0))
D ALLV^APCLAPIU(P,BD,ED,"APCS")
I '$D(APCS) Q ""
;now get rid of non-amb, non-H visits, and those whose primary dx is not asthma
NEW APCSJ
S X=0 F S X=$O(APCS(X)) Q:X'=+X D
.S V=$P(APCS(X),U,5)
.Q:'$D(^AUPNVSIT(V,0))
.Q:"AORSHI"'[$P(^AUPNVSIT(V,0),U,7)
.S (G,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(G) D
..S Q=$P($G(^AUPNVPOV(Y,0)),U)
..Q:Q=""
..Q:'$$ICD^ATXCHK(Q,T,9) ;not in taxonomy
..S G=1
..S APCSJ(9999999-$P(APCS(X),U,1))=$P(APCS(X),U,1) ;set by date to eliminate 2 on same day
.Q
S LPD=$O(APCSJ(0))
I LPD="" Q ""
S LPD=9999999-LPD ;date of prenatal dx, find miscarriage, abortion or delivery between this date and ED
NEW APCSF
S APCSF=""
;check abortion / misc dxs
K APCS S X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_LPD_"-"_ED S E=$$START1^APCLDF(X,"APCS(")
I $D(APCS) Q "" ;FOUND SO NOT PREG ANYMORE
K APCS S X=P_"^LAST PROC [BGP ABORTION PROCEDURES;DURING "_LPD_"-"_ED S E=$$START1^APCLDF(X,"APCS(")
I $D(APCS) Q "" ;FOUND SO NOT PREG ANYMORE
;now check CPTs for Abortion and Miscarriage
S %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"BGP CPT ABORTION","D")
I %]"" Q ""
S %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"BGP CPT MISCARRIAGE","D")
I %]"" Q ""
K APCS S X=P_"^LAST DX [SURVEILLANCE H1N1 DELIVERY DX;DURING "_LPD_"-"_ED S E=$$START1^APCLDF(X,"APCS(")
I $D(APCS) Q "" ;FOUND SO NOT PREG ANYMORE
K APCS S X=P_"^LAST PROC [SURVEILLANCE H1N1 DEL PROC;DURING "_LPD_"-"_ED S E=$$START1^APCLDF(X,"APCS(")
I $D(APCS) Q "" ;FOUND SO NOT PREG ANYMORE
;now check CPTs for Abortion and Miscarriage
S %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"SURVEILLANCE H1N1 DELIVERY CPT","D")
I %]"" Q ""
Q "Y"
MONUP ;EP
K APCSUP,APCSAC
S APCSBD=$$FMADD^XLFDT(DT,-(3*365))
S APCSCHS=$P(^BGPSITE(DUZ(2),0),U,6)
S APCSFITI=$P(^BGPSITE(DUZ(2),0),U,9)
S APCSDFN=0 F S APCSDFN=$O(^AUPNPAT(APCSDFN)) Q:APCSDFN'=+APCSDFN D
.Q:'$D(^DPT(APCSDFN,0))
.Q:$P(^DPT(APCSDFN,0),U)["DEMO,PATIENT"
.Q:$$DEMO^APCLUTL(APCSDFN,"E")
.Q:$P(^DPT(APCSDFN,0),U,19) ;merged away
.Q:$P($G(^AUPNPAT(APCSDFN,-9)),U)
.;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,APCSDFN)) S G=1
.;Q:G
.S APCSACUP=0,APCSACCL=0
.;S APCSX=0 F S APCSX=$O(^BGPSITE(APCSX)) Q:APCSX'=+APCSX!(APCSACUP) S APCSACUP=$$ACTUP(APCSDFN,APCSBD,DT,$P(^BGPSITE(APCSX,0),U,5),1)
.S APCSACUP=$$ACTUP(APCSDFN,APCSBD,DT)
.Q:'APCSACUP
.S APCSAGE=$$AGE^AUPNPAT(APCSDFN,DT)
.I APCSAGE=0 S X=$$FMDIFF^XLFDT(DT,$P(^DPT(APCSDFN,0),U,3)),X=X\30.5,X=$P(X,".",1) D
..I X<6 S APCSAGE="0-5 months" Q
..S APCSAGE="6-11 months"
.;APCSUP(APCSAGE)=TOT UP^TOT UP ASTHMA^TOT UP DM^TOT UP PREG
.S $P(APCSUP(APCSAGE),U,1)=$P($G(APCSUP(APCSAGE)),U,1)+1
.S (APCSDM,APCSAST,APCSPREG)=0 ;set all flags to 0
.S APCSDM=$$ASTDM^APCLSIL2(APCSDFN,DT)
.S APCSAST=$P(APCSDM,U)
.S APCSDM=$P(APCSDM,U,2)
.S APCSPREG=$$PNM(APCSDFN,DT)
.I APCSAST="Y" S $P(APCSUP(APCSAGE),U,2)=$P($G(APCSUP(APCSAGE)),U,2)+1
.I APCSDM="Y" S $P(APCSUP(APCSAGE),U,3)=$P($G(APCSUP(APCSAGE)),U,3)+1
.I APCSPREG="Y" S $P(APCSUP(APCSAGE),U,4)=$P($G(APCSUP(APCSAGE)),U,4)+1
.S APCSACCL=$$ACTCL(APCSDFN,APCSBD,DT,APCSCHS)
.Q:'APCSACCL
.S $P(APCSAC(APCSAGE),U,1)=$P($G(APCSAC(APCSAGE)),U,1)+1
.I APCSAST="Y" S $P(APCSAC(APCSAGE),U,2)=$P($G(APCSAC(APCSAGE)),U,2)+1
.I APCSDM="Y" S $P(APCSAC(APCSAGE),U,3)=$P($G(APCSAC(APCSAGE)),U,3)+1
.I APCSPREG="Y" S $P(APCSAC(APCSAGE),U,4)=$P($G(APCSAC(APCSAGE)),U,4)+1
.Q
;FIND HIGHEST AGE
S H="",X="" F S X=$O(APCSUP(X)) Q:X'=+X S H=X
I '$D(APCSUP("0-5 months")) S APCSUP("0-5 months")="0^0^0^0"
I '$D(APCSUP("6-11 months")) S APCSUP("6-11 months")="0^0^0^0"
I '$D(APCSAC("0-5 months")) S APCSAC("0-5 months")="0^0^0^0"
I '$D(APCSAC("6-11 months")) S APCSAC("6-11 months")="0^0^0^0"
F X=1:1:H D
.I '$D(APCSUP(X)) S APCSUP(X)="0^0^0^0"
.I '$D(APCSAC(X)) S APCSAC(X)="0^0^0^0"
;write out file using xbgsave
K ^APCSDATA($J)
;
S C=1,^APCSDATA($J,C)="0-5 months"_","_+$P(APCSUP("0-5 months"),U,1)_","_+$P(APCSAC("0-5 months"),U,1) D
.F P=2:1:4 S ^APCSDATA($J,C)=^APCSDATA($J,C)_","_+$P(APCSUP("0-5 months"),U,P)
.F P=2:1:4 S ^APCSDATA($J,C)=^APCSDATA($J,C)_","_+$P(APCSAC("0-5 months"),U,P)
;
S C=2,^APCSDATA($J,C)="6-11 months"_","_+$P(APCSUP("6-11 months"),U,1)_","_+$P(APCSAC("6-11 months"),U,1) D
.F P=2:1:4 S ^APCSDATA($J,C)=^APCSDATA($J,C)_","_+$P(APCSUP("6-11 months"),U,P)
.F P=2:1:4 S ^APCSDATA($J,C)=^APCSDATA($J,C)_","_+$P(APCSAC("6-11 months"),U,P)
;
K APCSUP("0-5 months"),APCSUP("6-11 months"),APCSAC("0-5 months"),APCSAC("6-11 months")
;
S X=0,C=2 F S X=$O(APCSUP(X)) Q:X="" S C=C+1,^APCSDATA($J,C)=X_","_+$P(APCSUP(X),U,1)_","_+$P(APCSAC(X),U,1) D
.F P=2:1:4 S ^APCSDATA($J,C)=^APCSDATA($J,C)_","_+$P(APCSUP(X),U,P)
.F P=2:1:4 S ^APCSDATA($J,C)=^APCSDATA($J,C)_","_+$P(APCSAC(X),U,P)
;
N XBGL,XBQ,XBQTO,XBNAR,XBMED,XBFLT,XBUF,XBFN
S XBGL="APCSDATA",XBMED="F",XBQ="N",XBFLT=1,XBF=$J,XBE=$J
S XBNAR="ILI SURVEILLANCE EXPORT-POPULATION"
S APCSASU=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10) ;asufac for file name
S XBFN="FLUPOP_"_APCSASU_"_"_$$DATE^APCLSILI(DT)_".txt"
S XBS1="SURVEILLANCE ILI SEND"
;
D ^XBGSAVE
;
I XBFLG'=0 D
. I XBFLG(1)="" W:'$D(ZTQUEUED) !!,"VISIT ILI file successfully created",!!
. I XBFLG(1)]"" W:'$D(ZTQUEUED) !!,"VISIT ILI 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
ACTUP(P,BDATE,EDATE) ;EP - is this patient in user pop?
S X=$$LASTVD(P,BDATE,EDATE)
Q $S(X:1,1:0)
;
ACTCL(P,BDATE,EDATE,CHS) ;EP - clinical user
I CHS G CHSACTCL
S (X,G,F,S)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(F) S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:'$D(^AUPNVPRV("AD",V))
.Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
.Q:"V"[$P(^AUPNVSIT(V,0),U,3)
.Q:$P(^AUPNVSIT(V,0),U,6)=""
.I $G(APCSFITI),'$D(^ATXAX(APCSFITI,21,"B",$P(^AUPNVSIT(V,0),U,6))) Q
.S B=$$CLINIC^APCLV(V,"C")
.Q:B=""
.I 'G,$D(^BGPCTRL($O(^BGPCTRL("B",2009,0)),11,"B",B)) S G=V ;must be a primary clinic S G=V
.I V'=G,$D(^BGPCTRL($O(^BGPCTRL("B",2009,0)),12,"B",B)) S S=1
.I G,S S F=1
.Q
Q $S(F:1,1:0)
;
;
CHSACTCL ;chs only sites active clinical defintion
;2 chs visits in past 3 years
S (X,G,F,S)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(F>1) S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:'$D(^AUPNVPRV("AD",V))
.Q:"SAHOI"'[$P(^AUPNVSIT(V,0),U,7)
.Q:"C"'[$P(^AUPNVSIT(V,0),U,3)
.S F=F+1
Q $S(F>1:1,1:0)
;
LASTVD(P,BDATE,EDATE) ;
I '$D(^AUPNVSIT("AC",P)) Q ""
K ^TMP($J,"A")
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G) S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:'$D(^AUPNVPRV("AD",V))
.Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
.Q:"V"[$P(^AUPNVSIT(V,0),U,3)
.Q:$P(^AUPNVSIT(V,0),U,6)=""
.I $G(APCSFITI),'$D(^ATXAX(APCSFITI,21,"B",$P(^AUPNVSIT(V,0),U,6))) Q
.S G=1
.Q
Q G
;
PNM(P,ED) ;EP
I $P(^DPT(P,0),U,2)'="F" Q ""
NEW T,X,Y,Q,BD,APCS,LPD,%,G
S BD=$$FMADD^XLFDT(ED,-60)
S G=""
S T=$O(^ATXAX("B","SURVEILLANCE H1N1 PREGNANCY DX",0))
D ALLV^APCLAPIU(P,BD,ED,"APCS")
I '$D(APCS) Q ""
;now get rid of non-amb, non-H visits, and those whose primary dx is not asthma
NEW APCSJ
S X=0 F S X=$O(APCS(X)) Q:X'=+X D
.S V=$P(APCS(X),U,5)
.Q:'$D(^AUPNVSIT(V,0))
.Q:"AORSHI"'[$P(^AUPNVSIT(V,0),U,7)
.S (G,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(G) D
..S Q=$P($G(^AUPNVPOV(Y,0)),U)
..Q:Q=""
..Q:'$$ICD^ATXCHK(Q,T,9) ;not in taxonomy
..S G=1
..S APCSJ(9999999-$P(APCS(X),U,1))=$P(APCS(X),U,1) ;set by date to eliminate 2 on same day
.Q
S LPD=$O(APCSJ(0))
I LPD="" Q ""
S LPD=9999999-LPD ;date of prenatal dx, find miscarriage, abortion or delivery between this date and ED
NEW APCSF
S APCSF=""
;check abortion / misc dxs
K APCS S X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_LPD_"-"_ED S E=$$START1^APCLDF(X,"APCS(")
I $D(APCS) Q "" ;FOUND SO NOT PREG ANYMORE
K APCS S X=P_"^LAST PROC [BGP ABORTION PROCEDURES;DURING "_LPD_"-"_ED S E=$$START1^APCLDF(X,"APCS(")
I $D(APCS) Q "" ;FOUND SO NOT PREG ANYMORE
;now check CPTs for Abortion and Miscarriage
S %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"BGP CPT ABORTION","D")
I %]"" Q ""
S %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"BGP CPT MISCARRIAGE","D")
I %]"" Q ""
K APCS S X=P_"^LAST DX [SURVEILLANCE H1N1 DELIVERY DX;DURING "_LPD_"-"_ED S E=$$START1^APCLDF(X,"APCS(")
I $D(APCS) Q "" ;FOUND SO NOT PREG ANYMORE
K APCS S X=P_"^LAST PROC [SURVEILLANCE H1N1 DEL PROC;DURING "_LPD_"-"_ED S E=$$START1^APCLDF(X,"APCS(")
I $D(APCS) Q "" ;FOUND SO NOT PREG ANYMORE
;now check CPTs for Abortion and Miscarriage
S %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"SURVEILLANCE H1N1 DELIVERY CPT","D")
I %]"" Q ""
Q "Y"
APCSSIL1 ;IHS/CMI/LAB - ILI SURVEILLANCE;
+1 ;;2.0;IHS PCC SUITE;**5**;MAY 14, 2009
+2 ;
PN(P,V) ;EP
+1 IF $PIECE(^DPT(P,0),U,2)'="F"
QUIT ""
+2 NEW T,X,Y,Q,ED,BD,APCS,LPD,%,G
+3 SET ED=$$VD^APCLV(V)
+4 SET BD=$$FMADD^XLFDT(ED,-60)
+5 SET G=""
+6 SET T=$ORDER(^ATXAX("B","SURVEILLANCE H1N1 PREGNANCY DX",0))
+7 DO ALLV^APCLAPIU(P,BD,ED,"APCS")
+8 IF '$DATA(APCS)
QUIT ""
+9 ;now get rid of non-amb, non-H visits, and those whose primary dx is not asthma
+10 NEW APCSJ
+11 SET X=0
FOR
SET X=$ORDER(APCS(X))
IF X'=+X
QUIT
Begin DoDot:1
+12 SET V=$PIECE(APCS(X),U,5)
+13 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+14 IF "AORSHI"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+15 SET (G,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:2
+16 SET Q=$PIECE($GET(^AUPNVPOV(Y,0)),U)
+17 IF Q=""
QUIT
+18 ;not in taxonomy
IF '$$ICD^ATXCHK(Q,T,9)
QUIT
+19 SET G=1
+20 ;set by date to eliminate 2 on same day
SET APCSJ(9999999-$PIECE(APCS(X),U,1))=$PIECE(APCS(X),U,1)
End DoDot:2
+21 QUIT
End DoDot:1
+22 SET LPD=$ORDER(APCSJ(0))
+23 IF LPD=""
QUIT ""
+24 ;date of prenatal dx, find miscarriage, abortion or delivery between this date and ED
SET LPD=9999999-LPD
+25 NEW APCSF
+26 SET APCSF=""
+27 ;check abortion / misc dxs
+28 KILL APCS
SET X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_LPD_"-"_ED
SET E=$$START1^APCLDF(X,"APCS(")
+29 ;FOUND SO NOT PREG ANYMORE
IF $DATA(APCS)
QUIT ""
+30 KILL APCS
SET X=P_"^LAST PROC [BGP ABORTION PROCEDURES;DURING "_LPD_"-"_ED
SET E=$$START1^APCLDF(X,"APCS(")
+31 ;FOUND SO NOT PREG ANYMORE
IF $DATA(APCS)
QUIT ""
+32 ;now check CPTs for Abortion and Miscarriage
+33 SET %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"BGP CPT ABORTION","D")
+34 IF %]""
QUIT ""
+35 SET %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"BGP CPT MISCARRIAGE","D")
+36 IF %]""
QUIT ""
+37 KILL APCS
SET X=P_"^LAST DX [SURVEILLANCE H1N1 DELIVERY DX;DURING "_LPD_"-"_ED
SET E=$$START1^APCLDF(X,"APCS(")
+38 ;FOUND SO NOT PREG ANYMORE
IF $DATA(APCS)
QUIT ""
+39 KILL APCS
SET X=P_"^LAST PROC [SURVEILLANCE H1N1 DEL PROC;DURING "_LPD_"-"_ED
SET E=$$START1^APCLDF(X,"APCS(")
+40 ;FOUND SO NOT PREG ANYMORE
IF $DATA(APCS)
QUIT ""
+41 ;now check CPTs for Abortion and Miscarriage
+42 SET %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"SURVEILLANCE H1N1 DELIVERY CPT","D")
+43 IF %]""
QUIT ""
+44 QUIT "Y"
MONUP ;EP
+1 KILL APCSUP,APCSAC
+2 SET APCSBD=$$FMADD^XLFDT(DT,-(3*365))
+3 SET APCSCHS=$PIECE(^BGPSITE(DUZ(2),0),U,6)
+4 SET APCSFITI=$PIECE(^BGPSITE(DUZ(2),0),U,9)
+5 SET APCSDFN=0
FOR
SET APCSDFN=$ORDER(^AUPNPAT(APCSDFN))
IF APCSDFN'=+APCSDFN
QUIT
Begin DoDot:1
+6 IF '$DATA(^DPT(APCSDFN,0))
QUIT
+7 IF $PIECE(^DPT(APCSDFN,0),U)["DEMO,PATIENT"
QUIT
+8 IF $$DEMO^APCLUTL(APCSDFN,"E")
QUIT
+9 ;merged away
IF $PIECE(^DPT(APCSDFN,0),U,19)
QUIT
+10 IF $PIECE($GET(^AUPNPAT(APCSDFN,-9)),U)
QUIT
+11 ;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,APCSDFN)) S G=1
+12 ;Q:G
+13 SET APCSACUP=0
SET APCSACCL=0
+14 ;S APCSX=0 F S APCSX=$O(^BGPSITE(APCSX)) Q:APCSX'=+APCSX!(APCSACUP) S APCSACUP=$$ACTUP(APCSDFN,APCSBD,DT,$P(^BGPSITE(APCSX,0),U,5),1)
+15 SET APCSACUP=$$ACTUP(APCSDFN,APCSBD,DT)
+16 IF 'APCSACUP
QUIT
+17 SET APCSAGE=$$AGE^AUPNPAT(APCSDFN,DT)
+18 IF APCSAGE=0
SET X=$$FMDIFF^XLFDT(DT,$PIECE(^DPT(APCSDFN,0),U,3))
SET X=X\30.5
SET X=$PIECE(X,".",1)
Begin DoDot:2
+19 IF X<6
SET APCSAGE="0-5 months"
QUIT
+20 SET APCSAGE="6-11 months"
End DoDot:2
+21 ;APCSUP(APCSAGE)=TOT UP^TOT UP ASTHMA^TOT UP DM^TOT UP PREG
+22 SET $PIECE(APCSUP(APCSAGE),U,1)=$PIECE($GET(APCSUP(APCSAGE)),U,1)+1
+23 ;set all flags to 0
SET (APCSDM,APCSAST,APCSPREG)=0
+24 SET APCSDM=$$ASTDM^APCLSIL2(APCSDFN,DT)
+25 SET APCSAST=$PIECE(APCSDM,U)
+26 SET APCSDM=$PIECE(APCSDM,U,2)
+27 SET APCSPREG=$$PNM(APCSDFN,DT)
+28 IF APCSAST="Y"
SET $PIECE(APCSUP(APCSAGE),U,2)=$PIECE($GET(APCSUP(APCSAGE)),U,2)+1
+29 IF APCSDM="Y"
SET $PIECE(APCSUP(APCSAGE),U,3)=$PIECE($GET(APCSUP(APCSAGE)),U,3)+1
+30 IF APCSPREG="Y"
SET $PIECE(APCSUP(APCSAGE),U,4)=$PIECE($GET(APCSUP(APCSAGE)),U,4)+1
+31 SET APCSACCL=$$ACTCL(APCSDFN,APCSBD,DT,APCSCHS)
+32 IF 'APCSACCL
QUIT
+33 SET $PIECE(APCSAC(APCSAGE),U,1)=$PIECE($GET(APCSAC(APCSAGE)),U,1)+1
+34 IF APCSAST="Y"
SET $PIECE(APCSAC(APCSAGE),U,2)=$PIECE($GET(APCSAC(APCSAGE)),U,2)+1
+35 IF APCSDM="Y"
SET $PIECE(APCSAC(APCSAGE),U,3)=$PIECE($GET(APCSAC(APCSAGE)),U,3)+1
+36 IF APCSPREG="Y"
SET $PIECE(APCSAC(APCSAGE),U,4)=$PIECE($GET(APCSAC(APCSAGE)),U,4)+1
+37 QUIT
End DoDot:1
+38 ;FIND HIGHEST AGE
+39 SET H=""
SET X=""
FOR
SET X=$ORDER(APCSUP(X))
IF X'=+X
QUIT
SET H=X
+40 IF '$DATA(APCSUP("0-5 months"))
SET APCSUP("0-5 months")="0^0^0^0"
+41 IF '$DATA(APCSUP("6-11 months"))
SET APCSUP("6-11 months")="0^0^0^0"
+42 IF '$DATA(APCSAC("0-5 months"))
SET APCSAC("0-5 months")="0^0^0^0"
+43 IF '$DATA(APCSAC("6-11 months"))
SET APCSAC("6-11 months")="0^0^0^0"
+44 FOR X=1:1:H
Begin DoDot:1
+45 IF '$DATA(APCSUP(X))
SET APCSUP(X)="0^0^0^0"
+46 IF '$DATA(APCSAC(X))
SET APCSAC(X)="0^0^0^0"
End DoDot:1
+47 ;write out file using xbgsave
+48 KILL ^APCSDATA($JOB)
+49 ;
+50 SET C=1
SET ^APCSDATA($JOB,C)="0-5 months"_","_+$PIECE(APCSUP("0-5 months"),U,1)_","_+$PIECE(APCSAC("0-5 months"),U,1)
Begin DoDot:1
+51 FOR P=2:1:4
SET ^APCSDATA($JOB,C)=^APCSDATA($JOB,C)_","_+$PIECE(APCSUP("0-5 months"),U,P)
+52 FOR P=2:1:4
SET ^APCSDATA($JOB,C)=^APCSDATA($JOB,C)_","_+$PIECE(APCSAC("0-5 months"),U,P)
End DoDot:1
+53 ;
+54 SET C=2
SET ^APCSDATA($JOB,C)="6-11 months"_","_+$PIECE(APCSUP("6-11 months"),U,1)_","_+$PIECE(APCSAC("6-11 months"),U,1)
Begin DoDot:1
+55 FOR P=2:1:4
SET ^APCSDATA($JOB,C)=^APCSDATA($JOB,C)_","_+$PIECE(APCSUP("6-11 months"),U,P)
+56 FOR P=2:1:4
SET ^APCSDATA($JOB,C)=^APCSDATA($JOB,C)_","_+$PIECE(APCSAC("6-11 months"),U,P)
End DoDot:1
+57 ;
+58 KILL APCSUP("0-5 months"),APCSUP("6-11 months"),APCSAC("0-5 months"),APCSAC("6-11 months")
+59 ;
+60 SET X=0
SET C=2
FOR
SET X=$ORDER(APCSUP(X))
IF X=""
QUIT
SET C=C+1
SET ^APCSDATA($JOB,C)=X_","_+$PIECE(APCSUP(X),U,1)_","_+$PIECE(APCSAC(X),U,1)
Begin DoDot:1
+61 FOR P=2:1:4
SET ^APCSDATA($JOB,C)=^APCSDATA($JOB,C)_","_+$PIECE(APCSUP(X),U,P)
+62 FOR P=2:1:4
SET ^APCSDATA($JOB,C)=^APCSDATA($JOB,C)_","_+$PIECE(APCSAC(X),U,P)
End DoDot:1
+63 ;
+64 NEW XBGL,XBQ,XBQTO,XBNAR,XBMED,XBFLT,XBUF,XBFN
+65 SET XBGL="APCSDATA"
SET XBMED="F"
SET XBQ="N"
SET XBFLT=1
SET XBF=$JOB
SET XBE=$JOB
+66 SET XBNAR="ILI SURVEILLANCE EXPORT-POPULATION"
+67 ;asufac for file name
SET APCSASU=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0)),U,10)
+68 SET XBFN="FLUPOP_"_APCSASU_"_"_$$DATE^APCLSILI(DT)_".txt"
+69 SET XBS1="SURVEILLANCE ILI SEND"
+70 ;
+71 DO ^XBGSAVE
+72 ;
+73 IF XBFLG'=0
Begin DoDot:1
+74 IF XBFLG(1)=""
IF '$DATA(ZTQUEUED)
WRITE !!,"VISIT ILI file successfully created",!!
+75 IF XBFLG(1)]""
IF '$DATA(ZTQUEUED)
WRITE !!,"VISIT ILI file NOT successfully created",!!
+76 IF '$DATA(ZTQUEUED)
WRITE !,"File was NOT successfully transferred to IHS/CDC",!,"you will need to manually ftp it.",!
+77 IF '$DATA(ZTQUEUED)
WRITE !,XBFLG(1),!!
End DoDot:1
+78 KILL ^APCSDATA($JOB)
+79 QUIT
ACTUP(P,BDATE,EDATE) ;EP - is this patient in user pop?
+1 SET X=$$LASTVD(P,BDATE,EDATE)
+2 QUIT $SELECT(X:1,1:0)
+3 ;
ACTCL(P,BDATE,EDATE,CHS) ;EP - clinical user
+1 IF CHS
GOTO CHSACTCL
+2 SET (X,G,F,S)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(F)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+3 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+4 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+5 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+6 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+7 IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+8 IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+9 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+10 IF $GET(APCSFITI)
IF '$DATA(^ATXAX(APCSFITI,21,"B",$PIECE(^AUPNVSIT(V,0),U,6)))
QUIT
+11 SET B=$$CLINIC^APCLV(V,"C")
+12 IF B=""
QUIT
+13 ;must be a primary clinic S G=V
IF 'G
IF $DATA(^BGPCTRL($ORDER(^BGPCTRL("B",2009,0)),11,"B",B))
SET G=V
+14 IF V'=G
IF $DATA(^BGPCTRL($ORDER(^BGPCTRL("B",2009,0)),12,"B",B))
SET S=1
+15 IF G
IF S
SET F=1
+16 QUIT
End DoDot:1
+17 QUIT $SELECT(F:1,1:0)
+18 ;
+19 ;
CHSACTCL ;chs only sites active clinical defintion
+1 ;2 chs visits in past 3 years
+2 SET (X,G,F,S)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(F>1)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+3 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+4 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+5 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+6 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+7 IF "SAHOI"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+8 IF "C"'[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+9 SET F=F+1
End DoDot:1
+10 QUIT $SELECT(F>1:1,1:0)
+11 ;
LASTVD(P,BDATE,EDATE) ;
+1 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+2 KILL ^TMP($JOB,"A")
+3 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+4 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+5 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+8 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+9 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+10 IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+11 IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+12 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+13 IF $GET(APCSFITI)
IF '$DATA(^ATXAX(APCSFITI,21,"B",$PIECE(^AUPNVSIT(V,0),U,6)))
QUIT
+14 SET G=1
+15 QUIT
End DoDot:1
+16 QUIT G
+17 ;
PNM(P,ED) ;EP
+1 IF $PIECE(^DPT(P,0),U,2)'="F"
QUIT ""
+2 NEW T,X,Y,Q,BD,APCS,LPD,%,G
+3 SET BD=$$FMADD^XLFDT(ED,-60)
+4 SET G=""
+5 SET T=$ORDER(^ATXAX("B","SURVEILLANCE H1N1 PREGNANCY DX",0))
+6 DO ALLV^APCLAPIU(P,BD,ED,"APCS")
+7 IF '$DATA(APCS)
QUIT ""
+8 ;now get rid of non-amb, non-H visits, and those whose primary dx is not asthma
+9 NEW APCSJ
+10 SET X=0
FOR
SET X=$ORDER(APCS(X))
IF X'=+X
QUIT
Begin DoDot:1
+11 SET V=$PIECE(APCS(X),U,5)
+12 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+13 IF "AORSHI"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+14 SET (G,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:2
+15 SET Q=$PIECE($GET(^AUPNVPOV(Y,0)),U)
+16 IF Q=""
QUIT
+17 ;not in taxonomy
IF '$$ICD^ATXCHK(Q,T,9)
QUIT
+18 SET G=1
+19 ;set by date to eliminate 2 on same day
SET APCSJ(9999999-$PIECE(APCS(X),U,1))=$PIECE(APCS(X),U,1)
End DoDot:2
+20 QUIT
End DoDot:1
+21 SET LPD=$ORDER(APCSJ(0))
+22 IF LPD=""
QUIT ""
+23 ;date of prenatal dx, find miscarriage, abortion or delivery between this date and ED
SET LPD=9999999-LPD
+24 NEW APCSF
+25 SET APCSF=""
+26 ;check abortion / misc dxs
+27 KILL APCS
SET X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_LPD_"-"_ED
SET E=$$START1^APCLDF(X,"APCS(")
+28 ;FOUND SO NOT PREG ANYMORE
IF $DATA(APCS)
QUIT ""
+29 KILL APCS
SET X=P_"^LAST PROC [BGP ABORTION PROCEDURES;DURING "_LPD_"-"_ED
SET E=$$START1^APCLDF(X,"APCS(")
+30 ;FOUND SO NOT PREG ANYMORE
IF $DATA(APCS)
QUIT ""
+31 ;now check CPTs for Abortion and Miscarriage
+32 SET %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"BGP CPT ABORTION","D")
+33 IF %]""
QUIT ""
+34 SET %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"BGP CPT MISCARRIAGE","D")
+35 IF %]""
QUIT ""
+36 KILL APCS
SET X=P_"^LAST DX [SURVEILLANCE H1N1 DELIVERY DX;DURING "_LPD_"-"_ED
SET E=$$START1^APCLDF(X,"APCS(")
+37 ;FOUND SO NOT PREG ANYMORE
IF $DATA(APCS)
QUIT ""
+38 KILL APCS
SET X=P_"^LAST PROC [SURVEILLANCE H1N1 DEL PROC;DURING "_LPD_"-"_ED
SET E=$$START1^APCLDF(X,"APCS(")
+39 ;FOUND SO NOT PREG ANYMORE
IF $DATA(APCS)
QUIT ""
+40 ;now check CPTs for Abortion and Miscarriage
+41 SET %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"SURVEILLANCE H1N1 DELIVERY CPT","D")
+42 IF %]""
QUIT ""
+43 QUIT "Y"
