APCHSM05 ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;
;;2.0;IHS PCC SUITE;**2,7**;MAY 14, 2009
;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
HEARWT ;
S V=$$REF^APCHSMU(APCHSPAT,9999999.15,$O(^AUTTEXAM("C","17",0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
S V=$$REF^APCHSMU(APCHSPAT,9999999.15,$O(^AUTTEXAM("C","23",0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
S V=$$REF^APCHSMU(APCHSPAT,9999999.15,$O(^AUTTEXAM("C","24",0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
;S V=$$REF^APCHSMU(APCHSPAT,81,+$$CODEN^ICPTCOD(92552),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
;S V=$$REF^APCHSMU(APCHSPAT,81,+$$CODEN^ICPTCOD(92553),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
;S V=$$REF^APCHSMU(APCHSPAT,81,+$$CODEN^ICPTCOD(92555),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
;S V=$$REF^APCHSMU(APCHSPAT,81,+$$CODEN^ICPTCOD(92556),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
S APCHT=$O(^ATXAX("B","APCH HEARING SCREEN CPTS",0))
I APCHT S V=$$CPTREFT^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT) 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
HEAR ;
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHICAR=$$LASTHEAR^APCLAPI3(APCHSPAT,$$DATEAGE^APCHSMU(APCHSPAT,3),,"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 HEARWT
.Q
HEARREG ;regular stuff
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I 'APCHSCRI,APCHSAGE<7 S APCHSINT=365,APCHMIN=3
I 'APCHSCRI Q:APCHSAGE<3
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 HEARWT Q
S APCHSOLD=$$FMDIFF^XLFDT(APCHLAST,APCHSDOB)
I 'APCHSCRI,APCHSAGE>2,APCHSOLD<(3*365) S APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(4*365))) D HEARWT Q
I APCHLAST]"" X APCHSURX Q ;had one in appropriate time so quit
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 HEARWT
Q
STRAB ;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<3
.Q:APCHSAGE>4
.S APCHSINT=(2*365)
.S APCHMIN=3
I APCHSINT="" X APCHSURX Q ;no frequency so skip it
S APCHSTEX(1)="Consider checking for Strabismus" D Q
.D WRITE^APCHSMU
.X APCHSURX
.Q
Q
;
WT ;EP - height
X APCHSURX
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHICAR=$$LASTITEM^APCLAPIU(APCHSPAT,"WT","MEASUREMENT",,,"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 PRWT
WTREG ;
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
I 'APCHSCRI S APCHSINT=365,APCHMIN=0
I APCHSINT="" X APCHSURX Q ;no frequency so skip it
I 'APCHSCRI D IHSWT Q
WTREG1 ;
I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D PRWT 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 PRWT
Q
;
IHSWT ;use IHS default criteria
I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D PRWT Q ;never had one recorded so due on DOB
I APCHSAGE>1 S APCHSINT=365 D WTREG1 Q
;calculate next date due
S APCHDAYS=$$FMDIFF^XLFDT(DT,APCHSDOB)
I APCHDAYS>0,APCHDAYS<(2*30.5) S APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(2*30.5))) D PRWT 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 WTT 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 WTT Q
I APCHDAYS'<(6*30.5),APCHDAYS<365 S APCHNEXT=$$FMADD^XLFDT(APCHSDOB,365),APCHLDUE=$$FMADD^XLFDT(APCHSDOB,(6*30.5)) D WTT Q
I APCHDAYS'<365,APCHDAYS<(18*30.5) S APCHNEXT=$$FMADD^XLFDT(APCHSDOB,(18*30.5)),APCHLDUE=$$FMADD^XLFDT(APCHSDOB,365) D WTT Q
S APCHNEXT=$$FMADD^XLFDT(APCHSDOB,(2*365)),APCHLDUE=$$FMADD^XLFDT(APCHSDOB,(18*30.5)) D WTT Q
Q
WTT ;
I APCHLDUE>APCHLAST S APCHSTEX(1)=$$DATE^APCHSMU(APCHLDUE) D PRWT Q
I APCHNEXT<DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT) D PRWT Q
I APCHNEXT'<DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT) D PRWT Q
Q
PRWT ;
S V=$$REF^APCHSMU(APCHSPAT,9999999.07,$O(^AUTTMSR("B","WT",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
;
REF ;
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
URIN ;
X APCHSURX
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I 'APCHSCRI,APCHSAGE<13 S APCHSINT=365,APCHMIN=5
I 'APCHSCRI Q:APCHSAGE<5
I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
S APCHLAST="",APCHNEXT="",APCHICAR="" K APCHSTEX
S APCHTAXN=$O(^ATXLAB("B","DM AUDIT URINALYSIS TAX",0))
I APCHSINT,APCHTAXN="" S APCHSTEX(1)="DM AUDIT URINALYSIS TAX Taxonomy Missing" D WRITE^APCHSMU X APCHSURX Q
S APCHICAR=$$LASTLAB^APCLAPIU(APCHSPAT,,,,$O(^ATXLAB("B","DM AUDIT URINALYSIS TAX",0)),,$O(^ATXAX("B","DM AUDIT URINALYSIS LOINC",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
URINREG ;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 APCHSOLD=$$FMDIFF^XLFDT(APCHLAST,APCHSDOB)
I 'APCHSCRI,APCHSAGE>3,APCHSOLD<(3*365) S APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(5*365))) D REF,WRITE^APCHSMU X APCHSURX Q
I 'APCHSCRI,APCHSAGE>3,APCHSOLD>(3*365) 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
;
VISIWT ;
S V=$$REF^APCHSMU(APCHSPAT,9999999.15,$O(^AUTTEXAM("C","19",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
VISI ;
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHICAR=$$LASTVAE^APCLAPI1(APCHSPAT,,,"A")
S APCHLAST=$P(APCHICAR,U,1)
VISIREG ;regular stuff
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I 'APCHSCRI,APCHSAGE>64 S APCHSINT=(2*365),APCHMIN=64
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 VISIWT 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 VISIWT
Q
DOMVWT ;
D WRITE^APCHSMU
X APCHSURX
Q
DOMV ;EP - domestic violence
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHLAST=$$LASTHF^APCHSMU(APCHSPAT,"DOMESTIC VIOLENCE")
DOMVREG ;regular stuff
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I 'APCHSCRI,APCHSAGE>14 S APCHSINT=365
I APCHSCRI S APCHSINT=$$AGESEX^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 DOMVWT 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 DOMVWT
Q
IPVWT ;
K APCHV
S V=$$REF^APCHSMU(APCHSPAT,9999999.15,$O(^AUTTEXAM("C","34",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)
.I X="" Q ;no test
.I $E(X)="U" S APCHV(D)="Unable to Screen INT PARTNER VIOLENCE SCREEN",$P(APCHV(D),U,2)="on "_$$FMTE^XLFDT((9999999-$P(D,".")))
.I X="REF" S APCHV(D)="Patient Declined INT PARTNER VIOLENCE SCREEN ",$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)
IPVWT1 ;
D WRITE^APCHSMU
X APCHSURX
Q
IPV ;EP
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHICAR=$$LASTIPVS^APCLAPI(APCHSPAT,,,"A")
S APCHLAST=$P(APCHICAR,U,1)
IPVREG ;regular stuff
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I 'APCHSCRI,APCHSAGE>14,$P(^DPT(APCHSPAT,0),U,2)="F" S APCHSINT=365,APCHMIN=15
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 IPVWT 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 IPVWT
Q
LASTIPV(P) ;
;look for exams and bh
NEW APCHG,%,APCHX,APCHC,APCHV
K APCHG,APCHX S %=P_"^LAST EXAM 34",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)
.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 ""
APCHSM05 ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;
+1 ;;2.0;IHS PCC SUITE;**2,7**;MAY 14, 2009
+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
HEARWT ;
+1 SET V=$$REF^APCHSMU(APCHSPAT,9999999.15,$ORDER(^AUTTEXAM("C","17",0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+2 SET V=$$REF^APCHSMU(APCHSPAT,9999999.15,$ORDER(^AUTTEXAM("C","23",0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+3 SET V=$$REF^APCHSMU(APCHSPAT,9999999.15,$ORDER(^AUTTEXAM("C","24",0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+4 ;S V=$$REF^APCHSMU(APCHSPAT,81,+$$CODEN^ICPTCOD(92552),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
+5 ;S V=$$REF^APCHSMU(APCHSPAT,81,+$$CODEN^ICPTCOD(92553),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
+6 ;S V=$$REF^APCHSMU(APCHSPAT,81,+$$CODEN^ICPTCOD(92555),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
+7 ;S V=$$REF^APCHSMU(APCHSPAT,81,+$$CODEN^ICPTCOD(92556),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
+8 SET APCHT=$ORDER(^ATXAX("B","APCH HEARING SCREEN CPTS",0))
+9 IF APCHT
SET V=$$CPTREFT^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT)
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
HEAR ;
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+3 SET APCHICAR=$$LASTHEAR^APCLAPI3(APCHSPAT,$$DATEAGE^APCHSMU(APCHSPAT,3),,"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 HEARWT
+9 QUIT
End DoDot:1
QUIT
HEARREG ;regular stuff
+1 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+2 IF 'APCHSCRI
IF APCHSAGE<7
SET APCHSINT=365
SET APCHMIN=3
+3 IF 'APCHSCRI
IF APCHSAGE<3
QUIT
+4 ;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)
+5 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+6 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))
DO HEARWT
QUIT
+7 SET APCHSOLD=$$FMDIFF^XLFDT(APCHLAST,APCHSDOB)
+8 IF 'APCHSCRI
IF APCHSAGE>2
IF APCHSOLD<(3*365)
SET APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(4*365)))
DO HEARWT
QUIT
+9 ;had one in appropriate time so quit
IF APCHLAST]""
XECUTE APCHSURX
QUIT
+10 SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
+11 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+12 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+13 DO HEARWT
+14 QUIT
STRAB ;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<3
QUIT
+8 IF APCHSAGE>4
QUIT
+9 SET APCHSINT=(2*365)
+10 SET APCHMIN=3
End DoDot:1
+11 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+12 SET APCHSTEX(1)="Consider checking for Strabismus"
Begin DoDot:1
+13 DO WRITE^APCHSMU
+14 XECUTE APCHSURX
+15 QUIT
End DoDot:1
QUIT
+16 QUIT
+17 ;
WT ;EP - height
+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,"WT","MEASUREMENT",,,"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 PRWT
End DoDot:1
QUIT
WTREG ;
+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
SET APCHSINT=365
SET APCHMIN=0
+4 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+5 IF 'APCHSCRI
DO IHSWT
QUIT
WTREG1 ;
+1 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))
DO PRWT
QUIT
+2 SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
+3 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+4 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+5 DO PRWT
+6 QUIT
+7 ;
IHSWT ;use IHS default criteria
+1 ;never had one recorded so due on DOB
IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))
DO PRWT
QUIT
+2 IF APCHSAGE>1
SET APCHSINT=365
DO WTREG1
QUIT
+3 ;calculate next date due
+4 SET APCHDAYS=$$FMDIFF^XLFDT(DT,APCHSDOB)
+5 IF APCHDAYS>0
IF APCHDAYS<(2*30.5)
SET APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(2*30.5)))
DO PRWT
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 WTT
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 WTT
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 WTT
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 WTT
QUIT
+10 SET APCHNEXT=$$FMADD^XLFDT(APCHSDOB,(2*365))
SET APCHLDUE=$$FMADD^XLFDT(APCHSDOB,(18*30.5))
DO WTT
QUIT
+11 QUIT
WTT ;
+1 IF APCHLDUE>APCHLAST
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHLDUE)
DO PRWT
QUIT
+2 IF APCHNEXT<DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
DO PRWT
QUIT
+3 IF APCHNEXT'<DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
DO PRWT
QUIT
+4 QUIT
PRWT ;
+1 SET V=$$REF^APCHSMU(APCHSPAT,9999999.07,$ORDER(^AUTTMSR("B","WT",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
+4 ;
REF ;
+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
URIN ;
+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
IF APCHSAGE<13
SET APCHSINT=365
SET APCHMIN=5
+5 IF 'APCHSCRI
IF APCHSAGE<5
QUIT
+6 IF APCHSCRI
SET APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT)
SET APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
+7 SET APCHLAST=""
SET APCHNEXT=""
SET APCHICAR=""
KILL APCHSTEX
+8 SET APCHTAXN=$ORDER(^ATXLAB("B","DM AUDIT URINALYSIS TAX",0))
+9 IF APCHSINT
IF APCHTAXN=""
SET APCHSTEX(1)="DM AUDIT URINALYSIS TAX Taxonomy Missing"
DO WRITE^APCHSMU
XECUTE APCHSURX
QUIT
+10 SET APCHICAR=$$LASTLAB^APCLAPIU(APCHSPAT,,,,$ORDER(^ATXLAB("B","DM AUDIT URINALYSIS TAX",0)),,$ORDER(^ATXAX("B","DM AUDIT URINALYSIS LOINC",0)),"A")
+11 SET APCHLAST=$PIECE(APCHICAR,U,1)
+12 SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
+13 IF $PIECE(APCHOVR,U)>APCHLAST
Begin DoDot:1
+14 SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"
DO S(X)
SET X=$PIECE(APCHOVR,U,3)
DO S(X)
+15 DO REF
+16 DO WRITE^APCHSMU
+17 XECUTE APCHSURX
+18 QUIT
End DoDot:1
QUIT
URINREG ;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 APCHSOLD=$$FMDIFF^XLFDT(APCHLAST,APCHSDOB)
+8 IF 'APCHSCRI
IF APCHSAGE>3
IF APCHSOLD<(3*365)
SET APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(5*365)))
DO REF
DO WRITE^APCHSMU
XECUTE APCHSURX
QUIT
+9 IF 'APCHSCRI
IF APCHSAGE>3
IF APCHSOLD>(3*365)
XECUTE APCHSURX
QUIT
+10 SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
+11 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+12 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+13 DO REF
+14 DO WRITE^APCHSMU
+15 XECUTE APCHSURX
+16 QUIT
+17 ;
VISIWT ;
+1 SET V=$$REF^APCHSMU(APCHSPAT,9999999.15,$ORDER(^AUTTEXAM("C","19",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
+3 XECUTE APCHSURX
+4 QUIT
VISI ;
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+3 SET APCHICAR=$$LASTVAE^APCLAPI1(APCHSPAT,,,"A")
+4 SET APCHLAST=$PIECE(APCHICAR,U,1)
VISIREG ;regular stuff
+1 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+2 IF 'APCHSCRI
IF APCHSAGE>64
SET APCHSINT=(2*365)
SET APCHMIN=64
+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 VISIWT
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 VISIWT
+10 QUIT
DOMVWT ;
+1 DO WRITE^APCHSMU
+2 XECUTE APCHSURX
+3 QUIT
DOMV ;EP - domestic violence
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+3 SET APCHLAST=$$LASTHF^APCHSMU(APCHSPAT,"DOMESTIC VIOLENCE")
DOMVREG ;regular stuff
+1 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+2 IF 'APCHSCRI
IF APCHSAGE>14
SET APCHSINT=365
+3 ;return in APCHSINT the frequency in days for this age/sex
IF APCHSCRI
SET APCHSINT=$$AGESEX^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 DOMVWT
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 DOMVWT
+10 QUIT
IPVWT ;
+1 KILL APCHV
+2 SET V=$$REF^APCHSMU(APCHSPAT,9999999.15,$ORDER(^AUTTEXAM("C","34",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)
+8 ;no test
IF X=""
QUIT
+9 IF $EXTRACT(X)="U"
SET APCHV(D)="Unable to Screen INT PARTNER VIOLENCE SCREEN"
SET $PIECE(APCHV(D),U,2)="on "_$$FMTE^XLFDT((9999999-$PIECE(D,".")))
+10 IF X="REF"
SET APCHV(D)="Patient Declined INT PARTNER VIOLENCE SCREEN "
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)
IPVWT1 ;
+1 DO WRITE^APCHSMU
+2 XECUTE APCHSURX
+3 QUIT
IPV ;EP
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+3 SET APCHICAR=$$LASTIPVS^APCLAPI(APCHSPAT,,,"A")
+4 SET APCHLAST=$PIECE(APCHICAR,U,1)
IPVREG ;regular stuff
+1 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+2 IF 'APCHSCRI
IF APCHSAGE>14
IF $PIECE(^DPT(APCHSPAT,0),U,2)="F"
SET APCHSINT=365
SET APCHMIN=15
+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 IPVWT
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 IPVWT
+10 QUIT
LASTIPV(P) ;
+1 ;look for exams and bh
+2 NEW APCHG,%,APCHX,APCHC,APCHV
+3 KILL APCHG,APCHX
SET %=P_"^LAST EXAM 34"
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)
+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 ""
