BDMS9B3 ; IHS/CMI/LAB - women's health supplement ; 27 Jan 2011 6:56 AM
;;2.0;DIABETES MANAGEMENT SYSTEM;**3,4,5,8,9,10,11,12**;JUN 14, 2007;Build 51
;
BI() ;EP- check to see if using new imm package or not 1/5/1999 IHS/CMI/LAB
Q $S($O(^AUTTIMM(0))<100:0,1:1)
TD(P,BDMBD,BDMSED,F) ;EP
NEW BDMY,X,E,B,%DT,Y,TDD
I '$G(BDMBD) S BDMBD=$$DOB^AUPNPAT(P)
I '$G(BDMSED) S BDMSED=DT
I $G(F)="" S F=""
S TDD=$$LASTTD(P,BDMBD,BDMSED)
I F="D" Q TDD
S X=$$FMADD^XLFDT(BDMSED,-(10*365))
I TDD>X Q "Yes "_$$DATE^BDMS9B1(TDD)
S R="",G="" F R=1,9,20,22,28,35,50,106,107,110,112,113,115,120,130,132,138,139,142 Q:R=""!(G) D
.S G=$$REFUSAL^BDMDG17(P,9999999.14,$O(^AUTTIMM("C",R,0)),$$FMADD^XLFDT(BDMSED,-365),DT,"R")
I G Q "Refused "_$P(G,U,3)
;; BI REFUSALS
S G="" F Z=1,9,20,22,28,35,50,106,107,110,112,113,115,120,130,132,138,139,142 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=""
.Q:D<$$FMADD^XLFDT(BDMSED,-365)
.S G=1_U_D
I G Q "Refused "_$$DATE^BDMS9B1($P(G,U,2))
Q "No "_$$DATE^BDMS9B1(TDD)
FLU(P) ;EP
NEW BDMY,%,LFLU,E,T,X,D,R,S,G,Z,Y
NEW D S D=$S($E(DT,4,5)>7:$E(DT,1,3)_"0801",1:$E(DT,1,3)-1_"0801")
S LFLU=$$LASTFLU^BDMDG13(P,D,DT)
I LFLU="" G FLUR
FLU1 ;
Q "Yes "_$$DATE^BDMS9B1($P(LFLU,U))
FLUR ;
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=$$VAL^XBDIQ1(9999999.14,Y,.03) I R]"" S S(R)=""
S R="",G="" F S R=$O(S(R)) Q:R=""!(G) D
.S G=$$REFUSAL^BDMDG17(P,9999999.14,$O(^AUTTIMM("C",R,0)),D,DT,"R")
I G Q "Refused "_$P(G,U,3)
S G="",Z="" 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 S=$P(^BIPC(X,0),U,3)
.Q:S=""
.Q:'$D(^BICONT(S,0))
.Q:$P(^BICONT(S,0),U,1)'["Refusal"
.S T=$P(^BIPC(X,0),U,4)
.Q:T=""
.Q:$P(^BIPC(X,0),U,4)<D
.S G=1_U_T
I G Q "Refused "_$$DATE^BDMS9B1($P(G,U,2))
S G="",Z="" F S Z=$O(S(Z)) Q:Z=""!(G]"") S G=$$FLCONT(P,Z,$$DOB^AUPNPAT(P),DT)
I G]"" Q G
Q "No"
FLCONT(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:D=""
.;Q:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.I $P(^BICONT(R,0),U,1)="Egg Allergy" S G="Contraindication: Egg Allergy "_$$DATE^BDMS9B1(D)
.I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G="Contraindication: Anaphylaxis "_$$DATE^BDMS9B1(D)
Q G
DIETV(P) ;EP
I '$G(P) Q ""
;get all dietician visits
;go through all visits in AA and get last to Prov 29 or
NEW D,V,G,X S (D,V,G)="" F S D=$O(^AUPNVSIT("AA",P,D)) Q:D'=+D!(G) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,D,V)) Q:V'=+V!(G) D
..Q:'$D(^AUPNVSIT(V,0))
..Q:$P(^AUPNVSIT(V,0),U,11)
..Q:'$P(^AUPNVSIT(V,0),U,9)
..Q:'$D(^AUPNVPOV("AD",V))
..Q:'$D(^AUPNVPRV("AD",V))
..Q:$$DNKA^BDMS9B4(V)
..Q:$$CLINIC^APCLV(V,"C")=52 ;chart review
..I $P(^AUPNVSIT(V,0),U,7)="C" Q ;chart review
..I $$CLINIC^APCLV(V,"C")=67 S G=V Q
..S X=$$DIETP(V) ; is there a prov 07 or 29
..I X S G=V Q
..Q
.Q
I 'G Q ""
Q $$DATE^BDMS9B1($P($P(^AUPNVSIT(G,0),U),"."))_" "_$E($$PRIMPOV^APCLV(G,"N"),1,35)
DIETP(V) ;are any providers an 07 or 29
I '$G(V) Q ""
NEW X,Y,Z,H
S H="",Z=0 F S Z=$O(^AUPNVPRV("AD",V,Z)) Q:Z'=+Z!(H) D
.S Y=$P(^AUPNVPRV(Z,0),U) ;provider ien
.S Y=$$PROVCLSC^XBFUNC1(Y) I Y=29!(Y="07")!(Y=34) S H=1 Q
.Q
Q H
LASTTD(BDMPDFN,BDMBD,BDMED,BDMFORM) ;PEP - date of last TD
;
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
S BDMLAST=""
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"1","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"9","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"20","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"22","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"28","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"35","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"50","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"106","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"107","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"110","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"112","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"113","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"115","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"120","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"130","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"132","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"138","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"139","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,"APCH TD CPTS","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
;
TOBACCO ;EP
K BDMTOB,BDMTOBS,BDMTOBC,BDMTOBD
S BDMTOBD=""
D TOBACCO0
S X=$P(BDMTOBS,U,2)
S Y=$P(BDMTOBC,U,2)
S BDMTOBD=X I Y>BDMTOBD S BDMTOBD=Y ;date of latest hf
D TOBACCO1 ;check Problem file for tobacco use
S X=$P(BDMTOBS,U,2)
S Y=$P(BDMTOBC,U,2)
S BDMTOBD=X I Y>BDMTOBD S BDMTOBD=Y
D TOBACCO2 ;check POVs for tobacco use
I $D(BDMTOBS)!($D(BDMTOBC)) Q
S BDMTOBS="UNDOCUMENTED"
Q
TOBACCO0 ;check for tobacco documented in health factors
S BDMTOBS="",BDMTOBC="" ;SMOKING AND CHEWING
S X=$$LASTHF^BDMSMU(BDMSDFN,"TOBACCO (SMOKING)","X")
S BDMTOBS=X
S X=$$LASTHF^BDMSMU(BDMSDFN,"TOBACCO (SMOKELESS - CHEWING/DIP)","X")
S BDMTOBC=X
I BDMTOBC]""!(BDMTOBS]"") Q ;have new patch 5 factors
S X=$$LASTHF^BDMSMU(BDMSDFN,"TOBACCO","B")
S BDMTOBS=X
Q
TOBACCO1 ;check problem file for tobacco use
NEW X,Y,Z,T
S T="DM AUDIT SMOKING RELATED DXS"
I 'T Q
S X=0
F S X=$O(^AUPNPROB("AC",BDMSDFN,X)) Q:X'=+X D
.Q:'$D(^AUPNPROB(X,0))
.Q:$P($G(^AUPNPROB(X,0)),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)'="A" ;HAS TO BE ACTIVE
.Q:$P($G(^AUPNPROB(X,2)),U,1) ;DELETED
.Q:$P(^AUPNPROB(X,0),U,3)<BDMTOBD
.Q:$P(^AUPNPROB(X,0),U,3)=BDMTOBD
.S Z=$P(^AUPNPROB(X,0),U,1)
.Q:'$$ICD^BDMUTL(Z,T,9)
.I $P($$ICDDX^BDMUTL(Z,,,"I"),U,2)=305.13 S BDMTOBS="PAST USE OF TOBACCO"_" - "_$E($$VAL^XBDIQ1(9000011,X,.05),1,30)_U_$P(^AUPNPROB(X,0),U,3) Q ;cmi/anch/maw 8/27/2007 code set versioning
.S BDMTOBS="YES, USES TOBACCO - "_$E($$VAL^XBDIQ1(9000011,X,.05),1,30)_" Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)_U_$P(^AUPNPROB(X,0),U,3)
Q
TOBACCO2 ;check pov file for TOBACCO USE DOC
K BDM S BDMX=BDMSDFN_"^LAST DX [DM AUDIT SMOKING RELATED DXS" S E=$$START1^APCLDF(BDMX,"BDM(") Q:E I $D(BDM(1)) D
. Q:$P(BDM(1),U,1)<BDMTOBD
. Q:$P(BDM(1),U,1)=BDMTOBD
. I $P(BDM(1),U,2)=305.13 S BDMTOBS="PAST USE OF TOBACCO"_" - "_$E($$VAL^XBDIQ1(9000010.07,+$P(BDM(1),U,4),.04),1,30)_U_$P(BDM(1),U) Q
. S BDMTOBS="YES, USES TOBACCO"_" - "_$E($P(^AUTNPOV(+$P(^AUPNVPOV(+$P(BDM(1),U,4),0),U,4),0),U),1,30)_" POV: "_$E($$VAL^XBDIQ1(9000010.07,+$P(BDM(1),U,4),.04),1,30)_" "_$$DATE^BDMS9B1($P(BDM(1),U))_U_$P(BDM(1),U)
.Q
Q
;
REFDF(P,F,I,D,TEXT) ;EP - dm item refused?
I '$G(P) Q ""
I '$G(F) Q ""
I '$G(I) Q ""
S TEXT=$G(TEXT)
I $G(D)="" S D=""
NEW X S X=$O(^AUPNPREF("AA",P,F,I,0))
I 'X Q "" ;none of this item was refused
NEW Y S Y=9999999-X
I D]"",Y>D Q "Refused "_$S(TEXT]"":TEXT,1:$E($$VAL^XBDIQ1(F,I,.01),1,30))_" on "_$$DATE^BDMS9B1(Y)
I D]"",Y<D Q ""
Q "Refused "_$S(TEXT]"":TEXT,1:$E($$VAL^XBDIQ1(F,I,.01),1,30))_" on "_$$DATE^BDMS9B1(Y)
;
CHEST(P) ;EP - get date of last chest xray from V RAD or V CPT
;FIX ALL RAD LOOKUPS TO LOOP THROUGH GLOBAL
I $G(P)="" Q ""
NEW X,Y,Z,G,LCHEST,T,D
S LCHEST=""
S (X,Y,V)=0 F S X=$O(^AUPNVRAD("AC",P,X)) Q:X'=+X D
.S V=$P(^AUPNVRAD(X,0),U,3)
.Q:'V
.S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
.S Y=$P(^AUPNVRAD(X,0),U),Y=$P($G(^RAMIS(71,Y,0)),U,9)
.I Y>71009&(Y<71036),V>LCHEST S LCHEST=V Q
S T=71009 F S T=$O(^ICPT("B",T)) Q:T>71035 S X=0 F S X=$O(^ICPT("B",T,X)) Q:X'=+X D
.S D=$O(^AUPNVCPT("AA",P,X,0)) I D S D=9999999-D
.I D,D>LCHEST S LCHEST=D
K BDMY S %=P_"^LAST PROCEDURE 87.44",E=$$START1^APCLDF(%,"BDMY(")
I $D(BDMY(1)),$P(BDMY(1),U)>LCHEST S LCHEST=$P(BDMY(1),U)
K BDMY S %=P_"^LAST PROCEDURE 87.39",E=$$START1^APCLDF(%,"BDMY(")
I $D(BDMY(1)),$P(BDMY(1),U)>LCHEST S LCHEST=$P(BDMY(1),U)
Q $S(LCHEST]"":$$DATE^BDMS9B1(LCHEST),1:"")
EKG(P) ;EP
NEW BDMY,%,LEKG S LEKG="",%=P_"^LAST DIAGNOSTIC ECG SUMMARY",E=$$START1^APCLDF(%,"BDMY(")
I $D(BDMY) S LEKG=$P(BDMY(1),U)_U_$$VAL^XBDIQ1(9000010.21,+$P(BDMY(1),U,4),.04)
K BDMY S %=P_"^LAST PROCEDURE 89.50",E=$$START1^APCLDF(%,"BDMY(")
I $D(BDMY(1)) D
.Q:LEKG>$P(BDMY(1),U)
.S LEKG=$P(BDMY(1),U)
K BDMY S %=P_"^LAST PROCEDURE 89.51",E=$$START1^APCLDF(%,"BDMY(")
I $D(BDMY(1)) D
.Q:LEKG>$P(BDMY(1),U)
.S LEKG=$P(BDMY(1),U)
K BDMY S %=P_"^LAST PROCEDURE 89.52",E=$$START1^APCLDF(%,"BDMY(")
I $D(BDMY(1)) D
.Q:LEKG>$P(BDMY(1),U)
.S LEKG=$P(BDMY(1),U)
K BDMY S %=P_"^LAST PROCEDURE 89.53",E=$$START1^APCLDF(%,"BDMY(")
I $D(BDMY(1)) D
.Q:LEKG>$P(BDMY(1),U)
.S LEKG=$P(BDMY(1),U)
K BDMY S %=P_"^LAST DX 794.31",E=$$START1^APCLDF(%,"BDMY(")
I $D(BDMY(1)) D
.Q:LEKG>$P(BDMY(1),U)
.S LEKG=$P(BDMY(1),U)
;check CPT
S T=$O(^ATXAX("B","DM AUDIT EKG CPTS",0))
K BDMY I T S BDMY(1)=$$CPT(P,,,T,3) D
.I BDMY(1)="" K BDMY Q
.Q:LEKG>$P(BDMY(1),U)
.S LEKG=$P(BDMY(1),U)
K BDMY I T S BDMY(1)=$$RAD(P,,,T,3) D
.I BDMY(1)="" K BDMY Q
.Q:LEKG>$P(BDMY(1),U)
.S LEKG=$P(BDMY(1),U)
;
;
Q $$DATE^BDMS9B1(LEKG)_U_$P(LEKG,U,2)
;
CPT(P,BDATE,EDATE,T,F) ;
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
I $G(EDATE)="" S EDATE=DT
I $G(BDATE)="" S BDATE=$P(^DPT(P,0),U,3)
;go through visits in a date range for this patient, check cpts
NEW D,BD,ED,X,Y,D,G,V
S ED=9999999-EDATE,BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVCPT("AD",V))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(G) D
...I $$ICD^ATXCHK($P(^AUPNVCPT(X,0),U),T,1) S G=X
...Q
..Q
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
I F=4 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $$DATE^BDMS9B1($P($P($G(^AUPNVSIT(V,0)),U),"."))
Q ""
RAD(P,BDATE,EDATE,T,F) ;return if a v rad entry in date range
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
I $G(EDATE)="" S EDATE=DT
I $G(BDATE)="" S BDATE=$P(^DPT(P,0),U,3)
;go through visits in a date range for this patient, check cpts
NEW D,BD,ED,X,Y,D,G,V
S ED=9999999-EDATE,BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVRAD("AD",V))
..S X=0 F S X=$O(^AUPNVRAD("AD",V,X)) Q:X'=+X!(G) D
...Q:'$D(^AUPNVRAD(X,0))
...S Y=$P(^AUPNVRAD(X,0),U) Q:'Y Q:'$D(^RAMIS(71,Y,0))
...S Y=$P($G(^RAMIS(71,Y,0)),U,9) Q:'Y
...Q:'$$ICD^ATXCHK(Y,T,1)
...S G=X
...Q
..Q
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
I F=4 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $$DATE^BDMS9B1($P($P($G(^AUPNVSIT(V,0)),U),"."))
Q ""
BDMS9B3 ; IHS/CMI/LAB - women's health supplement ; 27 Jan 2011 6:56 AM
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**3,4,5,8,9,10,11,12**;JUN 14, 2007;Build 51
+2 ;
BI() ;EP- check to see if using new imm package or not 1/5/1999 IHS/CMI/LAB
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))<100:0,1:1)
TD(P,BDMBD,BDMSED,F) ;EP
+1 NEW BDMY,X,E,B,%DT,Y,TDD
+2 IF '$GET(BDMBD)
SET BDMBD=$$DOB^AUPNPAT(P)
+3 IF '$GET(BDMSED)
SET BDMSED=DT
+4 IF $GET(F)=""
SET F=""
+5 SET TDD=$$LASTTD(P,BDMBD,BDMSED)
+6 IF F="D"
QUIT TDD
+7 SET X=$$FMADD^XLFDT(BDMSED,-(10*365))
+8 IF TDD>X
QUIT "Yes "_$$DATE^BDMS9B1(TDD)
+9 SET R=""
SET G=""
FOR R=1,9,20,22,28,35,50,106,107,110,112,113,115,120,130,132,138,139,142
IF R=""!(G)
QUIT
Begin DoDot:1
+10 SET G=$$REFUSAL^BDMDG17(P,9999999.14,$ORDER(^AUTTIMM("C",R,0)),$$FMADD^XLFDT(BDMSED,-365),DT,"R")
End DoDot:1
+11 IF G
QUIT "Refused "_$PIECE(G,U,3)
+12 ;; BI REFUSALS
+13 SET G=""
FOR Z=1,9,20,22,28,35,50,106,107,110,112,113,115,120,130,132,138,139,142
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
+14 SET R=$PIECE(^BIPC(X,0),U,3)
+15 IF R=""
QUIT
+16 IF '$DATA(^BICONT(R,0))
QUIT
+17 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+18 SET D=$PIECE(^BIPC(X,0),U,4)
+19 IF D=""
QUIT
+20 IF D<$$FMADD^XLFDT(BDMSED,-365)
QUIT
+21 SET G=1_U_D
End DoDot:1
+22 IF G
QUIT "Refused "_$$DATE^BDMS9B1($PIECE(G,U,2))
+23 QUIT "No "_$$DATE^BDMS9B1(TDD)
FLU(P) ;EP
+1 NEW BDMY,%,LFLU,E,T,X,D,R,S,G,Z,Y
+2 NEW D
SET D=$SELECT($EXTRACT(DT,4,5)>7:$EXTRACT(DT,1,3)_"0801",1:$EXTRACT(DT,1,3)-1_"0801")
+3 SET LFLU=$$LASTFLU^BDMDG13(P,D,DT)
+4 IF LFLU=""
GOTO FLUR
FLU1 ;
+1 QUIT "Yes "_$$DATE^BDMS9B1($PIECE(LFLU,U))
FLUR ;
+1 SET T=$ORDER(^ATXAX("B","BGP FLU IZ CVX CODES",0))
+2 IF T
SET X=0
FOR
SET X=$ORDER(^ATXAX(T,21,"B",X))
IF X=""
QUIT
SET S(X)=""
+3 ;S T=$O(^ATXAX("B","SURVEILLANCE FLU CVX CODES",0))
+4 ;I T S X=0 F S X=$O(^ATXAX(T,21,"B",X)) Q:X="" S S(X)=""
+5 ;S Y=0 F S Y=$O(^AUTTIMM(Y)) Q:Y'=+Y I $$VAL^XBDIQ1(9999999.14,+Y,.09)="FLU" S R=$$VAL^XBDIQ1(9999999.14,Y,.03) I R]"" S S(R)=""
+6 SET R=""
SET G=""
FOR
SET R=$ORDER(S(R))
IF R=""!(G)
QUIT
Begin DoDot:1
+7 SET G=$$REFUSAL^BDMDG17(P,9999999.14,$ORDER(^AUTTIMM("C",R,0)),D,DT,"R")
End DoDot:1
+8 IF G
QUIT "Refused "_$PIECE(G,U,3)
+9 SET G=""
SET Z=""
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
+10 SET S=$PIECE(^BIPC(X,0),U,3)
+11 IF S=""
QUIT
+12 IF '$DATA(^BICONT(S,0))
QUIT
+13 IF $PIECE(^BICONT(S,0),U,1)'["Refusal"
QUIT
+14 SET T=$PIECE(^BIPC(X,0),U,4)
+15 IF T=""
QUIT
+16 IF $PIECE(^BIPC(X,0),U,4)<D
QUIT
+17 SET G=1_U_T
End DoDot:1
+18 IF G
QUIT "Refused "_$$DATE^BDMS9B1($PIECE(G,U,2))
+19 SET G=""
SET Z=""
FOR
SET Z=$ORDER(S(Z))
IF Z=""!(G]"")
QUIT
SET G=$$FLCONT(P,Z,$$DOB^AUPNPAT(P),DT)
+20 IF G]""
QUIT G
+21 QUIT "No"
FLCONT(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 ;Q:D=""
+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)="Egg Allergy"
SET G="Contraindication: Egg Allergy "_$$DATE^BDMS9B1(D)
+11 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G="Contraindication: Anaphylaxis "_$$DATE^BDMS9B1(D)
End DoDot:1
+12 QUIT G
DIETV(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;get all dietician visits
+3 ;go through all visits in AA and get last to Prov 29 or
+4 NEW D,V,G,X
SET (D,V,G)=""
FOR
SET D=$ORDER(^AUPNVSIT("AA",P,D))
IF D'=+D!(G)
QUIT
Begin DoDot:1
+5 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,D,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+8 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+9 IF '$DATA(^AUPNVPOV("AD",V))
QUIT
+10 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+11 IF $$DNKA^BDMS9B4(V)
QUIT
+12 ;chart review
IF $$CLINIC^APCLV(V,"C")=52
QUIT
+13 ;chart review
IF $PIECE(^AUPNVSIT(V,0),U,7)="C"
QUIT
+14 IF $$CLINIC^APCLV(V,"C")=67
SET G=V
QUIT
+15 ; is there a prov 07 or 29
SET X=$$DIETP(V)
+16 IF X
SET G=V
QUIT
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 IF 'G
QUIT ""
+20 QUIT $$DATE^BDMS9B1($PIECE($PIECE(^AUPNVSIT(G,0),U),"."))_" "_$EXTRACT($$PRIMPOV^APCLV(G,"N"),1,35)
DIETP(V) ;are any providers an 07 or 29
+1 IF '$GET(V)
QUIT ""
+2 NEW X,Y,Z,H
+3 SET H=""
SET Z=0
FOR
SET Z=$ORDER(^AUPNVPRV("AD",V,Z))
IF Z'=+Z!(H)
QUIT
Begin DoDot:1
+4 ;provider ien
SET Y=$PIECE(^AUPNVPRV(Z,0),U)
+5 SET Y=$$PROVCLSC^XBFUNC1(Y)
IF Y=29!(Y="07")!(Y=34)
SET H=1
QUIT
+6 QUIT
End DoDot:1
+7 QUIT H
LASTTD(BDMPDFN,BDMBD,BDMED,BDMFORM) ;PEP - date of last TD
+1 ;
+2 IF $GET(BDMPDFN)=""
QUIT ""
+3 IF $GET(BDMBD)=""
SET BDMBD=$$DOB^AUPNPAT(BDMPDFN)
+4 IF $GET(BDMED)=""
SET BDMED=DT
+5 IF $GET(BDMFORM)=""
SET BDMFORM="D"
+6 NEW BDMLAST,BDMVAL,BDMX,R,X,Y,V,E,T,G,BDMY,BDMF
+7 SET BDMLAST=""
+8 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"1","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+9 DO E
+10 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"9","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+11 DO E
+12 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"20","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+13 DO E
+14 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"22","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+15 DO E
+16 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"28","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+17 DO E
+18 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"35","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+19 DO E
+20 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"50","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+21 DO E
+22 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"106","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+23 DO E
+24 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"107","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+25 DO E
+26 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"110","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+27 DO E
+28 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"112","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+29 DO E
+30 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"113","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+31 DO E
+32 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"115","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+33 DO E
+34 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"120","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+35 DO E
+36 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"130","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+37 DO E
+38 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"132","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+39 DO E
+40 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"138","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+41 DO E
+42 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"139","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+43 DO E
+44 SET BDMVAL=$$LASTCPTT^APCLAPIU(BDMPDFN,$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"APCH TD CPTS","A")
+45 DO E
+46 IF BDMFORM="D"
QUIT $PIECE(BDMLAST,U)
+47 QUIT BDMLAST
+48 ;
E ;
+1 IF $PIECE(BDMVAL,U,1)>$PIECE(BDMLAST,U,1)
SET BDMLAST=BDMVAL
+2 QUIT
+3 ;
TOBACCO ;EP
+1 KILL BDMTOB,BDMTOBS,BDMTOBC,BDMTOBD
+2 SET BDMTOBD=""
+3 DO TOBACCO0
+4 SET X=$PIECE(BDMTOBS,U,2)
+5 SET Y=$PIECE(BDMTOBC,U,2)
+6 ;date of latest hf
SET BDMTOBD=X
IF Y>BDMTOBD
SET BDMTOBD=Y
+7 ;check Problem file for tobacco use
DO TOBACCO1
+8 SET X=$PIECE(BDMTOBS,U,2)
+9 SET Y=$PIECE(BDMTOBC,U,2)
+10 SET BDMTOBD=X
IF Y>BDMTOBD
SET BDMTOBD=Y
+11 ;check POVs for tobacco use
DO TOBACCO2
+12 IF $DATA(BDMTOBS)!($DATA(BDMTOBC))
QUIT
+13 SET BDMTOBS="UNDOCUMENTED"
+14 QUIT
TOBACCO0 ;check for tobacco documented in health factors
+1 ;SMOKING AND CHEWING
SET BDMTOBS=""
SET BDMTOBC=""
+2 SET X=$$LASTHF^BDMSMU(BDMSDFN,"TOBACCO (SMOKING)","X")
+3 SET BDMTOBS=X
+4 SET X=$$LASTHF^BDMSMU(BDMSDFN,"TOBACCO (SMOKELESS - CHEWING/DIP)","X")
+5 SET BDMTOBC=X
+6 ;have new patch 5 factors
IF BDMTOBC]""!(BDMTOBS]"")
QUIT
+7 SET X=$$LASTHF^BDMSMU(BDMSDFN,"TOBACCO","B")
+8 SET BDMTOBS=X
+9 QUIT
TOBACCO1 ;check problem file for tobacco use
+1 NEW X,Y,Z,T
+2 SET T="DM AUDIT SMOKING RELATED DXS"
+3 IF 'T
QUIT
+4 SET X=0
+5 FOR
SET X=$ORDER(^AUPNPROB("AC",BDMSDFN,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 IF '$DATA(^AUPNPROB(X,0))
QUIT
+7 IF $PIECE($GET(^AUPNPROB(X,0)),U,12)="D"
QUIT
+8 ;HAS TO BE ACTIVE
IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+9 ;DELETED
IF $PIECE($GET(^AUPNPROB(X,2)),U,1)
QUIT
+10 IF $PIECE(^AUPNPROB(X,0),U,3)<BDMTOBD
QUIT
+11 IF $PIECE(^AUPNPROB(X,0),U,3)=BDMTOBD
QUIT
+12 SET Z=$PIECE(^AUPNPROB(X,0),U,1)
+13 IF '$$ICD^BDMUTL(Z,T,9)
QUIT
+14 ;cmi/anch/maw 8/27/2007 code set versioning
IF $PIECE($$ICDDX^BDMUTL(Z,,,"I"),U,2)=305.13
SET BDMTOBS="PAST USE OF TOBACCO"_" - "_$EXTRACT($$VAL^XBDIQ1(9000011,X,.05),1,30)_U_$PIECE(^AUPNPROB(X,0),U,3)
QUIT
+15 SET BDMTOBS="YES, USES TOBACCO - "_$EXTRACT($$VAL^XBDIQ1(9000011,X,.05),1,30)_" Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)_U_$PIECE(^AUPNPROB(X,0),U,3)
End DoDot:1
+16 QUIT
TOBACCO2 ;check pov file for TOBACCO USE DOC
+1 KILL BDM
SET BDMX=BDMSDFN_"^LAST DX [DM AUDIT SMOKING RELATED DXS"
SET E=$$START1^APCLDF(BDMX,"BDM(")
IF E
QUIT
IF $DATA(BDM(1))
Begin DoDot:1
+2 IF $PIECE(BDM(1),U,1)<BDMTOBD
QUIT
+3 IF $PIECE(BDM(1),U,1)=BDMTOBD
QUIT
+4 IF $PIECE(BDM(1),U,2)=305.13
SET BDMTOBS="PAST USE OF TOBACCO"_" - "_$EXTRACT($$VAL^XBDIQ1(9000010.07,+$PIECE(BDM(1),U,4),.04),1,30)_U_$PIECE(BDM(1),U)
QUIT
+5 SET BDMTOBS="YES, USES TOBACCO"_" - "_$EXTRACT($PIECE(^AUTNPOV(+$PIECE(^AUPNVPOV(+$PIECE(BDM(1),U,4),0),U,4),0),U),1,30)_" POV: "_$EXTRACT($$VAL^XBDIQ1(9000010.07,+$PIECE(BDM(1),U,4),.04),1,30)_" "_$$DATE^BDMS9B1($PIECE(BDM(1),U))_U_$
PIECE(BDM(1),U)
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
REFDF(P,F,I,D,TEXT) ;EP - dm item refused?
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(F)
QUIT ""
+3 IF '$GET(I)
QUIT ""
+4 SET TEXT=$GET(TEXT)
+5 IF $GET(D)=""
SET D=""
+6 NEW X
SET X=$ORDER(^AUPNPREF("AA",P,F,I,0))
+7 ;none of this item was refused
IF 'X
QUIT ""
+8 NEW Y
SET Y=9999999-X
+9 IF D]""
IF Y>D
QUIT "Refused "_$SELECT(TEXT]"":TEXT,1:$EXTRACT($$VAL^XBDIQ1(F,I,.01),1,30))_" on "_$$DATE^BDMS9B1(Y)
+10 IF D]""
IF Y<D
QUIT ""
+11 QUIT "Refused "_$SELECT(TEXT]"":TEXT,1:$EXTRACT($$VAL^XBDIQ1(F,I,.01),1,30))_" on "_$$DATE^BDMS9B1(Y)
+12 ;
CHEST(P) ;EP - get date of last chest xray from V RAD or V CPT
+1 ;FIX ALL RAD LOOKUPS TO LOOP THROUGH GLOBAL
+2 IF $GET(P)=""
QUIT ""
+3 NEW X,Y,Z,G,LCHEST,T,D
+4 SET LCHEST=""
+5 SET (X,Y,V)=0
FOR
SET X=$ORDER(^AUPNVRAD("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET V=$PIECE(^AUPNVRAD(X,0),U,3)
+7 IF 'V
QUIT
+8 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+9 SET Y=$PIECE(^AUPNVRAD(X,0),U)
SET Y=$PIECE($GET(^RAMIS(71,Y,0)),U,9)
+10 IF Y>71009&(Y<71036)
IF V>LCHEST
SET LCHEST=V
QUIT
End DoDot:1
+11 SET T=71009
FOR
SET T=$ORDER(^ICPT("B",T))
IF T>71035
QUIT
SET X=0
FOR
SET X=$ORDER(^ICPT("B",T,X))
IF X'=+X
QUIT
Begin DoDot:1
+12 SET D=$ORDER(^AUPNVCPT("AA",P,X,0))
IF D
SET D=9999999-D
+13 IF D
IF D>LCHEST
SET LCHEST=D
End DoDot:1
+14 KILL BDMY
SET %=P_"^LAST PROCEDURE 87.44"
SET E=$$START1^APCLDF(%,"BDMY(")
+15 IF $DATA(BDMY(1))
IF $PIECE(BDMY(1),U)>LCHEST
SET LCHEST=$PIECE(BDMY(1),U)
+16 KILL BDMY
SET %=P_"^LAST PROCEDURE 87.39"
SET E=$$START1^APCLDF(%,"BDMY(")
+17 IF $DATA(BDMY(1))
IF $PIECE(BDMY(1),U)>LCHEST
SET LCHEST=$PIECE(BDMY(1),U)
+18 QUIT $SELECT(LCHEST]"":$$DATE^BDMS9B1(LCHEST),1:"")
EKG(P) ;EP
+1 NEW BDMY,%,LEKG
SET LEKG=""
SET %=P_"^LAST DIAGNOSTIC ECG SUMMARY"
SET E=$$START1^APCLDF(%,"BDMY(")
+2 IF $DATA(BDMY)
SET LEKG=$PIECE(BDMY(1),U)_U_$$VAL^XBDIQ1(9000010.21,+$PIECE(BDMY(1),U,4),.04)
+3 KILL BDMY
SET %=P_"^LAST PROCEDURE 89.50"
SET E=$$START1^APCLDF(%,"BDMY(")
+4 IF $DATA(BDMY(1))
Begin DoDot:1
+5 IF LEKG>$PIECE(BDMY(1),U)
QUIT
+6 SET LEKG=$PIECE(BDMY(1),U)
End DoDot:1
+7 KILL BDMY
SET %=P_"^LAST PROCEDURE 89.51"
SET E=$$START1^APCLDF(%,"BDMY(")
+8 IF $DATA(BDMY(1))
Begin DoDot:1
+9 IF LEKG>$PIECE(BDMY(1),U)
QUIT
+10 SET LEKG=$PIECE(BDMY(1),U)
End DoDot:1
+11 KILL BDMY
SET %=P_"^LAST PROCEDURE 89.52"
SET E=$$START1^APCLDF(%,"BDMY(")
+12 IF $DATA(BDMY(1))
Begin DoDot:1
+13 IF LEKG>$PIECE(BDMY(1),U)
QUIT
+14 SET LEKG=$PIECE(BDMY(1),U)
End DoDot:1
+15 KILL BDMY
SET %=P_"^LAST PROCEDURE 89.53"
SET E=$$START1^APCLDF(%,"BDMY(")
+16 IF $DATA(BDMY(1))
Begin DoDot:1
+17 IF LEKG>$PIECE(BDMY(1),U)
QUIT
+18 SET LEKG=$PIECE(BDMY(1),U)
End DoDot:1
+19 KILL BDMY
SET %=P_"^LAST DX 794.31"
SET E=$$START1^APCLDF(%,"BDMY(")
+20 IF $DATA(BDMY(1))
Begin DoDot:1
+21 IF LEKG>$PIECE(BDMY(1),U)
QUIT
+22 SET LEKG=$PIECE(BDMY(1),U)
End DoDot:1
+23 ;check CPT
+24 SET T=$ORDER(^ATXAX("B","DM AUDIT EKG CPTS",0))
+25 KILL BDMY
IF T
SET BDMY(1)=$$CPT(P,,,T,3)
Begin DoDot:1
+26 IF BDMY(1)=""
KILL BDMY
QUIT
+27 IF LEKG>$PIECE(BDMY(1),U)
QUIT
+28 SET LEKG=$PIECE(BDMY(1),U)
End DoDot:1
+29 KILL BDMY
IF T
SET BDMY(1)=$$RAD(P,,,T,3)
Begin DoDot:1
+30 IF BDMY(1)=""
KILL BDMY
QUIT
+31 IF LEKG>$PIECE(BDMY(1),U)
QUIT
+32 SET LEKG=$PIECE(BDMY(1),U)
End DoDot:1
+33 ;
+34 ;
+35 QUIT $$DATE^BDMS9B1(LEKG)_U_$PIECE(LEKG,U,2)
+36 ;
CPT(P,BDATE,EDATE,T,F) ;
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 IF $GET(EDATE)=""
SET EDATE=DT
+5 IF $GET(BDATE)=""
SET BDATE=$PIECE(^DPT(P,0),U,3)
+6 ;go through visits in a date range for this patient, check cpts
+7 NEW D,BD,ED,X,Y,D,G,V
+8 SET ED=9999999-EDATE
SET BD=9999999-BDATE
SET G=0
+9 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+14 IF $$ICD^ATXCHK($PIECE(^AUPNVCPT(X,0),U),T,1)
SET G=X
+15 QUIT
End DoDot:3
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 IF 'G
QUIT ""
+19 IF F=1
QUIT $SELECT(G:1,1:"")
+20 IF F=2
QUIT G
+21 IF F=3
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+22 IF F=4
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $$DATE^BDMS9B1($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+23 QUIT ""
RAD(P,BDATE,EDATE,T,F) ;return if a v rad entry in date range
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 IF $GET(EDATE)=""
SET EDATE=DT
+5 IF $GET(BDATE)=""
SET BDATE=$PIECE(^DPT(P,0),U,3)
+6 ;go through visits in a date range for this patient, check cpts
+7 NEW D,BD,ED,X,Y,D,G,V
+8 SET ED=9999999-EDATE
SET BD=9999999-BDATE
SET G=0
+9 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 IF '$DATA(^AUPNVRAD("AD",V))
QUIT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVRAD("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+14 IF '$DATA(^AUPNVRAD(X,0))
QUIT
+15 SET Y=$PIECE(^AUPNVRAD(X,0),U)
IF 'Y
QUIT
IF '$DATA(^RAMIS(71,Y,0))
QUIT
+16 SET Y=$PIECE($GET(^RAMIS(71,Y,0)),U,9)
IF 'Y
QUIT
+17 IF '$$ICD^ATXCHK(Y,T,1)
QUIT
+18 SET G=X
+19 QUIT
End DoDot:3
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 IF 'G
QUIT ""
+23 IF F=1
QUIT $SELECT(G:1,1:"")
+24 IF F=2
QUIT G
+25 IF F=3
SET V=$PIECE(^AUPNVRAD(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+26 IF F=4
SET V=$PIECE(^AUPNVRAD(G,0),U,3)
IF V
QUIT $$DATE^BDMS9B1($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+27 QUIT ""
