Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BUDDRP6A

BUDDRP6A.m

Go to the documentation of this file.
  1. BUDDRP6A ; IHS/CMI/LAB - HIV/DEP 16 Nov 2016 8:52 AM ; 15 Dec 2016 9:46 AM
  1. ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
  1. ;
  1. ;
  1. S(V) ;
  1. S BUDDECNT=BUDDECNT+1
  1. S ^TMP($J,"BUDDEL",BUDDECNT)=$G(V)
  1. Q
  1. ;----------
  1. HIVLIST1 ;EP
  1. D EOJ
  1. S BUDHIV1L=1
  1. D HIV1
  1. G EN1^BUDDRP6B
  1. HIVLIST2 ;EP
  1. D EOJ
  1. S BUDHIV2L=1
  1. D HIV2
  1. G EN1^BUDDRP6B
  1. PAUSE ;
  1. K DIR S DIR(0)="E",DIR("A")="PRESS ENTER" KILL DA D ^DIR KILL DIR
  1. Q
  1. GENI ;EP
  1. D GENI^BUDDRP6I
  1. Q
  1. ;
  1. EOJ ;
  1. D EN^XBVK("BUD")
  1. Q
  1. CTR(X,Y) ;
  1. Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1. LOC() ;
  1. Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1. HIV1 ;EP
  1. D IN6B^BUDDDU("HIV1")
  1. Q
  1. HIV1L ;EP
  1. S BUDP=0,BUDQUIT=0,BUDTOT=0
  1. D HIV1H Q:BUDQUIT
  1. I '$D(^XTMP("BUDDRP6B",BUDJ,BUDH,"HIV1")) W:BUDROT="P" !!,"No patients to report." D:BUDROT="D" S() D:BUDROT="D" S("No patients to report.") Q
  1. D HIV1L1
  1. I BUDROT="P",$Y>(IOSL-3) D HIV1H Q:BUDQUIT
  1. I BUDROT="P" W !,"TOTAL PATIENTS WITH FIRST HIV DX & TIMELY FOLLOW-UP: ",BUDTOT,!
  1. I BUDROT="D" D S(),S("TOTAL PATIENTS WITH FIRST HIV DX & TIMELY FOLLOW-UP: "_BUDTOT)
  1. Q
  1. HIV1L1 ;
  1. I BUDROT="P",$Y>(IOSL-7) D HIV1H Q:BUDQUIT
  1. S BUDAGE="" F S BUDAGE=$O(^XTMP("BUDDRP6B",BUDJ,BUDH,"HIV1",BUDAGE)) Q:BUDAGE=""!(BUDQUIT) D
  1. .S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDDRP6B",BUDJ,BUDH,"HIV1",BUDAGE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
  1. ..S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDDRP6B",BUDJ,BUDH,"HIV1",BUDAGE,BUDNAME,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
  1. ...S DFN=0 F S DFN=$O(^XTMP("BUDDRP6B",BUDJ,BUDH,"HIV1",BUDAGE,BUDNAME,BUDCCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT) D
  1. ....I BUDROT="P",$Y>(IOSL-3) D HIV1H Q:BUDQUIT
  1. ....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,!
  1. ....S BUDTOT=BUDTOT+1
  1. ....S BUDALL=^XTMP("BUDDRP6B",BUDJ,BUDH,"HIV1",BUDAGE,BUDNAME,BUDCCOM,DFN)
  1. ....I BUDROT="P" W ?5,$P(BUDALL,"|",1),?35,$S($P(BUDALL,"|",3)]"":$P(BUDALL,"|",3),1:"None"),?46,$P(BUDALL,"|",2)
  1. ....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
  1. .....S X=X_U_$P(BUDALL,"|",1)_U_$S($P(BUDALL,"|",3)]"":$P(BUDALL,"|",3),1:"None")_U_$P(BUDALL,"|",2) D S(X)
  1. Q
  1. HIV1HD ;
  1. D S(),S(),S()
  1. D S("***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****")
  1. D S($P(^VA(200,DUZ,0),U,2)_" "_$$FMTE^XLFDT(DT))
  1. D S("*** RPMS Uniform Data System (UDS) ***")
  1. D S("Patient List for Table 6B, Section L")
  1. D S("Newly Identified HIV Cases with Timely Follow-Up")
  1. D S($P(^DIC(4,BUDSITE,0),U))
  1. S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) D S(X)
  1. 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)
  1. D S()
  1. D HT6B^BUDDDU("HIV1")
  1. D S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^First HIV DX: Date^Date of Onset^HIV Follow-up: Date")
  1. Q
  1. HIV1H ;
  1. I BUDROT="D" D HIV1HD Q
  1. G:'BUDGPG HIV1H1
  1. 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
  1. HIV1H1 ;
  1. W:$D(IOF) @IOF S BUDGPG=BUDGPG+1
  1. W !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
  1. W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
  1. W !,$$CTR("*** RPMS Uniform Data System (UDS) ***",80)
  1. W !,$$CTR("Patient List for Table 6B, Section L,",80),!,$$CTR("Newly Identified HIV Cases with Timely Follow-Up",80),!
  1. W $$CTR($P(^DIC(4,BUDSITE,0),U),80),!
  1. S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) W $$CTR(X,80),!
  1. 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),!
  1. W $TR($J("",80)," ","-")
  1. I BUDP=0 D
  1. .D HT6B^BUDDDU("HIV1")
  1. W !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"
  1. W !?5,"First HIV DX: Date",?35,"Date of Onset",?50,"HIV Follow-up: Date"
  1. W !,$TR($J("",80)," ","-"),!
  1. S BUDP=1
  1. Q
  1. ;----------
  1. HIV2 ;EP
  1. D IN6B^BUDDDU("HIV2")
  1. Q
  1. HIV2L ;EP
  1. S BUDP=0,BUDQUIT=0,BUDTOT=0
  1. D HIV2H Q:BUDQUIT
  1. I '$D(^XTMP("BUDDRP6B",BUDJ,BUDH,"HIV2")) W:BUDROT="P" !!,"No patients to report." D:BUDROT="D" S() D:BUDROT="D" S("No patients to report.") Q
  1. D HIV2L1
  1. I BUDROT="P",$Y>(IOSL-3) D HIV2H Q:BUDQUIT
  1. I BUDROT="P" W !,"TOTAL PATIENTS WITH FIRST HIV DX & TIMELY FOLLOW-UP: ",BUDTOT,!
  1. I BUDROT="D" D S(),S("TOTAL PATIENTS WITH FIRST HIV DX & TIMELY FOLLOW-UP: "_BUDTOT)
  1. Q
  1. HIV2L1 ;
  1. I BUDROT="P",$Y>(IOSL-7) D HIV2H Q:BUDQUIT
  1. S BUDAGE="" F S BUDAGE=$O(^XTMP("BUDDRP6B",BUDJ,BUDH,"HIV2",BUDAGE)) Q:BUDAGE=""!(BUDQUIT) D
  1. .S BUDNAME="" F S BUDNAME=$O(^XTMP("BUDDRP6B",BUDJ,BUDH,"HIV2",BUDAGE,BUDNAME)) Q:BUDNAME=""!(BUDQUIT) D
  1. ..S BUDCCOM="" F S BUDCCOM=$O(^XTMP("BUDDRP6B",BUDJ,BUDH,"HIV2",BUDAGE,BUDNAME,BUDCCOM)) Q:BUDCCOM=""!(BUDQUIT) D
  1. ...S DFN=0 F S DFN=$O(^XTMP("BUDDRP6B",BUDJ,BUDH,"HIV2",BUDAGE,BUDNAME,BUDCCOM,DFN)) Q:DFN'=+DFN!(BUDQUIT) D
  1. ....I BUDROT="P",$Y>(IOSL-3) D HIV2H Q:BUDQUIT
  1. ....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,!
  1. ....S BUDTOT=BUDTOT+1
  1. ....S BUDALL=^XTMP("BUDDRP6B",BUDJ,BUDH,"HIV2",BUDAGE,BUDNAME,BUDCCOM,DFN)
  1. ....I BUDROT="P" W ?5,$P(BUDALL,"|",1),?35,$S($P(BUDALL,"|",3)]"":$P(BUDALL,"|",3),1:"None"),?46,$P(BUDALL,"|",2)
  1. ....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
  1. .....S X=X_U_$P(BUDALL,"|",1)_U_$S($P(BUDALL,"|",3)]"":$P(BUDALL,"|",3),1:"None")_U_$P(BUDALL,"|",2) D S(X)
  1. Q
  1. HIV2HD ;
  1. D S(),S(),S()
  1. D S("***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****")
  1. D S($P(^VA(200,DUZ,0),U,2)_" "_$$FMTE^XLFDT(DT))
  1. D S("*** RPMS Uniform Data System (UDS) ***")
  1. D S("Patient List for Table 6B, Section L")
  1. D S("Newly Identified HIV Cases without Timely Follow-Up")
  1. D S($P(^DIC(4,BUDSITE,0),U))
  1. S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) D S(X)
  1. 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)
  1. D HT6B^BUDDDU("HIV2")
  1. D S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^First HIV DX: Date^Date of Onset^HIV Follow-up: Date")
  1. Q
  1. HIV2H ;
  1. I BUDROT="D" D HIV2HD Q
  1. G:'BUDGPG HIV2H1
  1. 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
  1. HIV2H1 ;
  1. W:$D(IOF) @IOF S BUDGPG=BUDGPG+1
  1. W !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
  1. W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
  1. W !,$$CTR("*** RPMS Uniform Data System (UDS) ***",80)
  1. W !,$$CTR("Patient List for Table 6B, Section L,",80),!,$$CTR("Newly Identified HIV Cases without Timely Follow-Up",80),!
  1. W $$CTR($P(^DIC(4,BUDSITE,0),U),80),!
  1. S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) W $$CTR(X,80),!
  1. 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),!
  1. W $TR($J("",80)," ","-")
  1. I BUDP=0 D
  1. .D HT6B^BUDDDU("HIV2")
  1. W !!,"PATIENT NAME",?34,"HRN",?41,"COMMUNITY",?70,"SEX",?75,"AGE"
  1. W !?5,"First HIV DX: Date",?35,"Date of Onset",?50,"HIV Follow-up: Date"
  1. W !,$TR($J("",80)," ","-"),!
  1. S BUDP=1
  1. Q
  1. N ;EP - DENTAL SEALANT
  1. ;must Be 6-9 yrs old
  1. NEW BUDADA,BUDX9YRB,BUDX6YRE
  1. S BUDX9YRB=($E(BUDBD,1,3)-9)_"0101"
  1. S BUDX6YRE=($E(BUDED,1,3)-6)_"1231"
  1. S BUDDOB=$P(^DPT(DFN,0),U,3)
  1. Q:BUDDOB<BUDX9YRB
  1. Q:BUDDOB>BUDX6YRE
  1. Q:$$NOSEAL(DFN,BUDED) ;
  1. S BUDADA=$$DENTALVS(DFN,BUDBD,BUDED) ;
  1. I $P(BUDADA,U,1)="" Q ;no dental visit
  1. I $P(BUDADA,U,2)="" Q ;no oral assessment
  1. I $P(BUDADA,U,3)="" Q ;no high risk
  1. ;
  1. S BUDSECTN("PTS")=$G(BUDSECTN("PTS"))+1
  1. S BUDDTA=$P(BUDADA,U,4) ;did they have a sealant in the report period?
  1. I BUDDTA]"" D Q
  1. .S BUDSECTN("SEAL")=$G(BUDSECTN("SEAL"))+1 D Q
  1. ..I $G(BUDDS1L) D
  1. ...S ^XTMP("BUDDRP6B",BUDJ,BUDH,"DS1",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDADA
  1. ..Q
  1. I $G(BUDDS2L) D
  1. .S ^XTMP("BUDDRP6B",BUDJ,BUDH,"DS2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDADA
  1. Q
  1. DENTALVS(P,BDATE,EDATE) ;
  1. NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDAST,TIEN1
  1. S BUDAST=""
  1. D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
  1. S TIEN=$O(^BUDDTSSC("B","T6B DENTAL VISIT CODES",0))
  1. S TIEN1=$O(^BUDDTSSC("B","T6B DENTAL ORAL ASSESSMENT",0))
  1. S TIEN2=$O(^BUDDTSSC("B","T6B DENTAL HIGH RISK",0))
  1. S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR D
  1. .S VIEN=$P(BUDVS(CTR),U,5)
  1. .S VDATE=$P(BUDVS(CTR),U,1)
  1. .S X=0 F S X=$O(^AUPNVDEN("AD",VIEN,X)) Q:X'=+X D
  1. ..Q:'$D(^AUPNVDEN(X,0))
  1. ..S Y=$$VAL^XBDIQ1(9000010.05,X,.01)
  1. ..I $D(^BUDDTSSC(TIEN,21,"B",Y)) S $P(BUDAST,U,1)=Y_" on "_$$DATE^BUDDUTL1(VDATE)
  1. ..I $D(^BUDDTSSC(TIEN1,21,"B",Y)) S $P(BUDAST,U,2)=Y_" on "_$$DATE^BUDDUTL1(VDATE)
  1. ..I $D(^BUDDTSSC(TIEN2,21,"B",Y)) S $P(BUDAST,U,3)=Y_" on "_$$DATE^BUDDUTL1(VDATE)
  1. ..I Y=1351 S $P(BUDAST,U,4)="Sealant: ADA "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
  1. .;CPT
  1. .S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X D
  1. ..Q:'$D(^AUPNVCPT(X,0))
  1. ..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
  1. ..Q:Y=""
  1. ..I $D(^BUDDTSSC("AC",Y,TIEN)) S $P(BUDAST,U,1)=Y_" on "_$$DATE^BUDDUTL1(VDATE)
  1. ..I $D(^BUDDTSSC("AC",Y,TIEN1)) S $P(BUDAST,U,2)=Y_" on "_$$DATE^BUDDUTL1(VDATE)
  1. ..I $D(^BUDDTSSC("AC",Y,TIEN2)) S $P(BUDAST,U,3)=Y_" on "_$$DATE^BUDDUTL1(VDATE)
  1. ..I Y="D1351" S $P(BUDAST,U,4)="Sealant: CPT "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
  1. .;V TRANS
  1. .S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X D
  1. ..Q:'$D(^AUPNVTC(X,0))
  1. ..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
  1. ..Q:Y=""
  1. ..I $D(^BUDDTSSC("AC",Y,TIEN)) S $P(BUDAST,U,1)=Y_" on "_$$DATE^BUDDUTL1(VDATE)
  1. ..I $D(^BUDDTSSC("AC",Y,TIEN1)) S $P(BUDAST,U,2)=Y_" on "_$$DATE^BUDDUTL1(VDATE)
  1. ..I $D(^BUDDTSSC("AC",Y,TIEN2)) S $P(BUDAST,U,3)=Y_" on "_$$DATE^BUDDUTL1(VDATE)
  1. ..I Y="D1351" S $P(BUDAST,U,4)="Sealant: CPT "_Y_" on "_$$DATE^BUDDUTL1(VDATE)
  1. Q BUDAST
  1. NOSEAL(P,EDATE) ;
  1. ;V11.0 ICD10
  1. NEW BUDG,%,E,T,X,G,Y
  1. K BUDG S %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
  1. S T=$O(^BUDDTSSC("B","NOSEAL DIAGNOSES",0))
  1. S X=0,G="" F S X=$O(BUDG(X)) Q:X'=+X!(G]"") D
  1. .S Y=+$P(BUDG(X),U,4)
  1. .S Y=$P($G(^AUPNVPOV(Y,0)),U,1)
  1. .I $D(^BUDDTSSC("AD",Y,T)) S G=1
  1. I G]"" Q G
  1. S X=$$PLCL^BUDDDU(P,"NOSEAL DIAGNOSES",EDATE,1) I X Q 1
  1. Q G
  1. SEAL(P,BDATE,EDATE) ;
  1. ;get all ada from v dental
  1. ;get all cpts from v cpt
  1. NEW BGPG,%,E,G,D,A,T
  1. S G=""
  1. S %=P_"^ALL ADA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1. S E=0 F S E=$O(BGPG(E)) Q:E'=+E!(G) D
  1. .S D=+$P(BGPG(E),U,4)
  1. .S A=$$VAL^XBDIQ1(9000010.05,D,.01)
  1. .S T=$$VALI^XBDIQ1(9000010.05,D,.05)
  1. .Q:'T
  1. .S T=$P($G(^ADEOPS(T,88)),U,1)
  1. .I A'=1350,A'=1351,A'=1352 Q
  1. .I T'=3,T'=14,T'=19,T'=30 Q ;not first molar
  1. .S G=1_U_"ADA "_A_" on "_$$FMTE^XLFDT($P(BGPG(E),U))
  1. I G Q G
  1. ;cpts
  1. S Y=$$CPTI^BUDDDU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("D1350"),U,1))
  1. I Y Q 1_U_"CPT D1350 on "_$$FMTE^XLFDT($P(Y,U,2))
  1. S Y=$$CPTI^BUDDDU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("D1351"),U,1))
  1. I Y Q 1_U_"CPT D1351 on "_$$FMTE^XLFDT($P(Y,U,2))
  1. S Y=$$CPTI^BUDDDU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("D1352"),U,1))
  1. I Y Q 1_U_"CPT D1352 on "_$$FMTE^XLFDT($P(Y,U,2))
  1. ;
  1. Q ""
  1. ;