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

APCHSM04.m

Go to the documentation of this file. 
  1. APCHSM04 ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES  ; 
  1.  ;;2.0;IHS PCC SUITE;**2,7,11,16**;MAY 14, 2009;Build 9
  1.  ;
  1. S(X) ;
  1.  NEW %,C S (C,%)=0 F  S %=$O(APCHSTEX(%)) Q:%'=+%  S C=C+1
  1.  S APCHSTEX(C+1)=X
  1.  Q
  1. HT ;EP
  1.  X APCHSURX
  1.  Q:'$$INAC^APCHSMU(APCHSITI)
  1.  S APCHLAST="",APCHNEXT="" K APCHSTEX
  1.  S APCHICAR=$$LASTITEM^APCLAPIU(APCHSPAT,"HT","MEASUREMENT",,,"A")
  1.  S APCHLAST=$P(APCHICAR,U,1)
  1.  S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
  1.  I $P(APCHOVR,U)>APCHLAST D  Q
  1.  .S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)
  1.  .D PRHT
  1. HTREG ;
  1.  S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
  1.  I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
  1.  I 'APCHSCRI S APCHSINT=365,APCHMIN=0
  1.  I APCHSINT="" X APCHSURX Q
  1.  I 'APCHSCRI D IHSHT Q
  1. HTREG1 ;
  1.  I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D PRHT Q
  1.  S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
  1.  I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
  1.  I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
  1.  D PRHT
  1.  Q
  1.  ;
  1. IHSHT ;
  1.  I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D PRHT Q
  1.  I APCHSAGE>2,APCHSAGE<19 S APCHSINT=365 D HTREG1 Q
  1.  I APCHSAGE>64 S APCHSINT=365 D HTREG1 Q
  1.  I APCHSAGE>18,APCHSAGE<65 D  Q
  1.  .S Y=$$FMADD^XLFDT(APCHSDOB,(18*365))
  1.  .I Y<APCHLAST X APCHSURX Q
  1.  .D HTREG1
  1.  .Q
  1.  S APCHDAYS=$$FMDIFF^XLFDT(DT,APCHSDOB)
  1.  I APCHDAYS>0,APCHDAYS<(2*30.5) S APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(2*30.5))) D PRHT Q
  1.  I APCHDAYS'<(2*30.5),APCHDAYS<(4*30.5) S APCHNEXT=$$FMADD^XLFDT(APCHSDOB,(4*30.5)),APCHLDUE=$$FMADD^XLFDT(APCHSDOB,(2*30.5)) D HTT Q
  1.  I APCHDAYS'<(4*30.5),APCHDAYS<(6*30.5) S APCHNEXT=$$FMADD^XLFDT(APCHSDOB,(6*30.5)),APCHLDUE=$$FMADD^XLFDT(APCHSDOB,(4*30.5)) D HTT Q
  1.  I APCHDAYS'<(6*30.5),APCHDAYS<365.25 S APCHNEXT=$$FMADD^XLFDT(APCHSDOB,365.25),APCHLDUE=$$FMADD^XLFDT(APCHSDOB,(6*30.5)) D HTT Q
  1.  I APCHDAYS'<365,APCHDAYS<(18*30.5) S APCHNEXT=$$FMADD^XLFDT(APCHSDOB,(18*30.5)),APCHLDUE=$$FMADD^XLFDT(APCHSDOB,365) D HTT Q
  1.  S APCHNEXT=$$FMADD^XLFDT(APCHSDOB,(2*365)),APCHLDUE=$$FMADD^XLFDT(APCHSDOB,(18*30.5)) D HTT Q
  1.  Q
  1. HTT ;
  1.  I APCHLDUE>APCHLAST S APCHSTEX(1)=$$DATE^APCHSMU(APCHLDUE) D PRHT Q
  1.  I APCHNEXT<DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT) D PRHT Q
  1.  I APCHNEXT'<DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT) D PRHT Q
  1.  Q
  1. PRHT ;
  1.  S V=$$REF^APCHSMU(APCHSPAT,9999999.07,$O(^AUTTMSR("B","HT",0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
  1.  D WRITE^APCHSMU X APCHSURX
  1.  Q
  1.  ;
  1. FLU ;EP - influenza
  1.  I $E(DT,4,5)="05"!($E(DT,4,5)="06")!($E(DT,4,5)="07")!($E(DT,4,5)="08") Q  ;don't display in summer
  1.  X APCHSURX
  1.  Q:'$$INAC^APCHSMU(APCHSITI)
  1.  S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
  1.  I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
  1.  I 'APCHSCRI I $$FLUIHS(APCHSPAT) S APCHSINT=365,APCHMIN=64 I $$PLTAX^APCHSMU(APCHSPAT,"SURVEILLANCE PNEUMOCOCCAL RISK") S APCHMIN=$$AGE^AUPNPAT(APCHSPAT)
  1.  S APCHLAST="",APCHNEXT="" K APCHSTEX
  1.  S APCHSFLX=$S($$BI^APCHS11C:$O(^AUTTIMM("C",88,"")),1:$O(^AUTTIMM("C",12,""))),APCHIMMC=$S($$BI^APCHS11C:88,1:12)
  1.  S APCHICAR=$$LASTFLU^APCLAPI4(APCHSPAT,,,"A")
  1.  S APCHLAST=$P(APCHICAR,U,1)
  1.  S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
  1.  I $P(APCHOVR,U)>APCHLAST D  Q
  1.  .S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)
  1.  .S V="" F APCHSC=15,16,88,111 Q:V]""  S APCHSFLX=$O(^AUTTIMM("C",APCHSC,0)) D
  1.  ..S V=$$REF^APCHSMU(APCHSPAT,9999999.14,APCHSFLX,APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
  1.  .D WRITE^APCHSMU
  1.  .X APCHSURX
  1.  .Q
  1. FLUREG ;
  1.  I APCHSINT="" X APCHSURX Q
  1.  I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D  Q
  1.  .S V="" F APCHSC=15,16,88,111 Q:V]""  S APCHSFLX=$O(^AUTTIMM("C",APCHSC,0)) D
  1.  ..S V=$$REF^APCHSMU(APCHSPAT,9999999.14,APCHSFLX,APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
  1.  .D WRITE^APCHSMU
  1.  .X APCHSURX
  1.  .Q
  1.  S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
  1.  I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
  1.  I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
  1.  S V="" F APCHSC=15,16,88,111 Q:V]""  S APCHSFLX=$O(^AUTTIMM("C",APCHSC,0)) D
  1.  .S V=$$REF^APCHSMU(APCHSPAT,9999999.14,APCHSFLX,APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
  1.  D WRITE^APCHSMU
  1.  X APCHSURX
  1.  Q
  1.  ;
  1. FLUIHS(P)  ;
  1.  NEW %,S
  1.  I '$G(P) Q ""
  1.  I $$AGE^AUPNPAT(P,DT)>64 Q 1
  1.  S %=$$FMDIFF^XLFDT(DT,$P(^DPT(P,0),U,3),1)
  1.  I %<180 Q ""
  1.  I $$PLTAX^APCHSMU(APCHSPAT,"SURVEILLANCE PNEUMOCOCCAL RISK") Q 1
  1.  Q ""
  1. MAMREF ;
  1.  D MAMREF^APCHSMU2
  1.  Q
  1. MAMWT ;
  1.  D MAMREF
  1.  D WRITE^APCHSMU
  1.  X APCHSURX
  1.  Q
  1. MAMM ;
  1.  Q:'$$INAC^APCHSMU(APCHSITI)
  1.  Q:APCHSEX'="F"
  1.  S (APCHLAST,APCHNEXT,APCHWHL,APCHWHN,APCHSWHR,APCHICAR,APCHIC,APCHWF)="" K APCHSTEX,APCHX
  1.  S APCHICAR=$$LASTMAM^APCLAPI1(APCHSPAT,,,"A"),APCHWF=$P(APCHICAR,U,5)
  1.  S APCHLAST=$P(APCHICAR,U,1)
  1.  D
  1.  .S X="BWUTL1" X ^%ZOSF("TEST") I '$T Q
  1.  .I '$D(^BWP(APCHSPAT,0)) Q
  1.  .S APCHX=$$BNEED^BWUTL1(APCHSPAT)
  1.  .I APCHX="UNKNOWN" K APCHX Q
  1.  .I APCHX["NO DATE" K APCHX Q
  1.  .S X=$P(APCHX,"by ",2),X=$P(X,")",1)
  1.  .I $E(X)'?1N Q
  1.  .S %DT="" D ^%DT
  1.  .S APCHWHN=Y,APCHSWHR=APCHX
  1.  ;now check against WH, if WH more current then check override, display and quit
  1.  S I=0  ;USE WH OR NOT?
  1.  I APCHWHN]"",APCHLAST]"",APCHLAST<APCHWHN S I=1
  1.  I APCHWHN]"",APCHLAST="" S I=1  ;use wh if have a next and last =""
  1.  I I D  Q
  1.  .S APCHNEXT=APCHWHN
  1.  .S APCHSTEX(1)=APCHX
  1.  .S X="(per Women's Health system)" D S(X)
  1.  .S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
  1.  .I $P(APCHOVR,U)>APCHLAST D  Q
  1.  ..S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)
  1.  .D MAMWT
  1.  .Q
  1. MAMR ;NOW REGULAR OLD STUFF
  1.  S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
  1.  I $P(APCHOVR,U)>APCHLAST D  Q
  1.  .S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)
  1.  .D MAMWT
  1. MAMREG ;regular stuff
  1.  S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
  1.  I 'APCHSCRI D
  1.  .Q:APCHSAGE<50
  1.  .Q:APCHSAGE>74
  1.  .S APCHSINT=365
  1.  .S APCHMIN=50
  1.  I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT) ;return in APCHSINT the frequency in days for this age/sex
  1.  I APCHSINT="" X APCHSURX Q  ;no frequency so skip it
  1.  I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D  Q
  1.  .D MAMWT
  1.  S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
  1.  I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
  1.  I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
  1.  D MAMWT
  1.  Q
  1. PAPWT ;
  1.  S APCHTAXN=$O(^ATXLAB("B","BGP PAP SMEAR TAX",0))
  1.  D REF
  1.  ;S V=$$REF^APCHSMU(APCHSPAT,60,$O(^LAB(60,"B","PAP SMEAR",0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
  1.  D WRITE^APCHSMU
  1.  X APCHSURX
  1.  Q
  1. REF ;
  1.  K APCHREF S APCHT=0 F  S APCHT=$O(^ATXLAB(APCHTAXN,21,"B",APCHT)) Q:APCHT'=+APCHT  D
  1.  .S V=$$REF^APCHSMU(APCHSPAT,60,APCHT,APCHLAST) I V]"" S APCHREF(9999999-$P(V,U,3))=V
  1.  S V=$$REF^APCHSMU(APCHSPAT,60,$O(^LAB(60,"B","PAP SMEAR",0)),APCHLAST) I V]"" S APCHREF(9999999-$P(V,U,3))=V
  1.  I $D(APCHREF) S %=0,%=$O(APCHREF(%)) I % S V=APCHREF(%),X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
  1.  Q
  1. PAP ;
  1.  Q:'$$INAC^APCHSMU(APCHSITI)  ;is item turned on or off
  1.  Q:APCHSEX'="F"  ;females only
  1.  S (APCHLAST,APCHNEXT,APCHWHL,APCHWHN,APCHSWHR,APCHICAR,APCHIC,APCHWF,APCHHPV)="" K APCHSTEX,APCHX
  1.  S APCHICAR=$$LASTPAP^APCLAPI1(APCHSPAT,,,"A")
  1.  S APCHLAST=$P(APCHICAR,U,1),APCHWF=$P(APCHICAR,U,5)
  1.  D
  1.  .S X="BWUTL1" X ^%ZOSF("TEST") I '$T Q
  1.  .I '$D(^BWP(APCHSPAT,0)) Q
  1.  .S APCHX=$$CNEED^BWUTL1(APCHSPAT)
  1.  .I APCHX="UNKNOWN" K APCHX Q
  1.  .I APCHX["NO DATE" K APCHX Q
  1.  .I APCHX'["PAP" S APCHWHN="",APCHSWHR=APCHX Q
  1.  .S APCHY=""
  1.  .I APCHX["by " D
  1.  ..S X=$P(APCHX,"by ",2),X=$P(X,")",1)
  1.  ..I $E(X)'?1N Q
  1.  ..S %DT="" D ^%DT
  1.  ..S APCHY=Y
  1.  .S APCHWHN=APCHY,APCHSWHR=APCHX
  1.  S APCHWHL=APCHLAST
  1.  S I=1
  1.  I APCHSWHR="" S I=0
  1.  I APCHWHN]"",APCHLAST]"",APCHLAST<APCHWHN S I=1
  1.  I I D  Q
  1.  .S APCHLAST=APCHWHL,APCHNEXT=APCHWHN
  1.  .S APCHSTEX(1)=APCHSWHR
  1.  .S X="(per Women's Health system)" D S(X)
  1.  .S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
  1.  .I $P(APCHOVR,U)>APCHLAST D  Q
  1.  ..S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)
  1.  .D PAPWT
  1.  .Q
  1.  S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
  1.  I $P(APCHOVR,U)>APCHLAST D  Q
  1.  .S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)
  1.  .D PAPWT
  1. PAPREG ;regular stuff
  1.  S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
  1.  I 'APCHSCRI D
  1.  .Q:APCHSAGE<21
  1.  .Q:APCHSAGE>64
  1.  .S APCHSINT=(3*365)
  1.  .S APCHMIN=21
  1.  I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
  1.  I APCHSINT="" X APCHSURX Q
  1.  ;check for hysterectomy
  1.  I $$HYSTER(APCHSPAT) S APCHSTEX(1)="Patient has had hysterectomy",APCHSTEX(2)="Pap may be needed based on",APCHSTEX(3)="clinical assessment." D PAPWT Q
  1.  I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D  Q
  1.  .D PAPWT
  1.  I APCHSAGE<30 D  Q
  1.  .S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
  1.  .I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
  1.  .I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
  1.  .D PAPWT
  1.  ;30-64
  1.  ;IF HAD PAP IN PAST 3 YRS, DISPLAY NEXT INFO AND DON'T WORRY ABOUT HPV TEST
  1.  I $$FMDIFF^XLFDT(APCHLAST,DT)<(3*365) D  Q
  1.  .S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
  1.  .S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
  1.  .S APCHSTEX(2)="PAP every 3 years: Next: "_$$DATE^APCHSMU(APCHNEXT)
  1.  .S APCHSTEX(3)="or PAP and high risk HPV test "
  1.  .S APCHSTEX(4)=" every 5 years:  Next: "_$$DATE^APCHSMU($$FMADD^XLFDT(APCHLAST,(5*365)))
  1.  .D PAPWT
  1.  ;IF HAD PAP AND HPV IN PAST 5 YRS DISPLAY NEXT PAP+5
  1.  S APCHHPV=$P($$LASTHPV(APCHSPAT),U,2)
  1.  I $$FMDIFF^XLFDT(APCHLAST,DT)<(5*365),$$FMDIFF^XLFDT(APCHLAST,DT)<(5*365) D  Q
  1.  .S APCHNEXT=$$FMADD^XLFDT(APCHLAST,(5*365))
  1.  .S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
  1.  .S APCHSTEX(2)="PAP every 3 years: Next: "_$$DATE^APCHSMU($$FMADD^XLFDT(APCHLAST,(3*365)))
  1.  .S APCHSTEX(3)="or PAP and high risk HPV test "
  1.  .S APCHSTEX(4)=" every 5 years:  Next: "_$$DATE^APCHSMU(APCHNEXT)
  1.  .D PAPWT
  1.  S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
  1.  S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
  1.  S APCHSTEX(2)="PAP every 3 years: Next: "_$$DATE^APCHSMU(APCHNEXT)
  1.  S APCHSTEX(3)="PAP and high risk HPV test "
  1.  S APCHSTEX(4)=" every 5 years:  Next: "_$$DATE^APCHSMU($$FMADD^XLFDT(APCHLAST,(5*365)))
  1.  D PAPWT
  1.  Q
  1. HYSTER(P) ;EP has patient had hysterectomy?
  1.  I '$G(P) Q ""
  1.  ;I '$D(^AUPNVPRC("AC",P)) Q ""
  1.  N APCHSVDT
  1.  NEW F,S,C S (F,S)=0 F  S F=$O(^AUPNVPRC("AC",P,F)) Q:F'=+F!(S)  I $D(^AUPNVPRC(F,0)) S APCHSVDT=$P(+^AUPNVSIT($P(^AUPNVPRC(F,0),U,3),0),"."),C=$P($$ICDOP^ICDEX(+^AUPNVPRC(F,0),APCHSVDT,,"I"),U,1) D
  1.  .S:$$ICD^ATXAPI(C,$O(^ATXAX("B","BGP HYSTERECTOMY PROCEDURES",0)),1) S=1
  1.  I S=1 Q 1
  1.  I $P($$LASTDX^APCHSMU2(P,"BGP HYSTERECTOMY DXS"),U) Q 1  ;had this dx
  1.  S T="HYSTERECTOMY",T=$O(^BWPN("B",T,0))
  1.  I T D  I X Q 1
  1.  .S X=$$WH^APCHSMU2(P,$$DOB^AUPNPAT(P),DT,T,1)
  1.  S T=$O(^ATXAX("B","BGP HYSTERECTOMY CPTS",0))
  1.  I T D  I X Q 1
  1.  .S X=$$CPT^APCHSMU2(P,$P(^DPT(P,0),U,3),DT,T,1)
  1.  Q ""
  1. LASTHPV(P) ;EP
  1.  NEW APCHC,APCHLPAP,T,APCHLT,B,D,E,L,X,J,APCH
  1.  S APCHC=""
  1.  S APCHLPAP=""
  1.  S BDATE=$$DOB^AUPNPAT(P)
  1.  S EDATE=DT
  1.  S T=$O(^ATXAX("B","BGP HPV LOINC CODES",0))
  1.  S APCHLT=$O(^ATXLAB("B","BGP HPV TESTS TAX",0))
  1.  S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(APCHC]"")  D
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(APCHC]"")  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(APCHC]"")  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...S Z=$P(^AUPNVLAB(X,0),U),Z=$P($G(^LAB(60,Z,0)),U) I Z="HPV" S APCHC="1^"_(9999999-D)_"^Lab" Q
  1.  ...I APCHLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCHLT,21,"B",$P(^AUPNVLAB(X,0),U))) S APCHC="1^"_(9999999-D)_"^Lab" Q
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,T)
  1.  ...S APCHC="1^"_(9999999-D)_"^Lab-loinc" Q
  1.  ...Q
  1.  S APCHLPAP=APCHC
  1.  K APCH
  1.  S T="BGP HPV DXS"
  1.  S X=$$LASTDXT^APCLAPIU(P,,,"BGP HPV DXS","D") I X,$P(APCHLPAP,U,2)<X S APCHLPAP="1^"_X_"^HPV POV "
  1.  S T=$O(^ATXAX("B","BGP HPV CPTS",0))
  1.  I T D  I X]"",$P(APCHLPAP,U,2)<$P(X,U,1) S APCHLPAP="1^"_$P(X,U)_"^CPT "_$P(X,U,2)
  1.  .S X=$$CPT^APCHSMU2(P,BDATE,EDATE,T,5) I X]"" Q
  1.  Q APCHLPAP
  1. WW ;EP - WiseWoman reminder - Mike Mosley
  1.  N WWSTAT,APCHLAST,APCHNEXT,APCHSTEX
  1.  Q:'$$INAC^APCHSMU(APCHSITI)
  1.  Q:APCHSEX'="F"
  1.  S (APCHLAST,APCHNEXT)="" K APCHSTEX
  1.  S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
  1.  S WWSTAT=$$GET1^DIQ(9000001,APCHSPAT,1709,"I")
  1.  Q:WWSTAT>1&(WWSTAT<4)
  1.  I $$HASWWP(APCHSPAT) D
  1.  .S APCHLAST=$$WWPDT(APCHSPAT)
  1.  .S APCHNEXT=$$FMADD^XLFDT(APCHLAST,305)
  1.  .I APCHNEXT'>DT S APCHSTEX(1)="MAY BE DUE NOW (WAS DUE "_$$DATE^APCHSMU(APCHNEXT)_")"
  1.  .E  S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
  1.  E  D
  1.  .S:APCHSAGE>29&(APCHSAGE<65) APCHSTEX(1)="MAY BE DUE NOW"
  1.  D:$D(APCHSTEX) WRITE^APCHSMU
  1.  X APCHSURX
  1.  Q
  1. WWPDT(DFN) ;
  1.  N IEN,PDT,WWP
  1.  S PDT=0
  1.  Q:'$G(DFN) PDT
  1.  S PDT=0,IEN=$C(1) F  S IEN=$O(^BWPCD("C",DFN,IEN),-1) Q:'IEN!PDT  D
  1.  .S WWP=$$GET1^DIQ(9002086.1,IEN,4.01,"I")
  1.  .I WWP=1!(WWP=2) S PDT=$$GET1^DIQ(9002086.1,IEN,4.02,"I")
  1.  Q PDT
  1.  ;
  1. HASWWP(DFN) ;
  1.  N IEN,FLG
  1.  S (FLG,IEN)=0 F  S IEN=$O(^BWPCD("C",DFN,IEN)) Q:'IEN!FLG  D
  1.  .I $$GET1^DIQ(9002086.1,IEN,4.01,"I")=1 S FLG=1
  1.  Q FLG
  1. PAPDAYS(P) ;PEP - called from WH to return # of days
  1.  ;          from last pap until this patient's next pap is due
  1.  ;          0 = clinical discretion (had hysterectomy)
  1.  ;          -1 = patient not eligible for this reminder
  1.  ;          return = # days
  1.  I '$G(P) Q -1
  1.  ;is patient eligible for this reminder per specifications in hmr file?
  1.  NEW APCHSITI,APCHSCRI,G
  1.  S APCHSITI=$O(^APCHSURV("B","PAP SMEAR",0))
  1.  S APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
  1.  I $$HYSTER(P) Q 0  ;if hysterectomy then clinical discretion
  1.  I 'APCHSCRI D  Q G
  1.  .S G=-1
  1.  .Q:$$AGE^AUPNPAT(P,DT)<18
  1.  .S G=(3*365)
  1.  S G=$$AGESEX^APCHSMU(APCHSITI,P),G=$P(G,".")
  1.  I 'G Q -1
  1.  Q G
  1. MAMDAYS(P) ;PEP - called from WH to return # of days 
  1.  ;          from last mammogram that the next one is due
  1.  ;          -1 = patient not eligible for this reminder
  1.  ;          return = # days
  1.  I '$G(P) Q -1
  1.  ;is patient eligible for this reminder per specifications in hmr file?
  1.  NEW APCHSITI,APCHSCRI,G
  1.  S APCHSITI=$O(^APCHSURV("B","MAMMOGRAM",0))
  1.  S APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
  1.  I 'APCHSCRI D  Q G
  1.  .S G=-1
  1.  .Q:$$AGE^AUPNPAT(P,DT)<50
  1.  .Q:$$AGE^AUPNPAT(P,DT)>69
  1.  .S G=365
  1.  S G=$$AGESEX^APCHSMU(APCHSITI,P),G=$P(G,".")
  1.  I 'G Q -1
  1.  Q G
  1. LOINC(A,B) ;
  1.  NEW %
  1.  S %=$P($G(^LAB(95.3,A,9999999)),U,2)
  1.  I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
  1.  S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1.  I $D(^ATXAX(B,21,"B",%)) Q 1
  1.  Q ""