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