APCLD992 ; IHS/CMI/LAB - 1999 DIABETES AUDIT ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
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 APCL S %=P_"^LAST RAD MAMMOGRAM BILAT;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 SCREENING MAMMOGRAM;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)
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 ""
;
APCLD992 ; IHS/CMI/LAB - 1999 DIABETES AUDIT ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
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 APCL
SET %=P_"^LAST RAD MAMMOGRAM BILAT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+6 IF $DATA(APCL(1))
Begin DoDot:1
+7 IF LMAM>$PIECE(APCL(1),U)
QUIT
+8 SET LMAM=$PIECE(APCL(1),U)
End DoDot:1
+9 KILL APCL
SET %=P_"^LAST RAD SCREENING MAMMOGRAM;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+10 IF $DATA(APCL(1))
Begin DoDot:1
+11 IF LMAM>$PIECE(APCL(1),U)
QUIT
+12 SET LMAM=$PIECE(APCL(1),U)
End DoDot:1
+13 KILL APCL
SET %=P_"^LAST DX V76.11;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+14 IF $DATA(APCL(1))
Begin DoDot:1
+15 IF LMAM>$PIECE(APCL(1),U)
QUIT
+16 SET LMAM=$PIECE(APCL(1),U)
End DoDot:1
+17 KILL APCL
SET %=P_"^LAST DX V76.12;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+18 IF $DATA(APCL(1))
Begin DoDot:1
+19 IF LMAM>$PIECE(APCL(1),U)
QUIT
+20 SET LMAM=$PIECE(APCL(1),U)
End DoDot:1
+21 KILL APCL
SET %=P_"^LAST PROCEDURE 87.37;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+22 IF $DATA(APCL(1))
Begin DoDot:1
+23 IF LMAM>$PIECE(APCL(1),U)
QUIT
+24 SET LMAM=$PIECE(APCL(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 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 ""
+23 ;
