APCHSM01.m

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

 ;;2.0;IHS PCC SUITE;**2,7,11**;MAY 14, 2009;Build 58

 ;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

PNEU ;EP - pneumovax

 X APCHSURX

 S (APCHA,APCHR,APCHHR)="" ;ALASKA, RISK, HIGH RISK

 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 S APCHSINT=365,APCHMIN=65

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

 S APCHSFLX=$S($$BI^APCHS11C:$O(^AUTTIMM("C",33,"")),1:$O(^AUTTIMM("C",19,""))),APCHIMMC=$S($$BI^APCHS11C:33,1:19)

 S APCHICAR=$$LASTPNEU^APCLAPI4(APCHSPAT,,,"A")

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

 ;get all pneumovax in APCHPNEU=#^date^date^date^date^date

 K APCHPNEU,APCHY

 S %=APCHSPAT_"^ALL IMMUNIZATION "_APCHIMMC,E=$$START1^APCLDF(%,"APCHY(")

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

 I C S $P(APCHPNEU,U,1)=C

 K APCHY

 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="" F APCHSC=33,100,109 Q:V]""  S APCHSFLX=$O(^AUTTIMM("C",APCHSC,0)) D

 ..S V=$$LPNREF(APCHSPAT,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

 I 'APCHSCRI D PNEUIHS Q

PNEUREG ;

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

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

 .S V="" F APCHSC=33,100,109 Q:V]""  S APCHSFLX=$O(^AUTTIMM("C",APCHSC,0)) D

 ..S V=$$LPNREF(APCHSPAT,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=33,100,109 Q:V]""  S APCHSFLX=$O(^AUTTIMM("C",APCHSC,0)) D

 .S V=$$LPNREF(APCHSPAT,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

 ;

PNEUIHS ;should this patient have pneumo reminder?

 I APCHSAGE<5 X APCHSURX Q

 NEW A S A=0 I $G(DUZ(2)) S A=$S($E($P(^AUTTLOC(DUZ(2),0),U,10))=3:1,1:0)

 I A D A Q  ;if alaska do alaska logic

 S APCHR=$$PLTAX^APCHSMU(APCHSPAT,"SURVEILLANCE PNEUMOCOCCAL RISK")

 S APCHHR=$$PLTAX^APCHSMU(APCHSPAT,"APCH PNEUMOVAX REVAX")

 I APCHSAGE<65 D  X APCHSURX Q

 .I 'APCHR Q  ;not high risk, no prompt

 .S D=$$DATEAGE^APCHSMU(APCHSPAT,5)

 .I APCHPNEU="" S APCHSTEX(1)=$$DATE^APCHSMU(D),APCHNEXT="" D  D WRITE^APCHSMU Q

 ..S V=$$LPNREF(APCHSPAT,APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) D S(X)

 .I APCHPNEU]"" D REVAX

 .Q

 I APCHSAGE>64 D  X APCHSURX Q

 .I APCHPNEU="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,65)),APCHNEXT="" D   D WRITE^APCHSMU Q

 ..S V=$$LPNREF(APCHSPAT,APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) D S(X)

 .D REVAX

 Q

