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

BUDERP6B.m

Go to the documentation of this file. 
  1. BUDERP6B ;IHS/CMI/LAB - UDS TABLE 6B DRIVER;
  1.  ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
  1.  ;
  1.  ;
  1. T6B ;
  1.  D EOJ
  1. EN ;
  1.  S BUDNOLI=1
  1.  D GENI
  1.  D T6BI
  1.  D PAUSE
  1.  D PRENATT
  1.  D PAUSE
  1.  ;
  1. EN1 ;EP
  1. PNC ;
  1.  ;S BUDPREN=""
  1.  ;S DIR(0)="Y",DIR("A")="Does your facility provide prenatal care",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  ;I $D(DIRUT) D EOJ Q
  1.  ;S BUDPREN=Y
  1.  ;
  1. EN2 ;
  1.  S BUDSITE=""
  1.  S DIC="^BUDESITE(",DIC(0)="AEMQ",DIC("A")="Enter your site: " D ^DIC
  1.  I Y=-1 D EOJ Q
  1.  S BUDSITE=+Y
  1.  I '$O(^BUDESITE(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
  1.  S BUDTAXT="B6" D TAXCHK^BUDEXTCH
  1.  D YEAR
  1.  I BUDYEAR="" D EOJ Q
  1.  W !!,"Your report will be run for the time period: ",$$FMTE^XLFDT(BUDBD)," to ",$$FMTE^XLFDT(BUDED)
  1.  ;get indian or not
  1.  S BUDBEN=""
  1.  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"
  1.  S DIR("B")="1" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) W !!,"Classification not entered." D EOJ Q
  1.  S BUDBEN=Y
  1.  I $G(BUDNOLI) S BUDROT="P",BUDDELT="" G ZIS
  1.  D PT^BUDERPTE
  1.  I BUDROT="" G EN1
  1. ZIS ;call to XBDBQUE
  1.  K IOP,%ZIS I BUDROT="D",BUDDELT="F" D NODEV,EOJ Q
  1.  W !! S %ZIS=$S(BUDDELT'="S":"PQM",1:"PM") D ^%ZIS
  1. ZIS1 ;
  1.  I POP W !,"Report Aborted" D EOJ Q
  1.  I $D(IO("Q")) G TSKMN
  1. DRIVER ;
  1.  D PROC
  1.  U IO
  1.  D PRINT
  1.  D ^%ZISC
  1.  D EOJ
  1.  Q
  1. NODEV ;
  1.  S XBRP="",XBRC="NODEV1^BUDERP6B",XBRX="EOJ^BUDERP6B",XBNS="BUD"
  1.  D ^XBDBQUE
  1.  Q
  1. NODEV1 ;
  1.  D PROC^BUDERP6B
  1.  D PRINT^BUDERP6B
  1.  D ^%ZISC
  1.  D EOJ
  1.  Q
  1. TSKMN ;EP ENTRY POINT FROM TASKMAN
  1.  S ZTIO=$S($D(ION):ION,1:IO) I $D(IOST)#2,IOST]"" S ZTIO=ZTIO_";"_IOST
  1.  I $G(IO("DOC"))]"" S ZTIO=ZTIO_";"_$G(IO("DOC"))
  1.  I $D(IOM)#2,IOM S ZTIO=ZTIO_";"_IOM I $D(IOSL)#2,IOSL S ZTIO=ZTIO_";"_IOSL
  1.  K ZTSAVE S ZTSAVE("BUD*")=""
  1.  S ZTCPU=$G(IOCPU),ZTRTN="DRIVER^BUDERP6B",ZTDTH="",ZTDESC="UDS 17 REPORT TABLE 6B" D ^%ZTLOAD D EOJ Q
  1.  Q
  1. EOJ ;
  1.  D EN^XBVK("BUD")
  1.  Q
  1. PAPLIST1 ;EP
  1.  D EOJ
  1.  S BUDPAP1L=1
  1.  D PAP1^BUDERP6P
  1.  G EN1
  1.  ;
  1. PAPLIST2 ;EP
  1.  D EOJ
  1.  S BUDPAP2L=1
  1.  D PAP2^BUDERP6P
  1.  G EN1
  1. DSLIST1 ;EP
  1.  D EOJ
  1.  S BUDDS1L=1
  1.  D DS1^BUDERP61
  1.  G EN1
  1.  ;
  1. DSLIST2 ;EP
  1.  D EOJ
  1.  S BUDDS2L=1
  1.  D DS2^BUDERP61
  1.  G EN1
  1. IMMLIST1 ;EP
  1.  D EOJ
  1.  S BUDIMM1L=1
  1.  D IMM1^BUDERP6I
  1.  G EN1
  1. IMMLIST2 ;EP
  1.  D EOJ
  1.  S BUDIMM2L=1
  1.  D IMM2^BUDERP6I
  1.  G EN1
  1. PRGA ;EP
  1.  D EOJ
  1.  S BUDPRGAL=1
  1.  D PRGA^BUDERP6W
  1.  G EN1
  1.  ;
  1. M ;EP - called from option
  1.  D EOJ
  1.  D GENI^BUDERP6I
  1.  K BUDTIND,BUDIND
  1.  D EN^BUDEDSI
  1.  I '$D(BUDIND) W !,"No Lists Selected." H 2 D EOJ Q
  1.  S X=0 F  S X=$O(BUDIND(X)) Q:X'=+X  X ^BUDELST2(X,1)
  1.  G EN1
  1. PROC ;EP - called from taskman
  1.  S BUDJ=$J,BUDH=$H
  1.  S ^XTMP("BUDERP6B",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^BUD TABLE 6B LISTS"
  1.  ;NOW LOOP PATS
  1.  S DFN=0 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  D
  1.  .K ^TMP($J)
  1.  .Q:'$D(^AUPNPAT(DFN,0))
  1.  .Q:'$D(^DPT(DFN,0))
  1.  .Q:$P(^DPT(DFN,0),U,19)  ;merged away
  1.  .Q:$$DEMO^BUDEDU(DFN,"E")
  1. N .;
  1.  .I BUDBEN=1,$$BEN^AUPNPAT(DFN,"C")'="01" Q  ;must be Indian/Alaskan Native
  1.  .I BUDBEN=2,$$BEN^AUPNPAT(DFN,"C")="01" Q  ;must not be I/A
  1.  .S C=$$COMMRES^AUPNPAT(DFN,"E")
  1.  .S BUDSEX=$P(^DPT(DFN,0),U,2)
  1.  .I BUDSEX'="F",BUDSEX'="M" Q
  1.  .S BUDCCOM=$$COMMRES^AUPNPAT(DFN,"E") I BUDCCOM="" S BUDCCOM="UNKNOWN"
  1.  .S BUDAGE=$$AGE^AUPNPAT(DFN,BUDED)  ;age at end of time period
  1.  .S BUDAGEP=$$AGE^AUPNPAT(DFN,BUDCCAD)  ;age on june 30 for pregnancy 
  1.  .D GETV^BUDERPTD  ;get visits that meet criteria
  1.  .I BUDUDSPT=0 Q  ;user doesn't have any countable visits
  1.  .I $G(BUDPRGAL) D PRGALST
  1.  .D IMM^BUDERP6C
  1.  .D PAPD^BUDERP6D
  1.  .D ADOLWT^BUDERP6V
  1.  .D ADULT^BUDERP6V
  1.  .D G^BUDERP6V  ;TOB
  1.  .D H^BUDERP6U  ;AST
  1.  .D I^BUDERP6O  ;CAD
  1.  .D J^BUDERP6M  ;IVD
  1.  .D K^BUDERP6N  ;CRC
  1.  .D L^BUDERP6Q  ;HIV
  1.  .D M^BUDERP6Q  ;DEPRESSION
  1.  .D N^BUDERP6A  ;DENTAL
  1.  Q
  1. PRGALST ;EP - list of pregnant females
  1.  ;is patient pregnant during the time period BUDDD and BUDED
  1.  Q:BUDSEX'="F"
  1.  S BUDP=$$PREG(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED,BUDBD)
  1.  I '$P(BUDP,U) Q  ;not pregnant
  1.  S X=$$AGB(BUDAGEP)
  1.  S ^XTMP("BUDERP6B",BUDJ,BUDH,"PRGA",X,BUDAGEP,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDP,"*",2)
  1.  Q
  1. AGB(N) ;
  1.  I N<15 Q "Less than 15 Years"
  1.  I N>14,N<20 Q "Ages 15-19"
  1.  I N>19,N<25 Q "Ages 20-24"
  1.  I N>24,N<45 Q "Ages 25-44"
  1.  Q "Ages 45 and Over"
  1. 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
  1.  S BUDD=""
  1.  D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDV")
  1.  I '$D(BUDV) G PROB
  1.  S CNT=0,BUDD="",BUDALL=""
  1.  K BUDG
  1.  S DXT=$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
  1.  S PXT=$O(^ATXAX("B","BGP PREGNANCY ICD PROCEDURES",0))
  1.  S CPTT=$O(^ATXAX("B","BGP PREGNANCY CPT CODES",0))
  1.  ;CHECK DX, PROCS, CPTS for 2 separate visits
  1.  S B=0,CTR=0 F  S CTR=$O(BUDV(CTR)) Q:CTR'=+CTR  D
  1.  .;get visit into VIEN
  1.  .S VIEN=$P(BUDV(CTR),U,5)
  1.  .S D=$$VD^APCLV(VIEN)
  1.  .;now check for dx
  1.  .S Y=0,H="" F  S Y=$O(^AUPNVPOV("AD",VIEN,Y)) Q:Y'=+Y  D
  1.  ..S %=+^AUPNVPOV(Y,0)
  1.  ..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
  1.  .Q:H
  1.  .;NOW GO THROUGH CPTS
  1.  .S Y=0,H="" F  S Y=$O(^AUPNVCPT("AD",VIEN,Y)) Q:Y'=+Y  D
  1.  ..S %=+^AUPNVCPT(Y,0)
  1.  ..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
  1.  .Q:H
  1.  .;NOW PROCEDURES
  1.  .S Y=0,H="" F  S Y=$O(^AUPNVPRC("AD",VIEN,Y)) Q:Y'=+Y  D
  1.  ..S %=+^AUPNVPRC(Y,0)
  1.  ..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
  1.  .Q:H
  1.  .Q
  1.  I CNT>1,B D  G MA
  1.  .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
  1.  I 'B Q 0  ;no visit during time period
  1. PROB S T=$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
  1.  S (X,G)=0,Z="" F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G)  D
  1.  .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1.  .Q:$P(^AUPNPROB(X,0),U,8)>EDATE
  1.  .Q:$P(^AUPNPROB(X,0),U,8)<BDATE
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .Q:'$$ICD^ATXCHK(Y,T,9)
  1.  .S G=$P(^AUPNPROB(X,0),U,8),Z=X
  1.  .Q
  1.  I G=0,BUDD="" Q 0  ;no dxs and no problem list
  1.  S BUDD=G,BUDALL=BUDALL_"Problem List: "_$$VAL^XBDIQ1(9000011,Z,.01)_" on "_$$DATE^BUDEUTL1(G)_U
  1. MA ;now check for abortion or miscarriage
  1.  ;abortion first
  1.  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)
  1.  I $D(BUDG(1)) Q 0  ;HAD MIS/AB
  1.  S BUDG=$$LASTPRC^BUDEUTL1(P,"BGP ABORTION PROCEDURES",BDATE,EDATE)
  1.  I BUDG Q 0
  1.  S T=$O(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
  1.  S (X,G)=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G)  D
  1.  .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1.  .Q:$P(^AUPNPROB(X,0),U,8)<BUDD
  1.  .Q:$P(^AUPNPROB(X,0),U,8)>EDATE
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .Q:'$$ICD^ATXCHK(Y,T,9)
  1.  .S G=1
  1.  .Q
  1.  I G Q 0
  1.  ;now check CPTs for Abortion and Miscarriage
  1.  S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
  1.  S %=$$CPT^BUDEDU(P,BUDD,EDATE,T,3)
  1.  I %]"" Q 0
  1.  S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
  1.  S %=$$CPT^BUDEDU(P,BUDD,EDATE,T,3)
  1.  I %]"" Q 0
  1.  S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
  1.  S %=$$TRAN^BUDEDU(P,BUDD,EDATE,T,3)
  1.  I %]"" Q 0
  1.  S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
  1.  S %=$$TRAN^BUDEDU(P,BUDD,EDATE,T,3)
  1.  I %]"" Q 0
  1.  Q 1_"*"_BUDALL
  1.  ;
  1. PRINT ;EP - called from taskman
  1.  S BUDPG=0
  1.  S BUDQUIT=0
  1.  S BUD80L="",$P(BUD80L,"_",79)="_"
  1.  I BUDROT="D" D  G PL
  1.  .D ^%ZISC ;close printer device
  1.  .K ^TMP($J)
  1.  .S ^TMP($J,"BUDDEL",0)=0
  1.  .S BUDDECNT=0
  1.  D HEADER^BUDERPTP Q:BUDQUIT  D T6BH
  1.  W $$CTR("SECTION A:  AGE CATEGORIES FOR PRENATAL PATIENTS"),!
  1.  D LINE
  1.  W $$CTR("DEMOGRAPHIC CHARACTERISTICS OF PRENATAL CARE PATIENTS"),!
  1.  D LINE
  1.  W ?20,"AGE",?45,"|",?50,"NUMBER OF PATIENTS (a)",!
  1.  D LINE1
  1.  W ?2,"1",?5,"LESS THAN 15 YEARS",?45,"|",?58,"",!
  1.  D LINE1
  1.  W ?2,"2",?5,"AGES 15-19",?45,"|",?58,"",!
  1.  D LINE1
  1.  I $Y>(IOSL-3) D HEADER^BUDERPTP Q:BUDQUIT  D T6BH
  1.  W ?2,"3",?5,"AGES 20-24",?45,"|",?58,"",! D LINE1
  1.  I $Y>(IOSL-3) D HEADER^BUDERPTP Q:BUDQUIT  D T6BH
  1.  W ?2,"4",?5,"AGES 25-44",?45,"|",?58,"",! D LINE1
  1.  I $Y>(IOSL-3) D HEADER^BUDERPTP Q:BUDQUIT  D T6BH
  1.  W ?2,"5",?5,"AGES 45 AND OVER",?45,"|","",! D LINE1
  1.  I $Y>(IOSL-3) D HEADER^BUDERPTP Q:BUDQUIT  D T6BH
  1.  W ?2,"6",?5,"TOTAL PATIENTS (SUM LINES 1-5)",?45,"|","",! D LINE1
  1.  I $Y>(IOSL-12) D HEADER^BUDERPTP Q:BUDQUIT  D T6BH
  1.  W !,$$CTR("SECTION B - EARLY ENTRY INTO PRENATAL CARE"),! D LINE
  1.  W "EARLY ENTRY INTO",?37,"|",?40,"WOMEN HAVING",?60,"|",?63,"WOMEN HAVING",!
  1.  W "PRENATAL CARE",?37,"|",?40,"FIRST VISIT WITH",?60,"|",?63,"FIRST VISIT WITH",!
  1.  W "",?37,"|",?40,"HEALTH CENTER",?60,"|",?63,"ANOTHER PROVIDER",!
  1.  W ?37,"|",?45,"(a)",?60,"|",?68,"(b)",!
  1.  D LINE2
  1.  W ?2,7,?5,"First Trimester",?37,"|",?45,"",?60,"|",?68,"",! D LINE2
  1.  W ?2,8,?5,"Second Trimester",?37,"|",?45,"",?60,"|",?68,"",! D LINE2
  1.  W ?2,9,?5,"Third Trimester",?37,"|",?45,"",?60,"|",?68,"",! D LINE2
  1.  ;
  1.  D HEADER^BUDERPTP Q:BUDQUIT  D T6BH
  1.  W $$CTR("SECTION C - CHILDHOOD IMMUNIZATION STATUS"),!
  1.  D LINE
  1.  W "CHILDHOOD IMMUNIZATION",?23,"|",?26,"TOTAL PATIENTS",?45,"|",?47,"NUMBER CHARTS",?65,"|",?67,"NUMBER OF",!
  1.  W "STATUS",?23,"|",?26,"WITH 2ND",?45,"|",?47,"SAMPLED OR EHR",?65,"|",?67,"PATIENTS",!
  1.  W ?23,"|",?26,"BIRTHDAY",?45,"|",?47,"TOTAL",?65,"|",?67,"IMMUNIZED",!
  1.  W ?23,"|",?26,"",?45,"|",?47,"",?65,"|",?67,"",!
  1.  W ?23,"|",?30,"(a)",?45,"|",?50,"(b)",?65,"|",?70,"(c)",!
  1.  D LINE3
  1.  W ?1,"10",?5,"MEASURE: ",?23,"|",?45,"|",?65,"|",!
  1.  W ?5,"Percentage of ",?23,"|",?45,"|",?65,"|",!
  1.  W ?5,"children 2 years",?23,"|",?45,"|",?65,"|",!
  1.  W ?5,"of age who",?23,"|",?45,"|",?65,"|",!
  1.  W ?5,"received age",?23,"|",?30,$$C($G(BUDSECTC("PTS"))),?45,"|",?50,$$C($G(BUDSECTC("PTS"))),?65,"|",?70,$$C($G(BUDSECTC("IMM"))),!
  1.  W ?5,"appropriate",?23,"|",?45,"|",?65,"|",!
  1.  W ?5,"vaccines by their",?23,"|",?45,"|",?65,"|",!
  1.  W ?5,"2nd birthday",?23,"|",?45,"|",?65,"|",!
  1.  ;W ?5,"birthday",?23,"|",?45,"|",?65,"|",!
  1.  D LINE
  1.  I $Y>(IOSL-20) D HEADER^BUDERPTP Q:BUDQUIT  D T6BH
  1.  W $$CTR("SECTION D - CERVICAL CANCER SCREENING"),!
  1.  D LINE
  1.  W "CERVICAL CANCER",?23,"|",?26,"TOTAL FEMALE",?45,"|",?47,"NUMBER CHARTS",?65,"|",?67,"NUMBER OF",!
  1.  W "SCREENING",?23,"|",?26,"PATIENTS AGED",?45,"|",?47,"SAMPLED OR EHR",?65,"|",?67,"PATIENTS",!
  1.  W ?23,"|",?26,"23 THROUGH 64",?45,"|",?47,"TOTAL",?65,"|",?67,"TESTED",!
  1.  W ?23,"|",?30,"(a)",?45,"|",?50,"(b)",?65,"|",?70,"(c)",!
  1.  D LINE3
  1.  W ?1,"11",?5,"MEASURE: ",?23,"|",?45,"|",?65,"|",!
  1.  W ?5,"Percentage of ",?23,"|",?45,"|",?65,"|",!
  1.  W ?5,"women 21-64 ",?23,"|",?45,"|",?65,"|",!
  1.  W ?5,"years of age who",?23,"|",?30,$$C($G(BUDSECTD("PTS"))),?45,"|",?50,$$C($G(BUDSECTD("PTS"))),?65,"|",?70,$$C($G(BUDSECTD("PAP"))),!
  1.  W ?5,"received one or",?23,"|",?45,"|",?65,"|",!
  1.  W ?5,"more Pap tests to",?23,"|",?45,"|",?65,"|",!
  1.  W ?5,"screen for",?23,"|",?45,"|",?65,"|",!
  1.  W ?5,"cervical cancer",?23,"|",?45,"|",?65,"|",!
  1.  D LINE
  1.  D REST6B^BUDERP6E
  1. PL D LISTS^BUDERP6I
  1.  D ^%ZISC
  1.  I BUDROT="D" D SAVEDEL^BUDERPTD
  1.  K ^XTMP("BUDERP6B",BUDJ,BUDH)
  1.  Q
  1. T6BH ;
  1.  W !,$$CTR("TABLE 6B - QUALITY OF CARE MEASURES"),!,$$REPEAT^XLFSTR("_",79),!
  1.  Q
  1. LINE ;
  1.  W $$REPEAT^XLFSTR("_",79),!
  1.  Q
  1. LINE1 ;
  1.  W $$REPEAT^XLFSTR("_",45),"|",$$REPEAT^XLFSTR("_",33),!
  1.  Q
  1. LINE2 ;
  1.  W $$REPEAT^XLFSTR("_",37),"|",$$REPEAT^XLFSTR("_",22),"|",$$REPEAT^XLFSTR("_",18),!
  1.  Q
  1. LINE3 ;
  1.  W $$REPEAT^XLFSTR("_",23),"|",$$REPEAT^XLFSTR("_",21),"|",$$REPEAT^XLFSTR("_",19),"|",$$REPEAT^XLFSTR("_",13),!
  1.  Q
  1. T6BI ;
  1.  W !!,"TABLE 6B:  QUALITY OF CARE MEASURES"
  1.  W !,"This report will produce UDS Table 6B, quality of care measures."
  1.  W !,"Patients must meet additional criteria as specified for each measure."
  1.  Q
  1. GENI ;general introductions
  1.  W:$D(IOF) @(IOF)
  1.  W !!,$$CTR($$LOC,80),!,$$CTR("UDS 2017",80),!
  1.  W !,"UDS searches your database to find all patients reported for the quality"
  1.  W !,"of care indicators during the time period January 1 - "
  1.  W !,"December 31, 2017.  Based on the UDS definition, to be considered a"
  1.  W !,"patient, the patient must have had at least one visit meeting the"
  1.  W !,"following criteria:"
  1.  W !?4,"- must be to a location specified in your visit location setup"
  1.  W !?4,"- must be to Service Category Ambulatory (A), Hospitalization (H), Day"
  1.  W !?6,"Surgery (S), Observation (O), Telemedicine (M), Nursing home visit (R), "
  1.  W !?6,"or In-Hospital (I) visit"
  1.  W !?4,"- must NOT have an excluded clinic code (see User Manual for a list)"
  1.  W !?4,"- must have a primary provider and a coded purpose of visit"
  1.  W !?4,"- the patient must NOT have a gender of 'Unknown'"
  1.  W !
  1.  Q
  1.  ;
  1. PRENATT ;EP
  1.  D PRENATT^BUDERP6I
  1.  Q
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  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.  ;----------
  1. NRY ;
  1.  W !!,"not developed yet....." H 3
  1.  Q
  1. PAUSE ;
  1.   K DIR S DIR(0)="E",DIR("A")="PRESS ENTER" KILL DA D ^DIR KILL DIR
  1.   Q
  1. C(X,Y) ;
  1.  I $G(Y)=1,+X=0 Q ""
  1.  I $G(Y)=2 Q "********"
  1.  S X2=0,X3=8
  1.  D COMMA^%DTC
  1.  Q X
  1. YEAR ;
  1.  S BUDYEAR=""
  1.  W !
  1.  W !,"Enter the Calendar Year.  Use a 4 digit year, e.g. 2017"
  1.  S DIR(0)="D^::EP"
  1.  S DIR("A")="Enter Calendar Year"
  1.  S DIR("?")="This report is compiled for a period.  Enter a valid date."
  1.  D ^DIR KILL DIR
  1.  K DIC
  1.  I $D(DUOUT) S DIRUT=1 Q
  1.  I $D(DIRUT) Q
  1.  I $E(Y,4,7)'="0000" W !!,"Please enter a year only!",! G YEAR
  1.  S BUDYEAR=Y,BUDBD=$E(BUDYEAR,1,3)_"0101",BUDED=$E(BUDYEAR,1,3)_"1231"
  1.  S BUDCCAD=$E(BUDYEAR,1,3)_"0630"
  1.  Q