BUDERP6N ; IHS/CMI/LAB - UDS REPORT ;
;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
;
K ;EP ;CRC
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUD50RB=($E(BUDBD,1,3)-50)_"1231"
S BUD75RB=($E(BUDBD,1,3)-75)_"0101"
Q:BUDDOB<BUD75RB
Q:BUDDOB>BUD50RB
Q:BUDMEDV<1
Q:$$CRC(DFN,BUDED)
S BUDDRCT=$$SCREEN(DFN,BUDBD,BUDED)
I BUDDRCT]"" S BUDSECTK("CRC")=$G(BUDSECTK("CRC"))+1
S BUDDRCL=""
S BUDSECTK("PTS")=$G(BUDSECTK("PTS"))+1 D
.I $G(BUDDRC2L) D
..I BUDDRCT="" D LAST S ^XTMP("BUDERP6B",BUDJ,BUDH,"CRC2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDDRCL,U)
.I $G(BUDDRC1L) D
..I BUDDRCT]"" S ^XTMP("BUDERP6B",BUDJ,BUDH,"CRC1",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDDRCT,U)
Q
LAST ;
NEW LAST,COLO,SIG,FOBT
S BUDDRCL=""
S COLO=$$COLO(DFN,$$DOB^AUPNPAT(DFN),BUDED)
S BUDDRCL=COLO
S SIG=$$SIG(DFN,$$DOB^AUPNPAT(DFN),BUDED)
I $P(SIG,U,2)>$P(BUDDRCL,U,2) S BUDDRCL=SIG
S FOBT=$$FOB(DFN,$$DOB^AUPNPAT(DFN),BUDED)
I $P(FOBT,U,2)>$P(BUDDRCL,U,2) S BUDDRCL=FOBT
Q
SCREEN(P,BDATE,EDATE) ;
NEW BUDDOLO,BUDSIG,BUDFOB
S BUDDOLO=$$COLO(DFN,,EDATE)
I BUDDOLO]"" Q BUDDOLO
S BUDSIG=$$SIG(DFN,,EDATE)
I BUDSIG]"" Q BUDSIG
S BUDFOB=$$FOB(P,BDATE,EDATE)
I BUDFOB]"" Q BUDFOB
Q ""
CRC(P,EDATE) ;EP
NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB,BDATE
S BDATE=$$DOB^AUPNPAT(P)
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S BUDTOB=0
S TIEN=$O(^BUDETSSC("B","T6B CRC CANCER CODES",0))
S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR!(BUDTOB) D
.S VIEN=$P(BUDVS(CTR),U,5)
.S VDATE=$P(BUDVS(CTR),U,1)
.;POV/SNOMED
.S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X!(BUDTOB) D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDETSSC("AD",Y,TIEN)) S BUDTOB=1 Q
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDETSSC("AS",Y,TIEN)) S BUDTOB=1 Q
.;CPT
.S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X!(BUDTOB) D
..Q:'$D(^AUPNVCPT(X,0))
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..Q:Y=""
..I $D(^BUDETSSC("AC",Y,TIEN)) S BUDTOB=1 Q
.;V TRANS
.S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X!(BUDTOB) D
..Q:'$D(^AUPNVTC(X,0))
..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
..Q:Y=""
..I $D(^BUDETSSC("AC",Y,TIEN)) S BUDTOB=1 Q
.;V PROC
.S X=0 F S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X!(BUDTOB) D
..Q:'$D(^AUPNVPRC(X,0))
..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
..I $D(^BUDETSSC("AP",Y,TIEN)) S BUDTOB=1 Q
I BUDTOB Q 1
S Y=$$PLCL^BUDEDU(P,"T6B CRC CANCER CODES",EDATE,0)
I Y Q 1
Q ""
SIG(P,BDATE,EDATE) ;EP
NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB
I $G(BDATE)="" S BDATE=$E(EDATE,1,3)-5_$E(EDATE,4,7)
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S BUDTOB=""
S TIEN=$O(^BUDETSSC("B","T6B CRC FLEX SIG CODES",0))
S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR!(BUDTOB]"") D
.S VIEN=$P(BUDVS(CTR),U,5)
.S VDATE=$P(BUDVS(CTR),U,1)
.;POV/SNOMED
.S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X!(BUDTOB]"") D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDETSSC("AD",Y,TIEN)) S BUDTOB="SIG: DX "_$$VAL^XBDIQ1(9000010.07,X,.01)_":"_$$DATE^BUDEDU(VDATE)_U_VDATE Q
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDETSSC("AS",Y,TIEN)) S BUDTOB="SIG: DX "_Y_":"_$$DATE^BUDEDU(VDATE)_U_VDATE Q
.;CPT
.S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X!(BUDTOB]"") D
..Q:'$D(^AUPNVCPT(X,0))
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..Q:Y=""
..I $D(^BUDETSSC("AC",Y,TIEN)) S BUDTOB="SIG: CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)_":"_$$DATE^BUDEDU(VDATE)_U_VDATE Q
.;V TRANS
.S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X!(BUDTOB]"") D
..Q:'$D(^AUPNVTC(X,0))
..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
..Q:Y=""
..I $D(^BUDETSSC("AC",Y,TIEN)) S BUDTOB="SIG: CPT "_Y_":"_$$DATE^BUDEDU(VDATE)_U_VDATE Q
.;V PROC
.S X=0 F S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X!(BUDTOB]"") D
..Q:'$D(^AUPNVPRC(X,0))
..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
..I $D(^BUDETSSC("AP",Y,TIEN)) S BUDTOB="SIG: PROC "_$$VAL^XBDIQ1(9000010.08,X,.01)_":"_$$DATE^BUDEDU(VDATE)_U_VDATE Q
I BUDTOB]"" Q BUDTOB
Q ""
COLO(P,BDATE,EDATE) ;EP
NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB
I $G(BDATE)="" S BDATE=$E(EDATE,1,3)-10_$E(EDATE,4,7)
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S BUDTOB=""
S TIEN=$O(^BUDETSSC("B","T6B CRC COLONOSCOPY CODES",0))
S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR!(BUDTOB]"") D
.S VIEN=$P(BUDVS(CTR),U,5)
.S VDATE=$P(BUDVS(CTR),U,1)
.;POV/SNOMED
.S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X!(BUDTOB]"") D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDETSSC("AD",Y,TIEN)) S BUDTOB="COLO: DX "_$$VAL^XBDIQ1(9000010.07,X,.01)_":"_$$DATE^BUDEDU(VDATE)_U_VDATE Q
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDETSSC("AS",Y,TIEN)) S BUDTOB="COLO: DX "_Y_":"_$$DATE^BUDEDU(VDATE)_U_VDATE Q
.;CPT
.S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X!(BUDTOB]"") D
..Q:'$D(^AUPNVCPT(X,0))
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..Q:Y=""
..I $D(^BUDETSSC("AC",Y,TIEN)) S BUDTOB="COLO: CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)_":"_$$DATE^BUDEDU(VDATE)_U_VDATE Q
.;V TRANS
.S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X!(BUDTOB]"") D
..Q:'$D(^AUPNVTC(X,0))
..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
..Q:Y=""
..I $D(^BUDETSSC("AC",Y,TIEN)) S BUDTOB="COLO: CPT "_Y_":"_$$DATE^BUDEDU(VDATE)_U_VDATE Q
.;V PROC
.S X=0 F S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X!(BUDTOB]"") D
..Q:'$D(^AUPNVPRC(X,0))
..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
..I $D(^BUDETSSC("AP",Y,TIEN)) S BUDTOB="COLO: PROC "_$$VAL^XBDIQ1(9000010.08,X,.01)_":"_$$DATE^BUDEDU(VDATE)_U_VDATE Q
I BUDTOB]"" Q BUDTOB
Q ""
FOB(P,BDATE,EDATE) ;EP
I $G(BDATE)="" S BDATE=$E(EDATE,1,3)-1_$E(EDATE,4,7)
S BUDD="",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)!(BUDD]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BUDD]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BUDD]"") D
...Q:'$D(^AUPNVLAB(X,0))
...I BUDLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BUDLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BUDD="FOB: Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_":"_$$DATE^BUDEDU(9999999-D)_U_(9999999-D) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S BUDD="FOB: LAB LOINC "_$$VAL^XBDIQ1(9000010.09,X,.01)_":"_$$DATE^BUDEDU(9999999-D)_U_(9999999-D) Q
...Q
S BUDLFOB=BUDD
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^BUDEDU($P(X,U,1))_"^"_$P(X,U,1)
.S X=$$CPT^BUDEDU(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^BUDERP6B
DEPLIST2 ;EP
D EOJ
S BUDDEP2L=1
D DEP2
G EN1^BUDERP6B
DEP1 ;EP
D IN6B^BUDEDU("DEP1")
Q
DEP1L ;EP
S BUDP=0,BUDQUIT=0,BUDTOT=0
D DEP1H Q:BUDQUIT
I '$D(^XTMP("BUDERP6B",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("BUDERP6B",BUDJ,BUDH,"DEP1",BUDAGE)) Q:BUDAGE=""!(BUDQUIT) D
.S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
..S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
...S DFN=0 F S DFN=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME,BUDCCOM,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(BUDCCOM,1,25),?70,$P(^DPT(DFN,0),U,2),?75,BUDAGE,!
....S BUDTOT=BUDTOT+1
....S BUDALL=^XTMP("BUDERP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME,BUDCCOM,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_BUDCCOM_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCCAD) 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(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"") D S(X)
D HT6B^BUDEDU("DEP1")
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(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"") W $$CTR(X,80),!
W $TR($J("",80)," ","-")
I BUDP=0 D
.D HT6B^BUDEDU("DEP1")
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
D IN6B^BUDEDU("DEP2")
Q
DEP2L ;EP
S BUDP=0,BUDQUIT=0,BUDTOT=0
D DEP2H Q:BUDQUIT
I '$D(^XTMP("BUDERP6B",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("BUDERP6B",BUDJ,BUDH,"DEP2",BUDAGE)) Q:BUDAGE=""!(BUDQUIT) D
.S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
..S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
...S DFN=0 F S DFN=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME,BUDCCOM,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(BUDCCOM,1,25),?70,$P(^DPT(DFN,0),U,2),?75,BUDAGE,!
....S BUDTOT=BUDTOT+1
....S BUDALL=^XTMP("BUDERP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME,BUDCCOM,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_BUDCCOM_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCCAD) 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 DEP2HD^BUDERPTE
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(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"") W $$CTR(X,80),!
W $TR($J("",80)," ","-")
I BUDP=0 D
.D HT6B^BUDEDU("DEP2")
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
CTR(X,Y) ;
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
EOJ ;
D EN^XBVK("BUD")
Q
BUDERP6N ; IHS/CMI/LAB - UDS REPORT ;
+1 ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
+2 ;
K ;EP ;CRC
+1 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+2 SET BUD50RB=($EXTRACT(BUDBD,1,3)-50)_"1231"
+3 SET BUD75RB=($EXTRACT(BUDBD,1,3)-75)_"0101"
+4 IF BUDDOB<BUD75RB
QUIT
+5 IF BUDDOB>BUD50RB
QUIT
+6 IF BUDMEDV<1
QUIT
+7 IF $$CRC(DFN,BUDED)
QUIT
+8 SET BUDDRCT=$$SCREEN(DFN,BUDBD,BUDED)
+9 IF BUDDRCT]""
SET BUDSECTK("CRC")=$GET(BUDSECTK("CRC"))+1
+10 SET BUDDRCL=""
+11 SET BUDSECTK("PTS")=$GET(BUDSECTK("PTS"))+1
Begin DoDot:1
+12 IF $GET(BUDDRC2L)
Begin DoDot:2
+13 IF BUDDRCT=""
DO LAST
SET ^XTMP("BUDERP6B",BUDJ,BUDH,"CRC2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=$PIECE(BUDDRCL,U)
End DoDot:2
+14 IF $GET(BUDDRC1L)
Begin DoDot:2
+15 IF BUDDRCT]""
SET ^XTMP("BUDERP6B",BUDJ,BUDH,"CRC1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=$PIECE(BUDDRCT,U)
End DoDot:2
End DoDot:1
+16 QUIT
LAST ;
+1 NEW LAST,COLO,SIG,FOBT
+2 SET BUDDRCL=""
+3 SET COLO=$$COLO(DFN,$$DOB^AUPNPAT(DFN),BUDED)
+4 SET BUDDRCL=COLO
+5 SET SIG=$$SIG(DFN,$$DOB^AUPNPAT(DFN),BUDED)
+6 IF $PIECE(SIG,U,2)>$PIECE(BUDDRCL,U,2)
SET BUDDRCL=SIG
+7 SET FOBT=$$FOB(DFN,$$DOB^AUPNPAT(DFN),BUDED)
+8 IF $PIECE(FOBT,U,2)>$PIECE(BUDDRCL,U,2)
SET BUDDRCL=FOBT
+9 QUIT
SCREEN(P,BDATE,EDATE) ;
+1 NEW BUDDOLO,BUDSIG,BUDFOB
+2 SET BUDDOLO=$$COLO(DFN,,EDATE)
+3 IF BUDDOLO]""
QUIT BUDDOLO
+4 SET BUDSIG=$$SIG(DFN,,EDATE)
+5 IF BUDSIG]""
QUIT BUDSIG
+6 SET BUDFOB=$$FOB(P,BDATE,EDATE)
+7 IF BUDFOB]""
QUIT BUDFOB
+8 QUIT ""
CRC(P,EDATE) ;EP
+1 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB,BDATE
+2 SET BDATE=$$DOB^AUPNPAT(P)
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+4 SET BUDTOB=0
+5 SET TIEN=$ORDER(^BUDETSSC("B","T6B CRC CANCER CODES",0))
+6 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR!(BUDTOB)
QUIT
Begin DoDot:1
+7 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+8 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+9 ;POV/SNOMED
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X!(BUDTOB)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+12 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
IF $DATA(^BUDETSSC("AD",Y,TIEN))
SET BUDTOB=1
QUIT
+13 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+14 IF Y=""
QUIT
+15 IF $DATA(^BUDETSSC("AS",Y,TIEN))
SET BUDTOB=1
QUIT
End DoDot:2
+16 ;CPT
+17 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X!(BUDTOB)
QUIT
Begin DoDot:2
+18 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+19 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+20 IF Y=""
QUIT
+21 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET BUDTOB=1
QUIT
End DoDot:2
+22 ;V TRANS
+23 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X!(BUDTOB)
QUIT
Begin DoDot:2
+24 IF '$DATA(^AUPNVTC(X,0))
QUIT
+25 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+26 IF Y=""
QUIT
+27 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET BUDTOB=1
QUIT
End DoDot:2
+28 ;V PROC
+29 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X!(BUDTOB)
QUIT
Begin DoDot:2
+30 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+31 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+32 IF $DATA(^BUDETSSC("AP",Y,TIEN))
SET BUDTOB=1
QUIT
End DoDot:2
End DoDot:1
+33 IF BUDTOB
QUIT 1
+34 SET Y=$$PLCL^BUDEDU(P,"T6B CRC CANCER CODES",EDATE,0)
+35 IF Y
QUIT 1
+36 QUIT ""
SIG(P,BDATE,EDATE) ;EP
+1 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB
+2 IF $GET(BDATE)=""
SET BDATE=$EXTRACT(EDATE,1,3)-5_$EXTRACT(EDATE,4,7)
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+4 SET BUDTOB=""
+5 SET TIEN=$ORDER(^BUDETSSC("B","T6B CRC FLEX SIG CODES",0))
+6 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR!(BUDTOB]"")
QUIT
Begin DoDot:1
+7 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+8 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+9 ;POV/SNOMED
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X!(BUDTOB]"")
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+12 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
IF $DATA(^BUDETSSC("AD",Y,TIEN))
SET BUDTOB="SIG: DX "_$$VAL^XBDIQ1(9000010.07,X,.01)_":"_$$DATE^BUDEDU(VDATE)_U_VDATE
QUIT
+13 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+14 IF Y=""
QUIT
+15 IF $DATA(^BUDETSSC("AS",Y,TIEN))
SET BUDTOB="SIG: DX "_Y_":"_$$DATE^BUDEDU(VDATE)_U_VDATE
QUIT
End DoDot:2
+16 ;CPT
+17 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X!(BUDTOB]"")
QUIT
Begin DoDot:2
+18 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+19 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+20 IF Y=""
QUIT
+21 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET BUDTOB="SIG: CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)_":"_$$DATE^BUDEDU(VDATE)_U_VDATE
QUIT
End DoDot:2
+22 ;V TRANS
+23 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X!(BUDTOB]"")
QUIT
Begin DoDot:2
+24 IF '$DATA(^AUPNVTC(X,0))
QUIT
+25 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+26 IF Y=""
QUIT
+27 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET BUDTOB="SIG: CPT "_Y_":"_$$DATE^BUDEDU(VDATE)_U_VDATE
QUIT
End DoDot:2
+28 ;V PROC
+29 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X!(BUDTOB]"")
QUIT
Begin DoDot:2
+30 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+31 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+32 IF $DATA(^BUDETSSC("AP",Y,TIEN))
SET BUDTOB="SIG: PROC "_$$VAL^XBDIQ1(9000010.08,X,.01)_":"_$$DATE^BUDEDU(VDATE)_U_VDATE
QUIT
End DoDot:2
End DoDot:1
+33 IF BUDTOB]""
QUIT BUDTOB
+34 QUIT ""
COLO(P,BDATE,EDATE) ;EP
+1 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB
+2 IF $GET(BDATE)=""
SET BDATE=$EXTRACT(EDATE,1,3)-10_$EXTRACT(EDATE,4,7)
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+4 SET BUDTOB=""
+5 SET TIEN=$ORDER(^BUDETSSC("B","T6B CRC COLONOSCOPY CODES",0))
+6 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR!(BUDTOB]"")
QUIT
Begin DoDot:1
+7 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+8 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+9 ;POV/SNOMED
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X!(BUDTOB]"")
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+12 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
IF $DATA(^BUDETSSC("AD",Y,TIEN))
SET BUDTOB="COLO: DX "_$$VAL^XBDIQ1(9000010.07,X,.01)_":"_$$DATE^BUDEDU(VDATE)_U_VDATE
QUIT
+13 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+14 IF Y=""
QUIT
+15 IF $DATA(^BUDETSSC("AS",Y,TIEN))
SET BUDTOB="COLO: DX "_Y_":"_$$DATE^BUDEDU(VDATE)_U_VDATE
QUIT
End DoDot:2
+16 ;CPT
+17 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X!(BUDTOB]"")
QUIT
Begin DoDot:2
+18 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+19 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+20 IF Y=""
QUIT
+21 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET BUDTOB="COLO: CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)_":"_$$DATE^BUDEDU(VDATE)_U_VDATE
QUIT
End DoDot:2
+22 ;V TRANS
+23 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X!(BUDTOB]"")
QUIT
Begin DoDot:2
+24 IF '$DATA(^AUPNVTC(X,0))
QUIT
+25 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+26 IF Y=""
QUIT
+27 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET BUDTOB="COLO: CPT "_Y_":"_$$DATE^BUDEDU(VDATE)_U_VDATE
QUIT
End DoDot:2
+28 ;V PROC
+29 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X!(BUDTOB]"")
QUIT
Begin DoDot:2
+30 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+31 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+32 IF $DATA(^BUDETSSC("AP",Y,TIEN))
SET BUDTOB="COLO: PROC "_$$VAL^XBDIQ1(9000010.08,X,.01)_":"_$$DATE^BUDEDU(VDATE)_U_VDATE
QUIT
End DoDot:2
End DoDot:1
+33 IF BUDTOB]""
QUIT BUDTOB
+34 QUIT ""
FOB(P,BDATE,EDATE) ;EP
+1 IF $GET(BDATE)=""
SET BDATE=$EXTRACT(EDATE,1,3)-1_$EXTRACT(EDATE,4,7)
+2 SET BUDD=""
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)!(BUDD]"")
QUIT
Begin DoDot:1
+6 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BUDD]"")
QUIT
Begin DoDot:2
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BUDD]"")
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 BUDD="FOB: Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_":"_$$DATE^BUDEDU(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 BUDD="FOB: LAB LOINC "_$$VAL^XBDIQ1(9000010.09,X,.01)_":"_$$DATE^BUDEDU(9999999-D)_U_(9999999-D)
QUIT
+14 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+15 SET BUDLFOB=BUDD
+16 SET T=$ORDER(^ATXAX("B","BUD FOBT CPTS",0))
+17 IF T
Begin DoDot:1
+18 SET X=$$CPT^BUDEDU(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^BUDEDU($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^BUDERP6B
DEPLIST2 ;EP
+1 DO EOJ
+2 SET BUDDEP2L=1
+3 DO DEP2
+4 GOTO EN1^BUDERP6B
DEP1 ;EP
+1 DO IN6B^BUDEDU("DEP1")
+2 QUIT
DEP1L ;EP
+1 SET BUDP=0
SET BUDQUIT=0
SET BUDTOT=0
+2 DO DEP1H
IF BUDQUIT
QUIT
+3 IF '$DATA(^XTMP("BUDERP6B",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("BUDERP6B",BUDJ,BUDH,"DEP1",BUDAGE))
IF BUDAGE=""!(BUDQUIT)
QUIT
Begin DoDot:1
+3 SET BUDNAME=""
FOR
SET BUDNAME=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME))
IF BUDNAME=""!(BUDQUIT)
QUIT
Begin DoDot:2
+4 SET BUDCCOM=""
FOR
SET BUDCCOM=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME,BUDCCOM))
IF BUDCCOM=""!(BUDQUIT)
QUIT
Begin DoDot:3
+5 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME,BUDCCOM,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(BUDCCOM,1,25),?70,$PIECE(^DPT(DFN,0),U,2),?75,
BUDAGE,!
+8 SET BUDTOT=BUDTOT+1
+9 SET BUDALL=^XTMP("BUDERP6B",BUDJ,BUDH,"DEP1",BUDAGE,BUDNAME,BUDCCOM,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_BUDCCOM_U_$PIECE(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCCAD)
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(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"")
DO S(X)
+10 DO HT6B^BUDEDU("DEP1")
+11 DO S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^Depression Scrn: Date/Result^Follow-up Plan: Date")
+12 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(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDBEN)=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 DO HT6B^BUDEDU("DEP1")
End DoDot:1
+12 WRITE !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"
+13 WRITE !?5,"Depression Scrn: Date/Result",?35,"Follow-up Plan: Date"
+14 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-"),!
+15 SET BUDP=1
+16 QUIT
DEP2 ;EP
+1 DO IN6B^BUDEDU("DEP2")
+2 QUIT
DEP2L ;EP
+1 SET BUDP=0
SET BUDQUIT=0
SET BUDTOT=0
+2 DO DEP2H
IF BUDQUIT
QUIT
+3 IF '$DATA(^XTMP("BUDERP6B",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("BUDERP6B",BUDJ,BUDH,"DEP2",BUDAGE))
IF BUDAGE=""!(BUDQUIT)
QUIT
Begin DoDot:1
+3 SET BUDNAME=""
FOR
SET BUDNAME=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME))
IF BUDNAME=""!(BUDQUIT)
QUIT
Begin DoDot:2
+4 SET BUDCCOM=""
FOR
SET BUDCCOM=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME,BUDCCOM))
IF BUDCCOM=""!(BUDQUIT)
QUIT
Begin DoDot:3
+5 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME,BUDCCOM,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(BUDCCOM,1,25),?70,$PIECE(^DPT(DFN,0),U,2),?75,
BUDAGE,!
+8 SET BUDTOT=BUDTOT+1
+9 SET BUDALL=^XTMP("BUDERP6B",BUDJ,BUDH,"DEP2",BUDAGE,BUDNAME,BUDCCOM,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_BUDCCOM_U_$PIECE(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,BUDCCAD)
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 DEP2HD^BUDERPTE
+2 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(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDBEN)=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 DO HT6B^BUDEDU("DEP2")
End DoDot:1
+12 WRITE !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"
+13 WRITE !?5,"Depression Scrn: Date/Result",?35,"Follow-up Plan: Date"
+14 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-"),!
+15 SET BUDP=1
+16 QUIT
S(V) ;
+1 SET BUDDECNT=BUDDECNT+1
+2 SET ^TMP($JOB,"BUDDEL",BUDDECNT)=$GET(V)
+3 QUIT
CTR(X,Y) ;
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
EOJ ;
+1 DO EN^XBVK("BUD")
+2 QUIT
