BUDARP6N ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2013 5:11 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
K ;EP ;CRC
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUD50RB=($E(BUDBD,1,3)-51)_"1231"
S BUD75RB=($E(BUDBD,1,3)-74)_"0101"
Q:BUDDOB<BUD75RB
Q:BUDDOB>BUD50RB
Q:BUDMEDV<1
Q:$$CRC(DFN,BUDED) ;has crc dx
S BUDCRCT=$$SCREEN(DFN,,$$VD^APCLV(BUDLASTV))
I BUDCRCT]"" S BUDSECTK("CRC")=$G(BUDSECTK("CRC"))+1
;put the rest in demoninator
S BUDCRCL=""
S BUDSECTK("PTS")=$G(BUDSECTK("PTS"))+1 D
.I $G(BUDCRC2L) D
..I BUDCRCT="" D LAST S ^XTMP("BUDARP6B",BUDJ,BUDH,"CRC2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDCRCL,U) ;_U_$P(BUDCRCT,U,2)
.I $G(BUDCRC1L) D
..I BUDCRCT]"" S ^XTMP("BUDARP6B",BUDJ,BUDH,"CRC1",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDCRCT,U) ;_U_$P(BUDCRCT,U,2)
Q
LAST ;
NEW LAST,COLO,SIG,FOBT
S BUDCRCL=""
S COLO=$$COLO(DFN,$$DOB^AUPNPAT(DFN),BUDED) ;get last one ever
S BUDCRCL=COLO
S SIG=$$SIG(DFN,$$DOB^AUPNPAT(DFN),BUDED) ;get last sig
I $P(SIG,U,2)>$P(BUDCRCL,U,2) S BUDCRCL=SIG
S FOBT=$$FOB(DFN,$$DOB^AUPNPAT(DFN),BUDED)
I $P(FOBT,U,2)>$P(BUDCRCL,U,2) S BUDCRCL=FOBT
Q
SCREEN(P,BDATE,EDATE) ;
NEW BUDCOLO,BUDSIG,BUDFOB
S BUDCOLO=$$COLO(DFN,,EDATE)
I BUDCOLO]"" Q BUDCOLO
S BUDSIG=$$SIG(DFN,,EDATE)
I BUDSIG]"" Q BUDSIG
S BUDFOB=$$FOB(P,,EDATE)
I BUDFOB]"" Q BUDFOB
Q ""
CRC(P,EDATE) ;EP
NEW BUDG,X,E,Y,T
K BUDG
S Y="BUDG("
S X=P_"^LAST DX [BUD COLORECTAL CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BUDG(1)) Q 1 ;has a dx
S T=$O(^ATXAX("B","BUD COLORECTAL CANCER CPTS",0))
I T D I X]"" Q 1
.S X=$$CPT^BUDADU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BUDADU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
S BUDG=$$LASTPRC^BUDAUTL1(P,"BUD COLORECTAL CANCER PROCS",$$DOB^AUPNPAT(P),EDATE)
I BUDG Q 1
S X=$$PLTAX^BUDADU(P,"BUD COLORECTAL CANCER DXS")
I X Q 1
;S T=$O(^ATXAX("B","BUD COLORECTAL CANCER PROCS",0))
;I T D I X]"" Q 1
;.S X=$$CPT^BUDADU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
;.S X=$$TRAN^BUDADU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
Q 0
SIG(P,BDATE,EDATE) ;EP
NEW BUDLSIG
S BUDLSIG=""
I $G(BDATE)="" S BDATE=$E(EDATE,1,3)-6_$E(EDATE,4,7) ;$$FMADD^XLFDT(EDATE,6*(-365))
S BUDG=$$LASTPRC^BUDAUTL1(P,"BGP SIG PROCS",BDATE,EDATE)
I $P(BUDG,U)=1 S BUDLSIG="SIG: Proc "_$P(BUDG,U,2)_":"_$$DATE^BUDADU($P(BUDG,U,3))_U_$P(BUDG,U,3)
;
S T=$O(^ATXAX("B","BUD SIG CPTS",0))
I T D I X]"",$P(BUDLSIG,U,3)<$P(X,U,1) S BUDLSIG="SIG: CPT "_$P(X,U,2)_":"_$$DATE^BUDADU($P(X,U,1))_U_$P(X,U,1)
.S X=$$CPT^BUDADU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BUDADU(P,BDATE,EDATE,T,5)
Q BUDLSIG
COLO(P,BDATE,EDATE) ;EP
K BUDG
S BUDLCOLO=""
I $G(BDATE)="" S BDATE=$E(EDATE,1,3)-10_$E(EDATE,4,7) ;$$FMADD^XLFDT(EDATE,10*(-365))
S BUDG=$$LASTPRC^BUDAUTL1(P,"BGP COLO PROCS",BDATE,EDATE)
I $P(BUDG,U)=1 S BUDLCOLO="COLO: Proc "_$P(BUDG,U,2)_":"_$$DATE^BUDADU($P(BUDG,U,3))_U_$P(BUDG,U,3)
K BUDG
S %=P_"^LAST DIAGNOSIS [BGP COLO DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BUDG(")
I $D(BUDG(1)),$P(BUDLCOLO,U,3)<$P(BUDG(1),U,1) S BUDLCOLO="COLO: DX V76.51"_":"_$$DATE^BUDADU($P(BUDG(1),U))
S T=$O(^ATXAX("B","BUD COLO CPTS",0))
I T D I X]"",$P(BUDLCOLO,U,3)<$P(X,U,1) S BUDLCOLO="COLO: CPT "_$P(X,U,2)_":"_$$DATE^BUDADU($P(X,U,1))_U_$P(X,U,1)
.S X=$$CPT^BUDADU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BUDADU(P,BDATE,EDATE,T,5)
Q BUDLCOLO
FOB(P,BDATE,EDATE) ;EP
I $G(BDATE)="" S BDATE=$E(EDATE,1,3)-2_$E(EDATE,4,7) ;$$FMADD^XLFDT(EDATE,2*(-365))
S BUDC="",BUDLFOB=""
S T=$O(^ATXAX("B","BGP FOBT LOINC CODES",0))
S BUDLT=$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)!(BUDC]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BUDC]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BUDC]"") D
...Q:'$D(^AUPNVLAB(X,0))
...I BUDLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BUDLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BUDC="FOB: Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_":"_$$DATE^BUDADU(9999999-D)_U_(9999999-D) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S BUDC="FOB: LAB LOINC "_$$VAL^XBDIQ1(9000010.09,X,.01)_":"_$$DATE^BUDADU(9999999-D)_U_(9999999-D) Q
...Q
S BUDLFOB=BUDC
S T=$O(^ATXAX("B","BUD FOBT CPTS",0))
I T D I X]"",$P(BUDLFOB,U,2)<$P(X,U,1) S BUDLFOB="FOB: CPT "_$P(X,"^",2)_":"_$$DATE^BUDADU($P(X,U,1))_"^"_$P(X,U,1)
.S X=$$CPT^BUDADU(P,BDATE,EDATE,T,5) I X]"" Q
Q BUDLFOB
;
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 ""
BUDARP6N ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2013 5:11 PM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
K ;EP ;CRC
+1 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+2 SET BUD50RB=($EXTRACT(BUDBD,1,3)-51)_"1231"
+3 SET BUD75RB=($EXTRACT(BUDBD,1,3)-74)_"0101"
+4 IF BUDDOB<BUD75RB
QUIT
+5 IF BUDDOB>BUD50RB
QUIT
+6 IF BUDMEDV<1
QUIT
+7 ;has crc dx
IF $$CRC(DFN,BUDED)
QUIT
+8 SET BUDCRCT=$$SCREEN(DFN,,$$VD^APCLV(BUDLASTV))
+9 IF BUDCRCT]""
SET BUDSECTK("CRC")=$GET(BUDSECTK("CRC"))+1
+10 ;put the rest in demoninator
+11 SET BUDCRCL=""
+12 SET BUDSECTK("PTS")=$GET(BUDSECTK("PTS"))+1
Begin DoDot:1
+13 IF $GET(BUDCRC2L)
Begin DoDot:2
+14 ;_U_$P(BUDCRCT,U,2)
IF BUDCRCT=""
DO LAST
SET ^XTMP("BUDARP6B",BUDJ,BUDH,"CRC2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=$PIECE(BUDCRCL,U)
End DoDot:2
+15 IF $GET(BUDCRC1L)
Begin DoDot:2
+16 ;_U_$P(BUDCRCT,U,2)
IF BUDCRCT]""
SET ^XTMP("BUDARP6B",BUDJ,BUDH,"CRC1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=$PIECE(BUDCRCT,U)
End DoDot:2
End DoDot:1
+17 QUIT
LAST ;
+1 NEW LAST,COLO,SIG,FOBT
+2 SET BUDCRCL=""
+3 ;get last one ever
SET COLO=$$COLO(DFN,$$DOB^AUPNPAT(DFN),BUDED)
+4 SET BUDCRCL=COLO
+5 ;get last sig
SET SIG=$$SIG(DFN,$$DOB^AUPNPAT(DFN),BUDED)
+6 IF $PIECE(SIG,U,2)>$PIECE(BUDCRCL,U,2)
SET BUDCRCL=SIG
+7 SET FOBT=$$FOB(DFN,$$DOB^AUPNPAT(DFN),BUDED)
+8 IF $PIECE(FOBT,U,2)>$PIECE(BUDCRCL,U,2)
SET BUDCRCL=FOBT
+9 QUIT
SCREEN(P,BDATE,EDATE) ;
+1 NEW BUDCOLO,BUDSIG,BUDFOB
+2 SET BUDCOLO=$$COLO(DFN,,EDATE)
+3 IF BUDCOLO]""
QUIT BUDCOLO
+4 SET BUDSIG=$$SIG(DFN,,EDATE)
+5 IF BUDSIG]""
QUIT BUDSIG
+6 SET BUDFOB=$$FOB(P,,EDATE)
+7 IF BUDFOB]""
QUIT BUDFOB
+8 QUIT ""
CRC(P,EDATE) ;EP
+1 NEW BUDG,X,E,Y,T
+2 KILL BUDG
+3 SET Y="BUDG("
+4 SET X=P_"^LAST DX [BUD COLORECTAL CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 ;has a dx
IF $DATA(BUDG(1))
QUIT 1
+6 SET T=$ORDER(^ATXAX("B","BUD COLORECTAL CANCER CPTS",0))
+7 IF T
Begin DoDot:1
+8 SET X=$$CPT^BUDADU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
IF X]""
QUIT
+9 SET X=$$TRAN^BUDADU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
End DoDot:1
IF X]""
QUIT 1
+10 SET BUDG=$$LASTPRC^BUDAUTL1(P,"BUD COLORECTAL CANCER PROCS",$$DOB^AUPNPAT(P),EDATE)
+11 IF BUDG
QUIT 1
+12 SET X=$$PLTAX^BUDADU(P,"BUD COLORECTAL CANCER DXS")
+13 IF X
QUIT 1
+14 ;S T=$O(^ATXAX("B","BUD COLORECTAL CANCER PROCS",0))
+15 ;I T D I X]"" Q 1
+16 ;.S X=$$CPT^BUDADU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
+17 ;.S X=$$TRAN^BUDADU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
+18 QUIT 0
SIG(P,BDATE,EDATE) ;EP
+1 NEW BUDLSIG
+2 SET BUDLSIG=""
+3 ;$$FMADD^XLFDT(EDATE,6*(-365))
IF $GET(BDATE)=""
SET BDATE=$EXTRACT(EDATE,1,3)-6_$EXTRACT(EDATE,4,7)
+4 SET BUDG=$$LASTPRC^BUDAUTL1(P,"BGP SIG PROCS",BDATE,EDATE)
+5 IF $PIECE(BUDG,U)=1
SET BUDLSIG="SIG: Proc "_$PIECE(BUDG,U,2)_":"_$$DATE^BUDADU($PIECE(BUDG,U,3))_U_$PIECE(BUDG,U,3)
+6 ;
+7 SET T=$ORDER(^ATXAX("B","BUD SIG CPTS",0))
+8 IF T
Begin DoDot:1
+9 SET X=$$CPT^BUDADU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+10 SET X=$$TRAN^BUDADU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
IF $PIECE(BUDLSIG,U,3)<$PIECE(X,U,1)
SET BUDLSIG="SIG: CPT "_$PIECE(X,U,2)_":"_$$DATE^BUDADU($PIECE(X,U,1))_U_$PIECE(X,U,1)
+11 QUIT BUDLSIG
COLO(P,BDATE,EDATE) ;EP
+1 KILL BUDG
+2 SET BUDLCOLO=""
+3 ;$$FMADD^XLFDT(EDATE,10*(-365))
IF $GET(BDATE)=""
SET BDATE=$EXTRACT(EDATE,1,3)-10_$EXTRACT(EDATE,4,7)
+4 SET BUDG=$$LASTPRC^BUDAUTL1(P,"BGP COLO PROCS",BDATE,EDATE)
+5 IF $PIECE(BUDG,U)=1
SET BUDLCOLO="COLO: Proc "_$PIECE(BUDG,U,2)_":"_$$DATE^BUDADU($PIECE(BUDG,U,3))_U_$PIECE(BUDG,U,3)
+6 KILL BUDG
+7 SET %=P_"^LAST DIAGNOSIS [BGP COLO DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BUDG(")
+8 IF $DATA(BUDG(1))
IF $PIECE(BUDLCOLO,U,3)<$PIECE(BUDG(1),U,1)
SET BUDLCOLO="COLO: DX V76.51"_":"_$$DATE^BUDADU($PIECE(BUDG(1),U))
+9 SET T=$ORDER(^ATXAX("B","BUD COLO CPTS",0))
+10 IF T
Begin DoDot:1
+11 SET X=$$CPT^BUDADU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+12 SET X=$$TRAN^BUDADU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
IF $PIECE(BUDLCOLO,U,3)<$PIECE(X,U,1)
SET BUDLCOLO="COLO: CPT "_$PIECE(X,U,2)_":"_$$DATE^BUDADU($PIECE(X,U,1))_U_$PIECE(X,U,1)
+13 QUIT BUDLCOLO
FOB(P,BDATE,EDATE) ;EP
+1 ;$$FMADD^XLFDT(EDATE,2*(-365))
IF $GET(BDATE)=""
SET BDATE=$EXTRACT(EDATE,1,3)-2_$EXTRACT(EDATE,4,7)
+2 SET BUDC=""
SET BUDLFOB=""
+3 SET T=$ORDER(^ATXAX("B","BGP FOBT LOINC CODES",0))
+4 SET BUDLT=$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)!(BUDC]"")
QUIT
Begin DoDot:1
+6 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BUDC]"")
QUIT
Begin DoDot:2
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BUDC]"")
QUIT
Begin DoDot:3
+8 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+9 IF BUDLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BUDLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BUDC="FOB: Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_":"_$$DATE^BUDADU(9999999-D)_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 BUDC="FOB: LAB LOINC "_$$VAL^XBDIQ1(9000010.09,X,.01)_":"_$$DATE^BUDADU(9999999-D)_U_(9999999-D)
QUIT
+14 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+15 SET BUDLFOB=BUDC
+16 SET T=$ORDER(^ATXAX("B","BUD FOBT CPTS",0))
+17 IF T
Begin DoDot:1
+18 SET X=$$CPT^BUDADU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
End DoDot:1
IF X]""
IF $PIECE(BUDLFOB,U,2)<$PIECE(X,U,1)
SET BUDLFOB="FOB: CPT "_$PIECE(X,"^",2)_":"_$$DATE^BUDADU($PIECE(X,U,1))_"^"_$PIECE(X,U,1)
+19 QUIT BUDLFOB
+20 ;
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 ""
