APCLD202 ; IHS/CMI/LAB - 2000 DIABETES AUDIT ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
SETN ;set N = to v lab to use
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,%
S %DT="P",X=EDATE D ^%DT S ED=Y
I $$SEX^AUPNPAT(P)'="F" Q "N/A - male"
I $$AGE^AUPNPAT(P,ED)<18 Q "N/A - under 18"
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))
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","DM AUDIT PAP CPTS",0))
K APCL I T S APCL(1)=$$CPT^APCLD202(P,,ED,T,4) I $G(APCL(1))]"" Q "Yes "_APCL(1)
NEW G S G=0
NEW T S T=$O(^LAB(60,"B","PAP SMEAR",0))
I 'T Q ""
S X=0 F S X=$O(^ATXLAB(T,21,X)) Q:X'=+X!(G) I $$REFUSAL^APCLD207(P,60,$P(^ATXLAB(T,21,X,0),U),BDATE,EDATE) S G=1
Q $S(G:"Refused",1:"No")
Q "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 ""
EKG(P,EDATE,F) ;EP
I $G(F)="" S F="E"
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)
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
S %DT="P",X=EDATE D ^%DT S ED=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 S %=P_"^LAST RAD 76091;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 RAD 76092;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 RAD 76090;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 DX V76.11;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 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^APCLD202(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
;
;IHS/ANMC/LJF 8/26/99 new code to look for all mammograms no matter
; how they are spelled in file 71 - for Rad version 4.5+
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
;IHS/ANMC/LJF 8/26/99 end of new code
;
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 ""
;
APCLD202 ; IHS/CMI/LAB - 2000 DIABETES AUDIT ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
SETN ;set N = to v lab to use
+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,%
+2 SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+3 IF $$SEX^AUPNPAT(P)'="F"
QUIT "N/A - male"
+4 IF $$AGE^AUPNPAT(P,ED)<18
QUIT "N/A - under 18"
+5 NEW APCL
SET %=P_"^LAST LAB PAP SMEAR;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+6 IF $DATA(APCL(1))
QUIT "Yes "_$$FMTE^XLFDT($PIECE(APCL(1),U))
+7 KILL APCL
SET %=P_"^LAST DX V76.2;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+8 IF $DATA(APCL(1))
QUIT "Yes "_$$FMTE^XLFDT($PIECE(APCL(1),U))
+9 KILL APCL
SET %=P_"^LAST DX V72.3;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+10 IF $DATA(APCL(1))
QUIT "Yes "_$$FMTE^XLFDT($PIECE(APCL(1),U))
+11 KILL APCL
SET %=P_"^LAST PROCEDURE 91.46;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+12 IF $DATA(APCL(1))
QUIT "Yes "_$$FMTE^XLFDT($PIECE(APCL(1),U))
+13 ;check CPT codes in year prior to date range
+14 SET T=$ORDER(^ATXAX("B","DM AUDIT PAP CPTS",0))
+15 KILL APCL
IF T
SET APCL(1)=$$CPT^APCLD202(P,,ED,T,4)
IF $GET(APCL(1))]""
QUIT "Yes "_APCL(1)
+16 NEW G
SET G=0
+17 NEW T
SET T=$ORDER(^LAB(60,"B","PAP SMEAR",0))
+18 IF 'T
QUIT ""
+19 SET X=0
FOR
SET X=$ORDER(^ATXLAB(T,21,X))
IF X'=+X!(G)
QUIT
IF $$REFUSAL^APCLD207(P,60,$PIECE(^ATXLAB(T,21,X,0),U),BDATE,EDATE)
SET G=1
+20 QUIT $SELECT(G:"Refused",1:"No")
+21 QUIT "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 ""
EKG(P,EDATE,F) ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW APCL,X,%,E,LEKG
SET LEKG=""
SET %=P_"^LAST DIAGNOSTIC ECG SUMMARY;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+3 IF $DATA(APCL)
SET LEKG=$PIECE(APCL(1),U)
+4 KILL APCL
SET %=P_"^LAST PROCEDURE 89.51"
SET E=$$START1^APCLDF(%,"APCL(")
+5 IF $DATA(APCL(1))
Begin DoDot:1
+6 IF LEKG>$PIECE(APCL(1),U)
QUIT
+7 SET LEKG=$PIECE(APCL(1),U)
End DoDot:1
+8 KILL APCL
SET %=P_"^LAST PROCEDURE 89.52"
SET E=$$START1^APCLDF(%,"APCL(")
+9 IF $DATA(APCL(1))
Begin DoDot:1
+10 IF LEKG>$PIECE(APCL(1),U)
QUIT
+11 SET LEKG=$PIECE(APCL(1),U)
End DoDot:1
+12 KILL APCL
SET %=P_"^LAST PROCEDURE 89.53"
SET E=$$START1^APCLDF(%,"APCL(")
+13 IF $DATA(APCL(1))
Begin DoDot:1
+14 IF LEKG>$PIECE(APCL(1),U)
QUIT
+15 SET LEKG=$PIECE(APCL(1),U)
End DoDot:1
+16 QUIT $SELECT(F="E":$$FMTE^XLFDT(LEKG),1:LEKG)
+17 ;
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 ""
+5 ;
+6 ;
MAMMOG(P,BDATE,EDATE) ; EP
+1 NEW X,%DT,ED
+2 SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+3 IF $$SEX^AUPNPAT(P)'="F"
QUIT "N/A - male"
+4 IF $$AGE^AUPNPAT(P,ED)<40
QUIT "N/A - under 40"
+5 IF '$GET(P)
QUIT ""
+6 NEW LMAM
SET LMAM=""
+7 IF $GET(^AUTTSITE(1,0))
IF $PIECE(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0),U,10)="353101"
SET LMAM=$$MAMMOG1(P,BDATE,EDATE)
+8 NEW APCL
SET %=P_"^LAST RAD 76091;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+9 IF $DATA(APCL(1))
Begin DoDot:1
+10 IF LMAM>$PIECE(APCL(1),U)
QUIT
+11 SET LMAM=$PIECE(APCL(1),U)
End DoDot:1
+12 KILL APCL
SET %=P_"^LAST RAD 76092;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+13 IF $DATA(APCL(1))
Begin DoDot:1
+14 IF LMAM>$PIECE(APCL(1),U)
QUIT
+15 SET LMAM=$PIECE(APCL(1),U)
End DoDot:1
+16 KILL APCL
SET %=P_"^LAST RAD 76090;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+17 IF $DATA(APCL(1))
Begin DoDot:1
+18 IF LMAM>$PIECE(APCL(1),U)
QUIT
+19 SET LMAM=$PIECE(APCL(1),U)
End DoDot:1
+20 KILL APCL
SET %=P_"^LAST DX V76.11;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+21 IF $DATA(APCL(1))
Begin DoDot:1
+22 IF LMAM>$PIECE(APCL(1),U)
QUIT
+23 SET LMAM=$PIECE(APCL(1),U)
End DoDot:1
+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^APCLD202(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 ;
+2 ;IHS/ANMC/LJF 8/26/99 new code to look for all mammograms no matter
+3 ; how they are spelled in file 71 - for Rad version 4.5+
+4 NEW APCLMAM,CODE,COUNT,IEN,X
+5 SET CODE=$ORDER(^DIC(40.7,"C",72,0))
IF 'CODE
QUIT "No <never recorded>"
+6 SET IEN=0
FOR
SET IEN=$ORDER(^RAMIS(71,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+7 ;inactive
IF $GET(^RAMIS(71,IEN,"I"))
QUIT
+8 ;no mamm stop code
IF '$DATA(^RAMIS(71,IEN,"STOP","B",CODE))
QUIT
+9 SET COUNT=$GET(COUNT)+1
SET APCLMAM(COUNT)=$PIECE(^RAMIS(71,IEN,0),U)
End DoDot:1
+10 ;
+11 ; -- use data fetcher to find mammogram dates
+12 NEW APCLY,APCLSAV,APCLX,APCLNAM
+13 SET (APCLSAV,APCLX)=0
FOR
SET APCLX=$ORDER(APCLMAM(APCLX))
IF 'APCLX
QUIT
Begin DoDot:1
+14 SET %=P_"^LAST RAD "_APCLMAM(APCLX)_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCLY(")
+15 ; save latest date and procedure name
+16 IF $GET(APCLY(1))
IF $PIECE(APCLY(1),U)>APCLSAV
SET APCLSAV=$PIECE(APCLY(1),U)
SET APCLNAM=APCLMAM(APCLX)
End DoDot:1
+17 ;
+18 ; -- return results
+19 IF APCLSAV'=0
QUIT APCLSAV
+20 ;IHS/ANMC/LJF 8/26/99 end of new code
+21 ;
+22 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 ;
