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)=""
KILL APCHSTEX,APCHX
+5 SET APCHICAR=$$LASTBRST^APCLAPI3(APCHSPAT,,,"A")
+6 SET APCHLAST=$PIECE(APCHICAR,U)
+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 BRSTWT
End DoDot:1
QUIT
BRSTREG ;regular stuff
+1 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+2 IF 'APCHSCRI
Begin DoDot:1
+3 IF APCHSAGE<20
QUIT
+4 SET APCHSINT=365
+5 SET APCHMIN=20
End DoDot:1
+6 ;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)
+7 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+8 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))
Begin DoDot:1
+9 DO BRSTWT
End DoDot:1
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 BRSTWT
+14 QUIT
PELVWT ;
+1 SET V=$$REF^APCHSMU(APCHSPAT,9999999.15,$ORDER(^AUTTEXAM("C","15",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
PELV ;
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 IF APCHSEX'="F"
QUIT
+3 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+4 SET APCHICAR=$$LASTPELV^APCLAPI2(APCHSPAT,APCHSDOB,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 DO PELVWT
End DoDot:1
QUIT
PELVREG ;regular stuff
+1 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
SET APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
+2 IF 'APCHSCRI
Begin DoDot:1
+3 IF APCHSAGE<18
QUIT
+4 SET APCHSINT=365
+5 SET APCHMIN=18
End DoDot:1
+6 ;return in APCHSINT the frequency in days for this age/sex
IF APCHSCRI
SET APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT)
+7 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+8 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))
DO PELVWT
QUIT
+9 SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
+10 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+11 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+12 DO PELVWT
+13 QUIT
PHYSWT ;
+1 DO WRITE^APCHSMU
+2 XECUTE APCHSURX
+3 QUIT
PHYS ;
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+3 SET APCHICAR=$$LASTPHYS^APCLAPI2(APCHSPAT,,,"A")
+4 SET APCHLAST=$PIECE(APCHICAR,U,1)
PHYSREG ;regular stuff
+1 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+2 IF 'APCHSCRI
SET APCHSINT=365
SET APCHMIN=18
+3 IF 'APCHSCRI
IF APCHSAGE<18
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 PHYSWT
QUIT
+7 SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
+8 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+9 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+10 DO PHYSWT
+11 QUIT
RECTWT ;
+1 SET V=$$REF^APCHSMU(APCHSPAT,9999999.15,$ORDER(^AUTTEXAM("C","14",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
RECT ;
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 SET (APCHLAST,APCHNEXT,APCHICAR)=""
KILL APCHSTEX
+3 SET APCHICAR=$$LASTRECT^APCLAPI2(APCHSPAT,$$DOB^AUPNPAT(APCHSPAT),DT,"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 RECTWT
+9 QUIT
End DoDot:1
QUIT
RECTREG ;regular stuff
+1 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+2 IF 'APCHSCRI
IF APCHSAGE>39
SET APCHSINT=365
SET APCHMIN=40
+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 RECTWT
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 RECTWT
+10 QUIT
LPNREF(P,D) ;get last pneumovax refusal
+1 NEW X,N,C,D,V,L
+2 IF $GET(D)=""
SET D=""
+3 SET T=$GET(T)
+4 SET V=""
SET L=""
+5 FOR Z=33,100,109
DO CHK
+6 IF L=""
QUIT L
+7 SET N=$PIECE(L,U,2)
+8 SET C=$PIECE(L,U,3)
+9 SET L=$PIECE(L,U)
+10 ;REFUSED BEFORE DATE OF THE LAST
IF D]""
IF L<D
QUIT ""
+11 ;quit on internal form of date
IF T="I"
QUIT Y
+12 QUIT $$TYPEREF(N)_$EXTRACT($$VAL^XBDIQ1(9999999.14,C,.01),1,(44-$LENGTH($$TYPEREF(N))))_"^on "_$$FMTE^XLFDT(L)_"^"_L
+13 QUIT V
CHK ;
+1 SET C=$ORDER(^AUTTIMM("C",Z,0))
+2 IF 'C
QUIT
+3 SET X=$ORDER(^AUPNPREF("AA",APCHSPAT,9999999.14,C,0))
+4 IF 'X
QUIT
+5 SET N=$ORDER(^AUPNPREF("AA",APCHSPAT,9999999.14,C,X,0))
+6 SET Y=9999999-X
+7 IF D]""
IF Y<D
QUIT
+8 IF $PIECE(L,U)]""
IF Y>$PIECE(L,U)
SET L=Y_U_N_U_C
QUIT
+9 IF L=""
SET L=Y_U_N_U_C
+10 QUIT
TYPEREF(N) ;EP
+1 NEW %
SET %=$PIECE(^AUPNPREF(N,0),U,7)
+2 IF %="R"!(%="")
QUIT "Patient Declined "
+3 IF %="N"
QUIT "Not Medically Indicated "
+4 IF %="F"
QUIT "No Response to F/U "
+5 IF %="U"
QUIT "Unable to Screen "
+6 QUIT $$VAL^XBDIQ1(9000022,N,.07)
+7 ;
