- BGPD6 ; IHS/CMI/LAB - indicator 6 ;
- ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
- ;
- I6 ;EP ;EP - indicator 6
- ;Q:'$D(BGPIND(15))
- Q:$P(^DPT(DFN,0),U,2)'="F"
- Q:BGPAGEB<18
- Q:BGPAGEB>70
- Q:$$HYSTER(DFN,BGPEDATE)
- D S(BGPRPT,$S(BGPTIME=1:15,BGPTIME=0:45,BGPTIME=8:85,1:999),5,1)
- S BGPPAP=$$PAP(DFN,BGPEDATE,1)
- I $E(BGPPAP)="Y" D S(BGPRPT,$S(BGPTIME=1:15,BGPTIME=0:45,BGPTIME=8:85,1:999),6,1)
- I $D(BGPLIST(15)),BGPTIME=1 S ^XTMP("BGPD",BGPJ,BGPH,"LIST",15,$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$P(^DPT(DFN,0),U,2),BGPAGEE,DFN)=BGPPAP
- Q
- I6A ;EP
- ;Q:'$D(BGPIND(16))
- Q:$P(^DPT(DFN,0),U,2)'="F"
- Q:BGPAGEB<18
- Q:BGPAGEB>70
- Q:$$HYSTER(DFN,BGPEDATE)
- S BGPPAP=$$PAP(DFN,BGPEDATE,3)
- I $E(BGPPAP)="Y" D S(BGPRPT,$S(BGPTIME=1:15,BGPTIME=0:45,BGPTIME=8:85,1:999),7,1)
- I $D(BGPLIST(16)),BGPTIME=1 S ^XTMP("BGPD",BGPJ,BGPH,"LIST",16,$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$P(^DPT(DFN,0),U,2),BGPAGEE,DFN)=BGPPAP
- Q
- S(R,N,P,V) ;
- I 'V Q ;no value to add
- S $P(^BGPD(R,N),U,P)=$P($G(^BGPD(R,N)),U,P)+V
- Q
- HYSTER(P,EDATE) ;EP has patient had hysterectomy?
- I '$G(P) Q ""
- I '$D(^AUPNVPRC("AC",P)) Q ""
- NEW F,S,C,G S (F,S)=0 F S F=$O(^AUPNVPRC("AC",P,F)) Q:F'=+F!(S) S C=$P($$ICDOP^ICDCODE(+^AUPNVPRC(F,0)),U,2) D
- .S G=0 S:C=68.3!(C=68.4)!(C=68.5)!(C=68.6)!(C=68.7)!(C=68.9) G=1
- .Q:G=0
- .S D=$P(^AUPNVPRC(F,0),U,6) I D="" S D=$P($P(^AUPNVSIT($P(^AUPNVPRC(F,0),U,3),0),U),".")
- .I D>EDATE Q
- .S S=1
- Q S
- REFUSAL(P,F,I,B,E) ;EP
- I '$G(P) Q ""
- I '$G(F) Q ""
- I '$G(I) Q ""
- I $G(B)="" Q ""
- I $G(E)="" Q ""
- NEW G,X
- S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,F,I,X)) Q:X'=+X!(G) S Y=0 F S Y=$O(^AUPNPREF("AA",P,F,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S G=1
- Q G
- PAP(P,EDATE,YEARS) ;
- NEW BGP,%,E,BDATE S BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS)),%=P_"^LAST LAB PAP SMEAR;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")
- I $D(BGP(1)) Q "Yes "_$$FMTE^XLFDT($P(BGP(1),U))
- K BGP S %=P_"^LAST DX V76.2;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")
- I $D(BGP(1)) Q "Yes "_$$FMTE^XLFDT($P(BGP(1),U))_" V76.2"
- K BGP S %=P_"^LAST DX V72.3;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")
- I $D(BGP(1)) Q "Yes "_$$FMTE^XLFDT($P(BGP(1),U))_" V72.3"
- K BGP S %=P_"^LAST PROCEDURE 91.46;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGP(")
- I $D(BGP(1)) Q "Yes "_$$FMTE^XLFDT($P(BGP(1),U))_" 91.46"
- S T=$O(^ATXAX("B","BGP CPT PAP",0))
- I T D I X]"" Q "Yes "_X_" CPT"
- .S X=$$CPT^BGPDU(P,,EDATE,T,4)
- S T="PAP SMEAR",T=$O(^BWPN("B",T,0))
- I T D I X]"" Q "Yes "_X_" WHTP"
- .S X=$$WH^BGPDU(P,,EDATE,T,4)
- S T=$$REFUSAL(P,60,$O(^LAB(60,"B","PAP SMEAR",0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
- I T Q "Yes - Refused or NMI"
- Q "No"
- BGPD6 ; IHS/CMI/LAB - indicator 6 ;
- +1 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
- +2 ;
- I6 ;EP ;EP - indicator 6
- +1 ;Q:'$D(BGPIND(15))
- +2 IF $PIECE(^DPT(DFN,0),U,2)'="F"
- QUIT
- +3 IF BGPAGEB<18
- QUIT
- +4 IF BGPAGEB>70
- QUIT
- +5 IF $$HYSTER(DFN,BGPEDATE)
- QUIT
- +6 DO S(BGPRPT,$SELECT(BGPTIME=1:15,BGPTIME=0:45,BGPTIME=8:85,1:999),5,1)
- +7 SET BGPPAP=$$PAP(DFN,BGPEDATE,1)
- +8 IF $EXTRACT(BGPPAP)="Y"
- DO S(BGPRPT,$SELECT(BGPTIME=1:15,BGPTIME=0:45,BGPTIME=8:85,1:999),6,1)
- +9 IF $DATA(BGPLIST(15))
- IF BGPTIME=1
- SET ^XTMP("BGPD",BGPJ,BGPH,"LIST",15,$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$PIECE(^DPT(DFN,0),U,2),BGPAGEE,DFN)=BGPPAP
- +10 QUIT
- I6A ;EP
- +1 ;Q:'$D(BGPIND(16))
- +2 IF $PIECE(^DPT(DFN,0),U,2)'="F"
- QUIT
- +3 IF BGPAGEB<18
- QUIT
- +4 IF BGPAGEB>70
- QUIT
- +5 IF $$HYSTER(DFN,BGPEDATE)
- QUIT
- +6 SET BGPPAP=$$PAP(DFN,BGPEDATE,3)
- +7 IF $EXTRACT(BGPPAP)="Y"
- DO S(BGPRPT,$SELECT(BGPTIME=1:15,BGPTIME=0:45,BGPTIME=8:85,1:999),7,1)
- +8 IF $DATA(BGPLIST(16))
- IF BGPTIME=1
- SET ^XTMP("BGPD",BGPJ,BGPH,"LIST",16,$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$PIECE(^DPT(DFN,0),U,2),BGPAGEE,DFN)=BGPPAP
- +9 QUIT
- S(R,N,P,V) ;
- +1 ;no value to add
- IF 'V
- QUIT
- +2 SET $PIECE(^BGPD(R,N),U,P)=$PIECE($GET(^BGPD(R,N)),U,P)+V
- +3 QUIT
- HYSTER(P,EDATE) ;EP has patient had hysterectomy?
- +1 IF '$GET(P)
- QUIT ""
- +2 IF '$DATA(^AUPNVPRC("AC",P))
- QUIT ""
- +3 NEW F,S,C,G
- SET (F,S)=0
- FOR
- SET F=$ORDER(^AUPNVPRC("AC",P,F))
- IF F'=+F!(S)
- QUIT
- SET C=$PIECE($$ICDOP^ICDCODE(+^AUPNVPRC(F,0)),U,2)
- Begin DoDot:1
- +4 SET G=0
- IF C=68.3!(C=68.4)!(C=68.5)!(C=68.6)!(C=68.7)!(C=68.9)
- SET G=1
- +5 IF G=0
- QUIT
- +6 SET D=$PIECE(^AUPNVPRC(F,0),U,6)
- IF D=""
- SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),U),".")
- +7 IF D>EDATE
- QUIT
- +8 SET S=1
- End DoDot:1
- +9 QUIT S
- REFUSAL(P,F,I,B,E) ;EP
- +1 IF '$GET(P)
- QUIT ""
- +2 IF '$GET(F)
- QUIT ""
- +3 IF '$GET(I)
- QUIT ""
- +4 IF $GET(B)=""
- QUIT ""
- +5 IF $GET(E)=""
- QUIT ""
- +6 NEW G,X
- +7 SET (X,G)=0
- FOR
- SET X=$ORDER(^AUPNPREF("AA",P,F,I,X))
- IF X'=+X!(G)
- QUIT
- SET Y=0
- FOR
- SET Y=$ORDER(^AUPNPREF("AA",P,F,I,X,Y))
- IF Y'=+Y
- QUIT
- SET D=$PIECE(^AUPNPREF(Y,0),U,3)
- IF D'<B&(D'>E)
- SET G=1
- +8 QUIT G
- PAP(P,EDATE,YEARS) ;
- +1 NEW BGP,%,E,BDATE
- SET BDATE=$$FMADD^XLFDT(EDATE,-(365*YEARS))
- SET %=P_"^LAST LAB PAP SMEAR;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
- SET E=$$START1^APCLDF(%,"BGP(")
- +2 IF $DATA(BGP(1))
- QUIT "Yes "_$$FMTE^XLFDT($PIECE(BGP(1),U))
- +3 KILL BGP
- SET %=P_"^LAST DX V76.2;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
- SET E=$$START1^APCLDF(%,"BGP(")
- +4 IF $DATA(BGP(1))
- QUIT "Yes "_$$FMTE^XLFDT($PIECE(BGP(1),U))_" V76.2"
- +5 KILL BGP
- SET %=P_"^LAST DX V72.3;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
- SET E=$$START1^APCLDF(%,"BGP(")
- +6 IF $DATA(BGP(1))
- QUIT "Yes "_$$FMTE^XLFDT($PIECE(BGP(1),U))_" V72.3"
- +7 KILL BGP
- SET %=P_"^LAST PROCEDURE 91.46;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
- SET E=$$START1^APCLDF(%,"BGP(")
- +8 IF $DATA(BGP(1))
- QUIT "Yes "_$$FMTE^XLFDT($PIECE(BGP(1),U))_" 91.46"
- +9 SET T=$ORDER(^ATXAX("B","BGP CPT PAP",0))
- +10 IF T
- Begin DoDot:1
- +11 SET X=$$CPT^BGPDU(P,,EDATE,T,4)
- End DoDot:1
- IF X]""
- QUIT "Yes "_X_" CPT"
- +12 SET T="PAP SMEAR"
- SET T=$ORDER(^BWPN("B",T,0))
- +13 IF T
- Begin DoDot:1
- +14 SET X=$$WH^BGPDU(P,,EDATE,T,4)
- End DoDot:1
- IF X]""
- QUIT "Yes "_X_" WHTP"
- +15 SET T=$$REFUSAL(P,60,$ORDER(^LAB(60,"B","PAP SMEAR",0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
- +16 IF T
- QUIT "Yes - Refused or NMI"
- +17 QUIT "No"
