BDMLPM ; IHS/CMI/LAB - CALCULATE LAST PAP MAM ; 20 Oct 2017 1:17 PM
;;2.0;DIABETES MANAGEMENT SYSTEM;**1,2,8,9,10,11,12**;JUN 14, 2007;Build 51
;
;
LASTPAP(P) ;EP - return last pap date
Q:$P($G(^DPT(+$G(P),0)),U,2)'="F" ""
I $$HYSTER(P) Q ""
N APCHY,%,LPAP,T
S LPAP=""
S %=P_"^LAST LAB PAP SMEAR"
S E=$$START1^APCLDF(%,"APCHY(")
S:$G(APCHY(1))>LPAP LPAP=+APCHY(1)
;
K APCHY S %=P_"^LAST LAB [BGP PAP SMEAR TAX",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) D
.Q:LPAP>$P(APCHY(1),U)
.S LPAP=$P(APCHY(1),U)
;
K APCHY
F X="V76.2" S %=P_"^LAST DX "_X D
.S E=$$START1^APCLDF(%,"APCHY(")
.S:$G(APCHY(1))>LPAP LPAP=+APCHY(1)
K APCHY
S %=P_"^LAST PROCEDURE [BGP HYSTERECTOMY PROCEDURES"
S E=$$START1^APCLDF(%,"APCHY(")
S:$G(APCHY(1))>LPAP LPAP=+APCHY(1)
K APCHY
F X=88141:1:88148,88150,88152:1:88158,88164:1:88167 D
.S T=$O(^ICPT("B",X,0))
.Q:'T
.S APCHY(1)=$O(^AUPNVCPT("AA",P,T,0))
.Q:'APCHY(1)
.S APCHY(1)=9999999-APCHY(1)
.S:APCHY(1)>LPAP LPAP=$P(APCHY(1),U)
Q $G(LPAP)
;
HYSTER(P) ;EP has patient had hysterectomy?
I '$G(P) Q ""
I '$D(^AUPNVPRC("AC",P)) Q ""
;NEW F,S,C S (F,S)=0 F S F=$O(^AUPNVPRC("AC",P,F)) Q:F'=+F!(S) S C=$P(^ICD0(+^AUPNVPRC(F,0),0),U) D ;cmi/anch/maw 8/27/2007 orig line patch 1
NEW F,S,C S (F,S)=0 F S F=$O(^AUPNVPRC("AC",P,F)) Q:F'=+F!(S) S C=+^AUPNVPRC(F,0) D ;cmi/anch/maw 8/27/2007 code set versioning patch 1
.;S:C=68.3!(C=68.4)!(C=68.5)!(C=68.6)!(C=68.7)!(C=68.9) S=1
.I $$ICD^BDMUTL(C,"BGP HYSTERECTOMY PROCEDURES",0)
I S=1 Q 1
S T="HYSTERECTOMY",T=$O(^BWPN("B",T,0))
I T D I X Q 1
.S X=$$WH(P,$$DOB^AUPNPAT(P),DT,T,1)
S T=$O(^ATXAX("B","BGP HYSTERECTOMY CPTS",0))
I T D I X Q 1
.S X=$$CPT(P,$P(^DPT(P,0),U,3),DT,"BGP HYSTERECTOMY CPTS",1)
Q ""
WH(P,BDATE,EDATE,T,F) ;EP
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
;go through procedures in a date range for this patient, check proc type
NEW D,X,Y,G,V
S (G,V)=0 F S V=$O(^BWPCD("C",P,V)) Q:V=""!(G) D
.Q:'$D(^BWPCD(V,0))
.I $P(^BWPCD(V,0),U,4)'=T Q
.S D=$P(^BWPCD(V,0),U,12)
.Q:D<BDATE
.Q:D>EDATE
.S G=V
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S D=$P(^BWPCD(G,0),U,12) Q D
I F=4 S D=$P(^BWPCD(G,0),U,12) Q $$FMTE^XLFDT(D)
Q ""
CPT(P,BDATE,EDATE,T,F) ;EP - return ien of CPT entry if patient had this CPT
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
;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 $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
I F=5 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVCPT(G,0),U),0),U,2)
Q ""
LASTMAM(P) ;EP
Q:$P($G(^DPT(+$G(P),0)),U,2)'="F" ""
N LMAM,T,APCHY,%
S LMAM=""
F X=76090:1:76092 S %=P_"^LAST RAD "_X D
.S E=$$START1^APCLDF(%,"APCHY(")
.S:$G(APCHY(1))>LMAM LMAM=+APCHY(1)
K APCHY
F X="V76.11","V76.12" S %=P_"^LAST DX "_X D
.S E=$$START1^APCLDF(%,"APCHY(")
.S:$G(APCHY(1))>LMAM LMAM=+APCHY(1)
K APCHY
F X=87.36,87.37 S %=P_"^LAST PROCEDURE "_X D
.S E=$$START1^APCLDF(%,"APCHY(")
.S:$G(APCHY(1))>LMAM LMAM=+APCHY(1)
K APCHY
F %=76090:1:76092 S T=$O(^ICPT("B",%,0)) D:T
.S APCHY(1)=$O(^AUPNVCPT("AA",P,T,0))
.Q:'APCHY(1)
.S APCHY(1)=9999999-APCHY(1)
.S:$G(APCHY(1))>LMAM LMAM=+APCHY(1)
F %=76090:1:76092 S G=$$REFDF^BDMS9B3(P,71,$O(^RAMIS(71,"D",%,0)),$G(LMAM)) Q:G]""
I $G(G)]"" Q $G(LMAM)_"^"_G
Q $G(LMAM)
MAS(P,EDATE) ;EPmastectomy before end of time frame
N BDMT
K BDMT S %=P_"^LAST PROCEDURE 85.42;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BDMT(")
I $D(BDMT(1)) Q 1
K BDMT S %=P_"^LAST PROCEDURE 85.44;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BDMT(")
I $D(BDMT(1)) Q 1
K BDMT S %=P_"^LAST PROCEDURE 85.46;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BDMT(")
I $D(BDMT(1)) Q 1
K BDMT S %=P_"^LAST PROCEDURE 85.48;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BDMT(")
I $D(BDMT(1)) Q 1
;check cpt codes for bilateral
;loop through all cpt codes up to Edate and if any match quit
S (X,Y,Z,G)=0 K BDMTX
S T=$O(^ICPT("B",19180,0)),T1=$O(^ICPT("B",19200,0)),T2=$O(^ICPT("B",19220,0)),T3=$O(^ICPT("B",19240,0))
I T,$D(^AUPNVCPT("AA",P,T)) S %="" D I %]"" Q 1
.S E=0 F S E=$O(^AUPNVCPT("AA",P,T,E)) Q:E'=+E!(%]"") D
..S D=9999999-E ;date done
..I D>EDATE Q
..S Y=0 F S Y=$O(^AUPNVCPT("AA",P,T,E,Y)) Q:Y'=+Y D
...S BDMTX(E)=""
...S M=$P(^AUPNVCPT(Y,0),U,8) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
...S M=$P(^AUPNVCPT(Y,0),U,9) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
..Q
.Q
I T1,$D(^AUPNVCPT("AA",P,T1)) S %="" D I %]"" Q 1
.S E=0 F S E=$O(^AUPNVCPT("AA",P,T1,E)) Q:E'=+E!(%]"") D
..S D=9999999-E ;date done
..I D>EDATE Q
..S Y=0 F S Y=$O(^AUPNVCPT("AA",P,T1,E,Y)) Q:Y'=+Y D
...S BDMTX(E)=""
...S M=$P(^AUPNVCPT(Y,0),U,8) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
...S M=$P(^AUPNVCPT(Y,0),U,9) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
..Q
.Q
I T2,$D(^AUPNVCPT("AA",P,T2)) S %="" D I %]"" Q 1
.S E=0 F S E=$O(^AUPNVCPT("AA",P,T2,E)) Q:E'=+E!(%]"") D
..S D=9999999-E ;date done
..I D>EDATE Q
..S Y=0 F S Y=$O(^AUPNVCPT("AA",P,T2,E,Y)) Q:Y'=+Y D
...S BDMTX(E)=""
...S M=$P(^AUPNVCPT(Y,0),U,8) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
...S M=$P(^AUPNVCPT(Y,0),U,9) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
..Q
.Q
I T3,$D(^AUPNVCPT("AA",P,T3)) S %="" D I %]"" Q 1
.S E=0 F S E=$O(^AUPNVCPT("AA",P,T3,E)) Q:E'=+E!(%]"") D
..S D=9999999-E ;date done
..I D>EDATE Q
..S Y=0 F S Y=$O(^AUPNVCPT("AA",P,T3,E,Y)) Q:Y'=+Y D
...S BDMTX(D)=""
...S M=$P(^AUPNVCPT(Y,0),U,8) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
...S M=$P(^AUPNVCPT(Y,0),U,9) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
..Q
.Q
;see if 2 on different dates
K BDMT S %=P_"^ALL PROCEDURE [BGP MASTECTOMY PROCEDURES;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BDMT(")
S X=0 F S X=$O(BDMT(X)) Q:X'=+X S BDMTX($P(BDMT(X),U))=""
S %=0,X=0,C=0 F S X=$O(BDMTX(X)) Q:X'=+X S C=C+1
I C>1 Q 1
Q 0
DIETEDUC(P,BDATE,EDATE) ;EP
NEW D,BD,ED,X,Y,%DT,D,G,APCLVRD,V,APCL,RD,NRD
S (RD,NRD)=""
S X=BDATE,%DT="P" D ^%DT S BD=Y
S X=EDATE,%DT="P" D ^%DT S ED=Y
S D=0,(RD,NRD)="",G="" ;is this right???
F S D=$O(^AUPNVSIT("AA",P,D)) Q:D=""!($P(D,".")>(9999999-BD))!(G]"") D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,D,V)) Q:V'=+V 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^BDMD917(V)
..Q:$P(^AUPNVSIT(V,0),U,3)="C"
..Q:$$CLINIC^APCLV(V,"C")=52
..I $$PRIMPROV^APCLV(V,"D")=29 S G=D Q
..I $$PRIMPROV^APCLV(V,"D")="07" S G=D Q
..I $$PRIMPROV^APCLV(V,"D")="34" S G=D Q
..S X=0 F S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X I $$ICD^BDMUTL($$VALI^XBDIQ1(9000010.07,X,.01),"BGP DIETARY SURVEILLANCE DXS",9) S G=D
..I G Q
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X S Z=$$VAL^XBDIQ1(9000010.07,X,.01) I Z=97802!(Z=97803)!(Z=97804) S G=D
..S T=$O(^ATXAX("B","DM AUDIT DIET EDUC TOPICS",0))
..I G Q
..S X=0 F S X=$O(^AUPNVPED("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVPED(X,0),U)
...I T,$D(^ATXAX(T,21,"AA",Y)) S G=D
...S J=$P(^AUTTEDT(Y,0),U,2)
...I $P(J,"-",2)="N" S G=D Q
...I $P(J,"-",2)="DT" S G=D Q
...I $P(J,"-",2)="MNT" S G=D Q
...I $P(J,"-",1)="MNT" S G=D Q
...I $P(J,"-",1)="DMCN" S G=D Q
.Q
Q G
PC(V) ;return provider discipline of educ provider
I 'V Q ""
NEW X S X=$P(^AUPNVPED(V,0),U,5)
I 'X Q ""
I $P(^DD(9000010.16,.05,0),U,2)[200 Q $$PROVCLSC^XBFUNC1(X)
NEW A S A=$P(^DIC(6,X,0),U,4)
I 'A Q ""
Q $P($G(^DIC(7,A,9999999)),U)
EXEDUC(P,BDATE,EDATE) ;EP
NEW D,BD,ED,X,Y,%DT,D,G,APCLVRD,V,APCL,RD,NRD
S (RD,NRD)=""
S X=BDATE,%DT="P" D ^%DT S BD=Y
S X=EDATE,%DT="P" D ^%DT S ED=Y
S D=0,(RD,NRD)="",G="" ;is this right???
F S D=$O(^AUPNVSIT("AA",P,D)) Q:D=""!($P(D,".")>(9999999-BD))!(G]"") D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,D,V)) Q:V'=+V 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^BDMD917(V)
..Q:$P(^AUPNVSIT(V,0),U,3)="C"
..S X=0 F S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X I $$ICD^BDMUTL($$VALI^XBDIQ1(9000010.07,X,.01),"BGP EXERCISE COUNSELING DXS",9) S G=D
..I G Q
..S T=$O(^ATXAX("B","DM AUDIT EXERCISE EDUC TOPICS",0))
..S X=0 F S X=$O(^AUPNVPED("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVPED(X,0),U)
...I T,$D(^ATXAX(T,21,"AA",Y)) S G=D
...S J=$P(^AUTTEDT(Y,0),U,2)
...I $P(J,"-",2)="EX" S G=D Q
.Q
Q G
OTHEDUC(P,BDATE,EDATE) ;EP
NEW D,BD,ED,X,Y,%DT,D,G,APCLVRD,V,APCL,RD,NRD
S (RD,NRD)=""
S X=BDATE,%DT="P" D ^%DT S BD=Y
S X=EDATE,%DT="P" D ^%DT S ED=Y
S D="",(RD,NRD)="",G="" ;is this right???
F S D=$O(^AUPNVSIT("AA",P,D)) Q:D=""!($P(D,".")>(9999999-BD))!(G]"") D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,D,V)) Q:V'=+V 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^BDMD917(V)
..Q:$P(^AUPNVSIT(V,0),U,3)="C"
..S T=$O(^ATXAX("B","DM AUDIT OTHER EDUC TOPICS",0))
..S X=0 F S X=$O(^AUPNVPED("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVPED(X,0),U)
...S J=$P(^AUTTEDT(Y,0),U,2)
...I $P(J,"-",2)="EX" Q
...I $P(J,"-",2)="N" Q
...I $P(J,"-",2)="DT" Q
...I $P(J,"-",2)="MNT" Q
...I $P(J,"-",1)="MNT" Q
...I $P(J,"-",1)="DMCN" Q
...I T,$D(^ATXAX(T,21,"AA",Y)) S G=D Q
...I $P(J,"-",1)="250" S G=D Q
...I $P(J,"-",1)="DM" S G=D Q
...I $P(J,"-",1)="DMC" S G=D Q
...I $P(J,"-",1)]"",$$SNOMED^BDMUTL(2019,"PXRM DIABETES",$P(J,"-",1)) S G=D Q
...N CODE
...S CODE=$P($$CODEN^BDMUTL($P(T,"-",1),80),"~")
...I CODE>0 D Q
....N TAX
....S TAX=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))
....I $$ICD^BDMUTL(CODE,$P(^ATXAX(TAX,0),U),9) S G=D
...I $P(J,"-",1)]"",$$SNOMED^BDMUTL(2019,"PXRM DIABETES",$P(J,"-",1)) S G=$$VD^APCLV($P(^AUPNVPED(I,0),U,3))
Q G
BDMLPM ; IHS/CMI/LAB - CALCULATE LAST PAP MAM ; 20 Oct 2017 1:17 PM
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**1,2,8,9,10,11,12**;JUN 14, 2007;Build 51
+2 ;
+3 ;
LASTPAP(P) ;EP - return last pap date
+1 IF $PIECE($GET(^DPT(+$GET(P),0)),U,2)'="F"
QUIT ""
+2 IF $$HYSTER(P)
QUIT ""
+3 NEW APCHY,%,LPAP,T
+4 SET LPAP=""
+5 SET %=P_"^LAST LAB PAP SMEAR"
+6 SET E=$$START1^APCLDF(%,"APCHY(")
+7 IF $GET(APCHY(1))>LPAP
SET LPAP=+APCHY(1)
+8 ;
+9 KILL APCHY
SET %=P_"^LAST LAB [BGP PAP SMEAR TAX"
SET E=$$START1^APCLDF(%,"APCHY(")
+10 IF $DATA(APCHY(1))
Begin DoDot:1
+11 IF LPAP>$PIECE(APCHY(1),U)
QUIT
+12 SET LPAP=$PIECE(APCHY(1),U)
End DoDot:1
+13 ;
+14 KILL APCHY
+15 FOR X="V76.2"
SET %=P_"^LAST DX "_X
Begin DoDot:1
+16 SET E=$$START1^APCLDF(%,"APCHY(")
+17 IF $GET(APCHY(1))>LPAP
SET LPAP=+APCHY(1)
End DoDot:1
+18 KILL APCHY
+19 SET %=P_"^LAST PROCEDURE [BGP HYSTERECTOMY PROCEDURES"
+20 SET E=$$START1^APCLDF(%,"APCHY(")
+21 IF $GET(APCHY(1))>LPAP
SET LPAP=+APCHY(1)
+22 KILL APCHY
+23 FOR X=88141:1:88148,88150,88152:1:88158,88164:1:88167
Begin DoDot:1
+24 SET T=$ORDER(^ICPT("B",X,0))
+25 IF 'T
QUIT
+26 SET APCHY(1)=$ORDER(^AUPNVCPT("AA",P,T,0))
+27 IF 'APCHY(1)
QUIT
+28 SET APCHY(1)=9999999-APCHY(1)
+29 IF APCHY(1)>LPAP
SET LPAP=$PIECE(APCHY(1),U)
End DoDot:1
+30 QUIT $GET(LPAP)
+31 ;
HYSTER(P) ;EP has patient had hysterectomy?
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^AUPNVPRC("AC",P))
QUIT ""
+3 ;NEW F,S,C S (F,S)=0 F S F=$O(^AUPNVPRC("AC",P,F)) Q:F'=+F!(S) S C=$P(^ICD0(+^AUPNVPRC(F,0),0),U) D ;cmi/anch/maw 8/27/2007 orig line patch 1
+4 ;cmi/anch/maw 8/27/2007 code set versioning patch 1
NEW F,S,C
SET (F,S)=0
FOR
SET F=$ORDER(^AUPNVPRC("AC",P,F))
IF F'=+F!(S)
QUIT
SET C=+^AUPNVPRC(F,0)
Begin DoDot:1
+5 ;S:C=68.3!(C=68.4)!(C=68.5)!(C=68.6)!(C=68.7)!(C=68.9) S=1
+6 IF $$ICD^BDMUTL(C,"BGP HYSTERECTOMY PROCEDURES",0)
End DoDot:1
+7 IF S=1
QUIT 1
+8 SET T="HYSTERECTOMY"
SET T=$ORDER(^BWPN("B",T,0))
+9 IF T
Begin DoDot:1
+10 SET X=$$WH(P,$$DOB^AUPNPAT(P),DT,T,1)
End DoDot:1
IF X
QUIT 1
+11 SET T=$ORDER(^ATXAX("B","BGP HYSTERECTOMY CPTS",0))
+12 IF T
Begin DoDot:1
+13 SET X=$$CPT(P,$PIECE(^DPT(P,0),U,3),DT,"BGP HYSTERECTOMY CPTS",1)
End DoDot:1
IF X
QUIT 1
+14 QUIT ""
WH(P,BDATE,EDATE,T,F) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 IF $GET(EDATE)=""
QUIT ""
+5 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+6 ;go through procedures in a date range for this patient, check proc type
+7 NEW D,X,Y,G,V
+8 SET (G,V)=0
FOR
SET V=$ORDER(^BWPCD("C",P,V))
IF V=""!(G)
QUIT
Begin DoDot:1
+9 IF '$DATA(^BWPCD(V,0))
QUIT
+10 IF $PIECE(^BWPCD(V,0),U,4)'=T
QUIT
+11 SET D=$PIECE(^BWPCD(V,0),U,12)
+12 IF D<BDATE
QUIT
+13 IF D>EDATE
QUIT
+14 SET G=V
+15 QUIT
End DoDot:1
+16 IF 'G
QUIT ""
+17 IF F=1
QUIT $SELECT(G:1,1:"")
+18 IF F=2
QUIT G
+19 IF F=3
SET D=$PIECE(^BWPCD(G,0),U,12)
QUIT D
+20 IF F=4
SET D=$PIECE(^BWPCD(G,0),U,12)
QUIT $$FMTE^XLFDT(D)
+21 QUIT ""
CPT(P,BDATE,EDATE,T,F) ;EP - return ien of CPT entry if patient had this CPT
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 IF $GET(EDATE)=""
QUIT ""
+5 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+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 $$FMTE^XLFDT($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+23 IF F=5
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVCPT(G,0),U),0),U,2)
+24 QUIT ""
LASTMAM(P) ;EP
+1 IF $PIECE($GET(^DPT(+$GET(P),0)),U,2)'="F"
QUIT ""
+2 NEW LMAM,T,APCHY,%
+3 SET LMAM=""
+4 FOR X=76090:1:76092
SET %=P_"^LAST RAD "_X
Begin DoDot:1
+5 SET E=$$START1^APCLDF(%,"APCHY(")
+6 IF $GET(APCHY(1))>LMAM
SET LMAM=+APCHY(1)
End DoDot:1
+7 KILL APCHY
+8 FOR X="V76.11","V76.12"
SET %=P_"^LAST DX "_X
Begin DoDot:1
+9 SET E=$$START1^APCLDF(%,"APCHY(")
+10 IF $GET(APCHY(1))>LMAM
SET LMAM=+APCHY(1)
End DoDot:1
+11 KILL APCHY
+12 FOR X=87.36,87.37
SET %=P_"^LAST PROCEDURE "_X
Begin DoDot:1
+13 SET E=$$START1^APCLDF(%,"APCHY(")
+14 IF $GET(APCHY(1))>LMAM
SET LMAM=+APCHY(1)
End DoDot:1
+15 KILL APCHY
+16 FOR %=76090:1:76092
SET T=$ORDER(^ICPT("B",%,0))
IF T
Begin DoDot:1
+17 SET APCHY(1)=$ORDER(^AUPNVCPT("AA",P,T,0))
+18 IF 'APCHY(1)
QUIT
+19 SET APCHY(1)=9999999-APCHY(1)
+20 IF $GET(APCHY(1))>LMAM
SET LMAM=+APCHY(1)
End DoDot:1
+21 FOR %=76090:1:76092
SET G=$$REFDF^BDMS9B3(P,71,$ORDER(^RAMIS(71,"D",%,0)),$GET(LMAM))
IF G]""
QUIT
+22 IF $GET(G)]""
QUIT $GET(LMAM)_"^"_G
+23 QUIT $GET(LMAM)
MAS(P,EDATE) ;EPmastectomy before end of time frame
+1 NEW BDMT
+2 KILL BDMT
SET %=P_"^LAST PROCEDURE 85.42;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BDMT(")
+3 IF $DATA(BDMT(1))
QUIT 1
+4 KILL BDMT
SET %=P_"^LAST PROCEDURE 85.44;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BDMT(")
+5 IF $DATA(BDMT(1))
QUIT 1
+6 KILL BDMT
SET %=P_"^LAST PROCEDURE 85.46;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BDMT(")
+7 IF $DATA(BDMT(1))
QUIT 1
+8 KILL BDMT
SET %=P_"^LAST PROCEDURE 85.48;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BDMT(")
+9 IF $DATA(BDMT(1))
QUIT 1
+10 ;check cpt codes for bilateral
+11 ;loop through all cpt codes up to Edate and if any match quit
+12 SET (X,Y,Z,G)=0
KILL BDMTX
+13 SET T=$ORDER(^ICPT("B",19180,0))
SET T1=$ORDER(^ICPT("B",19200,0))
SET T2=$ORDER(^ICPT("B",19220,0))
SET T3=$ORDER(^ICPT("B",19240,0))
+14 IF T
IF $DATA(^AUPNVCPT("AA",P,T))
SET %=""
Begin DoDot:1
+15 SET E=0
FOR
SET E=$ORDER(^AUPNVCPT("AA",P,T,E))
IF E'=+E!(%]"")
QUIT
Begin DoDot:2
+16 ;date done
SET D=9999999-E
+17 IF D>EDATE
QUIT
+18 SET Y=0
FOR
SET Y=$ORDER(^AUPNVCPT("AA",P,T,E,Y))
IF Y'=+Y
QUIT
Begin DoDot:3
+19 SET BDMTX(E)=""
+20 SET M=$PIECE(^AUPNVCPT(Y,0),U,8)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1
+21 SET M=$PIECE(^AUPNVCPT(Y,0),U,9)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1
End DoDot:3
+22 QUIT
End DoDot:2
+23 QUIT
End DoDot:1
IF %]""
QUIT 1
+24 IF T1
IF $DATA(^AUPNVCPT("AA",P,T1))
SET %=""
Begin DoDot:1
+25 SET E=0
FOR
SET E=$ORDER(^AUPNVCPT("AA",P,T1,E))
IF E'=+E!(%]"")
QUIT
Begin DoDot:2
+26 ;date done
SET D=9999999-E
+27 IF D>EDATE
QUIT
+28 SET Y=0
FOR
SET Y=$ORDER(^AUPNVCPT("AA",P,T1,E,Y))
IF Y'=+Y
QUIT
Begin DoDot:3
+29 SET BDMTX(E)=""
+30 SET M=$PIECE(^AUPNVCPT(Y,0),U,8)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1
+31 SET M=$PIECE(^AUPNVCPT(Y,0),U,9)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1
End DoDot:3
+32 QUIT
End DoDot:2
+33 QUIT
End DoDot:1
IF %]""
QUIT 1
+34 IF T2
IF $DATA(^AUPNVCPT("AA",P,T2))
SET %=""
Begin DoDot:1
+35 SET E=0
FOR
SET E=$ORDER(^AUPNVCPT("AA",P,T2,E))
IF E'=+E!(%]"")
QUIT
Begin DoDot:2
+36 ;date done
SET D=9999999-E
+37 IF D>EDATE
QUIT
+38 SET Y=0
FOR
SET Y=$ORDER(^AUPNVCPT("AA",P,T2,E,Y))
IF Y'=+Y
QUIT
Begin DoDot:3
+39 SET BDMTX(E)=""
+40 SET M=$PIECE(^AUPNVCPT(Y,0),U,8)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1
+41 SET M=$PIECE(^AUPNVCPT(Y,0),U,9)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1
End DoDot:3
+42 QUIT
End DoDot:2
+43 QUIT
End DoDot:1
IF %]""
QUIT 1
+44 IF T3
IF $DATA(^AUPNVCPT("AA",P,T3))
SET %=""
Begin DoDot:1
+45 SET E=0
FOR
SET E=$ORDER(^AUPNVCPT("AA",P,T3,E))
IF E'=+E!(%]"")
QUIT
Begin DoDot:2
+46 ;date done
SET D=9999999-E
+47 IF D>EDATE
QUIT
+48 SET Y=0
FOR
SET Y=$ORDER(^AUPNVCPT("AA",P,T3,E,Y))
IF Y'=+Y
QUIT
Begin DoDot:3
+49 SET BDMTX(D)=""
+50 SET M=$PIECE(^AUPNVCPT(Y,0),U,8)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1
+51 SET M=$PIECE(^AUPNVCPT(Y,0),U,9)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1
End DoDot:3
+52 QUIT
End DoDot:2
+53 QUIT
End DoDot:1
IF %]""
QUIT 1
+54 ;see if 2 on different dates
+55 KILL BDMT
SET %=P_"^ALL PROCEDURE [BGP MASTECTOMY PROCEDURES;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BDMT(")
+56 SET X=0
FOR
SET X=$ORDER(BDMT(X))
IF X'=+X
QUIT
SET BDMTX($PIECE(BDMT(X),U))=""
+57 SET %=0
SET X=0
SET C=0
FOR
SET X=$ORDER(BDMTX(X))
IF X'=+X
QUIT
SET C=C+1
+58 IF C>1
QUIT 1
+59 QUIT 0
DIETEDUC(P,BDATE,EDATE) ;EP
+1 NEW D,BD,ED,X,Y,%DT,D,G,APCLVRD,V,APCL,RD,NRD
+2 SET (RD,NRD)=""
+3 SET X=BDATE
SET %DT="P"
DO ^%DT
SET BD=Y
+4 SET X=EDATE
SET %DT="P"
DO ^%DT
SET ED=Y
+5 ;is this right???
SET D=0
SET (RD,NRD)=""
SET G=""
+6 FOR
SET D=$ORDER(^AUPNVSIT("AA",P,D))
IF D=""!($PIECE(D,".")>(9999999-BD))!(G]"")
QUIT
Begin DoDot:1
+7 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,D,V))
IF V'=+V
QUIT
Begin DoDot:2
+8 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+9 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+10 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+11 ;Q:'$D(^AUPNVPOV("AD",V))
+12 ;Q:'$D(^AUPNVPRV("AD",V))
+13 IF $$DNKA^BDMD917(V)
QUIT
+14 IF $PIECE(^AUPNVSIT(V,0),U,3)="C"
QUIT
+15 IF $$CLINIC^APCLV(V,"C")=52
QUIT
+16 IF $$PRIMPROV^APCLV(V,"D")=29
SET G=D
QUIT
+17 IF $$PRIMPROV^APCLV(V,"D")="07"
SET G=D
QUIT
+18 IF $$PRIMPROV^APCLV(V,"D")="34"
SET G=D
QUIT
+19 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",V,X))
IF X'=+X
QUIT
IF $$ICD^BDMUTL($$VALI^XBDIQ1(9000010.07,X,.01),"BGP DIETARY SURVEILLANCE DXS",9)
SET G=D
+20 IF G
QUIT
+21 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
SET Z=$$VAL^XBDIQ1(9000010.07,X,.01)
IF Z=97802!(Z=97803)!(Z=97804)
SET G=D
+22 SET T=$ORDER(^ATXAX("B","DM AUDIT DIET EDUC TOPICS",0))
+23 IF G
QUIT
+24 SET X=0
FOR
SET X=$ORDER(^AUPNVPED("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+25 SET Y=$PIECE(^AUPNVPED(X,0),U)
+26 IF T
IF $DATA(^ATXAX(T,21,"AA",Y))
SET G=D
+27 SET J=$PIECE(^AUTTEDT(Y,0),U,2)
+28 IF $PIECE(J,"-",2)="N"
SET G=D
QUIT
+29 IF $PIECE(J,"-",2)="DT"
SET G=D
QUIT
+30 IF $PIECE(J,"-",2)="MNT"
SET G=D
QUIT
+31 IF $PIECE(J,"-",1)="MNT"
SET G=D
QUIT
+32 IF $PIECE(J,"-",1)="DMCN"
SET G=D
QUIT
End DoDot:3
End DoDot:2
+33 QUIT
End DoDot:1
+34 QUIT G
PC(V) ;return provider discipline of educ provider
+1 IF 'V
QUIT ""
+2 NEW X
SET X=$PIECE(^AUPNVPED(V,0),U,5)
+3 IF 'X
QUIT ""
+4 IF $PIECE(^DD(9000010.16,.05,0),U,2)[200
QUIT $$PROVCLSC^XBFUNC1(X)
+5 NEW A
SET A=$PIECE(^DIC(6,X,0),U,4)
+6 IF 'A
QUIT ""
+7 QUIT $PIECE($GET(^DIC(7,A,9999999)),U)
EXEDUC(P,BDATE,EDATE) ;EP
+1 NEW D,BD,ED,X,Y,%DT,D,G,APCLVRD,V,APCL,RD,NRD
+2 SET (RD,NRD)=""
+3 SET X=BDATE
SET %DT="P"
DO ^%DT
SET BD=Y
+4 SET X=EDATE
SET %DT="P"
DO ^%DT
SET ED=Y
+5 ;is this right???
SET D=0
SET (RD,NRD)=""
SET G=""
+6 FOR
SET D=$ORDER(^AUPNVSIT("AA",P,D))
IF D=""!($PIECE(D,".")>(9999999-BD))!(G]"")
QUIT
Begin DoDot:1
+7 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,D,V))
IF V'=+V
QUIT
Begin DoDot:2
+8 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+9 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+10 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+11 ;Q:'$D(^AUPNVPOV("AD",V))
+12 ;Q:'$D(^AUPNVPRV("AD",V))
+13 IF $$DNKA^BDMD917(V)
QUIT
+14 IF $PIECE(^AUPNVSIT(V,0),U,3)="C"
QUIT
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",V,X))
IF X'=+X
QUIT
IF $$ICD^BDMUTL($$VALI^XBDIQ1(9000010.07,X,.01),"BGP EXERCISE COUNSELING DXS",9)
SET G=D
+16 IF G
QUIT
+17 SET T=$ORDER(^ATXAX("B","DM AUDIT EXERCISE EDUC TOPICS",0))
+18 SET X=0
FOR
SET X=$ORDER(^AUPNVPED("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+19 SET Y=$PIECE(^AUPNVPED(X,0),U)
+20 IF T
IF $DATA(^ATXAX(T,21,"AA",Y))
SET G=D
+21 SET J=$PIECE(^AUTTEDT(Y,0),U,2)
+22 IF $PIECE(J,"-",2)="EX"
SET G=D
QUIT
End DoDot:3
End DoDot:2
+23 QUIT
End DoDot:1
+24 QUIT G
OTHEDUC(P,BDATE,EDATE) ;EP
+1 NEW D,BD,ED,X,Y,%DT,D,G,APCLVRD,V,APCL,RD,NRD
+2 SET (RD,NRD)=""
+3 SET X=BDATE
SET %DT="P"
DO ^%DT
SET BD=Y
+4 SET X=EDATE
SET %DT="P"
DO ^%DT
SET ED=Y
+5 ;is this right???
SET D=""
SET (RD,NRD)=""
SET G=""
+6 FOR
SET D=$ORDER(^AUPNVSIT("AA",P,D))
IF D=""!($PIECE(D,".")>(9999999-BD))!(G]"")
QUIT
Begin DoDot:1
+7 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,D,V))
IF V'=+V
QUIT
Begin DoDot:2
+8 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+9 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+10 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+11 ;Q:'$D(^AUPNVPOV("AD",V))
+12 ;Q:'$D(^AUPNVPRV("AD",V))
+13 IF $$DNKA^BDMD917(V)
QUIT
+14 IF $PIECE(^AUPNVSIT(V,0),U,3)="C"
QUIT
+15 SET T=$ORDER(^ATXAX("B","DM AUDIT OTHER EDUC TOPICS",0))
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVPED("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+17 SET Y=$PIECE(^AUPNVPED(X,0),U)
+18 SET J=$PIECE(^AUTTEDT(Y,0),U,2)
+19 IF $PIECE(J,"-",2)="EX"
QUIT
+20 IF $PIECE(J,"-",2)="N"
QUIT
+21 IF $PIECE(J,"-",2)="DT"
QUIT
+22 IF $PIECE(J,"-",2)="MNT"
QUIT
+23 IF $PIECE(J,"-",1)="MNT"
QUIT
+24 IF $PIECE(J,"-",1)="DMCN"
QUIT
+25 IF T
IF $DATA(^ATXAX(T,21,"AA",Y))
SET G=D
QUIT
+26 IF $PIECE(J,"-",1)="250"
SET G=D
QUIT
+27 IF $PIECE(J,"-",1)="DM"
SET G=D
QUIT
+28 IF $PIECE(J,"-",1)="DMC"
SET G=D
QUIT
+29 IF $PIECE(J,"-",1)]""
IF $$SNOMED^BDMUTL(2019,"PXRM DIABETES",$PIECE(J,"-",1))
SET G=D
QUIT
+30 NEW CODE
+31 SET CODE=$PIECE($$CODEN^BDMUTL($PIECE(T,"-",1),80),"~")
+32 IF CODE>0
Begin DoDot:4
+33 NEW TAX
+34 SET TAX=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",0))
+35 IF $$ICD^BDMUTL(CODE,$PIECE(^ATXAX(TAX,0),U),9)
SET G=D
End DoDot:4
QUIT
+36 IF $PIECE(J,"-",1)]""
IF $$SNOMED^BDMUTL(2019,"PXRM DIABETES",$PIECE(J,"-",1))
SET G=$$VD^APCLV($PIECE(^AUPNVPED(I,0),U,3))
End DoDot:3
End DoDot:2
End DoDot:1
+37 QUIT G
