APCHSM03.m

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)