- BGP3D62 ; IHS/CMI/LAB - measure 31 01 Jul 2010 7:47 PM ; 19 Sep 2012 8:13 AM
- ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
- ;
- IBHEDIS ;EP
- S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
- I BGPAGEB<50 S BGPSTOP=1 Q
- I BGPAGEB>75 S BGPSTOP=1 Q
- Q:'BGPACTCL
- I $$CRC(DFN,BGPEDATE) S BGPSTOP=1 Q ;has colorectal cancer
- S BGPD1=1
- CRCP ;EP - called from elder
- S BGPFOB=$$FOB(DFN,BGPBDATE,BGPEDATE)
- I BGPFOB]"" S BGPN3=1,BGPN1=1
- S BGPSIG=$$SIG(DFN,BGPEDATE)
- S BGPCOLO=$$COLO(DFN,BGPEDATE)
- I BGPFOB]""!(BGPSIG]"")!(BGPCOLO]"") S BGPN1=1,BGPN7=1
- I BGPSIG]""!(BGPCOLO]"") S BGPN4=1
- S BGPREF="" I 'BGPN1 S BGPREF=$$REF^BGP3D61(DFN,$$FMADD^XLFDT(BGPEDATE,-365),BGPEDATE) I BGPREF S BGPN2=1
- S BGPVALUE=""
- I BGPFOB]"" S BGPVALUE="FOB: "_$$DATE^BGP3UTL($P(BGPFOB,U,2))_" "_$P(BGPFOB,U)
- I BGPSIG]"" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"") S BGPVALUE=BGPVALUE_"SIG: "_$P(BGPSIG,U,2)_" "_$P(BGPSIG,U)
- I BGPCOLO]"" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"") S BGPVALUE=BGPVALUE_"COLO: "_$P(BGPCOLO,U,2)_" "_$P(BGPCOLO,U,1)
- I BGPREF]"" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"") S BGPVALUE=BGPVALUE_$$DATE^BGP3UTL($P(BGPREF,U,2))_" "_$P(BGPREF,U,3)
- S BGPDV="AC"
- S BGPVALUE=BGPDV_"|||"_BGPVALUE
- K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P
- Q
- CRC(P,EDATE) ;EP
- K BGPG
- S Y="BGPG("
- S X=P_"^LAST DX [BGP COLORECTAL CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
- I $D(BGPG(1)) Q 1 ;has a dx
- S T=$O(^ATXAX("B","BGP COLORECTAL CANCER CPTS",0))
- I T D I X]"" Q 1
- .S X=$$CPT^BGP3DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
- .S X=$$TRAN^BGP3DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
- S BGPG=$$LASTPRC^BGP3UTL1(P,"BGP TOTAL COLECTOMY PROCS",$$DOB^AUPNPAT(P),EDATE)
- I BGPG Q 1
- S T=$O(^ATXAX("B","BGP TOTAL COLECTOMY CPTS",0))
- I T D I X]"" Q 1
- .S X=$$CPT^BGP3DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
- .S X=$$TRAN^BGP3DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
- Q 0
- SIG(P,EDATE,BDATE) ;EP
- NEW BGPLSIG
- S BGPLSIG=""
- I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
- S BGPG=$$LASTPRC^BGP3UTL1(P,"BGP SIG PROCS",BDATE,EDATE)
- I $P(BGPG,U)=1 S BGPLSIG="Proc "_$P(BGPG,U,2)_"^"_$$DATE^BGP3UTL($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 "_$P(X,U,2)_U_$$DATE^BGP3UTL($P(X,U,1))_U_$P(X,U,1)
- .S X=$$CPT^BGP3DU(P,BDATE,EDATE,T,5) I X]"" Q
- .S X=$$TRAN^BGP3DU(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^BGP3UTL1(P,"BGP COLO PROCS",BDATE,EDATE)
- I $P(BGPG,U)=1 S BGPLCOLO="Proc "_$P(BGPG,U,2)_"^"_$$DATE^BGP3UTL($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^BGP3UTL($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 "_$P(X,U,2)_U_$$DATE^BGP3UTL($P(X,U,1))_U_$P(X,U,1)
- .S X=$$CPT^BGP3DU(P,BDATE,EDATE,T,5) I X]"" Q
- .S X=$$TRAN^BGP3DU(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="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^BGP3DU(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="POV 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 ""
- BGP3D62 ; IHS/CMI/LAB - measure 31 01 Jul 2010 7:47 PM ; 19 Sep 2012 8:13 AM
- +1 ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
- +2 ;
- IBHEDIS ;EP
- +1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
- +2 IF BGPAGEB<50
- SET BGPSTOP=1
- QUIT
- +3 IF BGPAGEB>75
- SET BGPSTOP=1
- QUIT
- +4 IF 'BGPACTCL
- QUIT
- +5 ;has colorectal cancer
- IF $$CRC(DFN,BGPEDATE)
- SET BGPSTOP=1
- QUIT
- +6 SET BGPD1=1
- CRCP ;EP - called from elder
- +1 SET BGPFOB=$$FOB(DFN,BGPBDATE,BGPEDATE)
- +2 IF BGPFOB]""
- SET BGPN3=1
- SET BGPN1=1
- +3 SET BGPSIG=$$SIG(DFN,BGPEDATE)
- +4 SET BGPCOLO=$$COLO(DFN,BGPEDATE)
- +5 IF BGPFOB]""!(BGPSIG]"")!(BGPCOLO]"")
- SET BGPN1=1
- SET BGPN7=1
- +6 IF BGPSIG]""!(BGPCOLO]"")
- SET BGPN4=1
- +7 SET BGPREF=""
- IF 'BGPN1
- SET BGPREF=$$REF^BGP3D61(DFN,$$FMADD^XLFDT(BGPEDATE,-365),BGPEDATE)
- IF BGPREF
- SET BGPN2=1
- +8 SET BGPVALUE=""
- +9 IF BGPFOB]""
- SET BGPVALUE="FOB: "_$$DATE^BGP3UTL($PIECE(BGPFOB,U,2))_" "_$PIECE(BGPFOB,U)
- +10 IF BGPSIG]""
- SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")
- SET BGPVALUE=BGPVALUE_"SIG: "_$PIECE(BGPSIG,U,2)_" "_$PIECE(BGPSIG,U)
- +11 IF BGPCOLO]""
- SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")
- SET BGPVALUE=BGPVALUE_"COLO: "_$PIECE(BGPCOLO,U,2)_" "_$PIECE(BGPCOLO,U,1)
- +12 IF BGPREF]""
- SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")
- SET BGPVALUE=BGPVALUE_$$DATE^BGP3UTL($PIECE(BGPREF,U,2))_" "_$PIECE(BGPREF,U,3)
- +13 SET BGPDV="AC"
- +14 SET BGPVALUE=BGPDV_"|||"_BGPVALUE
- +15 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P
- +16 QUIT
- CRC(P,EDATE) ;EP
- +1 KILL BGPG
- +2 SET Y="BGPG("
- +3 SET X=P_"^LAST DX [BGP COLORECTAL CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
- SET E=$$START1^APCLDF(X,Y)
- +4 ;has a dx
- IF $DATA(BGPG(1))
- QUIT 1
- +5 SET T=$ORDER(^ATXAX("B","BGP COLORECTAL CANCER CPTS",0))
- +6 IF T
- Begin DoDot:1
- +7 SET X=$$CPT^BGP3DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
- IF X]""
- QUIT
- +8 SET X=$$TRAN^BGP3DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
- End DoDot:1
- IF X]""
- QUIT 1
- +9 SET BGPG=$$LASTPRC^BGP3UTL1(P,"BGP TOTAL COLECTOMY PROCS",$$DOB^AUPNPAT(P),EDATE)
- +10 IF BGPG
- QUIT 1
- +11 SET T=$ORDER(^ATXAX("B","BGP TOTAL COLECTOMY CPTS",0))
- +12 IF T
- Begin DoDot:1
- +13 SET X=$$CPT^BGP3DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
- IF X]""
- QUIT
- +14 SET X=$$TRAN^BGP3DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
- End DoDot:1
- IF X]""
- QUIT 1
- +15 QUIT 0
- SIG(P,EDATE,BDATE) ;EP
- +1 NEW BGPLSIG
- +2 SET BGPLSIG=""
- +3 IF $GET(BDATE)=""
- SET BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
- +4 SET BGPG=$$LASTPRC^BGP3UTL1(P,"BGP SIG PROCS",BDATE,EDATE)
- +5 IF $PIECE(BGPG,U)=1
- SET BGPLSIG="Proc "_$PIECE(BGPG,U,2)_"^"_$$DATE^BGP3UTL($PIECE(BGPG,U,3))_U_$PIECE(BGPG,U,3)
- +6 ;
- +7 SET T=$ORDER(^ATXAX("B","BGP SIG CPTS",0))
- +8 IF T
- Begin DoDot:1
- +9 SET X=$$CPT^BGP3DU(P,BDATE,EDATE,T,5)
- IF X]""
- QUIT
- +10 SET X=$$TRAN^BGP3DU(P,BDATE,EDATE,T,5)
- End DoDot:1
- IF X]""
- IF $PIECE(BGPLSIG,U,3)<$PIECE(X,U,1)
- SET BGPLSIG="CPT "_$PIECE(X,U,2)_U_$$DATE^BGP3UTL($PIECE(X,U,1))_U_$PIECE(X,U,1)
- +11 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^BGP3UTL1(P,"BGP COLO PROCS",BDATE,EDATE)
- +5 IF $PIECE(BGPG,U)=1
- SET BGPLCOLO="Proc "_$PIECE(BGPG,U,2)_"^"_$$DATE^BGP3UTL($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^BGP3UTL($P(BGPG(1),U))
- +8 SET T=$ORDER(^ATXAX("B","BGP COLO CPTS",0))
- +9 IF T
- Begin DoDot:1
- +10 SET X=$$CPT^BGP3DU(P,BDATE,EDATE,T,5)
- IF X]""
- QUIT
- +11 SET X=$$TRAN^BGP3DU(P,BDATE,EDATE,T,5)
- End DoDot:1
- IF X]""
- IF $PIECE(BGPLCOLO,U,3)<$PIECE(X,U,1)
- SET BGPLCOLO="CPT "_$PIECE(X,U,2)_U_$$DATE^BGP3UTL($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="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^BGP3DU(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 ;S %=P_"^LAST DIAGNOSIS [BGP COLO DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
- +20 ;I $D(BGPG(1)),$P(BGPLFOB,U,2)<$P(BGPG(1),U,1) S BGPLFOB="POV V76.51"_"^"_$P(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 ""