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