APCHSM08.m

APCHSM08 ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;

 ;;2.0;IHS PCC SUITE;**2,8,11,16**;MAY 14, 2009;Build 9

 ;

S(X) ;

 NEW %,C S (C,%)=0 F  S %=$O(APCHSTEX(%)) Q:%'=+%  S C=C+1

 S APCHSTEX(C+1)=X

 Q

DSSWT ;

 D WRITE^APCHSMU

 X APCHSURX

 Q

DSS ;EP - depression screen score

 ;this logic is specific to ANMC and is not IHS standard

 Q:'$$INAC^APCHSMU(APCHSITI)  ;is item turned on or off

 Q:$$AGE^AUPNPAT(APCHSPAT)<18  ;18 years and older only

 S APCHLAST="",APCHNEXT="" K APCHSTEX

 ;check to see if any in past 365 days is 10 or over

 S APCHSPOS=$$POS(APCHSPAT)

 I APCHLAST="" S APCHLAST=$$LASTHF^APCHSMU(APCHSPAT,"MENTAL HEALTH"),APCHLAS1=$$LASTHF^APCHSMU(APCHSPAT,"MENTAL HEALTH","S")

 I 'APCHSPOS S APCHSINT=$S(APCHLAS1>9:28,APCHLAS1="":0,1:365)

 I APCHSPOS S APCHSINT=$S(APCHLAS1>5:28,APCHLAS1="":0,1:365)

 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

DSSREG ;regular stuff

 ;S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI) ;not site definable

 ;S APCHSINT=""

 ;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)="MAY BE DUE NOW" D DSSWT Q

 S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)

 I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

 I APCHNEXT'>DT S APCHSTEX(1)="MAY BE DUE NOW (WAS DUE "_$$DATE^APCHSMU(APCHNEXT)_")"

 D DSSWT

 Q

POS(P) ;is any DSS over 10 in past 365 days?

 I '$G(P) Q ""

 S C=$O(^AUTTHF("B","MENTAL HEALTH",0)) ;ien of category passed

 I '$G(C) Q ""

 NEW H,D,O,S,G,A S H=0,(S,G)="" K O

 S A=$$FMADD^XLFDT(DT,-365)

 F  S H=$O(^AUTTHF("AC",C,H)) Q:H'=+H!(G)  D

 .  Q:'$D(^AUPNVHF("AA",P,H))

 .  S D=0 F  S D=$O(^AUPNVHF("AA",P,H,D)) Q:D'=+D!(G)  D

 .. Q:(9999999-D)<A  ;before 365 days

 .. S I=0 F  S I=$O(^AUPNVHF("AA",P,H,D,I)) Q:I'=+I!(G)  D

 ... Q:$P(^AUPNVHF(I,0),U,6)<10

 ... S G=1

 .. Q

 .  Q

 Q G

 ;

MMR1D(P) ;

 I $$AGE^AUPNPAT(P)<18 Q 0  ;no one under 18

 I $$SEX^AUPNPAT(P)="F",$$AGE^AUPNPAT(P)<50 Q 1

 I $E($$DOB^AUPNPAT(P),1,3)<257 Q 0

 Q 1

 ;

MMR1 ;EP - mmr one dose version

 Q:'$$INAC^APCHSMU(APCHSITI)  ;is item turned on or off

 S APCHLAST="",APCHNEXT="" K APCHSTEX

 S APCHICAR=$$LASTMMR^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)

 .S APCHLR=""

 .S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",3,0)),APCHLAST) I V]"" S APCHLR=V

 .S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",94,0)),APCHLAST) I V]"",$P(V,U,3)]$P(APCHLR,U,3) S APCHLR=V

 .I APCHLR]"" S X=$P(APCHLR,U) D S(X) S X=$P(APCHLR,U,2) I X]"" D S(X)

 .D WRITE^APCHSMU

 .X APCHSURX

 .Q

 S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)

 I 'APCHSCRI D

 .Q:'$$MMR1D(APCHSPAT)

 .S APCHSINT=9999999

 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]"",APCHLAST'<$$FMADD^XLFDT($$DOB^AUPNPAT(APCHSPAT),365) Q  ;had one so skip this prompt

 S APCHSTEX(1)="MAY BE DUE FOR MMR VACCINATION" D  Q

 .S APCHLR=""

 .S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",3,0)),APCHLAST) I V]"" S APCHLR=V

 .S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",94,0)),APCHLAST) I V]"",$P(V,U,3)]$P(APCHLR,U,3) S APCHLR=V

 .I APCHLR]"" S X=$P(APCHLR,U) D S(X) S X=$P(APCHLR,U,2) I X]"" D S(X)

 .D WRITE^APCHSMU

 .X APCHSURX

 .Q

 Q

