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

BGP1D61.m

Go to the documentation of this file. 
  1. BGP1D61 ; IHS/CMI/LAB - measure 31 01 Jul 2010 7:47 PM ;
  1.  ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
  1.  ;
  1. I17 ;EP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
  1.  I BGPAGEB<51 S BGPSTOP=1 Q
  1.  I BGPAGEB>80 S BGPSTOP=1 Q
  1.  I $$CRC(DFN,BGPEDATE) S BGPSTOP=1 Q  ;has colorectal cancer
  1.  I BGPACTUP S BGPD1=1
  1.  I BGPACTCL S BGPD2=1
  1.  I 'BGPD1 S BGPSTOP=1 Q  ;need to be at least in user pop
  1. CRCP ;EP - called from elder
  1.  S BGPFOB=$$FOB(DFN,BGPBDATE,BGPEDATE)
  1.  I BGPFOB]"" S BGPN3=1,BGPN1=1
  1.  S BGPOTH=""
  1.  I BGPN1=0 S BGPOTH=$$IBH(DFN,BGPEDATE)
  1.  I BGPOTH]"" S BGPN1=1
  1.  S BGPSIG=$$SIG(DFN,BGPEDATE)
  1.  S BGPCOLO=$$COLO(DFN,BGPEDATE)
  1.  S BGPBE=$$BE(DFN,BGPEDATE)
  1.  I BGPSIG]""!(BGPBE]"")!(BGPCOLO]"") S BGPN4=1
  1.  I BGPSIG]""!(BGPCOLO]"") S BGPN5=1
  1.  I BGPSIG]""&(BGPBE]"")!(BGPCOLO]"") S BGPN6=1
  1.  S BGPREF="" I 'BGPN1 S BGPREF=$$REF(DFN,$$FMADD^XLFDT(BGPEDATE,-365),BGPEDATE) I BGPREF S BGPN1=1,BGPN2=1
  1.  I BGPN1,'BGPN2 S BGPN7=1
  1.  S BGPVALUE=""
  1.  I BGPFOB]"" S BGPVALUE="FOB: "_$$DATE^BGP1UTL($P(BGPFOB,U,2))_" "_$P(BGPFOB,U)
  1.  ;I BGPOTH]"" S BGPVALUE=BGPVALUE_$P(BGPOTH,U)_":"_$P(BGPOTH,U,2)_" "
  1.  I BGPSIG]"" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"") S BGPVALUE=BGPVALUE_"SIG: "_$P(BGPSIG,U,2)_" "_$P(BGPSIG,U,1)
  1.  I BGPCOLO]"" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"") S BGPVALUE=BGPVALUE_"COLO: "_$P(BGPCOLO,U,2)_" "_$P(BGPCOLO,U,1)
  1.  I BGPBE]"" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"") S BGPVALUE=BGPVALUE_"BE: "_$P(BGPBE,U,2)_" "_$P(BGPBE,U,1)
  1.  I BGPREF]"" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"") S BGPVALUE=BGPVALUE_$$DATE^BGP1UTL($P(BGPREF,U,2))_" "_$P(BGPREF,U,3)
  1.  S BGPDV=$S(BGPD1:"UP",1:"")_$S(BGPD2:",AC",1:"")
  1.  S BGPVALUE=BGPDV_"|||"_BGPVALUE
  1.  K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P
  1.  Q
  1. IBH(P,EDATE) ;EP
  1.  NEW VALUE
  1.  S VALUE=""
  1.  S VALUE=$$SIG(P,EDATE)
  1.  I VALUE]"" Q VALUE
  1.  S VALUE=$$BE(P,EDATE)
  1.  I VALUE]"" Q VALUE
  1.  S VALUE=$$COLO(P,EDATE)
  1.  I VALUE]"" Q VALUE
  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^BGP1DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BGP1DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
  1.  S BGPG=$$LASTPRC^BGP1UTL1(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^BGP1DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BGP1DU(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=$$LASTPRCI^BGP1UTL1(P,"45.24",BDATE,EDATE)
  1.  S BGPG=$$LASTPRC^BGP1UTL1(P,"BGP SIG PROCS",BDATE,EDATE)
  1.  ;I $P(BGPG,U)=1 S BGPLSIG="SIG "_$P(BGPG,U,2)_"^"_$$DATE^BGP1UTL($P(BGPG,U,3))_U_$P(BGPG,U,3)
  1.  I $P(BGPG,U)=1 S BGPLSIG=$P(BGPG,U,2)_"^"_$$DATE^BGP1UTL($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 SIG "_$P(X,U,2)_U_$$DATE^BGP1UTL($P(X,U,1))_U_$P(X,U,1)
  1.  .S X=$$CPT^BGP1DU(P,BDATE,EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BGP1DU(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^BGP1UTL1(P,"BGP COLO PROCS",BDATE,EDATE)
  1.  I $P(BGPG,U)=1 S BGPLCOLO=$P(BGPG,U,2)_"^"_$$DATE^BGP1UTL($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="DX V76.51"_"^"_$$DATE^BGP1UTL($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^BGP1UTL($P(X,U,1))_U_$P(X,U,1)
  1.  .S X=$$CPT^BGP1DU(P,BDATE,EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BGP1DU(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="V 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^BGP1DU(P,BDATE,EDATE,T,5) I X]"" Q
  1.  Q BGPLFOB
  1. BE(P,EDATE,BDATE) ;EP
  1.  I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
  1.  S BGPLBE=""
  1.  S T=$O(^ATXAX("B","BGP BE CPTS",0))
  1.  I T D  I X]"" S BGPLBE="CPT "_$P(X,U,2)_U_$$DATE^BGP1UTL($P(X,U,1))_U_$P(X,U,1)
  1.  .S X=$$CPT^BGP1DU(P,BDATE,EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BGP1DU(P,BDATE,EDATE,T,5)
  1.  .Q
  1.  S T=$O(^ATXAX("B","BGP BE CPTS",0))
  1.  I T D  I X]"",$P(BGPLBE,U,3)<X Q "RAD "_$P(X,U,2)_U_$$DATE^BGP1UTL(X)_U_X
  1.  .S X=$$RAD^BGP1DU(P,BDATE,EDATE,T,5)
  1.  .Q
  1.  Q BGPLBE
  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 ""
  1. REF(P,BDATE,EDATE) ;EP
  1.  ;refusal
  1.  S BGPT=$O(^ATXLAB("B","BGP GPRA FOB TESTS",0))
  1.  I BGPT D  I $P(G,U) Q "1^"_$P(G,U,2)_U_"REF FOB"
  1.  .S (G,BGPT1)=0 F  S BGPT1=$O(^ATXLAB(BGPT,21,"B",BGPT1)) Q:BGPT1=""!($P(G,U))  D
  1.  ..S G=$$REFUSAL^BGP1UTL1(P,60,BGPT1,BDATE,EDATE)
  1.  F BGPT=82270,82274,89205,"G0107","G0328","G0394" D  Q:$P(T,U)=1
  1.  .S C=+$$CODEN^ICPTCOD(BGPT) Q:C'>0
  1.  .S T=""
  1.  .S T=$$REFUSAL^BGP1UTL1(P,81,+$$CODEN^ICPTCOD(BGPT),$$FMADD^XLFDT(EDATE,-365),EDATE)
  1.  .I T S T="1^"_$P(T,U,2)_"^ref FOBT cpt"
  1.  I $P(T,U)=1 Q T
  1.  S BGPT=$O(^ATXAX("B","BGP SIG CPTS",0))
  1.  I BGPT S G=$$RADREF^BGP1UTL1(P,BDATE,EDATE,BGPT) I $P(G,U,1)=1 Q 1_"^"_$P(G,U,2)_"^"_"ref SIG cpt"
  1.  S BGPT=$O(^ATXAX("B","BGP BE CPTS",0))
  1.  I BGPT S G=$$RADREF^BGP1UTL1(P,BDATE,EDATE,BGPT) I $P(G,U,1)=1 Q 1_"^"_$P(G,U,2)_"^"_"ref DCBE cpt"
  1.  S BGPT=$O(^ATXAX("B","BGP COLO CPTS",0))
  1.  I BGPT S G=$$RADREF^BGP1UTL1(P,BDATE,EDATE,BGPT) I $P(G,U,1)=1 Q 1_"^"_$P(G,U,2)_"^"_"ref COLO cpt"
  1.  S BGPT=$O(^ATXAX("B","BGP SIG CPTS",0))
  1.  I BGPT S G=$$CPTREFT^BGP1UTL1(P,BDATE,EDATE,BGPT) I $P(G,U,1)=1 Q 1_"^"_$P(G,U,2)_"^"_"ref SIG cpt"
  1.  S BGPT=$O(^ATXAX("B","BGP BE CPTS",0))
  1.  I BGPT S G=$$CPTREFT^BGP1UTL1(P,BDATE,EDATE,BGPT) I $P(G,U,1)=1 Q 1_"^"_$P(G,U,2)_"^"_"ref DCBE cpt"
  1.  S BGPT=$O(^ATXAX("B","BGP COLO CPTS",0))
  1.  I BGPT S G=$$CPTREFT^BGP1UTL1(P,BDATE,EDATE,BGPT) I $P(G,U,1)=1 Q 1_"^"_$P(G,U,2)_"^"_"ref COLO cpt"
  1.  F BGPT=45.24,45.42,45.22,45.23,45.25,45.43 D  Q:$P(T,U)=1
  1.  .S C=+$$CODEN^ICDCODE(BGPT,80.1) Q:C'>0
  1.  .S T=""
  1.  .S T=$$REFUSAL^BGP1UTL1(P,80.1,C,$$FMADD^XLFDT(EDATE,-365),EDATE)
  1.  .I T S T="1^"_$P(T,U,2)_"^ref "_$S(BGPT="45.24":"SIG ",1:"COLO ")_"proc"
  1.  I $P(T,U)=1 Q T
  1.  Q ""
  1. RECT(P,EDATE) ;EP
  1.  S BDATE=$$FMADD^XLFDT(EDATE,2*(-365))
  1.  K BGPG
  1.  S %=P_"^LAST EXAM RECTAL;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)) Q "RECTAL EXAM"_"^"_$$DATE^BGP6UTL($P(BGPG(1),U))
  1.  S %=P_"^LAST DIAGNOSIS V76.41;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)) Q "RECT DX V76.41"_"^"_$$DATE^BGP6UTL($P(BGPG(1),U))
  1.  S T=$O(^ATXAX("B","BGP RECTAL PROCEDURE CODES",0))
  1.  S (F,S)=0 F  S F=$O(^AUPNVPRC("AC",P,F)) Q:F'=+F!(S)  S C=$P(^AUPNVPRC(F,0),U) D
  1.  .S G=0 S:$$ICD^ATXCHK(C,T,0) G=1
  1.  .Q:G=0
  1.  .S D=$P(^AUPNVPRC(F,0),U,6) I D="" S D=$P($P(^AUPNVSIT($P(^AUPNVPRC(F,0),U,3),0),U),".")
  1.  .I D>EDATE Q
  1.  .I D<BDATE Q
  1.  .S S=1
  1.  I S=1 Q "RECT VPRC"_"^"_$$DATE^BGP6UTL(D)_" "_$P($$ICDOP^ICDCODE(C),U,2)
  1.  S BDATE=$$FMADD^XLFDT(EDATE,-365)
  1.  S G=$$REFUSAL^BGP6UTL1(P,9999999.15,$O(^AUTTEXAM("B","RECTAL EXAM",0)),BDATE,EDATE)
  1.  I $P(G,U)=1 Q "REFUSED RECTAL EXAM"_"^"_$$DATE^BGP6UTL($P(G,U,2))
  1.  Q ""