Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP3D62

BGP3D62.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. IBHEDIS ;EP
  1. S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
  1. I BGPAGEB<50 S BGPSTOP=1 Q
  1. I BGPAGEB>75 S BGPSTOP=1 Q
  1. Q:'BGPACTCL
  1. I $$CRC(DFN,BGPEDATE) S BGPSTOP=1 Q ;has colorectal cancer
  1. S BGPD1=1
  1. CRCP ;EP - called from elder
  1. S BGPFOB=$$FOB(DFN,BGPBDATE,BGPEDATE)
  1. I BGPFOB]"" S BGPN3=1,BGPN1=1
  1. S BGPSIG=$$SIG(DFN,BGPEDATE)
  1. S BGPCOLO=$$COLO(DFN,BGPEDATE)
  1. I BGPFOB]""!(BGPSIG]"")!(BGPCOLO]"") S BGPN1=1,BGPN7=1
  1. I BGPSIG]""!(BGPCOLO]"") S BGPN4=1
  1. S BGPREF="" I 'BGPN1 S BGPREF=$$REF^BGP3D61(DFN,$$FMADD^XLFDT(BGPEDATE,-365),BGPEDATE) I BGPREF S BGPN2=1
  1. S BGPVALUE=""
  1. I BGPFOB]"" S BGPVALUE="FOB: "_$$DATE^BGP3UTL($P(BGPFOB,U,2))_" "_$P(BGPFOB,U)
  1. I BGPSIG]"" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"") S BGPVALUE=BGPVALUE_"SIG: "_$P(BGPSIG,U,2)_" "_$P(BGPSIG,U)
  1. I BGPCOLO]"" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"") S BGPVALUE=BGPVALUE_"COLO: "_$P(BGPCOLO,U,2)_" "_$P(BGPCOLO,U,1)
  1. I BGPREF]"" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"") S BGPVALUE=BGPVALUE_$$DATE^BGP3UTL($P(BGPREF,U,2))_" "_$P(BGPREF,U,3)
  1. S BGPDV="AC"
  1. S BGPVALUE=BGPDV_"|||"_BGPVALUE
  1. K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P
  1. Q
  1. CRC(P,EDATE) ;EP
  1. K BGPG
  1. S Y="BGPG("
  1. S X=P_"^LAST DX [BGP COLORECTAL CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1. I $D(BGPG(1)) Q 1 ;has a dx
  1. S T=$O(^ATXAX("B","BGP COLORECTAL CANCER CPTS",0))
  1. I T D I X]"" Q 1
  1. .S X=$$CPT^BGP3DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
  1. .S X=$$TRAN^BGP3DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
  1. S BGPG=$$LASTPRC^BGP3UTL1(P,"BGP TOTAL COLECTOMY PROCS",$$DOB^AUPNPAT(P),EDATE)
  1. I BGPG Q 1
  1. S T=$O(^ATXAX("B","BGP TOTAL COLECTOMY CPTS",0))
  1. I T D I X]"" Q 1
  1. .S X=$$CPT^BGP3DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
  1. .S X=$$TRAN^BGP3DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
  1. Q 0
  1. SIG(P,EDATE,BDATE) ;EP
  1. NEW BGPLSIG
  1. S BGPLSIG=""
  1. I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
  1. S BGPG=$$LASTPRC^BGP3UTL1(P,"BGP SIG PROCS",BDATE,EDATE)
  1. I $P(BGPG,U)=1 S BGPLSIG="Proc "_$P(BGPG,U,2)_"^"_$$DATE^BGP3UTL($P(BGPG,U,3))_U_$P(BGPG,U,3)
  1. ;
  1. S T=$O(^ATXAX("B","BGP SIG CPTS",0))
  1. 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)
  1. .S X=$$CPT^BGP3DU(P,BDATE,EDATE,T,5) I X]"" Q
  1. .S X=$$TRAN^BGP3DU(P,BDATE,EDATE,T,5)
  1. Q BGPLSIG
  1. COLO(P,EDATE,BDATE) ;EP
  1. K BGPG
  1. S BGPLCOLO=""
  1. I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,10*(-365))
  1. S BGPG=$$LASTPRC^BGP3UTL1(P,"BGP COLO PROCS",BDATE,EDATE)
  1. I $P(BGPG,U)=1 S BGPLCOLO="Proc "_$P(BGPG,U,2)_"^"_$$DATE^BGP3UTL($P(BGPG,U,3))_U_$P(BGPG,U,3)
  1. ;S %=P_"^LAST DIAGNOSIS [BGP COLO DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1. ;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))
  1. S T=$O(^ATXAX("B","BGP COLO CPTS",0))
  1. 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)
  1. .S X=$$CPT^BGP3DU(P,BDATE,EDATE,T,5) I X]"" Q
  1. .S X=$$TRAN^BGP3DU(P,BDATE,EDATE,T,5)
  1. Q BGPLCOLO
  1. FOB(P,BDATE,EDATE) ;EP
  1. I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,2*(-365))
  1. S BGPC="",BGPLFOB=""
  1. S T=$O(^ATXAX("B","BGP FOBT LOINC CODES",0))
  1. S BGPLT=$O(^ATXLAB("B","BGP GPRA FOB TESTS",0))
  1. 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
  1. .S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"") D
  1. ..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"") D
  1. ...Q:'$D(^AUPNVLAB(X,0))
  1. ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC="Lab"_U_(9999999-D) Q
  1. ...Q:'T
  1. ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1. ...Q:'$$LOINC(J,T)
  1. ...S BGPC="LOINC"_U_(9999999-D) Q
  1. ...Q
  1. S BGPLFOB=BGPC
  1. S T=$O(^ATXAX("B","BGP FOBT CPTS",0))
  1. I T D I X]"",$P(BGPLFOB,U,2)<$P(X,U,1) S BGPLFOB="CPT "_$P(X,"^",2)_"^"_$P(X,U,1)
  1. .S X=$$CPT^BGP3DU(P,BDATE,EDATE,T,5) I X]"" Q
  1. ;S %=P_"^LAST DIAGNOSIS [BGP COLO DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1. ;I $D(BGPG(1)),$P(BGPLFOB,U,2)<$P(BGPG(1),U,1) S BGPLFOB="POV V76.51"_"^"_$P(BGPG(1),U)
  1. Q BGPLFOB
  1. ;
  1. LOINC(A,B) ;
  1. NEW %
  1. S %=$P($G(^LAB(95.3,A,9999999)),U,2)
  1. I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
  1. S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1. I $D(^ATXAX(B,21,"B",%)) Q 1
  1. Q ""