BUDHUTL3 ;IHS/CMI/LAB - UDS REPORT PROCESS;
;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
EVIDHEPB(P,EDATE) ;
;is there HEP B evidence
;V POV OR PROBLEM LIST
NEW X,Y,Z,G,T,S,D,E,R,L,J,ME
I $$PLTAXND^BUDHDU(P,"BGP IPC HEP B DXS",EDATE,0) Q 1
I $$IPLSNOND^BUDHDU(P,"T6B IMM EVIDENCE HEP B",EDATE,0) Q 1
I $$LASTDX^BUDHUTL1(P,"BGP IPC HEP B DXS",$$DOB^AUPNPAT(P),EDATE) Q 1
;NOW V POV SNOMED
;NOW SNOMED USING ASNC
S T=$O(^BUDHTSSC("B","T6B IMM EVIDENCE HEP B",0))
S G=""
S S=0 F S S=$O(^BUDHTSSC(T,13,"B",S)) Q:S=""!(G) D
.Q:'$D(^AUPNVPOV("ASNC",P,S))
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
..S Y=9999999-D
..Q:Y>EDATE
..S G=1
I G Q 1
;lab tests?
Q "" ;NOT SURE YET
DIS(P,EDATE) ;EP
NEW X,Y,Z,G,T,S,D,E,R,L,J,ME
I $$PLTAXND^BUDHDU(P,"BGP IPC IMMUNE DISORDERS DXS",EDATE,0) Q 1
I $$IPLSNOND^BUDHDU(P,"T6B IMM CONTRA IMMUNE SYSTEM",EDATE,0) Q 1
I $$LASTDX^BUDHUTL1(P,"BGP IPC IMMUNE DISORDERS DXS",$$DOB^AUPNPAT(P),EDATE) Q 1
;NOW V POV SNOMED
;NOW SNOMED USING ASNC
S T=$O(^BUDHTSSC("B","T6B IMM CONTRA IMMUNE SYSTEM",0))
S G=""
S S=0 F S S=$O(^BUDHTSSC(T,13,"B",S)) Q:S=""!(G) D
.Q:'$D(^AUPNVPOV("ASNC",P,S))
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
..S Y=9999999-D
..Q:Y>EDATE
..S G=1
Q G
HIV(P,EDATE) ;EP
NEW X,Y,Z,G,T,S,D,E,R,L,J,ME
I $$PLTAXND^BUDHDU(P,"BGP IPC HIV DXS",EDATE,0) Q 1
I $$IPLSNOND^BUDHDU(P,"T6B IMM CONTRA HIV",EDATE,0) Q 1
I $$LASTDX^BUDHUTL1(P,"BGP IPC HIV DXS",$$DOB^AUPNPAT(P),EDATE) Q 1
;NOW V POV SNOMED
;NOW SNOMED USING ASNC
S T=$O(^BUDHTSSC("B","T6B IMM CONTRA HIV",0))
S G=""
S S=0 F S S=$O(^BUDHTSSC(T,13,"B",S)) Q:S=""!(G) D
.Q:'$D(^AUPNVPOV("ASNC",P,S))
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
..S Y=9999999-D
..Q:Y>EDATE
..S G=1
Q G
MNLHT(P,EDATE) ;EP
NEW X,Y,Z,G,T,S,D,E,R,L,J,ME
I $$PLTAXND^BUDHDU(P,"BGP IPC LYMPHATIC CANCER DXS",EDATE,0) Q 1
I $$IPLSNOND^BUDHDU(P,"PXRM BGP IPC LYMPH CANCER",EDATE,0) Q 1
I $$LASTDX^BUDHUTL1(P,"BGP IPC LYMPHATIC CANCER DXS",$$DOB^AUPNPAT(P),EDATE) Q 1
;NOW V POV SNOMED
;NOW SNOMED USING ASNC
S T=$O(^BUDHTSSC("B","PXRM BGP IPC LYMPH CANCER",0))
S G=""
S S=0 F S S=$O(^BUDHTSSC(T,13,"B",S)) Q:S=""!(G) D
.Q:'$D(^AUPNVPOV("ASNC",P,S))
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
..S Y=9999999-D
..Q:Y>EDATE
..S G=1
Q G
ANSNROTA(P,EDATE) ;
;V POV OR PROBLEM LIST
NEW X,Y,Z,G,T,S,D,I
S (X,Y,I)=0
F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) D
.Q:'$D(^AUPNPROB(X,0))
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.I $P(^AUPNPROB(X,0),U,13),$P(^AUPNPROB(X,0),U,13)>EDATE Q ;if there is a doo and it is after report period skip
.I $P(^AUPNPROB(X,0),U,13)="",$P(^AUPNPROB(X,0),U,8)>EDATE Q ;entered after report period, skip
.S S=$$VAL^XBDIQ1(9000011,X,80001)
.I S=428331000124103 S I=1 Q
.Q
I I Q I
;NOW V POV SNOMED
;NOW SNOMED USING ASNC
S G="",I=""
S S="" F S S=$O(^AUPNVPOV("ASNC",P,S)) Q:S=""!(G) D
.S I=0
.I S=428331000124103 S I=1
.Q:'I
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
..S Y=9999999-D
..Q:Y>EDATE
..S G=1
I G Q G
;REFUSAL FILE
S I="" F S I=$O(^AUPNPREF("AA",P,9002318.4,I)) Q:I=""!(G) D
.I I'=428331000124103 Q ;IF IT'S SNOMED, MUST BE THAT ONE
.S ID=0 F S ID=$O(^AUPNPREF("AA",P,9002318.4,I,ID)) Q:ID=""!(G) D
..S D=9999999-$P(ID,".") ;ID
..Q:D>EDATE
..S G=1
Q G
SCID(P,EDATE) ;EP
NEW X,Y,Z,G,T,S,D,E,R,L,J,ME
I $$PLTAXND^BUDHDU(P,"BGP IPC SCID DXS",EDATE,0) Q 1
I $$IPLSNOND^BUDHDU(P,"T6B IMM CONTRA SCID",EDATE,0) Q 1
I $$LASTDX^BUDHUTL1(P,"BGP IPC SCID DXS",$$DOB^AUPNPAT(P),EDATE) Q 1
;NOW V POV SNOMED
;NOW SNOMED USING ASNC
S T=$O(^BUDHTSSC("B","T6B IMM CONTRA SCID",0))
S G=""
S S=0 F S S=$O(^BUDHTSSC(T,13,"B",S)) Q:S=""!(G) D
.Q:'$D(^AUPNVPOV("ASNC",P,S))
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
..S Y=9999999-D
..Q:Y>EDATE
..S G=1
Q G
INTUSS(P,EDATE) ;EP
NEW X,Y,Z,G,T,S,D,E,R,L,J,ME
I $$PLTAXND^BUDHDU(P,"BGP IPC INTUSSUSCEPTION DXS",EDATE,0) Q 1
I $$IPLSNOND^BUDHDU(P,"T6B IMM CONTRA INTUSS",EDATE,0) Q 1
I $$LASTDX^BUDHUTL1(P,"BGP IPC INTUSSUSCEPTION DXS",$$DOB^AUPNPAT(P),EDATE) Q 1
;NOW V POV SNOMED
;NOW SNOMED USING ASNC
S T=$O(^BUDHTSSC("B","T6B IMM CONTRA INTUSS",0))
S G=""
S S=0 F S S=$O(^BUDHTSSC(T,13,"B",S)) Q:S=""!(G) D
.Q:'$D(^AUPNVPOV("ASNC",P,S))
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
..S Y=9999999-D
..Q:Y>EDATE
..S G=1
Q G
ANFU(P,BDATE,EDATE) ;EP
NEW A,B,C,X,Y,Z,T,V,R,G,BUDV,BUDMEDS1,T1
;is there a dx
S X=$$LASTDX^BUDHUTL1(P,"BGP IPC ABOVE NORMAL FU DXS",BDATE,EDATE) I X Q "DX: "_$P(X,U,2)_U_$P(X,U,3)
;now check cpts
S T=$O(^ATXAX("B","BGP IPC ABOVE NORMAL FU CPTS",0))
I T D I X]"" Q "CPT: "_$P(X,U,2)_U_$P(X,U,1)
.S X=$$CPT^BUDHDU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BUDHDU(P,BDATE,EDATE,T,5)
I X Q X
;HOW ABOUT REFERRALS BETWEEN BDATE AND EDATE
;GET ALL VISITS
K BUDV
S G=""
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDV")
S G=""
S T=$O(^BUDHTSSC("B","PXRM BGP IPC WT ASMT REFER",0))
S T1=$O(^BUDHTSSC("B","PXRM BGP IPC OVERWEIGHT",0))
S X=0 F S X=$O(BUDV(X)) Q:X'=+X!(G) S Y=$P(BUDV(X),U,5) D
.Q:'$D(^AUPNVREF("AD",Y))
.S Z=0 F S Z=$O(^AUPNVREF("AD",Y,Z)) Q:Z'=+Z!(G) D
..S S=$P($G(^AUPNVREF(Z,0)),U,1) Q:S=""
..Q:'$D(^BUDHTSSC(T,13,"B",S))
..;NOW GO GET SNOMED REASON
..S R=$P($G(^AUPNVREF(Z,0)),U,6)
..Q:'R
..Q:'$D(^BMCREF(R,0))
..S A=0,G="" F S A=$O(^BMCREF(R,22,"B",A)) Q:A=""!(G) I $D(^BUDHTSSC(T1,13,"B",A)) S G="Refer: "_S_"/"_A_U_$$VD^APCLV(Y)
I G]"" Q G
S G=""
NEW BUDMEDS1
D GETMEDS^BUDHUTL2(P,BDATE,EDATE,"BGP IPC ABOVE NORMAL MEDS","",,,.BUDMEDS1,"BGP IPC ABOVE NORMAL RXNORM")
S X=0,T=0,W="" F S X=$O(BUDMEDS1(X)) Q:X'=+X!(G]"") D
.S Y=$P(BUDMEDS1(X),U,4) ;vmed ien
.S V=$P(BUDMEDS1(X),U,5)
.Q:'$D(^AUPNVMED(Y,0))
.Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
.S D=$P(^AUPNVMED(Y,0),U,1) ;drug ien
.;DAYS SUPPLY MUST BE >0
.S E=$P(^AUPNVMED(Y,0),U,8) ;date discontinued
.S S=$P(^AUPNVMED(Y,0),U,7) ;DAYS SUPPLY
.Q:'S
.I E,E'>$P(BUDMEDS1(X),U,1) Q ;at least one day
.S G="Med "_$$VAL^XBDIQ1(9000010.14,Y,.01)_U_$$VD^APCLV(V)
I G]"" Q G
;NOW V POV FOR SNOMED
;NOW SNOMED USING ASNC
S T=$O(^BUDHTSSC("B","PXRM BGP IPC ABOVE NORM",0))
S S=0 F S S=$O(^BUDHTSSC(T,13,"B",S)) Q:S=""!(G) D
.Q:'$D(^AUPNVPOV("ASNC",P,S))
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
..S Y=9999999-D
..Q:Y>EDATE
..Q:Y<BDATE
..S G="SNOMED: "_S_U_D
I G]"" Q G
NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,S,T,BUDPL,C
S BUDPL=""
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S TIEN=$O(^BUDHTSSC("B","T6B ADULTWT OVERWT PLAN CODES",0))
S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR D
.S VIEN=$P(BUDVS(CTR),U,5)
.S VDATE=$P(BUDVS(CTR),U,1)
.S C=$$CLINIC^APCLV(VIEN,"C") I C]"",$D(^BUDHTSSC(TIEN,17,"B",C)) S BUDPL="Clinic "_C_U_VDATE Q
.S X=0 F S X=$O(^AUPNVPED("AD",VIEN,X)) Q:X'=+X!(BUDPL]"") D
..Q:'$D(^AUPNVPED(X,0))
..S T=$$VALI^XBDIQ1(9000010.16,X,.01)
..Q:'$D(^AUTTEDT(T,0))
..S T=$P(^AUTTEDT(T,0),U,2)
..I $P(T,"-",2)="EX"!($P(T,"-",2)="LA")!($P(T,"-",2)="N")!($P(T,"-",2)="DT")!($P(T,"-",2)="MNT") S BUDPL=T_U_VDATE Q
..I $P(T,"-",1)="OBS"!($P(T,"-",1)="Z71.3") S BUDPL=T_U_VDATE Q
.;CPT
.S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X!(BUDPL]"") D
..Q:'$D(^AUPNVCPT(X,0))
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..Q:Y=""
..I $D(^BUDHTSSC("AC",Y,TIEN)) S BUDPL="CPT: "_Y_U_VDATE Q
.;V TRANS
.S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X!(BUDPL]"") D
..Q:'$D(^AUPNVTC(X,0))
..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
..Q:Y=""
..I $D(^BUDHTSSC("AC",Y,TIEN)) S BUDPL="CPT/TRAN: "_Y_U_VDATE Q
.;SNOMED
.S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X!(BUDPL]"") D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..I Y]"",$D(^BUDHTSSC("AS",Y,TIEN)) S BUDPL="SNOMED: "_Y_U_VDATE Q
..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDHTSSC("AD",Y,TIEN)) S BUDPL="DX "_$$VAL^XBDIQ1(9000010.07,X,.01)_U_VDATE Q
.;PROVIDER CODES
.S X=0 F S X=$O(^AUPNVPRV("AD",VIEN,X)) Q:X'=+X!(BUDPL]"") D
..Q:'$D(^AUPNVPRV(X,0))
..S Y=$$VALI^XBDIQ1(9000010.06,X,.01)
..Q:Y=""
..S Y=$$PROVCLSC^XBFUNC1(Y)
..Q:Y=""
..I $D(^BUDHTSSC(TIEN,16,"B",Y)) S BUDPL="Prv: "_Y_U_VDATE Q
I BUDPL]"" Q BUDPL
;CHECK PROBLEM LIST FOR SNOMED
S X=$$PLCL^BUDHDU(P,"T6B ADULTWT PLAN CODES",EDATE,0,BDATE) I X Q "PROBLEM SNOMED "_$P(X,U,2)
Q ""
BLFU(P,BDATE,EDATE) ;EP
NEW A,B,C,X,Y,Z,T,V,G,BUDV,BUDMEDS1
;is there a dx
S X=$$LASTDX^BUDHUTL1(P,"BGP IPC BELOW NORMAL FU DXS",BDATE,EDATE) I X]"" Q "DX: "_$P(X,U,2)
;now check cpts
S T=$O(^ATXAX("B","BGP IPC BELOW NORMAL FU CPTS",0))
I T D I X]"" Q "CPT: "_$P(X,U,2)_U_$P(X,U,1)
.S X=$$CPT^BUDHDU(P,BDATE,EDATE,T,5) I X]"" Q
.S X=$$TRAN^BUDHDU(P,BDATE,EDATE,T,5)
I X]"" Q X
;HOW ABOUT REFERRALS BETWEEN BDATE AND EDATE
;GET ALL VISITS
K BUDV
S G=""
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDV")
S T=$O(^BUDHTSSC("B","PXRM BGP IPC WT ASMT REFER",0))
S T1=$O(^BUDHTSSC("B","PXRM BGP IPC UNDERWEIGHT",0))
S X=0 F S X=$O(BUDV(X)) Q:X'=+X!(G) S Y=$P(BUDV(X),U,5) D
.Q:'$D(^AUPNVREF("AD",Y))
.S Z=0 F S Z=$O(^AUPNVREF("AD",Y,Z)) Q:Z'=+Z!(G) D
..S S=$P($G(^AUPNVREF(Z,0)),U,1) Q:S=""
..Q:'$D(^BUDHTSSC(T,13,"B",S))
..;NOW GO GET SNOMED REASON
..S R=$P($G(^AUPNVREF(Z,0)),U,6)
..Q:'R
..Q:'$D(^BMCREF(R,0))
..S A=0,G="" F S A=$O(^BMCREF(R,22,"B",A)) Q:A=""!(G) I $D(^BUDHTSSC(T1,13,"B",A)) S G="Refer: "_S_"/"_A_U_$$VD^APCLV(Y)
I G]"" Q G
;NOW MEDS
S G=""
D GETMEDS^BUDHUTL2(P,BDATE,EDATE,"BGP IPC BELOW NORMAL MEDS","",,,.BUDMEDS1,"BGP IPC BELOW NORMAL RXNORM")
S X=0,T=0,W="" F S X=$O(BUDMEDS1(X)) Q:X'=+X!(G) D
.S Y=$P(BUDMEDS1(X),U,4) ;vmed ien
.S V=$P(BUDMEDS1(X),U,5)
.Q:'$D(^AUPNVMED(Y,0))
.Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
.S D=$P(^AUPNVMED(Y,0),U,1) ;drug ien
.;DAYS SUPPLY MUST BE >0
.S E=$P(^AUPNVMED(Y,0),U,8) ;date discontinued
.S S=$P(^AUPNVMED(Y,0),U,7) ;DAYS SUPPLY
.Q:'S
.I E,E'>$P(BUDMEDS1(X),U,1) Q ;at least one day
.S G="Med "_$$VAL^XBDIQ1(9000010.14,Y,.01)_U_$$VD^APCLV(V)
I G]"" Q G
;NOW V POV FOR SNOMED
;NOW SNOMED USING ASNC
S T=$O(^BUDHTSSC("B","PXRM BGP IPC BELOW NORM",0))
S G=""
S S=0 F S S=$O(^BUDHTSSC(T,13,"B",S)) Q:S=""!(G) D
.Q:'$D(^AUPNVPOV("ASNC",P,S))
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
..S Y=9999999-D
..Q:Y>EDATE
..Q:Y<BDATE
..S G="SNOMED: "_S_U_D
I G]"" Q G
NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,S,T,BUDPL,C
S BUDPL=""
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S TIEN=$O(^BUDHTSSC("B","T6B ADULTWT OVERWT PLAN CODES",0))
S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR D
.S VIEN=$P(BUDVS(CTR),U,5)
.S VDATE=$P(BUDVS(CTR),U,1)
.;S C=$$CLINIC^APCLV(VIEN,"C") I C]"",$D(^BUDHTSSC(TIEN,17,"B",C)) S BUDPL="Clinic "_C_U_VDATE Q
.S X=0 F S X=$O(^AUPNVPED("AD",VIEN,X)) Q:X'=+X!(BUDPL]"") D
..Q:'$D(^AUPNVPED(X,0))
..S T=$$VALI^XBDIQ1(9000010.16,X,.01)
..Q:'$D(^AUTTEDT(T,0))
..S T=$P(^AUTTEDT(T,0),U,2)
..I $P(T,"-",2)="EX"!($P(T,"-",2)="LA")!($P(T,"-",2)="N")!($P(T,"-",2)="DT")!($P(T,"-",2)="MNT") S BUDPL=T_U_VDATE Q
..I $P(T,"-",1)="Z71.3" S BUDPL=T_U_VDATE Q
.;PROVIDER CODES
.S X=0 F S X=$O(^AUPNVPRV("AD",VIEN,X)) Q:X'=+X!(BUDPL]"") D
..Q:'$D(^AUPNVPRV(X,0))
..S Y=$$VALI^XBDIQ1(9000010.06,X,.01)
..Q:Y=""
..S Y=$$PROVCLSC^XBFUNC1(Y)
..Q:Y=""
..I $D(^BUDHTSSC(TIEN,16,"B",Y)) S BUDPL="Prv: "_Y_U_VDATE Q
I BUDPL]"" Q BUDPL
Q ""
BUDHUTL3 ;IHS/CMI/LAB - UDS REPORT PROCESS;
+1 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
EVIDHEPB(P,EDATE) ;
+1 ;is there HEP B evidence
+2 ;V POV OR PROBLEM LIST
+3 NEW X,Y,Z,G,T,S,D,E,R,L,J,ME
+4 IF $$PLTAXND^BUDHDU(P,"BGP IPC HEP B DXS",EDATE,0)
QUIT 1
+5 IF $$IPLSNOND^BUDHDU(P,"T6B IMM EVIDENCE HEP B",EDATE,0)
QUIT 1
+6 IF $$LASTDX^BUDHUTL1(P,"BGP IPC HEP B DXS",$$DOB^AUPNPAT(P),EDATE)
QUIT 1
+7 ;NOW V POV SNOMED
+8 ;NOW SNOMED USING ASNC
+9 SET T=$ORDER(^BUDHTSSC("B","T6B IMM EVIDENCE HEP B",0))
+10 SET G=""
+11 SET S=0
FOR
SET S=$ORDER(^BUDHTSSC(T,13,"B",S))
IF S=""!(G)
QUIT
Begin DoDot:1
+12 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+13 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+14 SET Y=9999999-D
+15 IF Y>EDATE
QUIT
+16 SET G=1
End DoDot:2
End DoDot:1
+17 IF G
QUIT 1
+18 ;lab tests?
+19 ;NOT SURE YET
QUIT ""
DIS(P,EDATE) ;EP
+1 NEW X,Y,Z,G,T,S,D,E,R,L,J,ME
+2 IF $$PLTAXND^BUDHDU(P,"BGP IPC IMMUNE DISORDERS DXS",EDATE,0)
QUIT 1
+3 IF $$IPLSNOND^BUDHDU(P,"T6B IMM CONTRA IMMUNE SYSTEM",EDATE,0)
QUIT 1
+4 IF $$LASTDX^BUDHUTL1(P,"BGP IPC IMMUNE DISORDERS DXS",$$DOB^AUPNPAT(P),EDATE)
QUIT 1
+5 ;NOW V POV SNOMED
+6 ;NOW SNOMED USING ASNC
+7 SET T=$ORDER(^BUDHTSSC("B","T6B IMM CONTRA IMMUNE SYSTEM",0))
+8 SET G=""
+9 SET S=0
FOR
SET S=$ORDER(^BUDHTSSC(T,13,"B",S))
IF S=""!(G)
QUIT
Begin DoDot:1
+10 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+11 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+12 SET Y=9999999-D
+13 IF Y>EDATE
QUIT
+14 SET G=1
End DoDot:2
End DoDot:1
+15 QUIT G
HIV(P,EDATE) ;EP
+1 NEW X,Y,Z,G,T,S,D,E,R,L,J,ME
+2 IF $$PLTAXND^BUDHDU(P,"BGP IPC HIV DXS",EDATE,0)
QUIT 1
+3 IF $$IPLSNOND^BUDHDU(P,"T6B IMM CONTRA HIV",EDATE,0)
QUIT 1
+4 IF $$LASTDX^BUDHUTL1(P,"BGP IPC HIV DXS",$$DOB^AUPNPAT(P),EDATE)
QUIT 1
+5 ;NOW V POV SNOMED
+6 ;NOW SNOMED USING ASNC
+7 SET T=$ORDER(^BUDHTSSC("B","T6B IMM CONTRA HIV",0))
+8 SET G=""
+9 SET S=0
FOR
SET S=$ORDER(^BUDHTSSC(T,13,"B",S))
IF S=""!(G)
QUIT
Begin DoDot:1
+10 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+11 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+12 SET Y=9999999-D
+13 IF Y>EDATE
QUIT
+14 SET G=1
End DoDot:2
End DoDot:1
+15 QUIT G
MNLHT(P,EDATE) ;EP
+1 NEW X,Y,Z,G,T,S,D,E,R,L,J,ME
+2 IF $$PLTAXND^BUDHDU(P,"BGP IPC LYMPHATIC CANCER DXS",EDATE,0)
QUIT 1
+3 IF $$IPLSNOND^BUDHDU(P,"PXRM BGP IPC LYMPH CANCER",EDATE,0)
QUIT 1
+4 IF $$LASTDX^BUDHUTL1(P,"BGP IPC LYMPHATIC CANCER DXS",$$DOB^AUPNPAT(P),EDATE)
QUIT 1
+5 ;NOW V POV SNOMED
+6 ;NOW SNOMED USING ASNC
+7 SET T=$ORDER(^BUDHTSSC("B","PXRM BGP IPC LYMPH CANCER",0))
+8 SET G=""
+9 SET S=0
FOR
SET S=$ORDER(^BUDHTSSC(T,13,"B",S))
IF S=""!(G)
QUIT
Begin DoDot:1
+10 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+11 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+12 SET Y=9999999-D
+13 IF Y>EDATE
QUIT
+14 SET G=1
End DoDot:2
End DoDot:1
+15 QUIT G
ANSNROTA(P,EDATE) ;
+1 ;V POV OR PROBLEM LIST
+2 NEW X,Y,Z,G,T,S,D,I
+3 SET (X,Y,I)=0
+4 FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUPNPROB(X,0))
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+7 ;if there is a doo and it is after report period skip
IF $PIECE(^AUPNPROB(X,0),U,13)
IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
QUIT
+8 ;entered after report period, skip
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+9 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+10 IF S=428331000124103
SET I=1
QUIT
+11 QUIT
End DoDot:1
+12 IF I
QUIT I
+13 ;NOW V POV SNOMED
+14 ;NOW SNOMED USING ASNC
+15 SET G=""
SET I=""
+16 SET S=""
FOR
SET S=$ORDER(^AUPNVPOV("ASNC",P,S))
IF S=""!(G)
QUIT
Begin DoDot:1
+17 SET I=0
+18 IF S=428331000124103
SET I=1
+19 IF 'I
QUIT
+20 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+21 SET Y=9999999-D
+22 IF Y>EDATE
QUIT
+23 SET G=1
End DoDot:2
End DoDot:1
+24 IF G
QUIT G
+25 ;REFUSAL FILE
+26 SET I=""
FOR
SET I=$ORDER(^AUPNPREF("AA",P,9002318.4,I))
IF I=""!(G)
QUIT
Begin DoDot:1
+27 ;IF IT'S SNOMED, MUST BE THAT ONE
IF I'=428331000124103
QUIT
+28 SET ID=0
FOR
SET ID=$ORDER(^AUPNPREF("AA",P,9002318.4,I,ID))
IF ID=""!(G)
QUIT
Begin DoDot:2
+29 ;ID
SET D=9999999-$PIECE(ID,".")
+30 IF D>EDATE
QUIT
+31 SET G=1
End DoDot:2
End DoDot:1
+32 QUIT G
SCID(P,EDATE) ;EP
+1 NEW X,Y,Z,G,T,S,D,E,R,L,J,ME
+2 IF $$PLTAXND^BUDHDU(P,"BGP IPC SCID DXS",EDATE,0)
QUIT 1
+3 IF $$IPLSNOND^BUDHDU(P,"T6B IMM CONTRA SCID",EDATE,0)
QUIT 1
+4 IF $$LASTDX^BUDHUTL1(P,"BGP IPC SCID DXS",$$DOB^AUPNPAT(P),EDATE)
QUIT 1
+5 ;NOW V POV SNOMED
+6 ;NOW SNOMED USING ASNC
+7 SET T=$ORDER(^BUDHTSSC("B","T6B IMM CONTRA SCID",0))
+8 SET G=""
+9 SET S=0
FOR
SET S=$ORDER(^BUDHTSSC(T,13,"B",S))
IF S=""!(G)
QUIT
Begin DoDot:1
+10 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+11 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+12 SET Y=9999999-D
+13 IF Y>EDATE
QUIT
+14 SET G=1
End DoDot:2
End DoDot:1
+15 QUIT G
INTUSS(P,EDATE) ;EP
+1 NEW X,Y,Z,G,T,S,D,E,R,L,J,ME
+2 IF $$PLTAXND^BUDHDU(P,"BGP IPC INTUSSUSCEPTION DXS",EDATE,0)
QUIT 1
+3 IF $$IPLSNOND^BUDHDU(P,"T6B IMM CONTRA INTUSS",EDATE,0)
QUIT 1
+4 IF $$LASTDX^BUDHUTL1(P,"BGP IPC INTUSSUSCEPTION DXS",$$DOB^AUPNPAT(P),EDATE)
QUIT 1
+5 ;NOW V POV SNOMED
+6 ;NOW SNOMED USING ASNC
+7 SET T=$ORDER(^BUDHTSSC("B","T6B IMM CONTRA INTUSS",0))
+8 SET G=""
+9 SET S=0
FOR
SET S=$ORDER(^BUDHTSSC(T,13,"B",S))
IF S=""!(G)
QUIT
Begin DoDot:1
+10 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+11 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+12 SET Y=9999999-D
+13 IF Y>EDATE
QUIT
+14 SET G=1
End DoDot:2
End DoDot:1
+15 QUIT G
ANFU(P,BDATE,EDATE) ;EP
+1 NEW A,B,C,X,Y,Z,T,V,R,G,BUDV,BUDMEDS1,T1
+2 ;is there a dx
+3 SET X=$$LASTDX^BUDHUTL1(P,"BGP IPC ABOVE NORMAL FU DXS",BDATE,EDATE)
IF X
QUIT "DX: "_$PIECE(X,U,2)_U_$PIECE(X,U,3)
+4 ;now check cpts
+5 SET T=$ORDER(^ATXAX("B","BGP IPC ABOVE NORMAL FU CPTS",0))
+6 IF T
Begin DoDot:1
+7 SET X=$$CPT^BUDHDU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+8 SET X=$$TRAN^BUDHDU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
QUIT "CPT: "_$PIECE(X,U,2)_U_$PIECE(X,U,1)
+9 IF X
QUIT X
+10 ;HOW ABOUT REFERRALS BETWEEN BDATE AND EDATE
+11 ;GET ALL VISITS
+12 KILL BUDV
+13 SET G=""
+14 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDV")
+15 SET G=""
+16 SET T=$ORDER(^BUDHTSSC("B","PXRM BGP IPC WT ASMT REFER",0))
+17 SET T1=$ORDER(^BUDHTSSC("B","PXRM BGP IPC OVERWEIGHT",0))
+18 SET X=0
FOR
SET X=$ORDER(BUDV(X))
IF X'=+X!(G)
QUIT
SET Y=$PIECE(BUDV(X),U,5)
Begin DoDot:1
+19 IF '$DATA(^AUPNVREF("AD",Y))
QUIT
+20 SET Z=0
FOR
SET Z=$ORDER(^AUPNVREF("AD",Y,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:2
+21 SET S=$PIECE($GET(^AUPNVREF(Z,0)),U,1)
IF S=""
QUIT
+22 IF '$DATA(^BUDHTSSC(T,13,"B",S))
QUIT
+23 ;NOW GO GET SNOMED REASON
+24 SET R=$PIECE($GET(^AUPNVREF(Z,0)),U,6)
+25 IF 'R
QUIT
+26 IF '$DATA(^BMCREF(R,0))
QUIT
+27 SET A=0
SET G=""
FOR
SET A=$ORDER(^BMCREF(R,22,"B",A))
IF A=""!(G)
QUIT
IF $DATA(^BUDHTSSC(T1,13,"B",A))
SET G="Refer: "_S_"/"_A_U_$$VD^APCLV(Y)
End DoDot:2
End DoDot:1
+28 IF G]""
QUIT G
+29 SET G=""
+30 NEW BUDMEDS1
+31 DO GETMEDS^BUDHUTL2(P,BDATE,EDATE,"BGP IPC ABOVE NORMAL MEDS","",,,.BUDMEDS1,"BGP IPC ABOVE NORMAL RXNORM")
+32 SET X=0
SET T=0
SET W=""
FOR
SET X=$ORDER(BUDMEDS1(X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+33 ;vmed ien
SET Y=$PIECE(BUDMEDS1(X),U,4)
+34 SET V=$PIECE(BUDMEDS1(X),U,5)
+35 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+36 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+37 ;drug ien
SET D=$PIECE(^AUPNVMED(Y,0),U,1)
+38 ;DAYS SUPPLY MUST BE >0
+39 ;date discontinued
SET E=$PIECE(^AUPNVMED(Y,0),U,8)
+40 ;DAYS SUPPLY
SET S=$PIECE(^AUPNVMED(Y,0),U,7)
+41 IF 'S
QUIT
+42 ;at least one day
IF E
IF E'>$PIECE(BUDMEDS1(X),U,1)
QUIT
+43 SET G="Med "_$$VAL^XBDIQ1(9000010.14,Y,.01)_U_$$VD^APCLV(V)
End DoDot:1
+44 IF G]""
QUIT G
+45 ;NOW V POV FOR SNOMED
+46 ;NOW SNOMED USING ASNC
+47 SET T=$ORDER(^BUDHTSSC("B","PXRM BGP IPC ABOVE NORM",0))
+48 SET S=0
FOR
SET S=$ORDER(^BUDHTSSC(T,13,"B",S))
IF S=""!(G)
QUIT
Begin DoDot:1
+49 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+50 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+51 SET Y=9999999-D
+52 IF Y>EDATE
QUIT
+53 IF Y<BDATE
QUIT
+54 SET G="SNOMED: "_S_U_D
End DoDot:2
End DoDot:1
+55 IF G]""
QUIT G
+56 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,S,T,BUDPL,C
+57 SET BUDPL=""
+58 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+59 SET TIEN=$ORDER(^BUDHTSSC("B","T6B ADULTWT OVERWT PLAN CODES",0))
+60 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+61 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+62 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+63 SET C=$$CLINIC^APCLV(VIEN,"C")
IF C]""
IF $DATA(^BUDHTSSC(TIEN,17,"B",C))
SET BUDPL="Clinic "_C_U_VDATE
QUIT
+64 SET X=0
FOR
SET X=$ORDER(^AUPNVPED("AD",VIEN,X))
IF X'=+X!(BUDPL]"")
QUIT
Begin DoDot:2
+65 IF '$DATA(^AUPNVPED(X,0))
QUIT
+66 SET T=$$VALI^XBDIQ1(9000010.16,X,.01)
+67 IF '$DATA(^AUTTEDT(T,0))
QUIT
+68 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+69 IF $PIECE(T,"-",2)="EX"!($PIECE(T,"-",2)="LA")!($PIECE(T,"-",2)="N")!($PIECE(T,"-",2)="DT")!($PIECE(T,"-",2)="MNT")
SET BUDPL=T_U_VDATE
QUIT
+70 IF $PIECE(T,"-",1)="OBS"!($PIECE(T,"-",1)="Z71.3")
SET BUDPL=T_U_VDATE
QUIT
End DoDot:2
+71 ;CPT
+72 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X!(BUDPL]"")
QUIT
Begin DoDot:2
+73 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+74 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+75 IF Y=""
QUIT
+76 IF $DATA(^BUDHTSSC("AC",Y,TIEN))
SET BUDPL="CPT: "_Y_U_VDATE
QUIT
End DoDot:2
+77 ;V TRANS
+78 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X!(BUDPL]"")
QUIT
Begin DoDot:2
+79 IF '$DATA(^AUPNVTC(X,0))
QUIT
+80 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+81 IF Y=""
QUIT
+82 IF $DATA(^BUDHTSSC("AC",Y,TIEN))
SET BUDPL="CPT/TRAN: "_Y_U_VDATE
QUIT
End DoDot:2
+83 ;SNOMED
+84 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X!(BUDPL]"")
QUIT
Begin DoDot:2
+85 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+86 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+87 IF Y]""
IF $DATA(^BUDHTSSC("AS",Y,TIEN))
SET BUDPL="SNOMED: "_Y_U_VDATE
QUIT
+88 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
IF $DATA(^BUDHTSSC("AD",Y,TIEN))
SET BUDPL="DX "_$$VAL^XBDIQ1(9000010.07,X,.01)_U_VDATE
QUIT
End DoDot:2
+89 ;PROVIDER CODES
+90 SET X=0
FOR
SET X=$ORDER(^AUPNVPRV("AD",VIEN,X))
IF X'=+X!(BUDPL]"")
QUIT
Begin DoDot:2
+91 IF '$DATA(^AUPNVPRV(X,0))
QUIT
+92 SET Y=$$VALI^XBDIQ1(9000010.06,X,.01)
+93 IF Y=""
QUIT
+94 SET Y=$$PROVCLSC^XBFUNC1(Y)
+95 IF Y=""
QUIT
+96 IF $DATA(^BUDHTSSC(TIEN,16,"B",Y))
SET BUDPL="Prv: "_Y_U_VDATE
QUIT
End DoDot:2
End DoDot:1
+97 IF BUDPL]""
QUIT BUDPL
+98 ;CHECK PROBLEM LIST FOR SNOMED
+99 SET X=$$PLCL^BUDHDU(P,"T6B ADULTWT PLAN CODES",EDATE,0,BDATE)
IF X
QUIT "PROBLEM SNOMED "_$PIECE(X,U,2)
+100 QUIT ""
BLFU(P,BDATE,EDATE) ;EP
+1 NEW A,B,C,X,Y,Z,T,V,G,BUDV,BUDMEDS1
+2 ;is there a dx
+3 SET X=$$LASTDX^BUDHUTL1(P,"BGP IPC BELOW NORMAL FU DXS",BDATE,EDATE)
IF X]""
QUIT "DX: "_$PIECE(X,U,2)
+4 ;now check cpts
+5 SET T=$ORDER(^ATXAX("B","BGP IPC BELOW NORMAL FU CPTS",0))
+6 IF T
Begin DoDot:1
+7 SET X=$$CPT^BUDHDU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+8 SET X=$$TRAN^BUDHDU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
QUIT "CPT: "_$PIECE(X,U,2)_U_$PIECE(X,U,1)
+9 IF X]""
QUIT X
+10 ;HOW ABOUT REFERRALS BETWEEN BDATE AND EDATE
+11 ;GET ALL VISITS
+12 KILL BUDV
+13 SET G=""
+14 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDV")
+15 SET T=$ORDER(^BUDHTSSC("B","PXRM BGP IPC WT ASMT REFER",0))
+16 SET T1=$ORDER(^BUDHTSSC("B","PXRM BGP IPC UNDERWEIGHT",0))
+17 SET X=0
FOR
SET X=$ORDER(BUDV(X))
IF X'=+X!(G)
QUIT
SET Y=$PIECE(BUDV(X),U,5)
Begin DoDot:1
+18 IF '$DATA(^AUPNVREF("AD",Y))
QUIT
+19 SET Z=0
FOR
SET Z=$ORDER(^AUPNVREF("AD",Y,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:2
+20 SET S=$PIECE($GET(^AUPNVREF(Z,0)),U,1)
IF S=""
QUIT
+21 IF '$DATA(^BUDHTSSC(T,13,"B",S))
QUIT
+22 ;NOW GO GET SNOMED REASON
+23 SET R=$PIECE($GET(^AUPNVREF(Z,0)),U,6)
+24 IF 'R
QUIT
+25 IF '$DATA(^BMCREF(R,0))
QUIT
+26 SET A=0
SET G=""
FOR
SET A=$ORDER(^BMCREF(R,22,"B",A))
IF A=""!(G)
QUIT
IF $DATA(^BUDHTSSC(T1,13,"B",A))
SET G="Refer: "_S_"/"_A_U_$$VD^APCLV(Y)
End DoDot:2
End DoDot:1
+27 IF G]""
QUIT G
+28 ;NOW MEDS
+29 SET G=""
+30 DO GETMEDS^BUDHUTL2(P,BDATE,EDATE,"BGP IPC BELOW NORMAL MEDS","",,,.BUDMEDS1,"BGP IPC BELOW NORMAL RXNORM")
+31 SET X=0
SET T=0
SET W=""
FOR
SET X=$ORDER(BUDMEDS1(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+32 ;vmed ien
SET Y=$PIECE(BUDMEDS1(X),U,4)
+33 SET V=$PIECE(BUDMEDS1(X),U,5)
+34 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+35 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+36 ;drug ien
SET D=$PIECE(^AUPNVMED(Y,0),U,1)
+37 ;DAYS SUPPLY MUST BE >0
+38 ;date discontinued
SET E=$PIECE(^AUPNVMED(Y,0),U,8)
+39 ;DAYS SUPPLY
SET S=$PIECE(^AUPNVMED(Y,0),U,7)
+40 IF 'S
QUIT
+41 ;at least one day
IF E
IF E'>$PIECE(BUDMEDS1(X),U,1)
QUIT
+42 SET G="Med "_$$VAL^XBDIQ1(9000010.14,Y,.01)_U_$$VD^APCLV(V)
End DoDot:1
+43 IF G]""
QUIT G
+44 ;NOW V POV FOR SNOMED
+45 ;NOW SNOMED USING ASNC
+46 SET T=$ORDER(^BUDHTSSC("B","PXRM BGP IPC BELOW NORM",0))
+47 SET G=""
+48 SET S=0
FOR
SET S=$ORDER(^BUDHTSSC(T,13,"B",S))
IF S=""!(G)
QUIT
Begin DoDot:1
+49 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+50 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+51 SET Y=9999999-D
+52 IF Y>EDATE
QUIT
+53 IF Y<BDATE
QUIT
+54 SET G="SNOMED: "_S_U_D
End DoDot:2
End DoDot:1
+55 IF G]""
QUIT G
+56 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,S,T,BUDPL,C
+57 SET BUDPL=""
+58 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+59 SET TIEN=$ORDER(^BUDHTSSC("B","T6B ADULTWT OVERWT PLAN CODES",0))
+60 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+61 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+62 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+63 ;S C=$$CLINIC^APCLV(VIEN,"C") I C]"",$D(^BUDHTSSC(TIEN,17,"B",C)) S BUDPL="Clinic "_C_U_VDATE Q
+64 SET X=0
FOR
SET X=$ORDER(^AUPNVPED("AD",VIEN,X))
IF X'=+X!(BUDPL]"")
QUIT
Begin DoDot:2
+65 IF '$DATA(^AUPNVPED(X,0))
QUIT
+66 SET T=$$VALI^XBDIQ1(9000010.16,X,.01)
+67 IF '$DATA(^AUTTEDT(T,0))
QUIT
+68 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+69 IF $PIECE(T,"-",2)="EX"!($PIECE(T,"-",2)="LA")!($PIECE(T,"-",2)="N")!($PIECE(T,"-",2)="DT")!($PIECE(T,"-",2)="MNT")
SET BUDPL=T_U_VDATE
QUIT
+70 IF $PIECE(T,"-",1)="Z71.3"
SET BUDPL=T_U_VDATE
QUIT
End DoDot:2
+71 ;PROVIDER CODES
+72 SET X=0
FOR
SET X=$ORDER(^AUPNVPRV("AD",VIEN,X))
IF X'=+X!(BUDPL]"")
QUIT
Begin DoDot:2
+73 IF '$DATA(^AUPNVPRV(X,0))
QUIT
+74 SET Y=$$VALI^XBDIQ1(9000010.06,X,.01)
+75 IF Y=""
QUIT
+76 SET Y=$$PROVCLSC^XBFUNC1(Y)
+77 IF Y=""
QUIT
+78 IF $DATA(^BUDHTSSC(TIEN,16,"B",Y))
SET BUDPL="Prv: "_Y_U_VDATE
QUIT
End DoDot:2
End DoDot:1
+79 IF BUDPL]""
QUIT BUDPL
+80 QUIT ""
