BUDARP6U ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2013 5:11 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
G2 ;EP
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUDX28RB=($E(BUDBD,1,3)-18)_"1231"
Q:BUDDOB>BUDX28RB
Q:BUDMEDV<1
S BUDX28TH=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)
I '$$VBBD^BUDARP6V(DFN,$$FMADD^XLFDT(BUDX28TH,1),BUDED) Q ;quit if no visiT before 17TH birthday
S X=$$GETV^BUDARP6U(DFN,BUDDOB,BUDED,BUDSITE)
Q:X<2
K BUDTOBS,BUDTOBD,BUDTOBC
S BUDTOBDD=$E(BUDBD,1,3)-1_$E(BUDBD,4,7)
S BUDTOBS=$$TOBACCO(DFN,BUDTOBDD,BUDED)
I BUDTOBS="" S BUDTOBC=$$TOBCESS(DFN,BUDTOBDD,BUDED) I BUDTOBC]"" S ^XTMP("BUDARP6B",BUDJ,BUDH,"TCI2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDTOBS,U,1)_U_$P(BUDTOBC,U,1) Q
I BUDTOBS="" Q ;COUNSELING??
S BUDTOBC=$$TOBCESS(DFN,BUDTOBDD,BUDED)
I BUDTOBC]"" S BUDSECG2("ATOB")=$G(BUDSECG2("ATOB"))+1
;put the rest in demoninator
S BUDSECG2("PTS")=$G(BUDSECG2("PTS"))+1 D
.I $G(BUDTCI2L) D
..I BUDTOBC="" S ^XTMP("BUDARP6B",BUDJ,BUDH,"TCI2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDTOBS,U,1)_U_$P(BUDTOBC,U,1)
.I $G(BUDTCI1L) D
..I BUDTOBC]"" S ^XTMP("BUDARP6B",BUDJ,BUDH,"TCI1",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDTOBS,U,1)_U_$P(BUDTOBC,U,1)
Q
;
TOBACCO(P,BDATE,EDATE) ;
NEW H,D,O,X,Y,V,F,C
S X=0,Y="" F S X=$O(^AUPNVHF("AC",P,X)) Q:X'=+X!(Y]"") D
.Q:'$D(^AUPNVHF(X,0))
.S V=$P(^AUPNVHF(X,0),U,3)
.S D=$$VD^APCLV(V)
.Q:D>EDATE ;after time frame
.Q:D<BDATE ;before time frame
.S H=$P(^AUPNVHF(X,0),U,1)
.S F=$P($G(^AUTTHF(H,0)),U,1)
.S G=0
.I F="CURRENT SMOKELESS" S G=1
.I F="CESSATION-SMOKER" S G=1
.I F="CESSATION-SMOKELESS" S G=1
.I F="CURRENT SMOKER, STATUS UNKNOWN" S G=1
.I F="CURRENT SMOKER, EVERY DAY" S G=1
.I F="CURRENT SMOKER, SOME DAY" S G=1
.Q:'G
.S Y=F_U_D
.Q
I Y]"" Q Y
;NOW CHECK DX
S Y=$$LASTDX^BUDAUTL1(P,"BUD TOBACCO SCREEN DXS",BDATE,EDATE)
I Y S Y=$P(Y,U,2)_U_$P(Y,U,3) Q Y
S Y=$$CPTI^BUDADU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("1034F"),U,1))
I Y S Y="1034F"_U_$P(Y,U,2) Q Y
S Y=$$CPTI^BUDADU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("1035F"),U,1))
I Y S Y="1035F"_U_$P(Y,U,2) Q Y
Q ""
;
TOBCESS(P,BDATE,EDATE,PDATE) ;EP
NEW Y,X,E,D,T,%,BUDG
S Y="BUDG("
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
;I '$D(BUDG) Q ""
S (X,D)=0,%="",T="" F S X=$O(BUDG(X)) Q:X'=+X!(%]"") D
.S T=$P(^AUPNVPED(+$P(BUDG(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I $P(T,"-")="TO" S %=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-",2)="TO" S %=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-",2)="SHS" S %=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="99406" S %=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="99407" S %=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="4000F" S %=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="4001F" S %=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
I %]"" Q %
S Y=""
S Y=$$CPTI^BUDADU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("99406"),U,1))
I Y S Y="99406"_U_$P(Y,U,2) Q Y
S Y=$$CPTI^BUDADU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("99407"),U,1))
I Y S Y="99407"_U_$P(Y,U,2) Q Y
S Y=$$CPTI^BUDADU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("4000F"),U,1))
I Y S Y="4000F"_U_$P(Y,U,2) Q Y
S Y=$$CPTI^BUDADU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("4001F"),U,1))
I Y S Y="4001F"_U_$P(Y,U,2) Q Y
NEW BUDMEDS1,T1,M,E,G,Z,N,C,BUDLPED
S BUDLPED=""
D GETMEDS^BUDAUTL2(P,BDATE,EDATE,,,,,.BUDMEDS1)
;I '$D(BUDMEDS1) G PEDREF
S T=$O(^ATXAX("B","BGP CMS SMOKING CESSATION MEDS",0))
S T1=$O(^ATXAX("B","BGP CMS SMOKING CESSATION NDC",0))
S (X,G,M,E)=0,D="" F S X=$O(BUDMEDS1(X)) Q:X'=+X S V=$P(BUDMEDS1(X),U,5),Y=+$P(BUDMEDS1(X),U,4) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
.S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
.Q:'Z
.S N=$P($G(^PSDRUG(Z,0)),U)
.I $D(^ATXAX(T,21,"B",Z)) I $P(BUDLPED,U)<$P($P(^AUPNVSIT(V,0),U),".") S BUDLPED=$P($P(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N Q
.I $D(^ATXAX(T,21,"B",Z))!(N["NICOTINE PATCH")!(N["NICOTINE POLACRILEX")!(N["NICOTINE INHALER")!(N["NICOTINE NASAL SPRAY") D
..I $P(BUDLPED,U)<$P($P(^AUPNVSIT(V,0),U),".") S BUDLPED=$P($P(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
.S C=$P($G(^PSDRUG(Z,2)),U,4)
.I C]"",$D(^ATXAX(T1,21,"B",C)) I $P(BUDLPED,U)<$P($P(^AUPNVSIT(V,0),U),".") S BUDLPED=$P($P(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
I BUDLPED]"" Q $P(BUDLPED,U,2)_U_$P(BUDLPED,U,1) ;BUDLPED
Q ""
NDC(A,B) ;
;a is drug ien
;b is taxonomy ien
NEW BUDNDC
S BUDNDC=$P($G(^PSDRUG(A,2)),U,4)
I BUDNDC]"",B,$D(^ATXAX(B,21,"B",BUDNDC)) Q 1
Q 0
H ;EP ; ASTHMA
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUD40RB=($E(BUDBD,1,3)-40)_"0101"
S BUD5RB=($E(BUDED,1,3)-5)_"1231"
Q:BUDDOB>BUD5RB
Q:BUDDOB<BUD40RB
S Z=($E(BUDDOB,1,3)+5)_$E(BUDDOB,4,7)
Q:$$VD^APCLV(BUDLASTV)<Z
S Z=($E(BUDDOB,1,3)+40)_$E(BUDDOB,4,7)
Q:$$VD^APCLV(BUDLASTV)>Z
;S B=$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),1)
;S A=$$AGE^AUPNPAT(DFN,B)
;I A<5 Q
;I A>40 Q
Q:BUDMEDV<1
S X=$$GETV(DFN,BUDDOB,BUDED,BUDSITE)
Q:X<2
Q:$$PROBAS1(DFN,BUDDOB,BUDED)=1 ;eliminate anyone with severity 1 on PL
Q:$$ASTALG(DFN,BUDED) ;eliminate those with an allergy to a controller
Q:$$SABA(DFN,BUDBD,BUDED) ;if only SABA, quit
;eliminate those with an allergy to a drug in the BUD PQA CONTROLLERS or NDC
K ^TMP($J,"A")
S BUDAST=$$ASTHMA(DFN,BUDBD,BUDED) ;no diagnosis of asthma during time period
K ^TMP($J,"A")
I BUDAST="" S X="",X=$$ASTHTHER(DFN,BUDBD,BUDED) I X]"" S ^XTMP("BUDARP6B",BUDJ,BUDH,"APT2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDAST,U)_U_$P(X,U,2) Q
Q:BUDAST="" ;no asthma diagnosis
Q:$$AST1039(DFN,$P(BUDAST,U,2),BUDED)]"" ;had a 1039f after the asthma dx/1038f
S BUDASTT=$$ASTHTHER(DFN,BUDBD,BUDED)
I BUDASTT]"" S BUDSECTH("APT")=$G(BUDSECTH("APT"))+1
;put the rest in demoninator
S BUDSECTH("PTS")=$G(BUDSECTH("PTS"))+1 D
.I $G(BUDAPT2L) D
..I BUDASTT="" S ^XTMP("BUDARP6B",BUDJ,BUDH,"APT2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDAST,U)_U_$P(BUDASTT,U,2)
.I $G(BUDAPT1L) D
..I BUDASTT]"" S ^XTMP("BUDARP6B",BUDJ,BUDH,"APT1",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDAST,U)_U_$P(BUDASTT,U,2)
Q
SABA(P,BD,ED) ;
NEW BUDMEDS1,G,A,C,M,V,V1D,BGPHSABA
S G="",BGPHSABA=""
D GETMEDS^BUDAUTL2(P,BD,ED,"BGP PQA SABA MEDS","BGP PQA SABA NDC",,,.BUDMEDS1)
I '$D(BUDMEDS1) Q G ; no SABA meds
S BUDISD=""
S A=0,C="" F S A=$O(BUDMEDS1(A)) Q:A'=+A!(C) D
.S M=$P(BUDMEDS1(A),U,4) ;IEN OF V MED
.Q:'$D(^AUPNVMED(M,0))
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BUDMEDS1(A) Q
.I $$STATDC(M) K BUDMEDS1(A) Q ;d/c'ed BY PROVIDER OR EDIT
.S V=$P(BUDMEDS1(A),U,5)
.S V1D=$$VD^APCLV(V)
.S C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
I C S BGPHSABA=1
I 'BGPHSABA Q ""
S G=""
D GETMEDS^BUDAUTL2(P,BD,ED,"BGP PQA CONTROLLER MEDS","BGP PQA CONTROLLER NDC",,,.BUDMEDS1)
I '$D(BUDMEDS1) Q 1 ; no CONTROLLER meds BUT HAS SABA
S BUDISD=""
S A=0,C="" F S A=$O(BUDMEDS1(A)) Q:A'=+A!(C) D
.S M=$P(BUDMEDS1(A),U,4) ;IEN OF V MED
.Q:'$D(^AUPNVMED(M,0))
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BUDMEDS1(A) Q
.I $$STATDC(M) K BUDMEDS1(A) Q ;d/c'ed BY PROVIDER OR EDIT
.S V=$P(BUDMEDS1(A),U,5)
.S V1D=$$VD^APCLV(V)
.S C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
I C Q 0
Q 1
ASTALG(P,ED) ;
;allergy tracking
NEW BUDC,X,N,G,Y,T,T1,S,A,B,C
S T=$O(^ATXAX("B","BGP PQA CONTROLLER MEDS",0))
S T1=$O(^ATXAX("B","BGP PQA CONTROLLER NDC",0))
S BUDC=0
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X D
.Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>ED ;entered after end date
.S N=$P($G(^GMR(120.8,X,0)),U,3)
.;IF PSDRUG CHECK AGAINST MEDS TAXONOMY
.I N["PSDRUG"!(N["PSNDF") D I BUDC Q 1
..S Y=+N
..I T,$D(^ATXAX(T,21,"AA",Y)) S BUDC=1
..S D=$P($G(^PSDRUG(Y,2)),U,4)
..I D,$D(^ATXAX(T1,21,"AA",D)) S BUDC=1
.;check name for the heck of it
.S S=$P(^GMR(120.8,X,0),U,2) ;NAME OF THING THEY ARE ALLERGIC TO
.S A=0 F S A=$O(^ATXAX(T,21,A)) Q:A'=+A D
..S B=$P($G(^ATXAX(T,21,A,0)),U,1)
..I $P($G(^PSDRUG(B,0)),U,1)=S S BUDC=1 Q
Q BUDC
;
PROBAS1(P,BDATE,EDATE) ;EP
NEW S,A,B,T,X,G,V,Y,Z
S G=""
S T=$O(^ATXAX("B","BUD ASTHMA DXS",0))
S X=0,G="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.S Z=$P(^AUPNPROB(X,0),U,13)
.I Z="" S Z=$P(^AUPNPROB(X,0),U,8)
.Q:Z>EDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:$P(^AUPNPROB(X,0),U,12)'="A"
.Q:'$$ICD^ATXCHK(Y,T,9)
.Q:$P(^AUPNPROB(X,0),U,15)=""
.S G(9999999-$P(^AUPNPROB(X,0),U,3))=$P(^AUPNPROB(X,0),U,15)
.Q
S X=$O(G(0)) I X Q G(X)
S EDATE1=9999999-EDATE-1
S D=$O(^AUPNVAST("AS",P,EDATE1))
I 'D Q ""
;I D>(9999999-BDATE) Q ""
S LAST="",E=0 F S E=$O(^AUPNVAST("AS",P,D,E)) Q:E'=+E S LAST=E
I 'LAST Q ""
S S=^AUPNVAST("AS",P,D,LAST)
Q S
;
ASTHMA(P,BDATE,EDATE) ;EP
I '$D(^AUPNVSIT("AC",P)) Q ""
NEW A,B,E,T,G,X,V,Y
K G
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S T=$O(^ATXAX("B","BUD ASTHMA DXS",0))
I 'T Q ""
S X=0,G="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y D
..S D=0
..I $D(^AUPNVPOV(Y,0)) S %=$P(^AUPNVPOV(Y,0),U)
..I $$ICD^ATXCHK(%,T,9) S D=1
..Q:'D
..S G($$VD^APCLV(V))=$$VAL^XBDIQ1(9000010.07,Y,.01)
..Q
;NOW CHECK FOR A CPT OF 1038F
S Y=""
S Y=$$CPTI^BUDADU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("1038F"),U,1))
I Y S G($P(Y,U,2))="CPT: 1038F"
S Y=$$CPTI^BUDADU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("4015F"),U,1))
I Y S G($P(Y,U,2))="CPT: 4015F"
S Y=$O(G(""),-1)
;W !,P," ",Y," " ZW G
I Y="" Q ""
S X=G(Y)
Q X_" on "_$$FMTE^XLFDT(Y)_U_Y
;
AST1039(P,BDATE,EDATE) ;EP
I '$D(^AUPNVSIT("AC",P)) Q ""
NEW A,B,E,T,G,X,V,Y
K G
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S Y=""
S Y=$$CPTI^BUDADU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("1039F"),U,1))
I Y S G($P(Y,U,2))="CPT: 1039F"
S Y=$O(G(""),-1) I Y="" Q ""
S X=G(Y)
Q X_" on "_$$FMTE^XLFDT(Y)_U_Y
ASTHTHER(P,BD,ED) ;
NEW BUDMEDS1,G,A,C,M,V,V1D
S G=""
D GETMEDS^BUDAUTL2(P,BD,ED,"BGP PQA CONTROLLER MEDS","BGP PQA CONTROLLER NDC",,,.BUDMEDS1)
I '$D(BUDMEDS1) Q G ; no CONTROLLER meds
S BUDISD=""
S A=0,C="" F S A=$O(BUDMEDS1(A)) Q:A'=+A!(C) D
.S M=$P(BUDMEDS1(A),U,4) ;IEN OF V MED
.Q:'$D(^AUPNVMED(M,0))
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BUDMEDS1(A) Q
.I $$STATDC(M) K BUDMEDS1(A) Q ;d/c'ed BY PROVIDER OR EDIT
.S V=$P(BUDMEDS1(A),U,5)
.S V1D=$$VD^APCLV(V)
.S C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
I C Q C
Q ""
;
STATDC(V) ;EP - is the prescription associated with this V MED discontinued?
I '$G(V) Q ""
I '$D(^AUPNVMED(V,0)) Q 0
NEW P,S,X
S P=$S($D(^PSRX("APCC",V)):$O(^(V,0)),1:0)
I 'P Q 0
S X=$P($G(^PSRX(P,0)),U,15)
I X=12 Q 1
I X=13 Q 1
I X=14 Q 1
I X=15 Q 1
S X=$P($G(^PSRX(P,"STA")),U,1)
I X=12 Q 1
I X=13 Q 1
I X=14 Q 1
I X=15 Q 1
Q 0
GETV(P,BD,ED,SITE) ;EP - get all visits for this patient and COUNT MEDICAL VISITS
NEW TV,T35V,T6V,MEDV,MEDVI,LASTV,A,X,VLOC,CLINC,TIEN,VSIT,VDATE,PP,S,LINE,D
S TV=0,T35V=0,T6V=0,MEDV=0,MEDVI="",LASTV=""
S A="A(""VISITS"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED),E=$$START1^APCLDF(B,A)
S X=0 F S X=$O(A("VISITS",X)) Q:X'=+X!(MEDV>1) S VSIT=$P(A("VISITS",X),U,5) D
.Q:'$D(^AUPNVSIT(VSIT,0))
.Q:'$P(^AUPNVSIT(VSIT,0),U,9)
.Q:$P(^AUPNVSIT(VSIT,0),U,11)
.S VLOC=$P(^AUPNVSIT(VSIT,0),U,6)
.Q:VLOC=""
.Q:'$D(^BUDQSITE(SITE,11,VLOC)) ;not valid location
.Q:"AHSORMEI"'[$P(^AUPNVSIT(VSIT,0),U,7)
.S CLINC=$$CLINIC^APCLV(VSIT,"C")
.S TIEN=$O(^BUDQCNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))
.I CLINC]"",$D(^BUDQCNTL(TIEN,11,"B",CLINC)) Q ;not a clinic code we want in any table
.;now eliminate subsequent visits to same provider on same day = item 4 in SRD visit definition
.S VDATE=$$VD^APCLV(VSIT)
.S PP=$$PRIMPROV^APCLV(VSIT,"I")
.I $P(^AUPNVSIT(VSIT,0),U,7)="I" Q ;don't count I visits
.I '$D(^AUPNVPOV("AD",VSIT)) Q
.S S=0
.I PP]"" D
..S D=$P($G(A("SAMEPROV",P,VDATE,PP)),U,1)
..I D]"",D'>$P(^AUPNVSIT(VSIT,0),U) S S=1 Q ;already had a visit to this provider on this date
..S A("SAMEPROV",P,VDATE,PP)=$P(^AUPNVSIT(VSIT,0),U)_U_VSIT
.Q:S ;quit if already had a visit to this provider
.S PP=$$PRIMPROV^APCLV(VSIT,"D")
.I PP="" Q
MEDC .;NOW CHECK FOR MEDICAL CARE, CAN ONLY HAVE 1 PER LOCATION OF ENCOUNTER
.S S=0
.S TIEN=$O(^BUDQCNTL("B","MEDICAL CARE LINE NUMBERS",0))
.;S PP=$$PRIMPROV^APCLV(VSIT,"D")
.I $E($$VAL^XBDIQ1(9000010,VSIT,.06),1,3)="CHS",PP=15 S LINE=2 G MEDC1
.S Y=$O(^BUDQTFIV("C",PP,0)) I Y="" S LINE=35 G MEDC1
.S LINE=$O(^BUDQTFIV("AA",PP,""))
MEDC1 .S S=0
.I $D(^BUDQCNTL(TIEN,11,"B",LINE)) D
..S D=$P($G(A("MEDCARE",P,VDATE,VLOC,TIEN)),U,1)
..I D]"",D'>$P(^AUPNVSIT(VSIT,0),U) S S=1 Q ;already have a medical care visit on this date
..S A("MEDCARE",P,VDATE,VLOC,TIEN)=$P(^AUPNVSIT(VSIT,0),U)_U_VSIT
..S MEDV=MEDV+1,MEDVI=VSIT
..Q
Q MEDV
BUDARP6U ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2013 5:11 PM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
+3 ;
G2 ;EP
+1 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+2 SET BUDX28RB=($EXTRACT(BUDBD,1,3)-18)_"1231"
+3 IF BUDDOB>BUDX28RB
QUIT
+4 IF BUDMEDV<1
QUIT
+5 SET BUDX28TH=$EXTRACT(BUDDOB,1,3)+18_$EXTRACT(BUDDOB,4,7)
+6 ;quit if no visiT before 17TH birthday
IF '$$VBBD^BUDARP6V(DFN,$$FMADD^XLFDT(BUDX28TH,1),BUDED)
QUIT
+7 SET X=$$GETV^BUDARP6U(DFN,BUDDOB,BUDED,BUDSITE)
+8 IF X<2
QUIT
+9 KILL BUDTOBS,BUDTOBD,BUDTOBC
+10 SET BUDTOBDD=$EXTRACT(BUDBD,1,3)-1_$EXTRACT(BUDBD,4,7)
+11 SET BUDTOBS=$$TOBACCO(DFN,BUDTOBDD,BUDED)
+12 IF BUDTOBS=""
SET BUDTOBC=$$TOBCESS(DFN,BUDTOBDD,BUDED)
IF BUDTOBC]""
SET ^XTMP("BUDARP6B",BUDJ,BUDH,"TCI2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=$PIECE(BUDTOBS,U,1)_U_$PIECE(BUDTOBC,U,1)
QUIT
+13 ;COUNSELING??
IF BUDTOBS=""
QUIT
+14 SET BUDTOBC=$$TOBCESS(DFN,BUDTOBDD,BUDED)
+15 IF BUDTOBC]""
SET BUDSECG2("ATOB")=$GET(BUDSECG2("ATOB"))+1
+16 ;put the rest in demoninator
+17 SET BUDSECG2("PTS")=$GET(BUDSECG2("PTS"))+1
Begin DoDot:1
+18 IF $GET(BUDTCI2L)
Begin DoDot:2
+19 IF BUDTOBC=""
SET ^XTMP("BUDARP6B",BUDJ,BUDH,"TCI2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=$PIECE(BUDTOBS,U,1)_U_$PIECE(BUDTOBC,U,1)
End DoDot:2
+20 IF $GET(BUDTCI1L)
Begin DoDot:2
+21 IF BUDTOBC]""
SET ^XTMP("BUDARP6B",BUDJ,BUDH,"TCI1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=$PIECE(BUDTOBS,U,1)_U_$PIECE(BUDTOBC,U,1)
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
TOBACCO(P,BDATE,EDATE) ;
+1 NEW H,D,O,X,Y,V,F,C
+2 SET X=0
SET Y=""
FOR
SET X=$ORDER(^AUPNVHF("AC",P,X))
IF X'=+X!(Y]"")
QUIT
Begin DoDot:1
+3 IF '$DATA(^AUPNVHF(X,0))
QUIT
+4 SET V=$PIECE(^AUPNVHF(X,0),U,3)
+5 SET D=$$VD^APCLV(V)
+6 ;after time frame
IF D>EDATE
QUIT
+7 ;before time frame
IF D<BDATE
QUIT
+8 SET H=$PIECE(^AUPNVHF(X,0),U,1)
+9 SET F=$PIECE($GET(^AUTTHF(H,0)),U,1)
+10 SET G=0
+11 IF F="CURRENT SMOKELESS"
SET G=1
+12 IF F="CESSATION-SMOKER"
SET G=1
+13 IF F="CESSATION-SMOKELESS"
SET G=1
+14 IF F="CURRENT SMOKER, STATUS UNKNOWN"
SET G=1
+15 IF F="CURRENT SMOKER, EVERY DAY"
SET G=1
+16 IF F="CURRENT SMOKER, SOME DAY"
SET G=1
+17 IF 'G
QUIT
+18 SET Y=F_U_D
+19 QUIT
End DoDot:1
+20 IF Y]""
QUIT Y
+21 ;NOW CHECK DX
+22 SET Y=$$LASTDX^BUDAUTL1(P,"BUD TOBACCO SCREEN DXS",BDATE,EDATE)
+23 IF Y
SET Y=$PIECE(Y,U,2)_U_$PIECE(Y,U,3)
QUIT Y
+24 SET Y=$$CPTI^BUDADU(P,BDATE,EDATE,$PIECE($$CPT^ICPTCOD("1034F"),U,1))
+25 IF Y
SET Y="1034F"_U_$PIECE(Y,U,2)
QUIT Y
+26 SET Y=$$CPTI^BUDADU(P,BDATE,EDATE,$PIECE($$CPT^ICPTCOD("1035F"),U,1))
+27 IF Y
SET Y="1035F"_U_$PIECE(Y,U,2)
QUIT Y
+28 QUIT ""
+29 ;
TOBCESS(P,BDATE,EDATE,PDATE) ;EP
+1 NEW Y,X,E,D,T,%,BUDG
+2 SET Y="BUDG("
+3 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 ;I '$D(BUDG) Q ""
+5 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+6 SET T=$PIECE(^AUPNVPED(+$PIECE(BUDG(X),U,4),0),U)
+7 IF 'T
QUIT
+8 IF '$DATA(^AUTTEDT(T,0))
QUIT
+9 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+10 IF $PIECE(T,"-")="TO"
SET %=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+11 IF $PIECE(T,"-",2)="TO"
SET %=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+12 IF $PIECE(T,"-",2)="SHS"
SET %=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+13 IF $PIECE(T,"-")="99406"
SET %=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+14 IF $PIECE(T,"-")="99407"
SET %=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+15 IF $PIECE(T,"-")="4000F"
SET %=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+16 IF $PIECE(T,"-")="4001F"
SET %=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
End DoDot:1
+17 IF %]""
QUIT %
+18 SET Y=""
+19 SET Y=$$CPTI^BUDADU(P,BDATE,EDATE,$PIECE($$CPT^ICPTCOD("99406"),U,1))
+20 IF Y
SET Y="99406"_U_$PIECE(Y,U,2)
QUIT Y
+21 SET Y=$$CPTI^BUDADU(P,BDATE,EDATE,$PIECE($$CPT^ICPTCOD("99407"),U,1))
+22 IF Y
SET Y="99407"_U_$PIECE(Y,U,2)
QUIT Y
+23 SET Y=$$CPTI^BUDADU(P,BDATE,EDATE,$PIECE($$CPT^ICPTCOD("4000F"),U,1))
+24 IF Y
SET Y="4000F"_U_$PIECE(Y,U,2)
QUIT Y
+25 SET Y=$$CPTI^BUDADU(P,BDATE,EDATE,$PIECE($$CPT^ICPTCOD("4001F"),U,1))
+26 IF Y
SET Y="4001F"_U_$PIECE(Y,U,2)
QUIT Y
+27 NEW BUDMEDS1,T1,M,E,G,Z,N,C,BUDLPED
+28 SET BUDLPED=""
+29 DO GETMEDS^BUDAUTL2(P,BDATE,EDATE,,,,,.BUDMEDS1)
+30 ;I '$D(BUDMEDS1) G PEDREF
+31 SET T=$ORDER(^ATXAX("B","BGP CMS SMOKING CESSATION MEDS",0))
+32 SET T1=$ORDER(^ATXAX("B","BGP CMS SMOKING CESSATION NDC",0))
+33 SET (X,G,M,E)=0
SET D=""
FOR
SET X=$ORDER(BUDMEDS1(X))
IF X'=+X
QUIT
SET V=$PIECE(BUDMEDS1(X),U,5)
SET Y=+$PIECE(BUDMEDS1(X),U,4)
Begin DoDot:1
+34 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+35 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+36 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+37 IF 'Z
QUIT
+38 SET N=$PIECE($GET(^PSDRUG(Z,0)),U)
+39 IF $DATA(^ATXAX(T,21,"B",Z))
IF $PIECE(BUDLPED,U)<$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET BUDLPED=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
QUIT
+40 IF $DATA(^ATXAX(T,21,"B",Z))!(N["NICOTINE PATCH")!(N["NICOTINE POLACRILEX")!(N["NICOTINE INHALER")!(N["NICOTINE NASAL SPRAY")
Begin DoDot:2
+41 IF $PIECE(BUDLPED,U)<$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET BUDLPED=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
End DoDot:2
+42 SET C=$PIECE($GET(^PSDRUG(Z,2)),U,4)
+43 IF C]""
IF $DATA(^ATXAX(T1,21,"B",C))
IF $PIECE(BUDLPED,U)<$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET BUDLPED=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
End DoDot:1
+44 ;BUDLPED
IF BUDLPED]""
QUIT $PIECE(BUDLPED,U,2)_U_$PIECE(BUDLPED,U,1)
+45 QUIT ""
NDC(A,B) ;
+1 ;a is drug ien
+2 ;b is taxonomy ien
+3 NEW BUDNDC
+4 SET BUDNDC=$PIECE($GET(^PSDRUG(A,2)),U,4)
+5 IF BUDNDC]""
IF B
IF $DATA(^ATXAX(B,21,"B",BUDNDC))
QUIT 1
+6 QUIT 0
H ;EP ; ASTHMA
+1 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+2 SET BUD40RB=($EXTRACT(BUDBD,1,3)-40)_"0101"
+3 SET BUD5RB=($EXTRACT(BUDED,1,3)-5)_"1231"
+4 IF BUDDOB>BUD5RB
QUIT
+5 IF BUDDOB<BUD40RB
QUIT
+6 SET Z=($EXTRACT(BUDDOB,1,3)+5)_$EXTRACT(BUDDOB,4,7)
+7 IF $$VD^APCLV(BUDLASTV)<Z
QUIT
+8 SET Z=($EXTRACT(BUDDOB,1,3)+40)_$EXTRACT(BUDDOB,4,7)
+9 IF $$VD^APCLV(BUDLASTV)>Z
QUIT
+10 ;S B=$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),1)
+11 ;S A=$$AGE^AUPNPAT(DFN,B)
+12 ;I A<5 Q
+13 ;I A>40 Q
+14 IF BUDMEDV<1
QUIT
+15 SET X=$$GETV(DFN,BUDDOB,BUDED,BUDSITE)
+16 IF X<2
QUIT
+17 ;eliminate anyone with severity 1 on PL
IF $$PROBAS1(DFN,BUDDOB,BUDED)=1
QUIT
+18 ;eliminate those with an allergy to a controller
IF $$ASTALG(DFN,BUDED)
QUIT
+19 ;if only SABA, quit
IF $$SABA(DFN,BUDBD,BUDED)
QUIT
+20 ;eliminate those with an allergy to a drug in the BUD PQA CONTROLLERS or NDC
+21 KILL ^TMP($JOB,"A")
+22 ;no diagnosis of asthma during time period
SET BUDAST=$$ASTHMA(DFN,BUDBD,BUDED)
+23 KILL ^TMP($JOB,"A")
+24 IF BUDAST=""
SET X=""
SET X=$$ASTHTHER(DFN,BUDBD,BUDED)
IF X]""
SET ^XTMP("BUDARP6B",BUDJ,BUDH,"APT2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=$PIECE(BUDAST,U)_U_$PIECE(X,U,2)
QUIT
+25 ;no asthma diagnosis
IF BUDAST=""
QUIT
+26 ;had a 1039f after the asthma dx/1038f
IF $$AST1039(DFN,$PIECE(BUDAST,U,2),BUDED)]""
QUIT
+27 SET BUDASTT=$$ASTHTHER(DFN,BUDBD,BUDED)
+28 IF BUDASTT]""
SET BUDSECTH("APT")=$GET(BUDSECTH("APT"))+1
+29 ;put the rest in demoninator
+30 SET BUDSECTH("PTS")=$GET(BUDSECTH("PTS"))+1
Begin DoDot:1
+31 IF $GET(BUDAPT2L)
Begin DoDot:2
+32 IF BUDASTT=""
SET ^XTMP("BUDARP6B",BUDJ,BUDH,"APT2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=$PIECE(BUDAST,U)_U_$PIECE(BUDASTT,U,2)
End DoDot:2
+33 IF $GET(BUDAPT1L)
Begin DoDot:2
+34 IF BUDASTT]""
SET ^XTMP("BUDARP6B",BUDJ,BUDH,"APT1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=$PIECE(BUDAST,U)_U_$PIECE(BUDASTT,U,2)
End DoDot:2
End DoDot:1
+35 QUIT
SABA(P,BD,ED) ;
+1 NEW BUDMEDS1,G,A,C,M,V,V1D,BGPHSABA
+2 SET G=""
SET BGPHSABA=""
+3 DO GETMEDS^BUDAUTL2(P,BD,ED,"BGP PQA SABA MEDS","BGP PQA SABA NDC",,,.BUDMEDS1)
+4 ; no SABA meds
IF '$DATA(BUDMEDS1)
QUIT G
+5 SET BUDISD=""
+6 SET A=0
SET C=""
FOR
SET A=$ORDER(BUDMEDS1(A))
IF A'=+A!(C)
QUIT
Begin DoDot:1
+7 ;IEN OF V MED
SET M=$PIECE(BUDMEDS1(A),U,4)
+8 IF '$DATA(^AUPNVMED(M,0))
QUIT
+9 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
KILL BUDMEDS1(A)
QUIT
+10 ;d/c'ed BY PROVIDER OR EDIT
IF $$STATDC(M)
KILL BUDMEDS1(A)
QUIT
+11 SET V=$PIECE(BUDMEDS1(A),U,5)
+12 SET V1D=$$VD^APCLV(V)
+13 SET C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
End DoDot:1
+14 IF C
SET BGPHSABA=1
+15 IF 'BGPHSABA
QUIT ""
+16 SET G=""
+17 DO GETMEDS^BUDAUTL2(P,BD,ED,"BGP PQA CONTROLLER MEDS","BGP PQA CONTROLLER NDC",,,.BUDMEDS1)
+18 ; no CONTROLLER meds BUT HAS SABA
IF '$DATA(BUDMEDS1)
QUIT 1
+19 SET BUDISD=""
+20 SET A=0
SET C=""
FOR
SET A=$ORDER(BUDMEDS1(A))
IF A'=+A!(C)
QUIT
Begin DoDot:1
+21 ;IEN OF V MED
SET M=$PIECE(BUDMEDS1(A),U,4)
+22 IF '$DATA(^AUPNVMED(M,0))
QUIT
+23 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
KILL BUDMEDS1(A)
QUIT
+24 ;d/c'ed BY PROVIDER OR EDIT
IF $$STATDC(M)
KILL BUDMEDS1(A)
QUIT
+25 SET V=$PIECE(BUDMEDS1(A),U,5)
+26 SET V1D=$$VD^APCLV(V)
+27 SET C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
End DoDot:1
+28 IF C
QUIT 0
+29 QUIT 1
ASTALG(P,ED) ;
+1 ;allergy tracking
+2 NEW BUDC,X,N,G,Y,T,T1,S,A,B,C
+3 SET T=$ORDER(^ATXAX("B","BGP PQA CONTROLLER MEDS",0))
+4 SET T1=$ORDER(^ATXAX("B","BGP PQA CONTROLLER NDC",0))
+5 SET BUDC=0
+6 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+7 ;entered after end date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>ED
QUIT
+8 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,3)
+9 ;IF PSDRUG CHECK AGAINST MEDS TAXONOMY
+10 IF N["PSDRUG"!(N["PSNDF")
Begin DoDot:2
+11 SET Y=+N
+12 IF T
IF $DATA(^ATXAX(T,21,"AA",Y))
SET BUDC=1
+13 SET D=$PIECE($GET(^PSDRUG(Y,2)),U,4)
+14 IF D
IF $DATA(^ATXAX(T1,21,"AA",D))
SET BUDC=1
End DoDot:2
IF BUDC
QUIT 1
+15 ;check name for the heck of it
+16 ;NAME OF THING THEY ARE ALLERGIC TO
SET S=$PIECE(^GMR(120.8,X,0),U,2)
+17 SET A=0
FOR
SET A=$ORDER(^ATXAX(T,21,A))
IF A'=+A
QUIT
Begin DoDot:2
+18 SET B=$PIECE($GET(^ATXAX(T,21,A,0)),U,1)
+19 IF $PIECE($GET(^PSDRUG(B,0)),U,1)=S
SET BUDC=1
QUIT
End DoDot:2
End DoDot:1
+20 QUIT BUDC
+21 ;
PROBAS1(P,BDATE,EDATE) ;EP
+1 NEW S,A,B,T,X,G,V,Y,Z
+2 SET G=""
+3 SET T=$ORDER(^ATXAX("B","BUD ASTHMA DXS",0))
+4 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET Z=$PIECE(^AUPNPROB(X,0),U,13)
+6 IF Z=""
SET Z=$PIECE(^AUPNPROB(X,0),U,8)
+7 IF Z>EDATE
QUIT
+8 SET Y=$PIECE(^AUPNPROB(X,0),U)
+9 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+10 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+11 IF $PIECE(^AUPNPROB(X,0),U,15)=""
QUIT
+12 SET G(9999999-$PIECE(^AUPNPROB(X,0),U,3))=$PIECE(^AUPNPROB(X,0),U,15)
+13 QUIT
End DoDot:1
+14 SET X=$ORDER(G(0))
IF X
QUIT G(X)
+15 SET EDATE1=9999999-EDATE-1
+16 SET D=$ORDER(^AUPNVAST("AS",P,EDATE1))
+17 IF 'D
QUIT ""
+18 ;I D>(9999999-BDATE) Q ""
+19 SET LAST=""
SET E=0
FOR
SET E=$ORDER(^AUPNVAST("AS",P,D,E))
IF E'=+E
QUIT
SET LAST=E
+20 IF 'LAST
QUIT ""
+21 SET S=^AUPNVAST("AS",P,D,LAST)
+22 QUIT S
+23 ;
ASTHMA(P,BDATE,EDATE) ;EP
+1 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+2 NEW A,B,E,T,G,X,V,Y
+3 KILL G
+4 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+5 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+6 SET T=$ORDER(^ATXAX("B","BUD ASTHMA DXS",0))
+7 IF 'T
QUIT ""
+8 SET X=0
SET G=""
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+11 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+12 IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+13 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+14 SET D=0
+15 IF $DATA(^AUPNVPOV(Y,0))
SET %=$PIECE(^AUPNVPOV(Y,0),U)
+16 IF $$ICD^ATXCHK(%,T,9)
SET D=1
+17 IF 'D
QUIT
+18 SET G($$VD^APCLV(V))=$$VAL^XBDIQ1(9000010.07,Y,.01)
+19 QUIT
End DoDot:2
End DoDot:1
+20 ;NOW CHECK FOR A CPT OF 1038F
+21 SET Y=""
+22 SET Y=$$CPTI^BUDADU(P,BDATE,EDATE,$PIECE($$CPT^ICPTCOD("1038F"),U,1))
+23 IF Y
SET G($PIECE(Y,U,2))="CPT: 1038F"
+24 SET Y=$$CPTI^BUDADU(P,BDATE,EDATE,$PIECE($$CPT^ICPTCOD("4015F"),U,1))
+25 IF Y
SET G($PIECE(Y,U,2))="CPT: 4015F"
+26 SET Y=$ORDER(G(""),-1)
+27 ;W !,P," ",Y," " ZW G
+28 IF Y=""
QUIT ""
+29 SET X=G(Y)
+30 QUIT X_" on "_$$FMTE^XLFDT(Y)_U_Y
+31 ;
AST1039(P,BDATE,EDATE) ;EP
+1 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+2 NEW A,B,E,T,G,X,V,Y
+3 KILL G
+4 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+5 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+6 SET Y=""
+7 SET Y=$$CPTI^BUDADU(P,BDATE,EDATE,$PIECE($$CPT^ICPTCOD("1039F"),U,1))
+8 IF Y
SET G($PIECE(Y,U,2))="CPT: 1039F"
+9 SET Y=$ORDER(G(""),-1)
IF Y=""
QUIT ""
+10 SET X=G(Y)
+11 QUIT X_" on "_$$FMTE^XLFDT(Y)_U_Y
ASTHTHER(P,BD,ED) ;
+1 NEW BUDMEDS1,G,A,C,M,V,V1D
+2 SET G=""
+3 DO GETMEDS^BUDAUTL2(P,BD,ED,"BGP PQA CONTROLLER MEDS","BGP PQA CONTROLLER NDC",,,.BUDMEDS1)
+4 ; no CONTROLLER meds
IF '$DATA(BUDMEDS1)
QUIT G
+5 SET BUDISD=""
+6 SET A=0
SET C=""
FOR
SET A=$ORDER(BUDMEDS1(A))
IF A'=+A!(C)
QUIT
Begin DoDot:1
+7 ;IEN OF V MED
SET M=$PIECE(BUDMEDS1(A),U,4)
+8 IF '$DATA(^AUPNVMED(M,0))
QUIT
+9 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
KILL BUDMEDS1(A)
QUIT
+10 ;d/c'ed BY PROVIDER OR EDIT
IF $$STATDC(M)
KILL BUDMEDS1(A)
QUIT
+11 SET V=$PIECE(BUDMEDS1(A),U,5)
+12 SET V1D=$$VD^APCLV(V)
+13 SET C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
End DoDot:1
+14 IF C
QUIT C
+15 QUIT ""
+16 ;
STATDC(V) ;EP - is the prescription associated with this V MED discontinued?
+1 IF '$GET(V)
QUIT ""
+2 IF '$DATA(^AUPNVMED(V,0))
QUIT 0
+3 NEW P,S,X
+4 SET P=$SELECT($DATA(^PSRX("APCC",V)):$ORDER(^(V,0)),1:0)
+5 IF 'P
QUIT 0
+6 SET X=$PIECE($GET(^PSRX(P,0)),U,15)
+7 IF X=12
QUIT 1
+8 IF X=13
QUIT 1
+9 IF X=14
QUIT 1
+10 IF X=15
QUIT 1
+11 SET X=$PIECE($GET(^PSRX(P,"STA")),U,1)
+12 IF X=12
QUIT 1
+13 IF X=13
QUIT 1
+14 IF X=14
QUIT 1
+15 IF X=15
QUIT 1
+16 QUIT 0
GETV(P,BD,ED,SITE) ;EP - get all visits for this patient and COUNT MEDICAL VISITS
+1 NEW TV,T35V,T6V,MEDV,MEDVI,LASTV,A,X,VLOC,CLINC,TIEN,VSIT,VDATE,PP,S,LINE,D
+2 SET TV=0
SET T35V=0
SET T6V=0
SET MEDV=0
SET MEDVI=""
SET LASTV=""
+3 SET A="A(""VISITS"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED)
SET E=$$START1^APCLDF(B,A)
+4 SET X=0
FOR
SET X=$ORDER(A("VISITS",X))
IF X'=+X!(MEDV>1)
QUIT
SET VSIT=$PIECE(A("VISITS",X),U,5)
Begin DoDot:1
+5 IF '$DATA(^AUPNVSIT(VSIT,0))
QUIT
+6 IF '$PIECE(^AUPNVSIT(VSIT,0),U,9)
QUIT
+7 IF $PIECE(^AUPNVSIT(VSIT,0),U,11)
QUIT
+8 SET VLOC=$PIECE(^AUPNVSIT(VSIT,0),U,6)
+9 IF VLOC=""
QUIT
+10 ;not valid location
IF '$DATA(^BUDQSITE(SITE,11,VLOC))
QUIT
+11 IF "AHSORMEI"'[$PIECE(^AUPNVSIT(VSIT,0),U,7)
QUIT
+12 SET CLINC=$$CLINIC^APCLV(VSIT,"C")
+13 SET TIEN=$ORDER(^BUDQCNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))
+14 ;not a clinic code we want in any table
IF CLINC]""
IF $DATA(^BUDQCNTL(TIEN,11,"B",CLINC))
QUIT
+15 ;now eliminate subsequent visits to same provider on same day = item 4 in SRD visit definition
+16 SET VDATE=$$VD^APCLV(VSIT)
+17 SET PP=$$PRIMPROV^APCLV(VSIT,"I")
+18 ;don't count I visits
IF $PIECE(^AUPNVSIT(VSIT,0),U,7)="I"
QUIT
+19 IF '$DATA(^AUPNVPOV("AD",VSIT))
QUIT
+20 SET S=0
+21 IF PP]""
Begin DoDot:2
+22 SET D=$PIECE($GET(A("SAMEPROV",P,VDATE,PP)),U,1)
+23 ;already had a visit to this provider on this date
IF D]""
IF D'>$PIECE(^AUPNVSIT(VSIT,0),U)
SET S=1
QUIT
+24 SET A("SAMEPROV",P,VDATE,PP)=$PIECE(^AUPNVSIT(VSIT,0),U)_U_VSIT
End DoDot:2
+25 ;quit if already had a visit to this provider
IF S
QUIT
+26 SET PP=$$PRIMPROV^APCLV(VSIT,"D")
+27 IF PP=""
QUIT
MEDC ;NOW CHECK FOR MEDICAL CARE, CAN ONLY HAVE 1 PER LOCATION OF ENCOUNTER
+1 SET S=0
+2 SET TIEN=$ORDER(^BUDQCNTL("B","MEDICAL CARE LINE NUMBERS",0))
+3 ;S PP=$$PRIMPROV^APCLV(VSIT,"D")
+4 IF $EXTRACT($$VAL^XBDIQ1(9000010,VSIT,.06),1,3)="CHS"
IF PP=15
SET LINE=2
GOTO MEDC1
+5 SET Y=$ORDER(^BUDQTFIV("C",PP,0))
IF Y=""
SET LINE=35
GOTO MEDC1
+6 SET LINE=$ORDER(^BUDQTFIV("AA",PP,""))
MEDC1 SET S=0
+1 IF $DATA(^BUDQCNTL(TIEN,11,"B",LINE))
Begin DoDot:2
+2 SET D=$PIECE($GET(A("MEDCARE",P,VDATE,VLOC,TIEN)),U,1)
+3 ;already have a medical care visit on this date
IF D]""
IF D'>$PIECE(^AUPNVSIT(VSIT,0),U)
SET S=1
QUIT
+4 SET A("MEDCARE",P,VDATE,VLOC,TIEN)=$PIECE(^AUPNVSIT(VSIT,0),U)_U_VSIT
+5 SET MEDV=MEDV+1
SET MEDVI=VSIT
+6 QUIT
End DoDot:2
End DoDot:1
+7 QUIT MEDV
