BGP0D64 ; IHS/CMI/LAB - measure 31 01 Jul 2009 7:47 PM ;
;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
;
ICCS ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
I 'BGPACTCL S BGPSTOP=1 Q ;not active clinical and must be
;
S BGPCERV=$$DEN7^BGP0D3(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
S BGPBREAS=$$DEN8^BGP0D4(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
S BGPCRCS="" I BGPAGEB>49,BGPAGEB<76,'$$CRC^BGP0D61(DFN,BGPEDATE) S BGPCRCS=1
;if cervical cancer, did they have a pap
S BGPPAP="" I BGPCERV S BGPPAP=$$PAP^BGP0D3(DFN,BGPEDATE,3,1)
S BGPMAM="" I BGPBREAS S BGPMAM=$$MAM^BGP0D4(DFN,BGPEDATE,2,1)
S BGPCRC="" I BGPCRCS S BGPCRC=$$CRCS(DFN,BGPBDATE,BGPEDATE)
;W !,BGPCRC
;BGPN1 will be set to 1 if the patient had all eligible screenings
S BGPN1=1
I BGPCERV,BGPPAP="" S BGPN1=0
I BGPBREAS,BGPMAM="" S BGPN1=0
I BGPCRCS,BGPCRC="" S BGPN1=0
I (BGPCERV+BGPBREAS+BGPCRCS) S BGPD1=1
I 'BGPD1 Q ;not eligible for any
S BGPDV="AC"
I BGPCERV S BGPDV=BGPDV_";PAP DENOM"
I BGPBREAS S BGPDV=BGPDV_";MAM DENOM"
I BGPCRCS S BGPDV=BGPDV_";CRCS DENOM"
S BGPVALUE=$S(BGPPAP]"":"Pap "_$P(BGPPAP,U,3)_" "_$$DATE^BGP0UTL($P(BGPPAP,U,2)),1:"")
I BGPMAM]"" S:BGPVALUE]"" BGPVALUE=BGPVALUE_"; " S BGPVALUE=BGPVALUE_$S(BGPMAM]"":"Mamm "_$P(BGPMAM,U,3)_" "_$$DATE^BGP0UTL($P(BGPMAM,U,2)),1:"")
I BGPCRC]"" S:BGPVALUE]"" BGPVALUE=BGPVALUE_"; " S BGPVALUE=BGPVALUE_$S(BGPCRC]"":"CRCS "_$P(BGPCRC,U,1)_" "_$$DATE^BGP0UTL($P(BGPCRC,U,3)),1:"")
S BGPVALUE=BGPDV_"|||"_BGPVALUE
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P
Q
CRCS(P,BDATE,EDATE) ;
NEW VALUE
S VALUE=""
S VALUE=$$SIG(P,EDATE)
I VALUE]"" Q VALUE
S VALUE=$$COLO(P,EDATE)
I VALUE]"" Q VALUE
S VALUE=$$FOB(P,BDATE,EDATE)
I VALUE]"" Q VALUE
Q ""
SIG(P,EDATE,BDATE) ;EP
NEW BGPLSIG
S BGPLSIG=""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
;S BGPG=$$LASTPRCI^BGP0UTL1(P,"45.24",BDATE,EDATE)
S BGPG=$$LASTPRC^BGP0UTL1(P,"BGP SIG PROCS",BDATE,EDATE)
I $P(BGPG,U)=1 S BGPLSIG="SIG "_$P(BGPG,U,2)_"^"_$$DATE^BGP0UTL($P(BGPG,U,3))_U_$P(BGPG,U,3)
;
S T=$O(^ATXAX("B","BGP SIG CPTS",0))
I T D I X]"",$P(BGPLSIG,U,3)<$P(X,U,1) S BGPLSIG="CPT SIG "_$P(X,U,2)_U_$$DATE^BGP0UTL($P(X,U,1))_U_$P(X,U,1)
.S X=$$CPT^BGP0DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP0DU(P,BDATE,EDATE,T,5)
Q BGPLSIG
COLO(P,EDATE,BDATE) ;EP
K BGPG
S BGPLCOLO=""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,10*(-365))
S BGPG=$$LASTPRC^BGP0UTL1(P,"BGP COLO PROCS",BDATE,EDATE)
I $P(BGPG,U)=1 S BGPLCOLO="COLO "_$P(BGPG,U,2)_"^"_$$DATE^BGP0UTL($P(BGPG,U,3))_U_$P(BGPG,U,3)
;S %=P_"^LAST DIAGNOSIS [BGP COLO DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
;I $D(BGPG(1)),$P(BGPLCOLO,U,3)<$P(BGPG(1),U,1) S BGPLCOLO="COLO DX V76.51"_"^"_$$DATE^BGP0UTL($P(BGPG(1),U))
S T=$O(^ATXAX("B","BGP COLO CPTS",0))
I T D I X]"",$P(BGPLCOLO,U,3)<$P(X,U,1) S BGPLCOLO="CPT COLO "_$P(X,U,2)_U_$$DATE^BGP0UTL($P(X,U,1))_U_$P(X,U,1)
.S X=$$CPT^BGP0DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP0DU(P,BDATE,EDATE,T,5)
Q BGPLCOLO
FOB(P,BDATE,EDATE) ;EP
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,2*(-365))
S BGPC="",BGPLFOB=""
S T=$O(^ATXAX("B","BGP FOBT LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","BGP GPRA FOB TESTS",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BGPC]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"") D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC="V LAB"_U_(9999999-D) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S BGPC="LOINC"_U_(9999999-D) Q
...Q
S BGPLFOB=BGPC
S T=$O(^ATXAX("B","BGP FOBT CPTS",0))
I T D I X]"",$P(BGPLFOB,U,2)<$P(X,U,1) S BGPLFOB="CPT "_$P(X,"^",2)_"^"_$P(X,U,1)
.S X=$$CPT^BGP0DU(P,BDATE,EDATE,T,5) I X]"" Q
S %=P_"^LAST DIAGNOSIS [BGP COLO DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)),$P(BGPLFOB,U,2)<$P(BGPG(1),U,1) S BGPLFOB="FOB DX V76.51"_"^"_$P(BGPG(1),U)
Q BGPLFOB
;
LOINC(A,B) ;
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
BGP0D64 ; IHS/CMI/LAB - measure 31 01 Jul 2009 7:47 PM ;
+1 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
+2 ;
ICCS ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 ;not active clinical and must be
IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+3 ;
+4 SET BGPCERV=$$DEN7^BGP0D3(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
+5 SET BGPBREAS=$$DEN8^BGP0D4(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
+6 SET BGPCRCS=""
IF BGPAGEB>49
IF BGPAGEB<76
IF '$$CRC^BGP0D61(DFN,BGPEDATE)
SET BGPCRCS=1
+7 ;if cervical cancer, did they have a pap
+8 SET BGPPAP=""
IF BGPCERV
SET BGPPAP=$$PAP^BGP0D3(DFN,BGPEDATE,3,1)
+9 SET BGPMAM=""
IF BGPBREAS
SET BGPMAM=$$MAM^BGP0D4(DFN,BGPEDATE,2,1)
+10 SET BGPCRC=""
IF BGPCRCS
SET BGPCRC=$$CRCS(DFN,BGPBDATE,BGPEDATE)
+11 ;W !,BGPCRC
+12 ;BGPN1 will be set to 1 if the patient had all eligible screenings
+13 SET BGPN1=1
+14 IF BGPCERV
IF BGPPAP=""
SET BGPN1=0
+15 IF BGPBREAS
IF BGPMAM=""
SET BGPN1=0
+16 IF BGPCRCS
IF BGPCRC=""
SET BGPN1=0
+17 IF (BGPCERV+BGPBREAS+BGPCRCS)
SET BGPD1=1
+18 ;not eligible for any
IF 'BGPD1
QUIT
+19 SET BGPDV="AC"
+20 IF BGPCERV
SET BGPDV=BGPDV_";PAP DENOM"
+21 IF BGPBREAS
SET BGPDV=BGPDV_";MAM DENOM"
+22 IF BGPCRCS
SET BGPDV=BGPDV_";CRCS DENOM"
+23 SET BGPVALUE=$SELECT(BGPPAP]"":"Pap "_$PIECE(BGPPAP,U,3)_" "_$$DATE^BGP0UTL($PIECE(BGPPAP,U,2)),1:"")
+24 IF BGPMAM]""
IF BGPVALUE]""
SET BGPVALUE=BGPVALUE_"; "
SET BGPVALUE=BGPVALUE_$SELECT(BGPMAM]"":"Mamm "_$PIECE(BGPMAM,U,3)_" "_$$DATE^BGP0UTL($PIECE(BGPMAM,U,2)),1:"")
+25 IF BGPCRC]""
IF BGPVALUE]""
SET BGPVALUE=BGPVALUE_"; "
SET BGPVALUE=BGPVALUE_$SELECT(BGPCRC]"":"CRCS "_$PIECE(BGPCRC,U,1)_" "_$$DATE^BGP0UTL($PIECE(BGPCRC,U,3)),1:"")
+26 SET BGPVALUE=BGPDV_"|||"_BGPVALUE
+27 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P
+28 QUIT
CRCS(P,BDATE,EDATE) ;
+1 NEW VALUE
+2 SET VALUE=""
+3 SET VALUE=$$SIG(P,EDATE)
+4 IF VALUE]""
QUIT VALUE
+5 SET VALUE=$$COLO(P,EDATE)
+6 IF VALUE]""
QUIT VALUE
+7 SET VALUE=$$FOB(P,BDATE,EDATE)
+8 IF VALUE]""
QUIT VALUE
+9 QUIT ""
SIG(P,EDATE,BDATE) ;EP
+1 NEW BGPLSIG
+2 SET BGPLSIG=""
+3 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
+4 ;S BGPG=$$LASTPRCI^BGP0UTL1(P,"45.24",BDATE,EDATE)
+5 SET BGPG=$$LASTPRC^BGP0UTL1(P,"BGP SIG PROCS",BDATE,EDATE)
+6 IF $PIECE(BGPG,U)=1
SET BGPLSIG="SIG "_$PIECE(BGPG,U,2)_"^"_$$DATE^BGP0UTL($PIECE(BGPG,U,3))_U_$PIECE(BGPG,U,3)
+7 ;
+8 SET T=$ORDER(^ATXAX("B","BGP SIG CPTS",0))
+9 IF T
Begin DoDot:1
+10 SET X=$$CPT^BGP0DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+11 SET X=$$TRAN^BGP0DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
IF $PIECE(BGPLSIG,U,3)<$PIECE(X,U,1)
SET BGPLSIG="CPT SIG "_$PIECE(X,U,2)_U_$$DATE^BGP0UTL($PIECE(X,U,1))_U_$PIECE(X,U,1)
+12 QUIT BGPLSIG
COLO(P,EDATE,BDATE) ;EP
+1 KILL BGPG
+2 SET BGPLCOLO=""
+3 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,10*(-365))
+4 SET BGPG=$$LASTPRC^BGP0UTL1(P,"BGP COLO PROCS",BDATE,EDATE)
+5 IF $PIECE(BGPG,U)=1
SET BGPLCOLO="COLO "_$PIECE(BGPG,U,2)_"^"_$$DATE^BGP0UTL($PIECE(BGPG,U,3))_U_$PIECE(BGPG,U,3)
+6 ;S %=P_"^LAST DIAGNOSIS [BGP COLO DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
+7 ;I $D(BGPG(1)),$P(BGPLCOLO,U,3)<$P(BGPG(1),U,1) S BGPLCOLO="COLO DX V76.51"_"^"_$$DATE^BGP0UTL($P(BGPG(1),U))
+8 SET T=$ORDER(^ATXAX("B","BGP COLO CPTS",0))
+9 IF T
Begin DoDot:1
+10 SET X=$$CPT^BGP0DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+11 SET X=$$TRAN^BGP0DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
IF $PIECE(BGPLCOLO,U,3)<$PIECE(X,U,1)
SET BGPLCOLO="CPT COLO "_$PIECE(X,U,2)_U_$$DATE^BGP0UTL($PIECE(X,U,1))_U_$PIECE(X,U,1)
+12 QUIT BGPLCOLO
FOB(P,BDATE,EDATE) ;EP
+1 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,2*(-365))
+2 SET BGPC=""
SET BGPLFOB=""
+3 SET T=$ORDER(^ATXAX("B","BGP FOBT LOINC CODES",0))
+4 SET BGPLT=$ORDER(^ATXLAB("B","BGP GPRA FOB TESTS",0))
+5 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BGPC]"")
QUIT
Begin DoDot:1
+6 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+8 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+9 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC="V LAB"_U_(9999999-D)
QUIT
+10 IF 'T
QUIT
+11 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+12 IF '$$LOINC(J,T)
QUIT
+13 SET BGPC="LOINC"_U_(9999999-D)
QUIT
+14 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+15 SET BGPLFOB=BGPC
+16 SET T=$ORDER(^ATXAX("B","BGP FOBT CPTS",0))
+17 IF T
Begin DoDot:1
+18 SET X=$$CPT^BGP0DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
End DoDot:1
IF X]""
IF $PIECE(BGPLFOB,U,2)<$PIECE(X,U,1)
SET BGPLFOB="CPT "_$PIECE(X,"^",2)_"^"_$PIECE(X,U,1)
+19 SET %=P_"^LAST DIAGNOSIS [BGP COLO DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+20 IF $DATA(BGPG(1))
IF $PIECE(BGPLFOB,U,2)<$PIECE(BGPG(1),U,1)
SET BGPLFOB="FOB DX V76.51"_"^"_$PIECE(BGPG(1),U)
+21 QUIT BGPLFOB
+22 ;
LOINC(A,B) ;
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
