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)_")"
DO S(X)
SET X=$PIECE(APCHOVR,U,3)
DO S(X)
+51 SET APCHLR=""
+52 SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,$ORDER(^AUTTIMM("C",3,0)),APCHLAST)
IF V]""
SET APCHLR=V
+53 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
+54 IF APCHLR]""
SET X=$PIECE(APCHLR,U)
DO S(X)
SET X=$PIECE(APCHLR,U,2)
IF X]""
DO S(X)
+55 DO WRITE^APCHSMU
+56 XECUTE APCHSURX
+57 QUIT
End DoDot:1
QUIT
+58 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+59 IF 'APCHSCRI
Begin DoDot:1
+60 IF '$$MMR1D(APCHSPAT)
QUIT
+61 SET APCHSINT=9999999
End DoDot:1
+62 ;return in APCHSINT the frequency in days for this age/sex
IF APCHSCRI
SET APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT)
+63 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+64 ;had both so skip prompt
IF $DATA(APCHYA1M)
XECUTE APCHSURX
QUIT
+65 ;if never had one
IF '$DATA(APCHYA1Y)
SET APCHSTEX(1)="MAY BE DUE FOR MMR #1 VACCINATION"
Begin DoDot:1
+66 SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,$ORDER(^AUTTIMM("C",3,0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+67 DO WRITE^APCHSMU
+68 XECUTE APCHSURX
+69 QUIT
End DoDot:1
QUIT
+70 SET APCHSTEX(1)="MAY BE DUE FOR MMR #2 VACCINATION"
Begin DoDot:1
+71 SET APCHLR=""
+72 SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,$ORDER(^AUTTIMM("C",3,0)),APCHLAST)
IF V]""
SET APCHLR=V
+73 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
+74 IF APCHLR]""
SET X=$PIECE(APCHLR,U)
DO S(X)
SET X=$PIECE(APCHLR,U,2)
IF X]""
DO S(X)
+75 DO WRITE^APCHSMU
+76 XECUTE APCHSURX
+77 QUIT
End DoDot:1
+78 QUIT
RUB ;EP
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+3 SET APCHICAR=$$LASTRUB^APCLAPI3(APCHSPAT,,,"A")
+4 SET APCHLAST=$PIECE(APCHICAR,U,1)
+5 IF APCHLAST]""
IF APCHLAST<$$FMADD^XLFDT($$DOB^AUPNPAT(APCHSPAT),365)
SET APCHLAST=""
+6 IF '$$MMR1D(APCHSPAT)
QUIT
+7 IF APCHLAST]""
QUIT
+8 SET APCHSINT=9999999
+9 SET APCHRIHF=$$LASTHF^APCHSMU(APCHSPAT,"RUBELLA IMMUNITY STATUS","N")
+10 ;do not display prompt if hf is immune
IF APCHRIHF="IMMUNE"
XECUTE APCHSURX
QUIT
+11 ;check imm package for Immune status
+12 ;immune for rubella
IF $$RUBIMM(APCHSPAT,6,DT)
XECUTE APCHSURX
QUIT
+13 DO GETTPT^APCHSTP(APCHSITI,APCHCOLW,.APCHSTEX,APCHLAST,APCHRIHF)
+14 DO WRITETP^APCHSTP
+15 QUIT
RUBIMM(P,C,ED) ;EP - ANApHYLAXIS/NEOMYCIN/IMMUNE CONTRAINDICATION
+1 NEW X
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 ;Q:$P(^BIPC(X,0),U,4)<BD
+9 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+10 IF $PIECE(^BICONT(R,0),U,1)="Immune"
SET G=D_U_"Immune"
End DoDot:1
+11 QUIT G
RUBWT ;
+1 SET APCHLR=""
+2 SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,$ORDER(^AUTTIMM("C",3,0)),APCHLAST)
IF V]""
SET APCHLR=V
+3 SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,$ORDER(^AUTTIMM("C",4,0)),APCHLAST)
IF V]""
IF $PIECE(V,U,3)]$PIECE(APCHLR,U,3)
SET APCHLR=V
+4 SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,$ORDER(^AUTTIMM("C",6,0)),APCHLAST)
IF V]""
IF $PIECE(V,U,3)]$PIECE(APCHLR,U,3)
SET APCHLR=V
+5 SET V=$$REF^APCHSMU(APCHSPAT,9999999.14,$ORDER(^AUTTIMM("C",38,0)),APCHLAST)
IF V]""
IF $PIECE(V,U,3)]$PIECE(APCHLR,U,3)
SET APCHLR=V
+6 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
+7 IF APCHLR]""
SET X=$PIECE(APCHLR,U)
DO S(X)
SET X=$PIECE(APCHLR,U,2)
IF X]""
DO S(X)
+8 DO WRITE^APCHSMU
+9 XECUTE APCHSURX
+10 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
NEWBORNH ;
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+3 ;hearing loss on problem list
IF $$PLTAX^APCHSMU(APCHSPAT,"APCH HEARING LOSS DXS")
QUIT
+4 SET D=$$DATEAGE^APCHSMU(APCHSPAT,1)
+5 ;last day before 1st birthday
IF DT>$$FMADD^XLFDT(D,-1)
QUIT
+6 SET APCHICAR=$$LASTNBHS^APCLAPI5(APCHSPAT,,,"A")
+7 SET APCHLAST=$PIECE(APCHICAR,U,1)
+8 ;had one and only need one
IF APCHLAST]""
QUIT
+9 SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
+10 IF $PIECE(APCHOVR,U)>APCHLAST
Begin DoDot:1
+11 SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"
DO S(X)
SET X=$PIECE(APCHOVR,U,3)
DO S(X)
+12 DO HEARWT
+13 QUIT
End DoDot:1
QUIT
HEARREG ;regular stuff
+1 SET APCHSINT=1
SET APCHMIN=0
+2 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))
DO HEARWT
QUIT
+3 QUIT
