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

BGP1D64.m

Go to the documentation of this file. 
  1. BGP1D64 ; 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. ICCS ;EP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
  1.  I 'BGPACTCL S BGPSTOP=1 Q  ;not active clinical and must be
  1.  ;
  1.  S BGPCERV=$$DEN7^BGP1D3(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
  1.  S BGPBREAS=$$DEN8^BGP1D4(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
  1.  S BGPCRCS="" I BGPAGEB>50,BGPAGEB<81,'$$CRC^BGP1D61(DFN,BGPEDATE) S BGPCRCS=1
  1.  ;if cervical cancer, did they have a pap
  1.  S BGPPAP="" I BGPCERV S BGPPAP=$$PAP^BGP1D3(DFN,BGPEDATE,3,1)
  1.  S BGPMAM="" I BGPBREAS S BGPMAM=$$MAM^BGP1D4(DFN,BGPEDATE,2,1)
  1.  S BGPCRC="" I BGPCRCS S BGPCRC=$$CRCS(DFN,BGPBDATE,BGPEDATE)
  1.  ;W !,BGPCRC
  1.  ;BGPN1 will be set to 1 if the patient had all eligible screenings
  1.  S BGPN1=1
  1.  I BGPCERV,BGPPAP="" S BGPN1=0
  1.  I BGPBREAS,BGPMAM="" S BGPN1=0
  1.  I BGPCRCS,BGPCRC="" S BGPN1=0
  1.  I (BGPCERV+BGPBREAS+BGPCRCS) S BGPD1=1
  1.  I 'BGPD1 Q  ;not eligible for any
  1.  S BGPDV="AC"
  1.  I BGPCERV S BGPDV=BGPDV_",PAP"
  1.  I BGPBREAS S BGPDV=BGPDV_",MAM"
  1.  I BGPCRCS S BGPDV=BGPDV_",CRCS"
  1.  S BGPVALUE=$S(BGPPAP]"":"PAP: "_$$DATE^BGP1UTL($P(BGPPAP,U,2))_" "_$P(BGPPAP,U,3),1:"")
  1.  I BGPMAM]"" S:BGPVALUE]"" BGPVALUE=BGPVALUE_"; " S BGPVALUE=BGPVALUE_$S(BGPMAM]"":"MAM: "_$$DATE^BGP1UTL($P(BGPMAM,U,2))_" "_$P(BGPMAM,U,3),1:"")
  1.  I BGPCRC]"" S:BGPVALUE]"" BGPVALUE=BGPVALUE_"; " S BGPVALUE=BGPVALUE_$S(BGPCRC]"":"CRCS: "_$P(BGPCRC,U,2)_" "_$P(BGPCRC,U,1),1:"")
  1.  S BGPVALUE=BGPDV_"|||"_BGPVALUE
  1.  K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P
  1.  Q
  1. CRCS(P,BDATE,EDATE) ;
  1.  NEW VALUE
  1.  S VALUE=""
  1.  S VALUE=$$SIG^BGP1D61(P,EDATE)
  1.  I VALUE]"" Q VALUE
  1.  S VALUE=$$COLO^BGP1D61(P,EDATE)
  1.  I VALUE]"" Q VALUE
  1.  S VALUE=$$FOB^BGP1D61(P,BDATE,EDATE)
  1.  I VALUE]"" Q $P(VALUE,U,1)_"^"_$$DATE^BGP1UTL($P(VALUE,U,2))_"^"_VALUE
  1.  S VALUE=$$BE^BGP1D61(P,EDATE)
  1.  I VALUE]"" Q VALUE
  1.  Q ""
  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.  ;
  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="COLO "_$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="COLO 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 COLO "_$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.  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="FOB DX V76.51"_"^"_$P(BGPG(1),U)
  1.  I BGPLFOB="" Q ""
  1.  Q $P(BGPLFOB,U,1)_U_$$DATE^BGP1UTL($P(BGPLFOB,U,2))
  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 ""