BUD0RPTD ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
GETV ;EP - get all visits for this patient and tally in BUDTV
;^TMP($J,"VISITS") has all visits
;^TMP($J,"VISITSLIST") is visit list 1 in the SRD
;^TMP($J,"VISITS35") is used for table 3 and 5
;^TMP($J,"VISITS6DX") is used for table 6 dxs and includes 2 visits on same day to same provider
K ^TMP($J)
S BUDTV=0,BUDT35V=0,BUDT6V=0,BUDMEDV=0,BUDMEDVI=""
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
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)
.Q:BUDVLOC=""
.Q:'$D(^BUDTSITE(BUDSITE,11,BUDVLOC)) ;not valid location
.Q:"AHSORMEI"'[$P(^AUPNVSIT(BUDVSIT,0),U,7)
.S BUDCLINC=$$CLINIC^APCLV(BUDVSIT,"C")
.S BUDTIEN=$O(^BUDTCNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))
.I BUDCLINC]"",$D(^BUDTCNTL(BUDTIEN,11,"B",BUDCLINC)) Q ;not a clinic code we want in any table
.;now eliminate subsequent visits to same provider on same day = item 4 in SRD visit definition
.S BUDVDATE=$$VD^APCLV(BUDVSIT)
.S BUDPP=$$PRIMPROV^APCLV(BUDVSIT,"I")
.I $P(^AUPNVSIT(BUDVSIT,0),U,7)="I" G SET ;don't count I visits
.I '$D(^AUPNVPOV("AD",BUDVSIT)) G SET
.S S=0
.I BUDPP]"" D
..S D=$P($G(^TMP($J,"SAMEPROV",DFN,BUDVDATE,BUDPP)),U,1)
..I D]"",D'>$P(^AUPNVSIT(BUDVSIT,0),U) S S=1 Q ;already had a visit to this provider on this date
..S ^TMP($J,"SAMEPROV",DFN,BUDVDATE,BUDPP)=$P(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT
.Q:S ;quit if already had a visit to this provider
.S BUDPP=$$PRIMPROV^APCLV(BUDVSIT,"D")
.I BUDPP="" G SET
MEDC .;NOW CHECK FOR MEDICAL CARE, CAN ONLY HAVE 1 PER LOCATION OF ENCOUNTER
.S S=0
.S BUDTIEN=$O(^BUDTCNTL("B","MEDICAL CARE LINE NUMBERS",0))
.;S BUDPP=$$PRIMPROV^APCLV(BUDVSIT,"D")
.I $E($$VAL^XBDIQ1(9000010,BUDVSIT,.06),1,3)="CHS",BUDPP=15 S BUDLINE=2 G MEDC1
.S BUDY=$O(^BUDTTFIV("C",BUDPP,0)) I BUDY="" S BUDLINE=35 G MEDC1
.S BUDLINE=$O(^BUDTTFIV("AA",BUDPP,""))
MEDC1 .S S=0
.I $D(^BUDTCNTL(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(^BUDTCNTL("B","DENTAL LINE NUMBERS",0))
.S S=0
.I $D(^BUDTCNTL(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(^BUDTCNTL("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(^BUDTCNTL(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(^BUDTCNTL("B","SUBSTANCE LINE NUMBERS",0))
.S S=0
.I $D(^BUDTCNTL(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(^BUDTCNTL("B","VISION LINE NUMBERS",0))
.S S=0
.I $D(^BUDTCNTL(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(^BUDTTFIV("B",22,0))
.S S=0
.I $D(^BUDTTFIV(BUDTIEN,11,"B",BUDPP)) D
..S D=$P($G(^TMP($J,"OTHSERV",DFN,BUDVDATE,BUDVLOC,BUDPP)),U,1)
..I D]"",D'>$P(^AUPNVSIT(BUDVSIT,0),U) S S=1 Q
..S ^TMP($J,"OTHSERV",DFN,BUDVDATE,BUDVLOC,BUDPP)=$P(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT
.Q:S
ENAB .;NOW CHECK FOR ENABLING
.S S=0
.S BUDTIEN=$O(^BUDTCNTL("B","ENABLING LINE NUMBERS",0))
.S S=0
.I $D(^BUDTCNTL(BUDTIEN,11,"B",BUDLINE)) D
..S D=$P($G(^TMP($J,"ENABCARE",DFN,BUDVDATE,BUDVLOC,BUDPP)),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,BUDPP)=$P(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT
.Q:S ;don't count this one, already counted onE ENABLING
SET .S BUDTV=BUDTV+1
.S ^TMP($J,"VISITSLIST",BUDVSIT)="" ;USED IN TABLE 6A SERVICES ONLY
.;NOW get all for table 3A, 3B, 5 AND 6 dxs, same list but include duplicates
.I '$D(^AUPNVPOV("AD",BUDVSIT)) Q
.;must have a primary dx other than .9999
.S Y=$$PRIMPOV^APCLV(BUDVSIT,"C") I Y=".9999" Q
.;the above make it a "complete" visit
.S BUDTIEN=$O(^BUDTCNTL("B","CLINIC EXCLUSIONS",0))
.I BUDCLINC]"",$D(^BUDTCNTL(BUDTIEN,11,"B",BUDCLINC)) Q ;exclude these clinics
.Q:"EI"[$P(^AUPNVSIT(BUDVSIT,0),U,7) ;new in 07 to exclude these from tables 3,5
.Q:BUDPP="" ;no primary provider
.S BUDT35V=BUDT35V+1
.S ^TMP($J,"VISITS356A",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
Q:BUDT35V=0 ;not a patient of interest
;Q:'$D(^BWP(DFN))
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))
I $$VERSION^XPDUTL("BW")<3 D
.S (G,V)=0 F S V=$O(^BWPCD("C",DFN,V)) Q:V="" D
..Q:'$D(^BWPCD(BUDVSIT,0))
..S D=$P(^BWPCD(BUDVSIT,0),U,12)
..S J=$P(^BWPCD(BUDVSIT,0),U,4) I J=T!(J=T1)!(J=T2) D Q
...Q:D<BUDBD
...Q:D>BUDED
...Q:$P($G(^BWPCD(BUDVSIT,"PCC")),U,1)]"" ;already in pcc
...S L=$P(^BWPCD(BUDVSIT,0),U,10)
...Q:L=""
...Q:'$D(^BUDTSITE(BUDSITE,11,L)) ;not valid location
...S ^TMP($J,"MAMMS",V)="WH "_$$VAL^XBDIQ1(9002086.1,V,.04)_U_$$FMTE^XLFDT(D)
.Q
;;E D
;.S T="MAMMOGRAM SCREENING",T=$O(^BWVPDT("B",T,0))
;.S T1="MAMMOGRAM DX BILAT",T1=$O(^BWVPDT("B",T1,0))
;.S T2="MAMMOGRAM DX UNILAT",T2=$O(^BWVPDT("B",T2,0))
;.S D=$$FINDLSTD^BWVPRD(DFN,T_"^"_T1_"^"_T2,BUDBD,BUDED)
;.Q:D=0
;.Q:D=""
;.;check location here
;.S ^TMP($J,"MAMMS",1)="WH MAMMOGRAM "_U_$$FMTE^XLFDT(D)_U_D
S T="PAP SMEAR",T=$O(^BWPN("B",T,0))
I $$VERSION^XPDUTL("BW")<3 D
.S (G,BUDVSIT)=0 F S BUDVSIT=$O(^BWPCD("C",DFN,BUDVSIT)) Q:BUDVSIT="" D
..Q:'$D(^BWPCD(BUDVSIT,0))
..S D=$P(^BWPCD(BUDVSIT,0),U,12)
..S J=$P(^BWPCD(BUDVSIT,0),U,4) I J=T D Q
...Q:D<BUDBD
...Q:D>BUDED
...Q:$P($G(^BWPCD(BUDVSIT,"PCC")),U,1)]"" ;already in pcc
...S L=$P(^BWPCD(BUDVSIT,0),U,10)
...Q:L=""
...Q:'$D(^BUDTSITE(BUDSITE,11,L)) ;not valid location
...S ^TMP($J,"PAPS",BUDVSIT)="WH PAP SMEAR"_U_$$FMTE^XLFDT(D)
.Q
;E D
;.S T="PAP SMEAR",T=$O(^BWVPDT("B",T,0))
;.S D=$$FINDLSTD^BWVPRD(DFN,T,BUDBD,BUDED)
;.Q:D=0
;.Q:D=""
;.;check location here
;.S ^TMP($J,"PAPS",1)="WH PAP SMEAR "_U_$$FMTE^XLFDT(D)_U_D
;.S ^DIBT(4370,1,DFN)=""
;.Q
Q
TZH ;EP
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("*** BPHC Uniform Data System (UDS) ***",80)
W !,$$CTR("Patient List: Patient by Zip Code",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),!
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"
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
BUD0RPTD ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
+3 ;
GETV ;EP - get all visits for this patient and tally in BUDTV
+1 ;^TMP($J,"VISITS") has all visits
+2 ;^TMP($J,"VISITSLIST") is visit list 1 in the SRD
+3 ;^TMP($J,"VISITS35") is used for table 3 and 5
+4 ;^TMP($J,"VISITS6DX") is used for table 6 dxs and includes 2 visits on same day to same provider
+5 KILL ^TMP($JOB)
+6 SET BUDTV=0
SET BUDT35V=0
SET BUDT6V=0
SET BUDMEDV=0
SET BUDMEDVI=""
+7 SET A="^TMP($J,""VISITS"","
SET B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BUDBD)_"-"_$$FMTE^XLFDT(BUDED)
SET E=$$START1^APCLDF(B,A)
+8 IF '$DATA(^TMP($JOB,"VISITS",1))
QUIT
+9 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
+10 IF '$DATA(^AUPNVSIT(BUDVSIT,0))
QUIT
+11 IF '$PIECE(^AUPNVSIT(BUDVSIT,0),U,9)
QUIT
+12 IF $PIECE(^AUPNVSIT(BUDVSIT,0),U,11)
QUIT
+13 SET BUDVLOC=$PIECE(^AUPNVSIT(BUDVSIT,0),U,6)
+14 IF BUDVLOC=""
QUIT
+15 ;not valid location
IF '$DATA(^BUDTSITE(BUDSITE,11,BUDVLOC))
QUIT
+16 IF "AHSORMEI"'[$PIECE(^AUPNVSIT(BUDVSIT,0),U,7)
QUIT
+17 SET BUDCLINC=$$CLINIC^APCLV(BUDVSIT,"C")
+18 SET BUDTIEN=$ORDER(^BUDTCNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))
+19 ;not a clinic code we want in any table
IF BUDCLINC]""
IF $DATA(^BUDTCNTL(BUDTIEN,11,"B",BUDCLINC))
QUIT
+20 ;now eliminate subsequent visits to same provider on same day = item 4 in SRD visit definition
+21 SET BUDVDATE=$$VD^APCLV(BUDVSIT)
+22 SET BUDPP=$$PRIMPROV^APCLV(BUDVSIT,"I")
+23 ;don't count I visits
IF $PIECE(^AUPNVSIT(BUDVSIT,0),U,7)="I"
GOTO SET
+24 IF '$DATA(^AUPNVPOV("AD",BUDVSIT))
GOTO SET
+25 SET S=0
+26 IF BUDPP]""
Begin DoDot:2
+27 SET D=$PIECE($GET(^TMP($JOB,"SAMEPROV",DFN,BUDVDATE,BUDPP)),U,1)
+28 ;already had a visit to this provider on this date
IF D]""
IF D'>$PIECE(^AUPNVSIT(BUDVSIT,0),U)
SET S=1
QUIT
+29 SET ^TMP($JOB,"SAMEPROV",DFN,BUDVDATE,BUDPP)=$PIECE(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT
End DoDot:2
+30 ;quit if already had a visit to this provider
IF S
QUIT
+31 SET BUDPP=$$PRIMPROV^APCLV(BUDVSIT,"D")
+32 IF BUDPP=""
GOTO SET
MEDC ;NOW CHECK FOR MEDICAL CARE, CAN ONLY HAVE 1 PER LOCATION OF ENCOUNTER
+1 SET S=0
+2 SET BUDTIEN=$ORDER(^BUDTCNTL("B","MEDICAL CARE LINE NUMBERS",0))
+3 ;S BUDPP=$$PRIMPROV^APCLV(BUDVSIT,"D")
+4 IF $EXTRACT($$VAL^XBDIQ1(9000010,BUDVSIT,.06),1,3)="CHS"
IF BUDPP=15
SET BUDLINE=2
GOTO MEDC1
+5 SET BUDY=$ORDER(^BUDTTFIV("C",BUDPP,0))
IF BUDY=""
SET BUDLINE=35
GOTO MEDC1
+6 SET BUDLINE=$ORDER(^BUDTTFIV("AA",BUDPP,""))
MEDC1 SET S=0
+1 IF $DATA(^BUDTCNTL(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(^BUDTCNTL("B","DENTAL LINE NUMBERS",0))
+3 SET S=0
+4 IF $DATA(^BUDTCNTL(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(^BUDTCNTL("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(^BUDTCNTL(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(^BUDTCNTL("B","SUBSTANCE LINE NUMBERS",0))
+3 SET S=0
+4 IF $DATA(^BUDTCNTL(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(^BUDTCNTL("B","VISION LINE NUMBERS",0))
+3 SET S=0
+4 IF $DATA(^BUDTCNTL(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(^BUDTTFIV("B",22,0))
+2 SET S=0
+3 IF $DATA(^BUDTTFIV(BUDTIEN,11,"B",BUDPP))
Begin DoDot:2
+4 SET D=$PIECE($GET(^TMP($JOB,"OTHSERV",DFN,BUDVDATE,BUDVLOC,BUDPP)),U,1)
+5 IF D]""
IF D'>$PIECE(^AUPNVSIT(BUDVSIT,0),U)
SET S=1
QUIT
+6 SET ^TMP($JOB,"OTHSERV",DFN,BUDVDATE,BUDVLOC,BUDPP)=$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(^BUDTCNTL("B","ENABLING LINE NUMBERS",0))
+3 SET S=0
+4 IF $DATA(^BUDTCNTL(BUDTIEN,11,"B",BUDLINE))
Begin DoDot:2
+5 SET D=$PIECE($GET(^TMP($JOB,"ENABCARE",DFN,BUDVDATE,BUDVLOC,BUDPP)),U,1)
+6 ;already have a ENABLING care visit on this date
IF D]""
IF D'>$PIECE(^AUPNVSIT(BUDVSIT,0),U)
SET S=1
QUIT
+7 SET ^TMP($JOB,"ENABCARE",DFN,BUDVDATE,BUDVLOC,BUDPP)=$PIECE(^AUPNVSIT(BUDVSIT,0),U)_U_BUDVSIT
End DoDot:2
+8 ;don't count this one, already counted onE ENABLING
IF S
QUIT
SET SET BUDTV=BUDTV+1
+1 ;USED IN TABLE 6A SERVICES ONLY
SET ^TMP($JOB,"VISITSLIST",BUDVSIT)=""
+2 ;NOW get all for table 3A, 3B, 5 AND 6 dxs, same list but include duplicates
+3 IF '$DATA(^AUPNVPOV("AD",BUDVSIT))
QUIT
+4 ;must have a primary dx other than .9999
+5 SET Y=$$PRIMPOV^APCLV(BUDVSIT,"C")
IF Y=".9999"
QUIT
+6 ;the above make it a "complete" visit
+7 SET BUDTIEN=$ORDER(^BUDTCNTL("B","CLINIC EXCLUSIONS",0))
+8 ;exclude these clinics
IF BUDCLINC]""
IF $DATA(^BUDTCNTL(BUDTIEN,11,"B",BUDCLINC))
QUIT
+9 ;new in 07 to exclude these from tables 3,5
IF "EI"[$PIECE(^AUPNVSIT(BUDVSIT,0),U,7)
QUIT
+10 ;no primary provider
IF BUDPP=""
QUIT
+11 SET BUDT35V=BUDT35V+1
+12 SET ^TMP($JOB,"VISITS356A",BUDVSIT)=""
End DoDot:1
+13 ;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
+14 ;not a patient of interest
IF BUDT35V=0
QUIT
+15 ;Q:'$D(^BWP(DFN))
+16 SET T="MAMMOGRAM SCREENING"
SET T=$ORDER(^BWPN("B",T,0))
+17 SET T1="MAMMOGRAM DX BILAT"
SET T1=$ORDER(^BWPN("B",T1,0))
+18 SET T2="MAMMOGRAM DX UNILAT"
SET T2=$ORDER(^BWPN("B",T2,0))
+19 IF $$VERSION^XPDUTL("BW")<3
Begin DoDot:1
+20 SET (G,V)=0
FOR
SET V=$ORDER(^BWPCD("C",DFN,V))
IF V=""
QUIT
Begin DoDot:2
+21 IF '$DATA(^BWPCD(BUDVSIT,0))
QUIT
+22 SET D=$PIECE(^BWPCD(BUDVSIT,0),U,12)
+23 SET J=$PIECE(^BWPCD(BUDVSIT,0),U,4)
IF J=T!(J=T1)!(J=T2)
Begin DoDot:3
+24 IF D<BUDBD
QUIT
+25 IF D>BUDED
QUIT
+26 ;already in pcc
IF $PIECE($GET(^BWPCD(BUDVSIT,"PCC")),U,1)]""
QUIT
+27 SET L=$PIECE(^BWPCD(BUDVSIT,0),U,10)
+28 IF L=""
QUIT
+29 ;not valid location
IF '$DATA(^BUDTSITE(BUDSITE,11,L))
QUIT
+30 SET ^TMP($JOB,"MAMMS",V)="WH "_$$VAL^XBDIQ1(9002086.1,V,.04)_U_$$FMTE^XLFDT(D)
End DoDot:3
QUIT
End DoDot:2
+31 QUIT
End DoDot:1
+32 ;;E D
+33 ;.S T="MAMMOGRAM SCREENING",T=$O(^BWVPDT("B",T,0))
+34 ;.S T1="MAMMOGRAM DX BILAT",T1=$O(^BWVPDT("B",T1,0))
+35 ;.S T2="MAMMOGRAM DX UNILAT",T2=$O(^BWVPDT("B",T2,0))
+36 ;.S D=$$FINDLSTD^BWVPRD(DFN,T_"^"_T1_"^"_T2,BUDBD,BUDED)
+37 ;.Q:D=0
+38 ;.Q:D=""
+39 ;.;check location here
+40 ;.S ^TMP($J,"MAMMS",1)="WH MAMMOGRAM "_U_$$FMTE^XLFDT(D)_U_D
+41 SET T="PAP SMEAR"
SET T=$ORDER(^BWPN("B",T,0))
+42 IF $$VERSION^XPDUTL("BW")<3
Begin DoDot:1
+43 SET (G,BUDVSIT)=0
FOR
SET BUDVSIT=$ORDER(^BWPCD("C",DFN,BUDVSIT))
IF BUDVSIT=""
QUIT
Begin DoDot:2
+44 IF '$DATA(^BWPCD(BUDVSIT,0))
QUIT
+45 SET D=$PIECE(^BWPCD(BUDVSIT,0),U,12)
+46 SET J=$PIECE(^BWPCD(BUDVSIT,0),U,4)
IF J=T
Begin DoDot:3
+47 IF D<BUDBD
QUIT
+48 IF D>BUDED
QUIT
+49 ;already in pcc
IF $PIECE($GET(^BWPCD(BUDVSIT,"PCC")),U,1)]""
QUIT
+50 SET L=$PIECE(^BWPCD(BUDVSIT,0),U,10)
+51 IF L=""
QUIT
+52 ;not valid location
IF '$DATA(^BUDTSITE(BUDSITE,11,L))
QUIT
+53 SET ^TMP($JOB,"PAPS",BUDVSIT)="WH PAP SMEAR"_U_$$FMTE^XLFDT(D)
End DoDot:3
QUIT
End DoDot:2
+54 QUIT
End DoDot:1
+55 ;E D
+56 ;.S T="PAP SMEAR",T=$O(^BWVPDT("B",T,0))
+57 ;.S D=$$FINDLSTD^BWVPRD(DFN,T,BUDBD,BUDED)
+58 ;.Q:D=0
+59 ;.Q:D=""
+60 ;.;check location here
+61 ;.S ^TMP($J,"PAPS",1)="WH PAP SMEAR "_U_$$FMTE^XLFDT(D)_U_D
+62 ;.S ^DIBT(4370,1,DFN)=""
+63 ;.Q
+64 QUIT
TZH ;EP
+1 IF 'BUDGPG
GOTO TZH1
+2 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("*** BPHC Uniform Data System (UDS) ***",80)
+5 WRITE !,$$CTR("Patient List: Patient by Zip Code",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 WRITE $TRANSLATE($JUSTIFY("",80)," ","-")
+9 IF BUDP=0
WRITE !,"List of all patients with one or more visits during the calendar year."
+10 IF BUDP=0
WRITE !,"Zip code is from patient registration."
+11 IF BUDP=0
WRITE !!,"NOTE: Patients with a zip code included in the Other Zip Codes category"
+12 IF BUDP=0
WRITE !,"have their zip code value followed by a ""","*",""" (e.g. 87015*)."
+13 WRITE !!,"PATIENT NAME",?24,"HRN",?36,"COMMUNITY",?50,"SEX",?55,"ZIP CODE"
+14 WRITE !?5,"VISIT DATE",?25,"PROV TYPE",?41,"SRV",?45,"CLINIC",?62,"LOCATION"
+15 SET BUDP=1
+16 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+17 QUIT
CTR(X,Y) ;EP
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