MMR2 ;EP - mmr two dose version

 Q:'$$INAC^APCHSMU(APCHSITI)  ;is item turned on or off

 S APCHLAST="",APCHNEXT="" K APCHSTEX

 S APCHICAR=$$LASTMMR^APCLAPI3(APCHSPAT,,,"A")

 S APCHLAST=$P(APCHICAR,U,1)

 ;get all MMR in APCHMMR=#^date^date^date^date^date

 K APCHMMR,APCHY

 S %=APCHSPAT_"^ALL IMMUNIZATION 3;DURING "_$$FMADD^XLFDT($$DOB^AUPNPAT(APCHSPAT),365)_"-"_DT,E=$$START1^APCLDF(%,"APCHY(") ;get all MMR's from 1yr old to today

 ;REORDER THEM BY DATE

 S X=0 F  S X=$O(APCHY(X)) Q:X'=+X  S APCHMMR($P(APCHY(X),U))=""

 K APCHY

 S %=APCHSPAT_"^ALL IMMUNIZATION 94;DURING "_$$FMADD^XLFDT($$DOB^AUPNPAT(APCHSPAT),365)_"-"_DT,E=$$START1^APCLDF(%,"APCHY(") ;get all MMRV's from 1yr old to today

 ;REORDER THEM BY DATE

 S X=0 F  S X=$O(APCHY(X)) Q:X'=+X  S APCHMMR($P(APCHY(X),U))=""

  K APCHY

 S %=APCHSPAT_"^ALL DX [BGP MMR IZ DXS;DURING "_$$FMADD^XLFDT($$DOB^AUPNPAT(APCHSPAT),365)_"-"_DT,E=$$START1^APCLDF(%,"APCHY(") ;get all MMRV's from 1yr old to today

 ;REORDER THEM BY DATE

 S X=0 F  S X=$O(APCHY(X)) Q:X'=+X  S APCHMMR($P(APCHY(X),U))=""

 K APCHY

 S %=APCHSPAT_"^ALL PROC [BGP MMR IZ PROCS;DURING "_$$FMADD^XLFDT($$DOB^AUPNPAT(APCHSPAT),365)_"-"_DT,E=$$START1^APCLDF(%,"APCHY(") ;get all MMRV's from 1yr old to today

 ;REORDER THEM BY DATE

 S X=0 F  S X=$O(APCHY(X)) Q:X'=+X  S APCHMMR($P(APCHY(X),U))=""

 K APCHY

 NEW T1,T2,C

 S T1=+$$CODEN^ICPTCOD(90707),T2=+$$CODEN^ICPTCOD(90710),C=0

  I T1,$D(^AUPNVCPT("AA",APCHSPAT,T1)) S %="" D  I %]"" Q %

 .S E=0 F  S E=$O(^AUPNVCPT("AA",APCHSPAT,T1,E)) Q:E'=+E  D

 ..S D=9999999-E

 ..S C=C+1,APCHY(C)=D

 ..Q

 .Q

 I T2,$D(^AUPNVCPT("AA",APCHSPAT,T2)) S %="" D  I %]"" Q %

 .S E=0 F  S E=$O(^AUPNVCPT("AA",APCHSPAT,T2,E)) Q:E'=+E  D

 ..S D=9999999-E

 ..S C=C+1,APCHY(C)=D

 ..Q

 .Q

 S X=0 F  S X=$O(APCHY(X)) Q:X'=+X  S APCHMMR($P(APCHY(X),U))=""

 K APCHY

 ;

 ;now check to see if 1 or 2 in appropriate intervals

 ;apchya1y - the one after 1 yr

 ;apchya1m - the one after 1 yr and at least 1 month after that 1

 K APCHYA1Y,APCHYA1M

 S D=0 F  S D=$O(APCHMMR(D)) Q:D'=+D  D

 .I '$D(APCHYA1Y) S APCHYA1Y=D K APCHMMR(D) Q

 .I $$FMDIFF^XLFDT(D,APCHYA1Y)>30 S APCHYA1M=1 K APCHMMR(D)

 .Q

 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 APCHLR=""

 .S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",3,0)),APCHLAST) I V]"" S APCHLR=V

 .S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",94,0)),APCHLAST) I V]"",$P(V,U,3)]$P(APCHLR,U,3) S APCHLR=V

 .I APCHLR]"" S X=$P(APCHLR,U) D S(X) S X=$P(APCHLR,U,2) I X]"" D S(X)

 .D WRITE^APCHSMU

 .X APCHSURX

 .Q

 S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)

 I 'APCHSCRI D

 .Q:'$$MMR1D(APCHSPAT)

 .S APCHSINT=9999999

 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 $D(APCHYA1M) X APCHSURX Q  ;had both so skip prompt

 I '$D(APCHYA1Y) S APCHSTEX(1)="MAY BE DUE FOR MMR #1 VACCINATION" D  Q  ;if never had one

 .S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",3,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 APCHSTEX(1)="MAY BE DUE FOR MMR #2 VACCINATION" D

 .S APCHLR=""

 .S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",3,0)),APCHLAST) I V]"" S APCHLR=V

 .S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",94,0)),APCHLAST) I V]"",$P(V,U,3)]$P(APCHLR,U,3) S APCHLR=V

 .I APCHLR]"" S X=$P(APCHLR,U) D S(X) S X=$P(APCHLR,U,2) I X]"" D S(X)

 .D WRITE^APCHSMU

 .X APCHSURX

 .Q

 Q

