- BUDBRPC2 ; IHS/CMI/LAB - UDS TABLE 6 ;
- ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
- ;
- ;
- L27(BUDV) ;EP
- S V=0,G="" F S V=$O(^AUPNVDEN("AD",BUDV,V)) Q:V'=+V!(G]"") D
- .S A=$P($G(^AUPNVDEN(V,0)),U)
- .Q:'A
- .S A=$P($G(^AUTTADA(A,0)),U)
- .Q:A=""
- .I A=9110 S G=A
- .Q
- I G]"" Q G
- S G="" S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
- .S Z=$$VAL^XBDIQ1(9000010.18,X,.01)
- .I Z="D9110" S G=Z
- .Q
- Q G
- L26B(BUDV) ;EP
- S G="" S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
- .S Z=$$VAL^XBDIQ1(9000010.18,X,.01)
- .I Z=99408!(Z=99409) S G=Z
- .Q
- I G]"" Q G
- S X=0 F S X=$O(^AUPNVPED("AD",BUDV,X)) Q:X'=+X!(G]"") D
- .S Z=$P($G(^AUPNVPED(X,0)),U)
- .Q:Z=""
- .Q:'$D(^AUTTEDT(Z,0))
- .S Z=$P(^AUTTEDT(Z,0),U,2)
- .I Z="AOD-INJ" S G=Z
- Q G
- L26C(BUDV) ;EP
- ;I $$CLINIC^APCLV(BUDV,"C")=94 Q "CLINIC 94"
- S G="" S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
- .S Z=$$VAL^XBDIQ1(9000010.18,X,.01)
- .I Z=99406!(Z=99407)!(Z="S9075") S G=Z
- .Q
- I G]"" Q G
- S X=0 F S X=$O(^AUPNVPED("AD",BUDV,X)) Q:X'=+X!(G]"") D
- .S Z=$P($G(^AUPNVPED(X,0)),U)
- .Q:Z=""
- .Q:'$D(^AUTTEDT(Z,0))
- .S Z=$P(^AUTTEDT(Z,0),U,2)
- .I $P(Z,"-",1)="TO" S G=Z Q
- .I $P(Z,"-",2)="TO" S G=Z Q
- .I $P(Z,"-",2)="SHS" S G=Z Q
- I G]"" Q G
- S X=0 F S X=$O(^AUPNVPOV("AD",BUDV,X)) Q:X'=+X!(G]"") D
- .S Z=$$VAL^XBDIQ1(9000010.07,X,.01)
- .I Z="305.1" S G="305.1"
- Q G
- L28(BUDV) ;EP
- S V=0,G="" F S V=$O(^AUPNVDEN("AD",BUDV,V)) Q:V'=+V!(G]"") D
- .S A=$P($G(^AUPNVDEN(V,0)),U)
- .Q:'A
- .S A=$P($G(^AUTTADA(A,0)),U)
- .Q:A=""
- .I A="0150"!(A="0120")!(A="0140")!(A="0160")!(A="0170")!(A="0180")!(A="0145") S G=A
- .Q
- I G]"" Q G
- S G="" S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
- .S Z=$$VAL^XBDIQ1(9000010.18,X,.01)
- .I Z="D0150"!(Z="D0120")!(Z="D0140")!(Z="D0160")!(Z="D0170")!(Z="D0180")!(Z="D0145") S G=Z
- .Q
- Q G
- L29(BUDV) ;EP
- S V=0,G="" F S V=$O(^AUPNVDEN("AD",BUDV,V)) Q:V'=+V!(G]"") D
- .S A=$P($G(^AUPNVDEN(V,0)),U)
- .Q:'A
- .S A=$P($G(^AUTTADA(A,0)),U)
- .Q:A=""
- .I A=1110!(A=1120) S G=A
- .Q
- I G]"" Q G
- S G="" S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
- .S Z=$$VAL^XBDIQ1(9000010.18,X,.01)
- .I Z="D1110"!(Z="D1120") S G=Z
- .Q
- Q G
- L30(BUDV) ;EP
- S V=0,G="" F S V=$O(^AUPNVDEN("AD",BUDV,V)) Q:V'=+V!(G]"") D
- .S A=$P($G(^AUPNVDEN(V,0)),U)
- .Q:'A
- .S A=$P($G(^AUTTADA(A,0)),U)
- .Q:A=""
- .I A=1351 S G=A
- .Q
- I G]"" Q G
- S G="" S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
- .S Z=$$VAL^XBDIQ1(9000010.18,X,.01)
- .I Z="D1351" S G=Z
- .Q
- Q G
- L31(BUDV) ;EP
- S G=""
- ;I '$D(^AUPNVDEN("AD",BUDV)) G L31POV
- S V=0,G="" F S V=$O(^AUPNVDEN("AD",BUDV,V)) Q:V'=+V!(G]"") D
- .S A=$P($G(^AUPNVDEN(V,0)),U)
- .Q:'A
- .S A=$P($G(^AUTTADA(A,0)),U)
- .Q:A=""
- .I A=1206!(A=1208) S G=A
- .Q
- I G]"" Q G
- S G="" S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
- .S Z=$$VAL^XBDIQ1(9000010.18,X,.01)
- .I Z="D1206"!(Z="D1208") S G=Z
- .Q
- Q G
- L31POV ;EP
- S G=""
- S V=0 F S V=$O(^AUPNVPOV("AD",BUDV,V)) Q:V'=+V!(G]"") D
- .S A=$P($G(^AUPNVPOV(V,0)),U)
- .Q:'A
- .S A=$P($$ICDDX^ICDCODE(A),U,2)
- .I A="V07.31" S G=A
- .Q
- Q G
- L32(BUDV) ;EP
- S V=0,G="" F S V=$O(^AUPNVDEN("AD",BUDV,V)) Q:V'=+V!(G]"") D
- .S A=$P($G(^AUPNVDEN(V,0)),U)
- .Q:'A
- .S A=$P($G(^AUTTADA(A,0)),U)
- .Q:A=""
- .I $E(A,1,2)=21!($E(A,1,2)=22)!($E(A,1,2)=23)!($E(A,1,2)=24)!($E(A,1,2)=25)!($E(A,1,2)=26)!($E(A,1,2)=27)!($E(A,1,2)=28)!($E(A,1,2)=29) S G=A
- .Q
- I G]"" Q G
- S G="" S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
- .S Z=$$VAL^XBDIQ1(9000010.18,X,.01)
- .I $E(Z,1,3)="D21"!($E(Z,1,3)="D22")!($E(Z,1,3)="D23")!($E(Z,1,3)="D24")!($E(Z,1,3)="D25")!($E(Z,1,3)="D26")!($E(Z,1,3)="D27")!($E(Z,1,3)="D28")!($E(Z,1,3)="D29") S G=Z
- .Q
- Q G
- L33(BUDV) ;EP
- S V=0,G="" F S V=$O(^AUPNVDEN("AD",BUDV,V)) Q:V'=+V!(G]"") D
- .S A=$P($G(^AUPNVDEN(V,0)),U)
- .Q:'A
- .S A=$P($G(^AUTTADA(A,0)),U)
- .Q:A=""
- .I A=7111!(A=7140)!(A=7210)!(A=7220)!(A=7230)!(A=7240)!(A=7241)!(A=7250)!(A=7260)!(A=7261)!(A=7270)!(A=7272)!(A=7280) S G=A
- .Q
- I G]"" Q G
- S V=0,G="" F S V=$O(^AUPNVCPT("AD",BUDV,V)) Q:V'=+V!(G]"") D
- .S A=$$VAL^XBDIQ1(9000010.18,V,.01)
- .I A="D7111"!(A="D7140")!(A="D7210")!(A="D7220")!(A="D7230")!(A="D7240")!(A="D7241")!(A="D7250")!(A="D7260")!(A="D7261")!(A="D7270")!(A="D7272")!(A="D7280") S G=A
- .Q
- Q G
- L34(BUDV) ;EP
- S V=0,G="" F S V=$O(^AUPNVDEN("AD",BUDV,V)) Q:V'=+V!(G]"") D
- .S A=$P($G(^AUPNVDEN(V,0)),U)
- .Q:'A
- .S A=$P($G(^AUTTADA(A,0)),U)
- .Q:A=""
- .I $E(A)=3!($E(A)=4)!($E(A)=5)!($E(A)=6)!($E(A)=8) S G=A
- .Q
- I G]"" Q G
- S V=0,G="" F S V=$O(^AUPNVCPT("AD",BUDV,V)) Q:V'=+V!(G]"") D
- .S A=$$VAL^XBDIQ1(9000010.18,V,.01)
- .I $E(A,1,2)="D3"!($E(A,1,2)="D4")!($E(A,1,2)="D5")!($E(A,1,2)="D6")!($E(A,1,2)="D8") S G=A
- .Q
- Q G
- L26(BUDV) ;EP
- I $$AGE^AUPNPAT($P(^AUPNVSIT(BUDV,0),U,5),BUDCAD)>11 Q ""
- I $$CLINIC^APCLV(BUDV,"C")=24 Q "CLIN 24"
- I $$CLINIC^APCLV(BUDV,"C")=57 Q "CLIN 57"
- S G="" I T S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
- .S Z=$P(^AUPNVCPT(X,0),U),Z=$P($$CPT^ICPTCOD(Z),U,2)
- .I Z=99391!(Z=99392)!(Z=99393)!(Z=99381)!(Z=99382)!(Z=99383) S G=Z Q
- Q G
- L26A(BUDV) ;EP
- ;age 9-72 months
- S G=""
- S A=$$AGE^BUDBUTL2(DFN,2,$$VD^APCLV(BUDV))
- I A<9 Q G
- I A>72 Q G
- S G="" S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
- .S Z=$$VAL^XBDIQ1(9000010.18,X,.01)
- .I Z=83655 S G=Z
- .Q
- Q G
- L26D(BUDV) ;EP
- S G=""
- S G="" S X=0 F S X=$O(^AUPNVCPT("AD",BUDV,X)) Q:X'=+X!(G]"") D
- .S Z=$$VAL^XBDIQ1(9000010.18,X,.01)
- .I Z=92002!(Z=92004)!(Z=92012)!(Z=92014) S G=Z
- .Q
- Q G
- T4 ;EP
- D HI
- D INS
- D MIGRANT
- D HOMELESS
- D SCHOOL
- D VET
- Q
- SHI(V,LV) ;
- S BUDT4V(V)=BUDT4V(V)+1
- S BUDT4V(6)=BUDT4V(6)+1
- I $G(BUDT4IPP) D
- .S ^XTMP("BUDBRPT1",BUDJ,BUDH,"T4IPPL",$G(V),$G(LV),BUDCOM,BUDSEX,BUDAGE,DFN)=$G(LV)
- Q
- HI ;
- S (BUDNIH,BUDTHI,BUDTHIP)=""
- S BUDTHIP=$$VALI^XBDIQ1(9000001,DFN,8701)
- I BUDTHIP="" S BUDTHIP="Y"
- S BUDNIH=+$$VAL^XBDIQ1(9000001,DFN,.35)
- I 'BUDNIH D SHI(5,"Unknown") Q ;can't calculate, no number is household
- S BUDTHI=$$VAL^XBDIQ1(9000001,DFN,.36)
- I 'BUDTHI D SHI(5,"Unknown") Q
- I $E(BUDTHI)="0" D SHI(5,"Unknown") Q
- I BUDTHIP="M" S BUDTHI=BUDTHI*12
- I BUDTHIP="W" S BUDTHI=BUDTHI*52
- I BUDTHIP="B" S BUDTHI=BUDTHI*26
- S X=$O(^BUDBIL("B",BUDNIH,0))
- S P="",T=""
- S S=$$VAL^XBDIQ1(9999999.06,BUDSITE,.16)
- I S]"" D G N
- .I T="ALASKA" S P=3 Q
- .I T="HAWAII" S P=4 Q
- .S P=2
- S P=2
- ;
- N ;
- S Y=$P(^BUDBIL(X,0),U,P)
- S Z=BUDTHI/Y
- S Z=Z*100
- I Z>200 D SHI(4,"Over 200%") Q
- I Z>150.9999999 D SHI(3,"151-200%") Q
- I Z>100.9999999 D SHI(2,"101-150%") Q
- D SHI(1,"100% and below")
- Q
- INS ;EP
- S BUDHAS=0
- S BUDHAS=$$PI(DFN,$$VD^APCLV(BUDLASTV))
- I BUDHAS=1 D TINS(BUDAGE,11) Q
- S BUDHAS=$$MCR(DFN,$$VD^APCLV(BUDLASTV))
- I BUDHAS=1 D TINS(BUDAGE,9) Q
- ;S BUDHAS=$$OPI(DFN,$$VD^APCLV(BUDLASTV),"W")
- ;I BUDHAS=1 D TINS(BUDAGE,"10a") Q
- S BUDHAS=$$RR^AUPNPAT(DFN,$$VD^APCLV(BUDLASTV))
- I BUDHAS=1 D TINS(BUDAGE,"10a") Q
- S BUDHAS=$$OPI(DFN,$$VD^APCLV(BUDLASTV))
- I BUDHAS=1 D TINS(BUDAGE,"10a") Q
- S BUDHAS=$$OPIC(DFN,$$VD^APCLV(BUDLASTV),"K")
- I BUDHAS=1 D TINS(BUDAGE,"10b") Q
- S BUDHAS=$$MCD(DFN,$$VD^APCLV(BUDLASTV),"D")
- I BUDHAS=1 D TINS(BUDAGE,"8a") Q
- S BUDHAS=$$MCD(DFN,$$VD^APCLV(BUDLASTV),"K")
- I BUDHAS=1 D TINS(BUDAGE,"8b") Q
- ;now check workman's comp and 3rd party liability
- S BUDHAS=$$WC(DFN,BUDBD,BUDED)
- I BUDHAS=1 D TINS(BUDAGE,"11") Q
- S BUDHAS=$$TPL(DFN,BUDBD,BUDED)
- I BUDHAS=1 D TINS(BUDAGE,"10a") Q
- ;now check guarantor file
- ;S BUDHAS=$$GUAR(DFN,BUDBD,BUDED)
- ;I BUDHAS=1 D TINS(BUDAGE,"7") Q
- D TINS(BUDAGE,7)
- Q
- GUAR(P,BD,ED) ;guarantor
- NEW X,Y,Z,A
- S A=0,Y=0,A=0
- S X=0 F S X=$O(^AUPNGUAR(P,1,X)) Q:X'=+X D
- .S Y=0 F S Y=$O(^AUPNGUAR(P,1,X,11,Y)) Q:Y'=+Y D
- ..I $P(^AUPNGUAR(P,1,X,11,Y,0),U,1)]"",$P(^(0),U,1)>ED Q
- ..I $P(^AUPNGUAR(P,1,X,11,Y,0),U,2)]"",$P(^(0),U,2)<BD Q
- ..S A=1
- Q A
- ;
- WC(P,BD,ED) ;EP - workman's comp goes in line 11 per Duane
- NEW X,Y,Z,SD
- ;find an injury in date range
- I '$D(^AUPNWC(P,0)) Q ""
- S SD=$$FMADD^XLFDT(BD,-1)
- ;
- S Y=0 ;no wc
- F S SD=$O(^AUPNWC(P,11,"B",SD)) Q:SD'=+SD!(SD>ED) D
- .Q:SD>ED
- .Q:SD<BD
- .S X=0 F S X=$O(^AUPNWC(P,11,"B",SD,X)) Q:X'=+X D
- ..I $P(^AUPNWC(P,11,X,0),U,12)]"",$P(^AUPNWC(P,11,X,0),U,12)>ED Q
- ..I $P(^AUPNWC(P,11,X,0),U,13)]"",$P(^AUPNWC(P,11,X,0),U,13)<BD Q
- ..S Y=1
- Q Y
- ;
- TPL(P,BD,ED) ;EP - workman's comp goes in line 11 per Duane
- NEW X,Y,Z,SD
- ;find an injury in date range
- S SD=$$FMADD^XLFDT(BD,-1)
- S Y=0 ;no wc
- F S SD=$O(^AUPNTPL(P,1,"B",SD)) Q:SD'=+SD!(SD>ED) D
- .S X=0 F S X=$O(^AUPNTPL(P,1,"B",SD,X)) Q:X'=+X D
- ..I $P(^AUPNTPL(P,1,X,0),U,4)]"",$P(^AUPNTPL(P,1,X,0),U,4)>ED Q
- ..I $P(^AUPNTPL(P,1,X,0),U,5)]"",$P(^AUPNTPL(P,1,X,0),U,5)<BD Q
- ..S Y=1
- Q Y
- ;
- TINS(A,P) ;
- S $P(BUDT4V(P),U,$S(A<18:1,1:2))=$P(BUDT4V(P),U,$S(A<18:1,1:2))+1
- S $P(BUDT4V(12),U,$S(A<18:1,1:2))=$P(BUDT4V(12),U,$S(A<18:1,1:2))+1
- I P="8a"!(P="8b") S $P(BUDT4V(8),U,$S(A<18:1,1:2))=$P(BUDT4V(8),U,$S(A<18:1,1:2))+1
- I P="10a"!(P="10b") S $P(BUDT4V(10),U,$S(A<18:1,1:2))=$P(BUDT4V(10),U,$S(A<18:1,1:2))+1
- I $G(BUDT4PMI) D
- .I P=7 S T="None/Uninsured"
- .I P="8a" S T="Regular Medicaid (Title XIX)",P=8.1
- .I P="8b" S T="CHIP Medicaid",P=8.2
- .I P="9" S T="Medicare"
- .I P="10a" S T="Other Public Insurance Non-CHIP",P=10.1
- .I P="10b" S T="Other Public Insurance CHIP",P=10.2
- .I P="11" S T="Private Insurance"
- .S ^XTMP("BUDBRPT1",BUDJ,BUDH,"T4PMIS",$G(P),$G(T),BUDAGE,BUDCOM,BUDSEX,DFN)=""
- Q
- ;
- MCD(P,D,T) ;EP - Is patient P medicaid eligible on date D.
- ; I = IEN.
- ; J = Node 11 IEN in ^AUPNMCD.
- I '$G(P) Q 0
- I '$G(D) Q 0
- S T=$G(T)
- NEW I,J,Y,Z,N
- S Y=0,U="^"
- I '$D(^DPT(P,0)) G MCDX
- I $P(^DPT(P,0),U,19) G MCDX
- I '$D(^AUPNPAT(P,0)) G MCDX
- I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCDX
- S I=0 F S I=$O(^AUPNMCD("B",P,I)) Q:I'=+I D
- .Q:'$D(^AUPNMCD(I,11))
- .S Z=$P(^AUPNMCD(I,0),U,2)
- .;get plan name/INSURER TYPE OF PLAN NAME
- .S N=$$VALI^XBDIQ1(9000004,I,.11)
- .I N S N=$$VALI^XBDIQ1(9999999.18,N,.21)
- .I T="K" Q:N'="K"
- .I T="" Q:N="K"
- .S J=0 F S J=$O(^AUPNMCD(I,11,J)) Q:J'=+J D
- ..Q:J>D
- ..I $P(^AUPNMCD(I,11,J,0),U,2)]"",$P(^(0),U,2)<D Q
- ..S Y=1
- ..Q
- .Q
- ;
- MCDX ;
- Q Y
- PI(P,D) ;EP - Is patient P private insurance eligible on date D. 1= yes, 0=no.
- G PI^BUDBRPC3
- OPIC(P,D,T) ;EP - Is patient P private insurance eligible on date D. 1= yes, 0=no.
- G OPIC^BUDBRPC3
- ;
- OPI(P,D,T) ;EP - Is patient P private insurance eligible on date D. 1= yes, 0=no.
- G OPI^BUDBRPC3
- ;
- MCR(P,D) ;EP - Is patient P medicare eligible on date D. 1 = yes, 0 = no.
- ; I = IEN in ^AUPNMCR multiple.
- I '$G(P) Q 0
- I '$G(D) Q 0
- NEW I,Y
- S Y=0,U="^"
- I '$D(^DPT(P,0)) G MCRX
- I $P(^DPT(P,0),U,19) G MCRX
- I '$D(^AUPNPAT(P,0)) G MCRX
- I '$D(^AUPNMCR(P,11)) G MCRX
- I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCRX
- S I=0
- F S I=$O(^AUPNMCR(P,11,I)) Q:I'=+I D
- . Q:$P(^AUPNMCR(P,11,I,0),U)>D
- . I $P(^AUPNMCR(P,11,I,0),U,2)]"",$P(^(0),U,2)<D Q
- . S Y=1
- .Q
- MCRX ;
- I Y Q Y
- ;now check Private insurance for MD, MH, R, M
- I '$D(^AUPNPRVT(P,11)) G MCRPIX
- I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCRPIX
- S I=0,G=0
- F S I=$O(^AUPNPRVT(P,11,I)) Q:I'=+I D
- . Q:$P(^AUPNPRVT(P,11,I,0),U)=""
- . S X=$P(^AUPNPRVT(P,11,I,0),U) Q:X=""
- . I $P($G(^AUTNINS(X,2)),U,1)="MC" S G=1
- . I $P($G(^AUTNINS(X,2)),U,1)="MMC" S G=1
- . I $P($G(^AUTNINS(X,2)),U,1)="MD" S G=1
- . I $P($G(^AUTNINS(X,2)),U,1)="MH" S G=1
- . I $P($G(^AUTNINS(X,2)),U,1)="R" S G=1
- . I 'G Q
- . Q:$P(^AUPNPRVT(P,11,I,0),U,6)>D
- . I $P(^AUPNPRVT(P,11,I,0),U,7)]"",$P(^(0),U,7)<D Q
- . S Y=1
- .Q
- MCRPIX ;
- Q Y
- MIGRANT ;
- S M=$$MIG(DFN,$$VD^APCLV(BUDLASTV))
- Q:M=""
- I $P(M,U,1)="M" S BUDT4V(14)=BUDT4V(14)+1,BUDT4V(16)=BUDT4V(16)+1 D
- .Q:'$G(BUDT4CHA)
- .S T="Migratory" S ^XTMP("BUDBRPT1",BUDJ,BUDH,"T4CHAR",14,T,BUDCOM,BUDSEX,BUDAGE,DFN)=""
- I $P(M,U,1)="S" S BUDT4V(15)=BUDT4V(15)+1,BUDT4V(16)=BUDT4V(16)+1 D
- .Q:'$G(BUDT4CHA)
- .S T="Seasonal"
- .S ^XTMP("BUDBRPT1",BUDJ,BUDH,"T4CHAR",15,T,BUDCOM,BUDSEX,BUDAGE,DFN)=""
- Q
- HOMELESS ;
- S H=$$HOMEL(DFN,$$VD^APCLV(BUDLASTV))
- I H="" Q
- I $P(H,U,1)="H" S BUDT4V(17)=BUDT4V(17)+1,BUDT4V(23)=BUDT4V(23)+1,T="Homeless (Type: Homeless Shelter)",L=17
- I $P(H,U,1)="T" S BUDT4V(18)=BUDT4V(18)+1,BUDT4V(23)=BUDT4V(23)+1,T="Homeless (Type: Transitional)",L=18
- I $P(H,U,1)="D" S BUDT4V(19)=BUDT4V(19)+1,BUDT4V(23)=BUDT4V(23)+1,T="Homeless (Type: Doubling Up)",L=19
- I $P(H,U,1)="S" S BUDT4V(20)=BUDT4V(20)+1,BUDT4V(23)=BUDT4V(23)+1,T="Homeless (Type: Street)",L=20
- I $P(H,U,1)="O" S BUDT4V(21)=BUDT4V(21)+1,BUDT4V(23)=BUDT4V(23)+1,T="Homeless (Type: Other)",L=21
- I $P(H,U,1)="U" S BUDT4V(22)=BUDT4V(22)+1,BUDT4V(23)=BUDT4V(23)+1,T="Homeless (Type: Unknown)",L=22
- S ^XTMP("BUDBRPT1",BUDJ,BUDH,"T4CHAR",L,T,BUDCOM,BUDSEX,BUDAGE,DFN)=""
- Q
- VET ;
- S V=$$VALI^XBDIQ1(2,DFN,1901)
- I V="Y" S T="Veteran" S BUDT4V(25)=BUDT4V(25)+1,^XTMP("BUDBRPT1",BUDJ,BUDH,"T4CHAR",25,T,BUDCOM,BUDSEX,BUDAGE,DFN)=""
- Q
- SCHOOL ;IF ALL VISITS ARE CLINIC SCHOOL??
- ;if any visit from 356a is clinic school set to yes
- NEW X,V,Y,S
- S S=""
- S X=0 F S X=$O(^TMP($J,"VISITS356A",X)) Q:X'=+X I $$CLINIC^APCLV(X,"C")=22 S S=1
- Q:S=""
- S BUDT4V(24)=$G(BUDT4V(24))+1
- S ^XTMP("BUDBRPT1",BUDJ,BUDH,"T4CHAR",24,"School Based Patient",BUDCOM,BUDSEX,BUDAGE,DFN)=""
- Q
- MIG(P,D) ;EP
- ;GET LAST VALUE WITH A YES BEFORE END OF TIME PERIOD
- I '$O(^AUPNPAT(P,84,0)) Q ""
- NEW X,Y,Z,L
- S L=""
- S X=0 F S X=$O(^AUPNPAT(P,84,"B",X)) Q:X'=+X D
- .Q:X>D ;AFTER LAST VISIT
- .S Y=0 F S Y=$O(^AUPNPAT(P,84,"B",X,Y)) Q:Y'=+Y D
- ..I $P($G(^AUPNPAT(P,84,Y,0)),U,2)="" Q
- ..;I $P($G(^AUPNPAT(P,84,Y,0)),U,3)="" Q
- ..S L=Y
- I L="" Q ""
- I $P(^AUPNPAT(P,84,L,0),U,2)="N" Q ""
- Q $S($P(^AUPNPAT(P,84,L,0),U,3)]"":$P(^AUPNPAT(P,84,L,0),U,3),1:"")_"^"_$P(^AUPNPAT(P,84,L,0),U,1)
- HOMEL(P,D) ;EP
- ;GET LAST VALUE WITH A YES BEFORE END OF TIME PERIOD
- I '$O(^AUPNPAT(P,85,0)) Q ""
- NEW X,Y,Z,L
- S L=""
- S X=0 F S X=$O(^AUPNPAT(P,85,"B",X)) Q:X'=+X D
- .Q:X>D
- .S Y=0 F S Y=$O(^AUPNPAT(P,85,"B",X,Y)) Q:Y'=+Y D
- ..I $P($G(^AUPNPAT(P,85,Y,0)),U,2)="" Q
- ..S L=Y
- I L="" Q ""
- I $P(^AUPNPAT(P,85,L,0),U,2)="N" Q ""
- Q $S($P(^AUPNPAT(P,85,L,0),U,3)]"":$P(^AUPNPAT(P,85,L,0),U,3),1:"U")_"^"_$P(^AUPNPAT(P,85,L,0),U,1)
- BUDBRPC2 ; IHS/CMI/LAB - UDS TABLE 6 ;
- +1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
- +2 ;
- +3 ;
- L27(BUDV) ;EP
- +1 SET V=0
- SET G=""
- FOR
- SET V=$ORDER(^AUPNVDEN("AD",BUDV,V))
- IF V'=+V!(G]"")
- QUIT
- Begin DoDot:1
- +2 SET A=$PIECE($GET(^AUPNVDEN(V,0)),U)
- +3 IF 'A
- QUIT
- +4 SET A=$PIECE($GET(^AUTTADA(A,0)),U)
- +5 IF A=""
- QUIT
- +6 IF A=9110
- SET G=A
- +7 QUIT
- End DoDot:1
- +8 IF G]""
- QUIT G
- +9 SET G=""
- SET X=0
- FOR
- SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
- IF X'=+X!(G]"")
- QUIT
- Begin DoDot:1
- +10 SET Z=$$VAL^XBDIQ1(9000010.18,X,.01)
- +11 IF Z="D9110"
- SET G=Z
- +12 QUIT
- End DoDot:1
- +13 QUIT G
- L26B(BUDV) ;EP
- +1 SET G=""
- SET X=0
- FOR
- SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
- IF X'=+X!(G]"")
- QUIT
- Begin DoDot:1
- +2 SET Z=$$VAL^XBDIQ1(9000010.18,X,.01)
- +3 IF Z=99408!(Z=99409)
- SET G=Z
- +4 QUIT
- End DoDot:1
- +5 IF G]""
- QUIT G
- +6 SET X=0
- FOR
- SET X=$ORDER(^AUPNVPED("AD",BUDV,X))
- IF X'=+X!(G]"")
- QUIT
- Begin DoDot:1
- +7 SET Z=$PIECE($GET(^AUPNVPED(X,0)),U)
- +8 IF Z=""
- QUIT
- +9 IF '$DATA(^AUTTEDT(Z,0))
- QUIT
- +10 SET Z=$PIECE(^AUTTEDT(Z,0),U,2)
- +11 IF Z="AOD-INJ"
- SET G=Z
- End DoDot:1
- +12 QUIT G
- L26C(BUDV) ;EP
- +1 ;I $$CLINIC^APCLV(BUDV,"C")=94 Q "CLINIC 94"
- +2 SET G=""
- SET X=0
- FOR
- SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
- IF X'=+X!(G]"")
- QUIT
- Begin DoDot:1
- +3 SET Z=$$VAL^XBDIQ1(9000010.18,X,.01)
- +4 IF Z=99406!(Z=99407)!(Z="S9075")
- SET G=Z
- +5 QUIT
- End DoDot:1
- +6 IF G]""
- QUIT G
- +7 SET X=0
- FOR
- SET X=$ORDER(^AUPNVPED("AD",BUDV,X))
- IF X'=+X!(G]"")
- QUIT
- Begin DoDot:1
- +8 SET Z=$PIECE($GET(^AUPNVPED(X,0)),U)
- +9 IF Z=""
- QUIT
- +10 IF '$DATA(^AUTTEDT(Z,0))
- QUIT
- +11 SET Z=$PIECE(^AUTTEDT(Z,0),U,2)
- +12 IF $PIECE(Z,"-",1)="TO"
- SET G=Z
- QUIT
- +13 IF $PIECE(Z,"-",2)="TO"
- SET G=Z
- QUIT
- +14 IF $PIECE(Z,"-",2)="SHS"
- SET G=Z
- QUIT
- End DoDot:1
- +15 IF G]""
- QUIT G
- +16 SET X=0
- FOR
- SET X=$ORDER(^AUPNVPOV("AD",BUDV,X))
- IF X'=+X!(G]"")
- QUIT
- Begin DoDot:1
- +17 SET Z=$$VAL^XBDIQ1(9000010.07,X,.01)
- +18 IF Z="305.1"
- SET G="305.1"
- End DoDot:1
- +19 QUIT G
- L28(BUDV) ;EP
- +1 SET V=0
- SET G=""
- FOR
- SET V=$ORDER(^AUPNVDEN("AD",BUDV,V))
- IF V'=+V!(G]"")
- QUIT
- Begin DoDot:1
- +2 SET A=$PIECE($GET(^AUPNVDEN(V,0)),U)
- +3 IF 'A
- QUIT
- +4 SET A=$PIECE($GET(^AUTTADA(A,0)),U)
- +5 IF A=""
- QUIT
- +6 IF A="0150"!(A="0120")!(A="0140")!(A="0160")!(A="0170")!(A="0180")!(A="0145")
- SET G=A
- +7 QUIT
- End DoDot:1
- +8 IF G]""
- QUIT G
- +9 SET G=""
- SET X=0
- FOR
- SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
- IF X'=+X!(G]"")
- QUIT
- Begin DoDot:1
- +10 SET Z=$$VAL^XBDIQ1(9000010.18,X,.01)
- +11 IF Z="D0150"!(Z="D0120")!(Z="D0140")!(Z="D0160")!(Z="D0170")!(Z="D0180")!(Z="D0145")
- SET G=Z
- +12 QUIT
- End DoDot:1
- +13 QUIT G
- L29(BUDV) ;EP
- +1 SET V=0
- SET G=""
- FOR
- SET V=$ORDER(^AUPNVDEN("AD",BUDV,V))
- IF V'=+V!(G]"")
- QUIT
- Begin DoDot:1
- +2 SET A=$PIECE($GET(^AUPNVDEN(V,0)),U)
- +3 IF 'A
- QUIT
- +4 SET A=$PIECE($GET(^AUTTADA(A,0)),U)
- +5 IF A=""
- QUIT
- +6 IF A=1110!(A=1120)
- SET G=A
- +7 QUIT
- End DoDot:1
- +8 IF G]""
- QUIT G
- +9 SET G=""
- SET X=0
- FOR
- SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
- IF X'=+X!(G]"")
- QUIT
- Begin DoDot:1
- +10 SET Z=$$VAL^XBDIQ1(9000010.18,X,.01)
- +11 IF Z="D1110"!(Z="D1120")
- SET G=Z
- +12 QUIT
- End DoDot:1
- +13 QUIT G
- L30(BUDV) ;EP
- +1 SET V=0
- SET G=""
- FOR
- SET V=$ORDER(^AUPNVDEN("AD",BUDV,V))
- IF V'=+V!(G]"")
- QUIT
- Begin DoDot:1
- +2 SET A=$PIECE($GET(^AUPNVDEN(V,0)),U)
- +3 IF 'A
- QUIT
- +4 SET A=$PIECE($GET(^AUTTADA(A,0)),U)
- +5 IF A=""
- QUIT
- +6 IF A=1351
- SET G=A
- +7 QUIT
- End DoDot:1
- +8 IF G]""
- QUIT G
- +9 SET G=""
- SET X=0
- FOR
- SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
- IF X'=+X!(G]"")
- QUIT
- Begin DoDot:1
- +10 SET Z=$$VAL^XBDIQ1(9000010.18,X,.01)
- +11 IF Z="D1351"
- SET G=Z
- +12 QUIT
- End DoDot:1
- +13 QUIT G
- L31(BUDV) ;EP
- +1 SET G=""
- +2 ;I '$D(^AUPNVDEN("AD",BUDV)) G L31POV
- +3 SET V=0
- SET G=""
- FOR
- SET V=$ORDER(^AUPNVDEN("AD",BUDV,V))
- IF V'=+V!(G]"")
- QUIT
- Begin DoDot:1
- +4 SET A=$PIECE($GET(^AUPNVDEN(V,0)),U)
- +5 IF 'A
- QUIT
- +6 SET A=$PIECE($GET(^AUTTADA(A,0)),U)
- +7 IF A=""
- QUIT
- +8 IF A=1206!(A=1208)
- SET G=A
- +9 QUIT
- End DoDot:1
- +10 IF G]""
- QUIT G
- +11 SET G=""
- SET X=0
- FOR
- SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
- IF X'=+X!(G]"")
- QUIT
- Begin DoDot:1
- +12 SET Z=$$VAL^XBDIQ1(9000010.18,X,.01)
- +13 IF Z="D1206"!(Z="D1208")
- SET G=Z
- +14 QUIT
- End DoDot:1
- +15 QUIT G
- L31POV ;EP
- +1 SET G=""
- +2 SET V=0
- FOR
- SET V=$ORDER(^AUPNVPOV("AD",BUDV,V))
- IF V'=+V!(G]"")
- QUIT
- Begin DoDot:1
- +3 SET A=$PIECE($GET(^AUPNVPOV(V,0)),U)
- +4 IF 'A
- QUIT
- +5 SET A=$PIECE($$ICDDX^ICDCODE(A),U,2)
- +6 IF A="V07.31"
- SET G=A
- +7 QUIT
- End DoDot:1
- +8 QUIT G
- L32(BUDV) ;EP
- +1 SET V=0
- SET G=""
- FOR
- SET V=$ORDER(^AUPNVDEN("AD",BUDV,V))
- IF V'=+V!(G]"")
- QUIT
- Begin DoDot:1
- +2 SET A=$PIECE($GET(^AUPNVDEN(V,0)),U)
- +3 IF 'A
- QUIT
- +4 SET A=$PIECE($GET(^AUTTADA(A,0)),U)
- +5 IF A=""
- QUIT
- +6 IF $EXTRACT(A,1,2)=21!($EXTRACT(A,1,2)=22)!($EXTRACT(A,1,2)=23)!($EXTRACT(A,1,2)=24)!($EXTRACT(A,1,2)=25)!($EXTRACT(A,1,2)=26)!($EXTRACT(A,1,2)=27)!($EXTRACT(A,1,2)=28)!($EXTRACT(A,1,2)=29)
- SET G=A
- +7 QUIT
- End DoDot:1
- +8 IF G]""
- QUIT G
- +9 SET G=""
- SET X=0
- FOR
- SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
- IF X'=+X!(G]"")
- QUIT
- Begin DoDot:1
- +10 SET Z=$$VAL^XBDIQ1(9000010.18,X,.01)
- +11 IF $EXTRACT(Z,1,3)="D21"!($EXTRACT(Z,1,3)="D22")!($EXTRACT(Z,1,3)="D23")!($EXTRACT(Z,1,3)="D24")!($EXTRACT(Z,1,3)="D25")!($EXTRACT(Z,1,3)="D26")!($EXTRACT(Z,1,3)="D27")!($EXTRACT(Z,1,3)="D28")!($EXTRACT(Z,1,3)="D29")
- SET G=Z
- +12 QUIT
- End DoDot:1
- +13 QUIT G
- L33(BUDV) ;EP
- +1 SET V=0
- SET G=""
- FOR
- SET V=$ORDER(^AUPNVDEN("AD",BUDV,V))
- IF V'=+V!(G]"")
- QUIT
- Begin DoDot:1
- +2 SET A=$PIECE($GET(^AUPNVDEN(V,0)),U)
- +3 IF 'A
- QUIT
- +4 SET A=$PIECE($GET(^AUTTADA(A,0)),U)
- +5 IF A=""
- QUIT
- +6 IF A=7111!(A=7140)!(A=7210)!(A=7220)!(A=7230)!(A=7240)!(A=7241)!(A=7250)!(A=7260)!(A=7261)!(A=7270)!(A=7272)!(A=7280)
- SET G=A
- +7 QUIT
- End DoDot:1
- +8 IF G]""
- QUIT G
- +9 SET V=0
- SET G=""
- FOR
- SET V=$ORDER(^AUPNVCPT("AD",BUDV,V))
- IF V'=+V!(G]"")
- QUIT
- Begin DoDot:1
- +10 SET A=$$VAL^XBDIQ1(9000010.18,V,.01)
- +11 IF A="D7111"!(A="D7140")!(A="D7210")!(A="D7220")!(A="D7230")!(A="D7240")!(A="D7241")!(A="D7250")!(A="D7260")!(A="D7261")!(A="D7270")!(A="D7272")!(A="D7280")
- SET G=A
- +12 QUIT
- End DoDot:1
- +13 QUIT G
- L34(BUDV) ;EP
- +1 SET V=0
- SET G=""
- FOR
- SET V=$ORDER(^AUPNVDEN("AD",BUDV,V))
- IF V'=+V!(G]"")
- QUIT
- Begin DoDot:1
- +2 SET A=$PIECE($GET(^AUPNVDEN(V,0)),U)
- +3 IF 'A
- QUIT
- +4 SET A=$PIECE($GET(^AUTTADA(A,0)),U)
- +5 IF A=""
- QUIT
- +6 IF $EXTRACT(A)=3!($EXTRACT(A)=4)!($EXTRACT(A)=5)!($EXTRACT(A)=6)!($EXTRACT(A)=8)
- SET G=A
- +7 QUIT
- End DoDot:1
- +8 IF G]""
- QUIT G
- +9 SET V=0
- SET G=""
- FOR
- SET V=$ORDER(^AUPNVCPT("AD",BUDV,V))
- IF V'=+V!(G]"")
- QUIT
- Begin DoDot:1
- +10 SET A=$$VAL^XBDIQ1(9000010.18,V,.01)
- +11 IF $EXTRACT(A,1,2)="D3"!($EXTRACT(A,1,2)="D4")!($EXTRACT(A,1,2)="D5")!($EXTRACT(A,1,2)="D6")!($EXTRACT(A,1,2)="D8")
- SET G=A
- +12 QUIT
- End DoDot:1
- +13 QUIT G
- L26(BUDV) ;EP
- +1 IF $$AGE^AUPNPAT($PIECE(^AUPNVSIT(BUDV,0),U,5),BUDCAD)>11
- QUIT ""
- +2 IF $$CLINIC^APCLV(BUDV,"C")=24
- QUIT "CLIN 24"
- +3 IF $$CLINIC^APCLV(BUDV,"C")=57
- QUIT "CLIN 57"
- +4 SET G=""
- IF T
SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+5 SET Z=$PIECE(^AUPNVCPT(X,0),U)
SET Z=$PIECE($$CPT^ICPTCOD(Z),U,2)
+6 IF Z=99391!(Z=99392)!(Z=99393)!(Z=99381)!(Z=99382)!(Z=99383)
SET G=Z
QUIT
End DoDot:1
+7 QUIT G
L26A(BUDV) ;EP
+1 ;age 9-72 months
+2 SET G=""
+3 SET A=$$AGE^BUDBUTL2(DFN,2,$$VD^APCLV(BUDV))
+4 IF A<9
QUIT G
+5 IF A>72
QUIT G
+6 SET G=""
SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+7 SET Z=$$VAL^XBDIQ1(9000010.18,X,.01)
+8 IF Z=83655
SET G=Z
+9 QUIT
End DoDot:1
+10 QUIT G
L26D(BUDV) ;EP
+1 SET G=""
+2 SET G=""
SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",BUDV,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+3 SET Z=$$VAL^XBDIQ1(9000010.18,X,.01)
+4 IF Z=92002!(Z=92004)!(Z=92012)!(Z=92014)
SET G=Z
+5 QUIT
End DoDot:1
+6 QUIT G
T4 ;EP
+1 DO HI
+2 DO INS
+3 DO MIGRANT
+4 DO HOMELESS
+5 DO SCHOOL
+6 DO VET
+7 QUIT
SHI(V,LV) ;
+1 SET BUDT4V(V)=BUDT4V(V)+1
+2 SET BUDT4V(6)=BUDT4V(6)+1
+3 IF $GET(BUDT4IPP)
Begin DoDot:1
+4 SET ^XTMP("BUDBRPT1",BUDJ,BUDH,"T4IPPL",$GET(V),$GET(LV),BUDCOM,BUDSEX,BUDAGE,DFN)=$GET(LV)
End DoDot:1
+5 QUIT
HI ;
+1 SET (BUDNIH,BUDTHI,BUDTHIP)=""
+2 SET BUDTHIP=$$VALI^XBDIQ1(9000001,DFN,8701)
+3 IF BUDTHIP=""
SET BUDTHIP="Y"
+4 SET BUDNIH=+$$VAL^XBDIQ1(9000001,DFN,.35)
+5 ;can't calculate, no number is household
IF 'BUDNIH
DO SHI(5,"Unknown")
QUIT
+6 SET BUDTHI=$$VAL^XBDIQ1(9000001,DFN,.36)
+7 IF 'BUDTHI
DO SHI(5,"Unknown")
QUIT
+8 IF $EXTRACT(BUDTHI)="0"
DO SHI(5,"Unknown")
QUIT
+9 IF BUDTHIP="M"
SET BUDTHI=BUDTHI*12
+10 IF BUDTHIP="W"
SET BUDTHI=BUDTHI*52
+11 IF BUDTHIP="B"
SET BUDTHI=BUDTHI*26
+12 SET X=$ORDER(^BUDBIL("B",BUDNIH,0))
+13 SET P=""
SET T=""
+14 SET S=$$VAL^XBDIQ1(9999999.06,BUDSITE,.16)
+15 IF S]""
Begin DoDot:1
+16 IF T="ALASKA"
SET P=3
QUIT
+17 IF T="HAWAII"
SET P=4
QUIT
+18 SET P=2
End DoDot:1
GOTO N
+19 SET P=2
+20 ;
N ;
+1 SET Y=$PIECE(^BUDBIL(X,0),U,P)
+2 SET Z=BUDTHI/Y
+3 SET Z=Z*100
+4 IF Z>200
DO SHI(4,"Over 200%")
QUIT
+5 IF Z>150.9999999
DO SHI(3,"151-200%")
QUIT
+6 IF Z>100.9999999
DO SHI(2,"101-150%")
QUIT
+7 DO SHI(1,"100% and below")
+8 QUIT
INS ;EP
+1 SET BUDHAS=0
+2 SET BUDHAS=$$PI(DFN,$$VD^APCLV(BUDLASTV))
+3 IF BUDHAS=1
DO TINS(BUDAGE,11)
QUIT
+4 SET BUDHAS=$$MCR(DFN,$$VD^APCLV(BUDLASTV))
+5 IF BUDHAS=1
DO TINS(BUDAGE,9)
QUIT
+6 ;S BUDHAS=$$OPI(DFN,$$VD^APCLV(BUDLASTV),"W")
+7 ;I BUDHAS=1 D TINS(BUDAGE,"10a") Q
+8 SET BUDHAS=$$RR^AUPNPAT(DFN,$$VD^APCLV(BUDLASTV))
+9 IF BUDHAS=1
DO TINS(BUDAGE,"10a")
QUIT
+10 SET BUDHAS=$$OPI(DFN,$$VD^APCLV(BUDLASTV))
+11 IF BUDHAS=1
DO TINS(BUDAGE,"10a")
QUIT
+12 SET BUDHAS=$$OPIC(DFN,$$VD^APCLV(BUDLASTV),"K")
+13 IF BUDHAS=1
DO TINS(BUDAGE,"10b")
QUIT
+14 SET BUDHAS=$$MCD(DFN,$$VD^APCLV(BUDLASTV),"D")
+15 IF BUDHAS=1
DO TINS(BUDAGE,"8a")
QUIT
+16 SET BUDHAS=$$MCD(DFN,$$VD^APCLV(BUDLASTV),"K")
+17 IF BUDHAS=1
DO TINS(BUDAGE,"8b")
QUIT
+18 ;now check workman's comp and 3rd party liability
+19 SET BUDHAS=$$WC(DFN,BUDBD,BUDED)
+20 IF BUDHAS=1
DO TINS(BUDAGE,"11")
QUIT
+21 SET BUDHAS=$$TPL(DFN,BUDBD,BUDED)
+22 IF BUDHAS=1
DO TINS(BUDAGE,"10a")
QUIT
+23 ;now check guarantor file
+24 ;S BUDHAS=$$GUAR(DFN,BUDBD,BUDED)
+25 ;I BUDHAS=1 D TINS(BUDAGE,"7") Q
+26 DO TINS(BUDAGE,7)
+27 QUIT
GUAR(P,BD,ED) ;guarantor
+1 NEW X,Y,Z,A
+2 SET A=0
SET Y=0
SET A=0
+3 SET X=0
FOR
SET X=$ORDER(^AUPNGUAR(P,1,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 SET Y=0
FOR
SET Y=$ORDER(^AUPNGUAR(P,1,X,11,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+5 IF $PIECE(^AUPNGUAR(P,1,X,11,Y,0),U,1)]""
IF $PIECE(^(0),U,1)>ED
QUIT
+6 IF $PIECE(^AUPNGUAR(P,1,X,11,Y,0),U,2)]""
IF $PIECE(^(0),U,2)<BD
QUIT
+7 SET A=1
End DoDot:2
End DoDot:1
+8 QUIT A
+9 ;
WC(P,BD,ED) ;EP - workman's comp goes in line 11 per Duane
+1 NEW X,Y,Z,SD
+2 ;find an injury in date range
+3 IF '$DATA(^AUPNWC(P,0))
QUIT ""
+4 SET SD=$$FMADD^XLFDT(BD,-1)
+5 ;
+6 ;no wc
SET Y=0
+7 FOR
SET SD=$ORDER(^AUPNWC(P,11,"B",SD))
IF SD'=+SD!(SD>ED)
QUIT
Begin DoDot:1
+8 IF SD>ED
QUIT
+9 IF SD<BD
QUIT
+10 SET X=0
FOR
SET X=$ORDER(^AUPNWC(P,11,"B",SD,X))
IF X'=+X
QUIT
Begin DoDot:2
+11 IF $PIECE(^AUPNWC(P,11,X,0),U,12)]""
IF $PIECE(^AUPNWC(P,11,X,0),U,12)>ED
QUIT
+12 IF $PIECE(^AUPNWC(P,11,X,0),U,13)]""
IF $PIECE(^AUPNWC(P,11,X,0),U,13)<BD
QUIT
+13 SET Y=1
End DoDot:2
End DoDot:1
+14 QUIT Y
+15 ;
TPL(P,BD,ED) ;EP - workman's comp goes in line 11 per Duane
+1 NEW X,Y,Z,SD
+2 ;find an injury in date range
+3 SET SD=$$FMADD^XLFDT(BD,-1)
+4 ;no wc
SET Y=0
+5 FOR
SET SD=$ORDER(^AUPNTPL(P,1,"B",SD))
IF SD'=+SD!(SD>ED)
QUIT
Begin DoDot:1
+6 SET X=0
FOR
SET X=$ORDER(^AUPNTPL(P,1,"B",SD,X))
IF X'=+X
QUIT
Begin DoDot:2
+7 IF $PIECE(^AUPNTPL(P,1,X,0),U,4)]""
IF $PIECE(^AUPNTPL(P,1,X,0),U,4)>ED
QUIT
+8 IF $PIECE(^AUPNTPL(P,1,X,0),U,5)]""
IF $PIECE(^AUPNTPL(P,1,X,0),U,5)<BD
QUIT
+9 SET Y=1
End DoDot:2
End DoDot:1
+10 QUIT Y
+11 ;
TINS(A,P) ;
+1 SET $PIECE(BUDT4V(P),U,$SELECT(A<18:1,1:2))=$PIECE(BUDT4V(P),U,$SELECT(A<18:1,1:2))+1
+2 SET $PIECE(BUDT4V(12),U,$SELECT(A<18:1,1:2))=$PIECE(BUDT4V(12),U,$SELECT(A<18:1,1:2))+1
+3 IF P="8a"!(P="8b")
SET $PIECE(BUDT4V(8),U,$SELECT(A<18:1,1:2))=$PIECE(BUDT4V(8),U,$SELECT(A<18:1,1:2))+1
+4 IF P="10a"!(P="10b")
SET $PIECE(BUDT4V(10),U,$SELECT(A<18:1,1:2))=$PIECE(BUDT4V(10),U,$SELECT(A<18:1,1:2))+1
+5 IF $GET(BUDT4PMI)
Begin DoDot:1
+6 IF P=7
SET T="None/Uninsured"
+7 IF P="8a"
SET T="Regular Medicaid (Title XIX)"
SET P=8.1
+8 IF P="8b"
SET T="CHIP Medicaid"
SET P=8.2
+9 IF P="9"
SET T="Medicare"
+10 IF P="10a"
SET T="Other Public Insurance Non-CHIP"
SET P=10.1
+11 IF P="10b"
SET T="Other Public Insurance CHIP"
SET P=10.2
+12 IF P="11"
SET T="Private Insurance"
+13 SET ^XTMP("BUDBRPT1",BUDJ,BUDH,"T4PMIS",$GET(P),$GET(T),BUDAGE,BUDCOM,BUDSEX,DFN)=""
End DoDot:1
+14 QUIT
+15 ;
MCD(P,D,T) ;EP - Is patient P medicaid eligible on date D.
+1 ; I = IEN.
+2 ; J = Node 11 IEN in ^AUPNMCD.
+3 IF '$GET(P)
QUIT 0
+4 IF '$GET(D)
QUIT 0
+5 SET T=$GET(T)
+6 NEW I,J,Y,Z,N
+7 SET Y=0
SET U="^"
+8 IF '$DATA(^DPT(P,0))
GOTO MCDX
+9 IF $PIECE(^DPT(P,0),U,19)
GOTO MCDX
+10 IF '$DATA(^AUPNPAT(P,0))
GOTO MCDX
+11 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO MCDX
+12 SET I=0
FOR
SET I=$ORDER(^AUPNMCD("B",P,I))
IF I'=+I
QUIT
Begin DoDot:1
+13 IF '$DATA(^AUPNMCD(I,11))
QUIT
+14 SET Z=$PIECE(^AUPNMCD(I,0),U,2)
+15 ;get plan name/INSURER TYPE OF PLAN NAME
+16 SET N=$$VALI^XBDIQ1(9000004,I,.11)
+17 IF N
SET N=$$VALI^XBDIQ1(9999999.18,N,.21)
+18 IF T="K"
IF N'="K"
QUIT
+19 IF T=""
IF N="K"
QUIT
+20 SET J=0
FOR
SET J=$ORDER(^AUPNMCD(I,11,J))
IF J'=+J
QUIT
Begin DoDot:2
+21 IF J>D
QUIT
+22 IF $PIECE(^AUPNMCD(I,11,J,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+23 SET Y=1
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 ;
MCDX ;
+1 QUIT Y
PI(P,D) ;EP - Is patient P private insurance eligible on date D. 1= yes, 0=no.
+1 GOTO PI^BUDBRPC3
OPIC(P,D,T) ;EP - Is patient P private insurance eligible on date D. 1= yes, 0=no.
+1 GOTO OPIC^BUDBRPC3
+2 ;
OPI(P,D,T) ;EP - Is patient P private insurance eligible on date D. 1= yes, 0=no.
+1 GOTO OPI^BUDBRPC3
+2 ;
MCR(P,D) ;EP - Is patient P medicare eligible on date D. 1 = yes, 0 = no.
+1 ; I = IEN in ^AUPNMCR multiple.
+2 IF '$GET(P)
QUIT 0
+3 IF '$GET(D)
QUIT 0
+4 NEW I,Y
+5 SET Y=0
SET U="^"
+6 IF '$DATA(^DPT(P,0))
GOTO MCRX
+7 IF $PIECE(^DPT(P,0),U,19)
GOTO MCRX
+8 IF '$DATA(^AUPNPAT(P,0))
GOTO MCRX
+9 IF '$DATA(^AUPNMCR(P,11))
GOTO MCRX
+10 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO MCRX
+11 SET I=0
+12 FOR
SET I=$ORDER(^AUPNMCR(P,11,I))
IF I'=+I
QUIT
Begin DoDot:1
+13 IF $PIECE(^AUPNMCR(P,11,I,0),U)>D
QUIT
+14 IF $PIECE(^AUPNMCR(P,11,I,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+15 SET Y=1
+16 QUIT
End DoDot:1
MCRX ;
+1 IF Y
QUIT Y
+2 ;now check Private insurance for MD, MH, R, M
+3 IF '$DATA(^AUPNPRVT(P,11))
GOTO MCRPIX
+4 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO MCRPIX
+5 SET I=0
SET G=0
+6 FOR
SET I=$ORDER(^AUPNPRVT(P,11,I))
IF I'=+I
QUIT
Begin DoDot:1
+7 IF $PIECE(^AUPNPRVT(P,11,I,0),U)=""
QUIT
+8 SET X=$PIECE(^AUPNPRVT(P,11,I,0),U)
IF X=""
QUIT
+9 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="MC"
SET G=1
+10 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="MMC"
SET G=1
+11 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="MD"
SET G=1
+12 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="MH"
SET G=1
+13 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="R"
SET G=1
+14 IF 'G
QUIT
+15 IF $PIECE(^AUPNPRVT(P,11,I,0),U,6)>D
QUIT
+16 IF $PIECE(^AUPNPRVT(P,11,I,0),U,7)]""
IF $PIECE(^(0),U,7)<D
QUIT
+17 SET Y=1
+18 QUIT
End DoDot:1
MCRPIX ;
+1 QUIT Y
MIGRANT ;
+1 SET M=$$MIG(DFN,$$VD^APCLV(BUDLASTV))
+2 IF M=""
QUIT
+3 IF $PIECE(M,U,1)="M"
SET BUDT4V(14)=BUDT4V(14)+1
SET BUDT4V(16)=BUDT4V(16)+1
Begin DoDot:1
+4 IF '$GET(BUDT4CHA)
QUIT
+5 SET T="Migratory"
SET ^XTMP("BUDBRPT1",BUDJ,BUDH,"T4CHAR",14,T,BUDCOM,BUDSEX,BUDAGE,DFN)=""
End DoDot:1
+6 IF $PIECE(M,U,1)="S"
SET BUDT4V(15)=BUDT4V(15)+1
SET BUDT4V(16)=BUDT4V(16)+1
Begin DoDot:1
+7 IF '$GET(BUDT4CHA)
QUIT
+8 SET T="Seasonal"
+9 SET ^XTMP("BUDBRPT1",BUDJ,BUDH,"T4CHAR",15,T,BUDCOM,BUDSEX,BUDAGE,DFN)=""
End DoDot:1
+10 QUIT
HOMELESS ;
+1 SET H=$$HOMEL(DFN,$$VD^APCLV(BUDLASTV))
+2 IF H=""
QUIT
+3 IF $PIECE(H,U,1)="H"
SET BUDT4V(17)=BUDT4V(17)+1
SET BUDT4V(23)=BUDT4V(23)+1
SET T="Homeless (Type: Homeless Shelter)"
SET L=17
+4 IF $PIECE(H,U,1)="T"
SET BUDT4V(18)=BUDT4V(18)+1
SET BUDT4V(23)=BUDT4V(23)+1
SET T="Homeless (Type: Transitional)"
SET L=18
+5 IF $PIECE(H,U,1)="D"
SET BUDT4V(19)=BUDT4V(19)+1
SET BUDT4V(23)=BUDT4V(23)+1
SET T="Homeless (Type: Doubling Up)"
SET L=19
+6 IF $PIECE(H,U,1)="S"
SET BUDT4V(20)=BUDT4V(20)+1
SET BUDT4V(23)=BUDT4V(23)+1
SET T="Homeless (Type: Street)"
SET L=20
+7 IF $PIECE(H,U,1)="O"
SET BUDT4V(21)=BUDT4V(21)+1
SET BUDT4V(23)=BUDT4V(23)+1
SET T="Homeless (Type: Other)"
SET L=21
+8 IF $PIECE(H,U,1)="U"
SET BUDT4V(22)=BUDT4V(22)+1
SET BUDT4V(23)=BUDT4V(23)+1
SET T="Homeless (Type: Unknown)"
SET L=22
+9 SET ^XTMP("BUDBRPT1",BUDJ,BUDH,"T4CHAR",L,T,BUDCOM,BUDSEX,BUDAGE,DFN)=""
+10 QUIT
VET ;
+1 SET V=$$VALI^XBDIQ1(2,DFN,1901)
+2 IF V="Y"
SET T="Veteran"
SET BUDT4V(25)=BUDT4V(25)+1
SET ^XTMP("BUDBRPT1",BUDJ,BUDH,"T4CHAR",25,T,BUDCOM,BUDSEX,BUDAGE,DFN)=""
+3 QUIT
SCHOOL ;IF ALL VISITS ARE CLINIC SCHOOL??
+1 ;if any visit from 356a is clinic school set to yes
+2 NEW X,V,Y,S
+3 SET S=""
+4 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"VISITS356A",X))
IF X'=+X
QUIT
IF $$CLINIC^APCLV(X,"C")=22
SET S=1
+5 IF S=""
QUIT
+6 SET BUDT4V(24)=$GET(BUDT4V(24))+1
+7 SET ^XTMP("BUDBRPT1",BUDJ,BUDH,"T4CHAR",24,"School Based Patient",BUDCOM,BUDSEX,BUDAGE,DFN)=""
+8 QUIT
MIG(P,D) ;EP
+1 ;GET LAST VALUE WITH A YES BEFORE END OF TIME PERIOD
+2 IF '$ORDER(^AUPNPAT(P,84,0))
QUIT ""
+3 NEW X,Y,Z,L
+4 SET L=""
+5 SET X=0
FOR
SET X=$ORDER(^AUPNPAT(P,84,"B",X))
IF X'=+X
QUIT
Begin DoDot:1
+6 ;AFTER LAST VISIT
IF X>D
QUIT
+7 SET Y=0
FOR
SET Y=$ORDER(^AUPNPAT(P,84,"B",X,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+8 IF $PIECE($GET(^AUPNPAT(P,84,Y,0)),U,2)=""
QUIT
+9 ;I $P($G(^AUPNPAT(P,84,Y,0)),U,3)="" Q
+10 SET L=Y
End DoDot:2
End DoDot:1
+11 IF L=""
QUIT ""
+12 IF $PIECE(^AUPNPAT(P,84,L,0),U,2)="N"
QUIT ""
+13 QUIT $SELECT($PIECE(^AUPNPAT(P,84,L,0),U,3)]"":$PIECE(^AUPNPAT(P,84,L,0),U,3),1:"")_"^"_$PIECE(^AUPNPAT(P,84,L,0),U,1)
HOMEL(P,D) ;EP
+1 ;GET LAST VALUE WITH A YES BEFORE END OF TIME PERIOD
+2 IF '$ORDER(^AUPNPAT(P,85,0))
QUIT ""
+3 NEW X,Y,Z,L
+4 SET L=""
+5 SET X=0
FOR
SET X=$ORDER(^AUPNPAT(P,85,"B",X))
IF X'=+X
QUIT
Begin DoDot:1
+6 IF X>D
QUIT
+7 SET Y=0
FOR
SET Y=$ORDER(^AUPNPAT(P,85,"B",X,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+8 IF $PIECE($GET(^AUPNPAT(P,85,Y,0)),U,2)=""
QUIT
+9 SET L=Y
End DoDot:2
End DoDot:1
+10 IF L=""
QUIT ""
+11 IF $PIECE(^AUPNPAT(P,85,L,0),U,2)="N"
QUIT ""
+12 QUIT $SELECT($PIECE(^AUPNPAT(P,85,L,0),U,3)]"":$PIECE(^AUPNPAT(P,85,L,0),U,3),1:"U")_"^"_$PIECE(^AUPNPAT(P,85,L,0),U,1)