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

APCSSIL1.m

Go to the documentation of this file. 
  1. APCSSIL1 ;IHS/CMI/LAB - ILI SURVEILLANCE; 
  1.  ;;2.0;IHS PCC SUITE;**5**;MAY 14, 2009
  1.  ;
  1. PN(P,V) ;EP
  1.  I $P(^DPT(P,0),U,2)'="F" Q ""
  1.  NEW T,X,Y,Q,ED,BD,APCS,LPD,%,G
  1.  S ED=$$VD^APCLV(V)
  1.  S BD=$$FMADD^XLFDT(ED,-60)
  1.  S G=""
  1.  S T=$O(^ATXAX("B","SURVEILLANCE H1N1 PREGNANCY DX",0))
  1.  D ALLV^APCLAPIU(P,BD,ED,"APCS")
  1.  I '$D(APCS) Q ""
  1.  ;now get rid of non-amb, non-H visits, and those whose primary dx is not asthma
  1.  NEW APCSJ
  1.  S X=0 F  S X=$O(APCS(X)) Q:X'=+X  D
  1.  .S V=$P(APCS(X),U,5)
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:"AORSHI"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .S (G,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(G)  D
  1.  ..S Q=$P($G(^AUPNVPOV(Y,0)),U)
  1.  ..Q:Q=""
  1.  ..Q:'$$ICD^ATXCHK(Q,T,9)  ;not in taxonomy
  1.  ..S G=1
  1.  ..S APCSJ(9999999-$P(APCS(X),U,1))=$P(APCS(X),U,1)  ;set by date to eliminate 2 on same day
  1.  .Q
  1.  S LPD=$O(APCSJ(0))
  1.  I LPD="" Q ""
  1.  S LPD=9999999-LPD  ;date of prenatal dx, find miscarriage, abortion or delivery between this date and ED
  1.  NEW APCSF
  1.  S APCSF=""
  1.  ;check abortion / misc dxs
  1.  K APCS S X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_LPD_"-"_ED S E=$$START1^APCLDF(X,"APCS(")
  1.  I $D(APCS) Q ""  ;FOUND SO NOT PREG ANYMORE
  1.  K APCS S X=P_"^LAST PROC [BGP ABORTION PROCEDURES;DURING "_LPD_"-"_ED S E=$$START1^APCLDF(X,"APCS(")
  1.  I $D(APCS) Q ""  ;FOUND SO NOT PREG ANYMORE
  1.  ;now check CPTs for Abortion and Miscarriage
  1.  S %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"BGP CPT ABORTION","D")
  1.  I %]"" Q ""
  1.  S %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"BGP CPT MISCARRIAGE","D")
  1.  I %]"" Q ""
  1.  K APCS S X=P_"^LAST DX [SURVEILLANCE H1N1 DELIVERY DX;DURING "_LPD_"-"_ED S E=$$START1^APCLDF(X,"APCS(")
  1.  I $D(APCS) Q ""  ;FOUND SO NOT PREG ANYMORE
  1.  K APCS S X=P_"^LAST PROC [SURVEILLANCE H1N1 DEL PROC;DURING "_LPD_"-"_ED S E=$$START1^APCLDF(X,"APCS(")
  1.  I $D(APCS) Q ""  ;FOUND SO NOT PREG ANYMORE
  1.  ;now check CPTs for Abortion and Miscarriage
  1.  S %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"SURVEILLANCE H1N1 DELIVERY CPT","D")
  1.  I %]"" Q ""
  1.  Q "Y"
  1. MONUP ;EP
  1.  K APCSUP,APCSAC
  1.  S APCSBD=$$FMADD^XLFDT(DT,-(3*365))
  1.  S APCSCHS=$P(^BGPSITE(DUZ(2),0),U,6)
  1.  S APCSFITI=$P(^BGPSITE(DUZ(2),0),U,9)
  1.  S APCSDFN=0 F  S APCSDFN=$O(^AUPNPAT(APCSDFN)) Q:APCSDFN'=+APCSDFN  D
  1.  .Q:'$D(^DPT(APCSDFN,0))
  1.  .Q:$P(^DPT(APCSDFN,0),U)["DEMO,PATIENT"
  1.  .Q:$$DEMO^APCLUTL(APCSDFN,"E")
  1.  .Q:$P(^DPT(APCSDFN,0),U,19)  ;merged away
  1.  .Q:$P($G(^AUPNPAT(APCSDFN,-9)),U)
  1.  .;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
  1.  .;Q:G
  1.  .S APCSACUP=0,APCSACCL=0
  1.  .;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)
  1.  .S APCSACUP=$$ACTUP(APCSDFN,APCSBD,DT)
  1.  .Q:'APCSACUP
  1.  .S APCSAGE=$$AGE^AUPNPAT(APCSDFN,DT)
  1.  .I APCSAGE=0 S X=$$FMDIFF^XLFDT(DT,$P(^DPT(APCSDFN,0),U,3)),X=X\30.5,X=$P(X,".",1) D
  1.  ..I X<6 S APCSAGE="0-5 months" Q
  1.  ..S APCSAGE="6-11 months"
  1.  .;APCSUP(APCSAGE)=TOT UP^TOT UP ASTHMA^TOT UP DM^TOT UP PREG
  1.  .S $P(APCSUP(APCSAGE),U,1)=$P($G(APCSUP(APCSAGE)),U,1)+1
  1.  .S (APCSDM,APCSAST,APCSPREG)=0  ;set all flags to 0
  1.  .S APCSDM=$$ASTDM^APCLSIL2(APCSDFN,DT)
  1.  .S APCSAST=$P(APCSDM,U)
  1.  .S APCSDM=$P(APCSDM,U,2)
  1.  .S APCSPREG=$$PNM(APCSDFN,DT)
  1.  .I APCSAST="Y" S $P(APCSUP(APCSAGE),U,2)=$P($G(APCSUP(APCSAGE)),U,2)+1
  1.  .I APCSDM="Y" S $P(APCSUP(APCSAGE),U,3)=$P($G(APCSUP(APCSAGE)),U,3)+1
  1.  .I APCSPREG="Y" S $P(APCSUP(APCSAGE),U,4)=$P($G(APCSUP(APCSAGE)),U,4)+1
  1.  .S APCSACCL=$$ACTCL(APCSDFN,APCSBD,DT,APCSCHS)
  1.  .Q:'APCSACCL
  1.  .S $P(APCSAC(APCSAGE),U,1)=$P($G(APCSAC(APCSAGE)),U,1)+1
  1.  .I APCSAST="Y" S $P(APCSAC(APCSAGE),U,2)=$P($G(APCSAC(APCSAGE)),U,2)+1
  1.  .I APCSDM="Y" S $P(APCSAC(APCSAGE),U,3)=$P($G(APCSAC(APCSAGE)),U,3)+1
  1.  .I APCSPREG="Y" S $P(APCSAC(APCSAGE),U,4)=$P($G(APCSAC(APCSAGE)),U,4)+1
  1.  .Q
  1.  ;FIND HIGHEST AGE
  1.  S H="",X="" F  S X=$O(APCSUP(X)) Q:X'=+X  S H=X
  1.  I '$D(APCSUP("0-5 months")) S APCSUP("0-5 months")="0^0^0^0"
  1.  I '$D(APCSUP("6-11 months")) S APCSUP("6-11 months")="0^0^0^0"
  1.  I '$D(APCSAC("0-5 months")) S APCSAC("0-5 months")="0^0^0^0"
  1.  I '$D(APCSAC("6-11 months")) S APCSAC("6-11 months")="0^0^0^0"
  1.  F X=1:1:H D
  1.  .I '$D(APCSUP(X)) S APCSUP(X)="0^0^0^0"
  1.  .I '$D(APCSAC(X)) S APCSAC(X)="0^0^0^0"
  1.  ;write out file using xbgsave
  1.  K ^APCSDATA($J)
  1.  ;
  1.  S C=1,^APCSDATA($J,C)="0-5 months"_","_+$P(APCSUP("0-5 months"),U,1)_","_+$P(APCSAC("0-5 months"),U,1) D
  1.  .F P=2:1:4 S ^APCSDATA($J,C)=^APCSDATA($J,C)_","_+$P(APCSUP("0-5 months"),U,P)
  1.  .F P=2:1:4 S ^APCSDATA($J,C)=^APCSDATA($J,C)_","_+$P(APCSAC("0-5 months"),U,P)
  1.  ;
  1.  S C=2,^APCSDATA($J,C)="6-11 months"_","_+$P(APCSUP("6-11 months"),U,1)_","_+$P(APCSAC("6-11 months"),U,1) D
  1.  .F P=2:1:4 S ^APCSDATA($J,C)=^APCSDATA($J,C)_","_+$P(APCSUP("6-11 months"),U,P)
  1.  .F P=2:1:4 S ^APCSDATA($J,C)=^APCSDATA($J,C)_","_+$P(APCSAC("6-11 months"),U,P)
  1.  ;
  1.  K APCSUP("0-5 months"),APCSUP("6-11 months"),APCSAC("0-5 months"),APCSAC("6-11 months")
  1.  ;
  1.  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
  1.  .F P=2:1:4 S ^APCSDATA($J,C)=^APCSDATA($J,C)_","_+$P(APCSUP(X),U,P)
  1.  .F P=2:1:4 S ^APCSDATA($J,C)=^APCSDATA($J,C)_","_+$P(APCSAC(X),U,P)
  1.  ;
  1.  N XBGL,XBQ,XBQTO,XBNAR,XBMED,XBFLT,XBUF,XBFN
  1.  S XBGL="APCSDATA",XBMED="F",XBQ="N",XBFLT=1,XBF=$J,XBE=$J
  1.  S XBNAR="ILI SURVEILLANCE EXPORT-POPULATION"
  1.  S APCSASU=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),0)),U,10)  ;asufac for file name
  1.  S XBFN="FLUPOP_"_APCSASU_"_"_$$DATE^APCLSILI(DT)_".txt"
  1.  S XBS1="SURVEILLANCE ILI SEND"
  1.  ;
  1.  D ^XBGSAVE
  1.  ;
  1.  I XBFLG'=0 D
  1.  . I XBFLG(1)="" W:'$D(ZTQUEUED) !!,"VISIT ILI file successfully created",!!
  1.  . I XBFLG(1)]"" W:'$D(ZTQUEUED) !!,"VISIT ILI 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 ^APCSDATA($J)
  1.  Q
  1. ACTUP(P,BDATE,EDATE) ;EP - is this patient in user pop?
  1.  S X=$$LASTVD(P,BDATE,EDATE)
  1.  Q $S(X:1,1:0)
  1.  ;
  1. ACTCL(P,BDATE,EDATE,CHS) ;EP - clinical user
  1.  I CHS G CHSACTCL
  1.  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
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .Q:'$D(^AUPNVPRV("AD",V))
  1.  .Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .Q:"V"[$P(^AUPNVSIT(V,0),U,3)
  1.  .Q:$P(^AUPNVSIT(V,0),U,6)=""
  1.  .I $G(APCSFITI),'$D(^ATXAX(APCSFITI,21,"B",$P(^AUPNVSIT(V,0),U,6))) Q
  1.  .S B=$$CLINIC^APCLV(V,"C")
  1.  .Q:B=""
  1.  .I 'G,$D(^BGPCTRL($O(^BGPCTRL("B",2009,0)),11,"B",B)) S G=V  ;must be a primary clinic S G=V
  1.  .I V'=G,$D(^BGPCTRL($O(^BGPCTRL("B",2009,0)),12,"B",B)) S S=1
  1.  .I G,S S F=1
  1.  .Q
  1.  Q $S(F:1,1:0)
  1.  ;
  1.  ;
  1. CHSACTCL ;chs only sites active clinical defintion
  1.  ;2 chs visits in past 3 years
  1.  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
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .Q:'$D(^AUPNVPRV("AD",V))
  1.  .Q:"SAHOI"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .Q:"C"'[$P(^AUPNVSIT(V,0),U,3)
  1.  .S F=F+1
  1.  Q $S(F>1:1,1:0)
  1.  ;
  1. LASTVD(P,BDATE,EDATE) ;
  1.  I '$D(^AUPNVSIT("AC",P)) Q ""
  1.  K ^TMP($J,"A")
  1.  S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
  1.  I '$D(^TMP($J,"A",1)) Q ""
  1.  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
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .Q:'$D(^AUPNVPRV("AD",V))
  1.  .Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .Q:"V"[$P(^AUPNVSIT(V,0),U,3)
  1.  .Q:$P(^AUPNVSIT(V,0),U,6)=""
  1.  .I $G(APCSFITI),'$D(^ATXAX(APCSFITI,21,"B",$P(^AUPNVSIT(V,0),U,6))) Q
  1.  .S G=1
  1.  .Q
  1.  Q G
  1.  ;
  1. PNM(P,ED) ;EP
  1.  I $P(^DPT(P,0),U,2)'="F" Q ""
  1.  NEW T,X,Y,Q,BD,APCS,LPD,%,G
  1.  S BD=$$FMADD^XLFDT(ED,-60)
  1.  S G=""
  1.  S T=$O(^ATXAX("B","SURVEILLANCE H1N1 PREGNANCY DX",0))
  1.  D ALLV^APCLAPIU(P,BD,ED,"APCS")
  1.  I '$D(APCS) Q ""
  1.  ;now get rid of non-amb, non-H visits, and those whose primary dx is not asthma
  1.  NEW APCSJ
  1.  S X=0 F  S X=$O(APCS(X)) Q:X'=+X  D
  1.  .S V=$P(APCS(X),U,5)
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:"AORSHI"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .S (G,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(G)  D
  1.  ..S Q=$P($G(^AUPNVPOV(Y,0)),U)
  1.  ..Q:Q=""
  1.  ..Q:'$$ICD^ATXCHK(Q,T,9)  ;not in taxonomy
  1.  ..S G=1
  1.  ..S APCSJ(9999999-$P(APCS(X),U,1))=$P(APCS(X),U,1)  ;set by date to eliminate 2 on same day
  1.  .Q
  1.  S LPD=$O(APCSJ(0))
  1.  I LPD="" Q ""
  1.  S LPD=9999999-LPD  ;date of prenatal dx, find miscarriage, abortion or delivery between this date and ED
  1.  NEW APCSF
  1.  S APCSF=""
  1.  ;check abortion / misc dxs
  1.  K APCS S X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_LPD_"-"_ED S E=$$START1^APCLDF(X,"APCS(")
  1.  I $D(APCS) Q ""  ;FOUND SO NOT PREG ANYMORE
  1.  K APCS S X=P_"^LAST PROC [BGP ABORTION PROCEDURES;DURING "_LPD_"-"_ED S E=$$START1^APCLDF(X,"APCS(")
  1.  I $D(APCS) Q ""  ;FOUND SO NOT PREG ANYMORE
  1.  ;now check CPTs for Abortion and Miscarriage
  1.  S %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"BGP CPT ABORTION","D")
  1.  I %]"" Q ""
  1.  S %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"BGP CPT MISCARRIAGE","D")
  1.  I %]"" Q ""
  1.  K APCS S X=P_"^LAST DX [SURVEILLANCE H1N1 DELIVERY DX;DURING "_LPD_"-"_ED S E=$$START1^APCLDF(X,"APCS(")
  1.  I $D(APCS) Q ""  ;FOUND SO NOT PREG ANYMORE
  1.  K APCS S X=P_"^LAST PROC [SURVEILLANCE H1N1 DEL PROC;DURING "_LPD_"-"_ED S E=$$START1^APCLDF(X,"APCS(")
  1.  I $D(APCS) Q ""  ;FOUND SO NOT PREG ANYMORE
  1.  ;now check CPTs for Abortion and Miscarriage
  1.  S %=$$LASTCPTT^APCLAPIU(P,LPD,ED,"SURVEILLANCE H1N1 DELIVERY CPT","D")
  1.  I %]"" Q ""
  1.  Q "Y"