BUDHRP6B ;IHS/CMI/LAB - UDS TABLE 6B DRIVER; ; 07 Aug 2018 11:03 AM
;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
;
;
T6B ;
D EOJ
EN ;
S BUDNOLI=1,BUDZLIST=0,BUDTSCTC=1
D GENI
D T6BI
D PAUSE
D PRENATT
D PAUSE
;
EN1 ;EP
PNC ;
;S BUDPREN=""
;S DIR(0)="Y",DIR("A")="Does your facility provide prenatal care",DIR("B")="N" KILL DA D ^DIR KILL DIR
;I $D(DIRUT) D EOJ Q
;S BUDPREN=Y
;
EN2 ;
S BUDSITE=""
S DIC="^BUDHSITE(",DIC(0)="AEMQ",DIC("A")="Enter your site: " D ^DIC
I Y=-1 D EOJ Q
S BUDSITE=+Y
I '$O(^BUDHSITE(BUDSITE,11,0)) W !!,"Warning: There are no locations defined in the site parameter file for this",!,"site. Report will not be accurate!" G EN
S BUDTAXT="B6" D TAXCHK^BUDHXTCH
D YEAR
I BUDYEAR="" D EOJ Q
W !!,"Your report will be run for the time period: ",$$FMTE^XLFDT(BUDBD)," to ",$$FMTE^XLFDT(BUDED)
;get indian or not
S BUDBEN=""
S DIR(0)="S^1:Indian/Alaskan Native (Classification 01);2:Not Indian Alaskan/Native (Not Classification 01);3:All (both Indian/Alaskan Natives and Non 01)",DIR("A")="Select Beneficiary Population to include in this report"
S DIR("B")="1" KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"Classification not entered." D EOJ Q
S BUDBEN=Y
I $G(BUDNOLI) S BUDROT="P",BUDDELT="" G ZIS
D PT^BUDHRPTE
I BUDROT="" G EN1
ZIS ;call to XBDBQUE
K IOP,%ZIS I BUDROT="D",BUDDELT="F" D NODEV,EOJ Q
W !! S %ZIS=$S(BUDDELT'="S":"PQM",1:"PM") D ^%ZIS
ZIS1 ;
I POP W !,"Report Aborted" D EOJ Q
I $D(IO("Q")) G TSKMN
DRIVER ;
D PROC
U IO
D PRINT
D ^%ZISC
D EOJ
Q
NODEV ;
S XBRP="",XBRC="NODEV1^BUDHRP6B",XBRX="EOJ^BUDHRP6B",XBNS="BUD"
D ^XBDBQUE
Q
NODEV1 ;
D PROC^BUDHRP6B
D PRINT^BUDHRP6B
D ^%ZISC
D EOJ
Q
TSKMN ;EP ENTRY POINT FROM TASKMAN
S ZTIO=$S($D(ION):ION,1:IO) I $D(IOST)#2,IOST]"" S ZTIO=ZTIO_";"_IOST
I $G(IO("DOC"))]"" S ZTIO=ZTIO_";"_$G(IO("DOC"))
I $D(IOM)#2,IOM S ZTIO=ZTIO_";"_IOM I $D(IOSL)#2,IOSL S ZTIO=ZTIO_";"_IOSL
K ZTSAVE S ZTSAVE("BUD*")=""
S ZTCPU=$G(IOCPU),ZTRTN="DRIVER^BUDHRP6B",ZTDTH="",ZTDESC="UDS 18 REPORT TABLE 6B" D ^%ZTLOAD D EOJ Q
Q
EOJ ;
D EN^XBVK("BUD")
Q
PAPLIST1 ;EP
D EOJ
S BUDPAP1L=1
D PAP1^BUDHRP6P
S BUDZLIST=1,BUDTSCTC=2 G EN1
;
PAPLIST2 ;EP
D EOJ
S BUDPAP2L=1
D PAP2^BUDHRP6P
S BUDZLIST=1,BUDTSCTC=2 G EN1
DSLIST1 ;EP
D EOJ
S BUDDS1L=1
D DS1^BUDHRP61
S BUDZLIST=1,BUDTSCTC=2 G EN1
;
DSLIST2 ;EP
D EOJ
S BUDDS2L=1
D DS2^BUDHRP61
S BUDZLIST=1,BUDTSCTC=2 G EN1
IMMLIST1 ;EP
D EOJ
S BUDIMM1L=1
D IMM1^BUDHRP6I
S BUDZLIST=1,BUDTSCTC=2 G EN1
IMMLIST2 ;EP
D EOJ
S BUDIMM2L=1
D IMM2^BUDHRP6I
S BUDZLIST=1,BUDTSCTC=2 G EN1
PRGA ;EP
D EOJ
S BUDPRGAL=1
D PRGA^BUDHRP6W
S BUDZLIST=1,BUDTSCTC=2 G EN1
;
M ;EP - called from option
D EOJ
D GENI^BUDHRP6I
K BUDTIND,BUDIND
D EN^BUDHDSI
I '$D(BUDIND) W !,"No Lists Selected." H 2 D EOJ Q
S BUDTSCTC=1,BUDZLIST=1
S X=0 F S X=$O(BUDIND(X)) Q:X'=+X X ^BUDHLST2(X,1) S BUDTSCTC=BUDTSCTC+1
G EN1
PROC ;EP - called from taskman
S BUDJ=$J,BUDH=$H
S ^XTMP("BUDHRP6B",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^BUD TABLE 6B LISTS"
;SET UP SNOMED LISTS FROM SUBSETS
;SET UP ICD10 LISTS FROM TAXONOMIES
D SETUP^BUDHUTL2
;NOW LOOP PATS
S DFN=0 F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN D
.K ^TMP($J)
.Q:'$D(^AUPNPAT(DFN,0))
.Q:'$D(^DPT(DFN,0))
.Q:$P(^DPT(DFN,0),U,19) ;merged away
.Q:$$DEMO^BUDHDU(DFN,"E")
.;;;I DUZ=2881,$$HRN^AUPNPAT(DFN,DUZ(2))
.;;I DUZ=2881 I $$HRN^AUPNPAT(DFN,DUZ(2))'=146418,$$HRN^AUPNPAT(DFN,DUZ(2))'=101861 Q
N .;
.I BUDBEN=1,$$BEN^AUPNPAT(DFN,"C")'="01" Q ;must be Indian/Alaskan Native
.I BUDBEN=2,$$BEN^AUPNPAT(DFN,"C")="01" Q ;must not be I/A
.S C=$$COMMRES^AUPNPAT(DFN,"E")
.S BUDSEX=$P(^DPT(DFN,0),U,2)
.I BUDSEX'="F",BUDSEX'="M" Q
.S BUDCCOM=$$COMMRES^AUPNPAT(DFN,"E") I BUDCCOM="" S BUDCCOM="UNKNOWN"
.S BUDAGE=$$AGE^AUPNPAT(DFN,BUDED) ;age at end of time period
.S BUDAGEP=$$AGE^AUPNPAT(DFN,BUDCCAD) ;age on june 30 for pregnancy
.D GETV^BUDHRPTD ;get visits that meet criteria
.I BUDUDSPT=0 Q ;user doesn't have any countable visits
.I $G(BUDPRGAL) D PRGALST
.D IMM^BUDHRP6C
.D PAPD^BUDHRP6D
.D ADOLWT^BUDHRP6V
.D ADULT^BUDHRP6V
.D G^BUDHRP6V ;TOB
.D H^BUDHRP6U ;AST
.D I^BUDHRP6O ;CAD
.D J^BUDHRP6M ;IVD
.D K^BUDHRP6N ;CRC
.D L^BUDHRP6Q ;HIV
.D M^BUDHRP6Q ;DEPRESSION
.D N^BUDHRP6A ;DENTAL
Q
PRGALST ;EP - list of pregnant females
;is patient pregnant during the time period BUDDD and BUDED
Q:BUDSEX'="F"
S BUDP=$$PREG(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED,BUDBD)
I '$P(BUDP,U) Q ;not pregnant
S X=$$AGB(BUDAGEP)
S ^XTMP("BUDHRP6B",BUDJ,BUDH,"PRGA",X,BUDAGEP,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDP,"*",2)
Q
AGB(N) ;
I N<15 Q "Less than 15 Years"
I N>14,N<20 Q "Ages 15-19"
I N>19,N<25 Q "Ages 20-24"
I N>24,N<45 Q "Ages 25-44"
Q "Ages 45 and Over"
PREG(P,BDATE,EDATE,RPBD) ;EP
NEW BUDD,B,CNT,BUDALL,BUDG,DXT,PXT,CPTT,CTR,VIEN,D,C,Y,H,X,BUDV,BUDDX
S BUDD=""
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDV")
I '$D(BUDV) G PROB
S CNT=0,BUDD="",BUDALL=""
K BUDG
S DXT=$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
S PXT=$O(^ATXAX("B","BGP PREGNANCY ICD PROCEDURES",0))
S CPTT=$O(^ATXAX("B","BGP PREGNANCY CPT CODES",0))
;CHECK DX, PROCS, CPTS for 2 separate visits
S B=0,CTR=0 F S CTR=$O(BUDV(CTR)) Q:CTR'=+CTR D
.;get visit into VIEN
.S VIEN=$P(BUDV(CTR),U,5)
.S D=$$VD^APCLV(VIEN)
.;now check for dx
.S Y=0,H="" F S Y=$O(^AUPNVPOV("AD",VIEN,Y)) Q:Y'=+Y D
..S %=+^AUPNVPOV(Y,0)
..I $$ICD^ATXCHK(%,DXT,9) I '$D(BUDDX(D)) S BUDDX(D)="",CNT=CNT+1,BUDALL=BUDALL_VIEN_"|"_$$VAL^XBDIQ1(9000010.07,Y,.01)_U,H=1 I D'<RPBD S B=1
.Q:H
.;NOW GO THROUGH CPTS
.S Y=0,H="" F S Y=$O(^AUPNVCPT("AD",VIEN,Y)) Q:Y'=+Y D
..S %=+^AUPNVCPT(Y,0)
..I $$ICD^ATXCHK(%,CPTT,1) I '$D(BUDDX(D)) S BUDDX(D)="",CNT=CNT+1,BUDALL=BUDALL_VIEN_"|"_$$VAL^XBDIQ1(9000010.18,Y,.01)_U,H=1 I D'<RPBD S B=1
.Q:H
.;NOW PROCEDURES
.S Y=0,H="" F S Y=$O(^AUPNVPRC("AD",VIEN,Y)) Q:Y'=+Y D
..S %=+^AUPNVPRC(Y,0)
..I $$ICD^ATXCHK(%,PXT,0) I '$D(BUDDX(D)) S BUDDX(D)="",CNT=CNT+1,BUDALL=BUDALL_VIEN_"|"_$$VAL^XBDIQ1(9000010.08,Y,.01)_U,H=1 I D'<RPBD S B=1
.Q:H
.Q
I CNT>1,B D G MA
.S X=0,C=0 F S X=$O(BUDDX(X)) Q:X'=+X S C=C+1 I C=2 S BUDD=X ;second visit
I 'B Q 0 ;no visit during time period
PROB S T=$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
S (X,G)=0,Z="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.Q:$P(^AUPNPROB(X,0),U,8)<BDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^ATXCHK(Y,T,9)
.S G=$P(^AUPNPROB(X,0),U,8),Z=X
.Q
I G=0,BUDD="" Q 0 ;no dxs and no problem list
S BUDD=G,BUDALL=BUDALL_"Problem List: "_$$VAL^XBDIQ1(9000011,Z,.01)_" on "_$$DATE^BUDHUTL1(G)_U
MA ;now check for abortion or miscarriage
;abortion first
K BUDG S Y="BUDG(" S X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BUDD)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BUDG(1)) Q 0 ;HAD MIS/AB
S BUDG=$$LASTPRC^BUDHUTL1(P,"BGP ABORTION PROCEDURES",BDATE,EDATE)
I BUDG Q 0
S T=$O(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,8)<BUDD
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^ATXCHK(Y,T,9)
.S G=1
.Q
I G Q 0
;now check CPTs for Abortion and Miscarriage
S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
S %=$$CPT^BUDHDU(P,BUDD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$CPT^BUDHDU(P,BUDD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
S %=$$TRAN^BUDHDU(P,BUDD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$TRAN^BUDHDU(P,BUDD,EDATE,T,3)
I %]"" Q 0
Q 1_"*"_BUDALL
;
PRINT ;EP - called from taskman
I '$G(BUDTPG) S BUDTPG=0
S BUDPG=0 S:'$G(BUDXXXXX) BUDSCTC=1
S BUDQUIT=0
S BUD80L="",$P(BUD80L,"_",79)="_"
I BUDROT="D" D G PL
.D ^%ZISC ;close printer device
.K ^TMP($J)
.S ^TMP($J,"BUDDEL",0)=0
.S BUDDECNT=0
D HEADER^BUDHRPTP Q:BUDQUIT D T6BH
W $$CTR("SECTION A: AGE CATEGORIES FOR PRENATAL PATIENTS"),!
D LINE
W $$CTR("DEMOGRAPHIC CHARACTERISTICS OF PRENATAL CARE PATIENTS"),!
D LINE
W ?20,"AGE",?45,"|",?50,"NUMBER OF PATIENTS (a)",!
D LINE1
W ?2,"1",?5,"LESS THAN 15 YEARS",?45,"|",?58,"",!
D LINE1
W ?2,"2",?5,"AGES 15-19",?45,"|",?58,"",!
D LINE1
I $Y>(IOSL-3) D HEADER^BUDHRPTP Q:BUDQUIT D T6BH
W ?2,"3",?5,"AGES 20-24",?45,"|",?58,"",! D LINE1
I $Y>(IOSL-3) D HEADER^BUDHRPTP Q:BUDQUIT D T6BH
W ?2,"4",?5,"AGES 25-44",?45,"|",?58,"",! D LINE1
I $Y>(IOSL-3) D HEADER^BUDHRPTP Q:BUDQUIT D T6BH
W ?2,"5",?5,"AGES 45 AND OVER",?45,"|","",! D LINE1
I $Y>(IOSL-3) D HEADER^BUDHRPTP Q:BUDQUIT D T6BH
W ?2,"6",?5,"TOTAL PATIENTS (SUM LINES 1-5)",?45,"|","",! D LINE1
I $Y>(IOSL-12) D HEADER^BUDHRPTP Q:BUDQUIT D T6BH
W !,$$CTR("SECTION B - EARLY ENTRY INTO PRENATAL CARE"),! D LINE
W "EARLY ENTRY INTO",?37,"|",?40,"WOMEN HAVING",?60,"|",?63,"WOMEN HAVING",!
W "PRENATAL CARE",?37,"|",?40,"FIRST VISIT WITH",?60,"|",?63,"FIRST VISIT WITH",!
W "",?37,"|",?40,"HEALTH CENTER",?60,"|",?63,"ANOTHER PROVIDER",!
W ?37,"|",?45,"(a)",?60,"|",?68,"(b)",!
D LINE2
W ?2,7,?5,"First Trimester",?37,"|",?45,"",?60,"|",?68,"",! D LINE2
W ?2,8,?5,"Second Trimester",?37,"|",?45,"",?60,"|",?68,"",! D LINE2
W ?2,9,?5,"Third Trimester",?37,"|",?45,"",?60,"|",?68,"",! D LINE2
;
D HEADER^BUDHRPTP Q:BUDQUIT D T6BH
W $$CTR("SECTION C - CHILDHOOD IMMUNIZATION STATUS"),!
D LINE
W "CHILDHOOD IMMUNIZATION",?23,"|",?26,"TOTAL PATIENTS",?45,"|",?47,"NUMBER CHARTS",?65,"|",?67,"NUMBER OF",!
W "STATUS",?23,"|",?26,"WITH 2ND",?45,"|",?47,"SAMPLED OR EHR",?65,"|",?67,"PATIENTS",!
W ?23,"|",?26,"BIRTHDAY",?45,"|",?47,"TOTAL",?65,"|",?67,"IMMUNIZED",!
W ?23,"|",?26,"",?45,"|",?47,"",?65,"|",?67,"",!
W ?23,"|",?30,"(a)",?45,"|",?50,"(b)",?65,"|",?70,"(c)",!
D LINE3
W ?1,"10",?5,"MEASURE: ",?23,"|",?45,"|",?65,"|",!
W ?5,"Percentage of ",?23,"|",?45,"|",?65,"|",!
W ?5,"children 2 years",?23,"|",?45,"|",?65,"|",!
W ?5,"of age who",?23,"|",?45,"|",?65,"|",!
W ?5,"received age",?23,"|",?30,$$C($G(BUDSECTC("PTS"))),?45,"|",?50,$$C($G(BUDSECTC("PTS"))),?65,"|",?70,$$C($G(BUDSECTC("IMM"))),!
W ?5,"appropriate",?23,"|",?45,"|",?65,"|",!
W ?5,"vaccines by their",?23,"|",?45,"|",?65,"|",!
W ?5,"2nd birthday",?23,"|",?45,"|",?65,"|",!
;W ?5,"birthday",?23,"|",?45,"|",?65,"|",!
D LINE
I $Y>(IOSL-20) D HEADER^BUDHRPTP Q:BUDQUIT D T6BH
W $$CTR("SECTION D - CERVICAL CANCER SCREENING"),!
D LINE
W "CERVICAL CANCER",?23,"|",?26,"TOTAL FEMALE",?45,"|",?47,"NUMBER CHARTS",?65,"|",?67,"NUMBER OF",!
W "SCREENING",?23,"|",?26,"PATIENTS AGED",?45,"|",?47,"SAMPLED OR EHR",?65,"|",?67,"PATIENTS",!
W ?23,"|",?26,"23 THROUGH 64",?45,"|",?47,"TOTAL",?65,"|",?67,"TESTED",!
W ?23,"|",?30,"(a)",?45,"|",?50,"(b)",?65,"|",?70,"(c)",!
D LINE3
W ?1,"11",?5,"MEASURE: ",?23,"|",?45,"|",?65,"|",!
W ?5,"Percentage of ",?23,"|",?45,"|",?65,"|",!
W ?5,"women 23-64 ",?23,"|",?45,"|",?65,"|",!
W ?5,"years of age, who ",?23,"|",?30,$$C($G(BUDSECTD("PTS"))),?45,"|",?50,$$C($G(BUDSECTD("PTS"))),?65,"|",?70,$$C($G(BUDSECTD("PAP"))),!
W ?5,"were screened for",?23,"|",?45,"|",?65,"|",!
W ?5,"cervical cancer",?23,"|",?45,"|",?65,"|",!
D LINE
D REST6B^BUDHRP6E
I BUDTSCTC>1,BUDROT'="D" W !,"***** END OF SECTION ",BUDSCTC," *****",!
PL D LISTS^BUDHRP6I
;D ^%ZISC
I BUDROT'="D",'$G(BUDXXXXX) W !!,"***** END OF REPORT *****",!
I BUDROT="D" D ^%ZISC D SAVEDEL^BUDHRPTD
K ^XTMP("BUDHRP6B",BUDJ,BUDH)
Q
T6BH ;
W !,$$CTR("TABLE 6B - QUALITY OF CARE MEASURES"),!,$$REPEAT^XLFSTR("_",79),!
Q
LINE ;
W $$REPEAT^XLFSTR("_",79),!
Q
LINE1 ;
W $$REPEAT^XLFSTR("_",45),"|",$$REPEAT^XLFSTR("_",33),!
Q
LINE2 ;
W $$REPEAT^XLFSTR("_",37),"|",$$REPEAT^XLFSTR("_",22),"|",$$REPEAT^XLFSTR("_",18),!
Q
LINE3 ;
W $$REPEAT^XLFSTR("_",23),"|",$$REPEAT^XLFSTR("_",21),"|",$$REPEAT^XLFSTR("_",19),"|",$$REPEAT^XLFSTR("_",13),!
Q
T6BI ;
W !!,"TABLE 6B: QUALITY OF CARE MEASURES"
W !,"This report will produce UDS Table 6B, quality of care measures."
W !,"Patients must meet additional criteria as specified for each measure."
Q
GENI ;general introductions
W:$D(IOF) @(IOF)
W !!,$$CTR($$LOC,80),!,$$CTR("UDS 2018",80),!
W !,"UDS searches your database to find all patients reported for the quality"
W !,"of care measures during the time period January 1 - "
W !,"December 31, 2018. Based on the UDS definition, to be considered a"
W !,"patient, the patient must have had at least one visit meeting the"
W !,"following criteria:"
W !?4,"- must be to a location specified in your visit location setup"
W !?4,"- must be to Service Category Ambulatory (A), Hospitalization (H), Day"
W !?6,"Surgery (S), Observation (O), Telemedicine (M), Nursing home visit (R), "
W !?6,"or In-Hospital (I) visit"
W !?4,"- must NOT have an excluded clinic code (see User Manual for a list)"
W !?4,"- must have a primary provider and a coded purpose of visit"
W !?4,"- the patient must NOT have a gender of 'Unknown'"
W !
Q
;
PRENATT ;EP
D PRENATT^BUDHRP6I
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
NRY ;
W !!,"not developed yet....." H 3
Q
PAUSE ;
K DIR S DIR(0)="E",DIR("A")="PRESS ENTER" KILL DA D ^DIR KILL DIR
Q
C(X,Y) ;
I $G(Y)=1,+X=0 Q ""
I $G(Y)=2 Q "********"
S X2=0,X3=8
D COMMA^%DTC
Q X
YEAR ;
S BUDYEAR=""
W !
W !,"Enter the Calendar Year. Use a 4 digit year, e.g. 2018"
S DIR(0)="D^::EP"
S DIR("A")="Enter Calendar Year"
S DIR("?")="This report is compiled for a period. Enter a valid date."
D ^DIR KILL DIR
K DIC
I $D(DUOUT) S DIRUT=1 Q
I $D(DIRUT) Q
I $E(Y,4,7)'="0000" W !!,"Please enter a year only!",! G YEAR
S BUDYEAR=Y,BUDBD=$E(BUDYEAR,1,3)_"0101",BUDED=$E(BUDYEAR,1,3)_"1231"
S BUDCCAD=$E(BUDYEAR,1,3)_"0630"
Q
BUDHRP6B ;IHS/CMI/LAB - UDS TABLE 6B DRIVER; ; 07 Aug 2018 11:03 AM
+1 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
+2 ;
+3 ;
T6B ;
+1 DO EOJ
EN ;
+1 SET BUDNOLI=1
SET BUDZLIST=0
SET BUDTSCTC=1
+2 DO GENI
+3 DO T6BI
+4 DO PAUSE
+5 DO PRENATT
+6 DO PAUSE
+7 ;
EN1 ;EP
PNC ;
+1 ;S BUDPREN=""
+2 ;S DIR(0)="Y",DIR("A")="Does your facility provide prenatal care",DIR("B")="N" KILL DA D ^DIR KILL DIR
+3 ;I $D(DIRUT) D EOJ Q
+4 ;S BUDPREN=Y
+5 ;
EN2 ;
+1 SET BUDSITE=""
+2 SET DIC="^BUDHSITE("
SET DIC(0)="AEMQ"
SET DIC("A")="Enter your site: "
DO ^DIC
+3 IF Y=-1
DO EOJ
QUIT
+4 SET BUDSITE=+Y
+5 IF '$ORDER(^BUDHSITE(BUDSITE,11,0))
WRITE !!,"Warning: There are no locations defined in the site parameter file for this",!,"site. Report will not be accurate!"
GOTO EN
+6 SET BUDTAXT="B6"
DO TAXCHK^BUDHXTCH
+7 DO YEAR
+8 IF BUDYEAR=""
DO EOJ
QUIT
+9 WRITE !!,"Your report will be run for the time period: ",$$FMTE^XLFDT(BUDBD)," to ",$$FMTE^XLFDT(BUDED)
+10 ;get indian or not
+11 SET BUDBEN=""
+12 SET DIR(0)="S^1:Indian/Alaskan Native (Classification 01);2:Not Indian Alaskan/Native (Not Classification 01);3:All (both Indian/Alaskan Natives and Non 01)"
SET DIR("A")="Select Beneficiary Population to include in this report"
+13 SET DIR("B")="1"
KILL DA
DO ^DIR
KILL DIR
+14 IF $DATA(DIRUT)
WRITE !!,"Classification not entered."
DO EOJ
QUIT
+15 SET BUDBEN=Y
+16 IF $GET(BUDNOLI)
SET BUDROT="P"
SET BUDDELT=""
GOTO ZIS
+17 DO PT^BUDHRPTE
+18 IF BUDROT=""
GOTO EN1
ZIS ;call to XBDBQUE
+1 KILL IOP,%ZIS
IF BUDROT="D"
IF BUDDELT="F"
DO NODEV
DO EOJ
QUIT
+2 WRITE !!
SET %ZIS=$SELECT(BUDDELT'="S":"PQM",1:"PM")
DO ^%ZIS
ZIS1 ;
+1 IF POP
WRITE !,"Report Aborted"
DO EOJ
QUIT
+2 IF $DATA(IO("Q"))
GOTO TSKMN
DRIVER ;
+1 DO PROC
+2 USE IO
+3 DO PRINT
+4 DO ^%ZISC
+5 DO EOJ
+6 QUIT
NODEV ;
+1 SET XBRP=""
SET XBRC="NODEV1^BUDHRP6B"
SET XBRX="EOJ^BUDHRP6B"
SET XBNS="BUD"
+2 DO ^XBDBQUE
+3 QUIT
NODEV1 ;
+1 DO PROC^BUDHRP6B
+2 DO PRINT^BUDHRP6B
+3 DO ^%ZISC
+4 DO EOJ
+5 QUIT
TSKMN ;EP ENTRY POINT FROM TASKMAN
+1 SET ZTIO=$SELECT($DATA(ION):ION,1:IO)
IF $DATA(IOST)#2
IF IOST]""
SET ZTIO=ZTIO_";"_IOST
+2 IF $GET(IO("DOC"))]""
SET ZTIO=ZTIO_";"_$GET(IO("DOC"))
+3 IF $DATA(IOM)#2
IF IOM
SET ZTIO=ZTIO_";"_IOM
IF $DATA(IOSL)#2
IF IOSL
SET ZTIO=ZTIO_";"_IOSL
+4 KILL ZTSAVE
SET ZTSAVE("BUD*")=""
+5 SET ZTCPU=$GET(IOCPU)
SET ZTRTN="DRIVER^BUDHRP6B"
SET ZTDTH=""
SET ZTDESC="UDS 18 REPORT TABLE 6B"
DO ^%ZTLOAD
DO EOJ
QUIT
+6 QUIT
EOJ ;
+1 DO EN^XBVK("BUD")
+2 QUIT
PAPLIST1 ;EP
+1 DO EOJ
+2 SET BUDPAP1L=1
+3 DO PAP1^BUDHRP6P
+4 SET BUDZLIST=1
SET BUDTSCTC=2
GOTO EN1
+5 ;
PAPLIST2 ;EP
+1 DO EOJ
+2 SET BUDPAP2L=1
+3 DO PAP2^BUDHRP6P
+4 SET BUDZLIST=1
SET BUDTSCTC=2
GOTO EN1
DSLIST1 ;EP
+1 DO EOJ
+2 SET BUDDS1L=1
+3 DO DS1^BUDHRP61
+4 SET BUDZLIST=1
SET BUDTSCTC=2
GOTO EN1
+5 ;
DSLIST2 ;EP
+1 DO EOJ
+2 SET BUDDS2L=1
+3 DO DS2^BUDHRP61
+4 SET BUDZLIST=1
SET BUDTSCTC=2
GOTO EN1
IMMLIST1 ;EP
+1 DO EOJ
+2 SET BUDIMM1L=1
+3 DO IMM1^BUDHRP6I
+4 SET BUDZLIST=1
SET BUDTSCTC=2
GOTO EN1
IMMLIST2 ;EP
+1 DO EOJ
+2 SET BUDIMM2L=1
+3 DO IMM2^BUDHRP6I
+4 SET BUDZLIST=1
SET BUDTSCTC=2
GOTO EN1
PRGA ;EP
+1 DO EOJ
+2 SET BUDPRGAL=1
+3 DO PRGA^BUDHRP6W
+4 SET BUDZLIST=1
SET BUDTSCTC=2
GOTO EN1
+5 ;
M ;EP - called from option
+1 DO EOJ
+2 DO GENI^BUDHRP6I
+3 KILL BUDTIND,BUDIND
+4 DO EN^BUDHDSI
+5 IF '$DATA(BUDIND)
WRITE !,"No Lists Selected."
HANG 2
DO EOJ
QUIT
+6 SET BUDTSCTC=1
SET BUDZLIST=1
+7 SET X=0
FOR
SET X=$ORDER(BUDIND(X))
IF X'=+X
QUIT
XECUTE ^BUDHLST2(X,1)
SET BUDTSCTC=BUDTSCTC+1
+8 GOTO EN1
PROC ;EP - called from taskman
+1 SET BUDJ=$JOB
SET BUDH=$HOROLOG
+2 SET ^XTMP("BUDHRP6B",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^BUD TABLE 6B LISTS"
+3 ;SET UP SNOMED LISTS FROM SUBSETS
+4 ;SET UP ICD10 LISTS FROM TAXONOMIES
+5 DO SETUP^BUDHUTL2
+6 ;NOW LOOP PATS
+7 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:1
+8 KILL ^TMP($JOB)
+9 IF '$DATA(^AUPNPAT(DFN,0))
QUIT
+10 IF '$DATA(^DPT(DFN,0))
QUIT
+11 ;merged away
IF $PIECE(^DPT(DFN,0),U,19)
QUIT
+12 IF $$DEMO^BUDHDU(DFN,"E")
QUIT
+13 ;;;I DUZ=2881,$$HRN^AUPNPAT(DFN,DUZ(2))
+14 ;;I DUZ=2881 I $$HRN^AUPNPAT(DFN,DUZ(2))'=146418,$$HRN^AUPNPAT(DFN,DUZ(2))'=101861 Q
N ;
+1 ;must be Indian/Alaskan Native
IF BUDBEN=1
IF $$BEN^AUPNPAT(DFN,"C")'="01"
QUIT
+2 ;must not be I/A
IF BUDBEN=2
IF $$BEN^AUPNPAT(DFN,"C")="01"
QUIT
+3 SET C=$$COMMRES^AUPNPAT(DFN,"E")
+4 SET BUDSEX=$PIECE(^DPT(DFN,0),U,2)
+5 IF BUDSEX'="F"
IF BUDSEX'="M"
QUIT
+6 SET BUDCCOM=$$COMMRES^AUPNPAT(DFN,"E")
IF BUDCCOM=""
SET BUDCCOM="UNKNOWN"
+7 ;age at end of time period
SET BUDAGE=$$AGE^AUPNPAT(DFN,BUDED)
+8 ;age on june 30 for pregnancy
SET BUDAGEP=$$AGE^AUPNPAT(DFN,BUDCCAD)
+9 ;get visits that meet criteria
DO GETV^BUDHRPTD
+10 ;user doesn't have any countable visits
IF BUDUDSPT=0
QUIT
+11 IF $GET(BUDPRGAL)
DO PRGALST
+12 DO IMM^BUDHRP6C
+13 DO PAPD^BUDHRP6D
+14 DO ADOLWT^BUDHRP6V
+15 DO ADULT^BUDHRP6V
+16 ;TOB
DO G^BUDHRP6V
+17 ;AST
DO H^BUDHRP6U
+18 ;CAD
DO I^BUDHRP6O
+19 ;IVD
DO J^BUDHRP6M
+20 ;CRC
DO K^BUDHRP6N
+21 ;HIV
DO L^BUDHRP6Q
+22 ;DEPRESSION
DO M^BUDHRP6Q
+23 ;DENTAL
DO N^BUDHRP6A
End DoDot:1
+24 QUIT
PRGALST ;EP - list of pregnant females
+1 ;is patient pregnant during the time period BUDDD and BUDED
+2 IF BUDSEX'="F"
QUIT
+3 SET BUDP=$$PREG(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED,BUDBD)
+4 ;not pregnant
IF '$PIECE(BUDP,U)
QUIT
+5 SET X=$$AGB(BUDAGEP)
+6 SET ^XTMP("BUDHRP6B",BUDJ,BUDH,"PRGA",X,BUDAGEP,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=$PIECE(BUDP,"*",2)
+7 QUIT
AGB(N) ;
+1 IF N<15
QUIT "Less than 15 Years"
+2 IF N>14
IF N<20
QUIT "Ages 15-19"
+3 IF N>19
IF N<25
QUIT "Ages 20-24"
+4 IF N>24
IF N<45
QUIT "Ages 25-44"
+5 QUIT "Ages 45 and Over"
PREG(P,BDATE,EDATE,RPBD) ;EP
+1 NEW BUDD,B,CNT,BUDALL,BUDG,DXT,PXT,CPTT,CTR,VIEN,D,C,Y,H,X,BUDV,BUDDX
+2 SET BUDD=""
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDV")
+4 IF '$DATA(BUDV)
GOTO PROB
+5 SET CNT=0
SET BUDD=""
SET BUDALL=""
+6 KILL BUDG
+7 SET DXT=$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
+8 SET PXT=$ORDER(^ATXAX("B","BGP PREGNANCY ICD PROCEDURES",0))
+9 SET CPTT=$ORDER(^ATXAX("B","BGP PREGNANCY CPT CODES",0))
+10 ;CHECK DX, PROCS, CPTS for 2 separate visits
+11 SET B=0
SET CTR=0
FOR
SET CTR=$ORDER(BUDV(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+12 ;get visit into VIEN
+13 SET VIEN=$PIECE(BUDV(CTR),U,5)
+14 SET D=$$VD^APCLV(VIEN)
+15 ;now check for dx
+16 SET Y=0
SET H=""
FOR
SET Y=$ORDER(^AUPNVPOV("AD",VIEN,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+17 SET %=+^AUPNVPOV(Y,0)
+18 IF $$ICD^ATXCHK(%,DXT,9)
IF '$DATA(BUDDX(D))
SET BUDDX(D)=""
SET CNT=CNT+1
SET BUDALL=BUDALL_VIEN_"|"_$$VAL^XBDIQ1(9000010.07,Y,.01)_U
SET H=1
IF D'<RPBD
SET B=1
End DoDot:2
+19 IF H
QUIT
+20 ;NOW GO THROUGH CPTS
+21 SET Y=0
SET H=""
FOR
SET Y=$ORDER(^AUPNVCPT("AD",VIEN,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+22 SET %=+^AUPNVCPT(Y,0)
+23 IF $$ICD^ATXCHK(%,CPTT,1)
IF '$DATA(BUDDX(D))
SET BUDDX(D)=""
SET CNT=CNT+1
SET BUDALL=BUDALL_VIEN_"|"_$$VAL^XBDIQ1(9000010.18,Y,.01)_U
SET H=1
IF D'<RPBD
SET B=1
End DoDot:2
+24 IF H
QUIT
+25 ;NOW PROCEDURES
+26 SET Y=0
SET H=""
FOR
SET Y=$ORDER(^AUPNVPRC("AD",VIEN,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+27 SET %=+^AUPNVPRC(Y,0)
+28 IF $$ICD^ATXCHK(%,PXT,0)
IF '$DATA(BUDDX(D))
SET BUDDX(D)=""
SET CNT=CNT+1
SET BUDALL=BUDALL_VIEN_"|"_$$VAL^XBDIQ1(9000010.08,Y,.01)_U
SET H=1
IF D'<RPBD
SET B=1
End DoDot:2
+29 IF H
QUIT
+30 QUIT
End DoDot:1
+31 IF CNT>1
IF B
Begin DoDot:1
+32 ;second visit
SET X=0
SET C=0
FOR
SET X=$ORDER(BUDDX(X))
IF X'=+X
QUIT
SET C=C+1
IF C=2
SET BUDD=X
End DoDot:1
GOTO MA
+33 ;no visit during time period
IF 'B
QUIT 0
PROB SET T=$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
+1 SET (X,G)=0
SET Z=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+2 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+3 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+4 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
QUIT
+5 SET Y=$PIECE(^AUPNPROB(X,0),U)
+6 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+7 SET G=$PIECE(^AUPNPROB(X,0),U,8)
SET Z=X
+8 QUIT
End DoDot:1
+9 ;no dxs and no problem list
IF G=0
IF BUDD=""
QUIT 0
+10 SET BUDD=G
SET BUDALL=BUDALL_"Problem List: "_$$VAL^XBDIQ1(9000011,Z,.01)_" on "_$$DATE^BUDHUTL1(G)_U
MA ;now check for abortion or miscarriage
+1 ;abortion first
+2 KILL BUDG
SET Y="BUDG("
SET X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BUDD)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+3 ;HAD MIS/AB
IF $DATA(BUDG(1))
QUIT 0
+4 SET BUDG=$$LASTPRC^BUDHUTL1(P,"BGP ABORTION PROCEDURES",BDATE,EDATE)
+5 IF BUDG
QUIT 0
+6 SET T=$ORDER(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
+7 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,8)<BUDD
QUIT
+10 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+11 SET Y=$PIECE(^AUPNPROB(X,0),U)
+12 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+13 SET G=1
+14 QUIT
End DoDot:1
+15 IF G
QUIT 0
+16 ;now check CPTs for Abortion and Miscarriage
+17 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+18 SET %=$$CPT^BUDHDU(P,BUDD,EDATE,T,3)
+19 IF %]""
QUIT 0
+20 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+21 SET %=$$CPT^BUDHDU(P,BUDD,EDATE,T,3)
+22 IF %]""
QUIT 0
+23 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+24 SET %=$$TRAN^BUDHDU(P,BUDD,EDATE,T,3)
+25 IF %]""
QUIT 0
+26 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+27 SET %=$$TRAN^BUDHDU(P,BUDD,EDATE,T,3)
+28 IF %]""
QUIT 0
+29 QUIT 1_"*"_BUDALL
+30 ;
PRINT ;EP - called from taskman
+1 IF '$GET(BUDTPG)
SET BUDTPG=0
+2 SET BUDPG=0
IF '$GET(BUDXXXXX)
SET BUDSCTC=1
+3 SET BUDQUIT=0
+4 SET BUD80L=""
SET $PIECE(BUD80L,"_",79)="_"
+5 IF BUDROT="D"
Begin DoDot:1
+6 ;close printer device
DO ^%ZISC
+7 KILL ^TMP($JOB)
+8 SET ^TMP($JOB,"BUDDEL",0)=0
+9 SET BUDDECNT=0
End DoDot:1
GOTO PL
+10 DO HEADER^BUDHRPTP
IF BUDQUIT
QUIT
DO T6BH
+11 WRITE $$CTR("SECTION A: AGE CATEGORIES FOR PRENATAL PATIENTS"),!
+12 DO LINE
+13 WRITE $$CTR("DEMOGRAPHIC CHARACTERISTICS OF PRENATAL CARE PATIENTS"),!
+14 DO LINE
+15 WRITE ?20,"AGE",?45,"|",?50,"NUMBER OF PATIENTS (a)",!
+16 DO LINE1
+17 WRITE ?2,"1",?5,"LESS THAN 15 YEARS",?45,"|",?58,"",!
+18 DO LINE1
+19 WRITE ?2,"2",?5,"AGES 15-19",?45,"|",?58,"",!
+20 DO LINE1
+21 IF $Y>(IOSL-3)
DO HEADER^BUDHRPTP
IF BUDQUIT
QUIT
DO T6BH
+22 WRITE ?2,"3",?5,"AGES 20-24",?45,"|",?58,"",!
DO LINE1
+23 IF $Y>(IOSL-3)
DO HEADER^BUDHRPTP
IF BUDQUIT
QUIT
DO T6BH
+24 WRITE ?2,"4",?5,"AGES 25-44",?45,"|",?58,"",!
DO LINE1
+25 IF $Y>(IOSL-3)
DO HEADER^BUDHRPTP
IF BUDQUIT
QUIT
DO T6BH
+26 WRITE ?2,"5",?5,"AGES 45 AND OVER",?45,"|","",!
DO LINE1
+27 IF $Y>(IOSL-3)
DO HEADER^BUDHRPTP
IF BUDQUIT
QUIT
DO T6BH
+28 WRITE ?2,"6",?5,"TOTAL PATIENTS (SUM LINES 1-5)",?45,"|","",!
DO LINE1
+29 IF $Y>(IOSL-12)
DO HEADER^BUDHRPTP
IF BUDQUIT
QUIT
DO T6BH
+30 WRITE !,$$CTR("SECTION B - EARLY ENTRY INTO PRENATAL CARE"),!
DO LINE
+31 WRITE "EARLY ENTRY INTO",?37,"|",?40,"WOMEN HAVING",?60,"|",?63,"WOMEN HAVING",!
+32 WRITE "PRENATAL CARE",?37,"|",?40,"FIRST VISIT WITH",?60,"|",?63,"FIRST VISIT WITH",!
+33 WRITE "",?37,"|",?40,"HEALTH CENTER",?60,"|",?63,"ANOTHER PROVIDER",!
+34 WRITE ?37,"|",?45,"(a)",?60,"|",?68,"(b)",!
+35 DO LINE2
+36 WRITE ?2,7,?5,"First Trimester",?37,"|",?45,"",?60,"|",?68,"",!
DO LINE2
+37 WRITE ?2,8,?5,"Second Trimester",?37,"|",?45,"",?60,"|",?68,"",!
DO LINE2
+38 WRITE ?2,9,?5,"Third Trimester",?37,"|",?45,"",?60,"|",?68,"",!
DO LINE2
+39 ;
+40 DO HEADER^BUDHRPTP
IF BUDQUIT
QUIT
DO T6BH
+41 WRITE $$CTR("SECTION C - CHILDHOOD IMMUNIZATION STATUS"),!
+42 DO LINE
+43 WRITE "CHILDHOOD IMMUNIZATION",?23,"|",?26,"TOTAL PATIENTS",?45,"|",?47,"NUMBER CHARTS",?65,"|",?67,"NUMBER OF",!
+44 WRITE "STATUS",?23,"|",?26,"WITH 2ND",?45,"|",?47,"SAMPLED OR EHR",?65,"|",?67,"PATIENTS",!
+45 WRITE ?23,"|",?26,"BIRTHDAY",?45,"|",?47,"TOTAL",?65,"|",?67,"IMMUNIZED",!
+46 WRITE ?23,"|",?26,"",?45,"|",?47,"",?65,"|",?67,"",!
+47 WRITE ?23,"|",?30,"(a)",?45,"|",?50,"(b)",?65,"|",?70,"(c)",!
+48 DO LINE3
+49 WRITE ?1,"10",?5,"MEASURE: ",?23,"|",?45,"|",?65,"|",!
+50 WRITE ?5,"Percentage of ",?23,"|",?45,"|",?65,"|",!
+51 WRITE ?5,"children 2 years",?23,"|",?45,"|",?65,"|",!
+52 WRITE ?5,"of age who",?23,"|",?45,"|",?65,"|",!
+53 WRITE ?5,"received age",?23,"|",?30,$$C($GET(BUDSECTC("PTS"))),?45,"|",?50,$$C($GET(BUDSECTC("PTS"))),?65,"|",?70,$$C($GET(BUDSECTC("IMM"))),!
+54 WRITE ?5,"appropriate",?23,"|",?45,"|",?65,"|",!
+55 WRITE ?5,"vaccines by their",?23,"|",?45,"|",?65,"|",!
+56 WRITE ?5,"2nd birthday",?23,"|",?45,"|",?65,"|",!
+57 ;W ?5,"birthday",?23,"|",?45,"|",?65,"|",!
+58 DO LINE
+59 IF $Y>(IOSL-20)
DO HEADER^BUDHRPTP
IF BUDQUIT
QUIT
DO T6BH
+60 WRITE $$CTR("SECTION D - CERVICAL CANCER SCREENING"),!
+61 DO LINE
+62 WRITE "CERVICAL CANCER",?23,"|",?26,"TOTAL FEMALE",?45,"|",?47,"NUMBER CHARTS",?65,"|",?67,"NUMBER OF",!
+63 WRITE "SCREENING",?23,"|",?26,"PATIENTS AGED",?45,"|",?47,"SAMPLED OR EHR",?65,"|",?67,"PATIENTS",!
+64 WRITE ?23,"|",?26,"23 THROUGH 64",?45,"|",?47,"TOTAL",?65,"|",?67,"TESTED",!
+65 WRITE ?23,"|",?30,"(a)",?45,"|",?50,"(b)",?65,"|",?70,"(c)",!
+66 DO LINE3
+67 WRITE ?1,"11",?5,"MEASURE: ",?23,"|",?45,"|",?65,"|",!
+68 WRITE ?5,"Percentage of ",?23,"|",?45,"|",?65,"|",!
+69 WRITE ?5,"women 23-64 ",?23,"|",?45,"|",?65,"|",!
+70 WRITE ?5,"years of age, who ",?23,"|",?30,$$C($GET(BUDSECTD("PTS"))),?45,"|",?50,$$C($GET(BUDSECTD("PTS"))),?65,"|",?70,$$C($GET(BUDSECTD("PAP"))),!
+71 WRITE ?5,"were screened for",?23,"|",?45,"|",?65,"|",!
+72 WRITE ?5,"cervical cancer",?23,"|",?45,"|",?65,"|",!
+73 DO LINE
+74 DO REST6B^BUDHRP6E
+75 IF BUDTSCTC>1
IF BUDROT'="D"
WRITE !,"***** END OF SECTION ",BUDSCTC," *****",!
PL DO LISTS^BUDHRP6I
+1 ;D ^%ZISC
+2 IF BUDROT'="D"
IF '$GET(BUDXXXXX)
WRITE !!,"***** END OF REPORT *****",!
+3 IF BUDROT="D"
DO ^%ZISC
DO SAVEDEL^BUDHRPTD
+4 KILL ^XTMP("BUDHRP6B",BUDJ,BUDH)
+5 QUIT
T6BH ;
+1 WRITE !,$$CTR("TABLE 6B - QUALITY OF CARE MEASURES"),!,$$REPEAT^XLFSTR("_",79),!
+2 QUIT
LINE ;
+1 WRITE $$REPEAT^XLFSTR("_",79),!
+2 QUIT
LINE1 ;
+1 WRITE $$REPEAT^XLFSTR("_",45),"|",$$REPEAT^XLFSTR("_",33),!
+2 QUIT
LINE2 ;
+1 WRITE $$REPEAT^XLFSTR("_",37),"|",$$REPEAT^XLFSTR("_",22),"|",$$REPEAT^XLFSTR("_",18),!
+2 QUIT
LINE3 ;
+1 WRITE $$REPEAT^XLFSTR("_",23),"|",$$REPEAT^XLFSTR("_",21),"|",$$REPEAT^XLFSTR("_",19),"|",$$REPEAT^XLFSTR("_",13),!
+2 QUIT
T6BI ;
+1 WRITE !!,"TABLE 6B: QUALITY OF CARE MEASURES"
+2 WRITE !,"This report will produce UDS Table 6B, quality of care measures."
+3 WRITE !,"Patients must meet additional criteria as specified for each measure."
+4 QUIT
GENI ;general introductions
+1 IF $DATA(IOF)
WRITE @(IOF)
+2 WRITE !!,$$CTR($$LOC,80),!,$$CTR("UDS 2018",80),!
+3 WRITE !,"UDS searches your database to find all patients reported for the quality"
+4 WRITE !,"of care measures during the time period January 1 - "
+5 WRITE !,"December 31, 2018. Based on the UDS definition, to be considered a"
+6 WRITE !,"patient, the patient must have had at least one visit meeting the"
+7 WRITE !,"following criteria:"
+8 WRITE !?4,"- must be to a location specified in your visit location setup"
+9 WRITE !?4,"- must be to Service Category Ambulatory (A), Hospitalization (H), Day"
+10 WRITE !?6,"Surgery (S), Observation (O), Telemedicine (M), Nursing home visit (R), "
+11 WRITE !?6,"or In-Hospital (I) visit"
+12 WRITE !?4,"- must NOT have an excluded clinic code (see User Manual for a list)"
+13 WRITE !?4,"- must have a primary provider and a coded purpose of visit"
+14 WRITE !?4,"- the patient must NOT have a gender of 'Unknown'"
+15 WRITE !
+16 QUIT
+17 ;
PRENATT ;EP
+1 DO PRENATT^BUDHRP6I
+2 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
NRY ;
+1 WRITE !!,"not developed yet....."
HANG 3
+2 QUIT
PAUSE ;
+1 KILL DIR
SET DIR(0)="E"
SET DIR("A")="PRESS ENTER"
KILL DA
DO ^DIR
KILL DIR
+2 QUIT
C(X,Y) ;
+1 IF $GET(Y)=1
IF +X=0
QUIT ""
+2 IF $GET(Y)=2
QUIT "********"
+3 SET X2=0
SET X3=8
+4 DO COMMA^%DTC
+5 QUIT X
YEAR ;
+1 SET BUDYEAR=""
+2 WRITE !
+3 WRITE !,"Enter the Calendar Year. Use a 4 digit year, e.g. 2018"
+4 SET DIR(0)="D^::EP"
+5 SET DIR("A")="Enter Calendar Year"
+6 SET DIR("?")="This report is compiled for a period. Enter a valid date."
+7 DO ^DIR
KILL DIR
+8 KILL DIC
+9 IF $DATA(DUOUT)
SET DIRUT=1
QUIT
+10 IF $DATA(DIRUT)
QUIT
+11 IF $EXTRACT(Y,4,7)'="0000"
WRITE !!,"Please enter a year only!",!
GOTO YEAR
+12 SET BUDYEAR=Y
SET BUDBD=$EXTRACT(BUDYEAR,1,3)_"0101"
SET BUDED=$EXTRACT(BUDYEAR,1,3)_"1231"
+13 SET BUDCCAD=$EXTRACT(BUDYEAR,1,3)_"0630"
+14 QUIT
