BUD8RP6B ; IHS/CMI/LAB - UDS REPORT DRIVER TABLE 6B 30 Dec 2008 8:09 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
T6B ;
D EOJ
EN ;
D GENI
D T6BI
D PAUSE
D PRENATT
D PAUSE
;
EN1 ;
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="^BUDGSITE(",DIC(0)="AEMQ",DIC("A")="Enter your site: " D ^DIC
I Y=-1 G PNC
S BUDSITE=+Y
I '$O(^BUDGSITE(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^BUD8XTCH
S BUDYEAR=3080000,BUDBD=3080101,BUDED=3081231
S BUDCAD=3080630
S BUDYEAR=3030000,BUDBD=3030101,BUDED=3031231
S BUDCAD=3030630
W !!,"Your report will be run for the time period: ",$$FMTE^XLFDT(BUDBD)," to ",$$FMTE^XLFDT(BUDED)
ZIS ;call to XBDBQUE
K IOP,%ZIS
W !! S %ZIS="PQM" D ^%ZIS
I POP D EOJ Q
ZIS1 ;
I $D(IO("Q")) G TSKMN
DRIVER ;
D PROC
U IO
D PRINT
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^BUD8RP6B",ZTDTH="",ZTDESC="UDS 08 REPORT TABLE 6B" D ^%ZTLOAD D EOJ Q
Q
EOJ ;
D EN^XBVK("BUD")
Q
PAPLIST1 ;EP
D EOJ
S BUDPAP1L=1
D PAP1^BUD8RP6P
G EN1
;
PAPLIST2 ;EP
D EOJ
S BUDPAP2L=1
D PAP2^BUD8RP6P
G EN1
IMMLIST1 ;EP
D EOJ
S BUDIMM1L=1
D IMM1^BUD8RP6I
G EN1
IMMLIST2 ;EP
D EOJ
S BUDIMM2L=1
D IMM2^BUD8RP6I
G EN1
PRGA ;EP
D EOJ
S BUDPRGAL=1
D PRGA^BUD8RP6I
G EN1
;
M ;EP - called from option
D EOJ
D GENI^BUD8RP6I
S (BUDIMM1L,BUDIMM2L,BUDPAP1L,BUDPAP2L,BUDPRGAL)=0
W !!,"UDS Table 6B List Selection"
W !!?5,"1 All Pregnant Patients by Age"
W !?5,"2 All Patients Age 2 w/All Child Immunizations"
W !?5,"3 All Patients Age 2 w/o All Child Immunizations"
W !?5,"4 All Female Patients w/Pap Test"
W !?5,"5 All Female Patients w/o Pap Test"
W !?5,"6 ALL Patient Lists for LST2 (Table 6B)"
S DIR(0)="L^1:6",DIR("A")="Include which Tables",DIR("B")=1 KILL DA D ^DIR KILL DIR
I $D(DIRUT) D EOJ Q
I Y[6 S (BUDIMM1L,BUDIMM2L,BUDPAP1L,BUDPAP2L,BUDPRGAL)=1
I Y[1 S BUDPRGAL=1
I Y[2 S BUDIMM1L=1
I Y[3 S BUDIMM2L=1
I Y[4 S BUDPAP1L=1
I Y[5 S BUDPAP2L=1
G EN1
Q
PROC ;EP - called from taskman
S BUDJ=$J,BUDH=$H
S ^XTMP("BUD8RP6B",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^BUD TABLE 6B LISTS"
;NOW LOOP THROUGH PATIENT FILE for imms and paps
S DFN=0 F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN D
.;Q:DFN'=126900
.K ^TMP($J)
.Q:'$D(^AUPNPAT(DFN,0))
.Q:'$D(^DPT(DFN,0))
.Q:$P(^DPT(DFN,0),U,19) ;merged away
.Q:$P(^DPT(DFN,0),U,1)["DEMO,PATIENT"
.Q:$P(^DPT(DFN,0),U,1)["PATIENT,CRS"
.S C=$$COMMRES^AUPNPAT(DFN,"E")
.;I C'="COWETA",C'="TULSA,URBAN" Q
.S BUDSEX=$P(^DPT(DFN,0),U,2)
.S BUDCOM=$$COMMRES^AUPNPAT(DFN,"E") I BUDCOM="" S BUDCOM="UNKNOWN"
.S BUDAGE=$$AGE^AUPNPAT(DFN,BUDED) ;age at end of time period
.S BUDAGEP=$$AGE^AUPNPAT(DFN,BUDCAD) ;age on june 30 for pregnancy
.D GETV^BUD8RPTD ;get visits that meet criteria
.I BUDT35V=0 Q ;user doesn't have any countable visits and is not considered a user
.I $G(BUDPRGAL) D PRGALST
.D IMM^BUD8RP6C
.D PAPD^BUD8RP6D
Q
PRGALST ; list of pregnant females
;is patient pregnant during the time period BUDBD and BUDED
Q:BUDSEX'="F"
S BUDP=$$PREG(DFN,$$FMADD^XLFDT(BUDED,(-(30*20))),BUDED)
I '$P(BUDP,U) Q ;not pregnant
S X=$$AGB(BUDAGEP)
S ^XTMP("BUD8RP6B",BUDJ,BUDH,"PRGA",X,BUDAGEP,$P(^DPT(DFN,0),U),BUDCOM,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,NORXCHR) ;EP
NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL,BUDA
S B=0,CNT=0,BUDD="",BUDALL="" ;if there is one before time frame set this to 1
S NORXCHR=$G(NORXCHR)
K BUDG
S Y="BUDG("
S X=P_"^ALL DX [BGP GPRA PREGNANCY DIAGNOSES;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
;now reorder by date of diagnosis and eliminate all chr and rx if necessary
;I '$D(BUDG) G PROB ;no diagnoses
;unduplicate by date
S X=0 F S X=$O(BUDG(X)) Q:X'=+X S BUDA($P(BUDG(X),U,1))=BUDG(X)
K BUDG
M BUDG=BUDA
S X=0 F S X=$O(BUDG(X)) Q:X'=+X D
.;get date
.S D=$P(BUDG(X),U,1)
.S C=$$CLINIC^APCLV($P(BUDG(X),U,5),"C")
.I NORXCHR,C=39 Q
.S C=$$PRIMPROV^APCLV($P(BUDG(X),U,5),"D")
.I NORXCHR,C=53 Q ;no chr as primary provider
.S V=$P(BUDG(X),U,5)
.S BUDDX(D)="",CNT=CNT+1,BUDALL=BUDALL_V_"|"_$P(BUDG(X),U,2)_U I CNT=2 S BUDD=D
.I D>$$FMADD^XLFDT(EDATE,-365) S B=1
.Q
I CNT>1,B G MA
I 'B Q 0 ;no visit during time period
PROB S T=$O(^ATXAX("B","BGP GPRA PREGNANCY DIAGNOSES",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)'="A"
.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^BUD8UTL1(G)
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^BUD8UTL1(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)'="A"
.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^BUD8DU(P,BUDD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$CPT^BUD8DU(P,BUDD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
S %=$$TRAN^BUD8DU(P,BUDD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$TRAN^BUD8DU(P,BUDD,EDATE,T,3)
I %]"" Q 0
Q 1_"*"_BUDALL
;
PRINT ;EP - called from taskman
S BUDPG=0
S BUDQUIT=0
S BUD80L="",$P(BUD80L,"_",79)="_"
D HEADER^BUD8RPTP Q:BUDQUIT D T6BH
W !!,"(NO PRENATAL CARE PROVIDED? CHECK HERE: "_$S(BUDPREN=0:"X",1:""),")",!
D LINE
W $$CTR("SECTION A: AGE CATEGORIES FOR PRENATAL PATIENTS"),!
W $$CTR("(GRANTEES WHO PROVIDE PRENATAL CARE ONLY)"),!
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,"|",!
D LINE1
W ?2,"2",?5,"AGES 15-19",?45,"|",!
D LINE1
I $Y>(IOSL-3) D HEADER^BUD8RPTP Q:BUDQUIT D T6BH
W ?2,"3",?5,"AGES 20-24",?45,"|",! D LINE1
I $Y>(IOSL-3) D HEADER^BUD8RPTP Q:BUDQUIT D T6BH
W ?2,"4",?5,"AGES 25-44",?45,"|",! D LINE1
I $Y>(IOSL-3) D HEADER^BUD8RPTP Q:BUDQUIT D T6BH
W ?2,"5",?5,"AGES 45 AND OVER",?45,"|",! D LINE1
I $Y>(IOSL-3) D HEADER^BUD8RPTP Q:BUDQUIT D T6BH
W ?2,"6",?5,"TOTAL PATIENTS (SUM LINES 1-5)",?45,"|",! D LINE1
I $Y>(IOSL-12) D HEADER^BUD8RPTP Q:BUDQUIT D T6BH
W !,$$CTR("SECTION B - TRIMESTER OF ENTRY INTO PRENATAL CARE"),! D LINE
W "TRIMESTER OF FIRST KNOWN VISIT",?37,"|",?40,"WOMEN HAVING",?60,"|",?63,"WOMEN HAVING",!
W "FOR WOMEN RECEIVING PRENATAL",?37,"|",?40,"FIRST VISIT WITH",?60,"|",?63,"FIRST VISIT WITH",!
W "CARE DURING REPORTING YEAR",?37,"|",?40," GRANTEE",?60,"|",?63,"ANOTHER PROVIDER",!
W ?37,"|",?45,"(a)",?60,"|",?68,"(b)",!
D LINE2
W ?2,7,?5,"First Trimester",?37,"|",?60,"|",! D LINE2
W ?2,8,?5,"Second Trimester",?37,"|",?60,"|",! D LINE2
W ?2,9,?5,"Third Trimester",?37,"|",?60,"|",! D LINE2
;
D HEADER^BUD8RPTP Q:BUDQUIT D T6BH
;D LINE
W $$CTR("SECTION C - CHILDHOOD IMMUNIZATION"),!
D LINE
W "CHILDHOOD IMMUNIZATION",?23,"|",?26,"TOTAL NUMBER",?45,"|",?47,"NUMBER CHARTS",?65,"|",?67,"NUMBER OF",!
W ?23,"|",?26,"PATIENTS WITH 2ND",?45,"|",?47,"SAMPLED OR EHR",?65,"|",?67,"PATIENTS",!
W ?23,"|",?26,"BIRTHDAY DURING",?45,"|",?47,"TOTAL",?65,"|",?67,"IMMUNIZED",!
W ?23,"|",?26,"MEASUREMENT YEAR",?45,"|",?47,"",?65,"|",?67,"",!
W ?23,"|",?30,"(a)",?45,"|",?50,"(b)",?65,"|",?70,"(c)",!
D LINE3
W ?1,"10",?5,"Number of children",?23,"|",?45,"|",?65,"|",!
W ?5,"who have received",?23,"|",?45,"|",?65,"|",!
W ?5,"required vaccines",?23,"|",?45,"|",?65,"|",!
W ?5,"who had their 2nd",?23,"|",?30,$$C($G(BUDSECTC("PTS"))),?45,"|",?50,$$C($G(BUDSECTC("PTS"))),?65,"|",?70,$$C($G(BUDSECTC("IMM"))),!
W ?5,"birthday during",?23,"|",?45,"|",?65,"|",!
W ?5,"measurement year",?23,"|",?45,"|",?65,"|",!
W ?5,"(on or prior to",?23,"|",?45,"|",?65,"|",!
W ?5,"31 December)",?23,"|",?45,"|",?65,"|",!
D LINE
I $Y>(IOSL-20) D HEADER^BUD8RPTP Q:BUDQUIT D T6BH
W $$CTR("SECTION D - PAP TESTS"),!
D LINE
W "PAP TEST",?23,"|",?26,"TOTAL NUMBER",?45,"|",?47,"NUMBER CHARTS",?65,"|",?67,"NUMBER OF",!
W ?23,"|",?26,"OF FEMALE PATIENTS",?45,"|",?47,"SAMPLED OR EHR",?65,"|",?67,"PATIENTS",!
W ?23,"|",?26,"21-64 YEARS OF AGE",?45,"|",?47,"TOTAL",?65,"|",?67,"TESTED",!
W ?23,"|",?30,"(a)",?45,"|",?50,"(b)",?65,"|",?70,"(c)",!
D LINE3
W ?1,"10",?5,"Number of female",?23,"|",?45,"|",?65,"|",!
W ?5,"patients aged",?23,"|",?45,"|",?65,"|",!
W ?5,"21-64 who had at",?23,"|",?45,"|",?65,"|",!
W ?5,"least on Pap test",?23,"|",?30,$$C($G(BUDSECTD("PTS"))),?45,"|",?50,$$C($G(BUDSECTD("PTS"))),?65,"|",?70,$$C($G(BUDSECTD("PAP"))),!
W ?5,"performed during",?23,"|",?45,"|",?65,"|",!
W ?5,"the measurement",?23,"|",?45,"|",?65,"|",!
W ?5,"year or during one",?23,"|",?45,"|",?65,"|",!
W ?5,"of the two ",?23,"|",?45,"|",?65,"|",!
W ?5,"previous years",?23,"|",?45,"|",?65,"|",!
D LINE
I $G(BUDPRGAL) S BUDGPG=0 D PRGAL^BUD8RP6I
I $G(BUDIMM1L) S BUDGPG=0 D IMM1L^BUD8RP6I
I $G(BUDIMM2L) S BUDGPG=0 D IMM2L^BUD8RP6I
I $G(BUDPAP1L) S BUDGPG=0 D PAP1L^BUD8RP6P
I $G(BUDPAP2L) S BUDGPG=0 D PAP2L^BUD8RP6P
;K ^XTMP("BUD8RP6B",BUDJ,BUDH)
Q
T6BH ;
W !,$$CTR("TABLE 6B - QUALITY OF CARE INDICATORS"),!,$$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 INDICATORS"
W !,"This report will produce UDS Table 6B, quality of care indicators"
W !,"for prenatal care, childhood immunizations and Pap tests. Patients"
W !,"must meet additional criteria as specified for each indicator."
Q
GENI ;general introductions
W:$D(IOF) @(IOF)
W !!,$$CTR($$LOC,80),!,$$CTR("UDS 2008",80),!
W !,"UDS searches your database to find all patients reported for the quality"
W !,"of care indicators during the time period January 1, 2008 through"
W !,"December 31, 2008. Based on the UDS defintion, 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), 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 !
Q
;
PRENATT ;
W !!,"UDS does not calculate the prenatal care indicators in Sections A and B."
W !,"However, you can run a list of patients identified by UDS as pregnant to"
W !,"determine which of them received prenatal care at your facility to assist"
W !,"you with completing Table 6B, Sections A and B. The menu options you "
W !,"would select to run the patient list are: LST, LST2, PRGA."
W !
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
BUD8RP6B ; IHS/CMI/LAB - UDS REPORT DRIVER TABLE 6B 30 Dec 2008 8:09 PM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
+3 ;
T6B ;
+1 DO EOJ
EN ;
+1 DO GENI
+2 DO T6BI
+3 DO PAUSE
+4 DO PRENATT
+5 DO PAUSE
+6 ;
EN1 ;
PNC ;
+1 SET BUDPREN=""
+2 SET DIR(0)="Y"
SET DIR("A")="Does your facility provide prenatal care"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
DO EOJ
QUIT
+4 SET BUDPREN=Y
+5 ;
EN2 ;
+1 SET BUDSITE=""
+2 SET DIC="^BUDGSITE("
SET DIC(0)="AEMQ"
SET DIC("A")="Enter your site: "
DO ^DIC
+3 IF Y=-1
GOTO PNC
+4 SET BUDSITE=+Y
+5 IF '$ORDER(^BUDGSITE(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^BUD8XTCH
+7 SET BUDYEAR=3080000
SET BUDBD=3080101
SET BUDED=3081231
+8 SET BUDCAD=3080630
+9 SET BUDYEAR=3030000
SET BUDBD=3030101
SET BUDED=3031231
+10 SET BUDCAD=3030630
+11 WRITE !!,"Your report will be run for the time period: ",$$FMTE^XLFDT(BUDBD)," to ",$$FMTE^XLFDT(BUDED)
ZIS ;call to XBDBQUE
+1 KILL IOP,%ZIS
+2 WRITE !!
SET %ZIS="PQM"
DO ^%ZIS
+3 IF POP
DO EOJ
QUIT
ZIS1 ;
+1 IF $DATA(IO("Q"))
GOTO TSKMN
DRIVER ;
+1 DO PROC
+2 USE IO
+3 DO PRINT
+4 DO ^%ZISC
+5 DO EOJ
+6 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^BUD8RP6B"
SET ZTDTH=""
SET ZTDESC="UDS 08 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^BUD8RP6P
+4 GOTO EN1
+5 ;
PAPLIST2 ;EP
+1 DO EOJ
+2 SET BUDPAP2L=1
+3 DO PAP2^BUD8RP6P
+4 GOTO EN1
IMMLIST1 ;EP
+1 DO EOJ
+2 SET BUDIMM1L=1
+3 DO IMM1^BUD8RP6I
+4 GOTO EN1
IMMLIST2 ;EP
+1 DO EOJ
+2 SET BUDIMM2L=1
+3 DO IMM2^BUD8RP6I
+4 GOTO EN1
PRGA ;EP
+1 DO EOJ
+2 SET BUDPRGAL=1
+3 DO PRGA^BUD8RP6I
+4 GOTO EN1
+5 ;
M ;EP - called from option
+1 DO EOJ
+2 DO GENI^BUD8RP6I
+3 SET (BUDIMM1L,BUDIMM2L,BUDPAP1L,BUDPAP2L,BUDPRGAL)=0
+4 WRITE !!,"UDS Table 6B List Selection"
+5 WRITE !!?5,"1 All Pregnant Patients by Age"
+6 WRITE !?5,"2 All Patients Age 2 w/All Child Immunizations"
+7 WRITE !?5,"3 All Patients Age 2 w/o All Child Immunizations"
+8 WRITE !?5,"4 All Female Patients w/Pap Test"
+9 WRITE !?5,"5 All Female Patients w/o Pap Test"
+10 WRITE !?5,"6 ALL Patient Lists for LST2 (Table 6B)"
+11 SET DIR(0)="L^1:6"
SET DIR("A")="Include which Tables"
SET DIR("B")=1
KILL DA
DO ^DIR
KILL DIR
+12 IF $DATA(DIRUT)
DO EOJ
QUIT
+13 IF Y[6
SET (BUDIMM1L,BUDIMM2L,BUDPAP1L,BUDPAP2L,BUDPRGAL)=1
+14 IF Y[1
SET BUDPRGAL=1
+15 IF Y[2
SET BUDIMM1L=1
+16 IF Y[3
SET BUDIMM2L=1
+17 IF Y[4
SET BUDPAP1L=1
+18 IF Y[5
SET BUDPAP2L=1
+19 GOTO EN1
+20 QUIT
PROC ;EP - called from taskman
+1 SET BUDJ=$JOB
SET BUDH=$HOROLOG
+2 SET ^XTMP("BUD8RP6B",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^BUD TABLE 6B LISTS"
+3 ;NOW LOOP THROUGH PATIENT FILE for imms and paps
+4 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:1
+5 ;Q:DFN'=126900
+6 KILL ^TMP($JOB)
+7 IF '$DATA(^AUPNPAT(DFN,0))
QUIT
+8 IF '$DATA(^DPT(DFN,0))
QUIT
+9 ;merged away
IF $PIECE(^DPT(DFN,0),U,19)
QUIT
+10 IF $PIECE(^DPT(DFN,0),U,1)["DEMO,PATIENT"
QUIT
+11 IF $PIECE(^DPT(DFN,0),U,1)["PATIENT,CRS"
QUIT
+12 SET C=$$COMMRES^AUPNPAT(DFN,"E")
+13 ;I C'="COWETA",C'="TULSA,URBAN" Q
+14 SET BUDSEX=$PIECE(^DPT(DFN,0),U,2)
+15 SET BUDCOM=$$COMMRES^AUPNPAT(DFN,"E")
IF BUDCOM=""
SET BUDCOM="UNKNOWN"
+16 ;age at end of time period
SET BUDAGE=$$AGE^AUPNPAT(DFN,BUDED)
+17 ;age on june 30 for pregnancy
SET BUDAGEP=$$AGE^AUPNPAT(DFN,BUDCAD)
+18 ;get visits that meet criteria
DO GETV^BUD8RPTD
+19 ;user doesn't have any countable visits and is not considered a user
IF BUDT35V=0
QUIT
+20 IF $GET(BUDPRGAL)
DO PRGALST
+21 DO IMM^BUD8RP6C
+22 DO PAPD^BUD8RP6D
End DoDot:1
+23 QUIT
PRGALST ; list of pregnant females
+1 ;is patient pregnant during the time period BUDBD and BUDED
+2 IF BUDSEX'="F"
QUIT
+3 SET BUDP=$$PREG(DFN,$$FMADD^XLFDT(BUDED,(-(30*20))),BUDED)
+4 ;not pregnant
IF '$PIECE(BUDP,U)
QUIT
+5 SET X=$$AGB(BUDAGEP)
+6 SET ^XTMP("BUD8RP6B",BUDJ,BUDH,"PRGA",X,BUDAGEP,$PIECE(^DPT(DFN,0),U),BUDCOM,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,NORXCHR) ;EP
+1 NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL,BUDA
+2 ;if there is one before time frame set this to 1
SET B=0
SET CNT=0
SET BUDD=""
SET BUDALL=""
+3 SET NORXCHR=$GET(NORXCHR)
+4 KILL BUDG
+5 SET Y="BUDG("
+6 SET X=P_"^ALL DX [BGP GPRA PREGNANCY DIAGNOSES;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 ;now reorder by date of diagnosis and eliminate all chr and rx if necessary
+8 ;I '$D(BUDG) G PROB ;no diagnoses
+9 ;unduplicate by date
+10 SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
SET BUDA($PIECE(BUDG(X),U,1))=BUDG(X)
+11 KILL BUDG
+12 MERGE BUDG=BUDA
+13 SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
Begin DoDot:1
+14 ;get date
+15 SET D=$PIECE(BUDG(X),U,1)
+16 SET C=$$CLINIC^APCLV($PIECE(BUDG(X),U,5),"C")
+17 IF NORXCHR
IF C=39
QUIT
+18 SET C=$$PRIMPROV^APCLV($PIECE(BUDG(X),U,5),"D")
+19 ;no chr as primary provider
IF NORXCHR
IF C=53
QUIT
+20 SET V=$PIECE(BUDG(X),U,5)
+21 SET BUDDX(D)=""
SET CNT=CNT+1
SET BUDALL=BUDALL_V_"|"_$PIECE(BUDG(X),U,2)_U
IF CNT=2
SET BUDD=D
+22 IF D>$$FMADD^XLFDT(EDATE,-365)
SET B=1
+23 QUIT
End DoDot:1
+24 IF CNT>1
IF B
GOTO MA
+25 ;no visit during time period
IF 'B
QUIT 0
PROB SET T=$ORDER(^ATXAX("B","BGP GPRA PREGNANCY DIAGNOSES",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)'="A"
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^BUD8UTL1(G)
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^BUD8UTL1(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)'="A"
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^BUD8DU(P,BUDD,EDATE,T,3)
+19 IF %]""
QUIT 0
+20 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+21 SET %=$$CPT^BUD8DU(P,BUDD,EDATE,T,3)
+22 IF %]""
QUIT 0
+23 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+24 SET %=$$TRAN^BUD8DU(P,BUDD,EDATE,T,3)
+25 IF %]""
QUIT 0
+26 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+27 SET %=$$TRAN^BUD8DU(P,BUDD,EDATE,T,3)
+28 IF %]""
QUIT 0
+29 QUIT 1_"*"_BUDALL
+30 ;
PRINT ;EP - called from taskman
+1 SET BUDPG=0
+2 SET BUDQUIT=0
+3 SET BUD80L=""
SET $PIECE(BUD80L,"_",79)="_"
+4 DO HEADER^BUD8RPTP
IF BUDQUIT
QUIT
DO T6BH
+5 WRITE !!,"(NO PRENATAL CARE PROVIDED? CHECK HERE: "_$SELECT(BUDPREN=0:"X",1:""),")",!
+6 DO LINE
+7 WRITE $$CTR("SECTION A: AGE CATEGORIES FOR PRENATAL PATIENTS"),!
+8 WRITE $$CTR("(GRANTEES WHO PROVIDE PRENATAL CARE ONLY)"),!
+9 DO LINE
+10 WRITE $$CTR("DEMOGRAPHIC CHARACTERISTICS OF PRENATAL CARE PATIENTS"),!
+11 DO LINE
+12 WRITE ?20,"AGE",?45,"|",?50,"NUMBER OF PATIENTS (a)",!
+13 DO LINE1
+14 WRITE ?2,"1",?5,"LESS THAN 15 YEARS",?45,"|",!
+15 DO LINE1
+16 WRITE ?2,"2",?5,"AGES 15-19",?45,"|",!
+17 DO LINE1
+18 IF $Y>(IOSL-3)
DO HEADER^BUD8RPTP
IF BUDQUIT
QUIT
DO T6BH
+19 WRITE ?2,"3",?5,"AGES 20-24",?45,"|",!
DO LINE1
+20 IF $Y>(IOSL-3)
DO HEADER^BUD8RPTP
IF BUDQUIT
QUIT
DO T6BH
+21 WRITE ?2,"4",?5,"AGES 25-44",?45,"|",!
DO LINE1
+22 IF $Y>(IOSL-3)
DO HEADER^BUD8RPTP
IF BUDQUIT
QUIT
DO T6BH
+23 WRITE ?2,"5",?5,"AGES 45 AND OVER",?45,"|",!
DO LINE1
+24 IF $Y>(IOSL-3)
DO HEADER^BUD8RPTP
IF BUDQUIT
QUIT
DO T6BH
+25 WRITE ?2,"6",?5,"TOTAL PATIENTS (SUM LINES 1-5)",?45,"|",!
DO LINE1
+26 IF $Y>(IOSL-12)
DO HEADER^BUD8RPTP
IF BUDQUIT
QUIT
DO T6BH
+27 WRITE !,$$CTR("SECTION B - TRIMESTER OF ENTRY INTO PRENATAL CARE"),!
DO LINE
+28 WRITE "TRIMESTER OF FIRST KNOWN VISIT",?37,"|",?40,"WOMEN HAVING",?60,"|",?63,"WOMEN HAVING",!
+29 WRITE "FOR WOMEN RECEIVING PRENATAL",?37,"|",?40,"FIRST VISIT WITH",?60,"|",?63,"FIRST VISIT WITH",!
+30 WRITE "CARE DURING REPORTING YEAR",?37,"|",?40," GRANTEE",?60,"|",?63,"ANOTHER PROVIDER",!
+31 WRITE ?37,"|",?45,"(a)",?60,"|",?68,"(b)",!
+32 DO LINE2
+33 WRITE ?2,7,?5,"First Trimester",?37,"|",?60,"|",!
DO LINE2
+34 WRITE ?2,8,?5,"Second Trimester",?37,"|",?60,"|",!
DO LINE2
+35 WRITE ?2,9,?5,"Third Trimester",?37,"|",?60,"|",!
DO LINE2
+36 ;
+37 DO HEADER^BUD8RPTP
IF BUDQUIT
QUIT
DO T6BH
+38 ;D LINE
+39 WRITE $$CTR("SECTION C - CHILDHOOD IMMUNIZATION"),!
+40 DO LINE
+41 WRITE "CHILDHOOD IMMUNIZATION",?23,"|",?26,"TOTAL NUMBER",?45,"|",?47,"NUMBER CHARTS",?65,"|",?67,"NUMBER OF",!
+42 WRITE ?23,"|",?26,"PATIENTS WITH 2ND",?45,"|",?47,"SAMPLED OR EHR",?65,"|",?67,"PATIENTS",!
+43 WRITE ?23,"|",?26,"BIRTHDAY DURING",?45,"|",?47,"TOTAL",?65,"|",?67,"IMMUNIZED",!
+44 WRITE ?23,"|",?26,"MEASUREMENT YEAR",?45,"|",?47,"",?65,"|",?67,"",!
+45 WRITE ?23,"|",?30,"(a)",?45,"|",?50,"(b)",?65,"|",?70,"(c)",!
+46 DO LINE3
+47 WRITE ?1,"10",?5,"Number of children",?23,"|",?45,"|",?65,"|",!
+48 WRITE ?5,"who have received",?23,"|",?45,"|",?65,"|",!
+49 WRITE ?5,"required vaccines",?23,"|",?45,"|",?65,"|",!
+50 WRITE ?5,"who had their 2nd",?23,"|",?30,$$C($GET(BUDSECTC("PTS"))),?45,"|",?50,$$C($GET(BUDSECTC("PTS"))),?65,"|",?70,$$C($GET(BUDSECTC("IMM"))),!
+51 WRITE ?5,"birthday during",?23,"|",?45,"|",?65,"|",!
+52 WRITE ?5,"measurement year",?23,"|",?45,"|",?65,"|",!
+53 WRITE ?5,"(on or prior to",?23,"|",?45,"|",?65,"|",!
+54 WRITE ?5,"31 December)",?23,"|",?45,"|",?65,"|",!
+55 DO LINE
+56 IF $Y>(IOSL-20)
DO HEADER^BUD8RPTP
IF BUDQUIT
QUIT
DO T6BH
+57 WRITE $$CTR("SECTION D - PAP TESTS"),!
+58 DO LINE
+59 WRITE "PAP TEST",?23,"|",?26,"TOTAL NUMBER",?45,"|",?47,"NUMBER CHARTS",?65,"|",?67,"NUMBER OF",!
+60 WRITE ?23,"|",?26,"OF FEMALE PATIENTS",?45,"|",?47,"SAMPLED OR EHR",?65,"|",?67,"PATIENTS",!
+61 WRITE ?23,"|",?26,"21-64 YEARS OF AGE",?45,"|",?47,"TOTAL",?65,"|",?67,"TESTED",!
+62 WRITE ?23,"|",?30,"(a)",?45,"|",?50,"(b)",?65,"|",?70,"(c)",!
+63 DO LINE3
+64 WRITE ?1,"10",?5,"Number of female",?23,"|",?45,"|",?65,"|",!
+65 WRITE ?5,"patients aged",?23,"|",?45,"|",?65,"|",!
+66 WRITE ?5,"21-64 who had at",?23,"|",?45,"|",?65,"|",!
+67 WRITE ?5,"least on Pap test",?23,"|",?30,$$C($GET(BUDSECTD("PTS"))),?45,"|",?50,$$C($GET(BUDSECTD("PTS"))),?65,"|",?70,$$C($GET(BUDSECTD("PAP"))),!
+68 WRITE ?5,"performed during",?23,"|",?45,"|",?65,"|",!
+69 WRITE ?5,"the measurement",?23,"|",?45,"|",?65,"|",!
+70 WRITE ?5,"year or during one",?23,"|",?45,"|",?65,"|",!
+71 WRITE ?5,"of the two ",?23,"|",?45,"|",?65,"|",!
+72 WRITE ?5,"previous years",?23,"|",?45,"|",?65,"|",!
+73 DO LINE
+74 IF $GET(BUDPRGAL)
SET BUDGPG=0
DO PRGAL^BUD8RP6I
+75 IF $GET(BUDIMM1L)
SET BUDGPG=0
DO IMM1L^BUD8RP6I
+76 IF $GET(BUDIMM2L)
SET BUDGPG=0
DO IMM2L^BUD8RP6I
+77 IF $GET(BUDPAP1L)
SET BUDGPG=0
DO PAP1L^BUD8RP6P
+78 IF $GET(BUDPAP2L)
SET BUDGPG=0
DO PAP2L^BUD8RP6P
+79 ;K ^XTMP("BUD8RP6B",BUDJ,BUDH)
+80 QUIT
T6BH ;
+1 WRITE !,$$CTR("TABLE 6B - QUALITY OF CARE INDICATORS"),!,$$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 INDICATORS"
+2 WRITE !,"This report will produce UDS Table 6B, quality of care indicators"
+3 WRITE !,"for prenatal care, childhood immunizations and Pap tests. Patients"
+4 WRITE !,"must meet additional criteria as specified for each indicator."
+5 QUIT
GENI ;general introductions
+1 IF $DATA(IOF)
WRITE @(IOF)
+2 WRITE !!,$$CTR($$LOC,80),!,$$CTR("UDS 2008",80),!
+3 WRITE !,"UDS searches your database to find all patients reported for the quality"
+4 WRITE !,"of care indicators during the time period January 1, 2008 through"
+5 WRITE !,"December 31, 2008. Based on the UDS defintion, 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), 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 !
+15 QUIT
+16 ;
PRENATT ;
+1 WRITE !!,"UDS does not calculate the prenatal care indicators in Sections A and B."
+2 WRITE !,"However, you can run a list of patients identified by UDS as pregnant to"
+3 WRITE !,"determine which of them received prenatal care at your facility to assist"
+4 WRITE !,"you with completing Table 6B, Sections A and B. The menu options you "
+5 WRITE !,"would select to run the patient list are: LST, LST2, PRGA."
+6 WRITE !
+7 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
