BDMDC13 ; IHS/CMI/LAB - 2015 DIABETES AUDIT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**8**;JUN 14, 2007;Build 53
;
LASTFLU(BDMPDFN,BDMBD,BDMED,BDMFORM) ;PEP - date of last FLU
; Return the last recorded FLU:
;
I $G(BDMPDFN)="" Q ""
I $G(BDMBD)="" S BDMBD=$$DOB^AUPNPAT(BDMPDFN)
I $G(BDMED)="" S BDMED=DT
I $G(BDMFORM)="" S BDMFORM="D"
NEW BDMLAST,BDMVAL,BDMX,R,X,Y,V,E,T,G,BDMY,BDMF,Z,D,S
S BDMLAST="",S=""
S T=$O(^ATXAX("B","BGP FLU IZ CVX CODES",0))
I T S X=0 F S X=$O(^ATXAX(T,21,"B",X)) Q:X="" S S(X)=""
;S T=$O(^ATXAX("B","SURVEILLANCE FLU CVX CODES",0))
;I T S X=0 F S X=$O(^ATXAX(T,21,"B",X)) Q:X="" S S(X)=""
;S Y=0 F S Y=$O(^AUTTIMM(Y)) Q:Y'=+Y I $$VAL^XBDIQ1(9999999.14,+Y,.09)="FLU" S R=$$GET1^DIQ(9999999.14,Y,.03) I R]"" S S(R)=""
S R="" F S R=$O(S(R)) Q:R="" D
.S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,R,"IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
.D E
S BDMVAL=$$LASTCPTT^APCLAPIU(BDMPDFN,$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"BGP CPT FLU","A")
D E
S BDMVAL=$$LASTDXT^APCLAPIU(BDMPDFN,$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"BGP FLU IZ DXS","A")
D E
I BDMFORM="D" Q $P(BDMLAST,U)
Q BDMLAST
E ;
I $P(BDMVAL,U,1)>$P(BDMLAST,U,1) S BDMLAST=BDMVAL
Q
FLU(P,BDATE,EDATE,R,F) ;EP
NEW BDM,X,E,%,%DT,BD,B,D,C,Y,LFLU,TFLU,Z,G,T,S,A,J
I $G(F)="" S F="E"
I $G(R)="" S R=0
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-366)
S LFLU=$$LASTFLU(P,BDATE,EDATE,"D")
I LFLU]"" Q $S(F="E":"1 Yes "_$$FMTE^XLFDT(LFLU),1:LFLU)
;
I R Q ""
K S
S T=$O(^ATXAX("B","BGP FLU IZ CVX CODES",0))
I T S X=0 F S X=$O(^ATXAX(T,21,"B",X)) Q:X="" S S(X)=""
S T=$O(^ATXAX("B","SURVEILLANCE FLU CVX CODES",0))
I T S X=0 F S X=$O(^ATXAX(T,21,"B",X)) Q:X="" S S(X)=""
S A="",J="" F S A=$O(S(A)) Q:A=""!(J]"") D
.S G=$$REFUSAL^BDMDC17(P,9999999.14,$O(^AUTTIMM("C",A,0)),BDATE,EDATE)
.I G,$P(G,U,2)'="N" S J="3 Refused "_$$FMTE^XLFDT($P(G,U,3)) Q
.I G S J="2 No - Not Medically Indicated"_$$FMTE^XLFDT($P(G,U,3))
I J]"" Q J
S Z=0,G="" F S Z=$O(S(Z)) Q:Z=""!(G) S X=0,Y=$O(^AUTTIMM("C",Z,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))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:$P(^BIPC(X,0),U,4)<BDATE
.Q:$P(^BIPC(X,0),U,4)>EDATE
.S G=1_U_D
I G Q "3 Refused "_$$FMTE^XLFDT($P(D,U,2))
Q "2 No"
PNEU(P,EDATE,R,F) ;EP
NEW BDM,X,E,B,%DT,Y,TPN,D,LPN,G,C,Z,T
K TPN
I $G(F)="" S F="E"
I $G(R)="" S R=0
S LPN=$$LASTPNEU^BDMS9B4(P,"",EDATE,"D")
I LPN]"" Q $S(F="E":"1 Yes "_$$FMTE^XLFDT(LPN),1:LPN)
I R Q ""
S R="",G="" F R=33,100,109,133,152 Q:R=""!(G) D
.S G=$$REFUSAL^BDMDC17(P,9999999.14,$O(^AUTTIMM("C",R,0)),$$DOB^AUPNPAT(P),DT,"R")
I G Q "3 Refused "_$P(G,U,3)
;; BI REFUSALS
S G="" F Z=33,100,109,133,152 Q:G S X=0,Y=$O(^AUTTIMM("C",Z,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))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.S G=1_U_D
I G Q "3 Refused "_$$DATE^BDMS9B1($P(G,U,2))
S G="",Z="" F Z=33,100,109,133,152 Q:Z=""!(G]"") S G=$$PNEUCONT^BDMS9B4(P,Z,$$DOB^AUPNPAT(P),DT)
I G]"" Q "2 No "_G
Q "2 No"
BI() ;
Q $S($O(^AUTTIMM(0))>100:1,1:0)
BPS(P,BDATE,EDATE,F) ;EP ;
I $G(F)="" S F="E"
NEW X,BDM,E,BDML,BDMLL,BDMV,BDMVF,BDMBDT,D,I
S BDMLL=0,BDMV=""
K BDM,BDMBDT
S X=P_"^ALL MEAS BP;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
S BDML=0 F S BDML=$O(BDM(BDML)) Q:BDML'=+BDML D
.S BDMVF=+$P(BDM(BDML),U,4)
.Q:$P($G(^AUPNVMSR(BDMVF,2)),U,1) ;entered in error
.Q:$$CLINIC^APCLV($P(BDM(BDML),U,5),"C")=30
.S D=$$VALI^XBDIQ1(9000010.01,BDMVF,1201)
.I D="" S D=$$VDTM^APCLV($P(BDM(BDML),U,5))
.S BDMBDT($P(D,"."),D,BDMVF)=BDM(BDML)
S D="" F S D=$O(BDMBDT(D),-1) Q:D'=+D!(BDMLL=3) D
.S E="",E=$O(BDMBDT(D,E),-1) Q:E'=+E!(BDMLL=3)
.S I="" S I=$O(BDMBDT(D,E,I),-1) Q:I'=+I!(BDMLL=3) D
..S BDMLL=BDMLL+1
..S BDMBP=$P(BDMBDT(D,E,I),U,2)
..I F="E" S $P(BDMV,";",BDMLL)=BDMBP_" mm Hg "_$$FMTE^XLFDT($P(BDMBDT(D,E,I),U))
..I F="I" S $P(BDMV,";",BDMLL)=$P(BDMBP," ")
Q BDMV
HTNDX(P,EDATE) ;EP - is HTN on problem list
I '$G(P) Q ""
I '$D(^DPT(P)) Q ""
NEW %,BDM,E,X,T,G,Y
S T=$O(^ATXAX("B","SURVEILLANCE HYPERTENSION",0))
S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:'$D(^AUPNPROB(X,0)) ;bad xref
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE ;if added to pl after end of time period, no go
.S Y=$P(^AUPNPROB(X,0),U)
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:'$$ICD^BDMUTL(Y,$P(^ATXAX(T,0),U),9) ;cmi/maw 05/15/2014 p8
.S G=1
.Q
I G Q "1 Yes"
K BDM
S X=P_"^LAST 3 DX [SURVEILLANCE HYPERTENSION;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(3)) S Y=$$FMTE^XLFDT($P(BDM(3),U,1))_" "_$$FMTE^XLFDT($P(BDM(2),U))_" "_$$FMTE^XLFDT($P(BDM(1),U)) Q "1 Yes - DX on "_Y
Q "2 No"
LASTHT(P,EDATE,F) ;PEP - return last ht and date
I 'P Q ""
I $G(F)="" S F="E"
I '$D(^AUPNVSIT("AC",P)) Q ""
NEW %,BDMARRY,H,E,W,BDATE,D
S %DT="P",X=EDATE D ^%DT S EDATE=Y
S BDATE=$P(^DPT(P,0),U,3)
S E=$O(^AUTTMSR("B","HT",0))
S H=""
S D=0 F S D=$O(^AUPNVMSR("AA",P,E,D)) Q:D'=+D!(H]"") D
.S W=0 F S W=$O(^AUPNVMSR("AA",P,E,D,W)) Q:W'=+W!(H]"") D
..Q:'$D(^AUPNVMSR(W,0))
..Q:$P($G(^AUPNVMSR(W,2)),U,1) ;entered in error
..S H=$P(^AUPNVMSR(W,0),U,4)
..S BDMARRY(1)=$$VD^APCLV($P(^AUPNVMSR(W,0),U,3))
I H="" Q H
I F="I" Q H
S H=$J(H,5,2)
Q H_" inches "_$$FMTE^XLFDT($P(BDMARRY(1),U))
LASTWT(P,BDATE,EDATE,F) ;PEP - return last wt
I 'P Q ""
I $G(F)="" S F="E"
NEW %,BDMARRY,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX,W,H,BDMVF
K BDM S BDMW="" S BDMX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(BDMX,"BDM(")
S BDMN=0 F S BDMN=$O(BDM(BDMN)) Q:BDMN'=+BDMN!(BDMW]"") D
. S BDMVF=+$P(BDM(BDMN),U,4)
. Q:$P($G(^AUPNVMSR(BDMVF,2)),U,1) ;entered in error
. S BDMZ=$P(BDM(BDMN),U,5)
. I '$D(^AUPNVPOV("AD",BDMZ)) S BDMW=$P(BDM(BDMN),U,2)_" lbs "_$$FMTE^XLFDT($P(BDM(BDMN),U)) Q
. S BDMD=0,G=0 F S BDMD=$O(^AUPNVPOV("AD",BDMZ,BDMD)) Q:'BDMD D
.. N ICDI
.. S ICDI=$P($$ICDDX^BDMUTL($P(^AUPNVPOV(BDMD,0),U)),U) ;p8
.. S ICD=$P($$ICDDX^BDMUTL($P(^AUPNVPOV(BDMD,0),U)),U,2) ;cmi/anch/maw 9/12/2007 csv
.. ;make the call here to BGP PREGNANCY DIAGNOSIS 2
..N TAX
..S TAX=$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
.. I $$ICD^BDMUTL(ICDI,$P(^ATXAX(TAX,0),U),9) S G=1 ;cmi/maw 05/15/2014 p8
..;I $$ICD^ATXCHK(ICDI,TAX,9) Q
..;I $E(ICD,1,3)="V22" Q
..;I $E(ICD,1,3)="V23" Q
..;I $E(ICD,1,3)="V27" Q
..;I $E(ICD,1,3)="V28" Q
..;I ICD>629.9999&(ICD<676.95) Q
.I 'G S BDMW=$P(BDM(BDMN),U,2)_" lbs "_$$FMTE^XLFDT($P(BDM(BDMN),U))
.Q
Q $S(F="E":BDMW,1:+BDMW)
CMSFDX(P,R,T) ;EP - return date/dx of dm in register
I '$G(P) Q ""
I '$G(R) Q ""
I $G(T)="" Q ""
NEW D1,Y,X,D,G S X=0,(D,Y)="" F S X=$O(^ACM(44,"C",P,X)) Q:X'=+X I $P(^ACM(44,X,0),U,4)=R D
.S D=$P($G(^ACM(44,X,"SV")),U,2),D1=D,D=$$FMTE^XLFDT(D)
.S Y=$$VAL^XBDIQ1(9002244,X,.01)
.I D1="" S D1=0
.S G(9999999-D1)=D_"^"_D1_"^"_Y
I '$O(G(0)) Q ""
S Y=0,G=$O(G(Y))
S D=$P(G(G),U),D1=$P(G(G),U,2),Y=$P(G(G),U,3)
Q $S(T="D":$G(D),T="DX":$G(Y),T="ID":$G(D1),1:"")
;
PLDMDOO(P,F) ;EP
I '$G(P) Q ""
I $G(F)="" S F="E"
NEW T S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))
I 'T Q ""
NEW D,X,I S D="",X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.Q:$P(^AUPNPROB(X,0),U,12)="D" ;deleted problem
.S I=$P(^AUPNPROB(X,0),U)
.;I $$ICD^ATXCHK(I,T,9) D
.I $$ICD^BDMUTL(I,$P(^ATXAX(T,0),U),9) D ;cmi/maw 05/15/2014 p8
..I $P(^AUPNPROB(X,0),U,13)]"" S D($P(^AUPNPROB(X,0),U,13))=""
..Q
.Q
S D=$O(D(0)) Q $S(F="E":$$FMTE^XLFDT(D),1:$O(D(0)))
PLDMDXS(P) ;EP - get all DM dxs from problem list
I '$G(P) Q ""
NEW T S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))
I 'T Q "<diabetes taxonomy missing>"
NEW D,X,I S D="",X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.Q:$P(^AUPNPROB(X,0),U,12)="D" ;deleted problem
.S I=$P(^AUPNPROB(X,0),U)
.;I $$ICD^ATXCHK(I,T,9) S:D]"" D=D_";" S D=D_$P($$ICDDX^BDMUTL(I),U,2)
.I $$ICD^BDMUTL(I,$P(^ATXAX(T,0),U),9) S:D]"" D=D_";" S D=D_$P($$ICDDX^BDMUTL(I),U,2) ;cmi/maw 05/15/2014 p8
.Q
Q D
;
FRSTDMDX(P,F) ;EP return date of first dm dx
I '$G(P) Q ""
I $G(F)="" S F="E"
NEW X,E,BDM,Y
S Y="BDM("
S X=P_"^FIRST DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y) S Y=$P($G(BDM(1)),U)
Q $S(F="E":$$FMTE^XLFDT(Y),1:Y)
LASTDMDX(P,D) ;EP - last pcc dm dx
I '$G(P) Q ""
NEW X,E,BDM,Y
S Y="BDM("
S X=P_"^LAST DX [DM AUDIT TYPE II DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D S E=$$START1^APCLDF(X,Y)
I $D(BDM(1)) Q "Type 2"
K BDM S X=P_"^LAST DX [DM AUDIT TYPE I DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D S E=$$START1^APCLDF(X,Y)
I $D(BDM(1)) Q "Type 1"
Q ""
INCHES ;
NEW F,FI,Z
S (X,Z)=$$LASTHT^BDMDC13(BDMPD,BDMRED,"I")
Q:X=""
S X=X/12 ;get feet
S F=$P(X,".")
S FI=F*12 ;GET INCHES
S X=Z-FI
;S X=$J(X,5,2)
Q
DATE(D) ;EP
I D="" Q D
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
HEP(P,EDATE,S,F) ;EP
NEW BDMC,BDMG,BDMX,BDMHEP,C,X,ED,G,T,BDM10743,V,Z,Y,BDMIMM,I,R,BDMZ
;get all immunizations
S F=$G(F) I F="" S F="E"
S S=$G(S)
S C="8^42^43^44^45^51^102^104^110^132^146"
D GETIMMS^BDMUTL(P,EDATE,C,.BDMX)
;go through and set into array if 10 days apart
S X=0 F S X=$O(BDMX(X)) Q:X'=+X S BDMHEP(X)=""
;now get cpts
S ED=9999999-EDATE,BD=9999999-$$DOB^AUPNPAT(P),G=0
S T=$O(^ATXAX("B","BGP HEPATITIS CPTS",0))
S BDM10743=0 F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVCPT(X,0),U) S Z=$P($$CPT^ICPTCOD(Y),U,2) S:Z=90743 BDM10743=1 I $$ICD^BDMUTL(Y,$P(^ATXAX(T,0),U),1) S BDMHEP(9999999-$P(ED,"."))="" ;cmi/maw 05/15/2014 p8
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y S Z=$P($$CPT^ICPTCOD(Y),U,2) S:Z=90743 BDM10743=1 I $$ICD^BDMUTL(Y,$P(^ATXAX(T,0),U),1) S BDMHEP(9999999-$P(ED,"."))="" ;cmi/maw 05/15/2014 p8
;now check to see if they are all spaced 20 days apart, if not, kill off the odd ones
S X="",Y="",C=0 F S X=$O(BDMHEP(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<21 K BDMHEP(X) Q
.S Y=X
;now count them and see if there are 3 of them
S BDMHEP=0,X=0 F S X=$O(BDMHEP(X)) Q:X'=+X S BDMHEP=BDMHEP+1
I BDMHEP>2 Q "1 Yes"
I I BDMHEP=2,BDM10743 Q "1 Yes" ;2 Hep B + 90743"
I $G(S) D Q %
.S %=""
.S X=0 F S X=$O(BDMHEP(X)) Q:X'=+X S %=X
;check for Evidence of desease and Contraindications and if yes, then quit
;CONTRA OF IMMUNE
F BDMIMM=8,42,43,44,45,51,102,104,110,132,146 S R=$$HEPCONT(P,BDMIMM,$$DOB^AUPNPAT(P),EDATE) Q:R]""
I R Q "4 Immune"
K BDMG S %=P_"^LAST DX [BGP HEP EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BDMG(")
I $D(BDMG(1)) Q "4 Immune by DX" ;_U_"Evid Hep B"
I $$PLTAX^BDMDC12(P,"BGP HEP EVIDENCE") Q "4 Immune by DX"
;now go to Refusals
S B=$$FMADD^XLFDT(EDATE,-365),E=EDATE,BDMNMI="",R=""
F BDMIMM="8",42,43,44,45,51,102,104,110,132,146 D
.S I=$O(^AUTTIMM("C",BDMIMM,0)) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BDMNMI=1 S R=1
I R Q $S(BDMNMI:2,1:3)_" "_$S(BDMNMI:"No - Not Medically Ind",1:"Refused")
S R=$$CPTREFT^BDMDCDU(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP HEPATITIS CPTS",0)))
I R S:$P(R,U,3)="N" BDMNMI=1 Q $S(BDMNMI:2,1:3)_" "_$S(BDMNMI:"No - Not Medically Ind.",1:"Refused")_" "_$$FMTE^XLFDT($P(R,U,2))
;now check Refusals in imm pkg
F BDMIMM=8,42,43,44,45,51,102,104,110,132,146 S R=$$IMMREF^BDMUTL(P,BDMIMM,$$DOB^AUPNPAT(P),EDATE) Q:R
I R Q "3 Refused"
F BDMZ=8,42,43,44,45,51,102,104,110,132,146 S X=$$ANCONT^BDMUTL(P,BDMZ,EDATE) Q:X]"" ;cmi/maw 12/17/07 missing edate
I X]"" Q X
Q "2 No"
HEPCONT(P,C,BD,ED) ;EP
NEW X,G,Y,R,D
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:$P(^BIPC(X,0),U,4)>ED
.I $P(^BICONT(R,0),U,1)="Immune" S G="4 Immune"
Q G
BDMDC13 ; IHS/CMI/LAB - 2015 DIABETES AUDIT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**8**;JUN 14, 2007;Build 53
+2 ;
LASTFLU(BDMPDFN,BDMBD,BDMED,BDMFORM) ;PEP - date of last FLU
+1 ; Return the last recorded FLU:
+2 ;
+3 IF $GET(BDMPDFN)=""
QUIT ""
+4 IF $GET(BDMBD)=""
SET BDMBD=$$DOB^AUPNPAT(BDMPDFN)
+5 IF $GET(BDMED)=""
SET BDMED=DT
+6 IF $GET(BDMFORM)=""
SET BDMFORM="D"
+7 NEW BDMLAST,BDMVAL,BDMX,R,X,Y,V,E,T,G,BDMY,BDMF,Z,D,S
+8 SET BDMLAST=""
SET S=""
+9 SET T=$ORDER(^ATXAX("B","BGP FLU IZ CVX CODES",0))
+10 IF T
SET X=0
FOR
SET X=$ORDER(^ATXAX(T,21,"B",X))
IF X=""
QUIT
SET S(X)=""
+11 ;S T=$O(^ATXAX("B","SURVEILLANCE FLU CVX CODES",0))
+12 ;I T S X=0 F S X=$O(^ATXAX(T,21,"B",X)) Q:X="" S S(X)=""
+13 ;S Y=0 F S Y=$O(^AUTTIMM(Y)) Q:Y'=+Y I $$VAL^XBDIQ1(9999999.14,+Y,.09)="FLU" S R=$$GET1^DIQ(9999999.14,Y,.03) I R]"" S S(R)=""
+14 SET R=""
FOR
SET R=$ORDER(S(R))
IF R=""
QUIT
Begin DoDot:1
+15 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,R,"IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+16 DO E
End DoDot:1
+17 SET BDMVAL=$$LASTCPTT^APCLAPIU(BDMPDFN,$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"BGP CPT FLU","A")
+18 DO E
+19 SET BDMVAL=$$LASTDXT^APCLAPIU(BDMPDFN,$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"BGP FLU IZ DXS","A")
+20 DO E
+21 IF BDMFORM="D"
QUIT $PIECE(BDMLAST,U)
+22 QUIT BDMLAST
E ;
+1 IF $PIECE(BDMVAL,U,1)>$PIECE(BDMLAST,U,1)
SET BDMLAST=BDMVAL
+2 QUIT
FLU(P,BDATE,EDATE,R,F) ;EP
+1 NEW BDM,X,E,%,%DT,BD,B,D,C,Y,LFLU,TFLU,Z,G,T,S,A,J
+2 IF $GET(F)=""
SET F="E"
+3 IF $GET(R)=""
SET R=0
+4 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-366)
+5 SET LFLU=$$LASTFLU(P,BDATE,EDATE,"D")
+6 IF LFLU]""
QUIT $SELECT(F="E":"1 Yes "_$$FMTE^XLFDT(LFLU),1:LFLU)
+7 ;
+8 IF R
QUIT ""
+9 KILL S
+10 SET T=$ORDER(^ATXAX("B","BGP FLU IZ CVX CODES",0))
+11 IF T
SET X=0
FOR
SET X=$ORDER(^ATXAX(T,21,"B",X))
IF X=""
QUIT
SET S(X)=""
+12 SET T=$ORDER(^ATXAX("B","SURVEILLANCE FLU CVX CODES",0))
+13 IF T
SET X=0
FOR
SET X=$ORDER(^ATXAX(T,21,"B",X))
IF X=""
QUIT
SET S(X)=""
+14 SET A=""
SET J=""
FOR
SET A=$ORDER(S(A))
IF A=""!(J]"")
QUIT
Begin DoDot:1
+15 SET G=$$REFUSAL^BDMDC17(P,9999999.14,$ORDER(^AUTTIMM("C",A,0)),BDATE,EDATE)
+16 IF G
IF $PIECE(G,U,2)'="N"
SET J="3 Refused "_$$FMTE^XLFDT($PIECE(G,U,3))
QUIT
+17 IF G
SET J="2 No - Not Medically Indicated"_$$FMTE^XLFDT($PIECE(G,U,3))
End DoDot:1
+18 IF J]""
QUIT J
+19 SET Z=0
SET G=""
FOR
SET Z=$ORDER(S(Z))
IF Z=""!(G)
QUIT
SET X=0
SET Y=$ORDER(^AUTTIMM("C",Z,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+20 SET R=$PIECE(^BIPC(X,0),U,3)
+21 IF R=""
QUIT
+22 IF '$DATA(^BICONT(R,0))
QUIT
+23 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+24 SET D=$PIECE(^BIPC(X,0),U,4)
+25 IF D=""
QUIT
+26 IF $PIECE(^BIPC(X,0),U,4)<BDATE
QUIT
+27 IF $PIECE(^BIPC(X,0),U,4)>EDATE
QUIT
+28 SET G=1_U_D
End DoDot:1
+29 IF G
QUIT "3 Refused "_$$FMTE^XLFDT($PIECE(D,U,2))
+30 QUIT "2 No"
PNEU(P,EDATE,R,F) ;EP
+1 NEW BDM,X,E,B,%DT,Y,TPN,D,LPN,G,C,Z,T
+2 KILL TPN
+3 IF $GET(F)=""
SET F="E"
+4 IF $GET(R)=""
SET R=0
+5 SET LPN=$$LASTPNEU^BDMS9B4(P,"",EDATE,"D")
+6 IF LPN]""
QUIT $SELECT(F="E":"1 Yes "_$$FMTE^XLFDT(LPN),1:LPN)
+7 IF R
QUIT ""
+8 SET R=""
SET G=""
FOR R=33,100,109,133,152
IF R=""!(G)
QUIT
Begin DoDot:1
+9 SET G=$$REFUSAL^BDMDC17(P,9999999.14,$ORDER(^AUTTIMM("C",R,0)),$$DOB^AUPNPAT(P),DT,"R")
End DoDot:1
+10 IF G
QUIT "3 Refused "_$PIECE(G,U,3)
+11 ;; BI REFUSALS
+12 SET G=""
FOR Z=33,100,109,133,152
IF G
QUIT
SET X=0
SET Y=$ORDER(^AUTTIMM("C",Z,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+13 SET R=$PIECE(^BIPC(X,0),U,3)
+14 IF R=""
QUIT
+15 IF '$DATA(^BICONT(R,0))
QUIT
+16 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+17 SET D=$PIECE(^BIPC(X,0),U,4)
+18 IF D=""
QUIT
+19 SET G=1_U_D
End DoDot:1
+20 IF G
QUIT "3 Refused "_$$DATE^BDMS9B1($PIECE(G,U,2))
+21 SET G=""
SET Z=""
FOR Z=33,100,109,133,152
IF Z=""!(G]"")
QUIT
SET G=$$PNEUCONT^BDMS9B4(P,Z,$$DOB^AUPNPAT(P),DT)
+22 IF G]""
QUIT "2 No "_G
+23 QUIT "2 No"
BI() ;
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))>100:1,1:0)
BPS(P,BDATE,EDATE,F) ;EP ;
+1 IF $GET(F)=""
SET F="E"
+2 NEW X,BDM,E,BDML,BDMLL,BDMV,BDMVF,BDMBDT,D,I
+3 SET BDMLL=0
SET BDMV=""
+4 KILL BDM,BDMBDT
+5 SET X=P_"^ALL MEAS BP;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+6 SET BDML=0
FOR
SET BDML=$ORDER(BDM(BDML))
IF BDML'=+BDML
QUIT
Begin DoDot:1
+7 SET BDMVF=+$PIECE(BDM(BDML),U,4)
+8 ;entered in error
IF $PIECE($GET(^AUPNVMSR(BDMVF,2)),U,1)
QUIT
+9 IF $$CLINIC^APCLV($PIECE(BDM(BDML),U,5),"C")=30
QUIT
+10 SET D=$$VALI^XBDIQ1(9000010.01,BDMVF,1201)
+11 IF D=""
SET D=$$VDTM^APCLV($PIECE(BDM(BDML),U,5))
+12 SET BDMBDT($PIECE(D,"."),D,BDMVF)=BDM(BDML)
End DoDot:1
+13 SET D=""
FOR
SET D=$ORDER(BDMBDT(D),-1)
IF D'=+D!(BDMLL=3)
QUIT
Begin DoDot:1
+14 SET E=""
SET E=$ORDER(BDMBDT(D,E),-1)
IF E'=+E!(BDMLL=3)
QUIT
+15 SET I=""
SET I=$ORDER(BDMBDT(D,E,I),-1)
IF I'=+I!(BDMLL=3)
QUIT
Begin DoDot:2
+16 SET BDMLL=BDMLL+1
+17 SET BDMBP=$PIECE(BDMBDT(D,E,I),U,2)
+18 IF F="E"
SET $PIECE(BDMV,";",BDMLL)=BDMBP_" mm Hg "_$$FMTE^XLFDT($PIECE(BDMBDT(D,E,I),U))
+19 IF F="I"
SET $PIECE(BDMV,";",BDMLL)=$PIECE(BDMBP," ")
End DoDot:2
End DoDot:1
+20 QUIT BDMV
HTNDX(P,EDATE) ;EP - is HTN on problem list
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^DPT(P))
QUIT ""
+3 NEW %,BDM,E,X,T,G,Y
+4 SET T=$ORDER(^ATXAX("B","SURVEILLANCE HYPERTENSION",0))
+5 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+6 ;bad xref
IF '$DATA(^AUPNPROB(X,0))
QUIT
+7 ;if added to pl after end of time period, no go
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+8 SET Y=$PIECE(^AUPNPROB(X,0),U)
+9 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+10 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+11 ;cmi/maw 05/15/2014 p8
IF '$$ICD^BDMUTL(Y,$PIECE(^ATXAX(T,0),U),9)
QUIT
+12 SET G=1
+13 QUIT
End DoDot:1
+14 IF G
QUIT "1 Yes"
+15 KILL BDM
+16 SET X=P_"^LAST 3 DX [SURVEILLANCE HYPERTENSION;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+17 IF $DATA(BDM(3))
SET Y=$$FMTE^XLFDT($PIECE(BDM(3),U,1))_" "_$$FMTE^XLFDT($PIECE(BDM(2),U))_" "_$$FMTE^XLFDT($PIECE(BDM(1),U))
QUIT "1 Yes - DX on "_Y
+18 QUIT "2 No"
LASTHT(P,EDATE,F) ;PEP - return last ht and date
+1 IF 'P
QUIT ""
+2 IF $GET(F)=""
SET F="E"
+3 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+4 NEW %,BDMARRY,H,E,W,BDATE,D
+5 SET %DT="P"
SET X=EDATE
DO ^%DT
SET EDATE=Y
+6 SET BDATE=$PIECE(^DPT(P,0),U,3)
+7 SET E=$ORDER(^AUTTMSR("B","HT",0))
+8 SET H=""
+9 SET D=0
FOR
SET D=$ORDER(^AUPNVMSR("AA",P,E,D))
IF D'=+D!(H]"")
QUIT
Begin DoDot:1
+10 SET W=0
FOR
SET W=$ORDER(^AUPNVMSR("AA",P,E,D,W))
IF W'=+W!(H]"")
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVMSR(W,0))
QUIT
+12 ;entered in error
IF $PIECE($GET(^AUPNVMSR(W,2)),U,1)
QUIT
+13 SET H=$PIECE(^AUPNVMSR(W,0),U,4)
+14 SET BDMARRY(1)=$$VD^APCLV($PIECE(^AUPNVMSR(W,0),U,3))
End DoDot:2
End DoDot:1
+15 IF H=""
QUIT H
+16 IF F="I"
QUIT H
+17 SET H=$JUSTIFY(H,5,2)
+18 QUIT H_" inches "_$$FMTE^XLFDT($PIECE(BDMARRY(1),U))
LASTWT(P,BDATE,EDATE,F) ;PEP - return last wt
+1 IF 'P
QUIT ""
+2 IF $GET(F)=""
SET F="E"
+3 NEW %,BDMARRY,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX,W,H,BDMVF
+4 KILL BDM
SET BDMW=""
SET BDMX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(BDMX,"BDM(")
+5 SET BDMN=0
FOR
SET BDMN=$ORDER(BDM(BDMN))
IF BDMN'=+BDMN!(BDMW]"")
QUIT
Begin DoDot:1
+6 SET BDMVF=+$PIECE(BDM(BDMN),U,4)
+7 ;entered in error
IF $PIECE($GET(^AUPNVMSR(BDMVF,2)),U,1)
QUIT
+8 SET BDMZ=$PIECE(BDM(BDMN),U,5)
+9 IF '$DATA(^AUPNVPOV("AD",BDMZ))
SET BDMW=$PIECE(BDM(BDMN),U,2)_" lbs "_$$FMTE^XLFDT($PIECE(BDM(BDMN),U))
QUIT
+10 SET BDMD=0
SET G=0
FOR
SET BDMD=$ORDER(^AUPNVPOV("AD",BDMZ,BDMD))
IF 'BDMD
QUIT
Begin DoDot:2
+11 NEW ICDI
+12 ;p8
SET ICDI=$PIECE($$ICDDX^BDMUTL($PIECE(^AUPNVPOV(BDMD,0),U)),U)
+13 ;cmi/anch/maw 9/12/2007 csv
SET ICD=$PIECE($$ICDDX^BDMUTL($PIECE(^AUPNVPOV(BDMD,0),U)),U,2)
+14 ;make the call here to BGP PREGNANCY DIAGNOSIS 2
+15 NEW TAX
+16 SET TAX=$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
+17 ;cmi/maw 05/15/2014 p8
IF $$ICD^BDMUTL(ICDI,$PIECE(^ATXAX(TAX,0),U),9)
SET G=1
+18 ;I $$ICD^ATXCHK(ICDI,TAX,9) Q
+19 ;I $E(ICD,1,3)="V22" Q
+20 ;I $E(ICD,1,3)="V23" Q
+21 ;I $E(ICD,1,3)="V27" Q
+22 ;I $E(ICD,1,3)="V28" Q
+23 ;I ICD>629.9999&(ICD<676.95) Q
End DoDot:2
+24 IF 'G
SET BDMW=$PIECE(BDM(BDMN),U,2)_" lbs "_$$FMTE^XLFDT($PIECE(BDM(BDMN),U))
+25 QUIT
End DoDot:1
+26 QUIT $SELECT(F="E":BDMW,1:+BDMW)
CMSFDX(P,R,T) ;EP - return date/dx of dm in register
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(R)
QUIT ""
+3 IF $GET(T)=""
QUIT ""
+4 NEW D1,Y,X,D,G
SET X=0
SET (D,Y)=""
FOR
SET X=$ORDER(^ACM(44,"C",P,X))
IF X'=+X
QUIT
IF $PIECE(^ACM(44,X,0),U,4)=R
Begin DoDot:1
+5 SET D=$PIECE($GET(^ACM(44,X,"SV")),U,2)
SET D1=D
SET D=$$FMTE^XLFDT(D)
+6 SET Y=$$VAL^XBDIQ1(9002244,X,.01)
+7 IF D1=""
SET D1=0
+8 SET G(9999999-D1)=D_"^"_D1_"^"_Y
End DoDot:1
+9 IF '$ORDER(G(0))
QUIT ""
+10 SET Y=0
SET G=$ORDER(G(Y))
+11 SET D=$PIECE(G(G),U)
SET D1=$PIECE(G(G),U,2)
SET Y=$PIECE(G(G),U,3)
+12 QUIT $SELECT(T="D":$GET(D),T="DX":$GET(Y),T="ID":$GET(D1),1:"")
+13 ;
PLDMDOO(P,F) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(F)=""
SET F="E"
+3 NEW T
SET T=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",0))
+4 IF 'T
QUIT ""
+5 NEW D,X,I
SET D=""
SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 ;deleted problem
IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+7 SET I=$PIECE(^AUPNPROB(X,0),U)
+8 ;I $$ICD^ATXCHK(I,T,9) D
+9 ;cmi/maw 05/15/2014 p8
IF $$ICD^BDMUTL(I,$PIECE(^ATXAX(T,0),U),9)
Begin DoDot:2
+10 IF $PIECE(^AUPNPROB(X,0),U,13)]""
SET D($PIECE(^AUPNPROB(X,0),U,13))=""
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 SET D=$ORDER(D(0))
QUIT $SELECT(F="E":$$FMTE^XLFDT(D),1:$ORDER(D(0)))
PLDMDXS(P) ;EP - get all DM dxs from problem list
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",0))
+3 IF 'T
QUIT "<diabetes taxonomy missing>"
+4 NEW D,X,I
SET D=""
SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 ;deleted problem
IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+6 SET I=$PIECE(^AUPNPROB(X,0),U)
+7 ;I $$ICD^ATXCHK(I,T,9) S:D]"" D=D_";" S D=D_$P($$ICDDX^BDMUTL(I),U,2)
+8 ;cmi/maw 05/15/2014 p8
IF $$ICD^BDMUTL(I,$PIECE(^ATXAX(T,0),U),9)
IF D]""
SET D=D_";"
SET D=D_$PIECE($$ICDDX^BDMUTL(I),U,2)
+9 QUIT
End DoDot:1
+10 QUIT D
+11 ;
FRSTDMDX(P,F) ;EP return date of first dm dx
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(F)=""
SET F="E"
+3 NEW X,E,BDM,Y
+4 SET Y="BDM("
+5 SET X=P_"^FIRST DX [SURVEILLANCE DIABETES"
SET E=$$START1^APCLDF(X,Y)
SET Y=$PIECE($GET(BDM(1)),U)
+6 QUIT $SELECT(F="E":$$FMTE^XLFDT(Y),1:Y)
LASTDMDX(P,D) ;EP - last pcc dm dx
+1 IF '$GET(P)
QUIT ""
+2 NEW X,E,BDM,Y
+3 SET Y="BDM("
+4 SET X=P_"^LAST DX [DM AUDIT TYPE II DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D
SET E=$$START1^APCLDF(X,Y)
+5 IF $DATA(BDM(1))
QUIT "Type 2"
+6 KILL BDM
SET X=P_"^LAST DX [DM AUDIT TYPE I DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D
SET E=$$START1^APCLDF(X,Y)
+7 IF $DATA(BDM(1))
QUIT "Type 1"
+8 QUIT ""
INCHES ;
+1 NEW F,FI,Z
+2 SET (X,Z)=$$LASTHT^BDMDC13(BDMPD,BDMRED,"I")
+3 IF X=""
QUIT
+4 ;get feet
SET X=X/12
+5 SET F=$PIECE(X,".")
+6 ;GET INCHES
SET FI=F*12
+7 SET X=Z-FI
+8 ;S X=$J(X,5,2)
+9 QUIT
DATE(D) ;EP
+1 IF D=""
QUIT D
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
HEP(P,EDATE,S,F) ;EP
+1 NEW BDMC,BDMG,BDMX,BDMHEP,C,X,ED,G,T,BDM10743,V,Z,Y,BDMIMM,I,R,BDMZ
+2 ;get all immunizations
+3 SET F=$GET(F)
IF F=""
SET F="E"
+4 SET S=$GET(S)
+5 SET C="8^42^43^44^45^51^102^104^110^132^146"
+6 DO GETIMMS^BDMUTL(P,EDATE,C,.BDMX)
+7 ;go through and set into array if 10 days apart
+8 SET X=0
FOR
SET X=$ORDER(BDMX(X))
IF X'=+X
QUIT
SET BDMHEP(X)=""
+9 ;now get cpts
+10 SET ED=9999999-EDATE
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+11 SET T=$ORDER(^ATXAX("B","BGP HEPATITIS CPTS",0))
+12 SET BDM10743=0
FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+13 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+14 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+16 ;cmi/maw 05/15/2014 p8
SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Z=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Z=90743
SET BDM10743=1
IF $$ICD^BDMUTL(Y,$PIECE(^ATXAX(T,0),U),1)
SET BDMHEP(9999999-$PIECE(ED,"."))=""
End DoDot:3
+17 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+18 ;cmi/maw 05/15/2014 p8
SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Z=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Z=90743
SET BDM10743=1
IF $$ICD^BDMUTL(Y,$PIECE(^ATXAX(T,0),U),1)
SET BDMHEP(9999999-$PIECE(ED,"."))=""
End DoDot:3
End DoDot:2
End DoDot:1
+19 ;now check to see if they are all spaced 20 days apart, if not, kill off the odd ones
+20 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BDMHEP(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+21 IF C=1
SET Y=X
QUIT
+22 IF $$FMDIFF^XLFDT(X,Y)<21
KILL BDMHEP(X)
QUIT
+23 SET Y=X
End DoDot:1
+24 ;now count them and see if there are 3 of them
+25 SET BDMHEP=0
SET X=0
FOR
SET X=$ORDER(BDMHEP(X))
IF X'=+X
QUIT
SET BDMHEP=BDMHEP+1
+26 IF BDMHEP>2
QUIT "1 Yes"
I ;2 Hep B + 90743"
IF BDMHEP=2
IF BDM10743
QUIT "1 Yes"
+1 IF $GET(S)
Begin DoDot:1
+2 SET %=""
+3 SET X=0
FOR
SET X=$ORDER(BDMHEP(X))
IF X'=+X
QUIT
SET %=X
End DoDot:1
QUIT %
+4 ;check for Evidence of desease and Contraindications and if yes, then quit
+5 ;CONTRA OF IMMUNE
+6 FOR BDMIMM=8,42,43,44,45,51,102,104,110,132,146
SET R=$$HEPCONT(P,BDMIMM,$$DOB^AUPNPAT(P),EDATE)
IF R]""
QUIT
+7 IF R
QUIT "4 Immune"
+8 KILL BDMG
SET %=P_"^LAST DX [BGP HEP EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDMG(")
+9 ;_U_"Evid Hep B"
IF $DATA(BDMG(1))
QUIT "4 Immune by DX"
+10 IF $$PLTAX^BDMDC12(P,"BGP HEP EVIDENCE")
QUIT "4 Immune by DX"
+11 ;now go to Refusals
+12 SET B=$$FMADD^XLFDT(EDATE,-365)
SET E=EDATE
SET BDMNMI=""
SET R=""
+13 FOR BDMIMM="8",42,43,44,45,51,102,104,110,132,146
Begin DoDot:1
+14 SET I=$ORDER(^AUTTIMM("C",BDMIMM,0))
IF 'I
QUIT
+15 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
IF $PIECE(^AUPNPREF(Y,0),U,7)="N"
SET BDMNMI=1
SET R=1
End DoDot:1
+16 IF R
QUIT $SELECT(BDMNMI:2,1:3)_" "_$SELECT(BDMNMI:"No - Not Medically Ind",1:"Refused")
+17 SET R=$$CPTREFT^BDMDCDU(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^ATXAX("B","BGP HEPATITIS CPTS",0)))
+18 IF R
IF $PIECE(R,U,3)="N"
SET BDMNMI=1
QUIT $SELECT(BDMNMI:2,1:3)_" "_$SELECT(BDMNMI:"No - Not Medically Ind.",1:"Refused")_" "_$$FMTE^XLFDT($PIECE(R,U,2))
+19 ;now check Refusals in imm pkg
+20 FOR BDMIMM=8,42,43,44,45,51,102,104,110,132,146
SET R=$$IMMREF^BDMUTL(P,BDMIMM,$$DOB^AUPNPAT(P),EDATE)
IF R
QUIT
+21 IF R
QUIT "3 Refused"
+22 ;cmi/maw 12/17/07 missing edate
FOR BDMZ=8,42,43,44,45,51,102,104,110,132,146
SET X=$$ANCONT^BDMUTL(P,BDMZ,EDATE)
IF X]""
QUIT
+23 IF X]""
QUIT X
+24 QUIT "2 No"
HEPCONT(P,C,BD,ED) ;EP
+1 NEW X,G,Y,R,D
+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 $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+8 IF $PIECE(^BICONT(R,0),U,1)="Immune"
SET G="4 Immune"
End DoDot:1
+9 QUIT G
