BUDHRPTD.m

BUDHRPTD ;IHS/CMI/LAB - UDS REPORT PROCESSOR; 

 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90

 ;

 ;

GETV ;EP - get all visits for this patient and tally in BUDTV

 ;^TMP($J,"VISITS") has all visits

 ;^TMP($J,"VISITSUDSPT") for visit list for table 3A

 ;^TMP($J,"VISITSTABLE5") has all visits to count on table 5

 ;^TMP($J,"VISITSTABLE6A") has all visits for tables 6a dxs and services

 K ^TMP($J)

 S BUDUDSPT=0 ;controls whether the patient qualifies as a UDS patient

 S BUDMEDV=0  ;controls whether the patient had a medical visit & how many

 S BUDMEDVI=""  ;contains the IEN of a medical visit

 S BUDLASTV=""  ;contains the IEN of their last visit (table 5 eligible)

 S BUDFRSTV=""  ;contains the IEN of their first visit (uds patient eligible)

 S A="^TMP($J,""VISITS"",",B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BUDBD)_"-"_$$FMTE^XLFDT(BUDED),E=$$START1^APCLDF(B,A)

 I '$D(^TMP($J,"VISITS",1)) Q

 ;loop and determine if they are a UDS patient

 S BUDX=0 F  S BUDX=$O(^TMP($J,"VISITS",BUDX)) Q:BUDX'=+BUDX  S BUDVSIT=$P(^TMP($J,"VISITS",BUDX),U,5) D

 .Q:'$D(^AUPNVSIT(BUDVSIT,0))

 .Q:'$P(^AUPNVSIT(BUDVSIT,0),U,9)

 .Q:$P(^AUPNVSIT(BUDVSIT,0),U,11)

 .S BUDVLOC=$P(^AUPNVSIT(BUDVSIT,0),U,6)  ;must be to a location in the site parameter file

 .Q:BUDVLOC=""

 .Q:'$D(^BUDHSITE(BUDSITE,11,BUDVLOC))  ;not valid location

 .Q:"AHSORMI"'[$P(^AUPNVSIT(BUDVSIT,0),U,7)  ;ignore cr/telephone/ events

 .;V12.0 ADD PROVIDER EXCLUSIONS

 .S J=$$PRIMPROV^APCLV(BUDVSIT,"F")

 .I J,$D(^BUDHSITE(BUDSITE,13,"B",J)) Q  ;don't count visits with this class

 .S BUDCLINC=$$CLINIC^APCLV(BUDVSIT,"C")

 .S BUDTIEN=$O(^BUDHCNTL("B","UDS PT/TABLE 5 CLINIC EXCL",0))

 .I BUDCLINC]"",$D(^BUDHCNTL(BUDTIEN,11,"B",BUDCLINC)) Q  ;don't count UDS PATIENT CLINIC EXCLUSIONS

 .S BUDPP=$$PRIMPROV^APCLV(BUDVSIT,"I")  ;IEN of primary provider

 .I 'BUDPP Q  ;no primary provider

 .S BUDPPD=$$PRIMPROV^APCLV(BUDVSIT,"D")

 .I BUDPPD="" Q  ;has to have a discipline

 .I '$D(^AUPNVPOV("AD",BUDVSIT)) Q  ;must have at least 1 pov to elimiate orphans

 .S BUDUDSPT=BUDUDSPT+1

 .S ^TMP($J,"VISITSUDSPT",BUDVSIT)=""  ;THIS IS THE LIST FOR PAT LISTS FOR 3A, 3B, ZIP, 4

 .I $$VD^APCLV(BUDLASTV)<$$VD^APCLV(BUDVSIT) S BUDLASTV=BUDVSIT

 .I $$VD^APCLV(BUDVSIT)>$$VD^APCLV(BUDFRSTV) S BUDFRSTV=BUDVSIT

 Q:'BUDUDSPT  ;QUIT IF THEY HAVE NO VISITS FOR PATIENT DEFINITION

