BDMD992 ; IHS/CMI/LAB - 1999 DIABETES AUDIT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
MAMMOG(P,BDATE,EDATE) ; EP
I $$SEX^AUPNPAT(P)'="F" Q "N/A"
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 BDM S %=P_"^LAST RAD MAMMOGRAM BILAT;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
I $D(BDM(1)) D
.Q:LMAM>$P(BDM(1),U)
.S LMAM=$P(BDM(1),U)
K BDM S %=P_"^LAST RAD SCREENING MAMMOGRAM;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
I $D(BDM(1)) D
.Q:LMAM>$P(BDM(1),U)
.S LMAM=$P(BDM(1),U)
K BDM S %=P_"^LAST DX V76.11;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
I $D(BDM(1)) D
.Q:LMAM>$P(BDM(1),U)
.S LMAM=$P(BDM(1),U)
K BDM S %=P_"^LAST DX V76.12;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
I $D(BDM(1)) D
.Q:LMAM>$P(BDM(1),U)
.S LMAM=$P(BDM(1),U)
K BDM S %=P_"^LAST PROCEDURE 87.37;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
I $D(BDM(1)) D
.Q:LMAM>$P(BDM(1),U)
.S LMAM=$P(BDM(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 BDMMAM,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,BDMMAM(COUNT)=$P(^RAMIS(71,IEN,0),U)
;
; -- use data fetcher to find mammogram dates
NEW BDMY,BDMSAV,BDMX,BDMNAM
S (BDMSAV,BDMX)=0 F S BDMX=$O(BDMMAM(BDMX)) Q:'BDMX D
. S %=P_"^LAST RAD "_BDMMAM(BDMX)_";DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDMY(")
. ; save latest date and procedure name
. I $G(BDMY(1)),$P(BDMY(1),U)>BDMSAV S BDMSAV=$P(BDMY(1),U),BDMNAM=BDMMAM(BDMX)
;
; -- return results
I BDMSAV'=0 Q BDMSAV
;IHS/ANMC/LJF 8/26/99 end of new code
;
Q ""
;
BDMD992 ; IHS/CMI/LAB - 1999 DIABETES AUDIT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
MAMMOG(P,BDATE,EDATE) ; EP
+1 IF $$SEX^AUPNPAT(P)'="F"
QUIT "N/A"
+2 IF '$GET(P)
QUIT ""
+3 NEW LMAM
SET LMAM=""
+4 IF $GET(^AUTTSITE(1,0))
IF $PIECE(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0),U,10)="353101"
SET LMAM=$$MAMMOG1(P,BDATE,EDATE)
+5 NEW BDM
SET %=P_"^LAST RAD MAMMOGRAM BILAT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
+6 IF $DATA(BDM(1))
Begin DoDot:1
+7 IF LMAM>$PIECE(BDM(1),U)
QUIT
+8 SET LMAM=$PIECE(BDM(1),U)
End DoDot:1
+9 KILL BDM
SET %=P_"^LAST RAD SCREENING MAMMOGRAM;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
+10 IF $DATA(BDM(1))
Begin DoDot:1
+11 IF LMAM>$PIECE(BDM(1),U)
QUIT
+12 SET LMAM=$PIECE(BDM(1),U)
End DoDot:1
+13 KILL BDM
SET %=P_"^LAST DX V76.11;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
+14 IF $DATA(BDM(1))
Begin DoDot:1
+15 IF LMAM>$PIECE(BDM(1),U)
QUIT
+16 SET LMAM=$PIECE(BDM(1),U)
End DoDot:1
+17 KILL BDM
SET %=P_"^LAST DX V76.12;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
+18 IF $DATA(BDM(1))
Begin DoDot:1
+19 IF LMAM>$PIECE(BDM(1),U)
QUIT
+20 SET LMAM=$PIECE(BDM(1),U)
End DoDot:1
+21 KILL BDM
SET %=P_"^LAST PROCEDURE 87.37;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
+22 IF $DATA(BDM(1))
Begin DoDot:1
+23 IF LMAM>$PIECE(BDM(1),U)
QUIT
+24 SET LMAM=$PIECE(BDM(1),U)
End DoDot:1
+25 QUIT $SELECT(LMAM]"":"Yes "_$$FMTE^XLFDT(LMAM),1:"No")
+26 ;
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 BDMMAM,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 BDMMAM(COUNT)=$PIECE(^RAMIS(71,IEN,0),U)
End DoDot:1
+10 ;
+11 ; -- use data fetcher to find mammogram dates
+12 NEW BDMY,BDMSAV,BDMX,BDMNAM
+13 SET (BDMSAV,BDMX)=0
FOR
SET BDMX=$ORDER(BDMMAM(BDMX))
IF 'BDMX
QUIT
Begin DoDot:1
+14 SET %=P_"^LAST RAD "_BDMMAM(BDMX)_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDMY(")
+15 ; save latest date and procedure name
+16 IF $GET(BDMY(1))
IF $PIECE(BDMY(1),U)>BDMSAV
SET BDMSAV=$PIECE(BDMY(1),U)
SET BDMNAM=BDMMAM(BDMX)
End DoDot:1
+17 ;
+18 ; -- return results
+19 IF BDMSAV'=0
QUIT BDMSAV
+20 ;IHS/ANMC/LJF 8/26/99 end of new code
+21 ;
+22 QUIT ""
+23 ;