RUB ;EP

 Q:'$$INAC^APCHSMU(APCHSITI)  ;is item turned on or off

 S APCHLAST="",APCHNEXT="" K APCHSTEX

 S APCHICAR=$$LASTRUB^APCLAPI3(APCHSPAT,,,"A")

 S APCHLAST=$P(APCHICAR,U,1)

 I APCHLAST]"",APCHLAST<$$FMADD^XLFDT($$DOB^AUPNPAT(APCHSPAT),365) S APCHLAST=""

 Q:'$$MMR1D(APCHSPAT)

 Q:APCHLAST]""

 S APCHSINT=9999999

 S APCHRIHF=$$LASTHF^APCHSMU(APCHSPAT,"RUBELLA IMMUNITY STATUS","N")

 I APCHRIHF="IMMUNE" X APCHSURX Q  ;do not display prompt if hf is immune

 ;check imm package for Immune status

 I $$RUBIMM(APCHSPAT,6,DT) X APCHSURX Q  ;immune for rubella

 D GETTPT^APCHSTP(APCHSITI,APCHCOLW,.APCHSTEX,APCHLAST,APCHRIHF)

 D WRITETP^APCHSTP

 Q

RUBIMM(P,C,ED) ;EP - ANApHYLAXIS/NEOMYCIN/IMMUNE CONTRAINDICATION

 NEW X

 S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G)  D

 .S R=$P(^BIPC(X,0),U,3)

 .Q:R=""

 .Q:'$D(^BICONT(R,0))

 .S D=$P(^BIPC(X,0),U,4)

 .Q:D=""

 .;Q:$P(^BIPC(X,0),U,4)<BD

 .Q:$P(^BIPC(X,0),U,4)>ED

 .I $P(^BICONT(R,0),U,1)="Immune" S G=D_U_"Immune"

 Q G

RUBWT ;

 S APCHLR=""

 S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",3,0)),APCHLAST) I V]"" S APCHLR=V

 S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",4,0)),APCHLAST) I V]"",$P(V,U,3)]$P(APCHLR,U,3) S APCHLR=V

 S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",6,0)),APCHLAST) I V]"",$P(V,U,3)]$P(APCHLR,U,3) S APCHLR=V

 S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",38,0)),APCHLAST) I V]"",$P(V,U,3)]$P(APCHLR,U,3) S APCHLR=V

 S V=$$REF^APCHSMU(APCHSPAT,9999999.14,$O(^AUTTIMM("C",94,0)),APCHLAST) I V]"",$P(V,U,3)]$P(APCHLR,U,3) S APCHLR=V

 I APCHLR]"" S X=$P(APCHLR,U) D S(X) S X=$P(APCHLR,U,2) I X]"" D S(X)

 D WRITE^APCHSMU

 X APCHSURX

 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

