BDMLPM.m

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),".")