APCLP812 ; IHS/CMI/LAB - 2003 DIABETES AUDIT ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;cmi/anch/maw 9/10/2007 code set versioning in HYSTER,MAMMOG
;
SETN ;
S N="" NEW A,G S (A,G)=0 F S A=$O(APCL(A)) Q:A'=+A!(G) I $P(^AUPNVLAB(+$P(APCL(A),U,4),0),U,4)]"" S G=A
S N=$S(G:G,1:1)
Q
TBTX(P) ;EP
I '$G(P) Q ""
NEW APCL,E,X
K APCL
S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"APCL(")
I E Q ""
I $D(APCL(1)) Q $P(APCL(1),U,3)_U_$S($P(APCL(1),U,3)["TX COMPLETE":"1 Yes",$P(APCL(1),U,3)["TX INCOMPLETE"!($P(APCL(1),U,3)["TX UNTREATED"):"2 No",1:"4 Unknown")
N T,Y S T=$O(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
I 'T Q ""
N G S G="",X=0 F S X=$O(^AUPNHF("AA",P,X)) Q:X'=+X!(G]"") I $D(^ATXAX(T,21,"B",X)) S G=$P(^AUTTHF(X,0),U)
I G]"" Q G_U_$S(G["TX COMPLETE":"1 Yes",G["TX INCOMPLETE"!(G["TX UNTREATED"):"2 No",1:"4 Unknown")
Q ""
PAP(P,BDATE,EDATE) ; EP
NEW X,%DT,ED,%,APCLLTX,APCLLTAX,APCLC
S %DT="P",X=EDATE D ^%DT S ED=Y
S %DT="P",X=BDATE D ^%DT S BD=Y
I $$SEX^AUPNPAT(P)'="F" Q "N/A - male"
I $$AGE^AUPNPAT(P,ED)<18 Q "N/A - under 18"
I $$HYSTER(P,EDATE) Q "N/A - Patient had hysterectomy"
NEW APCL S %=P_"^LAST LAB PAP SMEAR;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) Q "Yes "_$$FMTE^XLFDT($P(APCL(1),U))
S APCLLTX=$O(^ATXAX("B","BGP PAP LOINC CODES",0))
S APCLLTAX=$O(^ATXLAB("B","BGP PAP SMEAR TAX",0))
S APCLC="",B=9999999-BD,E=9999999-ED S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(APCLC]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(APCLC]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(APCLC]"") D
...Q:'$D(^AUPNVLAB(X,0))
...S Z=$P(^AUPNVLAB(X,0),U),Z=$P($G(^LAB(60,Z,0)),U) I Z="PAP SMEAR" S APCLC="Yes "_$$FMTE^XLFDT((9999999-D)) Q
...I APCLLTAX,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCLLTAX,21,"B",$P(^AUPNVLAB(X,0),U))) S APCLC="Yes "_$$FMTE^XLFDT((9999999-D)) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,APCLLTX)
...S APCLC="Yes "_$$FMTE^XLFDT((9999999-D)) Q
...Q
I APCLC]"" Q APCLC
K APCL S %=P_"^LAST DX V76.2;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) Q "Yes "_$$FMTE^XLFDT($P(APCL(1),U))
;K APCL S %=P_"^LAST DX V72.3;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
;I $D(APCL(1)) Q "Yes "_$$FMTE^XLFDT($P(APCL(1),U))
K APCL S %=P_"^LAST PROCEDURE 91.46;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) Q "Yes "_$$FMTE^XLFDT($P(APCL(1),U))
;check CPT codes in year prior to date range
S T=$O(^ATXAX("B","BGP PAP CPTS",0))
K APCL I T S APCL(1)=$$CPT(P,,ED,T,4) I $G(APCL(1))]"" Q "Yes "_APCL(1)
;check WH
S T="PAP SMEAR",T=$O(^BWPN("B",T,0))
I T D I X]"" Q "Yes "_$$FMTE^XLFDT(X)
.S X=$$WH(P,BD,ED,T,3)
S G=0
S T=$O(^LAB(60,"B","PAP SMEAR",0))
I T,$$REFUSAL^APCLP817(P,60,T,BDATE,EDATE) Q "Refused"
S T=$O(^ATXLAB("B","BGP PAP SMEAR TAX",0))
I 'T Q "No"
S G=0
S X=0 F S X=$O(^ATXLAB(T,21,X)) Q:X'=+X!(G) I $$REFUSAL^APCLP817(P,60,$P(^ATXLAB(T,21,X,0),U),BDATE,EDATE) S G=1
Q $S(G:"Refused",1:"No")
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),"."))
Q ""
RAD(P,BDATE,EDATE,T,F) ;EP 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)="" 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(^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 $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
Q ""
EKG(P,EDATE,F) ;EP
I $G(F)="" S F="E"
S %DT="P",X=EDATE D ^%DT S ED=Y
NEW APCL,X,%,E,LEKG S LEKG="",%=P_"^LAST DIAGNOSTIC ECG SUMMARY;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I $D(APCL) S LEKG=$P(APCL(1),U)
K APCL S %=P_"^LAST PROCEDURE 89.51",E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) D
.Q:LEKG>$P(APCL(1),U)
.S LEKG=$P(APCL(1),U)
K APCL S %=P_"^LAST PROCEDURE 89.52",E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) D
.Q:LEKG>$P(APCL(1),U)
.S LEKG=$P(APCL(1),U)
K APCL S %=P_"^LAST PROCEDURE 89.53",E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) D
.Q:LEKG>$P(APCL(1),U)
.S LEKG=$P(APCL(1),U)
;check CPT codes in year prior to date range
S T=$O(^ATXAX("B","DM AUDIT EKG CPTS",0))
K APCL I T S APCL(1)=$$CPT^APCLP812(P,,ED,T,3) D
.I APCL(1)="" K APCL Q
.Q:LEKG>$P(APCL(1),U)
.S LEKG=$P(APCL(1),U)
K APCL I T S APCL(1)=$$RAD^APCLP812(P,,ED,T,3) D
.I APCL(1)="" K APCL Q
.Q:LEKG>$P(APCL(1),U)
.S LEKG=$P(APCL(1),U)
Q $S(F="E":$$FMTE^XLFDT(LEKG),1:LEKG)
;
ALT(P,BDATE,EDATE) ;EP
NEW APCL,X,%,E,R,V
K APCL
S %=P_"^LAST LAB [DM AUDIT ALT TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I '$D(APCL(1)) Q ""
S D=$P(APCL(1),U),D=$$FMTE^XLFDT(D) K APCL S %=P_"^ALL LAB [DM AUDIT ALT TAX;DURING "_D_"-"_D,E=$$START1^APCLDF(%,"APCL(")
NEW N D SETN
Q $P(^AUPNVLAB(+$P(APCL(N),U,4),0),U,4)_" "_$$FMTE^XLFDT($P(APCL(N),U),5)
AST(P,BDATE,EDATE) ;EP
NEW APCL,X,%,E,R,V
K APCL
S %=P_"^LAST LAB [DM AUDIT AST TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I '$D(APCL(1)) Q ""
S D=$P(APCL(1),U),D=$$FMTE^XLFDT(D) K APCL S %=P_"^ALL LAB [DM AUDIT AST TAX;DURING "_D_"-"_D,E=$$START1^APCLDF(%,"APCL(")
NEW N D SETN
Q $P(^AUPNVLAB(+$P(APCL(N),U,4),0),U,4)_" "_$$FMTE^XLFDT($P(APCL(N),U),5)
INSULIN(P,BDATE,EDATE) ;EP
NEW X,APCL,E
S X=P_"^LAST MEDS [DM AUDIT INSULIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) Q "X"
Q ""
;
SULF(P,BDATE,EDATE) ;EP
NEW X,APCL,E
S X=P_"^LAST MEDS [DM AUDIT SULFONYLUREA DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) Q "X"
Q ""
MET(P,BDATE,EDATE) ;EP
NEW X,APCL,E
S X=P_"^LAST MEDS [DM AUDIT METFORMIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) Q "X"
Q ""
;
ACAR(P,BDATE,EDATE) ;EP
NEW X,APCL,E
S X=P_"^LAST MEDS [DM AUDIT ACARBOSE DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) Q "X"
Q ""
;
TROG(P,BDATE,EDATE) ;EP
NEW X,APCL,E
S X=P_"^LAST MEDS [DM AUDIT GLITAZONE DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) Q "X"
Q ""
MAMMOG(P,BDATE,EDATE) ; EP
NEW X,%DT,ED,BD,G,Y,V
S %DT="P",X=EDATE D ^%DT S ED=Y
S %DT="P",X=BDATE D ^%DT S BD=Y
I $$SEX^AUPNPAT(P)'="F" Q "N/A - male"
I $$AGE^AUPNPAT(P,ED)<40 Q "N/A - under 40"
I '$G(P) Q ""
NEW LMAM S LMAM=""
I $G(^AUTTSITE(1,0)),$P(^AUTTLOC($P(^AUTTSITE(1,0),U),0),U,10)="353101" S LMAM=$$MAMMOG1(P,BDATE,EDATE)
NEW APCL
K APCL
S (X,Y,V)=0,G="" F S X=$O(^AUPNVRAD("AC",P,X)) Q:X'=+X!(G]"") D
.S V=$P(^AUPNVRAD(X,0),U,3),V=$P($P($G(^AUPNVSIT(V,0)),U),".")
.Q:V>EDATE
.Q:V<BDATE
.S Y=$P(^AUPNVRAD(X,0),U),Y=$P($G(^RAMIS(71,Y,0)),U,9)
.Q:Y=""
.;S Y=$P($G(^ICPT(Y,0)),U) ;cmi/anch/maw 9/12/2007 orig line
.S Y=$P($$CPT^ICPTCOD(Y),U,2) ;cmi/anch/maw 9/12/2007 csv
.I Y=76092 S APCL(9999999-V)=""
.I Y=76090 S APCL(9999999-V)="" Q
.I Y=76091 S APCL(9999999-V)="" Q
.Q
S LMAM=$O(APCL(0)) I LMAN]"" S LMAM=9999999-LMAM
K APCL S %=P_"^LAST DX V76.12;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) D
.Q:LMAM>$P(APCL(1),U)
.S LMAM=$P(APCL(1),U)
K APCL S %=P_"^LAST PROCEDURE 87.37;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) D
.Q:LMAM>$P(APCL(1),U)
.S LMAM=$P(APCL(1),U)
K APCL S %=P_"^LAST PROCEDURE 87.36;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) D
.Q:LMAM>$P(APCL(1),U)
.S LMAM=$P(APCL(1),U)
;check CPT codes in year prior to date range
S T=$O(^ATXAX("B","DM AUDIT MAMMOGRAM CPTS",0))
K APCL I T S APCL(1)=$$CPT^APCLP812(P,,ED,T,3) D
.I APCL(1)="" K APCL Q
.Q:LMAM>$P(APCL(1),U)
.S LMAM=$P(APCL(1),U)
Q $S(LMAM]"":"Yes "_$$FMTE^XLFDT(LMAM),1:"No")
;
MAMMOG1(P,BDATE,EDATE) ;for radiology 4.5+ or until qman can handle taxonomies for radiology procedures
NEW APCLMAM,CODE,COUNT,IEN,X
S CODE=$O(^DIC(40.7,"C",72,0)) I 'CODE Q "No <never recorded>"
S IEN=0 F S IEN=$O(^RAMIS(71,IEN)) Q:'IEN D
. Q:$G(^RAMIS(71,IEN,"I")) ;inactive
. Q:'$D(^RAMIS(71,IEN,"STOP","B",CODE)) ;no mamm stop code
. S COUNT=$G(COUNT)+1,APCLMAM(COUNT)=$P(^RAMIS(71,IEN,0),U)
;
; -- use data fetcher to find mammogram dates
NEW APCLY,APCLSAV,APCLX,APCLNAM
S (APCLSAV,APCLX)=0 F S APCLX=$O(APCLMAM(APCLX)) Q:'APCLX D
. S %=P_"^LAST RAD "_APCLMAM(APCLX)_";DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCLY(")
. ; save latest date and procedure name
. I $G(APCLY(1)),$P(APCLY(1),U)>APCLSAV S APCLSAV=$P(APCLY(1),U),APCLNAM=APCLMAM(APCLX)
;
; -- return results
I APCLSAV'=0 Q APCLSAV
;
Q ""
TXNAME(V) ;EP
I $G(V)="" Q ""
S V=$$TXNAMES(V)
Q $E(V,1,16)
TXNAMES(Y) ;
I Y=1 Q "DIET"
I Y=2 Q "INSULIN"
I Y=3 Q "SULFONYLUREA"
I Y=4 Q "METFORMIN (GLUCOPHAGE)"
I Y=5 Q "ACARBOSE OR MIGLITOL"
I Y=6 Q "GLITAZONE"
I Y=9 Q "UNKNOWN/REFUSED"
I Y=23 Q "INSULIN+S'UREA"
I Y=24 Q "INSULIN+MET"
I Y=25 Q "INSULIN+ACAR"
I Y=26 Q "INSULIN+GLITAZONE"
I Y=34 Q "S'UREA+MET"
I Y=35 Q "S'UREA+ACAR"
I Y=36 Q "S'UREA+GLITAZONE"
I Y=45 Q "MET+ACAR"
I Y=46 Q "MET+GLITAZONE"
I Y=56 Q "ACAR+GLITAZONE"
I Y=234 Q "INS+S'UREA+MET"
I Y=235 Q "INS+S'UREA+ACAR"
I Y=236 Q "INS+S'UREA+GLIT"
I Y=245 Q "INS+MET+ACAR"
I Y=246 Q "INS+MET+GLITAZONE"
I Y=256 Q "INS+ACAR+GLITAZONE"
I Y=345 Q "S'UREA+MET+ACAR"
I Y=346 Q "S'UREA+MET+GLIT"
I Y=356 Q "S'UREA+ACAR+GLIT"
I Y=456 Q "MET+ACAR+GLIT"
Q ""
;
HYSTER(P,EDATE) ;EP
I '$G(P) Q ""
;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 9/12/2007 orig line
S (F,S)=0 F S F=$O(^AUPNVPRC("AC",P,F)) Q:F'=+F!(S) S C=$P($$ICDOP^ICDCODE(+^AUPNVPRC(F,0)),U,2) D ;cmi/anch/maw 9/12/2007 csv
.S G=0 S:(C=68.4)!(C=68.5)!(C=68.6)!(C=68.7)!(C=68.9) G=1
.Q:G=0
.S D=$P(^AUPNVPRC(F,0),U,6) I D="" S D=$P($P(^AUPNVSIT($P(^AUPNVPRC(F,0),U,3),0),U),".")
.I D>EDATE Q
.S S=1
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),EDATE,T,2)
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),EDATE,T,3)
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 ""
LOINC(A,B) ;
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
APCLP812 ; IHS/CMI/LAB - 2003 DIABETES AUDIT ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;cmi/anch/maw 9/10/2007 code set versioning in HYSTER,MAMMOG
+4 ;
SETN ;
+1 SET N=""
NEW A,G
SET (A,G)=0
FOR
SET A=$ORDER(APCL(A))
IF A'=+A!(G)
QUIT
IF $PIECE(^AUPNVLAB(+$PIECE(APCL(A),U,4),0),U,4)]""
SET G=A
+2 SET N=$SELECT(G:G,1:1)
+3 QUIT
TBTX(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW APCL,E,X
+3 KILL APCL
+4 SET X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS"
SET E=$$START1^APCLDF(X,"APCL(")
+5 IF E
QUIT ""
+6 IF $DATA(APCL(1))
QUIT $PIECE(APCL(1),U,3)_U_$SELECT($PIECE(APCL(1),U,3)["TX COMPLETE":"1 Yes",$PIECE(APCL(1),U,3)["TX INCOMPLETE"!($PIECE(APCL(1),U,3)["TX UNTREATED"):"2 No",1:"4 Unknown")
+7 NEW T,Y
SET T=$ORDER(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
+8 IF 'T
QUIT ""
+9 NEW G
SET G=""
SET X=0
FOR
SET X=$ORDER(^AUPNHF("AA",P,X))
IF X'=+X!(G]"")
QUIT
IF $DATA(^ATXAX(T,21,"B",X))
SET G=$PIECE(^AUTTHF(X,0),U)
+10 IF G]""
QUIT G_U_$SELECT(G["TX COMPLETE":"1 Yes",G["TX INCOMPLETE"!(G["TX UNTREATED"):"2 No",1:"4 Unknown")
+11 QUIT ""
PAP(P,BDATE,EDATE) ; EP
+1 NEW X,%DT,ED,%,APCLLTX,APCLLTAX,APCLC
+2 SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+3 SET %DT="P"
SET X=BDATE
DO ^%DT
SET BD=Y
+4 IF $$SEX^AUPNPAT(P)'="F"
QUIT "N/A - male"
+5 IF $$AGE^AUPNPAT(P,ED)<18
QUIT "N/A - under 18"
+6 IF $$HYSTER(P,EDATE)
QUIT "N/A - Patient had hysterectomy"
+7 NEW APCL
SET %=P_"^LAST LAB PAP SMEAR;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+8 IF $DATA(APCL(1))
QUIT "Yes "_$$FMTE^XLFDT($PIECE(APCL(1),U))
+9 SET APCLLTX=$ORDER(^ATXAX("B","BGP PAP LOINC CODES",0))
+10 SET APCLLTAX=$ORDER(^ATXLAB("B","BGP PAP SMEAR TAX",0))
+11 SET APCLC=""
SET B=9999999-BD
SET E=9999999-ED
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(APCLC]"")
QUIT
Begin DoDot:1
+12 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(APCLC]"")
QUIT
Begin DoDot:2
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(APCLC]"")
QUIT
Begin DoDot:3
+14 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+15 SET Z=$PIECE(^AUPNVLAB(X,0),U)
SET Z=$PIECE($GET(^LAB(60,Z,0)),U)
IF Z="PAP SMEAR"
SET APCLC="Yes "_$$FMTE^XLFDT((9999999-D))
QUIT
+16 IF APCLLTAX
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(APCLLTAX,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET APCLC="Yes "_$$FMTE^XLFDT((9999999-D))
QUIT
+17 IF 'T
QUIT
+18 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+19 IF '$$LOINC(J,APCLLTX)
QUIT
+20 SET APCLC="Yes "_$$FMTE^XLFDT((9999999-D))
QUIT
+21 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+22 IF APCLC]""
QUIT APCLC
+23 KILL APCL
SET %=P_"^LAST DX V76.2;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+24 IF $DATA(APCL(1))
QUIT "Yes "_$$FMTE^XLFDT($PIECE(APCL(1),U))
+25 ;K APCL S %=P_"^LAST DX V72.3;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
+26 ;I $D(APCL(1)) Q "Yes "_$$FMTE^XLFDT($P(APCL(1),U))
+27 KILL APCL
SET %=P_"^LAST PROCEDURE 91.46;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+28 IF $DATA(APCL(1))
QUIT "Yes "_$$FMTE^XLFDT($PIECE(APCL(1),U))
+29 ;check CPT codes in year prior to date range
+30 SET T=$ORDER(^ATXAX("B","BGP PAP CPTS",0))
+31 KILL APCL
IF T
SET APCL(1)=$$CPT(P,,ED,T,4)
IF $GET(APCL(1))]""
QUIT "Yes "_APCL(1)
+32 ;check WH
+33 SET T="PAP SMEAR"
SET T=$ORDER(^BWPN("B",T,0))
+34 IF T
Begin DoDot:1
+35 SET X=$$WH(P,BD,ED,T,3)
End DoDot:1
IF X]""
QUIT "Yes "_$$FMTE^XLFDT(X)
+36 SET G=0
+37 SET T=$ORDER(^LAB(60,"B","PAP SMEAR",0))
+38 IF T
IF $$REFUSAL^APCLP817(P,60,T,BDATE,EDATE)
QUIT "Refused"
+39 SET T=$ORDER(^ATXLAB("B","BGP PAP SMEAR TAX",0))
+40 IF 'T
QUIT "No"
+41 SET G=0
+42 SET X=0
FOR
SET X=$ORDER(^ATXLAB(T,21,X))
IF X'=+X!(G)
QUIT
IF $$REFUSAL^APCLP817(P,60,$PIECE(^ATXLAB(T,21,X,0),U),BDATE,EDATE)
SET G=1
+43 QUIT $SELECT(G:"Refused",1:"No")
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 QUIT ""
RAD(P,BDATE,EDATE,T,F) ;EP 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)=""
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(^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 $$FMTE^XLFDT($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+27 QUIT ""
EKG(P,EDATE,F) ;EP
+1 IF $GET(F)=""
SET F="E"
+2 SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+3 NEW APCL,X,%,E,LEKG
SET LEKG=""
SET %=P_"^LAST DIAGNOSTIC ECG SUMMARY;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+4 IF $DATA(APCL)
SET LEKG=$PIECE(APCL(1),U)
+5 KILL APCL
SET %=P_"^LAST PROCEDURE 89.51"
SET E=$$START1^APCLDF(%,"APCL(")
+6 IF $DATA(APCL(1))
Begin DoDot:1
+7 IF LEKG>$PIECE(APCL(1),U)
QUIT
+8 SET LEKG=$PIECE(APCL(1),U)
End DoDot:1
+9 KILL APCL
SET %=P_"^LAST PROCEDURE 89.52"
SET E=$$START1^APCLDF(%,"APCL(")
+10 IF $DATA(APCL(1))
Begin DoDot:1
+11 IF LEKG>$PIECE(APCL(1),U)
QUIT
+12 SET LEKG=$PIECE(APCL(1),U)
End DoDot:1
+13 KILL APCL
SET %=P_"^LAST PROCEDURE 89.53"
SET E=$$START1^APCLDF(%,"APCL(")
+14 IF $DATA(APCL(1))
Begin DoDot:1
+15 IF LEKG>$PIECE(APCL(1),U)
QUIT
+16 SET LEKG=$PIECE(APCL(1),U)
End DoDot:1
+17 ;check CPT codes in year prior to date range
+18 SET T=$ORDER(^ATXAX("B","DM AUDIT EKG CPTS",0))
+19 KILL APCL
IF T
SET APCL(1)=$$CPT^APCLP812(P,,ED,T,3)
Begin DoDot:1
+20 IF APCL(1)=""
KILL APCL
QUIT
+21 IF LEKG>$PIECE(APCL(1),U)
QUIT
+22 SET LEKG=$PIECE(APCL(1),U)
End DoDot:1
+23 KILL APCL
IF T
SET APCL(1)=$$RAD^APCLP812(P,,ED,T,3)
Begin DoDot:1
+24 IF APCL(1)=""
KILL APCL
QUIT
+25 IF LEKG>$PIECE(APCL(1),U)
QUIT
+26 SET LEKG=$PIECE(APCL(1),U)
End DoDot:1
+27 QUIT $SELECT(F="E":$$FMTE^XLFDT(LEKG),1:LEKG)
+28 ;
ALT(P,BDATE,EDATE) ;EP
+1 NEW APCL,X,%,E,R,V
+2 KILL APCL
+3 SET %=P_"^LAST LAB [DM AUDIT ALT TAX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+4 IF '$DATA(APCL(1))
QUIT ""
+5 SET D=$PIECE(APCL(1),U)
SET D=$$FMTE^XLFDT(D)
KILL APCL
SET %=P_"^ALL LAB [DM AUDIT ALT TAX;DURING "_D_"-"_D
SET E=$$START1^APCLDF(%,"APCL(")
+6 NEW N
DO SETN
+7 QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(N),U,4),0),U,4)_" "_$$FMTE^XLFDT($PIECE(APCL(N),U),5)
AST(P,BDATE,EDATE) ;EP
+1 NEW APCL,X,%,E,R,V
+2 KILL APCL
+3 SET %=P_"^LAST LAB [DM AUDIT AST TAX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+4 IF '$DATA(APCL(1))
QUIT ""
+5 SET D=$PIECE(APCL(1),U)
SET D=$$FMTE^XLFDT(D)
KILL APCL
SET %=P_"^ALL LAB [DM AUDIT AST TAX;DURING "_D_"-"_D
SET E=$$START1^APCLDF(%,"APCL(")
+6 NEW N
DO SETN
+7 QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(N),U,4),0),U,4)_" "_$$FMTE^XLFDT($PIECE(APCL(N),U),5)
INSULIN(P,BDATE,EDATE) ;EP
+1 NEW X,APCL,E
+2 SET X=P_"^LAST MEDS [DM AUDIT INSULIN DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+3 IF $DATA(APCL(1))
QUIT "X"
+4 QUIT ""
+5 ;
SULF(P,BDATE,EDATE) ;EP
+1 NEW X,APCL,E
+2 SET X=P_"^LAST MEDS [DM AUDIT SULFONYLUREA DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+3 IF $DATA(APCL(1))
QUIT "X"
+4 QUIT ""
MET(P,BDATE,EDATE) ;EP
+1 NEW X,APCL,E
+2 SET X=P_"^LAST MEDS [DM AUDIT METFORMIN DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+3 IF $DATA(APCL(1))
QUIT "X"
+4 QUIT ""
+5 ;
ACAR(P,BDATE,EDATE) ;EP
+1 NEW X,APCL,E
+2 SET X=P_"^LAST MEDS [DM AUDIT ACARBOSE DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+3 IF $DATA(APCL(1))
QUIT "X"
+4 QUIT ""
+5 ;
TROG(P,BDATE,EDATE) ;EP
+1 NEW X,APCL,E
+2 SET X=P_"^LAST MEDS [DM AUDIT GLITAZONE DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+3 IF $DATA(APCL(1))
QUIT "X"
+4 QUIT ""
MAMMOG(P,BDATE,EDATE) ; EP
+1 NEW X,%DT,ED,BD,G,Y,V
+2 SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+3 SET %DT="P"
SET X=BDATE
DO ^%DT
SET BD=Y
+4 IF $$SEX^AUPNPAT(P)'="F"
QUIT "N/A - male"
+5 IF $$AGE^AUPNPAT(P,ED)<40
QUIT "N/A - under 40"
+6 IF '$GET(P)
QUIT ""
+7 NEW LMAM
SET LMAM=""
+8 IF $GET(^AUTTSITE(1,0))
IF $PIECE(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0),U,10)="353101"
SET LMAM=$$MAMMOG1(P,BDATE,EDATE)
+9 NEW APCL
+10 KILL APCL
+11 SET (X,Y,V)=0
SET G=""
FOR
SET X=$ORDER(^AUPNVRAD("AC",P,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+12 SET V=$PIECE(^AUPNVRAD(X,0),U,3)
SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+13 IF V>EDATE
QUIT
+14 IF V<BDATE
QUIT
+15 SET Y=$PIECE(^AUPNVRAD(X,0),U)
SET Y=$PIECE($GET(^RAMIS(71,Y,0)),U,9)
+16 IF Y=""
QUIT
+17 ;S Y=$P($G(^ICPT(Y,0)),U) ;cmi/anch/maw 9/12/2007 orig line
+18 ;cmi/anch/maw 9/12/2007 csv
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
+19 IF Y=76092
SET APCL(9999999-V)=""
+20 IF Y=76090
SET APCL(9999999-V)=""
QUIT
+21 IF Y=76091
SET APCL(9999999-V)=""
QUIT
+22 QUIT
End DoDot:1
+23 SET LMAM=$ORDER(APCL(0))
IF LMAN]""
SET LMAM=9999999-LMAM
+24 KILL APCL
SET %=P_"^LAST DX V76.12;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+25 IF $DATA(APCL(1))
Begin DoDot:1
+26 IF LMAM>$PIECE(APCL(1),U)
QUIT
+27 SET LMAM=$PIECE(APCL(1),U)
End DoDot:1
+28 KILL APCL
SET %=P_"^LAST PROCEDURE 87.37;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+29 IF $DATA(APCL(1))
Begin DoDot:1
+30 IF LMAM>$PIECE(APCL(1),U)
QUIT
+31 SET LMAM=$PIECE(APCL(1),U)
End DoDot:1
+32 KILL APCL
SET %=P_"^LAST PROCEDURE 87.36;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+33 IF $DATA(APCL(1))
Begin DoDot:1
+34 IF LMAM>$PIECE(APCL(1),U)
QUIT
+35 SET LMAM=$PIECE(APCL(1),U)
End DoDot:1
+36 ;check CPT codes in year prior to date range
+37 SET T=$ORDER(^ATXAX("B","DM AUDIT MAMMOGRAM CPTS",0))
+38 KILL APCL
IF T
SET APCL(1)=$$CPT^APCLP812(P,,ED,T,3)
Begin DoDot:1
+39 IF APCL(1)=""
KILL APCL
QUIT
+40 IF LMAM>$PIECE(APCL(1),U)
QUIT
+41 SET LMAM=$PIECE(APCL(1),U)
End DoDot:1
+42 QUIT $SELECT(LMAM]"":"Yes "_$$FMTE^XLFDT(LMAM),1:"No")
+43 ;
MAMMOG1(P,BDATE,EDATE) ;for radiology 4.5+ or until qman can handle taxonomies for radiology procedures
+1 NEW APCLMAM,CODE,COUNT,IEN,X
+2 SET CODE=$ORDER(^DIC(40.7,"C",72,0))
IF 'CODE
QUIT "No <never recorded>"
+3 SET IEN=0
FOR
SET IEN=$ORDER(^RAMIS(71,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+4 ;inactive
IF $GET(^RAMIS(71,IEN,"I"))
QUIT
+5 ;no mamm stop code
IF '$DATA(^RAMIS(71,IEN,"STOP","B",CODE))
QUIT
+6 SET COUNT=$GET(COUNT)+1
SET APCLMAM(COUNT)=$PIECE(^RAMIS(71,IEN,0),U)
End DoDot:1
+7 ;
+8 ; -- use data fetcher to find mammogram dates
+9 NEW APCLY,APCLSAV,APCLX,APCLNAM
+10 SET (APCLSAV,APCLX)=0
FOR
SET APCLX=$ORDER(APCLMAM(APCLX))
IF 'APCLX
QUIT
Begin DoDot:1
+11 SET %=P_"^LAST RAD "_APCLMAM(APCLX)_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCLY(")
+12 ; save latest date and procedure name
+13 IF $GET(APCLY(1))
IF $PIECE(APCLY(1),U)>APCLSAV
SET APCLSAV=$PIECE(APCLY(1),U)
SET APCLNAM=APCLMAM(APCLX)
End DoDot:1
+14 ;
+15 ; -- return results
+16 IF APCLSAV'=0
QUIT APCLSAV
+17 ;
+18 QUIT ""
TXNAME(V) ;EP
+1 IF $GET(V)=""
QUIT ""
+2 SET V=$$TXNAMES(V)
+3 QUIT $EXTRACT(V,1,16)
TXNAMES(Y) ;
+1 IF Y=1
QUIT "DIET"
+2 IF Y=2
QUIT "INSULIN"
+3 IF Y=3
QUIT "SULFONYLUREA"
+4 IF Y=4
QUIT "METFORMIN (GLUCOPHAGE)"
+5 IF Y=5
QUIT "ACARBOSE OR MIGLITOL"
+6 IF Y=6
QUIT "GLITAZONE"
+7 IF Y=9
QUIT "UNKNOWN/REFUSED"
+8 IF Y=23
QUIT "INSULIN+S'UREA"
+9 IF Y=24
QUIT "INSULIN+MET"
+10 IF Y=25
QUIT "INSULIN+ACAR"
+11 IF Y=26
QUIT "INSULIN+GLITAZONE"
+12 IF Y=34
QUIT "S'UREA+MET"
+13 IF Y=35
QUIT "S'UREA+ACAR"
+14 IF Y=36
QUIT "S'UREA+GLITAZONE"
+15 IF Y=45
QUIT "MET+ACAR"
+16 IF Y=46
QUIT "MET+GLITAZONE"
+17 IF Y=56
QUIT "ACAR+GLITAZONE"
+18 IF Y=234
QUIT "INS+S'UREA+MET"
+19 IF Y=235
QUIT "INS+S'UREA+ACAR"
+20 IF Y=236
QUIT "INS+S'UREA+GLIT"
+21 IF Y=245
QUIT "INS+MET+ACAR"
+22 IF Y=246
QUIT "INS+MET+GLITAZONE"
+23 IF Y=256
QUIT "INS+ACAR+GLITAZONE"
+24 IF Y=345
QUIT "S'UREA+MET+ACAR"
+25 IF Y=346
QUIT "S'UREA+MET+GLIT"
+26 IF Y=356
QUIT "S'UREA+ACAR+GLIT"
+27 IF Y=456
QUIT "MET+ACAR+GLIT"
+28 QUIT ""
+29 ;
HYSTER(P,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;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 9/12/2007 orig line
+3 ;cmi/anch/maw 9/12/2007 csv
SET (F,S)=0
FOR
SET F=$ORDER(^AUPNVPRC("AC",P,F))
IF F'=+F!(S)
QUIT
SET C=$PIECE($$ICDOP^ICDCODE(+^AUPNVPRC(F,0)),U,2)
Begin DoDot:1
+4 SET G=0
IF (C=68.4)!(C=68.5)!(C=68.6)!(C=68.7)!(C=68.9)
SET G=1
+5 IF G=0
QUIT
+6 SET D=$PIECE(^AUPNVPRC(F,0),U,6)
IF D=""
SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),U),".")
+7 IF D>EDATE
QUIT
+8 SET S=1
End DoDot:1
+9 IF S=1
QUIT 1
+10 SET T="HYSTERECTOMY"
SET T=$ORDER(^BWPN("B",T,0))
+11 IF T
Begin DoDot:1
+12 SET X=$$WH(P,$$DOB^AUPNPAT(P),EDATE,T,2)
End DoDot:1
IF X]""
QUIT 1
+13 SET T=$ORDER(^ATXAX("B","BGP HYSTERECTOMY CPTS",0))
+14 IF T
Begin DoDot:1
+15 SET X=$$CPT(P,$PIECE(^DPT(P,0),U,3),EDATE,T,3)
End DoDot:1
IF X]""
QUIT 1
+16 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 ""
LOINC(A,B) ;
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