NEWBORNH ;

 Q:'$$INAC^APCHSMU(APCHSITI)  ;is item turned on or off

 S APCHLAST="",APCHNEXT="" K APCHSTEX

 Q:$$PLTAX^APCHSMU(APCHSPAT,"APCH HEARING LOSS DXS")  ;hearing loss on problem list

 S D=$$DATEAGE^APCHSMU(APCHSPAT,1)

 I DT>$$FMADD^XLFDT(D,-1) Q  ;last day before 1st birthday

 S APCHICAR=$$LASTNBHS^APCLAPI5(APCHSPAT,,,"A")

 S APCHLAST=$P(APCHICAR,U,1)

 I APCHLAST]"" Q  ;had one and only need one

 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=1,APCHMIN=0

 I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D HEARWT Q

 Q

APCHSM08  ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;

 +1       ;;2.0;IHS PCC SUITE;**2,8,11,16**;MAY 14, 2009;Build 9

 +2       ;

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 

DSSWT     ;

 +1        DO WRITE^APCHSMU

 +2        XECUTE APCHSURX

 +3        QUIT 

DSS       ;EP - depression screen score

 +1       ;this logic is specific to ANMC and is not IHS standard

 +2       ;is item turned on or off

           IF '$$INAC^APCHSMU(APCHSITI)

               QUIT 

 +3       ;18 years and older only

           IF $$AGE^AUPNPAT(APCHSPAT)<18

               QUIT 

 +4        SET APCHLAST=""

           SET APCHNEXT=""

           KILL APCHSTEX

 +5       ;check to see if any in past 365 days is 10 or over

 +6        SET APCHSPOS=$$POS(APCHSPAT)

 +7        IF APCHLAST=""

               SET APCHLAST=$$LASTHF^APCHSMU(APCHSPAT,"MENTAL HEALTH")

               SET APCHLAS1=$$LASTHF^APCHSMU(APCHSPAT,"MENTAL HEALTH","S")

 +8        IF 'APCHSPOS

               SET APCHSINT=$SELECT(APCHLAS1>9:28,APCHLAS1="":0,1:365)

 +9        IF APCHSPOS

               SET APCHSINT=$SELECT(APCHLAS1>5:28,APCHLAS1="":0,1:365)

 +10       SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)

 +11       IF $PIECE(APCHOVR,U)>APCHLAST

               Begin DoDot:1

 +12               SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"

                   DO S(X)

                   SET X=$PIECE(APCHOVR,U,3)

                   DO S(X)

 +13               DO WRITE^APCHSMU

 +14               XECUTE APCHSURX

 +15               QUIT 

               End DoDot:1

               QUIT 

DSSREG    ;regular stuff

 +1       ;S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI) ;not site definable

 +2       ;S APCHSINT=""

 +3       ;I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT) ;return in APCHSINT the frequency in days for this age/sex

 +4       ;I APCHSINT="" X APCHSURX Q  ;no frequency so skip it

 +5        IF APCHLAST=""

               SET APCHSTEX(1)="MAY BE DUE NOW"

               DO DSSWT

               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)="MAY BE DUE NOW (WAS DUE "_$$DATE^APCHSMU(APCHNEXT)_")"

 +9        DO DSSWT

 +10       QUIT 

POS(P)    ;is any DSS over 10 in past 365 days?

 +1        IF '$GET(P)

               QUIT ""

 +2       ;ien of category passed

           SET C=$ORDER(^AUTTHF("B","MENTAL HEALTH",0))

 +3        IF '$GET(C)

               QUIT ""

 +4        NEW H,D,O,S,G,A

           SET H=0

           SET (S,G)=""

           KILL O

 +5        SET A=$$FMADD^XLFDT(DT,-365)

 +6        FOR 

               SET H=$ORDER(^AUTTHF("AC",C,H))

               IF H'=+H!(G)

                   QUIT 

               Begin DoDot:1

 +7                IF '$DATA(^AUPNVHF("AA",P,H))

                       QUIT 

 +8                SET D=0

                   FOR 

                       SET D=$ORDER(^AUPNVHF("AA",P,H,D))

                       IF D'=+D!(G)

                           QUIT 

                       Begin DoDot:2

 +9       ;before 365 days

                           IF (9999999-D)<A

                               QUIT 

 +10                       SET I=0

                           FOR 

                               SET I=$ORDER(^AUPNVHF("AA",P,H,D,I))

                               IF I'=+I!(G)

                                   QUIT 

                               Begin DoDot:3

 +11                               IF $PIECE(^AUPNVHF(I,0),U,6)<10

                                       QUIT 

 +12                               SET G=1

                               End DoDot:3

 +13                       QUIT 

                       End DoDot:2

 +14               QUIT 

               End DoDot:1

 +15       QUIT G

 +16      ;

