BUDDRPC2 ; IHS/CMI/LAB - UDS TABLE 6 01 Dec 2016 6:10 PM ;
;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
;
;
DENT(BUDV) ;EP - when only ADA and CPT codes that are not wildcards (*)
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 $D(^BUDDTSC(BUDY,12,"B",A)) 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 $D(^BUDDTSC(BUDY,8,"B",Z)) 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 $D(^BUDDTSC(BUDY,8,"B",Z)) 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 $D(^BUDDTSC(BUDY,10,"B",Z)) 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 $D(^BUDDTSC(BUDY,8,"B",Z)) 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 $E($P(Z,"-",1),1,3)="F17" S G=Z Q
I G]"" Q G
S C=$$CLINIC^APCLV(BUDV,"C")
I C,$D(^BUDDTSC(BUDY,11,"B",C)) Q "CLIN "_C
;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
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
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),BUDCCAD)>11 Q ""
S C=$$CLINIC^APCLV(BUDV,"C")
I C,$D(^BUDDTSC(BUDY,11,"B",C)) Q "CLIN "_C
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 $D(^BUDDTSC(BUDY,8,"B",Z)) S G=Z Q
Q G
L26A(BUDV) ;EP
;age 9-72 months
S G=""
S A=$$AGE^BUDDUTL2(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 $D(^BUDDTSC(BUDY,8,"B",Z)) 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 $D(^BUDDTSC(BUDY,8,"B",Z)) 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("BUDDRPT1",BUDJ,BUDH,"T4IPPL",$G(V),$G(LV),BUDCCOM,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(^BUDDIL("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(^BUDDIL(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 Q
.D TINS(BUDAGE,9)
.I $$MCD(DFN,$$VD^APCLV(BUDLASTV),"D") D TINS(BUDAGE,"8.9") Q
.I $$MCD(DFN,$$VD^APCLV(BUDLASTV),"K") D TINS(BUDAGE,"8.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) ;
I P="8.9" S $P(BUDT4V("9a"),U,$S(A<18:1,1:2))=$P(BUDT4V("9a"),U,$S(A<18:1,1:2))+1
I P'=8.9 S $P(BUDT4V(P),U,$S(A<18:1,1:2))=$P(BUDT4V(P),U,$S(A<18:1,1:2))+1
I P'=8.9 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"
.I P="8.9" S T="Dually Eligible"
.S ^XTMP("BUDDRPT1",BUDJ,BUDH,"T4PMIS",$G(P),$G(T),BUDAGE,BUDCCOM,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^BUDDRPC3
OPIC(P,D,T) ;EP - Is patient P private insurance eligible on date D. 1= yes, 0=no.
G OPIC^BUDDRPC3
;
OPI(P,D,T) ;EP - Is patient P private insurance eligible on date D. 1= yes, 0=no.
G OPI^BUDDRPC3
;
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("BUDDRPT1",BUDJ,BUDH,"T4CHAR",14,T,BUDCCOM,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("BUDDRPT1",BUDJ,BUDH,"T4CHAR",15,T,BUDCCOM,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("BUDDRPT1",BUDJ,BUDH,"T4CHAR",L,T,BUDCCOM,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("BUDDRPT1",BUDJ,BUDH,"T4CHAR",25,T,BUDCCOM,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,"VISITSUDSPT",X)) Q:X'=+X I $$CLINIC^APCLV(X,"C")=22 S S=1
Q:S=""
S BUDT4V(24)=$G(BUDT4V(24))+1
S ^XTMP("BUDDRPT1",BUDJ,BUDH,"T4CHAR",24,"School Based Patient",BUDCCOM,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)
BUDDRPC2 ; IHS/CMI/LAB - UDS TABLE 6 01 Dec 2016 6:10 PM ;
+1 ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
+2 ;
+3 ;
DENT(BUDV) ;EP - when only ADA and CPT codes that are not wildcards (*)
+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 $DATA(^BUDDTSC(BUDY,12,"B",A))
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 $DATA(^BUDDTSC(BUDY,8,"B",Z))
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 $DATA(^BUDDTSC(BUDY,8,"B",Z))
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 $DATA(^BUDDTSC(BUDY,10,"B",Z))
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 $DATA(^BUDDTSC(BUDY,8,"B",Z))
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
+15 IF $EXTRACT($PIECE(Z,"-",1),1,3)="F17"
SET G=Z
QUIT
End DoDot:1
+16 IF G]""
QUIT G
+17 SET C=$$CLINIC^APCLV(BUDV,"C")
+18 IF C
IF $DATA(^BUDDTSC(BUDY,11,"B",C))
QUIT "CLIN "_C
+19 ;S X=0 F S X=$O(^AUPNVPOV("AD",BUDV,X)) Q:X'=+X!(G]"") D
+20 ;.S Z=$$VAL^XBDIQ1(9000010.07,X,.01)
+21 ;.I Z="305.1" S G="305.1"
+22 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
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),BUDCCAD)>11
QUIT ""
+2 SET C=$$CLINIC^APCLV(BUDV,"C")
+3 IF C
IF $DATA(^BUDDTSC(BUDY,11,"B",C))
QUIT "CLIN "_C
+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 $DATA(^BUDDTSC(BUDY,8,"B",Z))
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^BUDDUTL2(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 $DATA(^BUDDTSC(BUDY,8,"B",Z))
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 $DATA(^BUDDTSC(BUDY,8,"B",Z))
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("BUDDRPT1",BUDJ,BUDH,"T4IPPL",$GET(V),$GET(LV),BUDCCOM,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(^BUDDIL("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(^BUDDIL(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
Begin DoDot:1
+6 DO TINS(BUDAGE,9)
+7 IF $$MCD(DFN,$$VD^APCLV(BUDLASTV),"D")
DO TINS(BUDAGE,"8.9")
QUIT
+8 IF $$MCD(DFN,$$VD^APCLV(BUDLASTV),"K")
DO TINS(BUDAGE,"8.9")
QUIT
End DoDot:1
QUIT
+9 ;S BUDHAS=$$OPI(DFN,$$VD^APCLV(BUDLASTV),"W")
+10 ;I BUDHAS=1 D TINS(BUDAGE,"10a") Q
+11 SET BUDHAS=$$RR^AUPNPAT(DFN,$$VD^APCLV(BUDLASTV))
+12 IF BUDHAS=1
DO TINS(BUDAGE,"10a")
QUIT
+13 SET BUDHAS=$$OPI(DFN,$$VD^APCLV(BUDLASTV))
+14 IF BUDHAS=1
DO TINS(BUDAGE,"10a")
QUIT
+15 SET BUDHAS=$$OPIC(DFN,$$VD^APCLV(BUDLASTV),"K")
+16 IF BUDHAS=1
DO TINS(BUDAGE,"10b")
QUIT
+17 SET BUDHAS=$$MCD(DFN,$$VD^APCLV(BUDLASTV),"D")
+18 IF BUDHAS=1
DO TINS(BUDAGE,"8a")
QUIT
+19 SET BUDHAS=$$MCD(DFN,$$VD^APCLV(BUDLASTV),"K")
+20 IF BUDHAS=1
DO TINS(BUDAGE,"8b")
QUIT
+21 ;now check workman's comp and 3rd party liability
+22 SET BUDHAS=$$WC(DFN,BUDBD,BUDED)
+23 IF BUDHAS=1
DO TINS(BUDAGE,"11")
QUIT
+24 SET BUDHAS=$$TPL(DFN,BUDBD,BUDED)
+25 IF BUDHAS=1
DO TINS(BUDAGE,"10a")
QUIT
+26 ;now check guarantor file
+27 ;S BUDHAS=$$GUAR(DFN,BUDBD,BUDED)
+28 ;I BUDHAS=1 D TINS(BUDAGE,"7") Q
+29 DO TINS(BUDAGE,7)
+30 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 IF P="8.9"
SET $PIECE(BUDT4V("9a"),U,$SELECT(A<18:1,1:2))=$PIECE(BUDT4V("9a"),U,$SELECT(A<18:1,1:2))+1
+2 IF P'=8.9
SET $PIECE(BUDT4V(P),U,$SELECT(A<18:1,1:2))=$PIECE(BUDT4V(P),U,$SELECT(A<18:1,1:2))+1
+3 IF P'=8.9
SET $PIECE(BUDT4V(12),U,$SELECT(A<18:1,1:2))=$PIECE(BUDT4V(12),U,$SELECT(A<18:1,1:2))+1
+4 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
+5 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
+6 IF $GET(BUDT4PMI)
Begin DoDot:1
+7 IF P=7
SET T="None/Uninsured"
+8 IF P="8a"
SET T="Regular Medicaid (Title XIX)"
SET P=8.1
+9 IF P="8b"
SET T="CHIP Medicaid"
SET P=8.2
+10 IF P="9"
SET T="Medicare"
+11 IF P="10a"
SET T="Other Public Insurance Non-CHIP"
SET P=10.1
+12 IF P="10b"
SET T="Other Public Insurance CHIP"
SET P=10.2
+13 IF P="11"
SET T="Private Insurance"
+14 IF P="8.9"
SET T="Dually Eligible"
+15 SET ^XTMP("BUDDRPT1",BUDJ,BUDH,"T4PMIS",$GET(P),$GET(T),BUDAGE,BUDCCOM,BUDSEX,DFN)=""
End DoDot:1
+16 QUIT
+17 ;
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^BUDDRPC3
OPIC(P,D,T) ;EP - Is patient P private insurance eligible on date D. 1= yes, 0=no.
+1 GOTO OPIC^BUDDRPC3
+2 ;
OPI(P,D,T) ;EP - Is patient P private insurance eligible on date D. 1= yes, 0=no.
+1 GOTO OPI^BUDDRPC3
+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("BUDDRPT1",BUDJ,BUDH,"T4CHAR",14,T,BUDCCOM,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("BUDDRPT1",BUDJ,BUDH,"T4CHAR",15,T,BUDCCOM,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("BUDDRPT1",BUDJ,BUDH,"T4CHAR",L,T,BUDCCOM,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("BUDDRPT1",BUDJ,BUDH,"T4CHAR",25,T,BUDCCOM,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,"VISITSUDSPT",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("BUDDRPT1",BUDJ,BUDH,"T4CHAR",24,"School Based Patient",BUDCCOM,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)
