BUDDRPTD ; IHS/CMI/LAB - UDS REPORT PROCESSOR 05 Oct 2016 5:03 PM ;
;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
;
;
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 ;no visits so not a patient
;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) ;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(^BUDDSITE(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(^BUDDCNTL("B","UDS PT/TABLE 5 CLINIC EXCL",0))
.I BUDCLINC]"",$D(^BUDDCNTL(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(^BUDDSITE(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(^BUDDCNTL("B","UDS PT/TABLE 5 CLINIC EXCL",0))
.I BUDCLINC]"",$D(^BUDDCNTL(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
.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(^BUDDCNTL("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(^BUDDTFIV("C",BUDPPD,0)) I BUDY="" S BUDLINE=35 G MEDC1
.S BUDLINE=$O(^BUDDTFIV("AA",BUDPPD,""))
MEDC1 .S S=0
.I $D(^BUDDCNTL(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(^BUDDCNTL("B","DENTAL LINE NUMBERS",0))
.S S=0
.I $D(^BUDDCNTL(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(^BUDDCNTL("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(^BUDDCNTL(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(^BUDDCNTL("B","SUBSTANCE LINE NUMBERS",0))
.S S=0
.I $D(^BUDDCNTL(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(^BUDDCNTL("B","VISION LINE NUMBERS",0))
.S S=0
.I $D(^BUDDCNTL(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(^BUDDTFIV("B",22,0))
.S S=0
.I $D(^BUDDTFIV(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(^BUDDCNTL("B","ENABLING LINE NUMBERS",0))
.I $D(^BUDDCNTL(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 int he site parameter file
.Q:BUDVLOC=""
.Q:'$D(^BUDDSITE(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(^BUDDCNTL("B","TABLE 6A CLINIC EXCLUSIONS",0))
.I BUDCLINC]"",$D(^BUDDCNTL(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(^BUDDSITE(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(^BUDDSITE(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 !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
W !,$$CTR("*** RPMS Uniform Data System (UDS) ***",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)",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
;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
S X="DATE^BILL (A/R)^TRANSACTION TYPE^CREDIT^DEBIT^PRIME BILL AMOUNT^PAYMENT^ADJUSTMENT^ADJUSTMENT CATEGORY^ADJUSTMENT TYPE^A/R ACCOUNT^PATIENT (A/R)^VISIT LOCATION^CLINIC TYPE^DOS BEGIN^BILL TYPE^PRIMARY PROVIDER^"
S X=X_"HRN^DOB^COMMUNITY"
S ^BUDDATA(1)=X
S D=0,C=1 F S D=$O(^XTMP("BUDARP9DEL",BUDJ,BUDH,D)) Q:D'=+D D
.S X=0 F S X=$O(^XTMP("BUDARP9DEL",BUDJ,BUDH,D,X)) Q:X'=+X D
..S C=C+1 S ^BUDDATA(C)=^XTMP("BUDARP9DEL",BUDJ,BUDH,D,X)
S XBFLT=1,XBFN=BUDFILE_".txt",XBMED="F",XBTLE="UDS TABLE 9D DELIMITED",XBQ="N",XBF=0
D ^XBGSAVE
K XBFLT,XBFN,XBMED,XBTLE,XBE,XBF
L -^BUDDATA
K ^BUDDATA ;export global
Q
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("***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****")
D S($P(^VA(200,DUZ,0),U,2)_" "_$$FMTE^XLFDT(DT))
D S("*** RPMS Uniform Data System (UDS) ***")
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)",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
S X=0,C=0 F S X=$O(^TMP($J,"BUDDEL",X)) Q:X'=+X S C=C+1 S ^BUDDATA(C)=^TMP($J,"BUDDEL",X)
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 ;
S X=0 F S X=$O(^TMP($J,"BUDDEL",X)) Q:X'=+X W !,^TMP($J,"BUDDEL",X)
Q
T6DH ;EP
D S(""),S(""),S("")
D S("***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****")
D S($P(^VA(200,DUZ,0),U,2)_" "_$$FMTE^XLFDT(DT))
D S("*** RPMS Uniform Data System (UDS) ***")
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)",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
BUDDRPTD ; IHS/CMI/LAB - UDS REPORT PROCESSOR 05 Oct 2016 5:03 PM ;
+1 ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
+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 ;no visits so not a patient
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 ;0 dependent entries, not a visit
IF '$PIECE(^AUPNVSIT(BUDVSIT,0),U,9)
QUIT
+17 ;deleted visit
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(^BUDDSITE(BUDSITE,11,BUDVLOC))
QUIT
+21 ;ignore cr/telephone/ events
IF "AHSORMI"'[$PIECE(^AUPNVSIT(BUDVSIT,0),U,7)
QUIT
+22 SET BUDCLINC=$$CLINIC^APCLV(BUDVSIT,"C")
+23 SET BUDTIEN=$ORDER(^BUDDCNTL("B","UDS PT/TABLE 5 CLINIC EXCL",0))
+24 ;don't count UDS PATIENT CLINIC EXCLUSIONS
IF BUDCLINC]""
IF $DATA(^BUDDCNTL(BUDTIEN,11,"B",BUDCLINC))
QUIT
+25 ;IEN of primary provider
SET BUDPP=$$PRIMPROV^APCLV(BUDVSIT,"I")
+26 ;no primary provider
IF 'BUDPP
QUIT
+27 SET BUDPPD=$$PRIMPROV^APCLV(BUDVSIT,"D")
+28 ;has to have a discipline
IF BUDPPD=""
QUIT
+29 ;must have at least 1 pov to elimiate orphans
IF '$DATA(^AUPNVPOV("AD",BUDVSIT))
QUIT
+30 SET BUDUDSPT=BUDUDSPT+1
+31 ;THIS IS THE LIST FOR PAT LISTS FOR 3A, 3B, ZIP, 4
SET ^TMP($JOB,"VISITSUDSPT",BUDVSIT)=""
+32 IF $$VD^APCLV(BUDLASTV)<$$VD^APCLV(BUDVSIT)
SET BUDLASTV=BUDVSIT
+33 IF $$VD^APCLV(BUDVSIT)>$$VD^APCLV(BUDFRSTV)
SET BUDFRSTV=BUDVSIT
End DoDot:1
+34 ;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(^BUDDSITE(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(^BUDDCNTL("B","UDS PT/TABLE 5 CLINIC EXCL",0))
+12 ;don't count excluded clinics
IF BUDCLINC]""
IF $DATA(^BUDDCNTL(BUDTIEN,11,"B",BUDCLINC))
QUIT
+13 ;IEN of primary provider
SET BUDPP=$$PRIMPROV^APCLV(BUDVSIT,"I")
+14 ;no primary provider
IF 'BUDPP
QUIT
+15 SET BUDVDATE=$$VD^APCLV(BUDVSIT)
+16 ;primary provider discipline
SET BUDPPD=$$PRIMPROV^APCLV(BUDVSIT,"D")
+17 ;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(^BUDDCNTL("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(^BUDDTFIV("C",BUDPPD,0))
IF BUDY=""
SET BUDLINE=35
GOTO MEDC1
+5 SET BUDLINE=$ORDER(^BUDDTFIV("AA",BUDPPD,""))
MEDC1 SET S=0
+1 IF $DATA(^BUDDCNTL(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(^BUDDCNTL("B","DENTAL LINE NUMBERS",0))
+3 SET S=0
+4 IF $DATA(^BUDDCNTL(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(^BUDDCNTL("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(^BUDDCNTL(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(^BUDDCNTL("B","SUBSTANCE LINE NUMBERS",0))
+3 SET S=0
+4 IF $DATA(^BUDDCNTL(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(^BUDDCNTL("B","VISION LINE NUMBERS",0))
+3 SET S=0
+4 IF $DATA(^BUDDCNTL(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(^BUDDTFIV("B",22,0))
+2 SET S=0
+3 IF $DATA(^BUDDTFIV(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(^BUDDCNTL("B","ENABLING LINE NUMBERS",0))
+3 IF $DATA(^BUDDCNTL(BUDTIEN,11,"B",BUDLINE))
Begin DoDot:2
+4 SET D=$PIECE($GET(^TMP($JOB,"ENABCARE",DFN,BUDVDATE,BUDVLOC,BUDPPD)),U,1)
+5 ;already have a ENABLING care visit on this date
IF D]""
IF D'>$PIECE(^AUPNVSIT(BUDVSIT,0),U)
SET S=1
QUIT
+6 SET ^TMP($JOB,"ENABCARE",DFN,BUDVDATE,BUDVLOC,BUDPPD)=$PIECE(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT
End DoDot:2
+7 ;don't count this one, already counted onE ENABLING
IF S
QUIT
SET ;
+1 ;USED IN TABLE 5
SET ^TMP($JOB,"VISITSTABLE5",BUDVSIT)=""
End DoDot:1
+2 ;NOW TABLE 6A
A6 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
+1 IF '$DATA(^AUPNVSIT(BUDVSIT,0))
QUIT
+2 ;0 dependent entries, not a visit
IF '$PIECE(^AUPNVSIT(BUDVSIT,0),U,9)
QUIT
+3 ;deleted visit
IF $PIECE(^AUPNVSIT(BUDVSIT,0),U,11)
QUIT
+4 ;must be to a location int he site parameter file
SET BUDVLOC=$PIECE(^AUPNVSIT(BUDVSIT,0),U,6)
+5 IF BUDVLOC=""
QUIT
+6 ;not valid location
IF '$DATA(^BUDDSITE(BUDSITE,11,BUDVLOC))
QUIT
+7 ;ignore cr/telephone/events
IF "AHSORMI"'[$PIECE(^AUPNVSIT(BUDVSIT,0),U,7)
QUIT
+8 SET BUDCLINC=$$CLINIC^APCLV(BUDVSIT,"C")
+9 SET BUDTIEN=$ORDER(^BUDDCNTL("B","TABLE 6A CLINIC EXCLUSIONS",0))
+10 ;don't count excluded clinics
IF BUDCLINC]""
IF $DATA(^BUDDCNTL(BUDTIEN,11,"B",BUDCLINC))
QUIT
+11 ;S BUDP=$$PRIMPROV^APCLV(BUDVSIT) Q:'BUDP ;no primary provider - WHAT ABOUT ORPHANS FOR LAB/RAD/IMM
+12 ;COUNT ONLY 1 INPATIENT VISIT PER DAY
+13 IF $PIECE(^AUPNVSIT(BUDVSIT,0),U,7)="H"
IF $DATA(^TMP($JOB,"H",DFN,$$VD^APCLV(BUDVSIT)))
QUIT
+14 IF $PIECE(^AUPNVSIT(BUDVSIT,0),U,7)="H"
SET ^TMP($JOB,"H",DFN,$$VD^APCLV(BUDVSIT))=""
+15 SET ^TMP($JOB,"VISITSTABLE6A",BUDVSIT)=""
End DoDot:1
+16 ;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
+17 SET T="MAMMOGRAM SCREENING"
SET T=$ORDER(^BWPN("B",T,0))
+18 SET T1="MAMMOGRAM DX BILAT"
SET T1=$ORDER(^BWPN("B",T1,0))
+19 SET T2="MAMMOGRAM DX UNILAT"
SET T2=$ORDER(^BWPN("B",T2,0))
+20 Begin DoDot:1
+21 SET (G,V)=0
FOR
SET V=$ORDER(^BWPCD("C",DFN,V))
IF V=""
QUIT
Begin DoDot:2
+22 IF '$DATA(^BWPCD(V,0))
QUIT
+23 SET D=$PIECE(^BWPCD(V,0),U,12)
+24 SET J=$PIECE(^BWPCD(V,0),U,4)
IF J=T!(J=T1)!(J=T2)
Begin DoDot:3
+25 IF D<BUDBD
QUIT
+26 IF D>BUDED
QUIT
+27 SET L=$PIECE(^BWPCD(V,0),U,10)
+28 IF L=""
QUIT
+29 ;not valid location
IF '$DATA(^BUDDSITE(BUDSITE,11,L))
QUIT
+30 ;already in pcc
IF $PIECE($GET(^BWPCD(V,"PCC")),U,1)]""
QUIT
+31 SET ^TMP($JOB,"MAMMS",V)="WH "_$$VAL^XBDIQ1(9002086.1,V,.04)_U_$$FMTE^XLFDT(D)
End DoDot:3
QUIT
End DoDot:2
+32 QUIT
End DoDot:1
+33 SET T="PAP SMEAR"
SET T=$ORDER(^BWPN("B",T,0))
+34 Begin DoDot:1
+35 SET (G,V)=0
FOR
SET V=$ORDER(^BWPCD("C",DFN,V))
IF V=""
QUIT
Begin DoDot:2
+36 IF '$DATA(^BWPCD(V,0))
QUIT
+37 SET D=$PIECE(^BWPCD(V,0),U,12)
+38 SET J=$PIECE(^BWPCD(V,0),U,4)
IF J=T
Begin DoDot:3
+39 IF D<BUDBD
QUIT
+40 IF D>BUDED
QUIT
+41 SET L=$PIECE(^BWPCD(V,0),U,10)
+42 IF L=""
QUIT
+43 ;not valid location
IF '$DATA(^BUDDSITE(BUDSITE,11,L))
QUIT
+44 ;already in pcc
IF $PIECE($GET(^BWPCD(V,"PCC")),U,1)]""
QUIT
+45 SET ^TMP($JOB,"PAPS",V)="WH "_$$VAL^XBDIQ1(9002086.1,V,.04)_U_$$FMTE^XLFDT(D)
End DoDot:3
QUIT
End DoDot:2
+46 QUIT
End DoDot:1
+47 QUIT
TZH ;EP
+1 IF BUDROT="D"
QUIT
+2 IF 'BUDGPG
GOTO TZH1
+3 KILL DIR
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
IF '$DATA(ZTQUEUED)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BUDQUIT=1
QUIT
TZH1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET BUDGPG=BUDGPG+1
+2 WRITE !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
+3 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BUDGPG,!
+4 WRITE !,$$CTR("*** RPMS Uniform Data System (UDS) ***",80)
+5 WRITE !,$$CTR("Patient List: Patient by Zip Code/Insurance",80),!
+6 WRITE $$CTR($PIECE(^DIC(4,BUDSITE,0),U),80),!
+7 SET X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED)
WRITE $$CTR(X,80),!
+8 SET X="Population: "_$SELECT($GET(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"")
WRITE $$CTR(X,80),!
+9 WRITE $TRANSLATE($JUSTIFY("",80)," ","-")
+10 IF BUDP=0
WRITE !,"List of all patients with one or more visits during the calendar year."
+11 IF BUDP=0
WRITE !,"Zip code is from patient registration."
+12 IF BUDP=0
WRITE !!,"NOTE: Patients with a zip code included in the Other Zip Codes category"
+13 IF BUDP=0
WRITE !,"have their zip code value followed by a ""","*",""" (e.g. 87015*)."
+14 WRITE !!,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"ZIP CODE",?65,"INS"
+15 WRITE !?5,"VISIT DATE",?25,"PROV TYPE",?41,"SRV",?45,"CLINIC",?62,"LOCATION"
+16 SET BUDP=1
+17 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+18 QUIT
CTR(X,Y) ;EP
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;
WDEL ;EP - write out delimited file 9d
+1 ;call xbgsave to create output file
+2 SET XBGL="BUDDATA"
+3 LOCK +^BUDDATA:300
IF '$TEST
IF '$DATA(ZTQUEUED)
WRITE "Unable to lock global"
QUIT
+4 KILL ^TMP($JOB,"SUMMARYDEL")
+5 ;global for saving
KILL ^BUDDATA
+6 SET X="DATE^BILL (A/R)^TRANSACTION TYPE^CREDIT^DEBIT^PRIME BILL AMOUNT^PAYMENT^ADJUSTMENT^ADJUSTMENT CATEGORY^ADJUSTMENT TYPE^A/R ACCOUNT^PATIENT (A/R)^VISIT LOCATION^CLINIC TYPE^DOS BEGIN^BILL TYPE^PRIMARY PROVIDER^"
+7 SET X=X_"HRN^DOB^COMMUNITY"
+8 SET ^BUDDATA(1)=X
+9 SET D=0
SET C=1
FOR
SET D=$ORDER(^XTMP("BUDARP9DEL",BUDJ,BUDH,D))
IF D'=+D
QUIT
Begin DoDot:1
+10 SET X=0
FOR
SET X=$ORDER(^XTMP("BUDARP9DEL",BUDJ,BUDH,D,X))
IF X'=+X
QUIT
Begin DoDot:2
+11 SET C=C+1
SET ^BUDDATA(C)=^XTMP("BUDARP9DEL",BUDJ,BUDH,D,X)
End DoDot:2
End DoDot:1
+12 SET XBFLT=1
SET XBFN=BUDFILE_".txt"
SET XBMED="F"
SET XBTLE="UDS TABLE 9D DELIMITED"
SET XBQ="N"
SET XBF=0
+13 DO ^XBGSAVE
+14 KILL XBFLT,XBFN,XBMED,XBTLE,XBE,XBF
+15 LOCK -^BUDDATA
+16 ;export global
KILL ^BUDDATA
+17 QUIT
LOTE(P,V) ;
+1 ;if prim lang=other than english
+2 ;interpreter = yes AND
+3 ;preferred = other than english
+4 NEW X,%,Y,D,L,PL,IR,RL
+5 SET D=$$VD^APCLV(V)
+6 SET %=0
SET X=0
SET (Y,L,PL,IR,RL)=""
+7 ;get last one
FOR
SET X=$ORDER(^AUPNPAT(P,86,"B",X))
IF X'=+X!(X>D)
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPAT(P,86,"B",X,Y))
IF Y'=+Y
QUIT
SET L=Y
+8 ;no data recorded
IF 'L
QUIT 0
+9 ;INTERPRETER NOT REQUIRED SO DON'T COUNT
IF $PIECE($GET(^AUPNPAT(P,86,L,0)),U,3)'="Y"
QUIT 0
+10 SET PL=$PIECE($GET(^AUPNPAT(P,86,L,0)),U,1)
+11 ;NO PRIM LANG
IF 'PL
QUIT 0
+12 IF $$VAL^XBDIQ1(9999999.99,PL,.01)="ENGLISH"
QUIT 0
+13 SET PL=$PIECE($GET(^AUPNPAT(P,86,L,0)),U,4)
+14 ;NO PREF LANG
IF 'PL
QUIT 0
+15 IF $$VAL^XBDIQ1(9999999.99,PL,.04)="ENGLISH"
QUIT 0
+16 QUIT 1
TZHD ;EP
+1 DO S("***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****")
+2 DO S($PIECE(^VA(200,DUZ,0),U,2)_" "_$$FMTE^XLFDT(DT))
+3 DO S("*** RPMS Uniform Data System (UDS) ***")
+4 DO S("Patient List: Patient by Zip Code/Insurance")
+5 DO S($PIECE(^DIC(4,BUDSITE,0),U))
+6 SET X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED)
DO S(X)
+7 SET X="Population: "_$SELECT($GET(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"")
DO S(X)
+8 DO S(" ")
+9 DO S("List of all patients with one or more visits during the calendar year.")
+10 DO S("Zip code is from patient registration.")
+11 DO S("NOTE: Patients with a zip code included in the Other Zip Codes category")
+12 SET X="have their zip code value followed by a '*' (e.g. 87015*)."
DO S(X)
+13 DO S(" ")
DO S("PATIENT NAME^HRN^COMMUNITY^SEX^ZIP CODE^INSURANCE^VISIT DATE^PROV TYPE^SRV^CLINIC^LOCATION")
+14 QUIT
S(V) ;
+1 SET BUDDECNT=BUDDECNT+1
+2 SET ^TMP($JOB,"BUDDEL",BUDDECNT)=$GET(V)
+3 QUIT
SAVEDEL ;EP
+1 IF BUDDELT="S"
DO SCREEN
QUIT
+2 ;call xbgsave to create output file
+3 SET XBGL="BUDDATA"
+4 LOCK +^BUDDATA:300
IF '$TEST
IF '$DATA(ZTQUEUED)
WRITE "Unable to lock global"
QUIT
+5 KILL ^TMP($JOB,"SUMMARYDEL")
+6 ;global for saving
KILL ^BUDDATA
+7 SET X=0
SET C=0
FOR
SET X=$ORDER(^TMP($JOB,"BUDDEL",X))
IF X'=+X
QUIT
SET C=C+1
SET ^BUDDATA(C)=^TMP($JOB,"BUDDEL",X)
+8 Begin DoDot:1
+9 SET XBFLT=1
SET XBFN=BUDDELF_".txt"
SET XBMED="F"
SET XBTLE="UDS DELIMITED OUTPUT"
SET XBQ="N"
SET XBF=0
+10 DO ^XBGSAVE
+11 KILL XBFLT,XBFN,XBMED,XBTLE,XBE,XBF
End DoDot:1
+12 LOCK -^BUDDATA
+13 ;export global
KILL ^BUDDATA
+14 KILL ^TMP($JOB,"BUDDEL")
+15 QUIT
+16 ;
SCREEN ;
+1 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"BUDDEL",X))
IF X'=+X
QUIT
WRITE !,^TMP($JOB,"BUDDEL",X)
+2 QUIT
T6DH ;EP
+1 DO S("")
DO S("")
DO S("")
+2 DO S("***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****")
+3 DO S($PIECE(^VA(200,DUZ,0),U,2)_" "_$$FMTE^XLFDT(DT))
+4 DO S("*** RPMS Uniform Data System (UDS) ***")
+5 DO S("Patient List for Table 6A, By Diagnosis Category")
+6 DO S($PIECE(^DIC(4,BUDSITE,0),U))
+7 SET X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED)
DO S(X)
+8 SET X="Population: "_$SELECT($GET(BUDBEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDBEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDBEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"")
DO S(X)
+9 DO S(" ")
+10 DO S("List of all patients, sorted by diagnosis and tests/screening")
+11 DO S("categories. Displays community, gender, age and visit data, and codes.")
+12 DO S("* (R) - denotes the value was obtained from the Race field")
+13 DO S(" (C) - denotes the value was obtained from the Classification/Beneficiary field")
+14 ;D S("Age is calculated as of June 30.")
+15 DO S("")
+16 DO S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^RACE*^VISIT DATE^VALUE^SRV^CLINIC^LOCATION")
+17 QUIT
