- 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 ;
