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

APCHSM02.m

Go to the documentation of this file. 
  1. APCHSM02 ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;
  1.  ;;2.0;IHS PCC SUITE;**2,7,11,16**;MAY 14, 2009;Build 9
  1.  ;
  1.  ; ******************** SURVEILLANCE - HARD CODE ********************
  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. SIGMOID ;EP
  1.  G SIGMOID^APCHSM07
  1.  ;
  1. CHOL ;
  1.  X APCHSURX
  1.  Q:'$$INAC^APCHSMU(APCHSITI)  ;is item turned on or off
  1.  S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
  1.  I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
  1.  I 'APCHSCRI D
  1.  .Q:APCHSAGE>64
  1.  .I APCHSEX="M",APCHSAGE<35 Q
  1.  .I APCHSEX="F",APCHSAGE<45 Q
  1.  .S APCHSINT=(5*365)
  1.  .I APCHSEX="F" S APCHMIN=35
  1.  .I APCHSEX="M" S APCHMIN=45
  1.  S APCHLAST="",APCHNEXT="" K APCHSTEX
  1.  S APCHTAXN=$O(^ATXLAB("B","DM AUDIT CHOLESTEROL TAX",0))
  1.  I APCHSINT,APCHTAXN="" S APCHSTEX(1)="DM AUDIT CHOLESTEROL TAX Taxonomy Missing" D WRITE^APCHSMU X APCHSURX Q
  1.  S APCHICAR=$$LASTCHOL^APCLAPI3(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.  .D REF
  1.  .D WRITE^APCHSMU
  1.  .X APCHSURX
  1.  .Q
  1. CHOLREG ;regular stuff
  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 REF
  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.  D REF
  1.  D WRITE^APCHSMU
  1.  X APCHSURX
  1.  Q
  1.  ;
  1. GLUCOSE ;EP
  1.  ;add v77.1 as a hit 
  1.  X APCHSURX
  1.  Q:'$$INAC^APCHSMU(APCHSITI)  ;is item turned on or off
  1.  I $$SITECRIT^APCHSMU(APCHSITI) D GLUCSITE Q
  1.  Q:$$AGE^AUPNPAT(APCHSPAT,DT)<18
  1.  S APCHSINT=(3*365)
  1.  S APCHMIN=18
  1.  D GLUCDEF
  1.  Q
  1. GLUCSITE ;
  1.  S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT) ;return in APCHSINT the frequency in days for this age/sex
  1.  D GLUCDEF
  1.  Q
  1. GLUCDEF ;
  1.  S APCHLAST="",APCHNEXT="" K APCHSTEX
  1.  S APCHTAXN=$O(^ATXLAB("B","DM AUDIT GLUCOSE TESTS TAX",0))
  1.  I APCHSINT,APCHTAXN="" S APCHSTEX(1)="DM AUDIT GLUCOSE TESTS TAX Taxonomy Missing" D WRITE^APCHSMU X APCHSURX Q
  1.  S APCHICAR=$$LASTGLUC^APCLAPI3(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.  .D REF
  1.  .D WRITE^APCHSMU
  1.  .X APCHSURX
  1.  .Q
  1. GLUCOSER ;
  1.  I APCHSINT="" X APCHSURX Q  ;no frequency so skip it
  1.  I $$PLTAX^APCHSMU(APCHSPAT,"SURVEILLANCE DIABETES") X APCHSURX Q  ;cancel if DM is on Problem List
  1.  I $$IPLSNO^APCHSMU1(APCHSPAT,"PXRM DIABETES") X APCHSURX Q  ;cancel if pt has snomed htn on pl
  1.  I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D  Q
  1.  .D REF
  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.  D REF
  1.  D WRITE^APCHSMU
  1.  X APCHSURX
  1.  Q
  1.  ;
  1. FECAL ;EP - called from reminders
  1.  X APCHSURX
  1.  Q:'$$INAC^APCHSMU(APCHSITI)  ;is item turned on or off
  1.  I $$PLTAX^APCHSMU(APCHSPAT,"BGP COLORECTAL CANCER DXS") X APCHSURX Q  ;cancel if cancer on pl
  1.  S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
  1.  I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
  1.  I 'APCHSCRI D
  1.  .Q:APCHSAGE<50
  1.  .Q:APCHSAGE>75
  1.  .S APCHSINT=(1*365)
  1.  .S APCHMIN=50
  1.  S APCHLAST="",APCHNEXT="" K APCHSTEX
  1.  S APCHTAXN=$O(^ATXLAB("B","BGP GPRA FOB TESTS",0))
  1.  I APCHSINT,APCHTAXN="" S APCHSTEX(1)="BGP GPRA FOB TESTS Taxonomy Missing" D WRITE^APCHSMU X APCHSURX Q
  1.  I APCHSINT,'$O(^ATXLAB(APCHTAXN,21,0)) S APCHSTEX(1)="BGP GPRA FOB TESTS Taxonomy Missing" D WRITE^APCHSMU X APCHSURX Q
  1.  S APCHICAR=$$LASTFOBT^APCLAPI3(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.  .D REF
  1.  .D WRITE^APCHSMU
  1.  .X APCHSURX
  1.  .Q
  1. FECALREG ;
  1.  I APCHSINT="" X APCHSURX Q  ;no frequency so skip it
  1.  I $$PLTAX^APCHSMU(APCHSPAT,"BGP COLORECTAL CANCER DXS") X APCHSURX Q  ;cancel if cancer on pl
  1.  I $$IPLSNO^APCHSMU1(APCHSPAT,"PXRM COLORECTAL CANCER") X APCHSURX Q
  1.  ;<=== * * * Gary's mod starts here
  1.  ;S APCHSLBE=$$LASTBE^APCLAPI4(APCHSPAT) I $G(APCHSLBE)]"",$$FMDIFF^XLFDT(DT,APCHSLBE)<365 S APCHSTEX(1)="N/A...BARIUM ENEMA "_$$FMTE^XLFDT(APCHSLBE) D  Q
  1.  ;.D REF
  1.  ;.D WRITE^APCHSMU
  1.  ;.X APCHSURX
  1.  ;.Q
  1.  S APCHSLCO=$P($$LASTCOLO^APCLAPI(APCHSPAT),U,1) I $G(APCHSLCO)]"",$$FMDIFF^XLFDT(DT,APCHSLCO)<3650 S APCHSTEX(1)="N/A...COLONOSCOPY "_$$FMTE^XLFDT(APCHSLCO) D  Q
  1.  .D REF
  1.  .D WRITE^APCHSMU
  1.  .X APCHSURX
  1.  .Q
  1.  S APCHSLSI=$P($$LASTFSIG^APCLAPI(APCHSPAT),U,1) I $G(APCHSLSI)]"",$$FMDIFF^XLFDT(DT,APCHSLSI)<(5*365) S APCHSTEX(1)="N/A...SIGMOIDOSCOPY "_$$FMTE^XLFDT(APCHSLSI) D  Q
  1.  .D REF
  1.  .D WRITE^APCHSMU
  1.  .X APCHSURX
  1.  .Q
  1.  ;<==== * * * end of Gary's mod
  1.  I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D  Q
  1.  .D REF
  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.  D REF
  1.  D WRITE^APCHSMU
  1.  X APCHSURX
  1.  Q
  1.  ;
  1. HH ;
  1.  X APCHSURX
  1.  Q:'$$INAC^APCHSMU(APCHSITI)  ;is item turned on or off
  1.  S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
  1.  I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
  1.  I 'APCHSCRI D
  1.  .Q:APCHSAGE>10
  1.  .S APCHSINT=365
  1.  .S APCHSMIN=1
  1.  S APCHLAST="",APCHNEXT="" K APCHSTEX
  1.  S APCHTAXN=$O(^ATXLAB("B","APCH HCT/HGB TESTS",0))
  1.  I APCHSINT,APCHTAXN="" S APCHSTEX(1)="APCH HCT/HGB TESTS Taxonomy Missing" D WRITE^APCHSMU X APCHSURX Q
  1.  I APCHSINT,'$O(^ATXLAB(APCHTAXN,21,0)) S APCHSTEX(1)="APCH HCT/HGB TESTS Taxonomy Missing" D WRITE^APCHSMU X APCHSURX Q
  1.  ;S APCHLAST=$$LASTLAB^APCHSMU(APCHSPAT,,$O(^ATXLAB("B","APCH HCT/HGB TESTS",0)))
  1.  S APCHICAR=$$LASTLAB^APCLAPIU(APCHSPAT,,,,$O(^ATXLAB("B","APCH HCT/HGB TESTS",0)),,,"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 REF
  1.  .D WRITE^APCHSMU
  1.  .X APCHSURX
  1.  .Q
  1. HHREG ;
  1.  I APCHSINT="" X APCHSURX Q
  1.  I 'APCHSCRI D IHSHH Q
  1.  I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D  Q
  1.  .D REF
  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.  D REF
  1.  D WRITE^APCHSMU
  1.  X APCHSURX
  1.  Q
  1.  ;
  1. IHSHH ;
  1.  Q:APCHSAGE>10
  1.  I APCHLAST="",APCHSAGE<1 S APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,365)) D REF,WRITE^APCHSMU X APCHSURX Q
  1.  I APCHLAST="",APCHSAGE>0,APCHSAGE<4 S APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,365)) D REF,WRITE^APCHSMU X APCHSURX Q
  1.  I APCHLAST="",APCHSAGE>3 S APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(365*4))) D REF,WRITE^APCHSMU X APCHSURX Q
  1.  S APCHSOLD=$$FMDIFF^XLFDT(APCHLAST,APCHSDOB)
  1.  I APCHSAGE<1,APCHSOLD'>(9*30.5) S APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,365)) D REF,WRITE^APCHSMU X APCHSURX Q
  1.  I APCHSAGE>0,APCHSAGE<4,APCHSOLD<(9*30.5) S APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,365)) D REF,WRITE^APCHSMU X APCHSURX Q
  1.  I APCHSAGE>3,APCHSOLD<(3*365) S APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(4*365))) D REF,WRITE^APCHSMU X APCHSURX Q
  1.  Q
  1. REF ;EP
  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.  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. DEPOWT ;
  1.  K APCHV
  1.  S V=$$REF^APCHSMU(APCHSPAT,9999999.15,$O(^AUTTEXAM("C","35",0)),APCHLAST)
  1.  I V]"" S X=$P(V,U,3) S APCHV((9999999-X))=$P(V,U,1,2)
  1.  ;now look at AMHREC field
  1.  S APCHC=0,V=""
  1.  S E=9999999-APCHLAST,D=9999999-DT-1_".99" F  S D=$O(^AMHREC("AE",APCHSPAT,D)) Q:D'=+D!($P(D,".")>E)  S V=0 F  S V=$O(^AMHREC("AE",APCHSPAT,D,V)) Q:V'=+V  D
  1.  .S X=$P($G(^AMHREC(V,14)),U,3)
  1.  .I X="" Q  ;no test
  1.  .I $E(X)="U" S APCHV(D)="Unable to Screen DEPRESSION SCREENING ",$P(APCHV(D),U,2)="on "_$$FMTE^XLFDT((9999999-$P(D,".")))
  1.  .I X="REF" S APCHV(D)="Patient Declined DEPRESSION SCREENING ",$P(APCHV(D),U,2)="on "_$$FMTE^XLFDT((9999999-$P(D,".")))
  1.  .Q
  1.  I $O(APCHV(0)) S Y=$O(APCHV(0)) S Z=9999999-Y I Z>APCHLAST S X=$P(APCHV(Y),U) D S(X) S X=$P(APCHV(Y),U,2) I X]"" D S(X)
  1.  D WRITE^APCHSMU
  1.  X APCHSURX
  1.  Q
  1. DEPRESS ;EP - depression screening
  1.  Q:'$$INAC^APCHSMU(APCHSITI)  ;is item turned on or off
  1.  Q:$$LASTDXT^APCLAPIU(APCHSPAT,$$FMADD^XLFDT(DT,-365),DT,"BGP MOOD DISORDERS")
  1.  S APCHLAST="",APCHNEXT="" K APCHSTEX
  1.  S APCHICAR=$$LASTDEPS^APCLAPI(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.  .D WRITE^APCHSMU
  1.  .X APCHSURX
  1.  .Q
  1. DEPREG ;regular stuff
  1.  S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
  1.  I 'APCHSCRI,APCHSAGE>17 S APCHSINT=365,APCHMIN=18
  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 DEPOWT 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 DEPOWT
  1.  Q