REVAX ;

 I APCHSAGE<5 Q

 I APCHSAGE>4&(APCHSAGE<11) D  X APCHSURX Q

 .I 'APCHHR Q  ;not on high risk

 .I APCHPNEU="" S APCHNEXT="",APCHSTEX(1)="REVACCINATION MAY BE DUE NOW" D WRITE^APCHSMU Q

 .I $P(APCHPNEU,U)>1 Q  ;more than 1

 .S %=$P(APCHPNEU,U,2),%=$$FMDIFF^XLFDT(DT,%),%=%/365

 .I $E(%,1)>2 S APCHNEXT="",APCHSTEX(1)="REVACCINATION MAY BE DUE NOW"

 .S %=$$FMADD^XLFDT($P(APCHPNEU,U,2),(3*365))

 .S A=$$FMDIFF^XLFDT(%,APCHSDOB),A=A\365.25

 .I A<11 S APCHNEXT=%,APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT) D WRITE^APCHSMU Q

 .S APCHNEXT=$$FMADD^XLFDT(%,(2*365)),APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT) D WRITE^APCHSMU

 .Q

 I APCHSAGE<65 D  X APCHSURX Q

 .I 'APCHHR Q

 .I APCHPNEU="" S APCHSTEX(1)=$$DATE^APCHSMU(DT) D WRITE^APCHSMU Q

 .I $P(APCHPNEU,U)>1 Q

 .S %=$P(APCHPNEU,U,2),%=$$FMDIFF^XLFDT(DT,%),%=%/365.25

 .I %>5 S APCHSTEX(1)="REVACCINATION MAY BE DUE NOW" D WRITE^APCHSMU Q

 .S APCHNEXT=$$FMADD^XLFDT($P(APCHPNEU,U,2),(5*365)),APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT) D WRITE^APCHSMU Q

 .Q

 I APCHPNEU="" S APCHSTEX(1)="REVACCINATION MAY BE DUE NOW" D WRITE^APCHSMU X APCHSURX Q

 I $P(APCHPNEU,U)>1 X APCHSURX Q

 I ($$FMDIFF^XLFDT($P(APCHPNEU,U,2),APCHSDOB)/365)>65 X APCHSURX Q

 I ($$FMDIFF^XLFDT(DT,$P(APCHPNEU,U,2))\365)>4 S APCHSTEX(1)="REVACCINATION MAY BE DUE NOW" D WRITE^APCHSMU X APCHSURX Q

 S APCHNEXT=$$FMADD^XLFDT($P(APCHPNEU,U,2),(5*365)) S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT) D WRITE^APCHSMU

 X APCHSURX

 Q

A ;

 I A,APCHSAGE>54 S APCHSINT=(5*365) D PNEUREG Q  ;alaska all over 54 do twice 5 years apart

 I A,APCHR S APCHSINT=(5*365) D PNEUREG Q  ;alaska all at risk do twice

 Q

BRSTREF ;

 S V=$$REF^APCHSMU(APCHSPAT,9999999.15,$O(^AUTTEXAM("C","06",0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)

 NEW APCHC

 D BLDTAX^ATXAPI("APCH BREAST EXAM PROCS","APCHC",$O(^ATXAX("B","APCH BREAST EXAM PROCS",0)))

 S V=""

 S APCHC="" F  S APCHC=$O(APCHC(APCHC)) Q:APCHC=""!(V]"")  D

 .S V=$$REF^APCHSMU(APCHSPAT,80.1,APCHC,APCHLAST) I V]"" S X=$P(V,U,1) D S(X) S X=$P(V,U,2) I X]"" D S(X)

 S V=$$REF^APCHSMU(APCHSPAT,81,+$$CODEN^ICPTCOD("G0101"),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)

 Q

BRSTWT ;

 D BRSTREF

 D WRITE^APCHSMU

 X APCHSURX

 Q

BRST ;

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

 NEW APCHMIN

 Q:APCHSEX'="F"

 S (APCHLAST,APCHNEXT,APCHWHL,APCHWHN,APCHSWHR,APCHWHI)="" K APCHSTEX,APCHX

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

 S APCHLAST=$P(APCHICAR,U)

 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 BRSTWT

BRSTREG ;regular stuff

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

 I 'APCHSCRI D

 .Q:APCHSAGE<20

 .S APCHSINT=365

 .S APCHMIN=20

 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  Q

 .D BRSTWT

 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 BRSTWT

 Q

