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

BGP8D63.m

Go to the documentation of this file. 
  1. BGP8D63 ;IHS/CMI/LAB - MEASURE LOGIC;
  1.  ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
  1.  ;
  1. CRCHED2 ;EP - ADDED V18 GPRA DEV
  1.  S (BGPN1,BGPD1)=0
  1.  S (BGPFOB,BGPLAST,BGPSIG,BGPCT,BGPCOLO,BGPFIT)=""
  1.  I BGPAGEB<50 S BGPSTOP=1 Q
  1.  I BGPAGEB>75 S BGPSTOP=1 Q
  1.  I $$CRC^BGP8D62(DFN,BGPEDATE) S BGPSTOP=1 Q  ;has colorectal cancer
  1.  I 'BGPACTCL S BGPSTOP=1 Q  ;ONLY AC
  1.  I BGPACTCL S BGPD1=1
  1. CRCP ;EP - called from elder
  1.  S BGPLAST=""
  1.  S BGPFOB=$$FOB(DFN,BGPBDATE,BGPEDATE)
  1.  I BGPFOB]"" S BGPN1=1
  1.  I $P(BGPFOB,U,2)>$P(BGPLAST,U,2) S BGPLAST=BGPFOB
  1.  S BGPSIG=$$SIG(DFN,BGPEDATE)
  1.  I BGPSIG]"" S BGPN1=1
  1.  I $P(BGPSIG,U,2)>$P(BGPLAST,U,2) S BGPLAST=BGPSIG
  1.  S BGPCT=$$CT(DFN,BGPEDATE)
  1.  I BGPCT]"" S BGPN1=1
  1.  I $P(BGPCT,U,2)>$P(BGPLAST,U,2) S BGPLAST=BGPCT
  1.  S BGPCOLO=$$COLO(DFN,BGPEDATE)
  1.  I BGPCOLO]"" S BGPN1=1
  1.  I $P(BGPCOLO,U,2)>$P(BGPLAST,U,2) S BGPLAST=BGPCOLO
  1.  S BGPFIT=$$FIT(DFN,$$FMADD^XLFDT(BGPEDATE,-(3*365)),BGPEDATE)
  1.  I BGPFIT]"" S BGPN1=1
  1.  I $P(BGPFIT,U,2)>$P(BGPLAST,U,2) S BGPLAST=BGPFIT
  1.  ;
  1.  S (BGPVALUD,BGPVALUE)="AC|||"_$S(BGPLAST]"":$P(BGPLAST,U,1)_": "_$$DATE^BGP8UTL($P(BGPLAST,U,2)),1:"")
  1.  K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,BGPFOB,BGPLAST,BGPSIG,BGPCOLO,BGPFIT,BGPCT
  1.  Q
  1. SIG(P,EDATE,BDATE) ;EP
  1.  NEW BGPLSIG,T,X,BGPG
  1.  S BGPLSIG=""
  1.  I $G(BDATE)="" S BDATE=($E(EDATE,1,3)-5)_$E(EDATE,4,7),BDATE=$$FMADD^XLFDT(BDATE,1) ;S BDATE=$$FMADD^XLFDT(EDATE,5*(-365))I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
  1.  S BGPG=$$LASTPRC^BGP8UTL1(P,"BGP SIG PROCS",BDATE,EDATE)
  1.  I $P(BGPG,U)=1 S BGPLSIG="SIG Proc "_$P(BGPG,U,2)_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="SIG CPT "_$P(X,U,2)_U_$P(X,U,1)
  1.  .S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
  1.  Q BGPLSIG
  1. CT(P,EDATE) ;EP - CT COLONOGRAPHY
  1.  NEW BGPLCT,T,X,BGPG
  1.  S BGPLCT=""
  1.  I $G(BDATE)="" S BDATE=($E(EDATE,1,3)-5)_$E(EDATE,4,7),BDATE=$$FMADD^XLFDT(BDATE,1) ;S BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
  1.  ;
  1.  S T=$O(^ATXAX("B","BGP CT COLONOGRAPHY CPTS",0))
  1.  I T D  I X]"" S BGPLCT="CT CPT "_$P(X,U,2)_U_$P(X,U,1)
  1.  .S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
  1.  Q BGPLCT
  1. COLO(P,EDATE,BDATE) ;EP
  1.  NEW BGPG,BGPLCOLO,T,X
  1.  K BGPG
  1.  S BGPLCOLO=""
  1.  I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,10*(-365))
  1.  S BGPG=$$LASTPRC^BGP8UTL1(P,"BGP COLO PROCS",BDATE,EDATE)
  1.  I $P(BGPG,U)=1 S BGPLCOLO="COLO Proc "_$P(BGPG,U,2)_U_$P(BGPG,U,3)
  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="COLO CPT "_$P(X,U,2)_U_$P(X,U,1)
  1.  .S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
  1.  Q BGPLCOLO
  1. FOB(P,BDATE,EDATE) ;EP
  1.  I $G(BDATE)="" S BDATE=($E(EDATE,1,3)-2)_$E(EDATE,4,7),BDATE=$$FMADD^XLFDT(BDATE,1) ;S BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
  1.  ;I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,2*(-365))
  1.  NEW BGPLT,T,BGPC,BGPLFOB,B,E,D,X,J
  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="FOBT/FIT 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="FOBT/FIT CPT "_$P(X,"^",2)_"^"_$P(X,U,1)
  1.  .S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q
  1.  Q BGPLFOB
  1.  ;
  1. FIT(P,BDATE,EDATE) ;EP
  1.  I $G(BDATE)="" S BDATE=($E(EDATE,1,3)-3)_$E(EDATE,4,7),BDATE=$$FMADD^XLFDT(BDATE,1) ;S BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
  1.  ;I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,2*(-365))
  1.  NEW BGPLT,T,BGPC,BGPLFOB,B,E,D,X,J
  1.  S BGPC="",BGPLFOB=""
  1.  S T=$O(^ATXAX("B","BGP FIT-DNA LOINC CODES",0))
  1.  S BGPLT=$O(^ATXLAB("B","BGP FIT-DNA 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="FIT-DNA 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 FIT-DNA CPTS",0))
  1.  I T D  I X]"",$P(BGPLFOB,U,2)<$P(X,U,1) S BGPLFOB="FIT-DNA CPT "_$P(X,"^",2)_"^"_$P(X,U,1)
  1.  .S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q
  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 ""