BUD7RPTC ; IHS/CMI/LAB - UDS REPORT PROCESSOR 03 Feb 2009 1:05 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
PROC ;EP - called from xbdbque
S BUDJ=$J,BUDH=$H
K ^TMP($J)
S ^XTMP("BUD7RPT1",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"UDS REPORT"
;TABLE 3A
K BUDTOT F X=1:1:39 S $P(BUDTOT("M"),U,X)=0,$P(BUDTOT("F"),U,X)=0,$P(BUDTOT("ALL"),U,X)=0 ;for table 3A
S BUD019("M")="",BUD019("F")="",BUD019("ALL")=""
;TABLE 5
F X=1:1:6 S BUDTAB5(X)="0^0"
F X=7:1:38 S BUDTAB5(X)="0^0"
F X="9A","9B","20A","20B","20C","29A","10A","27a" S BUDTAB5(X)="0^0"
;TABLE 3B
K BUDHISP
S BUDHISP(1)=" 1.^Hispanic or Latino^0"
S BUDHISP(2)=" 2.^All others (including Unreported)^0"
S BUDHISP(3)=" 3.^<not used>^"
S BUDHISP(4)=" 4.^TOTAL PATIENTS (SUM LINES 1-2)^0^MUST = LINE 11"
K BUDRACET
S BUDRACET("5A")="5a.^Asian^0"
S BUDRACET("5B")="5b.^Native Hawaiian^0"
S BUDRACET("5C")="5c.^Other Pacific Islander^0"
S BUDRACET("5Z")=" 5.^TOTAL ASIAN/PACIFIC ISLANDER^0^(SUM LINES 5A+5B+5C)"
S BUDRACET(6)=" 6.^Black/African American (including Blacks or African^0^Americans of Latino or Hispanic Descent)"
S BUDRACET(7)=" 7.^American Indian/Alaska Native (including American Indians or^0^Alaska Natives of Latino/Hispanic Descent)"
S BUDRACET(8)=" 8.^White (including Whites of Latino/Hispanic Descent)^0"
S BUDRACET(9)=" 9.^More than one race^0"
S BUDRACET(10)="10.^Unreported / Refused to report^0"
S BUDRACET(11)="11.^ TOTAL PATIENTS (SUM LINES 5-10 MUST = LINE 4)^0"
K BUDLANG
S BUDLANG(12)="12.^PATIENT BEST SERVED IN A LANGUAGE OTHER THAN ENGLISH^0"
;TABLE 6
F X=1:1:26 S $P(BUDT6("V"),U,X)=0,$P(BUDT6("P"),U,X)=0
;NOW LOOP THROUGH PATIENT FILE
S DFN=0 F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN D
.;;I DUZ=5634,'$D(^DIBT(4370,1,DFN)) Q
.K ^TMP($J)
.Q:'$D(^AUPNPAT(DFN,0))
.Q:'$D(^DPT(DFN,0))
.Q:$P(^DPT(DFN,0),U,19) ;merged away
.Q:$P(^DPT(DFN,0),U,1)["DEMO,PATIENT"
.Q:$P(^DPT(DFN,0),U,1)["PATIENT,CRS"
.S C=$$COMMRES^AUPNPAT(DFN,"E")
.;I C'="COWETA",C'="TULSA,URBAN" Q
.S BUDAGE=$$AGE^AUPNPAT(DFN,BUDCAD)
.S BUDSEX=$P(^DPT(DFN,0),U,2)
.S BUDCOM=$$COMMRES^AUPNPAT(DFN,"E") I BUDCOM="" S BUDCOM="UNKNOWN"
.D GETV^BUD7RPTD ;get visits that meet criteria
.I BUDT35V=0 Q ;user doesn't have any countable visits and is not considered a user
.I $G(BUDTZ) D TZ
.I $G(BUDT3A) D T3A
.I $G(BUDT3B) D T3B
.I $G(BUDT5) D T5
.I $G(BUDT6) D T6
.Q
Q
;
T4 ;
Q
T3A ;
S G=0,Y=0 F S Y=$O(^BUDETTA("AC",Y)) Q:'Y!(G) S X=$O(^BUDETTA("AC",Y,0)) D
.S L=$P(^BUDETTA(X,0),U,7),H=$P(^BUDETTA(X,0),U,8),P=$P(^BUDETTA(X,0),U,2)
.I BUDAGE<0 S P=1 S $P(BUDTOT(BUDSEX),U,P)=$P(BUDTOT(BUDSEX),U,P)+1,$P(BUDTOT("ALL"),U,P)=$P(BUDTOT("ALL"),U,P)+1 D T S G=1 Q
.I BUDAGE'<L,BUDAGE'>H S $P(BUDTOT(BUDSEX),U,P)=$P(BUDTOT(BUDSEX),U,P)+1,$P(BUDTOT("ALL"),U,P)=$P(BUDTOT("ALL"),U,P)+1 D T S G=1
.Q
I $G(BUDT3AL) S X=0 F S X=$O(^TMP($J,"VISITS35",X)) Q:X'=+X S ^XTMP("BUD7RPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX,BUDCOM,DFN,X)=""
Q
T ;
S $P(BUDTOT(BUDSEX),U,39)=$P(BUDTOT(BUDSEX),U,39)+1,$P(BUDTOT("ALL"),U,39)=$P(BUDTOT("ALL"),U,39)+1
I BUDAGE<20 S BUD019(BUDSEX)=BUD019(BUDSEX)+1,BUD019("ALL")=BUD019("ALL")+1
Q
TZ ;
S BUDR=$$ZIP(DFN)
I BUDR="" S BUDR="Unknown Residence"
S ^XTMP("BUD7RPT1",BUDJ,BUDH,"ZIP",BUDR)=$G(^XTMP("BUD7RPT1",BUDJ,BUDH,"ZIP",BUDR))+1
I $G(BUDTZL) S X=0 F S X=$O(^TMP($J,"VISITS35",X)) Q:X'=+X S ^XTMP("BUD7RPT1",BUDJ,BUDH,"Z",BUDR,BUDCOM,BUDSEX,$P(^DPT(DFN,0),U),DFN,X)=""
Q
T3B ;
S BUDR=$$HISP(DFN)
S $P(BUDHISP(BUDR),U,3)=$P(BUDHISP(BUDR),U,3)+1
S $P(BUDHISP(4),U,3)=$P(BUDHISP(4),U,3)+1
;
S BUDR=$P($$RACE(DFN),U,1)
S $P(BUDRACET(BUDR),U,3)=$P(BUDRACET(BUDR),U,3)+1
S $P(BUDRACET(11),U,3)=$P(BUDRACET(11),U,3)+1
I BUDR[5 S $P(BUDRACET("5Z"),U,3)=$P(BUDRACET("5Z"),U,3)+1
I $G(BUDT3BL),'$G(BUDT3AL) S X=0 F S X=$O(^TMP($J,"VISITS35",X)) Q:X'=+X S ^XTMP("BUD7RPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX,BUDCOM,DFN,X)=""
Q
T5 ;tally prim provider by discipline and by user
S BUDV=0 F S BUDV=$O(^TMP($J,"VISITS35",BUDV)) Q:BUDV'=+BUDV D
.S BUDP=$$PRIMPROV^APCLV(BUDV,"D")
.I BUDP="" Q
.;special case for DX of MH
.;special case for provider code 15 and location CHS*
.I $E($$VAL^XBDIQ1(9000010,BUDV,.06),1,3)="CHS",BUDP=15 S BUDT5LN=2 D T5SET Q
.S BUDY=$O(^BUDETFIV("C",BUDP,0)) I BUDY="" S BUDT5LN=35 D T5SET Q
.;next lines for Bh stuff based on dx
.S T=$O(^BUDECNTL("B","BH DISCIPLINES FOR 20 AND 21",0))
.I $D(^BUDECNTL(T,11,"B",BUDP)) D D T5SET Q
..S P=$$PRIMPOV^APCLV(BUDV,"C")
..I $E(P,1,3)=303!($E(P,1,3)="304")!($E(P,1,3)="305") S BUDT5LN="21" Q
..S BUDT5LN=$P(^BUDECNTL(T,11,$O(^BUDECNTL(T,11,"B",BUDP,0)),0),U,2) Q
.S BUDT5LN=$P(^BUDETFIV(BUDY,0),U)
.D T5SET
.Q
Q
T5SET ;
I BUDT5LN>0,BUDT5LN<8 D T5PHY
I +BUDT5LN>8,+BUDT5LN<11 D T5MID
I +BUDT5LN>10,BUDT5LN<15 D T5NUR
I BUDT5LN>15,BUDT5LN<19 D T5DENT
I +BUDT5LN=20 D T520
I BUDT5LN=21 D T521
I BUDT5LN=22 D T522
I BUDT5LN=23 D T523
I BUDT5LN>23,BUDT5LN<29 D T5ENA
I BUDT5LN="29A" D T529A
I +BUDT5LN>29,BUDT5LN<33 D T5ADM
I BUDT5LN=35 D T5OTH
I $G(BUDT5L)!($G(BUDT5L2)) S ^XTMP("BUD7RPT1",BUDJ,BUDH,"T5",+BUDT5LN,$S(+BUDT5LN=BUDT5LN:0,1:$E(BUDT5LN,$L(BUDT5LN))),BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$$PRIMPROV^APCLV(BUDV,"N")_"^"_$$PRIMPROV^APCLV(BUDV,"P")
I $G(BUDT5L1) S ^XTMP("BUD7RPT1",BUDJ,BUDH,"T51",+BUDT5LN,$S(+BUDT5LN=BUDT5LN:0,1:$E(BUDT5LN,$L(BUDT5LN))),$$PRIMPROV^APCLV(BUDV,"N"))=$$PRIMPROV^APCLV(BUDV,"D")_" "_$$PRIMPROV^APCLV(BUDV,"E")
Q
T5PHY ;set physcian enc total, set med serv enc and user totals
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total encounters for this line
S $P(BUDTAB5(8),U)=$P(BUDTAB5(8),U)+1 ;total phy encs line
S $P(BUDTAB5(15),U)=$P(BUDTAB5(15),U)+1 ;total med services line
I $G(BUDT5L3) D
.I $D(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))) D I 1
..S ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))=^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))_U_BUDV
.E S ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))=BUDV
I $D(^TMP($J,"PATIENTS","MED SERV",DFN)) Q
S ^TMP($J,"PATIENTS","MED SERV",DFN)="",$P(BUDTAB5(15),U,2)=$P(BUDTAB5(15),U,2)+1
Q
T5MID ;set MID LEVEL enc total, set med serv enc and user totals
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total encounters for this line
S $P(BUDTAB5("10A"),U)=$P(BUDTAB5("10A"),U)+1 ;total MID encs line
S $P(BUDTAB5(15),U)=$P(BUDTAB5(15),U)+1 ;total med services line
I $D(^TMP($J,"PATIENTS","MED SERV",DFN)) Q
S ^TMP($J,"PATIENTS","MED SERV",DFN)="",$P(BUDTAB5(15),U,2)=$P(BUDTAB5(15),U,2)+1
Q
T5NUR ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total encounters for this line
I BUDT5LN=12 Q
I BUDT5LN=13 Q
I BUDT5LN=14 Q
S $P(BUDTAB5(15),U)=$P(BUDTAB5(15),U)+1 ;total med services line
I $D(^TMP($J,"PATIENTS","MED SERV",DFN)) Q
S ^TMP($J,"PATIENTS","MED SERV",DFN)="",$P(BUDTAB5(15),U,2)=$P(BUDTAB5(15),U,2)+1
Q
T5DENT ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total encounters for this line
I BUDT5LN=18 Q
S $P(BUDTAB5(19),U)=$P(BUDTAB5(19),U)+1 ;total dental services line
I $G(BUDT5L3) D I 1
.I $D(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))) D
..S ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))=^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))_U_BUDV
.E S ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))=BUDV
I $D(^TMP($J,"PATIENTS","DENT SERV",DFN)) Q
S ^TMP($J,"PATIENTS","DENT SERV",DFN)="",$P(BUDTAB5(19),U,2)=$P(BUDTAB5(19),U,2)+1
Q
T520 ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total encounters for this line
S $P(BUDTAB5(20),U)=$P(BUDTAB5(20),U)+1
I $G(BUDT5L3) D I 1
.I $D(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))) D
..S ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))=^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))_U_BUDV
.E S ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))=BUDV
I $D(^TMP($J,"PATIENTS","20 SERV",DFN)) Q
S ^TMP($J,"PATIENTS","20 SERV",DFN)="",$P(BUDTAB5(20),U,2)=$P(BUDTAB5(20),U,2)+1
Q
T521 ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total encounters for this line
I $G(BUDT5L3) D I 1
.I $D(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))) D
..S ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))=^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))_U_BUDV
.E S ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))=BUDV
I $D(^TMP($J,"PATIENTS","21 SERV",DFN)) Q
S ^TMP($J,"PATIENTS","21 SERV",DFN)="",$P(BUDTAB5(21),U,2)=$P(BUDTAB5(21),U,2)+1
Q
T522 ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total encounters for this line
I $G(BUDT5L3) D I 1
.I $D(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))) D
..S ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))=^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))_U_BUDV
.E S ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))=BUDV
I $D(^TMP($J,"PATIENTS","22 SERV",DFN)) Q
S ^TMP($J,"PATIENTS","22 SERV",DFN)="",$P(BUDTAB5(22),U,2)=$P(BUDTAB5(22),U,2)+1
Q
T523 ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total encounters for this line
Q
T5ENA ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total encounters for this line
I BUDT5LN=23 Q
I BUDT5LN=26 Q
I BUDT5LN=27 Q
I BUDT5LN=28 Q
S $P(BUDTAB5(29),U)=$P(BUDTAB5(29),U)+1 ;total enabling services line
I $G(BUDT5L3) D I 1
.I $D(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDP,$$VD^APCLV(BUDV))) D
..S ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDP,$$VD^APCLV(BUDV))=^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDP,$$VD^APCLV(BUDV))_U_BUDV
.E S ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDP,$$VD^APCLV(BUDV))=BUDV
I $D(^TMP($J,"PATIENTS","ENA SERV",DFN)) Q
S ^TMP($J,"PATIENTS","ENA SERV",DFN)="",$P(BUDTAB5(29),U,2)=$P(BUDTAB5(29),U,2)+1
Q
T529A ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total encounters for this line
Q
T5ADM ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total encounters for this line
S $P(BUDTAB5(33),U)=$P(BUDTAB5(33),U)+1 ;total adm services line
I $D(^TMP($J,"PATIENTS","ADM SERV",DFN)) Q
S ^TMP($J,"PATIENTS","ADM SERV",DFN)="",$P(BUDTAB5(33),U,2)=$P(BUDTAB5(33),U,2)+1
Q
T5OTH ;
S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1
Q
;
T6 ;
D T6^BUD7RPC1
Q
;
HISP(DFN) ;EP
I $G(DFN)="" Q ""
I $$BEN^AUPNPAT(DFN,"C")="01" Q 2 ;LINE 2
NEW X S X=$P(^DPT(DFN,0),U,6)
I X="" Q 2
S X=$P(^DIC(10,X,0),U,2)
I X=1 Q 1
I X=2 Q 1
Q 2
;
RACE(DFN) ;EP
I $G(DFN)="" Q ""
I $$BEN^AUPNPAT(DFN,"C")="01" Q "7^AI/AN"
NEW X S X=$P(^DPT(DFN,0),U,6)
I X="" Q "10^UNREP/REF"
I X S X=$P($G(^DIC(10,X,0)),U,2)
I X="" Q "10^UNREP/REF"
I X="A" Q "5A^ASIAN"
I X="H" Q "5B^NATIVE HAWAIIAN"
I X=5 Q "5C^OTH PAC ISLANDER"
I X=4!(X="B") Q "6^BLACK"
I X=3!(X="Z") Q "7^AI/AN"
I X=6!(X="W") Q "8^WHITE"
I X=1 Q "8^HISPANIC,WHITE"
I X="D" Q "10^UNREP/REF"
I X="7" Q "10^UNREP/REF"
I X="U" Q "10^UNREP/REF"
I X=2 Q "6^HISPANIC,BLACK"
Q "10^UNREP/REF"
;
ZIP(DFN) ;
I $G(DFN)="" Q ""
Q $E($P($G(^DPT(DFN,.11)),U,6),1,5)
;
BUD7RPTC ; IHS/CMI/LAB - UDS REPORT PROCESSOR 03 Feb 2009 1:05 PM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
+3 ;
PROC ;EP - called from xbdbque
+1 SET BUDJ=$JOB
SET BUDH=$HOROLOG
+2 KILL ^TMP($JOB)
+3 SET ^XTMP("BUD7RPT1",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"UDS REPORT"
+4 ;TABLE 3A
+5 ;for table 3A
KILL BUDTOT
FOR X=1:1:39
SET $PIECE(BUDTOT("M"),U,X)=0
SET $PIECE(BUDTOT("F"),U,X)=0
SET $PIECE(BUDTOT("ALL"),U,X)=0
+6 SET BUD019("M")=""
SET BUD019("F")=""
SET BUD019("ALL")=""
+7 ;TABLE 5
+8 FOR X=1:1:6
SET BUDTAB5(X)="0^0"
+9 FOR X=7:1:38
SET BUDTAB5(X)="0^0"
+10 FOR X="9A","9B","20A","20B","20C","29A","10A","27a"
SET BUDTAB5(X)="0^0"
+11 ;TABLE 3B
+12 KILL BUDHISP
+13 SET BUDHISP(1)=" 1.^Hispanic or Latino^0"
+14 SET BUDHISP(2)=" 2.^All others (including Unreported)^0"
+15 SET BUDHISP(3)=" 3.^<not used>^"
+16 SET BUDHISP(4)=" 4.^TOTAL PATIENTS (SUM LINES 1-2)^0^MUST = LINE 11"
+17 KILL BUDRACET
+18 SET BUDRACET("5A")="5a.^Asian^0"
+19 SET BUDRACET("5B")="5b.^Native Hawaiian^0"
+20 SET BUDRACET("5C")="5c.^Other Pacific Islander^0"
+21 SET BUDRACET("5Z")=" 5.^TOTAL ASIAN/PACIFIC ISLANDER^0^(SUM LINES 5A+5B+5C)"
+22 SET BUDRACET(6)=" 6.^Black/African American (including Blacks or African^0^Americans of Latino or Hispanic Descent)"
+23 SET BUDRACET(7)=" 7.^American Indian/Alaska Native (including American Indians or^0^Alaska Natives of Latino/Hispanic Descent)"
+24 SET BUDRACET(8)=" 8.^White (including Whites of Latino/Hispanic Descent)^0"
+25 SET BUDRACET(9)=" 9.^More than one race^0"
+26 SET BUDRACET(10)="10.^Unreported / Refused to report^0"
+27 SET BUDRACET(11)="11.^ TOTAL PATIENTS (SUM LINES 5-10 MUST = LINE 4)^0"
+28 KILL BUDLANG
+29 SET BUDLANG(12)="12.^PATIENT BEST SERVED IN A LANGUAGE OTHER THAN ENGLISH^0"
+30 ;TABLE 6
+31 FOR X=1:1:26
SET $PIECE(BUDT6("V"),U,X)=0
SET $PIECE(BUDT6("P"),U,X)=0
+32 ;NOW LOOP THROUGH PATIENT FILE
+33 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:1
+34 ;;I DUZ=5634,'$D(^DIBT(4370,1,DFN)) Q
+35 KILL ^TMP($JOB)
+36 IF '$DATA(^AUPNPAT(DFN,0))
QUIT
+37 IF '$DATA(^DPT(DFN,0))
QUIT
+38 ;merged away
IF $PIECE(^DPT(DFN,0),U,19)
QUIT
+39 IF $PIECE(^DPT(DFN,0),U,1)["DEMO,PATIENT"
QUIT
+40 IF $PIECE(^DPT(DFN,0),U,1)["PATIENT,CRS"
QUIT
+41 SET C=$$COMMRES^AUPNPAT(DFN,"E")
+42 ;I C'="COWETA",C'="TULSA,URBAN" Q
+43 SET BUDAGE=$$AGE^AUPNPAT(DFN,BUDCAD)
+44 SET BUDSEX=$PIECE(^DPT(DFN,0),U,2)
+45 SET BUDCOM=$$COMMRES^AUPNPAT(DFN,"E")
IF BUDCOM=""
SET BUDCOM="UNKNOWN"
+46 ;get visits that meet criteria
DO GETV^BUD7RPTD
+47 ;user doesn't have any countable visits and is not considered a user
IF BUDT35V=0
QUIT
+48 IF $GET(BUDTZ)
DO TZ
+49 IF $GET(BUDT3A)
DO T3A
+50 IF $GET(BUDT3B)
DO T3B
+51 IF $GET(BUDT5)
DO T5
+52 IF $GET(BUDT6)
DO T6
+53 QUIT
End DoDot:1
+54 QUIT
+55 ;
T4 ;
+1 QUIT
T3A ;
+1 SET G=0
SET Y=0
FOR
SET Y=$ORDER(^BUDETTA("AC",Y))
IF 'Y!(G)
QUIT
SET X=$ORDER(^BUDETTA("AC",Y,0))
Begin DoDot:1
+2 SET L=$PIECE(^BUDETTA(X,0),U,7)
SET H=$PIECE(^BUDETTA(X,0),U,8)
SET P=$PIECE(^BUDETTA(X,0),U,2)
+3 IF BUDAGE<0
SET P=1
SET $PIECE(BUDTOT(BUDSEX),U,P)=$PIECE(BUDTOT(BUDSEX),U,P)+1
SET $PIECE(BUDTOT("ALL"),U,P)=$PIECE(BUDTOT("ALL"),U,P)+1
DO T
SET G=1
QUIT
+4 IF BUDAGE'<L
IF BUDAGE'>H
SET $PIECE(BUDTOT(BUDSEX),U,P)=$PIECE(BUDTOT(BUDSEX),U,P)+1
SET $PIECE(BUDTOT("ALL"),U,P)=$PIECE(BUDTOT("ALL"),U,P)+1
DO T
SET G=1
+5 QUIT
End DoDot:1
+6 IF $GET(BUDT3AL)
SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"VISITS35",X))
IF X'=+X
QUIT
SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX,BUDCOM,DFN,X)=""
+7 QUIT
T ;
+1 SET $PIECE(BUDTOT(BUDSEX),U,39)=$PIECE(BUDTOT(BUDSEX),U,39)+1
SET $PIECE(BUDTOT("ALL"),U,39)=$PIECE(BUDTOT("ALL"),U,39)+1
+2 IF BUDAGE<20
SET BUD019(BUDSEX)=BUD019(BUDSEX)+1
SET BUD019("ALL")=BUD019("ALL")+1
+3 QUIT
TZ ;
+1 SET BUDR=$$ZIP(DFN)
+2 IF BUDR=""
SET BUDR="Unknown Residence"
+3 SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"ZIP",BUDR)=$GET(^XTMP("BUD7RPT1",BUDJ,BUDH,"ZIP",BUDR))+1
+4 IF $GET(BUDTZL)
SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"VISITS35",X))
IF X'=+X
QUIT
SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"Z",BUDR,BUDCOM,BUDSEX,$PIECE(^DPT(DFN,0),U),DFN,X)=""
+5 QUIT
T3B ;
+1 SET BUDR=$$HISP(DFN)
+2 SET $PIECE(BUDHISP(BUDR),U,3)=$PIECE(BUDHISP(BUDR),U,3)+1
+3 SET $PIECE(BUDHISP(4),U,3)=$PIECE(BUDHISP(4),U,3)+1
+4 ;
+5 SET BUDR=$PIECE($$RACE(DFN),U,1)
+6 SET $PIECE(BUDRACET(BUDR),U,3)=$PIECE(BUDRACET(BUDR),U,3)+1
+7 SET $PIECE(BUDRACET(11),U,3)=$PIECE(BUDRACET(11),U,3)+1
+8 IF BUDR[5
SET $PIECE(BUDRACET("5Z"),U,3)=$PIECE(BUDRACET("5Z"),U,3)+1
+9 IF $GET(BUDT3BL)
IF '$GET(BUDT3AL)
SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"VISITS35",X))
IF X'=+X
QUIT
SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX,BUDCOM,DFN,X)=""
+10 QUIT
T5 ;tally prim provider by discipline and by user
+1 SET BUDV=0
FOR
SET BUDV=$ORDER(^TMP($JOB,"VISITS35",BUDV))
IF BUDV'=+BUDV
QUIT
Begin DoDot:1
+2 SET BUDP=$$PRIMPROV^APCLV(BUDV,"D")
+3 IF BUDP=""
QUIT
+4 ;special case for DX of MH
+5 ;special case for provider code 15 and location CHS*
+6 IF $EXTRACT($$VAL^XBDIQ1(9000010,BUDV,.06),1,3)="CHS"
IF BUDP=15
SET BUDT5LN=2
DO T5SET
QUIT
+7 SET BUDY=$ORDER(^BUDETFIV("C",BUDP,0))
IF BUDY=""
SET BUDT5LN=35
DO T5SET
QUIT
+8 ;next lines for Bh stuff based on dx
+9 SET T=$ORDER(^BUDECNTL("B","BH DISCIPLINES FOR 20 AND 21",0))
+10 IF $DATA(^BUDECNTL(T,11,"B",BUDP))
Begin DoDot:2
+11 SET P=$$PRIMPOV^APCLV(BUDV,"C")
+12 IF $EXTRACT(P,1,3)=303!($EXTRACT(P,1,3)="304")!($EXTRACT(P,1,3)="305")
SET BUDT5LN="21"
QUIT
+13 SET BUDT5LN=$PIECE(^BUDECNTL(T,11,$ORDER(^BUDECNTL(T,11,"B",BUDP,0)),0),U,2)
QUIT
End DoDot:2
DO T5SET
QUIT
+14 SET BUDT5LN=$PIECE(^BUDETFIV(BUDY,0),U)
+15 DO T5SET
+16 QUIT
End DoDot:1
+17 QUIT
T5SET ;
+1 IF BUDT5LN>0
IF BUDT5LN<8
DO T5PHY
+2 IF +BUDT5LN>8
IF +BUDT5LN<11
DO T5MID
+3 IF +BUDT5LN>10
IF BUDT5LN<15
DO T5NUR
+4 IF BUDT5LN>15
IF BUDT5LN<19
DO T5DENT
+5 IF +BUDT5LN=20
DO T520
+6 IF BUDT5LN=21
DO T521
+7 IF BUDT5LN=22
DO T522
+8 IF BUDT5LN=23
DO T523
+9 IF BUDT5LN>23
IF BUDT5LN<29
DO T5ENA
+10 IF BUDT5LN="29A"
DO T529A
+11 IF +BUDT5LN>29
IF BUDT5LN<33
DO T5ADM
+12 IF BUDT5LN=35
DO T5OTH
+13 IF $GET(BUDT5L)!($GET(BUDT5L2))
SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"T5",+BUDT5LN,$SELECT(+BUDT5LN=BUDT5LN:0,1:$EXTRACT(BUDT5LN,$LENGTH(BUDT5LN))),BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$$PRIMPROV^APCLV(BUDV,"N")_"^"_$$PRIMPROV^APCLV(BUDV,"P")
+14 IF $GET(BUDT5L1)
SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"T51",+BUDT5LN,$SELECT(+BUDT5LN=BUDT5LN:0,1:$EXTRACT(BUDT5LN,$LENGTH(BUDT5LN))),$$PRIMPROV^APCLV(BUDV,"N"))=$$PRIMPROV^APCLV(BUDV,"D")_" "_$$PRIMPROV^APCLV(BUDV,"E")
+15 QUIT
T5PHY ;set physcian enc total, set med serv enc and user totals
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 ;total phy encs line
SET $PIECE(BUDTAB5(8),U)=$PIECE(BUDTAB5(8),U)+1
+3 ;total med services line
SET $PIECE(BUDTAB5(15),U)=$PIECE(BUDTAB5(15),U)+1
+4 IF $GET(BUDT5L3)
Begin DoDot:1
+5 IF $DATA(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV)))
Begin DoDot:2
+6 SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))=^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))_U_BUDV
End DoDot:2
IF 1
+7 IF '$TEST
SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))=BUDV
End DoDot:1
+8 IF $DATA(^TMP($JOB,"PATIENTS","MED SERV",DFN))
QUIT
+9 SET ^TMP($JOB,"PATIENTS","MED SERV",DFN)=""
SET $PIECE(BUDTAB5(15),U,2)=$PIECE(BUDTAB5(15),U,2)+1
+10 QUIT
T5MID ;set MID LEVEL enc total, set med serv enc and user totals
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 ;total MID encs line
SET $PIECE(BUDTAB5("10A"),U)=$PIECE(BUDTAB5("10A"),U)+1
+3 ;total med services line
SET $PIECE(BUDTAB5(15),U)=$PIECE(BUDTAB5(15),U)+1
+4 IF $DATA(^TMP($JOB,"PATIENTS","MED SERV",DFN))
QUIT
+5 SET ^TMP($JOB,"PATIENTS","MED SERV",DFN)=""
SET $PIECE(BUDTAB5(15),U,2)=$PIECE(BUDTAB5(15),U,2)+1
+6 QUIT
T5NUR ;
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 IF BUDT5LN=12
QUIT
+3 IF BUDT5LN=13
QUIT
+4 IF BUDT5LN=14
QUIT
+5 ;total med services line
SET $PIECE(BUDTAB5(15),U)=$PIECE(BUDTAB5(15),U)+1
+6 IF $DATA(^TMP($JOB,"PATIENTS","MED SERV",DFN))
QUIT
+7 SET ^TMP($JOB,"PATIENTS","MED SERV",DFN)=""
SET $PIECE(BUDTAB5(15),U,2)=$PIECE(BUDTAB5(15),U,2)+1
+8 QUIT
T5DENT ;
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 IF BUDT5LN=18
QUIT
+3 ;total dental services line
SET $PIECE(BUDTAB5(19),U)=$PIECE(BUDTAB5(19),U)+1
+4 IF $GET(BUDT5L3)
Begin DoDot:1
+5 IF $DATA(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV)))
Begin DoDot:2
+6 SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))=^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))_U_BUDV
End DoDot:2
+7 IF '$TEST
SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))=BUDV
End DoDot:1
IF 1
+8 IF $DATA(^TMP($JOB,"PATIENTS","DENT SERV",DFN))
QUIT
+9 SET ^TMP($JOB,"PATIENTS","DENT SERV",DFN)=""
SET $PIECE(BUDTAB5(19),U,2)=$PIECE(BUDTAB5(19),U,2)+1
+10 QUIT
T520 ;
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 SET $PIECE(BUDTAB5(20),U)=$PIECE(BUDTAB5(20),U)+1
+3 IF $GET(BUDT5L3)
Begin DoDot:1
+4 IF $DATA(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV)))
Begin DoDot:2
+5 SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))=^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))_U_BUDV
End DoDot:2
+6 IF '$TEST
SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))=BUDV
End DoDot:1
IF 1
+7 IF $DATA(^TMP($JOB,"PATIENTS","20 SERV",DFN))
QUIT
+8 SET ^TMP($JOB,"PATIENTS","20 SERV",DFN)=""
SET $PIECE(BUDTAB5(20),U,2)=$PIECE(BUDTAB5(20),U,2)+1
+9 QUIT
T521 ;
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 IF $GET(BUDT5L3)
Begin DoDot:1
+3 IF $DATA(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV)))
Begin DoDot:2
+4 SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))=^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))_U_BUDV
End DoDot:2
+5 IF '$TEST
SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))=BUDV
End DoDot:1
IF 1
+6 IF $DATA(^TMP($JOB,"PATIENTS","21 SERV",DFN))
QUIT
+7 SET ^TMP($JOB,"PATIENTS","21 SERV",DFN)=""
SET $PIECE(BUDTAB5(21),U,2)=$PIECE(BUDTAB5(21),U,2)+1
+8 QUIT
T522 ;
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 IF $GET(BUDT5L3)
Begin DoDot:1
+3 IF $DATA(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV)))
Begin DoDot:2
+4 SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))=^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))_U_BUDV
End DoDot:2
+5 IF '$TEST
SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))=BUDV
End DoDot:1
IF 1
+6 IF $DATA(^TMP($JOB,"PATIENTS","22 SERV",DFN))
QUIT
+7 SET ^TMP($JOB,"PATIENTS","22 SERV",DFN)=""
SET $PIECE(BUDTAB5(22),U,2)=$PIECE(BUDTAB5(22),U,2)+1
+8 QUIT
T523 ;
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 QUIT
T5ENA ;
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 IF BUDT5LN=23
QUIT
+3 IF BUDT5LN=26
QUIT
+4 IF BUDT5LN=27
QUIT
+5 IF BUDT5LN=28
QUIT
+6 ;total enabling services line
SET $PIECE(BUDTAB5(29),U)=$PIECE(BUDTAB5(29),U)+1
+7 IF $GET(BUDT5L3)
Begin DoDot:1
+8 IF $DATA(^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDP,$$VD^APCLV(BUDV)))
Begin DoDot:2
+9 SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDP,$$VD^APCLV(BUDV))=^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDP,$$VD^APCLV(BUDV))_U_BUDV
End DoDot:2
+10 IF '$TEST
SET ^XTMP("BUD7RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDP,$$VD^APCLV(BUDV))=BUDV
End DoDot:1
IF 1
+11 IF $DATA(^TMP($JOB,"PATIENTS","ENA SERV",DFN))
QUIT
+12 SET ^TMP($JOB,"PATIENTS","ENA SERV",DFN)=""
SET $PIECE(BUDTAB5(29),U,2)=$PIECE(BUDTAB5(29),U,2)+1
+13 QUIT
T529A ;
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 QUIT
T5ADM ;
+1 ;total encounters for this line
SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 ;total adm services line
SET $PIECE(BUDTAB5(33),U)=$PIECE(BUDTAB5(33),U)+1
+3 IF $DATA(^TMP($JOB,"PATIENTS","ADM SERV",DFN))
QUIT
+4 SET ^TMP($JOB,"PATIENTS","ADM SERV",DFN)=""
SET $PIECE(BUDTAB5(33),U,2)=$PIECE(BUDTAB5(33),U,2)+1
+5 QUIT
T5OTH ;
+1 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
+2 QUIT
+3 ;
T6 ;
+1 DO T6^BUD7RPC1
+2 QUIT
+3 ;
HISP(DFN) ;EP
+1 IF $GET(DFN)=""
QUIT ""
+2 ;LINE 2
IF $$BEN^AUPNPAT(DFN,"C")="01"
QUIT 2
+3 NEW X
SET X=$PIECE(^DPT(DFN,0),U,6)
+4 IF X=""
QUIT 2
+5 SET X=$PIECE(^DIC(10,X,0),U,2)
+6 IF X=1
QUIT 1
+7 IF X=2
QUIT 1
+8 QUIT 2
+9 ;
RACE(DFN) ;EP
+1 IF $GET(DFN)=""
QUIT ""
+2 IF $$BEN^AUPNPAT(DFN,"C")="01"
QUIT "7^AI/AN"
+3 NEW X
SET X=$PIECE(^DPT(DFN,0),U,6)
+4 IF X=""
QUIT "10^UNREP/REF"
+5 IF X
SET X=$PIECE($GET(^DIC(10,X,0)),U,2)
+6 IF X=""
QUIT "10^UNREP/REF"
+7 IF X="A"
QUIT "5A^ASIAN"
+8 IF X="H"
QUIT "5B^NATIVE HAWAIIAN"
+9 IF X=5
QUIT "5C^OTH PAC ISLANDER"
+10 IF X=4!(X="B")
QUIT "6^BLACK"
+11 IF X=3!(X="Z")
QUIT "7^AI/AN"
+12 IF X=6!(X="W")
QUIT "8^WHITE"
+13 IF X=1
QUIT "8^HISPANIC,WHITE"
+14 IF X="D"
QUIT "10^UNREP/REF"
+15 IF X="7"
QUIT "10^UNREP/REF"
+16 IF X="U"
QUIT "10^UNREP/REF"
+17 IF X=2
QUIT "6^HISPANIC,BLACK"
+18 QUIT "10^UNREP/REF"
+19 ;
ZIP(DFN) ;
+1 IF $GET(DFN)=""
QUIT ""
+2 QUIT $EXTRACT($PIECE($GET(^DPT(DFN,.11)),U,6),1,5)
+3 ;