PELVWT ;

 S V=$$REF^APCHSMU(APCHSPAT,9999999.15,$O(^AUTTEXAM("C","15",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

PELV ;

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

 Q:APCHSEX'="F"

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

 S APCHICAR=$$LASTPELV^APCLAPI2(APCHSPAT,APCHSDOB,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)

 .D PELVWT

PELVREG ;regular stuff

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

 I 'APCHSCRI D

 .Q:APCHSAGE<18

 .S APCHSINT=365

 .S APCHMIN=18

 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 PELVWT 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 PELVWT

 Q

PHYSWT ;

 D WRITE^APCHSMU

 X APCHSURX

 Q

PHYS ;

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

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

 S APCHICAR=$$LASTPHYS^APCLAPI2(APCHSPAT,,,"A")

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

PHYSREG ;regular stuff

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

 I 'APCHSCRI S APCHSINT=365,APCHMIN=18

 I 'APCHSCRI Q:APCHSAGE<18

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

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

 I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D PHYSWT 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 PHYSWT

 Q

RECTWT ;

 S V=$$REF^APCHSMU(APCHSPAT,9999999.15,$O(^AUTTEXAM("C","14",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

RECT ;

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

 S (APCHLAST,APCHNEXT,APCHICAR)="" K APCHSTEX

 S APCHICAR=$$LASTRECT^APCLAPI2(APCHSPAT,$$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)

 .D RECTWT

 .Q

RECTREG ;regular stuff

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

 I 'APCHSCRI,APCHSAGE>39 S APCHSINT=365,APCHMIN=40

 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 RECTWT 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 RECTWT

 Q

LPNREF(P,D) ;get last pneumovax refusal

 NEW X,N,C,D,V,L

 I $G(D)="" S D=""

 S T=$G(T)

 S V="",L=""

 F Z=33,100,109 D CHK

 I L="" Q L

 S N=$P(L,U,2)

 S C=$P(L,U,3)

 S L=$P(L,U)

 I D]"",L<D Q ""  ;REFUSED BEFORE DATE OF THE LAST

 I T="I" Q Y  ;quit on internal form of date

 Q $$TYPEREF(N)_$E($$VAL^XBDIQ1(9999999.14,C,.01),1,(44-$L($$TYPEREF(N))))_"^on "_$$FMTE^XLFDT(L)_"^"_L

 Q V

CHK ;

 S C=$O(^AUTTIMM("C",Z,0))

 Q:'C

 S X=$O(^AUPNPREF("AA",APCHSPAT,9999999.14,C,0))

 Q:'X

 S N=$O(^AUPNPREF("AA",APCHSPAT,9999999.14,C,X,0))

 S Y=9999999-X

 I D]"",Y<D Q

 I $P(L,U)]"",Y>$P(L,U) S L=Y_U_N_U_C Q

 I L="" S L=Y_U_N_U_C

 Q

TYPEREF(N) ;EP

 NEW % S %=$P(^AUPNPREF(N,0),U,7)

 I %="R"!(%="") Q "Patient Declined "

 I %="N" Q "Not Medically Indicated "

 I %="F" Q "No Response to F/U "

 I %="U" Q "Unable to Screen "

 Q $$VAL^XBDIQ1(9000022,N,.07)

 ;

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

 +1       ;;2.0;IHS PCC SUITE;**2,7,11**;MAY 14, 2009;Build 58

 +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 

PNEU      ;EP - pneumovax

 +1        XECUTE APCHSURX

 +2       ;ALASKA, RISK, HIGH RISK

           SET (APCHA,APCHR,APCHHR)=""

 +3       ;is item turned on or off

           IF '$$INAC^APCHSMU(APCHSITI)

               QUIT 

 +4        SET APCHSINT=""

           SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)

 +5        IF APCHSCRI

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

               SET APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)

 +6        IF 'APCHSCRI

               SET APCHSINT=365

               SET APCHMIN=65

 +7        SET APCHLAST=""

           SET APCHNEXT=""

           KILL APCHSTEX

 +8        SET APCHSFLX=$SELECT($$BI^APCHS11C:$O(^AUTTIMM("C",33,"")),1:$ORDER(^AUTTIMM("C",19,"")))

           SET APCHIMMC=$SELECT($$BI^APCHS11C:33,1:19)

 +9        SET APCHICAR=$$LASTPNEU^APCLAPI4(APCHSPAT,,,"A")

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

 +11      ;get all pneumovax in APCHPNEU=#^date^date^date^date^date

 +12       KILL APCHPNEU,APCHY

 +13       SET %=APCHSPAT_"^ALL IMMUNIZATION "_APCHIMMC

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

 +14       SET APCHPNEU=""

           SET (X,C)=0

           FOR 

               SET X=$ORDER(APCHY(X))

               IF X'=+X

                   QUIT 

               SET C=C+1

               SET $PIECE(APCHPNEU,U,(C+1))=$PIECE(APCHY(X),U)

 +15       IF C

               SET $PIECE(APCHPNEU,U,1)=C

 +16       KILL APCHY

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

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

               Begin DoDot:1

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

                   DO S(X)

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

                   DO S(X)

 +20               SET V=""

                   FOR APCHSC=33,100,109

                       IF V]""

                           QUIT 

                       SET APCHSFLX=$ORDER(^AUTTIMM("C",APCHSC,0))

                       Begin DoDot:2

 +21                       SET V=$$LPNREF(APCHSPAT,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

 +22               DO WRITE^APCHSMU

 +23               XECUTE APCHSURX

 +24               QUIT 

               End DoDot:1

               QUIT 

 +25       IF 'APCHSCRI

               DO PNEUIHS

               QUIT 

PNEUREG   ;

 +1       ;no frequency so skip it

           IF APCHSINT=""

               XECUTE APCHSURX

               QUIT 

 +2        IF APCHLAST=""

               SET APCHSTEX(1)=$$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)

               Begin DoDot:1

 +3                SET V=""

                   FOR APCHSC=33,100,109

                       IF V]""

                           QUIT 

                       SET APCHSFLX=$ORDER(^AUTTIMM("C",APCHSC,0))

                       Begin DoDot:2

 +4                        SET V=$$LPNREF(APCHSPAT,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=33,100,109

               IF V]""

                   QUIT 

               SET APCHSFLX=$ORDER(^AUTTIMM("C",APCHSC,0))

               Begin DoDot:1

 +12               SET V=$$LPNREF(APCHSPAT,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      ;

PNEUIHS   ;should this patient have pneumo reminder?

 +1        IF APCHSAGE<5

               XECUTE APCHSURX

               QUIT 

 +2        NEW A

           SET A=0

           IF $GET(DUZ(2))

               SET A=$SELECT($EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10))=3:1,1:0)

 +3       ;if alaska do alaska logic

           IF A

               DO A

               QUIT 

 +4        SET APCHR=$$PLTAX^APCHSMU(APCHSPAT,"SURVEILLANCE PNEUMOCOCCAL RISK")

 +5        SET APCHHR=$$PLTAX^APCHSMU(APCHSPAT,"APCH PNEUMOVAX REVAX")

 +6        IF APCHSAGE<65

               Begin DoDot:1

 +7       ;not high risk, no prompt

                   IF 'APCHR

                       QUIT 

 +8                SET D=$$DATEAGE^APCHSMU(APCHSPAT,5)

 +9                IF APCHPNEU=""

                       SET APCHSTEX(1)=$$DATE^APCHSMU(D)

                       SET APCHNEXT=""

                       Begin DoDot:2

 +10                       SET V=$$LPNREF(APCHSPAT,APCHLAST)

                           IF V]""

                               SET X=$PIECE(V,U)

                               DO S(X)

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

                               DO S(X)

                       End DoDot:2

                       DO WRITE^APCHSMU

                       QUIT 

 +11               IF APCHPNEU]""

                       DO REVAX

 +12               QUIT 

               End DoDot:1

               XECUTE APCHSURX

               QUIT 

 +13       IF APCHSAGE>64

               Begin DoDot:1

 +14               IF APCHPNEU=""

                       SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,65))

                       SET APCHNEXT=""

                       Begin DoDot:2

 +15                       SET V=$$LPNREF(APCHSPAT,APCHLAST)

                           IF V]""

                               SET X=$PIECE(V,U)

                               DO S(X)

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

                               DO S(X)

                       End DoDot:2

                       DO WRITE^APCHSMU

                       QUIT 

 +16               DO REVAX

               End DoDot:1

               XECUTE APCHSURX

               QUIT 

 +17       QUIT 

