BGP1D61 ; IHS/CMI/LAB - measure 31 01 Jul 2010 7:47 PM ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
I17 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
I BGPAGEB<51 S BGPSTOP=1 Q
I BGPAGEB>80 S BGPSTOP=1 Q
I $$CRC(DFN,BGPEDATE) S BGPSTOP=1 Q ;has colorectal cancer
I BGPACTUP S BGPD1=1
I BGPACTCL S BGPD2=1
I 'BGPD1 S BGPSTOP=1 Q ;need to be at least in user pop
CRCP ;EP - called from elder
S BGPFOB=$$FOB(DFN,BGPBDATE,BGPEDATE)
I BGPFOB]"" S BGPN3=1,BGPN1=1
S BGPOTH=""
I BGPN1=0 S BGPOTH=$$IBH(DFN,BGPEDATE)
I BGPOTH]"" S BGPN1=1
S BGPSIG=$$SIG(DFN,BGPEDATE)
S BGPCOLO=$$COLO(DFN,BGPEDATE)
S BGPBE=$$BE(DFN,BGPEDATE)
I BGPSIG]""!(BGPBE]"")!(BGPCOLO]"") S BGPN4=1
I BGPSIG]""!(BGPCOLO]"") S BGPN5=1
I BGPSIG]""&(BGPBE]"")!(BGPCOLO]"") S BGPN6=1
S BGPREF="" I 'BGPN1 S BGPREF=$$REF(DFN,$$FMADD^XLFDT(BGPEDATE,-365),BGPEDATE) I BGPREF S BGPN1=1,BGPN2=1
I BGPN1,'BGPN2 S BGPN7=1
S BGPVALUE=""
I BGPFOB]"" S BGPVALUE="FOB: "_$$DATE^BGP1UTL($P(BGPFOB,U,2))_" "_$P(BGPFOB,U)
;I BGPOTH]"" S BGPVALUE=BGPVALUE_$P(BGPOTH,U)_":"_$P(BGPOTH,U,2)_" "
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)
I BGPBE]"" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"") S BGPVALUE=BGPVALUE_"BE: "_$P(BGPBE,U,2)_" "_$P(BGPBE,U,1)
I BGPREF]"" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"") S BGPVALUE=BGPVALUE_$$DATE^BGP1UTL($P(BGPREF,U,2))_" "_$P(BGPREF,U,3)
S BGPDV=$S(BGPD1:"UP",1:"")_$S(BGPD2:",AC",1:"")
S BGPVALUE=BGPDV_"|||"_BGPVALUE
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P
Q
IBH(P,EDATE) ;EP
NEW VALUE
S VALUE=""
S VALUE=$$SIG(P,EDATE)
I VALUE]"" Q VALUE
S VALUE=$$BE(P,EDATE)
I VALUE]"" Q VALUE
S VALUE=$$COLO(P,EDATE)
I VALUE]"" Q VALUE
Q ""
CRC(P,EDATE) ;EP
K BGPG
S Y="BGPG("
S X=P_"^LAST DX [BGP COLORECTAL CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1 ;has a dx
S T=$O(^ATXAX("B","BGP COLORECTAL CANCER CPTS",0))
I T D I X]"" Q 1
.S X=$$CPT^BGP1DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP1DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
S BGPG=$$LASTPRC^BGP1UTL1(P,"BGP TOTAL COLECTOMY PROCS",$$DOB^AUPNPAT(P),EDATE)
I BGPG Q 1
S T=$O(^ATXAX("B","BGP TOTAL COLECTOMY CPTS",0))
I T D I X]"" Q 1
.S X=$$CPT^BGP1DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP1DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
Q 0
SIG(P,EDATE,BDATE) ;EP
NEW BGPLSIG
S BGPLSIG=""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
;S BGPG=$$LASTPRCI^BGP1UTL1(P,"45.24",BDATE,EDATE)
S BGPG=$$LASTPRC^BGP1UTL1(P,"BGP SIG PROCS",BDATE,EDATE)
;I $P(BGPG,U)=1 S BGPLSIG="SIG "_$P(BGPG,U,2)_"^"_$$DATE^BGP1UTL($P(BGPG,U,3))_U_$P(BGPG,U,3)
I $P(BGPG,U)=1 S BGPLSIG=$P(BGPG,U,2)_"^"_$$DATE^BGP1UTL($P(BGPG,U,3))_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="CPT SIG "_$P(X,U,2)_U_$$DATE^BGP1UTL($P(X,U,1))_U_$P(X,U,1)
.S X=$$CPT^BGP1DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP1DU(P,BDATE,EDATE,T,5)
Q BGPLSIG
COLO(P,EDATE,BDATE) ;EP
K BGPG
S BGPLCOLO=""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,10*(-365))
S BGPG=$$LASTPRC^BGP1UTL1(P,"BGP COLO PROCS",BDATE,EDATE)
I $P(BGPG,U)=1 S BGPLCOLO=$P(BGPG,U,2)_"^"_$$DATE^BGP1UTL($P(BGPG,U,3))_U_$P(BGPG,U,3)
S %=P_"^LAST DIAGNOSIS [BGP COLO DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)),$P(BGPLCOLO,U,3)<$P(BGPG(1),U,1) S BGPLCOLO="DX V76.51"_"^"_$$DATE^BGP1UTL($P(BGPG(1),U))
S T=$O(^ATXAX("B","BGP COLO CPTS",0))
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)
.S X=$$CPT^BGP1DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP1DU(P,BDATE,EDATE,T,5)
Q BGPLCOLO
FOB(P,BDATE,EDATE) ;EP
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,2*(-365))
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="V 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="CPT "_$P(X,"^",2)_"^"_$P(X,U,1)
.S X=$$CPT^BGP1DU(P,BDATE,EDATE,T,5) I X]"" Q
Q BGPLFOB
BE(P,EDATE,BDATE) ;EP
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
S BGPLBE=""
S T=$O(^ATXAX("B","BGP BE CPTS",0))
I T D I X]"" S BGPLBE="CPT "_$P(X,U,2)_U_$$DATE^BGP1UTL($P(X,U,1))_U_$P(X,U,1)
.S X=$$CPT^BGP1DU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP1DU(P,BDATE,EDATE,T,5)
.Q
S T=$O(^ATXAX("B","BGP BE CPTS",0))
I T D I X]"",$P(BGPLBE,U,3)<X Q "RAD "_$P(X,U,2)_U_$$DATE^BGP1UTL(X)_U_X
.S X=$$RAD^BGP1DU(P,BDATE,EDATE,T,5)
.Q
Q BGPLBE
;
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 ""
REF(P,BDATE,EDATE) ;EP
;refusal
S BGPT=$O(^ATXLAB("B","BGP GPRA FOB TESTS",0))
I BGPT D I $P(G,U) Q "1^"_$P(G,U,2)_U_"REF FOB"
.S (G,BGPT1)=0 F S BGPT1=$O(^ATXLAB(BGPT,21,"B",BGPT1)) Q:BGPT1=""!($P(G,U)) D
..S G=$$REFUSAL^BGP1UTL1(P,60,BGPT1,BDATE,EDATE)
F BGPT=82270,82274,89205,"G0107","G0328","G0394" D Q:$P(T,U)=1
.S C=+$$CODEN^ICPTCOD(BGPT) Q:C'>0
.S T=""
.S T=$$REFUSAL^BGP1UTL1(P,81,+$$CODEN^ICPTCOD(BGPT),$$FMADD^XLFDT(EDATE,-365),EDATE)
.I T S T="1^"_$P(T,U,2)_"^ref FOBT cpt"
I $P(T,U)=1 Q T
S BGPT=$O(^ATXAX("B","BGP SIG CPTS",0))
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"
S BGPT=$O(^ATXAX("B","BGP BE CPTS",0))
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"
S BGPT=$O(^ATXAX("B","BGP COLO CPTS",0))
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"
S BGPT=$O(^ATXAX("B","BGP SIG CPTS",0))
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"
S BGPT=$O(^ATXAX("B","BGP BE CPTS",0))
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"
S BGPT=$O(^ATXAX("B","BGP COLO CPTS",0))
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"
F BGPT=45.24,45.42,45.22,45.23,45.25,45.43 D Q:$P(T,U)=1
.S C=+$$CODEN^ICDCODE(BGPT,80.1) Q:C'>0
.S T=""
.S T=$$REFUSAL^BGP1UTL1(P,80.1,C,$$FMADD^XLFDT(EDATE,-365),EDATE)
.I T S T="1^"_$P(T,U,2)_"^ref "_$S(BGPT="45.24":"SIG ",1:"COLO ")_"proc"
I $P(T,U)=1 Q T
Q ""
RECT(P,EDATE) ;EP
S BDATE=$$FMADD^XLFDT(EDATE,2*(-365))
K BGPG
S %=P_"^LAST EXAM RECTAL;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "RECTAL EXAM"_"^"_$$DATE^BGP6UTL($P(BGPG(1),U))
S %=P_"^LAST DIAGNOSIS V76.41;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "RECT DX V76.41"_"^"_$$DATE^BGP6UTL($P(BGPG(1),U))
S T=$O(^ATXAX("B","BGP RECTAL PROCEDURE CODES",0))
S (F,S)=0 F S F=$O(^AUPNVPRC("AC",P,F)) Q:F'=+F!(S) S C=$P(^AUPNVPRC(F,0),U) D
.S G=0 S:$$ICD^ATXCHK(C,T,0) G=1
.Q:G=0
.S D=$P(^AUPNVPRC(F,0),U,6) I D="" S D=$P($P(^AUPNVSIT($P(^AUPNVPRC(F,0),U,3),0),U),".")
.I D>EDATE Q
.I D<BDATE Q
.S S=1
I S=1 Q "RECT VPRC"_"^"_$$DATE^BGP6UTL(D)_" "_$P($$ICDOP^ICDCODE(C),U,2)
S BDATE=$$FMADD^XLFDT(EDATE,-365)
S G=$$REFUSAL^BGP6UTL1(P,9999999.15,$O(^AUTTEXAM("B","RECTAL EXAM",0)),BDATE,EDATE)
I $P(G,U)=1 Q "REFUSED RECTAL EXAM"_"^"_$$DATE^BGP6UTL($P(G,U,2))
Q ""
BGP1D61 ; IHS/CMI/LAB - measure 31 01 Jul 2010 7:47 PM ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
I17 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 IF BGPAGEB<51
SET BGPSTOP=1
QUIT
+3 IF BGPAGEB>80
SET BGPSTOP=1
QUIT
+4 ;has colorectal cancer
IF $$CRC(DFN,BGPEDATE)
SET BGPSTOP=1
QUIT
+5 IF BGPACTUP
SET BGPD1=1
+6 IF BGPACTCL
SET BGPD2=1
+7 ;need to be at least in user pop
IF 'BGPD1
SET BGPSTOP=1
QUIT
CRCP ;EP - called from elder
+1 SET BGPFOB=$$FOB(DFN,BGPBDATE,BGPEDATE)
+2 IF BGPFOB]""
SET BGPN3=1
SET BGPN1=1
+3 SET BGPOTH=""
+4 IF BGPN1=0
SET BGPOTH=$$IBH(DFN,BGPEDATE)
+5 IF BGPOTH]""
SET BGPN1=1
+6 SET BGPSIG=$$SIG(DFN,BGPEDATE)
+7 SET BGPCOLO=$$COLO(DFN,BGPEDATE)
+8 SET BGPBE=$$BE(DFN,BGPEDATE)
+9 IF BGPSIG]""!(BGPBE]"")!(BGPCOLO]"")
SET BGPN4=1
+10 IF BGPSIG]""!(BGPCOLO]"")
SET BGPN5=1
+11 IF BGPSIG]""&(BGPBE]"")!(BGPCOLO]"")
SET BGPN6=1
+12 SET BGPREF=""
IF 'BGPN1
SET BGPREF=$$REF(DFN,$$FMADD^XLFDT(BGPEDATE,-365),BGPEDATE)
IF BGPREF
SET BGPN1=1
SET BGPN2=1
+13 IF BGPN1
IF 'BGPN2
SET BGPN7=1
+14 SET BGPVALUE=""
+15 IF BGPFOB]""
SET BGPVALUE="FOB: "_$$DATE^BGP1UTL($PIECE(BGPFOB,U,2))_" "_$PIECE(BGPFOB,U)
+16 ;I BGPOTH]"" S BGPVALUE=BGPVALUE_$P(BGPOTH,U)_":"_$P(BGPOTH,U,2)_" "
+17 IF BGPSIG]""
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"SIG: "_$PIECE(BGPSIG,U,2)_" "_$PIECE(BGPSIG,U,1)
+18 IF BGPCOLO]""
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"COLO: "_$PIECE(BGPCOLO,U,2)_" "_$PIECE(BGPCOLO,U,1)
+19 IF BGPBE]""
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_"BE: "_$PIECE(BGPBE,U,2)_" "_$PIECE(BGPBE,U,1)
+20 IF BGPREF]""
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")
SET BGPVALUE=BGPVALUE_$$DATE^BGP1UTL($PIECE(BGPREF,U,2))_" "_$PIECE(BGPREF,U,3)
+21 SET BGPDV=$SELECT(BGPD1:"UP",1:"")_$SELECT(BGPD2:",AC",1:"")
+22 SET BGPVALUE=BGPDV_"|||"_BGPVALUE
+23 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P
+24 QUIT
IBH(P,EDATE) ;EP
+1 NEW VALUE
+2 SET VALUE=""
+3 SET VALUE=$$SIG(P,EDATE)
+4 IF VALUE]""
QUIT VALUE
+5 SET VALUE=$$BE(P,EDATE)
+6 IF VALUE]""
QUIT VALUE
+7 SET VALUE=$$COLO(P,EDATE)
+8 IF VALUE]""
QUIT VALUE
+9 QUIT ""
CRC(P,EDATE) ;EP
+1 KILL BGPG
+2 SET Y="BGPG("
+3 SET X=P_"^LAST DX [BGP COLORECTAL CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 ;has a dx
IF $DATA(BGPG(1))
QUIT 1
+5 SET T=$ORDER(^ATXAX("B","BGP COLORECTAL CANCER CPTS",0))
+6 IF T
Begin DoDot:1
+7 SET X=$$CPT^BGP1DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
IF X]""
QUIT
+8 SET X=$$TRAN^BGP1DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
End DoDot:1
IF X]""
QUIT 1
+9 SET BGPG=$$LASTPRC^BGP1UTL1(P,"BGP TOTAL COLECTOMY PROCS",$$DOB^AUPNPAT(P),EDATE)
+10 IF BGPG
QUIT 1
+11 SET T=$ORDER(^ATXAX("B","BGP TOTAL COLECTOMY CPTS",0))
+12 IF T
Begin DoDot:1
+13 SET X=$$CPT^BGP1DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
IF X]""
QUIT
+14 SET X=$$TRAN^BGP1DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
End DoDot:1
IF X]""
QUIT 1
+15 QUIT 0
SIG(P,EDATE,BDATE) ;EP
+1 NEW BGPLSIG
+2 SET BGPLSIG=""
+3 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
+4 ;S BGPG=$$LASTPRCI^BGP1UTL1(P,"45.24",BDATE,EDATE)
+5 SET BGPG=$$LASTPRC^BGP1UTL1(P,"BGP SIG PROCS",BDATE,EDATE)
+6 ;I $P(BGPG,U)=1 S BGPLSIG="SIG "_$P(BGPG,U,2)_"^"_$$DATE^BGP1UTL($P(BGPG,U,3))_U_$P(BGPG,U,3)
+7 IF $PIECE(BGPG,U)=1
SET BGPLSIG=$PIECE(BGPG,U,2)_"^"_$$DATE^BGP1UTL($PIECE(BGPG,U,3))_U_$PIECE(BGPG,U,3)
+8 ;
+9 SET T=$ORDER(^ATXAX("B","BGP SIG CPTS",0))
+10 IF T
Begin DoDot:1
+11 SET X=$$CPT^BGP1DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+12 SET X=$$TRAN^BGP1DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
IF $PIECE(BGPLSIG,U,3)<$PIECE(X,U,1)
SET BGPLSIG="CPT SIG "_$PIECE(X,U,2)_U_$$DATE^BGP1UTL($PIECE(X,U,1))_U_$PIECE(X,U,1)
+13 QUIT BGPLSIG
COLO(P,EDATE,BDATE) ;EP
+1 KILL BGPG
+2 SET BGPLCOLO=""
+3 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,10*(-365))
+4 SET BGPG=$$LASTPRC^BGP1UTL1(P,"BGP COLO PROCS",BDATE,EDATE)
+5 IF $PIECE(BGPG,U)=1
SET BGPLCOLO=$PIECE(BGPG,U,2)_"^"_$$DATE^BGP1UTL($PIECE(BGPG,U,3))_U_$PIECE(BGPG,U,3)
+6 SET %=P_"^LAST DIAGNOSIS [BGP COLO DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+7 IF $DATA(BGPG(1))
IF $PIECE(BGPLCOLO,U,3)<$PIECE(BGPG(1),U,1)
SET BGPLCOLO="DX V76.51"_"^"_$$DATE^BGP1UTL($PIECE(BGPG(1),U))
+8 SET T=$ORDER(^ATXAX("B","BGP COLO CPTS",0))
+9 IF T
Begin DoDot:1
+10 SET X=$$CPT^BGP1DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+11 SET X=$$TRAN^BGP1DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
IF $PIECE(BGPLCOLO,U,3)<$PIECE(X,U,1)
SET BGPLCOLO="CPT "_$PIECE(X,U,2)_U_$$DATE^BGP1UTL($PIECE(X,U,1))_U_$PIECE(X,U,1)
+12 QUIT BGPLCOLO
FOB(P,BDATE,EDATE) ;EP
+1 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,2*(-365))
+2 SET BGPC=""
SET BGPLFOB=""
+3 SET T=$ORDER(^ATXAX("B","BGP FOBT LOINC CODES",0))
+4 SET BGPLT=$ORDER(^ATXLAB("B","BGP GPRA FOB TESTS",0))
+5 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
+6 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+8 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+9 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC="V LAB"_U_(9999999-D)
QUIT
+10 IF 'T
QUIT
+11 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+12 IF '$$LOINC(J,T)
QUIT
+13 SET BGPC="LOINC"_U_(9999999-D)
QUIT
+14 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+15 SET BGPLFOB=BGPC
+16 SET T=$ORDER(^ATXAX("B","BGP FOBT CPTS",0))
+17 IF T
Begin DoDot:1
+18 SET X=$$CPT^BGP1DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
End DoDot:1
IF X]""
IF $PIECE(BGPLFOB,U,2)<$PIECE(X,U,1)
SET BGPLFOB="CPT "_$PIECE(X,"^",2)_"^"_$PIECE(X,U,1)
+19 QUIT BGPLFOB
BE(P,EDATE,BDATE) ;EP
+1 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,5*(-365))
+2 SET BGPLBE=""
+3 SET T=$ORDER(^ATXAX("B","BGP BE CPTS",0))
+4 IF T
Begin DoDot:1
+5 SET X=$$CPT^BGP1DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+6 SET X=$$TRAN^BGP1DU(P,BDATE,EDATE,T,5)
+7 QUIT
End DoDot:1
IF X]""
SET BGPLBE="CPT "_$PIECE(X,U,2)_U_$$DATE^BGP1UTL($PIECE(X,U,1))_U_$PIECE(X,U,1)
+8 SET T=$ORDER(^ATXAX("B","BGP BE CPTS",0))
+9 IF T
Begin DoDot:1
+10 SET X=$$RAD^BGP1DU(P,BDATE,EDATE,T,5)
+11 QUIT
End DoDot:1
IF X]""
IF $PIECE(BGPLBE,U,3)<X
QUIT "RAD "_$PIECE(X,U,2)_U_$$DATE^BGP1UTL(X)_U_X
+12 QUIT BGPLBE
+13 ;
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 ""
REF(P,BDATE,EDATE) ;EP
+1 ;refusal
+2 SET BGPT=$ORDER(^ATXLAB("B","BGP GPRA FOB TESTS",0))
+3 IF BGPT
Begin DoDot:1
+4 SET (G,BGPT1)=0
FOR
SET BGPT1=$ORDER(^ATXLAB(BGPT,21,"B",BGPT1))
IF BGPT1=""!($PIECE(G,U))
QUIT
Begin DoDot:2
+5 SET G=$$REFUSAL^BGP1UTL1(P,60,BGPT1,BDATE,EDATE)
End DoDot:2
End DoDot:1
IF $PIECE(G,U)
QUIT "1^"_$PIECE(G,U,2)_U_"REF FOB"
+6 FOR BGPT=82270,82274,89205,"G0107","G0328","G0394"
Begin DoDot:1
+7 SET C=+$$CODEN^ICPTCOD(BGPT)
IF C'>0
QUIT
+8 SET T=""
+9 SET T=$$REFUSAL^BGP1UTL1(P,81,+$$CODEN^ICPTCOD(BGPT),$$FMADD^XLFDT(EDATE,-365),EDATE)
+10 IF T
SET T="1^"_$PIECE(T,U,2)_"^ref FOBT cpt"
End DoDot:1
IF $PIECE(T,U)=1
QUIT
+11 IF $PIECE(T,U)=1
QUIT T
+12 SET BGPT=$ORDER(^ATXAX("B","BGP SIG CPTS",0))
+13 IF BGPT
SET G=$$RADREF^BGP1UTL1(P,BDATE,EDATE,BGPT)
IF $PIECE(G,U,1)=1
QUIT 1_"^"_$PIECE(G,U,2)_"^"_"ref SIG cpt"
+14 SET BGPT=$ORDER(^ATXAX("B","BGP BE CPTS",0))
+15 IF BGPT
SET G=$$RADREF^BGP1UTL1(P,BDATE,EDATE,BGPT)
IF $PIECE(G,U,1)=1
QUIT 1_"^"_$PIECE(G,U,2)_"^"_"ref DCBE cpt"
+16 SET BGPT=$ORDER(^ATXAX("B","BGP COLO CPTS",0))
+17 IF BGPT
SET G=$$RADREF^BGP1UTL1(P,BDATE,EDATE,BGPT)
IF $PIECE(G,U,1)=1
QUIT 1_"^"_$PIECE(G,U,2)_"^"_"ref COLO cpt"
+18 SET BGPT=$ORDER(^ATXAX("B","BGP SIG CPTS",0))
+19 IF BGPT
SET G=$$CPTREFT^BGP1UTL1(P,BDATE,EDATE,BGPT)
IF $PIECE(G,U,1)=1
QUIT 1_"^"_$PIECE(G,U,2)_"^"_"ref SIG cpt"
+20 SET BGPT=$ORDER(^ATXAX("B","BGP BE CPTS",0))
+21 IF BGPT
SET G=$$CPTREFT^BGP1UTL1(P,BDATE,EDATE,BGPT)
IF $PIECE(G,U,1)=1
QUIT 1_"^"_$PIECE(G,U,2)_"^"_"ref DCBE cpt"
+22 SET BGPT=$ORDER(^ATXAX("B","BGP COLO CPTS",0))
+23 IF BGPT
SET G=$$CPTREFT^BGP1UTL1(P,BDATE,EDATE,BGPT)
IF $PIECE(G,U,1)=1
QUIT 1_"^"_$PIECE(G,U,2)_"^"_"ref COLO cpt"
+24 FOR BGPT=45.24,45.42,45.22,45.23,45.25,45.43
Begin DoDot:1
+25 SET C=+$$CODEN^ICDCODE(BGPT,80.1)
IF C'>0
QUIT
+26 SET T=""
+27 SET T=$$REFUSAL^BGP1UTL1(P,80.1,C,$$FMADD^XLFDT(EDATE,-365),EDATE)
+28 IF T
SET T="1^"_$PIECE(T,U,2)_"^ref "_$SELECT(BGPT="45.24":"SIG ",1:"COLO ")_"proc"
End DoDot:1
IF $PIECE(T,U)=1
QUIT
+29 IF $PIECE(T,U)=1
QUIT T
+30 QUIT ""
RECT(P,EDATE) ;EP
+1 SET BDATE=$$FMADD^XLFDT(EDATE,2*(-365))
+2 KILL BGPG
+3 SET %=P_"^LAST EXAM RECTAL;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
QUIT "RECTAL EXAM"_"^"_$$DATE^BGP6UTL($PIECE(BGPG(1),U))
+5 SET %=P_"^LAST DIAGNOSIS V76.41;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+6 IF $DATA(BGPG(1))
QUIT "RECT DX V76.41"_"^"_$$DATE^BGP6UTL($PIECE(BGPG(1),U))
+7 SET T=$ORDER(^ATXAX("B","BGP RECTAL PROCEDURE CODES",0))
+8 SET (F,S)=0
FOR
SET F=$ORDER(^AUPNVPRC("AC",P,F))
IF F'=+F!(S)
QUIT
SET C=$PIECE(^AUPNVPRC(F,0),U)
Begin DoDot:1
+9 SET G=0
IF $$ICD^ATXCHK(C,T,0)
SET G=1
+10 IF G=0
QUIT
+11 SET D=$PIECE(^AUPNVPRC(F,0),U,6)
IF D=""
SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),U),".")
+12 IF D>EDATE
QUIT
+13 IF D<BDATE
QUIT
+14 SET S=1
End DoDot:1
+15 IF S=1
QUIT "RECT VPRC"_"^"_$$DATE^BGP6UTL(D)_" "_$PIECE($$ICDOP^ICDCODE(C),U,2)
+16 SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+17 SET G=$$REFUSAL^BGP6UTL1(P,9999999.15,$ORDER(^AUTTEXAM("B","RECTAL EXAM",0)),BDATE,EDATE)
+18 IF $PIECE(G,U)=1
QUIT "REFUSED RECTAL EXAM"_"^"_$$DATE^BGP6UTL($PIECE(G,U,2))
+19 QUIT ""