T5 ;now get visits for table 5 1 per provider type per day

 S BUDX=0 F  S BUDX=$O(^TMP($J,"VISITS",BUDX)) Q:BUDX'=+BUDX  S BUDVSIT=$P(^TMP($J,"VISITS",BUDX),U,5) D

 .Q:'$D(^AUPNVSIT(BUDVSIT,0))

 .Q:'$P(^AUPNVSIT(BUDVSIT,0),U,9)  ;0 dependent entries, not a visit

 .Q:$P(^AUPNVSIT(BUDVSIT,0),U,11)  ;deleted visit

 .S BUDVLOC=$P(^AUPNVSIT(BUDVSIT,0),U,6)  ;must be to a location int he site parameter file

 .Q:BUDVLOC=""

 .Q:'$D(^BUDHSITE(BUDSITE,11,BUDVLOC))  ;not valid location

 .Q:"AHSORMI"'[$P(^AUPNVSIT(BUDVSIT,0),U,7)  ;ignore cr/telephone

 .Q:'$D(^AUPNVPOV("AD",BUDVSIT))

 .S BUDCLINC=$$CLINIC^APCLV(BUDVSIT,"C")

 .S BUDTIEN=$O(^BUDHCNTL("B","UDS PT/TABLE 5 CLINIC EXCL",0))

 .I BUDCLINC]"",$D(^BUDHCNTL(BUDTIEN,11,"B",BUDCLINC)) Q  ;don't count excluded clinics

 .S BUDPP=$$PRIMPROV^APCLV(BUDVSIT,"I")  ;IEN of primary provider

 .I 'BUDPP Q  ;no primary provider

 .;V13.0 ADD PROVIDER EXCLUSIONS

 .S J=$$PRIMPROV^APCLV(BUDVSIT,"F")

 .I J,$D(^BUDHSITE(BUDSITE,13,"B",J)) Q  ;don't count visits with this class

 .S BUDVDATE=$$VD^APCLV(BUDVSIT)

 .S BUDPPD=$$PRIMPROV^APCLV(BUDVSIT,"D") ;primary provider discipline

 .I BUDPPD="" Q  ;no discipline to check so can't count this visit

MEDC .;NOW CHECK FOR MEDICAL CARE, CAN ONLY HAVE 1 PER LOCATION OF ENCOUNTER

 .S S=0

 .S BUDTIEN=$O(^BUDHCNTL("B","MEDICAL CARE LINE NUMBERS",0))

 .I $E($$VAL^XBDIQ1(9000010,BUDVSIT,.06),1,3)="CHS",BUDPPD=15 S BUDLINE=2 G MEDC1

 .S BUDY=$O(^BUDHTFIV("C",BUDPPD,0)) I BUDY="" S BUDLINE=35 G MEDC1

 .S BUDLINE=$O(^BUDHTFIV("AA",BUDPPD,""))