REVAX     ;

 +1        IF APCHSAGE<5

               QUIT 

 +2        IF APCHSAGE>4&(APCHSAGE<11)

               Begin DoDot:1

 +3       ;not on high risk

                   IF 'APCHHR

                       QUIT 

 +4                IF APCHPNEU=""

                       SET APCHNEXT=""

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

                       DO WRITE^APCHSMU

                       QUIT 

 +5       ;more than 1

                   IF $PIECE(APCHPNEU,U)>1

                       QUIT 

 +6                SET %=$PIECE(APCHPNEU,U,2)

                   SET %=$$FMDIFF^XLFDT(DT,%)

                   SET %=%/365

 +7                IF $EXTRACT(%,1)>2

                       SET APCHNEXT=""

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

 +8                SET %=$$FMADD^XLFDT($PIECE(APCHPNEU,U,2),(3*365))

 +9                SET A=$$FMDIFF^XLFDT(%,APCHSDOB)

                   SET A=A\365.25

 +10               IF A<11

                       SET APCHNEXT=%

                       SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

                       DO WRITE^APCHSMU

                       QUIT 

 +11               SET APCHNEXT=$$FMADD^XLFDT(%,(2*365))

                   SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

                   DO WRITE^APCHSMU

 +12               QUIT 

               End DoDot:1

               XECUTE APCHSURX

               QUIT 

 +13       IF APCHSAGE<65

               Begin DoDot:1

 +14               IF 'APCHHR

                       QUIT 

 +15               IF APCHPNEU=""

                       SET APCHSTEX(1)=$$DATE^APCHSMU(DT)

                       DO WRITE^APCHSMU

                       QUIT 

 +16               IF $PIECE(APCHPNEU,U)>1

                       QUIT 

 +17               SET %=$PIECE(APCHPNEU,U,2)

                   SET %=$$FMDIFF^XLFDT(DT,%)

                   SET %=%/365.25

 +18               IF %>5

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

                       DO WRITE^APCHSMU

                       QUIT 

 +19               SET APCHNEXT=$$FMADD^XLFDT($PIECE(APCHPNEU,U,2),(5*365))

                   SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

                   DO WRITE^APCHSMU

                   QUIT 

 +20               QUIT 

               End DoDot:1

               XECUTE APCHSURX

               QUIT 

 +21       IF APCHPNEU=""

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

               DO WRITE^APCHSMU

               XECUTE APCHSURX

               QUIT 

 +22       IF $PIECE(APCHPNEU,U)>1

               XECUTE APCHSURX

               QUIT 

 +23       IF ($$FMDIFF^XLFDT($PIECE(APCHPNEU,U,2),APCHSDOB)/365)>65

               XECUTE APCHSURX

               QUIT 

 +24       IF ($$FMDIFF^XLFDT(DT,$PIECE(APCHPNEU,U,2))\365)>4

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

               DO WRITE^APCHSMU

               XECUTE APCHSURX

               QUIT 

 +25       SET APCHNEXT=$$FMADD^XLFDT($PIECE(APCHPNEU,U,2),(5*365))

           SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)

           DO WRITE^APCHSMU

 +26       XECUTE APCHSURX

 +27       QUIT 

