BUDBRPTD ; IHS/CMI/LAB - UDS REPORT PROCESSOR 05 Oct 2014 5:03 PM ;
;;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="",BUDLASTV=""
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(^BUDBSITE(BUDSITE,11,BUDVLOC)) ;not valid location
.Q:"AHSORMEI"'[$P(^AUPNVSIT(BUDVSIT,0),U,7)
.S BUDCLINC=$$CLINIC^APCLV(BUDVSIT,"C")
.S BUDTIEN=$O(^BUDBCNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))
.I BUDCLINC]"",$D(^BUDBCNTL(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(^BUDBCNTL("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(^BUDBTFIV("C",BUDPP,0)) I BUDY="" S BUDLINE=35 G MEDC1
.S BUDLINE=$O(^BUDBTFIV("AA",BUDPP,""))
MEDC1 .S S=0
.I $D(^BUDBCNTL(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(^BUDBCNTL("B","DENTAL LINE NUMBERS",0))
.S S=0
.I $D(^BUDBCNTL(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(^BUDBCNTL("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(^BUDBCNTL(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(^BUDBCNTL("B","SUBSTANCE LINE NUMBERS",0))
.S S=0
.I $D(^BUDBCNTL(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(^BUDBCNTL("B","VISION LINE NUMBERS",0))
.S S=0
.I $D(^BUDBCNTL(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(^BUDBTFIV("B",22,0))
.S S=0
.I $D(^BUDBTFIV(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(^BUDBCNTL("B","ENABLING LINE NUMBERS",0))
.S S=0
.I $D(^BUDBCNTL(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(^BUDBCNTL("B","CLINIC EXCLUSIONS",0))
.I BUDCLINC]"",$D(^BUDBCNTL(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)=""
.I $$VD^APCLV(BUDLASTV)<$$VD^APCLV(BUDVSIT) S BUDLASTV=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(^BUDBSITE(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(^BUDBSITE(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("*** 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
BUDBRPTD ; IHS/CMI/LAB - UDS REPORT PROCESSOR 05 Oct 2014 5:03 PM ;
+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=""
SET BUDLASTV=""
+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(^BUDBSITE(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(^BUDBCNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))
+19 ;not a clinic code we want in any table
IF BUDCLINC]""
IF $DATA(^BUDBCNTL(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(^BUDBCNTL("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(^BUDBTFIV("C",BUDPP,0))
IF BUDY=""
SET BUDLINE=35
GOTO MEDC1
+6 SET BUDLINE=$ORDER(^BUDBTFIV("AA",BUDPP,""))
MEDC1 SET S=0
+1 IF $DATA(^BUDBCNTL(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(^BUDBCNTL("B","DENTAL LINE NUMBERS",0))
+3 SET S=0
+4 IF $DATA(^BUDBCNTL(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(^BUDBCNTL("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(^BUDBCNTL(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(^BUDBCNTL("B","SUBSTANCE LINE NUMBERS",0))
+3 SET S=0
+4 IF $DATA(^BUDBCNTL(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(^BUDBCNTL("B","VISION LINE NUMBERS",0))
+3 SET S=0
+4 IF $DATA(^BUDBCNTL(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(^BUDBTFIV("B",22,0))
+2 SET S=0
+3 IF $DATA(^BUDBTFIV(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(^BUDBCNTL("B","ENABLING LINE NUMBERS",0))
+3 SET S=0
+4 IF $DATA(^BUDBCNTL(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(^BUDBCNTL("B","CLINIC EXCLUSIONS",0))
+8 ;exclude these clinics
IF BUDCLINC]""
IF $DATA(^BUDBCNTL(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)=""
+13 IF $$VD^APCLV(BUDLASTV)<$$VD^APCLV(BUDVSIT)
SET BUDLASTV=BUDVSIT
End DoDot:1
+14 ;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
+15 ;not a patient of interest
IF BUDT35V=0
QUIT
+16 ;Q:'$D(^BWP(DFN))
+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 IF $$VERSION^XPDUTL("BW")<3
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(BUDVSIT,0))
QUIT
+23 SET D=$PIECE(^BWPCD(BUDVSIT,0),U,12)
+24 SET J=$PIECE(^BWPCD(BUDVSIT,0),U,4)
IF J=T!(J=T1)!(J=T2)
Begin DoDot:3
+25 IF D<BUDBD
QUIT
+26 IF D>BUDED
QUIT
+27 ;already in pcc
IF $PIECE($GET(^BWPCD(BUDVSIT,"PCC")),U,1)]""
QUIT
+28 SET L=$PIECE(^BWPCD(BUDVSIT,0),U,10)
+29 IF L=""
QUIT
+30 ;not valid location
IF '$DATA(^BUDBSITE(BUDSITE,11,L))
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 ;;E D
+34 ;.S T="MAMMOGRAM SCREENING",T=$O(^BWVPDT("B",T,0))
+35 ;.S T1="MAMMOGRAM DX BILAT",T1=$O(^BWVPDT("B",T1,0))
+36 ;.S T2="MAMMOGRAM DX UNILAT",T2=$O(^BWVPDT("B",T2,0))
+37 ;.S D=$$FINDLSTD^BWVPRD(DFN,T_"^"_T1_"^"_T2,BUDBD,BUDED)
+38 ;.Q:D=0
+39 ;.Q:D=""
+40 ;.;check location here
+41 ;.S ^TMP($J,"MAMMS",1)="WH MAMMOGRAM "_U_$$FMTE^XLFDT(D)_U_D
+42 SET T="PAP SMEAR"
SET T=$ORDER(^BWPN("B",T,0))
+43 IF $$VERSION^XPDUTL("BW")<3
Begin DoDot:1
+44 SET (G,BUDVSIT)=0
FOR
SET BUDVSIT=$ORDER(^BWPCD("C",DFN,BUDVSIT))
IF BUDVSIT=""
QUIT
Begin DoDot:2
+45 IF '$DATA(^BWPCD(BUDVSIT,0))
QUIT
+46 SET D=$PIECE(^BWPCD(BUDVSIT,0),U,12)
+47 SET J=$PIECE(^BWPCD(BUDVSIT,0),U,4)
IF J=T
Begin DoDot:3
+48 IF D<BUDBD
QUIT
+49 IF D>BUDED
QUIT
+50 ;already in pcc
IF $PIECE($GET(^BWPCD(BUDVSIT,"PCC")),U,1)]""
QUIT
+51 SET L=$PIECE(^BWPCD(BUDVSIT,0),U,10)
+52 IF L=""
QUIT
+53 ;not valid location
IF '$DATA(^BUDBSITE(BUDSITE,11,L))
QUIT
+54 SET ^TMP($JOB,"PAPS",BUDVSIT)="WH PAP SMEAR"_U_$$FMTE^XLFDT(D)
End DoDot:3
QUIT
End DoDot:2
+55 QUIT
End DoDot:1
+56 ;E D
+57 ;.S T="PAP SMEAR",T=$O(^BWVPDT("B",T,0))
+58 ;.S D=$$FINDLSTD^BWVPRD(DFN,T,BUDBD,BUDED)
+59 ;.Q:D=0
+60 ;.Q:D=""
+61 ;.;check location here
+62 ;.S ^TMP($J,"PAPS",1)="WH PAP SMEAR "_U_$$FMTE^XLFDT(D)_U_D
+63 ;.S ^DIBT(4370,1,DFN)=""
+64 ;.Q
+65 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("*** 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