MEDC1 .S S=0

 .I $D(^BUDHCNTL(BUDTIEN,11,"B",BUDLINE)) D

 ..S D=$P($G(^TMP($J,"MEDCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)),U,1)

 ..I D]"",D'>$P(^AUPNVSIT(BUDVSIT,0),U) S S=1 Q  ;already have a medical care visit on this date

 ..S ^TMP($J,"MEDCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)=$P(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT

 ..S BUDMEDV=BUDMEDV+1,BUDMEDVI=BUDVSIT

 .Q:S  ;don't count this one, already counted one medical

DENT .;NOW CHECK FOR DENTAL CARE

 .S S=0

 .S BUDTIEN=$O(^BUDHCNTL("B","DENTAL LINE NUMBERS",0))

 .S S=0

 .I $D(^BUDHCNTL(BUDTIEN,11,"B",BUDLINE)) D

 ..S D=$P($G(^TMP($J,"DENTCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)),U,1)

 ..I D]"",D'>$P(^AUPNVSIT(BUDVSIT,0),U) S S=1 Q  ;already have a DENTAL care visit on this date

 ..S ^TMP($J,"DENTCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)=$P(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT

 .Q:S  ;don't count this one, already counted one DENTAL

MH .;NOW CHECK FOR MH CARE

 .S S=0

 .S BUDTIEN=$O(^BUDHCNTL("B","MENTAL HEALTH LINE NUMBERS",0))

 .S P=$$PRIMPOV^APCLV(BUDVSIT,"C")

 .I $E(P,1,3)=303!($E(P,1,3)="304")!($E(P,1,3)="305") G SUB

 .S S=0

 .I $D(^BUDHCNTL(BUDTIEN,11,"B",BUDLINE)) D

 ..S D=$P($G(^TMP($J,"MHCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)),U,1)

 ..I D]"",D'>$P(^AUPNVSIT(BUDVSIT,0),U) S S=1 Q  ;already have a MH care visit on this date

 ..S ^TMP($J,"MHCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)=$P(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT

 .Q:S  ;don't count this one, already counted one MH

SUB .;

 .S S=0

 .S BUDTIEN=$O(^BUDHCNTL("B","SUBSTANCE LINE NUMBERS",0))

 .S S=0

 .I $D(^BUDHCNTL(BUDTIEN,11,"B",BUDLINE)) D

 ..S D=$P($G(^TMP($J,"SUBCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)),U,1)

 ..I D]"",D'>$P(^AUPNVSIT(BUDVSIT,0),U) S S=1 Q  ;already have a SUB care visit on this date

 ..S ^TMP($J,"SUBCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)=$P(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT

 .Q:S  ;don't count this one, already counted one SUBSTANCE

VISION .;

 .S S=0

 .S BUDTIEN=$O(^BUDHCNTL("B","VISION LINE NUMBERS",0))

 .S S=0

 .I $D(^BUDHCNTL(BUDTIEN,11,"B",BUDLINE)) D

 ..S D=$P($G(^TMP($J,"VISIONCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)),U,1)

 ..I D]"",D'>$P(^AUPNVSIT(BUDVSIT,0),U) S S=1 Q  ;already have a VISION care visit on this date

 ..S ^TMP($J,"VISIONCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)=$P(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT

 .Q:S  ;don't count this one, already counted one VISION

OTH .;can have only 1 in each category

 .S BUDTIEN=$O(^BUDHTFIV("B",22,0))

 .S S=0

 .I $D(^BUDHTFIV(BUDTIEN,11,"B",BUDPPD)) D

 ..S D=$P($G(^TMP($J,"OTHSERV",DFN,BUDVDATE,BUDVLOC,BUDPPD)),U,1)

 ..I D]"",D'>$P(^AUPNVSIT(BUDVSIT,0),U) S S=1 Q

 ..S ^TMP($J,"OTHSERV",DFN,BUDVDATE,BUDVLOC,BUDPPD)=$P(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT

 .Q:S

ENAB .;NOW CHECK FOR ENABLING

 .S S=0

 .S BUDTIEN=$O(^BUDHCNTL("B","ENABLING LINE NUMBERS",0))

 .I $D(^BUDHCNTL(BUDTIEN,11,"B",BUDLINE)) D

 ..S D=$P($G(^TMP($J,"ENABCARE",DFN,BUDVDATE,BUDVLOC,BUDPPD)),U,1)

 ..I D]"",D'>$P(^AUPNVSIT(BUDVSIT,0),U) S S=1 Q  ;already have a ENABLING care visit on this date

 ..S ^TMP($J,"ENABCARE",DFN,BUDVDATE,BUDVLOC,BUDPPD)=$P(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT

 .Q:S   ;don't count this one, already counted onE ENABLING

SET .;

 .S ^TMP($J,"VISITSTABLE5",BUDVSIT)=""  ;USED IN TABLE 5

 ;NOW TABLE 6A

A6 S BUDX=0 F  S BUDX=$O(^TMP($J,"VISITS",BUDX)) Q:BUDX'=+BUDX  S BUDVSIT=$P(^TMP($J,"VISITS",BUDX),U,5) D

 .Q:'$D(^AUPNVSIT(BUDVSIT,0))

 .Q:'$P(^AUPNVSIT(BUDVSIT,0),U,9)  ;0 dependent entries, not a visit

 .Q:$P(^AUPNVSIT(BUDVSIT,0),U,11)  ;deleted visit

 .S BUDVLOC=$P(^AUPNVSIT(BUDVSIT,0),U,6)  ;must be to a location in the site parameter file

 .Q:BUDVLOC=""

 .Q:'$D(^BUDHSITE(BUDSITE,11,BUDVLOC))  ;not valid location

 .Q:"AHSORMI"'[$P(^AUPNVSIT(BUDVSIT,0),U,7)  ;ignore cr/telephone/events

 .S BUDCLINC=$$CLINIC^APCLV(BUDVSIT,"C")

 .S BUDTIEN=$O(^BUDHCNTL("B","TABLE 6A CLINIC EXCLUSIONS",0))

 .I BUDCLINC]"",$D(^BUDHCNTL(BUDTIEN,11,"B",BUDCLINC)) Q  ;don't count excluded clinics

 .;S BUDP=$$PRIMPROV^APCLV(BUDVSIT) Q:'BUDP  ;no primary provider - WHAT ABOUT ORPHANS FOR LAB/RAD/IMM

 .;COUNT ONLY 1 INPATIENT VISIT PER DAY

 .I $P(^AUPNVSIT(BUDVSIT,0),U,7)="H",$D(^TMP($J,"H",DFN,$$VD^APCLV(BUDVSIT))) Q

 .I $P(^AUPNVSIT(BUDVSIT,0),U,7)="H" S ^TMP($J,"H",DFN,$$VD^APCLV(BUDVSIT))=""

 .S ^TMP($J,"VISITSTABLE6A",BUDVSIT)=""

 ;now get all mamms and paps in date range and count as orphans if at this facility and no mam on that date in pcc

 S T="MAMMOGRAM SCREENING",T=$O(^BWPN("B",T,0))

 S T1="MAMMOGRAM DX BILAT",T1=$O(^BWPN("B",T1,0))

 S T2="MAMMOGRAM DX UNILAT",T2=$O(^BWPN("B",T2,0))

 D

 .S (G,V)=0 F  S V=$O(^BWPCD("C",DFN,V)) Q:V=""  D

 ..Q:'$D(^BWPCD(V,0))

 ..S D=$P(^BWPCD(V,0),U,12)

 ..S J=$P(^BWPCD(V,0),U,4) I J=T!(J=T1)!(J=T2) D  Q

 ...Q:D<BUDBD

 ...Q:D>BUDED

 ...S L=$P(^BWPCD(V,0),U,10)

 ...Q:L=""

 ...Q:'$D(^BUDHSITE(BUDSITE,11,L))  ;not valid location

 ...Q:$P($G(^BWPCD(V,"PCC")),U,1)]""  ;already in pcc

 ...S ^TMP($J,"MAMMS",V)="WH "_$$VAL^XBDIQ1(9002086.1,V,.04)_U_$$FMTE^XLFDT(D)

 .Q

 S T="PAP SMEAR",T=$O(^BWPN("B",T,0))

 D

 .S (G,V)=0 F  S V=$O(^BWPCD("C",DFN,V)) Q:V=""  D

 ..Q:'$D(^BWPCD(V,0))

 ..S D=$P(^BWPCD(V,0),U,12)

 ..S J=$P(^BWPCD(V,0),U,4) I J=T D  Q

 ...Q:D<BUDBD

 ...Q:D>BUDED

 ...S L=$P(^BWPCD(V,0),U,10)

 ...Q:L=""

 ...Q:'$D(^BUDHSITE(BUDSITE,11,L))  ;not valid location

 ...Q:$P($G(^BWPCD(V,"PCC")),U,1)]""  ;already in pcc

 ...S ^TMP($J,"PAPS",V)="WH "_$$VAL^XBDIQ1(9002086.1,V,.04)_U_$$FMTE^XLFDT(D)

 .Q

 Q

TZH ;EP

 Q:BUDROT="D"

 G:'BUDGPG TZH1

 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

TZH1 ;

 W:$D(IOF) @IOF S BUDGPG=BUDGPG+1

 W !,$$CTR("***** SENSITIVE INFORMATION *****",IOM)

 W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?55,"Section "_BUDSCTC_" of "_BUDTSCTC_", Page "_BUDGPG,!

 W !,$$CTR("***  RPMS Uniform Data System (UDS) "_$$VER^BUDHBAN()_"  ***",80)

 W !,$$CTR("Patient List: Patient by Zip Code/Insurance",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)",BUDBEN=4:"Homeless",1:"")

 W $$CTR(X,80),!

 W $TR($J("",80)," ","-")

 I BUDP=0 W !,"List of all patients with one or more visits during the calendar year."

 I BUDP=0 W !,"Zip code is from patient registration."

 I BUDP=0 W !!,"NOTE:  Patients with a zip code included in the Other Zip Codes category"

 I BUDP=0 W !,"have their zip code value followed by a ""","*",""" (e.g. 87015*)."

 W !!,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"ZIP CODE",?65,"INS"

 W !?5,"VISIT DATE",?25,"PROV TYPE",?41,"SRV",?45,"CLINIC",?62,"LOCATION"

 S BUDP=1

 W !,$TR($J("",80)," ","-")

 Q

CTR(X,Y) ;EP

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

 ;

WDEL ;EP - write out delimited file 9d

 G WDEL^BUDHRPTQ

LOTE(P,V) ;

 ;if prim lang=other than english

 ;interpreter = yes AND

 ;preferred = other than english

 NEW X,%,Y,D,L,PL,IR,RL

 S D=$$VD^APCLV(V)

 S %=0,X=0 S (Y,L,PL,IR,RL)=""

 F  S X=$O(^AUPNPAT(P,86,"B",X)) Q:X'=+X!(X>D)  S Y=0 F  S Y=$O(^AUPNPAT(P,86,"B",X,Y)) Q:Y'=+Y  S L=Y  ;get last one

 I 'L Q 0  ;no data recorded

 I $P($G(^AUPNPAT(P,86,L,0)),U,3)'="Y" Q 0  ;INTERPRETER NOT REQUIRED SO DON'T COUNT

 S PL=$P($G(^AUPNPAT(P,86,L,0)),U,1)

 I 'PL Q 0  ;NO PRIM LANG

 I $$VAL^XBDIQ1(9999999.99,PL,.01)="ENGLISH" Q 0

 S PL=$P($G(^AUPNPAT(P,86,L,0)),U,4)

 I 'PL Q 0  ;NO PREF LANG

 I $$VAL^XBDIQ1(9999999.99,PL,.04)="ENGLISH" Q 0

 Q 1

TZHD ;EP

 D S("***** SENSITIVE INFORMATION *****")

 D S($P(^VA(200,DUZ,0),U,2)_"    "_$$FMTE^XLFDT(DT))

 D S("***  RPMS Uniform Data System (UDS) "_$$VER^BUDHBAN()_"  ***")

 D S("Patient List: Patient by Zip Code/Insurance")

 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)",BUDBEN=4:"Homeless",1:"") D S(X)

 D S(" ")

 D S("List of all patients with one or more visits during the calendar year.")

 D S("Zip code is from patient registration.")

 D S("NOTE:  Patients with a zip code included in the Other Zip Codes category")

 S X="have their zip code value followed by a '*' (e.g. 87015*)." D S(X)

 D S(" "),S("PATIENT NAME^HRN^COMMUNITY^SEX^ZIP CODE^INSURANCE^VISIT DATE^PROV TYPE^SRV^CLINIC^LOCATION")

 Q

S(V) ;

 S BUDDECNT=BUDDECNT+1

 S ^TMP($J,"BUDDEL",BUDDECNT)=$G(V)

 Q

SAVEDEL ;EP

 I BUDDELT="S" D SCREEN Q

 ;call xbgsave to create output file

 S XBGL="BUDDATA"

 L +^BUDDATA:300 E  W:'$D(ZTQUEUED) "Unable to lock global" Q

 K ^TMP($J,"SUMMARYDEL")

 K ^BUDDATA ;global for saving

 D COVPAGED^BUDHUTL1

 S C=C+1 S ^BUDDATA(C)=" "

 S X=0 F  S X=$O(^TMP($J,"BUDDEL",X)) Q:X'=+X  S C=C+1 S ^BUDDATA(C)=^TMP($J,"BUDDEL",X)

 S C=C+2 S ^BUDDATA(C)="***** END OF REPORT *****"

 D

 .S XBFLT=1,XBFN=BUDDELF_".txt",XBMED="F",XBTLE="UDS DELIMITED OUTPUT",XBQ="N",XBF=0

 .D ^XBGSAVE

 .K XBFLT,XBFN,XBMED,XBTLE,XBE,XBF

 L -^BUDDATA

 K ^BUDDATA ;export global

 K ^TMP($J,"BUDDEL")

 Q

 ;

SCREEN ;

 D COVPAGEP^BUDHUTL1

 W !," "

 S X=0 F  S X=$O(^TMP($J,"BUDDEL",X)) Q:X'=+X  W !,^TMP($J,"BUDDEL",X)

 W !!,"***** END OF REPORT *****",!

 Q

T6DH ;EP

 D S(""),S(""),S("")

 D S("***** SENSITIVE INFORMATION *****")

 D S($P(^VA(200,DUZ,0),U,2)_"       "_$$FMTE^XLFDT(DT))

 D S("***  RPMS Uniform Data System (UDS) "_$$VER^BUDHBAN()_"  ***")

 D S("Patient List for Table 6A, By Diagnosis Category")

 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)",BUDBEN=4:"Homeless",1:"") D S(X)

 D S(" ")

 D S("List of all patients, sorted by diagnosis and tests/screening")

 D S("categories.  Displays community, gender, age and visit data, and codes.")

 D S("* (R) - denotes the value was obtained from the Race field")

 D S("  (C) - denotes the value was obtained from the Classification/Beneficiary field")

 ;D S("Age is calculated as of June 30.")

 D S("")

 D S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^RACE*^VISIT DATE^VALUE^SRV^CLINIC^LOCATION")

 Q

BUDHRPTD  ;IHS/CMI/LAB - UDS REPORT PROCESSOR; 

 +1       ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90

 +2       ;

 +3       ;

GETV      ;EP - get all visits for this patient and tally in BUDTV

 +1       ;^TMP($J,"VISITS") has all visits

 +2       ;^TMP($J,"VISITSUDSPT") for visit list for table 3A

 +3       ;^TMP($J,"VISITSTABLE5") has all visits to count on table 5

 +4       ;^TMP($J,"VISITSTABLE6A") has all visits for tables 6a dxs and services

 +5        KILL ^TMP($JOB)

 +6       ;controls whether the patient qualifies as a UDS patient

           SET BUDUDSPT=0

 +7       ;controls whether the patient had a medical visit & how many

           SET BUDMEDV=0

 +8       ;contains the IEN of a medical visit

           SET BUDMEDVI=""

 +9       ;contains the IEN of their last visit (table 5 eligible)

           SET BUDLASTV=""

 +10      ;contains the IEN of their first visit (uds patient eligible)

           SET BUDFRSTV=""

 +11       SET A="^TMP($J,""VISITS"","

           SET B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BUDBD)_"-"_$$FMTE^XLFDT(BUDED)

           SET E=$$START1^APCLDF(B,A)

 +12       IF '$DATA(^TMP($JOB,"VISITS",1))

               QUIT 

 +13      ;loop and determine if they are a UDS patient

 +14       SET BUDX=0

           FOR 

               SET BUDX=$ORDER(^TMP($JOB,"VISITS",BUDX))

               IF BUDX'=+BUDX

                   QUIT 

               SET BUDVSIT=$PIECE(^TMP($JOB,"VISITS",BUDX),U,5)

               Begin DoDot:1

 +15               IF '$DATA(^AUPNVSIT(BUDVSIT,0))

                       QUIT 

 +16               IF '$PIECE(^AUPNVSIT(BUDVSIT,0),U,9)

                       QUIT 

 +17               IF $PIECE(^AUPNVSIT(BUDVSIT,0),U,11)

                       QUIT 

 +18      ;must be to a location in the site parameter file

                   SET BUDVLOC=$PIECE(^AUPNVSIT(BUDVSIT,0),U,6)

 +19               IF BUDVLOC=""

                       QUIT 

 +20      ;not valid location

                   IF '$DATA(^BUDHSITE(BUDSITE,11,BUDVLOC))

                       QUIT 

 +21      ;ignore cr/telephone/ events

                   IF "AHSORMI"'[$PIECE(^AUPNVSIT(BUDVSIT,0),U,7)

                       QUIT 

 +22      ;V12.0 ADD PROVIDER EXCLUSIONS

 +23               SET J=$$PRIMPROV^APCLV(BUDVSIT,"F")

 +24      ;don't count visits with this class

                   IF J

                       IF $DATA(^BUDHSITE(BUDSITE,13,"B",J))

                           QUIT 

 +25               SET BUDCLINC=$$CLINIC^APCLV(BUDVSIT,"C")

 +26               SET BUDTIEN=$ORDER(^BUDHCNTL("B","UDS PT/TABLE 5 CLINIC EXCL",0))

 +27      ;don't count UDS PATIENT CLINIC EXCLUSIONS

                   IF BUDCLINC]""

                       IF $DATA(^BUDHCNTL(BUDTIEN,11,"B",BUDCLINC))

                           QUIT 

 +28      ;IEN of primary provider

                   SET BUDPP=$$PRIMPROV^APCLV(BUDVSIT,"I")

 +29      ;no primary provider

                   IF 'BUDPP

                       QUIT 

 +30               SET BUDPPD=$$PRIMPROV^APCLV(BUDVSIT,"D")

 +31      ;has to have a discipline

                   IF BUDPPD=""

                       QUIT 

 +32      ;must have at least 1 pov to elimiate orphans

                   IF '$DATA(^AUPNVPOV("AD",BUDVSIT))

                       QUIT 

 +33               SET BUDUDSPT=BUDUDSPT+1

 +34      ;THIS IS THE LIST FOR PAT LISTS FOR 3A, 3B, ZIP, 4

                   SET ^TMP($JOB,"VISITSUDSPT",BUDVSIT)=""

 +35               IF $$VD^APCLV(BUDLASTV)<$$VD^APCLV(BUDVSIT)

                       SET BUDLASTV=BUDVSIT

 +36               IF $$VD^APCLV(BUDVSIT)>$$VD^APCLV(BUDFRSTV)

                       SET BUDFRSTV=BUDVSIT

               End DoDot:1

 +37      ;QUIT IF THEY HAVE NO VISITS FOR PATIENT DEFINITION

           IF 'BUDUDSPT

               QUIT 

T5        ;now get visits for table 5 1 per provider type per day

 +1        SET BUDX=0

           FOR 

               SET BUDX=$ORDER(^TMP($JOB,"VISITS",BUDX))

               IF BUDX'=+BUDX

                   QUIT 

               SET BUDVSIT=$PIECE(^TMP($JOB,"VISITS",BUDX),U,5)

               Begin DoDot:1

 +2                IF '$DATA(^AUPNVSIT(BUDVSIT,0))

                       QUIT 

 +3       ;0 dependent entries, not a visit

                   IF '$PIECE(^AUPNVSIT(BUDVSIT,0),U,9)

                       QUIT 

 +4       ;deleted visit

                   IF $PIECE(^AUPNVSIT(BUDVSIT,0),U,11)

                       QUIT 

 +5       ;must be to a location int he site parameter file

                   SET BUDVLOC=$PIECE(^AUPNVSIT(BUDVSIT,0),U,6)

 +6                IF BUDVLOC=""

                       QUIT 

 +7       ;not valid location

                   IF '$DATA(^BUDHSITE(BUDSITE,11,BUDVLOC))

                       QUIT 

 +8       ;ignore cr/telephone

                   IF "AHSORMI"'[$PIECE(^AUPNVSIT(BUDVSIT,0),U,7)

                       QUIT 

 +9                IF '$DATA(^AUPNVPOV("AD",BUDVSIT))

                       QUIT 

 +10               SET BUDCLINC=$$CLINIC^APCLV(BUDVSIT,"C")

 +11               SET BUDTIEN=$ORDER(^BUDHCNTL("B","UDS PT/TABLE 5 CLINIC EXCL",0))

 +12      ;don't count excluded clinics

                   IF BUDCLINC]""

                       IF $DATA(^BUDHCNTL(BUDTIEN,11,"B",BUDCLINC))

                           QUIT 

 +13      ;IEN of primary provider

                   SET BUDPP=$$PRIMPROV^APCLV(BUDVSIT,"I")

 +14      ;no primary provider

                   IF 'BUDPP

                       QUIT 

 +15      ;V13.0 ADD PROVIDER EXCLUSIONS

 +16               SET J=$$PRIMPROV^APCLV(BUDVSIT,"F")

 +17      ;don't count visits with this class

                   IF J

                       IF $DATA(^BUDHSITE(BUDSITE,13,"B",J))

                           QUIT 

 +18               SET BUDVDATE=$$VD^APCLV(BUDVSIT)

 +19      ;primary provider discipline

                   SET BUDPPD=$$PRIMPROV^APCLV(BUDVSIT,"D")

 +20      ;no discipline to check so can't count this visit

                   IF BUDPPD=""

                       QUIT 

MEDC      ;NOW CHECK FOR MEDICAL CARE, CAN ONLY HAVE 1 PER LOCATION OF ENCOUNTER

 +1                SET S=0

 +2                SET BUDTIEN=$ORDER(^BUDHCNTL("B","MEDICAL CARE LINE NUMBERS",0))

 +3                IF $EXTRACT($$VAL^XBDIQ1(9000010,BUDVSIT,.06),1,3)="CHS"

                       IF BUDPPD=15

                           SET BUDLINE=2

                           GOTO MEDC1

 +4                SET BUDY=$ORDER(^BUDHTFIV("C",BUDPPD,0))

                   IF BUDY=""

                       SET BUDLINE=35

                       GOTO MEDC1

 +5                SET BUDLINE=$ORDER(^BUDHTFIV("AA",BUDPPD,""))

MEDC1              SET S=0

 +1                IF $DATA(^BUDHCNTL(BUDTIEN,11,"B",BUDLINE))

                       Begin DoDot:2

 +2                        SET D=$PIECE($GET(^TMP($JOB,"MEDCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)),U,1)

 +3       ;already have a medical care visit on this date

                           IF D]""

                               IF D'>$PIECE(^AUPNVSIT(BUDVSIT,0),U)

                                   SET S=1

                                   QUIT 

 +4                        SET ^TMP($JOB,"MEDCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)=$PIECE(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT

 +5                        SET BUDMEDV=BUDMEDV+1

                           SET BUDMEDVI=BUDVSIT

                       End DoDot:2

 +6       ;don't count this one, already counted one medical

                   IF S

                       QUIT 

DENT      ;NOW CHECK FOR DENTAL CARE

 +1                SET S=0

 +2                SET BUDTIEN=$ORDER(^BUDHCNTL("B","DENTAL LINE NUMBERS",0))

 +3                SET S=0

 +4                IF $DATA(^BUDHCNTL(BUDTIEN,11,"B",BUDLINE))

                       Begin DoDot:2

 +5                        SET D=$PIECE($GET(^TMP($JOB,"DENTCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)),U,1)

 +6       ;already have a DENTAL care visit on this date

                           IF D]""

                               IF D'>$PIECE(^AUPNVSIT(BUDVSIT,0),U)

                                   SET S=1

                                   QUIT 

 +7                        SET ^TMP($JOB,"DENTCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)=$PIECE(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT

                       End DoDot:2

 +8       ;don't count this one, already counted one DENTAL

                   IF S

                       QUIT 

MH        ;NOW CHECK FOR MH CARE

 +1                SET S=0

 +2                SET BUDTIEN=$ORDER(^BUDHCNTL("B","MENTAL HEALTH LINE NUMBERS",0))

 +3                SET P=$$PRIMPOV^APCLV(BUDVSIT,"C")

 +4                IF $EXTRACT(P,1,3)=303!($EXTRACT(P,1,3)="304")!($EXTRACT(P,1,3)="305")

                       GOTO SUB

 +5                SET S=0

 +6                IF $DATA(^BUDHCNTL(BUDTIEN,11,"B",BUDLINE))

                       Begin DoDot:2

 +7                        SET D=$PIECE($GET(^TMP($JOB,"MHCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)),U,1)

 +8       ;already have a MH care visit on this date

                           IF D]""

                               IF D'>$PIECE(^AUPNVSIT(BUDVSIT,0),U)

                                   SET S=1

                                   QUIT 

 +9                        SET ^TMP($JOB,"MHCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)=$PIECE(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT

                       End DoDot:2

 +10      ;don't count this one, already counted one MH

                   IF S

                       QUIT 

SUB       ;

 +1                SET S=0

 +2                SET BUDTIEN=$ORDER(^BUDHCNTL("B","SUBSTANCE LINE NUMBERS",0))

 +3                SET S=0

 +4                IF $DATA(^BUDHCNTL(BUDTIEN,11,"B",BUDLINE))

                       Begin DoDot:2

 +5                        SET D=$PIECE($GET(^TMP($JOB,"SUBCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)),U,1)

 +6       ;already have a SUB care visit on this date

                           IF D]""

                               IF D'>$PIECE(^AUPNVSIT(BUDVSIT,0),U)

                                   SET S=1

                                   QUIT 

 +7                        SET ^TMP($JOB,"SUBCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)=$PIECE(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT

                       End DoDot:2

 +8       ;don't count this one, already counted one SUBSTANCE

                   IF S

                       QUIT 

VISION    ;

 +1                SET S=0

 +2                SET BUDTIEN=$ORDER(^BUDHCNTL("B","VISION LINE NUMBERS",0))

 +3                SET S=0

 +4                IF $DATA(^BUDHCNTL(BUDTIEN,11,"B",BUDLINE))

                       Begin DoDot:2

 +5                        SET D=$PIECE($GET(^TMP($JOB,"VISIONCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)),U,1)

 +6       ;already have a VISION care visit on this date

                           IF D]""

                               IF D'>$PIECE(^AUPNVSIT(BUDVSIT,0),U)

                                   SET S=1

                                   QUIT 

 +7                        SET ^TMP($JOB,"VISIONCARE",DFN,BUDVDATE,BUDVLOC,BUDTIEN)=$PIECE(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT

                       End DoDot:2

 +8       ;don't count this one, already counted one VISION

                   IF S

                       QUIT 

OTH       ;can have only 1 in each category

 +1                SET BUDTIEN=$ORDER(^BUDHTFIV("B",22,0))

 +2                SET S=0

 +3                IF $DATA(^BUDHTFIV(BUDTIEN,11,"B",BUDPPD))

                       Begin DoDot:2

 +4                        SET D=$PIECE($GET(^TMP($JOB,"OTHSERV",DFN,BUDVDATE,BUDVLOC,BUDPPD)),U,1)

 +5                        IF D]""

                               IF D'>$PIECE(^AUPNVSIT(BUDVSIT,0),U)

                                   SET S=1

                                   QUIT 

 +6                        SET ^TMP($JOB,"OTHSERV",DFN,BUDVDATE,BUDVLOC,BUDPPD)=$PIECE(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT

                       End DoDot:2

 +7                IF S

                       QUIT 

ENAB      ;NOW CHECK FOR ENABLING

 +1                SET S=0

 +2                SET BUDTIEN=$ORDER(^BUDHCNTL("B","ENABLING LINE NUMBERS",0))

 +3                IF $DATA(^BUDHCNTL(BUDTIEN,11,"B",BUDLINE))