BUDCRP6N ; IHS/CMI/LAB - UDS REPORT ;
;;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)
S BUDCRCT=$$SCREEN(DFN,,$$VD^APCLV(BUDLASTV))
I BUDCRCT]"" S BUDSECTK("CRC")=$G(BUDSECTK("CRC"))+1
S BUDCRCL=""
S BUDSECTK("PTS")=$G(BUDSECTK("PTS"))+1 D
.I $G(BUDCRC2L) D
..I BUDCRCT="" D LAST S ^XTMP("BUDCRP6B",BUDJ,BUDH,"CRC2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDCRCL,U)
.I $G(BUDCRC1L) D
..I BUDCRCT]"" S ^XTMP("BUDCRP6B",BUDJ,BUDH,"CRC1",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDCRCT,U)
Q
LAST ;
NEW LAST,COLO,SIG,FOBT
S BUDCRCL=""
S COLO=$$COLO(DFN,$$DOB^AUPNPAT(DFN),BUDED)
S BUDCRCL=COLO
S SIG=$$SIG(DFN,$$DOB^AUPNPAT(DFN),BUDED)
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 [BGP COLORECTAL CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BUDG(1)) Q 1
S T=$O(^ATXAX("B","BUD COLORECTAL CANCER CPTS",0))
I T D I X]"" Q 1
.S X=$$CPT^BUDCDU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BUDCDU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
S BUDG=$$LASTPRC^BUDCUTL1(P,"BGP TOTAL COLECTOMY PROCS",$$DOB^AUPNPAT(P),EDATE)
I BUDG Q 1
S X=$$PLTAX^BUDCDU(P,"BGP COLORECTAL CANCER DXS")
I X Q 1
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)
S BUDG=$$LASTPRC^BUDCUTL1(P,"BGP SIG PROCS",BDATE,EDATE)
I $P(BUDG,U)=1 S BUDLSIG="SIG: Proc "_$P(BUDG,U,2)_":"_$$DATE^BUDCDU($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^BUDCDU($P(X,U,1))_U_$P(X,U,1)
.S X=$$CPT^BUDCDU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BUDCDU(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)
S BUDG=$$LASTPRC^BUDCUTL1(P,"BGP COLO PROCS",BDATE,EDATE)
I $P(BUDG,U)=1 S BUDLCOLO="COLO: Proc "_$P(BUDG,U,2)_":"_$$DATE^BUDCDU($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 "_$P(BUDG(1),U,2)_":"_$$DATE^BUDCDU($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^BUDCDU($P(X,U,1))_U_$P(X,U,1)
.S X=$$CPT^BUDCDU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BUDCDU(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)
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^BUDCDU(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^BUDCDU(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^BUDCDU($P(X,U,1))_"^"_$P(X,U,1)
.S X=$$CPT^BUDCDU(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 ""
;
DEPLIST1 ;EP
D EOJ
S BUDDEP1L=1
D DEP1
G EN1^BUDCRP6B
DEPLIST2 ;EP
D EOJ
S BUDDEP2L=1
D DEP2
G EN1^BUDCRP6B
DEP1 ;EP
W:$D(IOF) @IOF
W !,$$CTR($$LOC^BUDCRP6S,80)
W !,$$CTR("UDS 2015",80)
W !!,"All Patients 12+ w/Depression Scrn & if Positive a Follow-up Plan (Table 6B)",!
D GENI
D PAUSE
W !!,"This report provides a list of all patients 12 years and older who were "
W !,"screened for depression with a standardized tool during the report year"
W !,"and had a follow-up plan documented if screened positive, and had at"
W !,"least one medical visit during the report year."
W !
Q
DEP1L ;EP
S BUDP=0,BUDQUIT=0,BUDTOT=0
D DEP1H Q:BUDQUIT
I '$D(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP1")) W:BUDROT="P" !!,"No patients to report." D:BUDROT="D" S() D:BUDROT="D" S("No patients to report.") Q
D DEP1L1
I BUDROT="P",$Y>(IOSL-3) D DEP1H Q:BUDQUIT
I BUDROT="P" W !,"TOTAL PATIENTS WITH DEP SCRN & IF POSITIVE, FOLLOW-UP: ",BUDTOT,!
I BUDROT="D" D S(),S("TOTAL PATIENTS WITH DEP SCRN & IF POSITIVE, FOLLOW-UP: "_BUDTOT)
Q
DEP1L1 ;
I BUDROT="P",$Y>(IOSL-7) D DEP1H Q:BUDQUIT
S BUDAGE="" F S BUDAGE=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP1",BUDAGE)) Q:BUDAGE=""!(BUDQUIT) D
.S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
..S BUDCOM="" F S BUDCOM=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME,BUDCOM)) Q:BUDCOM=""!(BUDQUIT) D
...S DFN=0 F S DFN=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME,BUDCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT) D
....I BUDROT="P",$Y>(IOSL-3) D DEP1H Q:BUDQUIT
....I BUDROT="P" W !,$E($P(^DPT(DFN,0),U,1),1,25),?29,$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?41,$E(BUDCOM,1,25),?70,$P(^DPT(DFN,0),U,2),?75,BUDAGE,!
....S BUDTOT=BUDTOT+1
....S BUDALL=^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME,BUDCOM,DFN)
....S BUD1=$P(BUDALL,"|",1),BUD2=$P(BUDALL,"|",2)
....I BUD1]"",BUDROT="P" W ?5,$P(BUD1,U,2),": ",$P(BUD1,U,3),": ",$$FMTE^XLFDT($P(BUD1,U,1),5)
....I BUDROT="P" W ?35,"Follow-up: " I BUD2]"" W $P(BUD2,U,2),": ",$$FMTE^XLFDT($P(BUD2,U,1),5)
....I BUDROT="D" S X=$P(^DPT(DFN,0),U,1)_U_$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_BUDCOM_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCAD) D
.....I BUD1]"" S X=X_U_$P(BUD1,U,2)_": "_$P(BUD1,U,3)_": "_$$FMTE^XLFDT($P(BUD1,U,1),5)
.....S X=X_U_"Follow-up: "
.....I BUD2]"" S X=X_$P(BUD2,U,2)_": "_$$FMTE^XLFDT($P(BUD2,U,1),5)
.....D S(X)
Q
DEP1HD ;
D S(),S(),S()
D S("***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****")
D S($P(^VA(200,DUZ,0),U,2)_" "_$$FMTE^XLFDT(DT))
D S("*** RPMS Uniform Data System (UDS) ***")
D S("Patient List for Table 6B, Section M")
D S("Patients Screened for Depression and Followed Up if Appropriate")
D S($P(^DIC(4,BUDSITE,0),U))
S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) D S(X)
S X="Population: "_$S($G(BUDCEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDCEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDCEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"") D S(X)
D S()
D S("This report provides a list of all patients 12 years and older who were ")
D S("screened for depression with a standardized tool during the report year and")
D S("had a follow-up plan documented if screened positive, and had at least one")
D S("medical visit during the report year. ")
D S("Age is calculated as of December 31.")
D S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^Depression Scrn: Date/Result^Follow-up Plan: Date")
Q
DEP1H ;
I BUDROT="D" D DEP1HD Q
G:'BUDGPG DEP1H1
K DIR I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BUDQUIT=1 Q
DEP1H1 ;
W:$D(IOF) @IOF S BUDGPG=BUDGPG+1
W !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
W !,$$CTR("*** RPMS Uniform Data System (UDS) ***",80)
W !,$$CTR("Patient List for Table 6B, Section M,",80),!,$$CTR("Patients Screened for Depression and Followed Up if Appropriate",80),!
W $$CTR($P(^DIC(4,BUDSITE,0),U),80),!
S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) W $$CTR(X,80),!
S X="Population: "_$S($G(BUDCEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDCEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDCEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"") W $$CTR(X,80),!
W $TR($J("",80)," ","-")
I BUDP=0 D
.W !!,"This report provides a list of all patients 12 years and older who were "
.W !,"screened for depression with a standardized tool during the report year and"
.W !,"had a follow-up plan documented if screened positive, and had at least one"
.W !,"medical visit during the report year. "
.W !,"Age is calculated as of December 31."
W !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"
W !?5,"Depression Scrn: Date/Result",?35,"Follow-up Plan: Date"
W !,$TR($J("",80)," ","-"),!
S BUDP=1
Q
DEP2 ;EP
W:$D(IOF) @IOF
W !,$$CTR($$LOC^BUDCRP6S,80)
W !,$$CTR("UDS 2015",80)
W !!,"All Patients 12+ w/o Depression Scrn or w/o Follow-up (Table 6B)",!
D GENI
D PAUSE
W !!,"This report provides a list of all patients 12 years and older not"
W !,"screened for depression or who were screened for depression with a"
W !,"standardized tool during the report year and does not have a follow-up"
W !,"plan documented if screened positive, and had at least one medical visit"
W !,"during the report year."
W !
Q
DEP2L ;EP
S BUDP=0,BUDQUIT=0,BUDTOT=0
D DEP2H Q:BUDQUIT
I '$D(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP2")) W:BUDROT="P" !!,"No patients to report." D:BUDROT="D" S() D:BUDROT="D" S("No patients to report.") Q
D DEP2L1
I BUDROT="P",$Y>(IOSL-3) D DEP2H Q:BUDQUIT
I BUDROT="P" W !,"TOTAL PATIENTS W/O DEP SCRN OR W/O FOLLOW-UP IF POSITIVE: ",BUDTOT,!
I BUDROT="D" D S(),S("TOTAL PATIENTS W/O DEP SCRN OR W/O FOLLOW-UP IF POSITIVE: "_BUDTOT)
Q
DEP2L1 ;
I BUDROT="P",$Y>(IOSL-7) D DEP2H Q:BUDQUIT
S BUDAGE="" F S BUDAGE=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP2",BUDAGE)) Q:BUDAGE=""!(BUDQUIT) D
.S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
..S BUDCOM="" F S BUDCOM=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME,BUDCOM)) Q:BUDCOM=""!(BUDQUIT) D
...S DFN=0 F S DFN=$O(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME,BUDCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT) D
....I BUDROT="P",$Y>(IOSL-3) D DEP2H Q:BUDQUIT
....I BUDROT="P" W !,$E($P(^DPT(DFN,0),U,1),1,25),?29,$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?41,$E(BUDCOM,1,25),?70,$P(^DPT(DFN,0),U,2),?75,BUDAGE,!
....S BUDTOT=BUDTOT+1
....S BUDALL=^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME,BUDCOM,DFN)
....S BUD1=$P(BUDALL,"|",1),BUD2=$P(BUDALL,"|",2)
....I BUD1]"" I BUDROT="P" W ?5,$P(BUD1,U,2),": ",$P(BUD1,U,3),": ",$$FMTE^XLFDT($P(BUD1,U,1),5)
....I BUDROT="P" W ?35,"Follow-up: " I BUD2]"" W $P(BUD2,U,2),": ",$$FMTE^XLFDT($P(BUD2,U,1),5)
....I BUDROT="D" S X=$P(^DPT(DFN,0),U,1)_U_$S($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_BUDCOM_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCAD) D
.....I BUD1]"" S X=X_U_$P(BUD1,U,2)_": "_$P(BUD1,U,3)_": "_$$FMTE^XLFDT($P(BUD1,U,1),5)
.....I BUD1="" S X=X_U
.....S X=X_U_"Follow-up: "
.....I BUD2]"" S X=X_$P(BUD2,U,2)_": "_$$FMTE^XLFDT($P(BUD2,U,1),5)
.....D S(X)
Q
DEP2HD ;
D S(),S(),S()
D S("***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****")
D S($P(^VA(200,DUZ,0),U,2)_" "_$$FMTE^XLFDT(DT))
D S("*** RPMS Uniform Data System (UDS) ***")
D S("Patient List for Table 6B, Section M")
D S("Patients not Screened for Depression or w/o follow up")
D S($P(^DIC(4,BUDSITE,0),U))
S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) D S(X)
S X="Population: "_$S($G(BUDCEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDCEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDCEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"") D S(X)
D S()
D S("This report provides a list of all patients 12 years and older not")
D S("screened for depression or who were screened for depression with a")
D S("standardized tool during the report year and does not have a follow-up")
D S("plan documented if screened positive, and had at least one medical visit")
D S("during the report year.")
D S("Age is calculated as of December 31.")
D S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^Depression Scrn: Date/Result^Follow-up Plan: Date")
Q
DEP2H ;
I BUDROT="D" D DEP2HD Q
G:'BUDGPG DEP2H1
K DIR I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BUDQUIT=1 Q
DEP2H1 ;
W:$D(IOF) @IOF S BUDGPG=BUDGPG+1
W !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
W !,$$CTR("*** RPMS Uniform Data System (UDS) ***",80)
W !,$$CTR("Patient List for Table 6B, Section M,",80),!,$$CTR("Patients not Screened for Depression or w/o Follow-up",80),!
W $$CTR($P(^DIC(4,BUDSITE,0),U),80),!
S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) W $$CTR(X,80),!
S X="Population: "_$S($G(BUDCEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDCEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDCEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"") W $$CTR(X,80),!
W $TR($J("",80)," ","-")
I BUDP=0 D
.W !!,"This report provides a list of all patients 12 years and older not"
.W !,"screened for depression or who were screened for depression with a"
.W !,"standardized tool during the report year and does not have a follow-up"
.W !,"plan documented if screened positive, and had at least one medical visit"
.W !,"during the report year."
.W !,"Age is calculated as of December 31."
W !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"
W !?5,"Depression Scrn: Date/Result",?35,"Follow-up Plan: Date"
W !,$TR($J("",80)," ","-"),!
S BUDP=1
Q
S(V) ;
S BUDDECNT=BUDDECNT+1
S ^TMP($J,"BUDDEL",BUDDECNT)=$G(V)
Q
PAUSE ;
K DIR S DIR(0)="E",DIR("A")="PRESS ENTER" KILL DA D ^DIR KILL DIR
Q
GENI ;EP
D GENI^BUDCRP6I
Q
;
CTR(X,Y) ;
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
EOJ ;
D EN^XBVK("BUD")
Q
BUDCRP6N ; IHS/CMI/LAB - UDS REPORT ;
+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 IF $$CRC(DFN,BUDED)
QUIT
+8 SET BUDCRCT=$$SCREEN(DFN,,$$VD^APCLV(BUDLASTV))
+9 IF BUDCRCT]""
SET BUDSECTK("CRC")=$GET(BUDSECTK("CRC"))+1
+10 SET BUDCRCL=""
+11 SET BUDSECTK("PTS")=$GET(BUDSECTK("PTS"))+1
Begin DoDot:1
+12 IF $GET(BUDCRC2L)
Begin DoDot:2
+13 IF BUDCRCT=""
DO LAST
SET ^XTMP("BUDCRP6B",BUDJ,BUDH,"CRC2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=$PIECE(BUDCRCL,U)
End DoDot:2
+14 IF $GET(BUDCRC1L)
Begin DoDot:2
+15 IF BUDCRCT]""
SET ^XTMP("BUDCRP6B",BUDJ,BUDH,"CRC1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=$PIECE(BUDCRCT,U)
End DoDot:2
End DoDot:1
+16 QUIT
LAST ;
+1 NEW LAST,COLO,SIG,FOBT
+2 SET BUDCRCL=""
+3 SET COLO=$$COLO(DFN,$$DOB^AUPNPAT(DFN),BUDED)
+4 SET BUDCRCL=COLO
+5 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 [BGP COLORECTAL CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 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^BUDCDU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
IF X]""
QUIT
+9 SET X=$$TRAN^BUDCDU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
End DoDot:1
IF X]""
QUIT 1
+10 SET BUDG=$$LASTPRC^BUDCUTL1(P,"BGP TOTAL COLECTOMY PROCS",$$DOB^AUPNPAT(P),EDATE)
+11 IF BUDG
QUIT 1
+12 SET X=$$PLTAX^BUDCDU(P,"BGP COLORECTAL CANCER DXS")
+13 IF X
QUIT 1
+14 QUIT 0
SIG(P,BDATE,EDATE) ;EP
+1 NEW BUDLSIG
+2 SET BUDLSIG=""
+3 IF $GET(BDATE)=""
SET BDATE=$EXTRACT(EDATE,1,3)-6_$EXTRACT(EDATE,4,7)
+4 SET BUDG=$$LASTPRC^BUDCUTL1(P,"BGP SIG PROCS",BDATE,EDATE)
+5 IF $PIECE(BUDG,U)=1
SET BUDLSIG="SIG: Proc "_$PIECE(BUDG,U,2)_":"_$$DATE^BUDCDU($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^BUDCDU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+10 SET X=$$TRAN^BUDCDU(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^BUDCDU($PIECE(X,U,1))_U_$PIECE(X,U,1)
+11 QUIT BUDLSIG
COLO(P,BDATE,EDATE) ;EP
+1 KILL BUDG
+2 SET BUDLCOLO=""
+3 IF $GET(BDATE)=""
SET BDATE=$EXTRACT(EDATE,1,3)-10_$EXTRACT(EDATE,4,7)
+4 SET BUDG=$$LASTPRC^BUDCUTL1(P,"BGP COLO PROCS",BDATE,EDATE)
+5 IF $PIECE(BUDG,U)=1
SET BUDLCOLO="COLO: Proc "_$PIECE(BUDG,U,2)_":"_$$DATE^BUDCDU($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 "_$PIECE(BUDG(1),U,2)_":"_$$DATE^BUDCDU($PIECE(BUDG(1),U))
+9 SET T=$ORDER(^ATXAX("B","BUD COLO CPTS",0))
+10 IF T
Begin DoDot:1
+11 SET X=$$CPT^BUDCDU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+12 SET X=$$TRAN^BUDCDU(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^BUDCDU($PIECE(X,U,1))_U_$PIECE(X,U,1)
+13 QUIT BUDLCOLO
FOB(P,BDATE,EDATE) ;EP
+1 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^BUDCDU(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^BUDCDU(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^BUDCDU(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^BUDCDU($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 ""
+7 ;
DEPLIST1 ;EP
+1 DO EOJ
+2 SET BUDDEP1L=1
+3 DO DEP1
+4 GOTO EN1^BUDCRP6B
DEPLIST2 ;EP
+1 DO EOJ
+2 SET BUDDEP2L=1
+3 DO DEP2
+4 GOTO EN1^BUDCRP6B
DEP1 ;EP
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,$$CTR($$LOC^BUDCRP6S,80)
+3 WRITE !,$$CTR("UDS 2015",80)
+4 WRITE !!,"All Patients 12+ w/Depression Scrn & if Positive a Follow-up Plan (Table 6B)",!
+5 DO GENI
+6 DO PAUSE
+7 WRITE !!,"This report provides a list of all patients 12 years and older who were "
+8 WRITE !,"screened for depression with a standardized tool during the report year"
+9 WRITE !,"and had a follow-up plan documented if screened positive, and had at"
+10 WRITE !,"least one medical visit during the report year."
+11 WRITE !
+12 QUIT
DEP1L ;EP
+1 SET BUDP=0
SET BUDQUIT=0
SET BUDTOT=0
+2 DO DEP1H
IF BUDQUIT
QUIT
+3 IF '$DATA(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP1"))
IF BUDROT="P"
WRITE !!,"No patients to report."
IF BUDROT="D"
DO S()
IF BUDROT="D"
DO S("No patients to report.")
QUIT
+4 DO DEP1L1
+5 IF BUDROT="P"
IF $Y>(IOSL-3)
DO DEP1H
IF BUDQUIT
QUIT
+6 IF BUDROT="P"
WRITE !,"TOTAL PATIENTS WITH DEP SCRN & IF POSITIVE, FOLLOW-UP: ",BUDTOT,!
+7 IF BUDROT="D"
DO S()
DO S("TOTAL PATIENTS WITH DEP SCRN & IF POSITIVE, FOLLOW-UP: "_BUDTOT)
+8 QUIT
DEP1L1 ;
+1 IF BUDROT="P"
IF $Y>(IOSL-7)
DO DEP1H
IF BUDQUIT
QUIT
+2 SET BUDAGE=""
FOR
SET BUDAGE=$ORDER(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP1",BUDAGE))
IF BUDAGE=""!(BUDQUIT)
QUIT
Begin DoDot:1
+3 SET BUDNAME=""
FOR
SET BUDNAME=$ORDER(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME))
IF BUDNAME=""!(BUDQUIT)
QUIT
Begin DoDot:2
+4 SET BUDCOM=""
FOR
SET BUDCOM=$ORDER(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME,BUDCOM))
IF BUDCOM=""!(BUDQUIT)
QUIT
Begin DoDot:3
+5 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME,BUDCOM,DFN))
IF DFN'=+DFN!(BUDQUIT)
QUIT
Begin DoDot:4
+6 IF BUDROT="P"
IF $Y>(IOSL-3)
DO DEP1H
IF BUDQUIT
QUIT
+7 IF BUDROT="P"
WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U,1),1,25),?29,$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?41,$EXTRACT(BUDCOM,1,25),?70,$PIECE(^DPT(DFN,0),U,2),?75,B
UDAGE,!
+8 SET BUDTOT=BUDTOT+1
+9 SET BUDALL=^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME,BUDCOM,DFN)
+10 SET BUD1=$PIECE(BUDALL,"|",1)
SET BUD2=$PIECE(BUDALL,"|",2)
+11 IF BUD1]""
IF BUDROT="P"
WRITE ?5,$PIECE(BUD1,U,2),": ",$PIECE(BUD1,U,3),": ",$$FMTE^XLFDT($PIECE(BUD1,U,1),5)
+12 IF BUDROT="P"
WRITE ?35,"Follow-up: "
IF BUD2]""
WRITE $PIECE(BUD2,U,2),": ",$$FMTE^XLFDT($PIECE(BUD2,U,1),5)
+13 IF BUDROT="D"
SET X=$PIECE(^DPT(DFN,0),U,1)_U_$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_BUDCOM_U_$PIECE(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCAD)
Begin DoDot:5
+14 IF BUD1]""
SET X=X_U_$PIECE(BUD1,U,2)_": "_$PIECE(BUD1,U,3)_": "_$$FMTE^XLFDT($PIECE(BUD1,U,1),5)
+15 SET X=X_U_"Follow-up: "
+16 IF BUD2]""
SET X=X_$PIECE(BUD2,U,2)_": "_$$FMTE^XLFDT($PIECE(BUD2,U,1),5)
+17 DO S(X)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
DEP1HD ;
+1 DO S()
DO S()
DO S()
+2 DO S("***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****")
+3 DO S($PIECE(^VA(200,DUZ,0),U,2)_" "_$$FMTE^XLFDT(DT))
+4 DO S("*** RPMS Uniform Data System (UDS) ***")
+5 DO S("Patient List for Table 6B, Section M")
+6 DO S("Patients Screened for Depression and Followed Up if Appropriate")
+7 DO S($PIECE(^DIC(4,BUDSITE,0),U))
+8 SET X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED)
DO S(X)
+9 SET X="Population: "_$SELECT($GET(BUDCEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDCEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDCEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"")
DO S(X)
+10 DO S()
+11 DO S("This report provides a list of all patients 12 years and older who were ")
+12 DO S("screened for depression with a standardized tool during the report year and")
+13 DO S("had a follow-up plan documented if screened positive, and had at least one")
+14 DO S("medical visit during the report year. ")
+15 DO S("Age is calculated as of December 31.")
+16 DO S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^Depression Scrn: Date/Result^Follow-up Plan: Date")
+17 QUIT
DEP1H ;
+1 IF BUDROT="D"
DO DEP1HD
QUIT
+2 IF 'BUDGPG
GOTO DEP1H1
+3 KILL DIR
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
IF '$DATA(ZTQUEUED)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BUDQUIT=1
QUIT
DEP1H1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET BUDGPG=BUDGPG+1
+2 WRITE !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
+3 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
+4 WRITE !,$$CTR("*** RPMS Uniform Data System (UDS) ***",80)
+5 WRITE !,$$CTR("Patient List for Table 6B, Section M,",80),!,$$CTR("Patients Screened for Depression and Followed Up if Appropriate",80),!
+6 WRITE $$CTR($PIECE(^DIC(4,BUDSITE,0),U),80),!
+7 SET X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED)
WRITE $$CTR(X,80),!
+8 SET X="Population: "_$SELECT($GET(BUDCEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDCEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDCEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"")
WRITE $$CTR(X,80),!
+9 WRITE $TRANSLATE($JUSTIFY("",80)," ","-")
+10 IF BUDP=0
Begin DoDot:1
+11 WRITE !!,"This report provides a list of all patients 12 years and older who were "
+12 WRITE !,"screened for depression with a standardized tool during the report year and"
+13 WRITE !,"had a follow-up plan documented if screened positive, and had at least one"
+14 WRITE !,"medical visit during the report year. "
+15 WRITE !,"Age is calculated as of December 31."
End DoDot:1
+16 WRITE !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"
+17 WRITE !?5,"Depression Scrn: Date/Result",?35,"Follow-up Plan: Date"
+18 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-"),!
+19 SET BUDP=1
+20 QUIT
DEP2 ;EP
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,$$CTR($$LOC^BUDCRP6S,80)
+3 WRITE !,$$CTR("UDS 2015",80)
+4 WRITE !!,"All Patients 12+ w/o Depression Scrn or w/o Follow-up (Table 6B)",!
+5 DO GENI
+6 DO PAUSE
+7 WRITE !!,"This report provides a list of all patients 12 years and older not"
+8 WRITE !,"screened for depression or who were screened for depression with a"
+9 WRITE !,"standardized tool during the report year and does not have a follow-up"
+10 WRITE !,"plan documented if screened positive, and had at least one medical visit"
+11 WRITE !,"during the report year."
+12 WRITE !
+13 QUIT
DEP2L ;EP
+1 SET BUDP=0
SET BUDQUIT=0
SET BUDTOT=0
+2 DO DEP2H
IF BUDQUIT
QUIT
+3 IF '$DATA(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP2"))
IF BUDROT="P"
WRITE !!,"No patients to report."
IF BUDROT="D"
DO S()
IF BUDROT="D"
DO S("No patients to report.")
QUIT
+4 DO DEP2L1
+5 IF BUDROT="P"
IF $Y>(IOSL-3)
DO DEP2H
IF BUDQUIT
QUIT
+6 IF BUDROT="P"
WRITE !,"TOTAL PATIENTS W/O DEP SCRN OR W/O FOLLOW-UP IF POSITIVE: ",BUDTOT,!
+7 IF BUDROT="D"
DO S()
DO S("TOTAL PATIENTS W/O DEP SCRN OR W/O FOLLOW-UP IF POSITIVE: "_BUDTOT)
+8 QUIT
DEP2L1 ;
+1 IF BUDROT="P"
IF $Y>(IOSL-7)
DO DEP2H
IF BUDQUIT
QUIT
+2 SET BUDAGE=""
FOR
SET BUDAGE=$ORDER(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP2",BUDAGE))
IF BUDAGE=""!(BUDQUIT)
QUIT
Begin DoDot:1
+3 SET BUDNAME=""
FOR
SET BUDNAME=$ORDER(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME))
IF BUDNAME=""!(BUDQUIT)
QUIT
Begin DoDot:2
+4 SET BUDCOM=""
FOR
SET BUDCOM=$ORDER(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME,BUDCOM))
IF BUDCOM=""!(BUDQUIT)
QUIT
Begin DoDot:3
+5 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME,BUDCOM,DFN))
IF DFN'=+DFN!(BUDQUIT)
QUIT
Begin DoDot:4
+6 IF BUDROT="P"
IF $Y>(IOSL-3)
DO DEP2H
IF BUDQUIT
QUIT
+7 IF BUDROT="P"
WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U,1),1,25),?29,$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2)),?41,$EXTRACT(BUDCOM,1,25),?70,$PIECE(^DPT(DFN,0),U,2),?75,B
UDAGE,!
+8 SET BUDTOT=BUDTOT+1
+9 SET BUDALL=^XTMP("BUDCRP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME,BUDCOM,DFN)
+10 SET BUD1=$PIECE(BUDALL,"|",1)
SET BUD2=$PIECE(BUDALL,"|",2)
+11 IF BUD1]""
IF BUDROT="P"
WRITE ?5,$PIECE(BUD1,U,2),": ",$PIECE(BUD1,U,3),": ",$$FMTE^XLFDT($PIECE(BUD1,U,1),5)
+12 IF BUDROT="P"
WRITE ?35,"Follow-up: "
IF BUD2]""
WRITE $PIECE(BUD2,U,2),": ",$$FMTE^XLFDT($PIECE(BUD2,U,1),5)
+13 IF BUDROT="D"
SET X=$PIECE(^DPT(DFN,0),U,1)_U_$SELECT($$HRN^AUPNPAT(DFN,BUDSITE)]"":$$HRN^AUPNPAT(DFN,BUDSITE,2),1:$$HRN^AUPNPAT(DFN,DUZ(2),2))_U_BUDCOM_U_$PIECE(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCAD)
Begin DoDot:5
+14 IF BUD1]""
SET X=X_U_$PIECE(BUD1,U,2)_": "_$PIECE(BUD1,U,3)_": "_$$FMTE^XLFDT($PIECE(BUD1,U,1),5)
+15 IF BUD1=""
SET X=X_U
+16 SET X=X_U_"Follow-up: "
+17 IF BUD2]""
SET X=X_$PIECE(BUD2,U,2)_": "_$$FMTE^XLFDT($PIECE(BUD2,U,1),5)
+18 DO S(X)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT
DEP2HD ;
+1 DO S()
DO S()
DO S()
+2 DO S("***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****")
+3 DO S($PIECE(^VA(200,DUZ,0),U,2)_" "_$$FMTE^XLFDT(DT))
+4 DO S("*** RPMS Uniform Data System (UDS) ***")
+5 DO S("Patient List for Table 6B, Section M")
+6 DO S("Patients not Screened for Depression or w/o follow up")
+7 DO S($PIECE(^DIC(4,BUDSITE,0),U))
+8 SET X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED)
DO S(X)
+9 SET X="Population: "_$SELECT($GET(BUDCEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDCEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDCEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"")
DO S(X)
+10 DO S()
+11 DO S("This report provides a list of all patients 12 years and older not")
+12 DO S("screened for depression or who were screened for depression with a")
+13 DO S("standardized tool during the report year and does not have a follow-up")
+14 DO S("plan documented if screened positive, and had at least one medical visit")
+15 DO S("during the report year.")
+16 DO S("Age is calculated as of December 31.")
+17 DO S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^Depression Scrn: Date/Result^Follow-up Plan: Date")
+18 QUIT
DEP2H ;
+1 IF BUDROT="D"
DO DEP2HD
QUIT
+2 IF 'BUDGPG
GOTO DEP2H1
+3 KILL DIR
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
IF '$DATA(ZTQUEUED)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BUDQUIT=1
QUIT
DEP2H1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET BUDGPG=BUDGPG+1
+2 WRITE !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
+3 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
+4 WRITE !,$$CTR("*** RPMS Uniform Data System (UDS) ***",80)
+5 WRITE !,$$CTR("Patient List for Table 6B, Section M,",80),!,$$CTR("Patients not Screened for Depression or w/o Follow-up",80),!
+6 WRITE $$CTR($PIECE(^DIC(4,BUDSITE,0),U),80),!
+7 SET X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED)
WRITE $$CTR(X,80),!
+8 SET X="Population: "_$SELECT($GET(BUDCEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDCEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDCEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"")
WRITE $$CTR(X,80),!
+9 WRITE $TRANSLATE($JUSTIFY("",80)," ","-")
+10 IF BUDP=0
Begin DoDot:1
+11 WRITE !!,"This report provides a list of all patients 12 years and older not"
+12 WRITE !,"screened for depression or who were screened for depression with a"
+13 WRITE !,"standardized tool during the report year and does not have a follow-up"
+14 WRITE !,"plan documented if screened positive, and had at least one medical visit"
+15 WRITE !,"during the report year."
+16 WRITE !,"Age is calculated as of December 31."
End DoDot:1
+17 WRITE !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"
+18 WRITE !?5,"Depression Scrn: Date/Result",?35,"Follow-up Plan: Date"
+19 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-"),!
+20 SET BUDP=1
+21 QUIT
S(V) ;
+1 SET BUDDECNT=BUDDECNT+1
+2 SET ^TMP($JOB,"BUDDEL",BUDDECNT)=$GET(V)
+3 QUIT
PAUSE ;
+1 KILL DIR
SET DIR(0)="E"
SET DIR("A")="PRESS ENTER"
KILL DA
DO ^DIR
KILL DIR
+2 QUIT
GENI ;EP
+1 DO GENI^BUDCRP6I
+2 QUIT
+3 ;
CTR(X,Y) ;
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
EOJ ;
+1 DO EN^XBVK("BUD")
+2 QUIT
