BGP8D63 ;IHS/CMI/LAB - MEASURE LOGIC;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
CRCHED2 ;EP - ADDED V18 GPRA DEV
S (BGPN1,BGPD1)=0
S (BGPFOB,BGPLAST,BGPSIG,BGPCT,BGPCOLO,BGPFIT)=""
I BGPAGEB<50 S BGPSTOP=1 Q
I BGPAGEB>75 S BGPSTOP=1 Q
I $$CRC^BGP8D62(DFN,BGPEDATE) S BGPSTOP=1 Q ;has colorectal cancer
I 'BGPACTCL S BGPSTOP=1 Q ;ONLY AC
I BGPACTCL S BGPD1=1
CRCP ;EP - called from elder
S BGPLAST=""
S BGPFOB=$$FOB(DFN,BGPBDATE,BGPEDATE)
I BGPFOB]"" S BGPN1=1
I $P(BGPFOB,U,2)>$P(BGPLAST,U,2) S BGPLAST=BGPFOB
S BGPSIG=$$SIG(DFN,BGPEDATE)
I BGPSIG]"" S BGPN1=1
I $P(BGPSIG,U,2)>$P(BGPLAST,U,2) S BGPLAST=BGPSIG
S BGPCT=$$CT(DFN,BGPEDATE)
I BGPCT]"" S BGPN1=1
I $P(BGPCT,U,2)>$P(BGPLAST,U,2) S BGPLAST=BGPCT
S BGPCOLO=$$COLO(DFN,BGPEDATE)
I BGPCOLO]"" S BGPN1=1
I $P(BGPCOLO,U,2)>$P(BGPLAST,U,2) S BGPLAST=BGPCOLO
S BGPFIT=$$FIT(DFN,$$FMADD^XLFDT(BGPEDATE,-(3*365)),BGPEDATE)
I BGPFIT]"" S BGPN1=1
I $P(BGPFIT,U,2)>$P(BGPLAST,U,2) S BGPLAST=BGPFIT
;
S (BGPVALUD,BGPVALUE)="AC|||"_$S(BGPLAST]"":$P(BGPLAST,U,1)_": "_$$DATE^BGP8UTL($P(BGPLAST,U,2)),1:"")
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,BGPFOB,BGPLAST,BGPSIG,BGPCOLO,BGPFIT,BGPCT
Q
SIG(P,EDATE,BDATE) ;EP
NEW BGPLSIG,T,X,BGPG
S BGPLSIG=""
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))
S BGPG=$$LASTPRC^BGP8UTL1(P,"BGP SIG PROCS",BDATE,EDATE)
I $P(BGPG,U)=1 S BGPLSIG="SIG Proc "_$P(BGPG,U,2)_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="SIG CPT "_$P(X,U,2)_U_$P(X,U,1)
.S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
Q BGPLSIG
CT(P,EDATE) ;EP - CT COLONOGRAPHY
NEW BGPLCT,T,X,BGPG
S BGPLCT=""
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))
;
S T=$O(^ATXAX("B","BGP CT COLONOGRAPHY CPTS",0))
I T D I X]"" S BGPLCT="CT CPT "_$P(X,U,2)_U_$P(X,U,1)
.S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
Q BGPLCT
COLO(P,EDATE,BDATE) ;EP
NEW BGPG,BGPLCOLO,T,X
K BGPG
S BGPLCOLO=""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,10*(-365))
S BGPG=$$LASTPRC^BGP8UTL1(P,"BGP COLO PROCS",BDATE,EDATE)
I $P(BGPG,U)=1 S BGPLCOLO="COLO Proc "_$P(BGPG,U,2)_U_$P(BGPG,U,3)
S T=$O(^ATXAX("B","BGP COLO CPTS",0))
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)
.S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
Q BGPLCOLO
FOB(P,BDATE,EDATE) ;EP
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))
;I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,2*(-365))
NEW BGPLT,T,BGPC,BGPLFOB,B,E,D,X,J
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="FOBT/FIT 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="FOBT/FIT CPT "_$P(X,"^",2)_"^"_$P(X,U,1)
.S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q
Q BGPLFOB
;
FIT(P,BDATE,EDATE) ;EP
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))
;I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,2*(-365))
NEW BGPLT,T,BGPC,BGPLFOB,B,E,D,X,J
S BGPC="",BGPLFOB=""
S T=$O(^ATXAX("B","BGP FIT-DNA LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","BGP FIT-DNA 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="FIT-DNA 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 FIT-DNA CPTS",0))
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)
.S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q
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 ""
BGP8D63 ;IHS/CMI/LAB - MEASURE LOGIC;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
CRCHED2 ;EP - ADDED V18 GPRA DEV
+1 SET (BGPN1,BGPD1)=0
+2 SET (BGPFOB,BGPLAST,BGPSIG,BGPCT,BGPCOLO,BGPFIT)=""
+3 IF BGPAGEB<50
SET BGPSTOP=1
QUIT
+4 IF BGPAGEB>75
SET BGPSTOP=1
QUIT
+5 ;has colorectal cancer
IF $$CRC^BGP8D62(DFN,BGPEDATE)
SET BGPSTOP=1
QUIT
+6 ;ONLY AC
IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+7 IF BGPACTCL
SET BGPD1=1
CRCP ;EP - called from elder
+1 SET BGPLAST=""
+2 SET BGPFOB=$$FOB(DFN,BGPBDATE,BGPEDATE)
+3 IF BGPFOB]""
SET BGPN1=1
+4 IF $PIECE(BGPFOB,U,2)>$PIECE(BGPLAST,U,2)
SET BGPLAST=BGPFOB
+5 SET BGPSIG=$$SIG(DFN,BGPEDATE)
+6 IF BGPSIG]""
SET BGPN1=1
+7 IF $PIECE(BGPSIG,U,2)>$PIECE(BGPLAST,U,2)
SET BGPLAST=BGPSIG
+8 SET BGPCT=$$CT(DFN,BGPEDATE)
+9 IF BGPCT]""
SET BGPN1=1
+10 IF $PIECE(BGPCT,U,2)>$PIECE(BGPLAST,U,2)
SET BGPLAST=BGPCT
+11 SET BGPCOLO=$$COLO(DFN,BGPEDATE)
+12 IF BGPCOLO]""
SET BGPN1=1
+13 IF $PIECE(BGPCOLO,U,2)>$PIECE(BGPLAST,U,2)
SET BGPLAST=BGPCOLO
+14 SET BGPFIT=$$FIT(DFN,$$FMADD^XLFDT(BGPEDATE,-(3*365)),BGPEDATE)
+15 IF BGPFIT]""
SET BGPN1=1
+16 IF $PIECE(BGPFIT,U,2)>$PIECE(BGPLAST,U,2)
SET BGPLAST=BGPFIT
+17 ;
+18 SET (BGPVALUD,BGPVALUE)="AC|||"_$SELECT(BGPLAST]"":$PIECE(BGPLAST,U,1)_": "_$$DATE^BGP8UTL($PIECE(BGPLAST,U,2)),1:"")
+19 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,BGPFOB,BGPLAST,BGPSIG,BGPCOLO,BGPFIT,BGPCT
+20 QUIT
SIG(P,EDATE,BDATE) ;EP
+1 NEW BGPLSIG,T,X,BGPG
+2 SET BGPLSIG=""
+3 ;S BDATE=$$FMADD^XLFDT(EDATE,5*(-365))I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
IF $GET(BDATE)=""
SET BDATE=($EXTRACT(EDATE,1,3)-5)_$EXTRACT(EDATE,4,7)
SET BDATE=$$FMADD^XLFDT(BDATE,1)
+4 SET BGPG=$$LASTPRC^BGP8UTL1(P,"BGP SIG PROCS",BDATE,EDATE)
+5 IF $PIECE(BGPG,U)=1
SET BGPLSIG="SIG Proc "_$PIECE(BGPG,U,2)_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^BGP8DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+10 SET X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
IF $PIECE(BGPLSIG,U,3)<$PIECE(X,U,1)
SET BGPLSIG="SIG CPT "_$PIECE(X,U,2)_U_$PIECE(X,U,1)
+11 QUIT BGPLSIG
CT(P,EDATE) ;EP - CT COLONOGRAPHY
+1 NEW BGPLCT,T,X,BGPG
+2 SET BGPLCT=""
+3 ;S BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
IF $GET(BDATE)=""
SET BDATE=($EXTRACT(EDATE,1,3)-5)_$EXTRACT(EDATE,4,7)
SET BDATE=$$FMADD^XLFDT(BDATE,1)
+4 ;
+5 SET T=$ORDER(^ATXAX("B","BGP CT COLONOGRAPHY CPTS",0))
+6 IF T
Begin DoDot:1
+7 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+8 SET X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
SET BGPLCT="CT CPT "_$PIECE(X,U,2)_U_$PIECE(X,U,1)
+9 QUIT BGPLCT
COLO(P,EDATE,BDATE) ;EP
+1 NEW BGPG,BGPLCOLO,T,X
+2 KILL BGPG
+3 SET BGPLCOLO=""
+4 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,10*(-365))
+5 SET BGPG=$$LASTPRC^BGP8UTL1(P,"BGP COLO PROCS",BDATE,EDATE)
+6 IF $PIECE(BGPG,U)=1
SET BGPLCOLO="COLO Proc "_$PIECE(BGPG,U,2)_U_$PIECE(BGPG,U,3)
+7 SET T=$ORDER(^ATXAX("B","BGP COLO CPTS",0))
+8 IF T
Begin DoDot:1
+9 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+10 SET X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
IF $PIECE(BGPLCOLO,U,3)<$PIECE(X,U,1)
SET BGPLCOLO="COLO CPT "_$PIECE(X,U,2)_U_$PIECE(X,U,1)
+11 QUIT BGPLCOLO
FOB(P,BDATE,EDATE) ;EP
+1 ;S BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
IF $GET(BDATE)=""
SET BDATE=($EXTRACT(EDATE,1,3)-2)_$EXTRACT(EDATE,4,7)
SET BDATE=$$FMADD^XLFDT(BDATE,1)
+2 ;I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,2*(-365))
+3 NEW BGPLT,T,BGPC,BGPLFOB,B,E,D,X,J
+4 SET BGPC=""
SET BGPLFOB=""
+5 SET T=$ORDER(^ATXAX("B","BGP FOBT LOINC CODES",0))
+6 SET BGPLT=$ORDER(^ATXLAB("B","BGP GPRA FOB TESTS",0))
+7 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
+8 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+10 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+11 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC="FOBT/FIT Lab"_U_(9999999-D)
QUIT
+12 IF 'T
QUIT
+13 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+14 IF '$$LOINC(J,T)
QUIT
+15 SET BGPC="LOINC"_U_(9999999-D)
QUIT
+16 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+17 SET BGPLFOB=BGPC
+18 SET T=$ORDER(^ATXAX("B","BGP FOBT CPTS",0))
+19 IF T
Begin DoDot:1
+20 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
End DoDot:1
IF X]""
IF $PIECE(BGPLFOB,U,2)<$PIECE(X,U,1)
SET BGPLFOB="FOBT/FIT CPT "_$PIECE(X,"^",2)_"^"_$PIECE(X,U,1)
+21 QUIT BGPLFOB
+22 ;
FIT(P,BDATE,EDATE) ;EP
+1 ;S BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
IF $GET(BDATE)=""
SET BDATE=($EXTRACT(EDATE,1,3)-3)_$EXTRACT(EDATE,4,7)
SET BDATE=$$FMADD^XLFDT(BDATE,1)
+2 ;I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,2*(-365))
+3 NEW BGPLT,T,BGPC,BGPLFOB,B,E,D,X,J
+4 SET BGPC=""
SET BGPLFOB=""
+5 SET T=$ORDER(^ATXAX("B","BGP FIT-DNA LOINC CODES",0))
+6 SET BGPLT=$ORDER(^ATXLAB("B","BGP FIT-DNA TESTS",0))
+7 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
+8 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+10 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+11 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC="FIT-DNA Lab"_U_(9999999-D)
QUIT
+12 IF 'T
QUIT
+13 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+14 IF '$$LOINC(J,T)
QUIT
+15 SET BGPC="LOINC"_U_(9999999-D)
QUIT
+16 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+17 SET BGPLFOB=BGPC
+18 SET T=$ORDER(^ATXAX("B","BGP FIT-DNA CPTS",0))
+19 IF T
Begin DoDot:1
+20 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
End DoDot:1
IF X]""
IF $PIECE(BGPLFOB,U,2)<$PIECE(X,U,1)
SET BGPLFOB="FIT-DNA CPT "_$PIECE(X,"^",2)_"^"_$PIECE(X,U,1)
+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 ""