MMR1D(P)  ;

 +1       ;no one under 18

           IF $$AGE^AUPNPAT(P)<18

               QUIT 0

 +2        IF $$SEX^AUPNPAT(P)="F"

               IF $$AGE^AUPNPAT(P)<50

                   QUIT 1

 +3        IF $EXTRACT($$DOB^AUPNPAT(P),1,3)<257

               QUIT 0

 +4        QUIT 1

 +5       ;

MMR1      ;EP - mmr one dose version

 +1       ;is item turned on or off

           IF '$$INAC^APCHSMU(APCHSITI)

               QUIT 

 +2        SET APCHLAST=""

           SET APCHNEXT=""

           KILL APCHSTEX

 +3        SET APCHICAR=$$LASTMMR^APCLAPI3(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                SET APCHLR=""

 +9                SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,$ORDER(^AUTTIMM("C",3,0)),APCHLAST)

                   IF V]""

                       SET APCHLR=V

 +10               SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,$ORDER(^AUTTIMM("C",94,0)),APCHLAST)

                   IF V]""

                       IF $PIECE(V,U,3)]$PIECE(APCHLR,U,3)

                           SET APCHLR=V

 +11               IF APCHLR]""

                       SET X=$PIECE(APCHLR,U)

                       DO S(X)

                       SET X=$PIECE(APCHLR,U,2)

                       IF X]""

                           DO S(X)

 +12               DO WRITE^APCHSMU

 +13               XECUTE APCHSURX

 +14               QUIT 

               End DoDot:1

               QUIT 

 +15       SET APCHSINT=""

           SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)

 +16       IF 'APCHSCRI

               Begin DoDot:1

 +17               IF '$$MMR1D(APCHSPAT)

                       QUIT 

 +18               SET APCHSINT=9999999

               End DoDot:1

 +19      ;return in APCHSINT the frequency in days for this age/sex

           IF APCHSCRI

               SET APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT)

 +20      ;no frequency so skip it

           IF APCHSINT=""

               XECUTE APCHSURX

               QUIT 

 +21      ;had one so skip this prompt

           IF APCHLAST]""

               IF APCHLAST'<$$FMADD^XLFDT($$DOB^AUPNPAT(APCHSPAT),365)

                   QUIT 

 +22       SET APCHSTEX(1)="MAY BE DUE FOR MMR VACCINATION"

           Begin DoDot:1

 +23           SET APCHLR=""

 +24           SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,$ORDER(^AUTTIMM("C",3,0)),APCHLAST)

               IF V]""

                   SET APCHLR=V

 +25           SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,$ORDER(^AUTTIMM("C",94,0)),APCHLAST)

               IF V]""

                   IF $PIECE(V,U,3)]$PIECE(APCHLR,U,3)

                       SET APCHLR=V

 +26           IF APCHLR]""

                   SET X=$PIECE(APCHLR,U)

                   DO S(X)

                   SET X=$PIECE(APCHLR,U,2)

                   IF X]""

                       DO S(X)

 +27           DO WRITE^APCHSMU

 +28           XECUTE APCHSURX

 +29           QUIT 

           End DoDot:1

           QUIT 

 +30       QUIT 

