APCHSM03 ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;
;;2.0;IHS PCC SUITE;**2,7,16**;MAY 14, 2009;Build 9
;IHS/CMI/LAB - uncommented age limit on pap smear
;
; ******************** 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
TD ;EP - influenza
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:$$AGE^AUPNPAT(APCHSPAT)<12
.S APCHSINT=10*365
.S APCHMIN=12
I APCHSINT="" X APCHSURX Q
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHICAR=$$LASTTD^APCLAPI4(APCHSPAT,,,"A")
S APCHLAST=$P(APCHICAR,U,1)
S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
S V=""
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)
.S V="" F APCHSC=1,9,20,22,28,35,50,106,107,110 Q:V]"" S APCHSFLX=$O(^AUTTIMM("C",APCHSC,0)) D
..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)
.D WRITE^APCHSMU
.X APCHSURX
.Q
TDREG ;
I APCHSINT="" X APCHSURX Q ;no frequency so skip it
I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D Q
.S V="" F APCHSC=1,9,20,22,28,35,50,106,107,110,112,113,115 Q:V]"" S APCHSFLX=$O(^AUTTIMM("C",APCHSC,0)) D
..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)
.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)
S V="" F APCHSC=1,9,20,22,28,35,50,106,107,110,112,113,115 Q:V]"" S APCHSFLX=$O(^AUTTIMM("C",APCHSC,0)) D
.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)
D WRITE^APCHSMU
X APCHSURX
Q
;
TON ;
X APCHSURX
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHICAR=$$LASTTON^APCLAPI1(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)
.S V=$$REF^APCHSMU(APCHSPAT,9999999.07,$O(^AUTTMSR("B","TON",0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
.D WRITE^APCHSMU
.X APCHSURX
.Q
TONREG ;regular stuff
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
I 'APCHSCRI D
.Q:APCHSAGE<40
.I APCHSAGE<60 S APCHSINT=(3*365),APCHMIN=40 Q
.S APCHSINT=365
.S APCHMIN=40
I APCHSINT="" X APCHSURX Q ;no frequency so skip it
I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D Q
.S V=$$REF^APCHSMU(APCHSPAT,9999999.07,$O(^AUTTMSR("B","TON",0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
.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)
S V=$$REF^APCHSMU(APCHSPAT,9999999.07,$O(^AUTTMSR("B","TON",0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
D WRITE^APCHSMU
X APCHSURX
Q
;
BP ;
X APCHSURX
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHICAR=$$LASTITEM^APCLAPIU(APCHSPAT,"BP","MEASUREMENT",$$DOB^AUPNPAT(APCHSPAT),DT,"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)
.S V=$$REF^APCHSMU(APCHSPAT,9999999.07,$O(^AUTTMSR("B","BP",0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
.D WRITE^APCHSMU
.X APCHSURX
.Q
BPREG ;regular stuff
I $$PLTAX^APCHSMU(APCHSPAT,"SURVEILLANCE HYPERTENSION") X APCHSURX Q ;cancel if pt has hypertension on problem list
I $$IPLSNO^APCHSMU1(APCHSPAT,"PXRM HYPERTENSION") X APCHSURX Q ;cancel if pt has snomed htn 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<2
.S APCHSINT=(2*365)
.S APCHMIN=2
I APCHSINT="" X APCHSURX Q ;no frequency so skip it
;reset APCHSINT if needed depending on last BP diastolic and age
I 'APCHSCRI D RESET
I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D Q
.S V=$$REF^APCHSMU(APCHSPAT,9999999.07,$O(^AUTTMSR("B","BP",0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
.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)
S V=$$REF^APCHSMU(APCHSPAT,9999999.07,$O(^AUTTMSR("B","BP",0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
D WRITE^APCHSMU
X APCHSURX
Q
;
HEAD ;EP - head circumference
X APCHSURX
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHICAR=$$LASTHC^APCLAPI2(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 PRHH
.Q
HEADREG ;
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
I 'APCHSCRI D
.Q:APCHSAGE>3
.S APCHSINT=(2*30.5)
.S APCHMIN=0
I APCHSINT="" X APCHSURX Q ;no frequency so skip it
;reset APCHSINT if needed depending on last HC diastolic and age
I 'APCHSCRI D IHSHEAD Q
I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D PRHH 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 PRHH
Q
;
IHSHEAD ;use IHS default criteria
I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU(APCHSDOB) D PRHH Q ;never had one recorded so due on DOB
;calculate next date due
S APCHDAYS=$$FMDIFF^XLFDT(DT,APCHSDOB)
S APCHSOLD=$$FMDIFF^XLFDT(APCHLAST,APCHSDOB)
I APCHDAYS>0,APCHDAYS<(2*30.5) S APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(2*30.5))) D PRHH Q
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 HEADT Q
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 HEADT Q
I APCHDAYS'<(6*30.5),APCHDAYS<365 S APCHNEXT=$$FMADD^XLFDT(APCHSDOB,365),APCHLDUE=$$FMADD^XLFDT(APCHSDOB,(6*30.5)) D HEADT Q
I APCHDAYS'<365,APCHDAYS<(18*30.5) S APCHNEXT=$$FMADD^XLFDT(APCHSDOB,(18*30.5)),APCHLDUE=$$FMADD^XLFDT(APCHSDOB,365) D HEADT Q
I APCHDAYS'<(365.25*2),APCHDAYS<(3*365.25) S APCHNEXT=$$FMADD^XLFDT(APCHSDOB,(2*365.25)),APCHLDUE=$$FMADD^XLFDT(APCHSDOB,(18*30.5)) D HEADT Q
Q
HEADT ;
I APCHLDUE>APCHLAST S APCHSTEX(1)=$$DATE^APCHSMU(APCHLDUE) D PRHH Q
I APCHNEXT<DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT) D PRHH Q
I APCHNEXT'<DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT) D PRHH Q
Q
PRHH ;
S V=$$REF^APCHSMU(APCHSPAT,9999999.07,$O(^AUTTMSR("B","HC",0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
D WRITE^APCHSMU X APCHSURX
Q
RESET ;
Q:APCHSAGE<22
NEW D S D=$$LASTITEM^APCHSMU(APCHSPAT,"BP","MEASUREMENT","V")
I $P(D,"/")>139 S APCHSINT=1 Q
I $P(D,"/",2)>89 S APCHSINT=1 Q
I $P(D,"/",2)>84.9&($P(D,"/",2)<90) S APCHSINT=365 Q
Q
HEARINQ ;EP
X APCHSURX
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
I 'APCHSCRI D
.Q:APCHSAGE<65
.S APCHSINT=(2*365)
.S APCHMIN=65
I APCHSINT="" X APCHSURX Q ;no frequency so skip it
S APCHSTEX(1)="Consider inquiring about hearing",APCHSTEX(2)="difficulties at least every 2 years." D Q
.D WRITE^APCHSMU
.X APCHSURX
.Q
Q
;
ALCOWT ;
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 ALCOHOL SCREENING ",$P(APCHV(D),U,2)="on "_$$FMTE^XLFDT((9999999-$P(D,".")))
.I X="REF" S APCHV(D)="Patient Declined ALCOHOL 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
ALCOHOL ;EP - alcohol screening
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
;ADD V79.1 PER DENISE, 8-3-05
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHICAR=$$LASTALC^APCLAPI(APCHSPAT,,,"A")
S APCHLAST=$P(APCHICAR,U,1)
;add check for alcohol screening 35 and do in crs also
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
ALCOREG ;regular stuff
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I 'APCHSCRI,APCHSAGE>12 S APCHSINT=365,APCHMIN=13
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 ALCOWT 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 ALCOWT
Q
TOBWT ;
D WRITE^APCHSMU
X APCHSURX
Q
TOBACCO ;EP - tobacco screening
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHICAR=$$LASTTOBS^APCLAPI1(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
TOBREG ;regular stuff
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I 'APCHSCRI,APCHSAGE>12 S APCHSINT=365,APCHMIN=13
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 TOBWT 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 TOBWT
Q
LASTBHDX(P,BDATE,EDATE,C) ;find date of last BH dx of C, return date in fileman format
NEW APCHX,APCHP,V,D,E S APCHX=""
S E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(APCHX]"") S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(APCHX]"") D
.Q:'$D(^AMHREC(V,0))
.S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(APCHX]"") S APCHP=$P($G(^AMHRPRO(X,0)),U) D
..Q:'APCHP
..S APCHP=$P($G(^AMHPROB(APCHP,0)),U)
..I APCHP=C S APCHX=$P($P(^AMHREC(V,0),U),".")
Q APCHX
LASTBHED(P,BDATE,EDATE,C) ;find date of last BH EDUC of C, return date in fileman format
NEW APCHX,APCHP,V,D,E S APCHX=""
S E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(APCHX]"") S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(APCHX]"") D
.Q:'$D(^AMHREC(V,0))
.S X=0 F S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X!(APCHX]"") S APCHP=$P($G(^AMHREDU(X,0)),U) D
..Q:'APCHP
..S APCHP=$P($G(^AUTTEDT(APCHP,0)),U,2)
..I APCHP=C S APCHX=$P($P(^AMHREC(V,0),U),".")
Q APCHX
LASTALCS(P) ;
;look for exams and bh
NEW APCHG,%,APCHX,APCHC,APCHV
K APCHG,APCHX S %=P_"^LAST EXAM 35",E=$$START1^APCLDF(%,"APCHG(")
I $D(APCHG(1)) S APCHX(9999999-$P(APCHG(1),U))=""
;now look at AMHREC field
S APCHC=0,APCHV=""
S E=0,D=9999999-DT-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!(APCHC) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(APCHC) D
.S X=$P($G(^AMHREC(V,14)),U,3)
.I X="" Q ;no test
.I $E(X)="U" Q ;don't count refusal here
.I X="REF" Q
.S APCHC=APCHC+1,APCHX($P(D,"."))=""
I $O(APCHX(0)) Q (9999999-$O(APCHX(0)))
Q ""
APCHSM03 ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;
+1 ;;2.0;IHS PCC SUITE;**2,7,16**;MAY 14, 2009;Build 9
+2 ;IHS/CMI/LAB - uncommented age limit on pap smear
+3 ;
+4 ; ******************** 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
TD ;EP - influenza
+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 $$AGE^AUPNPAT(APCHSPAT)<12
QUIT
+7 SET APCHSINT=10*365
+8 SET APCHMIN=12
End DoDot:1
+9 IF APCHSINT=""
XECUTE APCHSURX
QUIT
+10 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+11 SET APCHICAR=$$LASTTD^APCLAPI4(APCHSPAT,,,"A")
+12 SET APCHLAST=$PIECE(APCHICAR,U,1)
+13 SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
+14 SET V=""
+15 IF $PIECE(APCHOVR,U)>APCHLAST
Begin DoDot:1
+16 SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"
DO S(X)
SET X=$PIECE(APCHOVR,U,3)
DO S(X)
+17 SET V=""
FOR APCHSC=1,9,20,22,28,35,50,106,107,110
IF V]""
QUIT
SET APCHSFLX=$ORDER(^AUTTIMM("C",APCHSC,0))
Begin DoDot:2
+18 SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,APCHSFLX,APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
End DoDot:2
+19 DO WRITE^APCHSMU
+20 XECUTE APCHSURX
+21 QUIT
End DoDot:1
QUIT
TDREG ;
+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 SET V=""
FOR APCHSC=1,9,20,22,28,35,50,106,107,110,112,113,115
IF V]""
QUIT
SET APCHSFLX=$ORDER(^AUTTIMM("C",APCHSC,0))
Begin DoDot:2
+4 SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,APCHSFLX,APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
End DoDot:2
+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 SET V=""
FOR APCHSC=1,9,20,22,28,35,50,106,107,110,112,113,115
IF V]""
QUIT
SET APCHSFLX=$ORDER(^AUTTIMM("C",APCHSC,0))
Begin DoDot:1
+12 SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,APCHSFLX,APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
End DoDot:1
+13 DO WRITE^APCHSMU
+14 XECUTE APCHSURX
+15 QUIT
+16 ;
TON ;
+1 XECUTE APCHSURX
+2 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+3 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+4 SET APCHICAR=$$LASTTON^APCLAPI1(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 SET V=$$REF^APCHSMU(APCHSPAT,9999999.07,$ORDER(^AUTTMSR("B","TON",0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+10 DO WRITE^APCHSMU
+11 XECUTE APCHSURX
+12 QUIT
End DoDot:1
QUIT
TONREG ;regular stuff
+1 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+2 IF APCHSCRI
SET APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT)
SET APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
+3 IF 'APCHSCRI
Begin DoDot:1
+4 IF APCHSAGE<40
QUIT
+5 IF APCHSAGE<60
SET APCHSINT=(3*365)
SET APCHMIN=40
QUIT
+6 SET APCHSINT=365
+7 SET APCHMIN=40
End DoDot:1
+8 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+9 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))
Begin DoDot:1
+10 SET V=$$REF^APCHSMU(APCHSPAT,9999999.07,$ORDER(^AUTTMSR("B","TON",0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+11 DO WRITE^APCHSMU
+12 XECUTE APCHSURX
+13 QUIT
End DoDot:1
QUIT
+14 SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
+15 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+16 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+17 SET V=$$REF^APCHSMU(APCHSPAT,9999999.07,$ORDER(^AUTTMSR("B","TON",0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+18 DO WRITE^APCHSMU
+19 XECUTE APCHSURX
+20 QUIT
+21 ;
BP ;
+1 XECUTE APCHSURX
+2 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+3 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+4 SET APCHICAR=$$LASTITEM^APCLAPIU(APCHSPAT,"BP","MEASUREMENT",$$DOB^AUPNPAT(APCHSPAT),DT,"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 SET V=$$REF^APCHSMU(APCHSPAT,9999999.07,$ORDER(^AUTTMSR("B","BP",0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+10 DO WRITE^APCHSMU
+11 XECUTE APCHSURX
+12 QUIT
End DoDot:1
QUIT
BPREG ;regular stuff
+1 ;cancel if pt has hypertension on problem list
IF $$PLTAX^APCHSMU(APCHSPAT,"SURVEILLANCE HYPERTENSION")
XECUTE APCHSURX
QUIT
+2 ;cancel if pt has snomed htn on pl
IF $$IPLSNO^APCHSMU1(APCHSPAT,"PXRM HYPERTENSION")
XECUTE APCHSURX
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<2
QUIT
+7 SET APCHSINT=(2*365)
+8 SET APCHMIN=2
End DoDot:1
+9 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+10 ;reset APCHSINT if needed depending on last BP diastolic and age
+11 IF 'APCHSCRI
DO RESET
+12 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))
Begin DoDot:1
+13 SET V=$$REF^APCHSMU(APCHSPAT,9999999.07,$ORDER(^AUTTMSR("B","BP",0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+14 DO WRITE^APCHSMU
+15 XECUTE APCHSURX
+16 QUIT
End DoDot:1
QUIT
+17 SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
+18 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+19 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+20 SET V=$$REF^APCHSMU(APCHSPAT,9999999.07,$ORDER(^AUTTMSR("B","BP",0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+21 DO WRITE^APCHSMU
+22 XECUTE APCHSURX
+23 QUIT
+24 ;
HEAD ;EP - head circumference
+1 XECUTE APCHSURX
+2 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+3 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+4 SET APCHICAR=$$LASTHC^APCLAPI2(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 PRHH
+10 QUIT
End DoDot:1
QUIT
HEADREG ;
+1 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+2 IF APCHSCRI
SET APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT)
SET APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
+3 IF 'APCHSCRI
Begin DoDot:1
+4 IF APCHSAGE>3
QUIT
+5 SET APCHSINT=(2*30.5)
+6 SET APCHMIN=0
End DoDot:1
+7 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+8 ;reset APCHSINT if needed depending on last HC diastolic and age
+9 IF 'APCHSCRI
DO IHSHEAD
QUIT
+10 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))
DO PRHH
QUIT
+11 SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
+12 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+13 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+14 DO PRHH
+15 QUIT
+16 ;
IHSHEAD ;use IHS default criteria
+1 ;never had one recorded so due on DOB
IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHSDOB)
DO PRHH
QUIT
+2 ;calculate next date due
+3 SET APCHDAYS=$$FMDIFF^XLFDT(DT,APCHSDOB)
+4 SET APCHSOLD=$$FMDIFF^XLFDT(APCHLAST,APCHSDOB)
+5 IF APCHDAYS>0
IF APCHDAYS<(2*30.5)
SET APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(2*30.5)))
DO PRHH
QUIT
+6 IF APCHDAYS'<(2*30.5)
IF APCHDAYS<(4*30.5)
SET APCHNEXT=$$FMADD^XLFDT(APCHSDOB,(4*30.5))
SET APCHLDUE=$$FMADD^XLFDT(APCHSDOB,(2*30.5))
DO HEADT
QUIT
+7 IF APCHDAYS'<(4*30.5)
IF APCHDAYS<(6*30.5)
SET APCHNEXT=$$FMADD^XLFDT(APCHSDOB,(6*30.5))
SET APCHLDUE=$$FMADD^XLFDT(APCHSDOB,(4*30.5))
DO HEADT
QUIT
+8 IF APCHDAYS'<(6*30.5)
IF APCHDAYS<365
SET APCHNEXT=$$FMADD^XLFDT(APCHSDOB,365)
SET APCHLDUE=$$FMADD^XLFDT(APCHSDOB,(6*30.5))
DO HEADT
QUIT
+9 IF APCHDAYS'<365
IF APCHDAYS<(18*30.5)
SET APCHNEXT=$$FMADD^XLFDT(APCHSDOB,(18*30.5))
SET APCHLDUE=$$FMADD^XLFDT(APCHSDOB,365)
DO HEADT
QUIT
+10 IF APCHDAYS'<(365.25*2)
IF APCHDAYS<(3*365.25)
SET APCHNEXT=$$FMADD^XLFDT(APCHSDOB,(2*365.25))
SET APCHLDUE=$$FMADD^XLFDT(APCHSDOB,(18*30.5))
DO HEADT
QUIT
+11 QUIT
HEADT ;
+1 IF APCHLDUE>APCHLAST
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHLDUE)
DO PRHH
QUIT
+2 IF APCHNEXT<DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
DO PRHH
QUIT
+3 IF APCHNEXT'<DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
DO PRHH
QUIT
+4 QUIT
PRHH ;
+1 SET V=$$REF^APCHSMU(APCHSPAT,9999999.07,$ORDER(^AUTTMSR("B","HC",0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+2 DO WRITE^APCHSMU
XECUTE APCHSURX
+3 QUIT
RESET ;
+1 IF APCHSAGE<22
QUIT
+2 NEW D
SET D=$$LASTITEM^APCHSMU(APCHSPAT,"BP","MEASUREMENT","V")
+3 IF $PIECE(D,"/")>139
SET APCHSINT=1
QUIT
+4 IF $PIECE(D,"/",2)>89
SET APCHSINT=1
QUIT
+5 IF $PIECE(D,"/",2)>84.9&($PIECE(D,"/",2)<90)
SET APCHSINT=365
QUIT
+6 QUIT
HEARINQ ;EP
+1 XECUTE APCHSURX
+2 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+3 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+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<65
QUIT
+8 SET APCHSINT=(2*365)
+9 SET APCHMIN=65
End DoDot:1
+10 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+11 SET APCHSTEX(1)="Consider inquiring about hearing"
SET APCHSTEX(2)="difficulties at least every 2 years."
Begin DoDot:1
+12 DO WRITE^APCHSMU
+13 XECUTE APCHSURX
+14 QUIT
End DoDot:1
QUIT
+15 QUIT
+16 ;
ALCOWT ;
+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 ALCOHOL SCREENING "
SET $PIECE(APCHV(D),U,2)="on "_$$FMTE^XLFDT((9999999-$PIECE(D,".")))
+10 IF X="REF"
SET APCHV(D)="Patient Declined ALCOHOL 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
ALCOHOL ;EP - alcohol screening
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 ;ADD V79.1 PER DENISE, 8-3-05
+3 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+4 SET APCHICAR=$$LASTALC^APCLAPI(APCHSPAT,,,"A")
+5 SET APCHLAST=$PIECE(APCHICAR,U,1)
+6 ;add check for alcohol screening 35 and do in crs also
+7 SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
+8 IF $PIECE(APCHOVR,U)>APCHLAST
Begin DoDot:1
+9 SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"
DO S(X)
SET X=$PIECE(APCHOVR,U,3)
DO S(X)
+10 DO WRITE^APCHSMU
+11 XECUTE APCHSURX
+12 QUIT
End DoDot:1
QUIT
ALCOREG ;regular stuff
+1 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+2 IF 'APCHSCRI
IF APCHSAGE>12
SET APCHSINT=365
SET APCHMIN=13
+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 ALCOWT
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 ALCOWT
+10 QUIT
TOBWT ;
+1 DO WRITE^APCHSMU
+2 XECUTE APCHSURX
+3 QUIT
TOBACCO ;EP - tobacco screening
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+3 SET APCHICAR=$$LASTTOBS^APCLAPI1(APCHSPAT,,,"A")
+4 SET APCHLAST=$PIECE(APCHICAR,U,1)
+5 SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
+6 IF $PIECE(APCHOVR,U)>APCHLAST
Begin DoDot:1
+7 SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"
DO S(X)
SET X=$PIECE(APCHOVR,U,3)
DO S(X)
+8 DO WRITE^APCHSMU
+9 XECUTE APCHSURX
+10 QUIT
End DoDot:1
QUIT
TOBREG ;regular stuff
+1 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+2 IF 'APCHSCRI
IF APCHSAGE>12
SET APCHSINT=365
SET APCHMIN=13
+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 TOBWT
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 TOBWT
+10 QUIT
LASTBHDX(P,BDATE,EDATE,C) ;find date of last BH dx of C, return date in fileman format
+1 NEW APCHX,APCHP,V,D,E
SET APCHX=""
+2 SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(APCHX]"")
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(APCHX]"")
QUIT
Begin DoDot:1
+3 IF '$DATA(^AMHREC(V,0))
QUIT
+4 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X!(APCHX]"")
QUIT
SET APCHP=$PIECE($GET(^AMHRPRO(X,0)),U)
Begin DoDot:2
+5 IF 'APCHP
QUIT
+6 SET APCHP=$PIECE($GET(^AMHPROB(APCHP,0)),U)
+7 IF APCHP=C
SET APCHX=$PIECE($PIECE(^AMHREC(V,0),U),".")
End DoDot:2
End DoDot:1
+8 QUIT APCHX
LASTBHED(P,BDATE,EDATE,C) ;find date of last BH EDUC of C, return date in fileman format
+1 NEW APCHX,APCHP,V,D,E
SET APCHX=""
+2 SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(APCHX]"")
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(APCHX]"")
QUIT
Begin DoDot:1
+3 IF '$DATA(^AMHREC(V,0))
QUIT
+4 SET X=0
FOR
SET X=$ORDER(^AMHREDU("AD",V,X))
IF X'=+X!(APCHX]"")
QUIT
SET APCHP=$PIECE($GET(^AMHREDU(X,0)),U)
Begin DoDot:2
+5 IF 'APCHP
QUIT
+6 SET APCHP=$PIECE($GET(^AUTTEDT(APCHP,0)),U,2)
+7 IF APCHP=C
SET APCHX=$PIECE($PIECE(^AMHREC(V,0),U),".")
End DoDot:2
End DoDot:1
+8 QUIT APCHX
LASTALCS(P) ;
+1 ;look for exams and bh
+2 NEW APCHG,%,APCHX,APCHC,APCHV
+3 KILL APCHG,APCHX
SET %=P_"^LAST EXAM 35"
SET E=$$START1^APCLDF(%,"APCHG(")
+4 IF $DATA(APCHG(1))
SET APCHX(9999999-$PIECE(APCHG(1),U))=""
+5 ;now look at AMHREC field
+6 SET APCHC=0
SET APCHV=""
+7 SET E=0
SET D=9999999-DT-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!(APCHC)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(APCHC)
QUIT
Begin DoDot:1
+8 SET X=$PIECE($GET(^AMHREC(V,14)),U,3)
+9 ;no test
IF X=""
QUIT
+10 ;don't count refusal here
IF $EXTRACT(X)="U"
QUIT
+11 IF X="REF"
QUIT
+12 SET APCHC=APCHC+1
SET APCHX($PIECE(D,"."))=""
End DoDot:1
+13 IF $ORDER(APCHX(0))
QUIT (9999999-$ORDER(APCHX(0)))
+14 QUIT ""
