- 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