MMR2      ;EP - mmr two dose version

 +1       ;is item turned on or off

           IF '$$INAC^APCHSMU(APCHSITI)

               QUIT 

 +2        SET APCHLAST=""

           SET APCHNEXT=""

           KILL APCHSTEX

 +3        SET APCHICAR=$$LASTMMR^APCLAPI3(APCHSPAT,,,"A")

 +4        SET APCHLAST=$PIECE(APCHICAR,U,1)

 +5       ;get all MMR in APCHMMR=#^date^date^date^date^date

 +6        KILL APCHMMR,APCHY

 +7       ;get all MMR's from 1yr old to today

           SET %=APCHSPAT_"^ALL IMMUNIZATION 3;DURING "_$$FMADD^XLFDT($$DOB^AUPNPAT(APCHSPAT),365)_"-"_DT

           SET E=$$START1^APCLDF(%,"APCHY(")

 +8       ;REORDER THEM BY DATE

 +9        SET X=0

           FOR 

               SET X=$ORDER(APCHY(X))

               IF X'=+X

                   QUIT 

               SET APCHMMR($PIECE(APCHY(X),U))=""

 +10       KILL APCHY

 +11      ;get all MMRV's from 1yr old to today

           SET %=APCHSPAT_"^ALL IMMUNIZATION 94;DURING "_$$FMADD^XLFDT($$DOB^AUPNPAT(APCHSPAT),365)_"-"_DT

           SET E=$$START1^APCLDF(%,"APCHY(")

 +12      ;REORDER THEM BY DATE

 +13       SET X=0

           FOR 

               SET X=$ORDER(APCHY(X))

               IF X'=+X

                   QUIT 

               SET APCHMMR($PIECE(APCHY(X),U))=""

 +14       KILL APCHY

 +15      ;get all MMRV's from 1yr old to today

           SET %=APCHSPAT_"^ALL DX [BGP MMR IZ DXS;DURING "_$$FMADD^XLFDT($$DOB^AUPNPAT(APCHSPAT),365)_"-"_DT

           SET E=$$START1^APCLDF(%,"APCHY(")

 +16      ;REORDER THEM BY DATE

 +17       SET X=0

           FOR 

               SET X=$ORDER(APCHY(X))

               IF X'=+X

                   QUIT 

               SET APCHMMR($PIECE(APCHY(X),U))=""

 +18       KILL APCHY

 +19      ;get all MMRV's from 1yr old to today

           SET %=APCHSPAT_"^ALL PROC [BGP MMR IZ PROCS;DURING "_$$FMADD^XLFDT($$DOB^AUPNPAT(APCHSPAT),365)_"-"_DT

           SET E=$$START1^APCLDF(%,"APCHY(")

 +20      ;REORDER THEM BY DATE

 +21       SET X=0

           FOR 

               SET X=$ORDER(APCHY(X))

               IF X'=+X

                   QUIT 

               SET APCHMMR($PIECE(APCHY(X),U))=""

 +22       KILL APCHY

 +23       NEW T1,T2,C

 +24       SET T1=+$$CODEN^ICPTCOD(90707)

           SET T2=+$$CODEN^ICPTCOD(90710)

           SET C=0

 +25       IF T1

               IF $DATA(^AUPNVCPT("AA",APCHSPAT,T1))

                   SET %=""

                   Begin DoDot:1

 +26                   SET E=0

                       FOR 

                           SET E=$ORDER(^AUPNVCPT("AA",APCHSPAT,T1,E))

                           IF E'=+E

                               QUIT 

                           Begin DoDot:2

 +27                           SET D=9999999-E

 +28                           SET C=C+1

                               SET APCHY(C)=D

 +29                           QUIT 

                           End DoDot:2

 +30                   QUIT 

                   End DoDot:1

                   IF %]""

                       QUIT %

 +31       IF T2

               IF $DATA(^AUPNVCPT("AA",APCHSPAT,T2))

                   SET %=""

                   Begin DoDot:1

 +32                   SET E=0

                       FOR 

                           SET E=$ORDER(^AUPNVCPT("AA",APCHSPAT,T2,E))

                           IF E'=+E

                               QUIT 

                           Begin DoDot:2

 +33                           SET D=9999999-E

 +34                           SET C=C+1

                               SET APCHY(C)=D

 +35                           QUIT 

                           End DoDot:2

 +36                   QUIT 

                   End DoDot:1

                   IF %]""

                       QUIT %

 +37       SET X=0

           FOR 

               SET X=$ORDER(APCHY(X))

               IF X'=+X

                   QUIT 

               SET APCHMMR($PIECE(APCHY(X),U))=""

 +38       KILL APCHY

 +39      ;

 +40      ;now check to see if 1 or 2 in appropriate intervals

 +41      ;apchya1y - the one after 1 yr

 +42      ;apchya1m - the one after 1 yr and at least 1 month after that 1

 +43       KILL APCHYA1Y,APCHYA1M

 +44       SET D=0

           FOR 

               SET D=$ORDER(APCHMMR(D))

               IF D'=+D

                   QUIT 

               Begin DoDot:1

 +45               IF '$DATA(APCHYA1Y)

                       SET APCHYA1Y=D

                       KILL APCHMMR(D)

                       QUIT 

 +46               IF $$FMDIFF^XLFDT(D,APCHYA1Y)>30

                       SET APCHYA1M=1

                       KILL APCHMMR(D)

 +47               QUIT 

               End DoDot:1

 +48       SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)

 +49       IF $PIECE(APCHOVR,U)>APCHLAST

               Begin DoDot:1

 +50               SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"