BUDERP6A ;IHS/CMI/LAB - TABLE 6 MEASURES;
;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
;
;
S(V) ;
S BUDDECNT=BUDDECNT+1
S ^TMP($J,"BUDDEL",BUDDECNT)=$G(V)
Q
;----------
HIVLIST1 ;EP
D EOJ
S BUDHIV1L=1
D HIV1
G EN1^BUDERP6B
HIVLIST2 ;EP
D EOJ
S BUDHIV2L=1
D HIV2
G EN1^BUDERP6B
PAUSE ;
K DIR S DIR(0)="E",DIR("A")="PRESS ENTER" KILL DA D ^DIR KILL DIR
Q
GENI ;EP
D GENI^BUDERP6I
Q
;
EOJ ;
D EN^XBVK("BUD")
Q
CTR(X,Y) ;
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
LOC() ;
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
HIV1 ;EP
D IN6B^BUDEDU("HIV1")
Q
HIV1L ;EP
S BUDP=0,BUDQUIT=0,BUDTOT=0
D HIV1H Q:BUDQUIT
I '$D(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV1")) W:BUDROT="P" !!,"No patients to report." D:BUDROT="D" S() D:BUDROT="D" S("No patients to report.") Q
D HIV1L1
I BUDROT="P",$Y>(IOSL-3) D HIV1H Q:BUDQUIT
I BUDROT="P" W !,"TOTAL PATIENTS WITH FIRST HIV DX & TIMELY FOLLOW-UP: ",BUDTOT,!
I BUDROT="D" D S(),S("TOTAL PATIENTS WITH FIRST HIV DX & TIMELY FOLLOW-UP: "_BUDTOT)
Q
HIV1L1 ;
I BUDROT="P",$Y>(IOSL-7) D HIV1H Q:BUDQUIT
S BUDAGE="" F S BUDAGE=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV1",BUDAGE)) Q:BUDAGE=""!(BUDQUIT) D
.S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV1",BUDAGE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
..S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV1",BUDAGE,BUDNAME,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
...S DFN=0 F S DFN=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV1",BUDAGE,BUDNAME,BUDCCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT) D
....I BUDROT="P",$Y>(IOSL-3) D HIV1H 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,"HIV1",BUDAGE,BUDNAME,BUDCCOM,DFN)
....I BUDROT="P" W ?5,$P(BUDALL,"|",1),?35,$S($P(BUDALL,"|",3)]"":$P(BUDALL,"|",3),1:"None"),?46,$P(BUDALL,"|",2)
....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
.....S X=X_U_$P(BUDALL,"|",1)_U_$S($P(BUDALL,"|",3)]"":$P(BUDALL,"|",3),1:"None")_U_$P(BUDALL,"|",2) D S(X)
Q
HIV1HD ;
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 L")
D S("Newly Identified HIV Cases with Timely 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(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 S()
D HT6B^BUDEDU("HIV1")
D S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^First HIV DX: Date^Date of Onset^HIV Follow-up: Date")
Q
HIV1H ;
I BUDROT="D" D HIV1HD Q
G:'BUDGPG HIV1H1
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
HIV1H1 ;
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 L,",80),!,$$CTR("Newly Identified HIV Cases with Timely 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("HIV1")
W !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"
W !?5,"First HIV DX: Date",?35,"Date of Onset",?50,"HIV Follow-up: Date"
W !,$TR($J("",80)," ","-"),!
S BUDP=1
Q
;----------
HIV2 ;EP
D IN6B^BUDEDU("HIV2")
Q
HIV2L ;EP
S BUDP=0,BUDQUIT=0,BUDTOT=0
D HIV2H Q:BUDQUIT
I '$D(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV2")) W:BUDROT="P" !!,"No patients to report." D:BUDROT="D" S() D:BUDROT="D" S("No patients to report.") Q
D HIV2L1
I BUDROT="P",$Y>(IOSL-3) D HIV2H Q:BUDQUIT
I BUDROT="P" W !,"TOTAL PATIENTS WITH FIRST HIV DX & TIMELY FOLLOW-UP: ",BUDTOT,!
I BUDROT="D" D S(),S("TOTAL PATIENTS WITH FIRST HIV DX & TIMELY FOLLOW-UP: "_BUDTOT)
Q
HIV2L1 ;
I BUDROT="P",$Y>(IOSL-7) D HIV2H Q:BUDQUIT
S BUDAGE="" F S BUDAGE=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV2",BUDAGE)) Q:BUDAGE=""!(BUDQUIT) D
.S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV2",BUDAGE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
..S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV2",BUDAGE,BUDNAME,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
...S DFN=0 F S DFN=$O(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV2",BUDAGE,BUDNAME,BUDCCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT) D
....I BUDROT="P",$Y>(IOSL-3) D HIV2H 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,"HIV2",BUDAGE,BUDNAME,BUDCCOM,DFN)
....I BUDROT="P" W ?5,$P(BUDALL,"|",1),?35,$S($P(BUDALL,"|",3)]"":$P(BUDALL,"|",3),1:"None"),?46,$P(BUDALL,"|",2)
....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
.....S X=X_U_$P(BUDALL,"|",1)_U_$S($P(BUDALL,"|",3)]"":$P(BUDALL,"|",3),1:"None")_U_$P(BUDALL,"|",2) D S(X)
Q
HIV2HD ;
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 L")
D S("Newly Identified HIV Cases without Timely 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(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("HIV2")
D S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^First HIV DX: Date^Date of Onset^HIV Follow-up: Date")
Q
HIV2H ;
I BUDROT="D" D HIV2HD Q
G:'BUDGPG HIV2H1
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
HIV2H1 ;
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 L,",80),!,$$CTR("Newly Identified HIV Cases without Timely 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("HIV2")
W !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"
W !?5,"First HIV DX: Date",?35,"Date of Onset",?50,"HIV Follow-up: Date"
W !,$TR($J("",80)," ","-"),!
S BUDP=1
Q
N ;EP - DENTAL SEALANT
;must Be 6-9 yrs old
NEW BUDADA,BUDX9YRB,BUDX6YRE
S BUDX9YRB=($E(BUDBD,1,3)-9)_"0101"
S BUDX6YRE=($E(BUDED,1,3)-6)_"1231"
S BUDDOB=$P(^DPT(DFN,0),U,3)
Q:BUDDOB<BUDX9YRB
Q:BUDDOB>BUDX6YRE
Q:$$NOSEAL(DFN,BUDED) ;
S BUDADA=$$DENTALVS(DFN,BUDBD,BUDED) ;
I $P(BUDADA,U,1)="" Q ;no dental visit
I $P(BUDADA,U,2)="" Q ;no oral assessment
I $P(BUDADA,U,3)="" Q ;no high risk
;
S BUDSECTN("PTS")=$G(BUDSECTN("PTS"))+1
S BUDDTA=$P(BUDADA,U,4) ;did they have a sealant in the report period?
I BUDDTA]"" D Q
.S BUDSECTN("SEAL")=$G(BUDSECTN("SEAL"))+1 D Q
..I $G(BUDDS1L) D
...S ^XTMP("BUDERP6B",BUDJ,BUDH,"DS1",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDADA
..Q
I $G(BUDDS2L) D
.S ^XTMP("BUDERP6B",BUDJ,BUDH,"DS2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDADA
Q
DENTALVS(P,BDATE,EDATE) ;
NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDAST,TIEN1
S BUDAST=""
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S TIEN=$O(^BUDETSSC("B","T6B DENTAL VISIT CODES",0))
S TIEN1=$O(^BUDETSSC("B","T6B DENTAL ORAL ASSESSMENT",0))
S TIEN2=$O(^BUDETSSC("B","T6B DENTAL HIGH RISK",0))
S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR D
.S VIEN=$P(BUDVS(CTR),U,5)
.S VDATE=$P(BUDVS(CTR),U,1)
.S X=0 F S X=$O(^AUPNVDEN("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVDEN(X,0))
..S Y=$$VAL^XBDIQ1(9000010.05,X,.01)
..I $D(^BUDETSSC(TIEN,21,"B",Y)) S $P(BUDAST,U,1)=Y_" on "_$$DATE^BUDEUTL1(VDATE)
..I $D(^BUDETSSC(TIEN1,21,"B",Y)) S $P(BUDAST,U,2)=Y_" on "_$$DATE^BUDEUTL1(VDATE)
..I $D(^BUDETSSC(TIEN2,21,"B",Y)) S $P(BUDAST,U,3)=Y_" on "_$$DATE^BUDEUTL1(VDATE)
..I Y=1351 S $P(BUDAST,U,4)="Sealant: ADA "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
.;CPT
.S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVCPT(X,0))
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..Q:Y=""
..I $D(^BUDETSSC("AC",Y,TIEN)) S $P(BUDAST,U,1)=Y_" on "_$$DATE^BUDEUTL1(VDATE)
..I $D(^BUDETSSC("AC",Y,TIEN1)) S $P(BUDAST,U,2)=Y_" on "_$$DATE^BUDEUTL1(VDATE)
..I $D(^BUDETSSC("AC",Y,TIEN2)) S $P(BUDAST,U,3)=Y_" on "_$$DATE^BUDEUTL1(VDATE)
..I Y="D1351" S $P(BUDAST,U,4)="Sealant: CPT "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
.;V TRANS
.S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVTC(X,0))
..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
..Q:Y=""
..I $D(^BUDETSSC("AC",Y,TIEN)) S $P(BUDAST,U,1)=Y_" on "_$$DATE^BUDEUTL1(VDATE)
..I $D(^BUDETSSC("AC",Y,TIEN1)) S $P(BUDAST,U,2)=Y_" on "_$$DATE^BUDEUTL1(VDATE)
..I $D(^BUDETSSC("AC",Y,TIEN2)) S $P(BUDAST,U,3)=Y_" on "_$$DATE^BUDEUTL1(VDATE)
..I Y="D1351" S $P(BUDAST,U,4)="Sealant: CPT "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
Q BUDAST
NOSEAL(P,EDATE) ;
;V11.0 ICD10
NEW BUDG,%,E,T,X,G,Y
K BUDG S %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDETSSC("B","NOSEAL DIAGNOSES",0))
S X=0,G="" F S X=$O(BUDG(X)) Q:X'=+X!(G]"") D
.S Y=+$P(BUDG(X),U,4)
.S Y=$P($G(^AUPNVPOV(Y,0)),U,1)
.I $D(^BUDETSSC("AD",Y,T)) S G=1
I G]"" Q G
S X=$$PLCL^BUDEDU(P,"NOSEAL DIAGNOSES",EDATE,1) I X Q 1
Q G
SEAL(P,BDATE,EDATE) ;
;get all ada from v dental
;get all cpts from v cpt
NEW BUDG,%,E,G,D,A,T
S G=""
S %=P_"^ALL ADA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BUDG(")
S E=0 F S E=$O(BUDG(E)) Q:E'=+E!(G) D
.S D=+$P(BUDG(E),U,4)
.S A=$$VAL^XBDIQ1(9000010.05,D,.01)
.S T=$$VALI^XBDIQ1(9000010.05,D,.05)
.Q:'T
.S T=$P($G(^ADEOPS(T,88)),U,1)
.I A'=1350,A'=1351,A'=1352 Q
.I T'=3,T'=14,T'=19,T'=30 Q ;not first molar
.S G=1_U_"ADA "_A_" on "_$$FMTE^XLFDT($P(BUDG(E),U))
I G Q G
;cpts
S Y=$$CPTI^BUDEDU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("D1350"),U,1))
I Y Q 1_U_"CPT D1350 on "_$$FMTE^XLFDT($P(Y,U,2))
S Y=$$CPTI^BUDEDU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("D1351"),U,1))
I Y Q 1_U_"CPT D1351 on "_$$FMTE^XLFDT($P(Y,U,2))
S Y=$$CPTI^BUDEDU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("D1352"),U,1))
I Y Q 1_U_"CPT D1352 on "_$$FMTE^XLFDT($P(Y,U,2))
;
Q ""
;
BUDERP6A ;IHS/CMI/LAB - TABLE 6 MEASURES;
+1 ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
+2 ;
+3 ;
S(V) ;
+1 SET BUDDECNT=BUDDECNT+1
+2 SET ^TMP($JOB,"BUDDEL",BUDDECNT)=$GET(V)
+3 QUIT
+4 ;----------
HIVLIST1 ;EP
+1 DO EOJ
+2 SET BUDHIV1L=1
+3 DO HIV1
+4 GOTO EN1^BUDERP6B
HIVLIST2 ;EP
+1 DO EOJ
+2 SET BUDHIV2L=1
+3 DO HIV2
+4 GOTO EN1^BUDERP6B
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^BUDERP6I
+2 QUIT
+3 ;
EOJ ;
+1 DO EN^XBVK("BUD")
+2 QUIT
CTR(X,Y) ;
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
LOC() ;
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
HIV1 ;EP
+1 DO IN6B^BUDEDU("HIV1")
+2 QUIT
HIV1L ;EP
+1 SET BUDP=0
SET BUDQUIT=0
SET BUDTOT=0
+2 DO HIV1H
IF BUDQUIT
QUIT
+3 IF '$DATA(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV1"))
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 HIV1L1
+5 IF BUDROT="P"
IF $Y>(IOSL-3)
DO HIV1H
IF BUDQUIT
QUIT
+6 IF BUDROT="P"
WRITE !,"TOTAL PATIENTS WITH FIRST HIV DX & TIMELY FOLLOW-UP: ",BUDTOT,!
+7 IF BUDROT="D"
DO S()
DO S("TOTAL PATIENTS WITH FIRST HIV DX & TIMELY FOLLOW-UP: "_BUDTOT)
+8 QUIT
HIV1L1 ;
+1 IF BUDROT="P"
IF $Y>(IOSL-7)
DO HIV1H
IF BUDQUIT
QUIT
+2 SET BUDAGE=""
FOR
SET BUDAGE=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV1",BUDAGE))
IF BUDAGE=""!(BUDQUIT)
QUIT
Begin DoDot:1
+3 SET BUDNAME=""
FOR
SET BUDNAME=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV1",BUDAGE,BUDNAME))
IF BUDNAME=""!(BUDQUIT)
QUIT
Begin DoDot:2
+4 SET BUDCCOM=""
FOR
SET BUDCCOM=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV1",BUDAGE,BUDNAME,BUDCCOM))
IF BUDCCOM=""!(BUDQUIT)
QUIT
Begin DoDot:3
+5 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV1",BUDAGE,BUDNAME,BUDCCOM,DFN))
IF DFN'=+DFN!(BUDQUIT)
QUIT
Begin DoDot:4
+6 IF BUDROT="P"
IF $Y>(IOSL-3)
DO HIV1H
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,"HIV1",BUDAGE,BUDNAME,BUDCCOM,DFN)
+10 IF BUDROT="P"
WRITE ?5,$PIECE(BUDALL,"|",1),?35,$SELECT($PIECE(BUDALL,"|",3)]"":$PIECE(BUDALL,"|",3),1:"None"),?46,$PIECE(BUDALL,"|",2)
+11 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
+12 SET X=X_U_$PIECE(BUDALL,"|",1)_U_$SELECT($PIECE(BUDALL,"|",3)]"":$PIECE(BUDALL,"|",3),1:"None")_U_$PIECE(BUDALL,"|",2)
DO S(X)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
HIV1HD ;
+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 L")
+6 DO S("Newly Identified HIV Cases with Timely 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(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 S()
+11 DO HT6B^BUDEDU("HIV1")
+12 DO S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^First HIV DX: Date^Date of Onset^HIV Follow-up: Date")
+13 QUIT
HIV1H ;
+1 IF BUDROT="D"
DO HIV1HD
QUIT
+2 IF 'BUDGPG
GOTO HIV1H1
+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
HIV1H1 ;
+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 L,",80),!,$$CTR("Newly Identified HIV Cases with Timely 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("HIV1")
End DoDot:1
+12 WRITE !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"
+13 WRITE !?5,"First HIV DX: Date",?35,"Date of Onset",?50,"HIV Follow-up: Date"
+14 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-"),!
+15 SET BUDP=1
+16 QUIT
+17 ;----------
HIV2 ;EP
+1 DO IN6B^BUDEDU("HIV2")
+2 QUIT
HIV2L ;EP
+1 SET BUDP=0
SET BUDQUIT=0
SET BUDTOT=0
+2 DO HIV2H
IF BUDQUIT
QUIT
+3 IF '$DATA(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV2"))
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 HIV2L1
+5 IF BUDROT="P"
IF $Y>(IOSL-3)
DO HIV2H
IF BUDQUIT
QUIT
+6 IF BUDROT="P"
WRITE !,"TOTAL PATIENTS WITH FIRST HIV DX & TIMELY FOLLOW-UP: ",BUDTOT,!
+7 IF BUDROT="D"
DO S()
DO S("TOTAL PATIENTS WITH FIRST HIV DX & TIMELY FOLLOW-UP: "_BUDTOT)
+8 QUIT
HIV2L1 ;
+1 IF BUDROT="P"
IF $Y>(IOSL-7)
DO HIV2H
IF BUDQUIT
QUIT
+2 SET BUDAGE=""
FOR
SET BUDAGE=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV2",BUDAGE))
IF BUDAGE=""!(BUDQUIT)
QUIT
Begin DoDot:1
+3 SET BUDNAME=""
FOR
SET BUDNAME=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV2",BUDAGE,BUDNAME))
IF BUDNAME=""!(BUDQUIT)
QUIT
Begin DoDot:2
+4 SET BUDCCOM=""
FOR
SET BUDCCOM=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV2",BUDAGE,BUDNAME,BUDCCOM))
IF BUDCCOM=""!(BUDQUIT)
QUIT
Begin DoDot:3
+5 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BUDERP6B",BUDJ,BUDH,"HIV2",BUDAGE,BUDNAME,BUDCCOM,DFN))
IF DFN'=+DFN!(BUDQUIT)
QUIT
Begin DoDot:4
+6 IF BUDROT="P"
IF $Y>(IOSL-3)
DO HIV2H
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,"HIV2",BUDAGE,BUDNAME,BUDCCOM,DFN)
+10 IF BUDROT="P"
WRITE ?5,$PIECE(BUDALL,"|",1),?35,$SELECT($PIECE(BUDALL,"|",3)]"":$PIECE(BUDALL,"|",3),1:"None"),?46,$PIECE(BUDALL,"|",2)
+11 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
+12 SET X=X_U_$PIECE(BUDALL,"|",1)_U_$SELECT($PIECE(BUDALL,"|",3)]"":$PIECE(BUDALL,"|",3),1:"None")_U_$PIECE(BUDALL,"|",2)
DO S(X)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
HIV2HD ;
+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 L")
+6 DO S("Newly Identified HIV Cases without Timely 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(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("HIV2")
+11 DO S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^First HIV DX: Date^Date of Onset^HIV Follow-up: Date")
+12 QUIT
HIV2H ;
+1 IF BUDROT="D"
DO HIV2HD
QUIT
+2 IF 'BUDGPG
GOTO HIV2H1
+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
HIV2H1 ;
+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 L,",80),!,$$CTR("Newly Identified HIV Cases without Timely 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("HIV2")
End DoDot:1
+12 WRITE !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"
+13 WRITE !?5,"First HIV DX: Date",?35,"Date of Onset",?50,"HIV Follow-up: Date"
+14 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-"),!
+15 SET BUDP=1
+16 QUIT
N ;EP - DENTAL SEALANT
+1 ;must Be 6-9 yrs old
+2 NEW BUDADA,BUDX9YRB,BUDX6YRE
+3 SET BUDX9YRB=($EXTRACT(BUDBD,1,3)-9)_"0101"
+4 SET BUDX6YRE=($EXTRACT(BUDED,1,3)-6)_"1231"
+5 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+6 IF BUDDOB<BUDX9YRB
QUIT
+7 IF BUDDOB>BUDX6YRE
QUIT
+8 ;
IF $$NOSEAL(DFN,BUDED)
QUIT
+9 ;
SET BUDADA=$$DENTALVS(DFN,BUDBD,BUDED)
+10 ;no dental visit
IF $PIECE(BUDADA,U,1)=""
QUIT
+11 ;no oral assessment
IF $PIECE(BUDADA,U,2)=""
QUIT
+12 ;no high risk
IF $PIECE(BUDADA,U,3)=""
QUIT
+13 ;
+14 SET BUDSECTN("PTS")=$GET(BUDSECTN("PTS"))+1
+15 ;did they have a sealant in the report period?
SET BUDDTA=$PIECE(BUDADA,U,4)
+16 IF BUDDTA]""
Begin DoDot:1
+17 SET BUDSECTN("SEAL")=$GET(BUDSECTN("SEAL"))+1
Begin DoDot:2
+18 IF $GET(BUDDS1L)
Begin DoDot:3
+19 SET ^XTMP("BUDERP6B",BUDJ,BUDH,"DS1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDADA
End DoDot:3
+20 QUIT
End DoDot:2
QUIT
End DoDot:1
QUIT
+21 IF $GET(BUDDS2L)
Begin DoDot:1
+22 SET ^XTMP("BUDERP6B",BUDJ,BUDH,"DS2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDADA
End DoDot:1
+23 QUIT
DENTALVS(P,BDATE,EDATE) ;
+1 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDAST,TIEN1
+2 SET BUDAST=""
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+4 SET TIEN=$ORDER(^BUDETSSC("B","T6B DENTAL VISIT CODES",0))
+5 SET TIEN1=$ORDER(^BUDETSSC("B","T6B DENTAL ORAL ASSESSMENT",0))
+6 SET TIEN2=$ORDER(^BUDETSSC("B","T6B DENTAL HIGH RISK",0))
+7 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+8 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+9 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVDEN("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVDEN(X,0))
QUIT
+12 SET Y=$$VAL^XBDIQ1(9000010.05,X,.01)
+13 IF $DATA(^BUDETSSC(TIEN,21,"B",Y))
SET $PIECE(BUDAST,U,1)=Y_" on "_$$DATE^BUDEUTL1(VDATE)
+14 IF $DATA(^BUDETSSC(TIEN1,21,"B",Y))
SET $PIECE(BUDAST,U,2)=Y_" on "_$$DATE^BUDEUTL1(VDATE)
+15 IF $DATA(^BUDETSSC(TIEN2,21,"B",Y))
SET $PIECE(BUDAST,U,3)=Y_" on "_$$DATE^BUDEUTL1(VDATE)
+16 IF Y=1351
SET $PIECE(BUDAST,U,4)="Sealant: ADA "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
End DoDot:2
+17 ;CPT
+18 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+19 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+20 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+21 IF Y=""
QUIT
+22 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET $PIECE(BUDAST,U,1)=Y_" on "_$$DATE^BUDEUTL1(VDATE)
+23 IF $DATA(^BUDETSSC("AC",Y,TIEN1))
SET $PIECE(BUDAST,U,2)=Y_" on "_$$DATE^BUDEUTL1(VDATE)
+24 IF $DATA(^BUDETSSC("AC",Y,TIEN2))
SET $PIECE(BUDAST,U,3)=Y_" on "_$$DATE^BUDEUTL1(VDATE)
+25 IF Y="D1351"
SET $PIECE(BUDAST,U,4)="Sealant: CPT "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
End DoDot:2
+26 ;V TRANS
+27 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+28 IF '$DATA(^AUPNVTC(X,0))
QUIT
+29 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+30 IF Y=""
QUIT
+31 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET $PIECE(BUDAST,U,1)=Y_" on "_$$DATE^BUDEUTL1(VDATE)
+32 IF $DATA(^BUDETSSC("AC",Y,TIEN1))
SET $PIECE(BUDAST,U,2)=Y_" on "_$$DATE^BUDEUTL1(VDATE)
+33 IF $DATA(^BUDETSSC("AC",Y,TIEN2))
SET $PIECE(BUDAST,U,3)=Y_" on "_$$DATE^BUDEUTL1(VDATE)
+34 IF Y="D1351"
SET $PIECE(BUDAST,U,4)="Sealant: CPT "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
End DoDot:2
End DoDot:1
+35 QUIT BUDAST
NOSEAL(P,EDATE) ;
+1 ;V11.0 ICD10
+2 NEW BUDG,%,E,T,X,G,Y
+3 KILL BUDG
SET %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+4 SET T=$ORDER(^BUDETSSC("B","NOSEAL DIAGNOSES",0))
+5 SET X=0
SET G=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+6 SET Y=+$PIECE(BUDG(X),U,4)
+7 SET Y=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+8 IF $DATA(^BUDETSSC("AD",Y,T))
SET G=1
End DoDot:1
+9 IF G]""
QUIT G
+10 SET X=$$PLCL^BUDEDU(P,"NOSEAL DIAGNOSES",EDATE,1)
IF X
QUIT 1
+11 QUIT G
SEAL(P,BDATE,EDATE) ;
+1 ;get all ada from v dental
+2 ;get all cpts from v cpt
+3 NEW BUDG,%,E,G,D,A,T
+4 SET G=""
+5 SET %=P_"^ALL ADA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BUDG(")
+6 SET E=0
FOR
SET E=$ORDER(BUDG(E))
IF E'=+E!(G)
QUIT
Begin DoDot:1
+7 SET D=+$PIECE(BUDG(E),U,4)
+8 SET A=$$VAL^XBDIQ1(9000010.05,D,.01)
+9 SET T=$$VALI^XBDIQ1(9000010.05,D,.05)
+10 IF 'T
QUIT
+11 SET T=$PIECE($GET(^ADEOPS(T,88)),U,1)
+12 IF A'=1350
IF A'=1351
IF A'=1352
QUIT
+13 ;not first molar
IF T'=3
IF T'=14
IF T'=19
IF T'=30
QUIT
+14 SET G=1_U_"ADA "_A_" on "_$$FMTE^XLFDT($PIECE(BUDG(E),U))
End DoDot:1
+15 IF G
QUIT G
+16 ;cpts
+17 SET Y=$$CPTI^BUDEDU(P,BDATE,EDATE,$PIECE($$CPT^ICPTCOD("D1350"),U,1))
+18 IF Y
QUIT 1_U_"CPT D1350 on "_$$FMTE^XLFDT($PIECE(Y,U,2))
+19 SET Y=$$CPTI^BUDEDU(P,BDATE,EDATE,$PIECE($$CPT^ICPTCOD("D1351"),U,1))
+20 IF Y
QUIT 1_U_"CPT D1351 on "_$$FMTE^XLFDT($PIECE(Y,U,2))
+21 SET Y=$$CPTI^BUDEDU(P,BDATE,EDATE,$PIECE($$CPT^ICPTCOD("D1352"),U,1))
+22 IF Y
QUIT 1_U_"CPT D1352 on "_$$FMTE^XLFDT($PIECE(Y,U,2))
+23 ;
+24 QUIT ""
+25 ;