A         ;

 +1       ;alaska all over 54 do twice 5 years apart

           IF A

               IF APCHSAGE>54

                   SET APCHSINT=(5*365)

                   DO PNEUREG

                   QUIT 

 +2       ;alaska all at risk do twice

           IF A

               IF APCHR

                   SET APCHSINT=(5*365)

                   DO PNEUREG

                   QUIT 

 +3        QUIT 

BRSTREF   ;

 +1        SET V=$$REF^APCHSMU(APCHSPAT,9999999.15,$ORDER(^AUTTEXAM("C","06",0)),APCHLAST)

           IF V]""

               SET X=$PIECE(V,U)

               DO S(X)

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

               IF X]""

                   DO S(X)

 +2        NEW APCHC

 +3        DO BLDTAX^ATXAPI("APCH BREAST EXAM PROCS","APCHC",$ORDER(^ATXAX("B","APCH BREAST EXAM PROCS",0)))

 +4        SET V=""

 +5        SET APCHC=""

           FOR 

               SET APCHC=$ORDER(APCHC(APCHC))

               IF APCHC=""!(V]"")

                   QUIT 

               Begin DoDot:1

 +6                SET V=$$REF^APCHSMU(APCHSPAT,80.1,APCHC,APCHLAST)

                   IF V]""

                       SET X=$PIECE(V,U,1)

                       DO S(X)

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

                       IF X]""

                           DO S(X)

               End DoDot:1

 +7        SET V=$$REF^APCHSMU(APCHSPAT,81,+$$CODEN^ICPTCOD("G0101"),APCHLAST)

           IF V]""

               SET X=$PIECE(V,U)

               DO S(X)

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

               IF X]""

                   DO S(X)

 +8        QUIT 

BRSTWT    ;

 +1        DO BRSTREF

 +2        DO WRITE^APCHSMU

 +3        XECUTE APCHSURX

 +4        QUIT 

BRST      ;

 +1       ;is item turned on or off

           IF '$$INAC^APCHSMU(APCHSITI)

               QUIT 

 +2        NEW APCHMIN

 +3        IF APCHSEX'="F"

               QUIT 

 +4        SET (APCHLAST,APCHNEXT,APCHWHL,APCHWHN,APCHSWHR,APCHWHI)=""