- BUD1RPTC ; IHS/CMI/LAB - UDS REPORT PROCESSOR 03 Feb 2011 1:15 PM ; 23 Jan 2012 10:19 AM
- ;;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("BUD1RPT1",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"UDS REPORT"
- S ^XTMP("BUD1RP6B",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^UDS TABLE 6B LISTS"
- S ^XTMP("BUD1RP7",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^BUD TABLE 7 LISTS"
- S ^XTMP("BUD1RP9DEL",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^BUD TABLE 9 DELIMINTED FILE"
- ;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 ;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","20A1","20A2","20B","20C","22A","22B","22C","22D","29A","10A","27a","27b","30A","30B","30C" S BUDTAB5(X)="0^0"
- ;TABLE 3B
- K BUDRACET
- ;S BUDRACET(LINE)=LINE NUMBER^LABEL^HISP/LATINO^NOT HISPANIC^UNREP^TOTAL^LINE LABEL 2^LINE LABEL 3"
- S BUDRACET(1)="1.^Asian^0^0^0^0"
- S BUDRACET("2A")="2a.^Native Hawaiian^0^0^0^0"
- S BUDRACET("2B")="2b.^Other Pacific^0^0^0^0^Islander"
- S BUDRACET(2)="2.^Total Hawaiian/^0^0^0^0^Pacific Islander^(Sum Lines 2a+2b)"
- S BUDRACET(3)="3.^Black/African^0^0^0^0^American"
- S BUDRACET(4)="4.^American Indian/^0^0^0^0^Alaska Native"
- S BUDRACET(5)="5.^White^0^0^0^0"
- S BUDRACET(6)="6.^More than one^0^0^0^0^race"
- S BUDRACET(7)="7.^Unreported/^0^0^0^0^Refused to Report"
- S BUDRACET(8)="8.^Total Patients^0^0^0^0^(Sum Lines 1+2^+ 3 to 7)"
- K BUDLANG
- S BUDLANG(9)="9.^Patients Best Served in a Language Other Than^0^English"
- ;TABLE 6
- F X=1:1:26 S $P(BUDT6("V"),U,X)=0,$P(BUDT6("P"),U,X)=0
- ;TABLE 4
- K BUDT4V
- F X=1:1:6 S BUDT4V(X)=0
- F X=7,"8a","8b",8,9,"10a","10b",10,11,12 S BUDT4V(X)="0^0"
- F X=14:1:25 S BUDT4V(X)=0
- ;TABLE 9 DELIMITED
- S BUDT9C=0
- ;TABLE 9D
- K BUDT9TC
- F X=1,"2a","2b",3,4,"5a","5b",6,7,"8a","8b",9,10,"11a","11b",12,13,14 S BUDT9(X)="0^0" ;COLUMN A & B
- ;NOW LOOP THROUGH PATIENT FILE
- S DFN=0 F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN D
- .K ^TMP($J)
- .;;I DUZ=5634 Q:DFN'=16126
- .;;I DUZ=5634 Q:$$HRN^AUPNPAT(DFN,DUZ(2))'=333360
- .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"
- .Q:$P(^DPT(DFN,0),U,1)["PATIENT,UDS"
- .Q:$$DEMO^BUD1DU(DFN,"E")
- .;DO NOT COUNT BASED ON CLASSIFICATION IN V6.0
- .I BUDBEN=1,$$BEN^AUPNPAT(DFN,"C")'="01" Q
- .I BUDBEN=2,$$BEN^AUPNPAT(DFN,"C")="01" 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^BUD1RPTD
- .I BUDT35V=0 Q
- .I $G(BUDTZ) D TZ
- .I $G(BUDT3A) D T3A
- .I $G(BUDT3B) D T3B
- .I $G(BUDT4) D T4^BUD1RPC2
- .I $G(BUDT5) D T5
- .I $G(BUDT6) D T6
- .I $G(BUDT6B) D T6B
- .I $G(BUDT7) D T7
- .I $G(BUDT9) D T9^BUD1RPC4
- .I $G(BUDT9D) D T9D^BUD1RPC3
- .Q
- Q
- T3A ;
- S G=0,Y=0 F S Y=$O(^BUDLTTA("AC",Y)) Q:'Y!(G) S X=$O(^BUDLTTA("AC",Y,0)) D
- .S L=$P(^BUDLTTA(X,0),U,7),H=$P(^BUDLTTA(X,0),U,8),P=$P(^BUDLTTA(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,"VISITS356A",X)) Q:X'=+X S ^XTMP("BUD1RPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX,BUDCOM,DFN,X)=""
- I $G(BUDSTMP) S ^XTMP("BUD1RPT1",BUDJ,BUDH,"3ATEMP",DFN)=""
- 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("BUD1RPT1",BUDJ,BUDH,"ZIP",BUDR)=$G(^XTMP("BUD1RPT1",BUDJ,BUDH,"ZIP",BUDR))+1
- I $G(BUDTZL) S X=0 F S X=$O(^TMP($J,"VISITS356A",X)) Q:X'=+X S ^XTMP("BUD1RPT1",BUDJ,BUDH,"Z",BUDR,BUDCOM,BUDSEX,$P(^DPT(DFN,0),U),DFN,X)=""
- Q
- T3B ;
- S BUDHISPN=$$HISP(DFN)
- S BUDHISP=$P($$HISP(DFN),U,1) ;column
- S BUDHISP1=BUDHISP+2 ;set piece
- ;
- S BUDR1=$$RACE(DFN)
- S BUDR=$P(BUDR1,U,1) ;LINE
- S $P(BUDRACET(BUDR),U,BUDHISP1)=$P(BUDRACET(BUDR),U,BUDHISP1)+1 ;HISPANIC COLUMN FOR RACE
- S $P(BUDRACET(BUDR),U,6)=$P(BUDRACET(BUDR),U,6)+1 ;TOTAL COLUMN FOR RACE
- I BUDR="2A"!(BUDR="2B") S $P(BUDRACET(2),U,BUDHISP1)=$P(BUDRACET(2),U,BUDHISP1)+1,$P(BUDRACET(2),U,6)=$P(BUDRACET(2),U,6)+1 ;total line 2
- S $P(BUDRACET(8),U,BUDHISP1)=$P(BUDRACET(8),U,BUDHISP1)+1,$P(BUDRACET(8),U,6)=$P(BUDRACET(8),U,6)+1
- I $P(BUDR1,U,5)=16 S $P(BUDR1,U,5)=8
- I $G(BUDT3BRL) S X=0 F S X=$O(^TMP($J,"VISITS356A",X)) Q:X'=+X S ^XTMP("BUD1RPT1",BUDJ,BUDH,"3BR",$P(BUDR1,U,5),$P(BUDHISPN,U,1),BUDAGE,BUDSEX,BUDCOM,DFN,X)=BUDR1_"|||"_BUDHISPN
- Q
- T5 ;tally prim provider
- S BUDV=0 F S BUDV=$O(^TMP($J,"VISITS356A",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(^BUDLTFIV("C",BUDP,0)) I BUDY="" S BUDT5LN=35 D T5SET Q
- .;next lines for Bh stuff based on dx
- .S T=$O(^BUDLCNTL("B","BH DISCIPLINES FOR 20 AND 21",0))
- .I $D(^BUDLCNTL(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(^BUDLCNTL(T,11,$O(^BUDLCNTL(T,11,"B",BUDP,0)),0),U,2) Q
- .S BUDT5LN=$P(^BUDLTFIV(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 $L(BUDT5LN)=3,$E(BUDT5LN,1,2)=22 D T5VISION
- I BUDT5LN=22 D T522
- I BUDT5LN=23 D T523
- I BUDT5LN>23,BUDT5LN<29 D T5ENA
- I BUDT5LN="29A" D T529A
- I BUDT5LN["30" D T530A
- I +BUDT5LN>29,BUDT5LN<33 D T5ADM
- I BUDT5LN=35 D T5OTH
- I $G(BUDT5L)!($G(BUDT5L2)) D
- .Q:BUDT5LN=12
- .Q:BUDT5LN=13
- .Q:BUDT5LN=14
- .Q:BUDT5LN=18
- .Q:BUDT5LN="22C"
- .Q:BUDT5LN=23
- .Q:BUDT5LN=26
- .Q:BUDT5LN="30A"
- .Q:BUDT5LN=32
- .Q:BUDT5LN=27
- .Q:BUDT5LN="27a"
- .Q:BUDT5LN="27b"
- .Q:BUDT5LN=28
- .Q:BUDT5LN="29A"
- .Q:BUDT5LN="30B"
- .Q:BUDT5LN="30C"
- .Q:BUDT5LN=31
- .S ^XTMP("BUD1RPT1",BUDJ,BUDH,"T5",+BUDT5LN,$S(BUDT5LN="20A1":"A1",BUDT5LN="20A2":"A2",+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("BUD1RPT1",BUDJ,BUDH,"T51",+BUDT5LN,$S(BUDT5LN="20A1":"A1",BUDT5LN="20A2":"A2",+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
- S $P(BUDTAB5(8),U)=$P(BUDTAB5(8),U)+1
- S $P(BUDTAB5(15),U)=$P(BUDTAB5(15),U)+1
- I $G(BUDT5L3) D
- .I $D(^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))) D I 1
- ..S ^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))=^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))_U_BUDV
- .E S ^XTMP("BUD1RPT1",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 ;
- S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total visits 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
- I BUDT5LN=12 Q
- I BUDT5LN=13 Q
- I BUDT5LN=14 Q
- S $P(BUDTAB5(15),U)=$P(BUDTAB5(15),U)+1
- 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
- I BUDT5LN=18 Q
- S $P(BUDTAB5(19),U)=$P(BUDTAB5(19),U)+1
- I $G(BUDT5L3) D I 1
- .I $D(^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))) D
- ..S ^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))=^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))_U_BUDV
- .E S ^XTMP("BUD1RPT1",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
- S $P(BUDTAB5(20),U)=$P(BUDTAB5(20),U)+1
- I $G(BUDT5L3) D I 1
- .I $D(^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))) D
- ..S ^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))=^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))_U_BUDV
- .E S ^XTMP("BUD1RPT1",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
- I $G(BUDT5L3) D I 1
- .I $D(^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))) D
- ..S ^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))=^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))_U_BUDV
- .E S ^XTMP("BUD1RPT1",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
- I $G(BUDT5L3) D I 1
- .I $D(^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))) D
- ..S ^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))=^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))_U_BUDV
- .E S ^XTMP("BUD1RPT1",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
- Q
- T5VISION ;
- S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1
- I BUDT5LN="22C" Q
- S $P(BUDTAB5("22D"),U)=$P(BUDTAB5("22D"),U)+1 ;total vision line
- I $G(BUDT5L3) D I 1
- .I $D(^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"VISION SERV",BUDP,$$VD^APCLV(BUDV))) D
- ..S ^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"VISION SERV",BUDP,$$VD^APCLV(BUDV))=^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"VISION SERV",BUDP,$$VD^APCLV(BUDV))_U_BUDV
- .E S ^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"VISION SERV",BUDP,$$VD^APCLV(BUDV))=BUDV
- I $D(^TMP($J,"PATIENTS","22D SERV",DFN)) Q
- S ^TMP($J,"PATIENTS","22D SERV",DFN)="",$P(BUDTAB5("22D"),U,2)=$P(BUDTAB5("22D"),U,2)+1
- Q
- T5ENA ;
- S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1
- I BUDT5LN=23 Q
- I BUDT5LN=26 Q
- I $E(BUDT5LN,1,2)=27 Q
- I BUDT5LN=28 Q
- I BUDT5LN=24!(BUDT5LN=25) S $P(BUDTAB5(29),U)=$P(BUDTAB5(29),U)+1 ;total enabling services line
- I $G(BUDT5L3) D I 1
- .I $D(^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDT5LN,$$VD^APCLV(BUDV))) D
- ..S ^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDT5LN,$$VD^APCLV(BUDV))=^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDT5LN,$$VD^APCLV(BUDV))_U_BUDV
- .E S ^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDT5LN,$$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 visits for this line
- Q
- T530A ;
- Q ;all of line 3 grayed out
- S $P(BUDTAB5(30),U)=$P(BUDTAB5(30),U)+1 ;total line 30
- T5ADM ;
- Q ;all of 31, 32, 33 is grayed out
- S $P(BUDTAB5(BUDT5LN),U)=$P(BUDTAB5(BUDT5LN),U)+1 ;total visits for this line
- S $P(BUDTAB5(33),U)=$P(BUDTAB5(33),U)+1
- 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^BUD1RPC1
- Q
- ;
- HISP(DFN) ;EP
- NEW X,Y,Z,V
- I $G(DFN)="" Q ""
- S Y=$$ETHN(DFN)
- I Y="HISPANIC OR LATINO" Q 1_U_"E"_U_Y
- I Y="NOT HISPANIC OR LATINO" Q 2_U_"E"_U_Y
- NEW X S X=$P(^DPT(DFN,0),U,6)
- S Z=""
- I X S Z=$P(^DIC(10,X,0),U,2)
- I Z=1 Q 1_U_"R"_U_$$RABB(Z)
- I Z=2 Q 1_U_"R"_U_$$RABB(Z)
- I Z="D"!(Z="U")!(Z=7) D Q V
- .I Y]"" S V=3_U_"E"_U_Y Q
- .S V=3_U_"R"_U_$$RABB(Z)
- I Z]"" Q 2_"^R^"_$$RABB(Z)
- I Y]"" Q 3_U_"E"_U_Y
- I $$BEN^AUPNPAT(DFN,"C")="01",Y="" Q 2_U_"C"_U_"AI/AN"
- Q 3_"^E^BLANK RACE & ETHNICITY"
- ;
- ETHN(P) ;EP
- NEW Z,E
- S E=""
- S Z=0 F S Z=$O(^DPT(P,.06,Z)) Q:Z'=+Z!(E]"") D
- .S E=$P($G(^DPT(P,.06,Z,0)),U,1)
- .Q:E=""
- .S E=$P($G(^DIC(10.2,E,0)),U,1)
- .Q
- Q E
- RACE(DFN) ;EP
- NEW X,Y,Z
- I $G(DFN)="" Q ""
- NEW X S X=$P(^DPT(DFN,0),U,6)
- I X="" G CL
- I X S Z=$P(^DIC(10,X,0),U),X=$P($G(^DIC(10,X,0)),U,2)
- I X="" G CL
- I X="A" Q "1^ASIAN^R"_U_Z_U_1
- I X="H" Q "2A^NATIVE HAWAIIAN^R"_U_Z_U_2
- I X=5 Q "2B^OTH PAC ISLANDER^R"_U_Z_U_3
- I X=4!(X="B") Q "3^BLACK^R"_U_Z_U_4
- I X=3!(X="Z") Q "4^AI/AN^R"_U_Z_U_5
- I X=6!(X="W") Q "5^WHITE^R"_U_Z_U_6
- I X=1 Q "5^WHITE^R"_U_Z_U_6
- I X="D" Q "7^UNREP/REF^R"_U_Z_U_8
- I X="7" Q "7^UNREP/REF^R"_U_Z_U_8
- I X="U" Q "7^UNREP/REF^R"_U_Z_U_8
- I X=2 Q "3^BLACK^R"_U_Z_U_4
- CL I $$BEN^AUPNPAT(DFN,"C")="01" Q "4^AI/AN^C^AI/AN^5"
- Q "7^UNREP/REF^C^BLANK RACE^8"
- ;
- ZIP(DFN) ;
- I $G(DFN)="" Q ""
- Q $E($P($G(^DPT(DFN,.11)),U,6),1,5)
- ;
- RABB(X) ;
- I X="A" Q "ASIAN"
- I X="H" Q "NATIVE HAWAIIAN"
- I X=5 Q "OTH PAC ISLANDER"
- I X="B" Q "BLACK/AFRICAN"
- I X=4 Q "BLACK NOT HISP"
- I X=3!(X="Z") Q "AI/AN"
- I X="W" Q "WHITE"
- I X=6 Q "WHITE NOT HISP"
- I X=1 Q "HISPANIC, WHITE"
- I X="D" Q "DECLINED"
- I X="7" Q "UNKNOWN"
- I X="U" Q "UNKNOWN BY PT"
- I X=2 Q "HISPANIC, BLACK"
- Q "??"
- T6B ;
- D IMM^BUD1RP6C
- D PAPD^BUD1RP6D
- Q
- T7 ;
- S BUDAGEP=$$AGE^AUPNPAT(DFN,BUDCAD)
- D PRGHLST^BUD1RP7A
- D PRGRLST^BUD1RP7A
- D HTN^BUD1RP7B
- D DM^BUD1RP7C
- Q
- BUD1RPTC ; IHS/CMI/LAB - UDS REPORT PROCESSOR 03 Feb 2011 1:15 PM ; 23 Jan 2012 10:19 AM
- +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("BUD1RPT1",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"UDS REPORT"
- +4 SET ^XTMP("BUD1RP6B",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^UDS TABLE 6B LISTS"
- +5 SET ^XTMP("BUD1RP7",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^BUD TABLE 7 LISTS"
- +6 SET ^XTMP("BUD1RP9DEL",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^BUD TABLE 9 DELIMINTED FILE"
- +7 ;TABLE 3A
- +8 ;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
- +9 SET BUD019("M")=""
- SET BUD019("F")=""
- SET BUD019("ALL")=""
- +10 ;TABLE 5
- +11 FOR X=1:1:6
- SET BUDTAB5(X)="0^0"
- +12 FOR X=7:1:38
- SET BUDTAB5(X)="0^0"
- +13 FOR X="9A","9B","20A","20A1","20A2","20B","20C","22A","22B","22C","22D","29A","10A","27a","27b","30A","30B","30C"
- SET BUDTAB5(X)="0^0"
- +14 ;TABLE 3B
- +15 KILL BUDRACET
- +16 ;S BUDRACET(LINE)=LINE NUMBER^LABEL^HISP/LATINO^NOT HISPANIC^UNREP^TOTAL^LINE LABEL 2^LINE LABEL 3"
- +17 SET BUDRACET(1)="1.^Asian^0^0^0^0"
- +18 SET BUDRACET("2A")="2a.^Native Hawaiian^0^0^0^0"
- +19 SET BUDRACET("2B")="2b.^Other Pacific^0^0^0^0^Islander"
- +20 SET BUDRACET(2)="2.^Total Hawaiian/^0^0^0^0^Pacific Islander^(Sum Lines 2a+2b)"
- +21 SET BUDRACET(3)="3.^Black/African^0^0^0^0^American"
- +22 SET BUDRACET(4)="4.^American Indian/^0^0^0^0^Alaska Native"
- +23 SET BUDRACET(5)="5.^White^0^0^0^0"
- +24 SET BUDRACET(6)="6.^More than one^0^0^0^0^race"
- +25 SET BUDRACET(7)="7.^Unreported/^0^0^0^0^Refused to Report"
- +26 SET BUDRACET(8)="8.^Total Patients^0^0^0^0^(Sum Lines 1+2^+ 3 to 7)"
- +27 KILL BUDLANG
- +28 SET BUDLANG(9)="9.^Patients Best Served in a Language Other Than^0^English"
- +29 ;TABLE 6
- +30 FOR X=1:1:26
- SET $PIECE(BUDT6("V"),U,X)=0
- SET $PIECE(BUDT6("P"),U,X)=0
- +31 ;TABLE 4
- +32 KILL BUDT4V
- +33 FOR X=1:1:6
- SET BUDT4V(X)=0
- +34 FOR X=7,"8a","8b",8,9,"10a","10b",10,11,12
- SET BUDT4V(X)="0^0"
- +35 FOR X=14:1:25
- SET BUDT4V(X)=0
- +36 ;TABLE 9 DELIMITED
- +37 SET BUDT9C=0
- +38 ;TABLE 9D
- +39 KILL BUDT9TC
- +40 ;COLUMN A & B
- FOR X=1,"2a","2b",3,4,"5a","5b",6,7,"8a","8b",9,10,"11a","11b",12,13,14
- SET BUDT9(X)="0^0"
- +41 ;NOW LOOP THROUGH PATIENT FILE
- +42 SET DFN=0
- FOR
- SET DFN=$ORDER(^AUPNPAT(DFN))
- IF DFN'=+DFN
- QUIT
- Begin DoDot:1
- +43 KILL ^TMP($JOB)
- +44 ;;I DUZ=5634 Q:DFN'=16126
- +45 ;;I DUZ=5634 Q:$$HRN^AUPNPAT(DFN,DUZ(2))'=333360
- +46 IF '$DATA(^AUPNPAT(DFN,0))
- QUIT
- +47 IF '$DATA(^DPT(DFN,0))
- QUIT
- +48 ;merged away
- IF $PIECE(^DPT(DFN,0),U,19)
- QUIT
- +49 IF $PIECE(^DPT(DFN,0),U,1)["DEMO,PATIENT"
- QUIT
- +50 IF $PIECE(^DPT(DFN,0),U,1)["PATIENT,CRS"
- QUIT
- +51 IF $PIECE(^DPT(DFN,0),U,1)["PATIENT,UDS"
- QUIT
- +52 IF $$DEMO^BUD1DU(DFN,"E")
- QUIT
- +53 ;DO NOT COUNT BASED ON CLASSIFICATION IN V6.0
- +54 IF BUDBEN=1
- IF $$BEN^AUPNPAT(DFN,"C")'="01"
- QUIT
- +55 IF BUDBEN=2
- IF $$BEN^AUPNPAT(DFN,"C")="01"
- QUIT
- +56 SET BUDAGE=$$AGE^AUPNPAT(DFN,BUDCAD)
- +57 SET BUDSEX=$PIECE(^DPT(DFN,0),U,2)
- +58 SET BUDCOM=$$COMMRES^AUPNPAT(DFN,"E")
- IF BUDCOM=""
- SET BUDCOM="UNKNOWN"
- +59 DO GETV^BUD1RPTD
- +60 IF BUDT35V=0
- QUIT
- +61 IF $GET(BUDTZ)
- DO TZ
- +62 IF $GET(BUDT3A)
- DO T3A
- +63 IF $GET(BUDT3B)
- DO T3B
- +64 IF $GET(BUDT4)
- DO T4^BUD1RPC2
- +65 IF $GET(BUDT5)
- DO T5
- +66 IF $GET(BUDT6)
- DO T6
- +67 IF $GET(BUDT6B)
- DO T6B
- +68 IF $GET(BUDT7)
- DO T7
- +69 IF $GET(BUDT9)
- DO T9^BUD1RPC4
- +70 IF $GET(BUDT9D)
- DO T9D^BUD1RPC3
- +71 QUIT
- End DoDot:1
- +72 QUIT
- T3A ;
- +1 SET G=0
- SET Y=0
- FOR
- SET Y=$ORDER(^BUDLTTA("AC",Y))
- IF 'Y!(G)
- QUIT
- SET X=$ORDER(^BUDLTTA("AC",Y,0))
- Begin DoDot:1
- +2 SET L=$PIECE(^BUDLTTA(X,0),U,7)
- SET H=$PIECE(^BUDLTTA(X,0),U,8)
- SET P=$PIECE(^BUDLTTA(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,"VISITS356A",X))
- IF X'=+X
- QUIT
- SET ^XTMP("BUD1RPT1",BUDJ,BUDH,"3A",BUDAGE,BUDSEX,BUDCOM,DFN,X)=""
- +7 IF $GET(BUDSTMP)
- SET ^XTMP("BUD1RPT1",BUDJ,BUDH,"3ATEMP",DFN)=""
- +8 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("BUD1RPT1",BUDJ,BUDH,"ZIP",BUDR)=$GET(^XTMP("BUD1RPT1",BUDJ,BUDH,"ZIP",BUDR))+1
- +4 IF $GET(BUDTZL)
- SET X=0
- FOR
- SET X=$ORDER(^TMP($JOB,"VISITS356A",X))
- IF X'=+X
- QUIT
- SET ^XTMP("BUD1RPT1",BUDJ,BUDH,"Z",BUDR,BUDCOM,BUDSEX,$PIECE(^DPT(DFN,0),U),DFN,X)=""
- +5 QUIT
- T3B ;
- +1 SET BUDHISPN=$$HISP(DFN)
- +2 ;column
- SET BUDHISP=$PIECE($$HISP(DFN),U,1)
- +3 ;set piece
- SET BUDHISP1=BUDHISP+2
- +4 ;
- +5 SET BUDR1=$$RACE(DFN)
- +6 ;LINE
- SET BUDR=$PIECE(BUDR1,U,1)
- +7 ;HISPANIC COLUMN FOR RACE
- SET $PIECE(BUDRACET(BUDR),U,BUDHISP1)=$PIECE(BUDRACET(BUDR),U,BUDHISP1)+1
- +8 ;TOTAL COLUMN FOR RACE
- SET $PIECE(BUDRACET(BUDR),U,6)=$PIECE(BUDRACET(BUDR),U,6)+1
- +9 ;total line 2
- IF BUDR="2A"!(BUDR="2B")
- SET $PIECE(BUDRACET(2),U,BUDHISP1)=$PIECE(BUDRACET(2),U,BUDHISP1)+1
- SET $PIECE(BUDRACET(2),U,6)=$PIECE(BUDRACET(2),U,6)+1
- +10 SET $PIECE(BUDRACET(8),U,BUDHISP1)=$PIECE(BUDRACET(8),U,BUDHISP1)+1
- SET $PIECE(BUDRACET(8),U,6)=$PIECE(BUDRACET(8),U,6)+1
- +11 IF $PIECE(BUDR1,U,5)=16
- SET $PIECE(BUDR1,U,5)=8
- +12 IF $GET(BUDT3BRL)
- SET X=0
- FOR
- SET X=$ORDER(^TMP($JOB,"VISITS356A",X))
- IF X'=+X
- QUIT
- SET ^XTMP("BUD1RPT1",BUDJ,BUDH,"3BR",$PIECE(BUDR1,U,5),$PIECE(BUDHISPN,U,1),BUDAGE,BUDSEX,BUDCOM,DFN,X)=BUDR1_"|||"_BUDHISPN
- +13 QUIT
- T5 ;tally prim provider
- +1 SET BUDV=0
- FOR
- SET BUDV=$ORDER(^TMP($JOB,"VISITS356A",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(^BUDLTFIV("C",BUDP,0))
- IF BUDY=""
- SET BUDT5LN=35
- DO T5SET
- QUIT
- +8 ;next lines for Bh stuff based on dx
- +9 SET T=$ORDER(^BUDLCNTL("B","BH DISCIPLINES FOR 20 AND 21",0))
- +10 IF $DATA(^BUDLCNTL(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(^BUDLCNTL(T,11,$ORDER(^BUDLCNTL(T,11,"B",BUDP,0)),0),U,2)
- QUIT
- End DoDot:2
- DO T5SET
- QUIT
- +14 SET BUDT5LN=$PIECE(^BUDLTFIV(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 $LENGTH(BUDT5LN)=3
- IF $EXTRACT(BUDT5LN,1,2)=22
- DO T5VISION
- +8 IF BUDT5LN=22
- DO T522
- +9 IF BUDT5LN=23
- DO T523
- +10 IF BUDT5LN>23
- IF BUDT5LN<29
- DO T5ENA
- +11 IF BUDT5LN="29A"
- DO T529A
- +12 IF BUDT5LN["30"
- DO T530A
- +13 IF +BUDT5LN>29
- IF BUDT5LN<33
- DO T5ADM
- +14 IF BUDT5LN=35
- DO T5OTH
- +15 IF $GET(BUDT5L)!($GET(BUDT5L2))
- Begin DoDot:1
- +16 IF BUDT5LN=12
- QUIT
- +17 IF BUDT5LN=13
- QUIT
- +18 IF BUDT5LN=14
- QUIT
- +19 IF BUDT5LN=18
- QUIT
- +20 IF BUDT5LN="22C"
- QUIT
- +21 IF BUDT5LN=23
- QUIT
- +22 IF BUDT5LN=26
- QUIT
- +23 IF BUDT5LN="30A"
- QUIT
- +24 IF BUDT5LN=32
- QUIT
- +25 IF BUDT5LN=27
- QUIT
- +26 IF BUDT5LN="27a"
- QUIT
- +27 IF BUDT5LN="27b"
- QUIT
- +28 IF BUDT5LN=28
- QUIT
- +29 IF BUDT5LN="29A"
- QUIT
- +30 IF BUDT5LN="30B"
- QUIT
- +31 IF BUDT5LN="30C"
- QUIT
- +32 IF BUDT5LN=31
- QUIT
- +33 SET ^XTMP("BUD1RPT1",BUDJ,BUDH,"T5",+BUDT5LN,$SELECT(BUDT5LN="20A1":"A1",BUDT5LN="20A2":"A2",+BUDT5LN=BUDT5LN:0,1:$EXTRACT(BUDT5LN,$LENGTH(BUDT5LN))),BUDCOM,BUDAGE,BUDSEX,DFN,BUDV)=$$PRIMPROV^APCLV(BUDV,"N")_"^"_$$PRIMPROV^APCLV(BUDV,"P
- ")
- End DoDot:1
- +34 IF $GET(BUDT5L1)
- SET ^XTMP("BUD1RPT1",BUDJ,BUDH,"T51",+BUDT5LN,$SELECT(BUDT5LN="20A1":"A1",BUDT5LN="20A2":"A2",+BUDT5LN=BUDT5LN:0,1:$EXTRACT(BUDT5LN,$LENGTH(BUDT5LN))),$$PRIMPROV^APCLV(BUDV,"N"))=$$PRIMPROV^APCLV(BUDV,"D")_" "_$$PRIMPROV^APCLV(BUDV,"E")
- +35 QUIT
- T5PHY ;set physcian enc total, set med serv enc and user totals
- +1 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
- +2 SET $PIECE(BUDTAB5(8),U)=$PIECE(BUDTAB5(8),U)+1
- +3 SET $PIECE(BUDTAB5(15),U)=$PIECE(BUDTAB5(15),U)+1
- +4 IF $GET(BUDT5L3)
- Begin DoDot:1
- +5 IF $DATA(^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV)))
- Begin DoDot:2
- +6 SET ^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))=^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MED SERV",$$VD^APCLV(BUDV))_U_BUDV
- End DoDot:2
- IF 1
- +7 IF '$TEST
- SET ^XTMP("BUD1RPT1",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 ;
- +1 ;total visits 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 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 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 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
- +2 IF BUDT5LN=18
- QUIT
- +3 SET $PIECE(BUDTAB5(19),U)=$PIECE(BUDTAB5(19),U)+1
- +4 IF $GET(BUDT5L3)
- Begin DoDot:1
- +5 IF $DATA(^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV)))
- Begin DoDot:2
- +6 SET ^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))=^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"DENT SERV",$$VD^APCLV(BUDV))_U_BUDV
- End DoDot:2
- +7 IF '$TEST
- SET ^XTMP("BUD1RPT1",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 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("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV)))
- Begin DoDot:2
- +5 SET ^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))=^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"MENT SERV",$$VD^APCLV(BUDV))_U_BUDV
- End DoDot:2
- +6 IF '$TEST
- SET ^XTMP("BUD1RPT1",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 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
- +2 IF $GET(BUDT5L3)
- Begin DoDot:1
- +3 IF $DATA(^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV)))
- Begin DoDot:2
- +4 SET ^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))=^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"SUB SERV",$$VD^APCLV(BUDV))_U_BUDV
- End DoDot:2
- +5 IF '$TEST
- SET ^XTMP("BUD1RPT1",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 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
- +2 IF $GET(BUDT5L3)
- Begin DoDot:1
- +3 IF $DATA(^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV)))
- Begin DoDot:2
- +4 SET ^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))=^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"OTH SERV",BUDP,$$VD^APCLV(BUDV))_U_BUDV
- End DoDot:2
- +5 IF '$TEST
- SET ^XTMP("BUD1RPT1",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 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
- +2 QUIT
- T5VISION ;
- +1 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
- +2 IF BUDT5LN="22C"
- QUIT
- +3 ;total vision line
- SET $PIECE(BUDTAB5("22D"),U)=$PIECE(BUDTAB5("22D"),U)+1
- +4 IF $GET(BUDT5L3)
- Begin DoDot:1
- +5 IF $DATA(^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"VISION SERV",BUDP,$$VD^APCLV(BUDV)))
- Begin DoDot:2
- +6 SET ^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"VISION SERV",BUDP,$$VD^APCLV(BUDV))=^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"VISION SERV",BUDP,$$VD^APCLV(BUDV))_U_BUDV
- End DoDot:2
- +7 IF '$TEST
- SET ^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"VISION SERV",BUDP,$$VD^APCLV(BUDV))=BUDV
- End DoDot:1
- IF 1
- +8 IF $DATA(^TMP($JOB,"PATIENTS","22D SERV",DFN))
- QUIT
- +9 SET ^TMP($JOB,"PATIENTS","22D SERV",DFN)=""
- SET $PIECE(BUDTAB5("22D"),U,2)=$PIECE(BUDTAB5("22D"),U,2)+1
- +10 QUIT
- T5ENA ;
- +1 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
- +2 IF BUDT5LN=23
- QUIT
- +3 IF BUDT5LN=26
- QUIT
- +4 IF $EXTRACT(BUDT5LN,1,2)=27
- QUIT
- +5 IF BUDT5LN=28
- QUIT
- +6 ;total enabling services line
- IF BUDT5LN=24!(BUDT5LN=25)
- SET $PIECE(BUDTAB5(29),U)=$PIECE(BUDTAB5(29),U)+1
- +7 IF $GET(BUDT5L3)
- Begin DoDot:1
- +8 IF $DATA(^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDT5LN,$$VD^APCLV(BUDV)))
- Begin DoDot:2
- +9 SET ^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDT5LN,$$VD^APCLV(BUDV))=^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDT5LN,$$VD^APCLV(BUDV))_U_BUDV
- End DoDot:2
- +10 IF '$TEST
- SET ^XTMP("BUD1RPT1",BUDJ,BUDH,"T53",BUDCOM,BUDAGE,BUDSEX,DFN,"ENA SERV",BUDT5LN,$$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 visits for this line
- SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
- +2 QUIT
- T530A ;
- +1 ;all of line 3 grayed out
- QUIT
- +2 ;total line 30
- SET $PIECE(BUDTAB5(30),U)=$PIECE(BUDTAB5(30),U)+1
- T5ADM ;
- +1 ;all of 31, 32, 33 is grayed out
- QUIT
- +2 ;total visits for this line
- SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
- +3 SET $PIECE(BUDTAB5(33),U)=$PIECE(BUDTAB5(33),U)+1
- +4 IF $DATA(^TMP($JOB,"PATIENTS","ADM SERV",DFN))
- QUIT
- +5 SET ^TMP($JOB,"PATIENTS","ADM SERV",DFN)=""
- SET $PIECE(BUDTAB5(33),U,2)=$PIECE(BUDTAB5(33),U,2)+1
- +6 QUIT
- T5OTH ;
- +1 SET $PIECE(BUDTAB5(BUDT5LN),U)=$PIECE(BUDTAB5(BUDT5LN),U)+1
- +2 QUIT
- +3 ;
- T6 ;
- +1 DO T6^BUD1RPC1
- +2 QUIT
- +3 ;
- HISP(DFN) ;EP
- +1 NEW X,Y,Z,V
- +2 IF $GET(DFN)=""
- QUIT ""
- +3 SET Y=$$ETHN(DFN)
- +4 IF Y="HISPANIC OR LATINO"
- QUIT 1_U_"E"_U_Y
- +5 IF Y="NOT HISPANIC OR LATINO"
- QUIT 2_U_"E"_U_Y
- +6 NEW X
- SET X=$PIECE(^DPT(DFN,0),U,6)
- +7 SET Z=""
- +8 IF X
- SET Z=$PIECE(^DIC(10,X,0),U,2)
- +9 IF Z=1
- QUIT 1_U_"R"_U_$$RABB(Z)
- +10 IF Z=2
- QUIT 1_U_"R"_U_$$RABB(Z)
- +11 IF Z="D"!(Z="U")!(Z=7)
- Begin DoDot:1
- +12 IF Y]""
- SET V=3_U_"E"_U_Y
- QUIT
- +13 SET V=3_U_"R"_U_$$RABB(Z)
- End DoDot:1
- QUIT V
- +14 IF Z]""
- QUIT 2_"^R^"_$$RABB(Z)
- +15 IF Y]""
- QUIT 3_U_"E"_U_Y
- +16 IF $$BEN^AUPNPAT(DFN,"C")="01"
- IF Y=""
- QUIT 2_U_"C"_U_"AI/AN"
- +17 QUIT 3_"^E^BLANK RACE & ETHNICITY"
- +18 ;
- ETHN(P) ;EP
- +1 NEW Z,E
- +2 SET E=""
- +3 SET Z=0
- FOR
- SET Z=$ORDER(^DPT(P,.06,Z))
- IF Z'=+Z!(E]"")
- QUIT
- Begin DoDot:1
- +4 SET E=$PIECE($GET(^DPT(P,.06,Z,0)),U,1)
- +5 IF E=""
- QUIT
- +6 SET E=$PIECE($GET(^DIC(10.2,E,0)),U,1)
- +7 QUIT
- End DoDot:1
- +8 QUIT E
- RACE(DFN) ;EP
- +1 NEW X,Y,Z
- +2 IF $GET(DFN)=""
- QUIT ""
- +3 NEW X
- SET X=$PIECE(^DPT(DFN,0),U,6)
- +4 IF X=""
- GOTO CL
- +5 IF X
- SET Z=$PIECE(^DIC(10,X,0),U)
- SET X=$PIECE($GET(^DIC(10,X,0)),U,2)
- +6 IF X=""
- GOTO CL
- +7 IF X="A"
- QUIT "1^ASIAN^R"_U_Z_U_1
- +8 IF X="H"
- QUIT "2A^NATIVE HAWAIIAN^R"_U_Z_U_2
- +9 IF X=5
- QUIT "2B^OTH PAC ISLANDER^R"_U_Z_U_3
- +10 IF X=4!(X="B")
- QUIT "3^BLACK^R"_U_Z_U_4
- +11 IF X=3!(X="Z")
- QUIT "4^AI/AN^R"_U_Z_U_5
- +12 IF X=6!(X="W")
QUIT "5^WHITE^R"_U_Z_U_6
+13 IF X=1
QUIT "5^WHITE^R"_U_Z_U_6
+14 IF X="D"
QUIT "7^UNREP/REF^R"_U_Z_U_8
+15 IF X="7"
QUIT "7^UNREP/REF^R"_U_Z_U_8
+16 IF X="U"
QUIT "7^UNREP/REF^R"_U_Z_U_8
+17 IF X=2
QUIT "3^BLACK^R"_U_Z_U_4
CL IF $$BEN^AUPNPAT(DFN,"C")="01"
QUIT "4^AI/AN^C^AI/AN^5"
+1 QUIT "7^UNREP/REF^C^BLANK RACE^8"
+2 ;
ZIP(DFN) ;
+1 IF $GET(DFN)=""
QUIT ""
+2 QUIT $EXTRACT($PIECE($GET(^DPT(DFN,.11)),U,6),1,5)
+3 ;
RABB(X) ;
+1 IF X="A"
QUIT "ASIAN"
+2 IF X="H"
QUIT "NATIVE HAWAIIAN"
+3 IF X=5
QUIT "OTH PAC ISLANDER"
+4 IF X="B"
QUIT "BLACK/AFRICAN"
+5 IF X=4
QUIT "BLACK NOT HISP"
+6 IF X=3!(X="Z")
QUIT "AI/AN"
+7 IF X="W"
QUIT "WHITE"
+8 IF X=6
QUIT "WHITE NOT HISP"
+9 IF X=1
QUIT "HISPANIC, WHITE"
+10 IF X="D"
QUIT "DECLINED"
+11 IF X="7"
QUIT "UNKNOWN"
+12 IF X="U"
QUIT "UNKNOWN BY PT"
+13 IF X=2
QUIT "HISPANIC, BLACK"
+14 QUIT "??"
T6B ;
+1 DO IMM^BUD1RP6C
+2 DO PAPD^BUD1RP6D
+3 QUIT
T7 ;
+1 SET BUDAGEP=$$AGE^AUPNPAT(DFN,BUDCAD)
+2 DO PRGHLST^BUD1RP7A
+3 DO PRGRLST^BUD1RP7A
+4 DO HTN^BUD1RP7B
+5 DO DM^BUD1RP7C
+6 QUIT