BUDDRP6R ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
;
G ;EP
NEW BUDGOT,BUDX18RB,BUDX18TH,X,BUDTOBS,BUDTOBD,BUDTOBDD,BUDB24M
S BUDGOT=""
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUDX18RB=($E(BUDBD,1,3)-18)_"1231"
Q:BUDDOB>BUDX18RB
S BUDX18TH=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)
I '$$VBBD^BUDDRP6V(DFN,BUDX18TH,BUDED) Q ; seen after 18th birthday
I BUDMEDV>1 G N ;AT LEAST 2 MED VISITS OR 1 PREVENTATIVE
S X=$$PREVV^BUDDRP6U(DFN,BUDBD,BUDED)
Q:X<1
Q:$$NOSCREEN(DFN,BUDBD,BUDED)
N ;
S (BUDTOBS,BUDCESS,BUDUSER)=""
S BUDTOBDD=$E(BUDBD,1,3)-1_$E(BUDBD,4,7)
S BUDB24M=$$VD^APCLV(BUDLASTV),BUDB24M=$E(BUDB24M,1,3)-2_$E(BUDB24M,4,7)
S BUDUSER=$$TOBUSER(DFN,BUDB24M,$$VD^APCLV(BUDLASTV))
I BUDUSER]"" S BUDTOBS=BUDUSER G C
S BUDTOBS=$$TOBSCRN(DFN,BUDB24M,$$VD^APCLV(BUDLASTV)) ;SCREENED IN 24 MONTHS PRIOR TO OR ON LAST VISIT
C S BUDCESS=""
I BUDTOBS]"",BUDUSER="" S BUDGOT=1
I BUDTOBS]"",BUDUSER]"" S BUDCESS=$$TOBCESS(DFN,BUDB24M,BUDED) I BUDCESS]"" S BUDGOT=1
I BUDGOT S BUDSECG1("ABM")=$G(BUDSECG1("ABM"))+1
S1 ;put the rest in demoninator
S BUDSECG1("PTS")=$G(BUDSECG1("PTS"))+1 D
.I $G(BUDTUA2L) D
..I 'BUDGOT S ^XTMP("BUDDRP6B",BUDJ,BUDH,"TUA2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDTOBS_"|"_$S(BUDUSER]"":$P(BUDUSER,U,1)_" "_$$DATE^BUDDUTL1($P(BUDUSER,U,3))_"|"_$P(BUDCESS,U,1)_" "_$$DATE^BUDDUTL1($P(BUDCESS,U,3)),1:"")
.I $G(BUDTUA1L) D
..I BUDGOT S ^XTMP("BUDDRP6B",BUDJ,BUDH,"TUA1",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDTOBS_"|"_$S(BUDUSER]"":$P(BUDUSER,U,1)_" "_$$DATE^BUDDUTL1($P(BUDUSER,U,3))_"|"_$P(BUDCESS,U,1)_" "_$$DATE^BUDDUTL1($P(BUDCESS,U,3)),1:"")
Q
;
TOBCESS(P,BDATE,EDATE,PDATE) ;EP
;TOBACCO SCREENING IN DATE RANGE?
NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB,TIEN1
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S TIEN=$O(^BUDDTSSC("B","T6B TOBACCO CESSATION CODES",0))
S TIEN1=$O(^BUDDTSSC("B","T6B TOBACCO USER 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) I C=94 S BUDTOB(9999999-VDATE)="Cl 94"_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
.;CPT
.S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVCPT(X,0))
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..Q:Y=""
..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
.;V TRANS
.S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVTC(X,0))
..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
..Q:Y=""
..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
.;V PROC
.S X=0 F S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVPRC(X,0))
..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
..I $D(^BUDDTSSC("AP",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
.;POV/SNOMED
.S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDDTSSC("AD",Y,TIEN)) S BUDTOB(9999999-VDATE)=$$VAL^XBDIQ1(9000010.07,X,.01)_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDDTSSC("AS",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
.;PATIENT ED
.S X=0 F S X=$O(^AUPNVPED("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVPED(X,0))
..S T=$$VALI^XBDIQ1(9000010.16,X,.01)
..Q:'T
..Q:'$D(^AUTTEDT(T,0))
..S T=$P(^AUTTEDT(T,0),U,2)
..I $P(T,"-")="TO" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
..I $P(T,"-",2)="TO" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
..I $P(T,"-",2)="SHS" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
..I $P(T,"-")="99406" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
..I $P(T,"-")="99407" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
..I $P(T,"-")="4000F" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
..I $P(T,"-")="4001F" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
..S S=$P(T,"-") I S]"",$D(^BUDDTSSC("AS",S,TIEN1)) S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
..S S=$P(T,"-") I S]"",$D(^BUDDTSSC("AS",S,TIEN)) S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
I $O(BUDTOB(0)) S X=$O(BUDTOB(0)),X=BUDTOB(X) Q X
S Y=$$PLCL^BUDDDU(P,"T6B TOBACCO CESSATION CODES",EDATE,0,BDATE)
I Y Q "PL SCREEN "_$P(Y,U,2)_U_$$DATE^BUDDUTL1($P(Y,U,3))_U_$P(Y,U,3)
NEW BUDMEDS1,T1,M,E,G,Z,N,C,BUDLPED
S BUDLPED=""
D GETMEDS^BUDDUTL2(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_$$DATE^BUDDUTL1($P(BUDLPED,U,1))_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
TOBUSER(P,BDATE,EDATE) ;
NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB,V
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S TIEN=$O(^BUDDTSSC("B","T6B TOBACCO USER 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 V=""
.S X=0 F S X=$O(^AUPNVHF("AD",VIEN,X)) Q:X'=+X!(V) D
..Q:'$D(^AUPNVHF(X,0))
..S Y=$$VAL^XBDIQ1(9000010.23,X,.01)
..I $D(^BUDDTSSC(TIEN,18,"B",Y)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
.;CPT
.S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X!(V) D
..Q:'$D(^AUPNVCPT(X,0))
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..Q:Y=""
..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
.;V TRANS
.S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X!(V) D
..Q:'$D(^AUPNVTC(X,0))
..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
..Q:Y=""
..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
.;V PROC
.S X=0 F S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X!(V) D
..Q:'$D(^AUPNVPRC(X,0))
..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
..I $D(^BUDDTSSC("AP",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
.;POV/SNOMED
.S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X!(V) D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDDTSSC("AD",Y,TIEN)) S BUDTOB(9999999-VDATE)=$$VAL^XBDIQ1(9000010.07,X,.01)_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDDTSSC("AS",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..;PATIENT ED
.S X=0 F S X=$O(^AUPNVPED("AD",VIEN,X)) Q:X'=+X!(V) D
..Q:'$D(^AUPNVPED(X,0))
..S T=$$VALI^XBDIQ1(9000010.16,X,.01)
..Q:'T
..Q:'$D(^AUTTEDT(T,0))
..S T=$P(^AUTTEDT(T,0),U,2)
..;I $P(T,"-")="TO" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..;I $P(T,"-",2)="TO" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..;I $P(T,"-",2)="SHS" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="305.1" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="649.00" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="649.01" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="649.02" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="649.03" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="649.04" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..;I $P(T,"-")="V15.82" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="1034F" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="1035F" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $E($P(T,"-"),1,3)="F17" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $E($P(T,"-"),1,6)="O99.33" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="Z72.0" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..S S=$P(T,"-") I S]"",$D(^BUDDTSSC("AS",S,TIEN)) S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
I $O(BUDTOB(0)) S X=$O(BUDTOB(0)),X=BUDTOB(X) Q X
S Y=$$PLCL^BUDDDU(P,"T6B TOBACCO USER CODES",EDATE,0,BDATE)
I Y Q "PL USER "_$P(Y,U,2)_U_$$DATE^BUDDUTL1($P(Y,U,3))_U_$P(Y,U,3)
Q ""
TOBSCRN(P,BDATE,EDATE) ;
;TOBACCO SCREENING IN DATE RANGE?
NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB,V
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S TIEN=$O(^BUDDTSSC("B","T6B TOBACCO SCREEN CODES",0))
S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR D
.S V=""
.S VIEN=$P(BUDVS(CTR),U,5)
.S VDATE=$P(BUDVS(CTR),U,1)
.S X=0 F S X=$O(^AUPNVHF("AD",VIEN,X)) Q:X'=+X!(V) D
..Q:'$D(^AUPNVHF(X,0))
..S Y=$$VAL^XBDIQ1(9000010.23,X,.01)
..I $D(^BUDDTSSC(TIEN,18,"B",Y)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
.;CPT
.S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X!(V) D
..Q:'$D(^AUPNVCPT(X,0))
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..Q:Y=""
..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
.;V TRANS
.S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X!(V) D
..Q:'$D(^AUPNVTC(X,0))
..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
..Q:Y=""
..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
.;V PROC
.S X=0 F S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X!(V) D
..Q:'$D(^AUPNVPRC(X,0))
..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
..I $D(^BUDDTSSC("AP",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
.;POV/SNOMED
.S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X!(V) D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDDTSSC("AD",Y,TIEN)) S V=1,BUDTOB(9999999-VDATE)=$$VAL^XBDIQ1(9000010.07,X,.01)_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDDTSSC("AS",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
.;PATIENT ED
.S X=0 F S X=$O(^AUPNVPED("AD",VIEN,X)) Q:X'=+X!(V) D
..Q:'$D(^AUPNVPED(X,0))
..S T=$$VALI^XBDIQ1(9000010.16,X,.01)
..Q:'T
..Q:'$D(^AUTTEDT(T,0))
..S T=$P(^AUTTEDT(T,0),U,2)
..I $P(T,"-")="TO" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-",2)="TO" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-",2)="SHS" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="305.1" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="649.00" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="649.01" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="649.02" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="649.03" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="649.04" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="V15.82" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="1034F" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="1035F" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="1036F" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="1000F" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $E($P(T,"-"),1,3)="F17" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $E($P(T,"-"),1,6)="O99.33" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
..I $P(T,"-")="Z72.0" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
I $O(BUDTOB(0)) S X=$O(BUDTOB(0)),X=BUDTOB(X) Q X
S Y=$$PLCL^BUDDDU(P,"T6B TOBACCO SCREEN CODES",EDATE,0,BDATE)
I Y Q "PL SCREEN "_$P(Y,U,2)_U_$$DATE^BUDDUTL1($P(Y,U,3))_U_$P(Y,U,3)
Q ""
S(V) ;
S BUDDECNT=BUDDECNT+1
S ^TMP($J,"BUDDEL",BUDDECNT)=$G(V)
Q
;------
NOSCREEN(P,BDATE,EDATE) ;
NEW D,BUDG,E,%
S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
NEW X,Y,G,T,V,Z,A
S T=$O(^BUDDTSSC("B","T6B TOBACCO NO SCREEN",0))
S G=""
S X=0 F S X=$O(BUDG(X)) Q:X'=+X!(G) D
.S Y=+$P(BUDG(X),U,4)
.S Z=$P($G(^AUPNVPOV(Y,0)),U,1)
.I $D(^BUDDTSSC("AD",Z,T)) S G=1 Q
.S Y=$$VAL^XBDIQ1(9000010.07,Y,1101)
.Q:Y=""
.I $D(^BUDDTSSC("AS",Y,T)) S G=1
I G Q G
S X=$$PLCL^BUDDDU(P,"T6B TOBACCO NO SCREEN",EDATE,0,BDATE) I X Q 1 ;"PROBLEM SNOMED "_$P(X,U,2)
Q ""
BUDDRP6R ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
+1 ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
+2 ;
G ;EP
+1 NEW BUDGOT,BUDX18RB,BUDX18TH,X,BUDTOBS,BUDTOBD,BUDTOBDD,BUDB24M
+2 SET BUDGOT=""
+3 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+4 SET BUDX18RB=($EXTRACT(BUDBD,1,3)-18)_"1231"
+5 IF BUDDOB>BUDX18RB
QUIT
+6 SET BUDX18TH=$EXTRACT(BUDDOB,1,3)+18_$EXTRACT(BUDDOB,4,7)
+7 ; seen after 18th birthday
IF '$$VBBD^BUDDRP6V(DFN,BUDX18TH,BUDED)
QUIT
+8 ;AT LEAST 2 MED VISITS OR 1 PREVENTATIVE
IF BUDMEDV>1
GOTO N
+9 SET X=$$PREVV^BUDDRP6U(DFN,BUDBD,BUDED)
+10 IF X<1
QUIT
+11 IF $$NOSCREEN(DFN,BUDBD,BUDED)
QUIT
N ;
+1 SET (BUDTOBS,BUDCESS,BUDUSER)=""
+2 SET BUDTOBDD=$EXTRACT(BUDBD,1,3)-1_$EXTRACT(BUDBD,4,7)
+3 SET BUDB24M=$$VD^APCLV(BUDLASTV)
SET BUDB24M=$EXTRACT(BUDB24M,1,3)-2_$EXTRACT(BUDB24M,4,7)
+4 SET BUDUSER=$$TOBUSER(DFN,BUDB24M,$$VD^APCLV(BUDLASTV))
+5 IF BUDUSER]""
SET BUDTOBS=BUDUSER
GOTO C
+6 ;SCREENED IN 24 MONTHS PRIOR TO OR ON LAST VISIT
SET BUDTOBS=$$TOBSCRN(DFN,BUDB24M,$$VD^APCLV(BUDLASTV))
C SET BUDCESS=""
+1 IF BUDTOBS]""
IF BUDUSER=""
SET BUDGOT=1
+2 IF BUDTOBS]""
IF BUDUSER]""
SET BUDCESS=$$TOBCESS(DFN,BUDB24M,BUDED)
IF BUDCESS]""
SET BUDGOT=1
+3 IF BUDGOT
SET BUDSECG1("ABM")=$GET(BUDSECG1("ABM"))+1
S1 ;put the rest in demoninator
+1 SET BUDSECG1("PTS")=$GET(BUDSECG1("PTS"))+1
Begin DoDot:1
+2 IF $GET(BUDTUA2L)
Begin DoDot:2
+3 IF 'BUDGOT
SET ^XTMP("BUDDRP6B",BUDJ,BUDH,"TUA2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDTOBS_"|"_$SELECT(BUDUSER]"":$PIECE(BUDUSER,U,1)_" "_$$DATE^BUDDUTL1($PIECE(BUDUSER,U,3))_"|"_$PIECE(BUDCESS,U,1)_" "_$$DATE^BUDDUTL1($PIECE(BUDCE
SS,U,3)),1:"")
End DoDot:2
+4 IF $GET(BUDTUA1L)
Begin DoDot:2
+5 IF BUDGOT
SET ^XTMP("BUDDRP6B",BUDJ,BUDH,"TUA1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDTOBS_"|"_$SELECT(BUDUSER]"":$PIECE(BUDUSER,U,1)_" "_$$DATE^BUDDUTL1($PIECE(BUDUSER,U,3))_"|"_$PIECE(BUDCESS,U,1)_" "_$$DATE^BUDDUTL1($PIECE(BUDCE
SS,U,3)),1:"")
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
TOBCESS(P,BDATE,EDATE,PDATE) ;EP
+1 ;TOBACCO SCREENING IN DATE RANGE?
+2 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB,TIEN1
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+4 SET TIEN=$ORDER(^BUDDTSSC("B","T6B TOBACCO CESSATION CODES",0))
+5 SET TIEN1=$ORDER(^BUDDTSSC("B","T6B TOBACCO USER CODES",0))
+6 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+7 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+8 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+9 SET C=$$CLINIC^APCLV(VIEN)
IF C=94
SET BUDTOB(9999999-VDATE)="Cl 94"_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
QUIT
+10 ;CPT
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+12 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+13 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+14 IF Y=""
QUIT
+15 IF $DATA(^BUDDTSSC("AC",Y,TIEN))
SET BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
QUIT
End DoDot:2
+16 ;V TRANS
+17 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+18 IF '$DATA(^AUPNVTC(X,0))
QUIT
+19 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+20 IF Y=""
QUIT
+21 IF $DATA(^BUDDTSSC("AC",Y,TIEN))
SET BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
QUIT
End DoDot:2
+22 ;V PROC
+23 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+24 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+25 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+26 IF $DATA(^BUDDTSSC("AP",Y,TIEN))
SET BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
QUIT
End DoDot:2
+27 ;POV/SNOMED
+28 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+29 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+30 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
IF $DATA(^BUDDTSSC("AD",Y,TIEN))
SET BUDTOB(9999999-VDATE)=$$VAL^XBDIQ1(9000010.07,X,.01)_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
QUIT
+31 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+32 IF Y=""
QUIT
+33 IF $DATA(^BUDDTSSC("AS",Y,TIEN))
SET BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
QUIT
End DoDot:2
+34 ;PATIENT ED
+35 SET X=0
FOR
SET X=$ORDER(^AUPNVPED("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+36 IF '$DATA(^AUPNVPED(X,0))
QUIT
+37 SET T=$$VALI^XBDIQ1(9000010.16,X,.01)
+38 IF 'T
QUIT
+39 IF '$DATA(^AUTTEDT(T,0))
QUIT
+40 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+41 IF $PIECE(T,"-")="TO"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
QUIT
+42 IF $PIECE(T,"-",2)="TO"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
QUIT
+43 IF $PIECE(T,"-",2)="SHS"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
QUIT
+44 IF $PIECE(T,"-")="99406"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
QUIT
+45 IF $PIECE(T,"-")="99407"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
QUIT
+46 IF $PIECE(T,"-")="4000F"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
QUIT
+47 IF $PIECE(T,"-")="4001F"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
QUIT
+48 SET S=$PIECE(T,"-")
IF S]""
IF $DATA(^BUDDTSSC("AS",S,TIEN1))
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
QUIT
+49 SET S=$PIECE(T,"-")
IF S]""
IF $DATA(^BUDDTSSC("AS",S,TIEN))
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
QUIT
End DoDot:2
End DoDot:1
+50 IF $ORDER(BUDTOB(0))
SET X=$ORDER(BUDTOB(0))
SET X=BUDTOB(X)
QUIT X
+51 SET Y=$$PLCL^BUDDDU(P,"T6B TOBACCO CESSATION CODES",EDATE,0,BDATE)
+52 IF Y
QUIT "PL SCREEN "_$PIECE(Y,U,2)_U_$$DATE^BUDDUTL1($PIECE(Y,U,3))_U_$PIECE(Y,U,3)
+53 NEW BUDMEDS1,T1,M,E,G,Z,N,C,BUDLPED
+54 SET BUDLPED=""
+55 DO GETMEDS^BUDDUTL2(P,BDATE,EDATE,,,,,.BUDMEDS1)
+56 ;I '$D(BUDMEDS1) G PEDREF
+57 SET T=$ORDER(^ATXAX("B","BGP CMS SMOKING CESSATION MEDS",0))
+58 SET T1=$ORDER(^ATXAX("B","BGP CMS SMOKING CESSATION NDC",0))
+59 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
+60 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+61 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+62 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+63 IF 'Z
QUIT
+64 SET N=$PIECE($GET(^PSDRUG(Z,0)),U)
+65 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
+66 IF $DATA(^ATXAX(T,21,"B",Z))!(N["NICOTINE PATCH")!(N["NICOTINE POLACRILEX")!(N["NICOTINE INHALER")!(N["NICOTINE NASAL SPRAY")
Begin DoDot:2
+67 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
+68 SET C=$PIECE($GET(^PSDRUG(Z,2)),U,4)
+69 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
+70 ;BUDLPED
IF BUDLPED]""
QUIT $PIECE(BUDLPED,U,2)_U_$$DATE^BUDDUTL1($PIECE(BUDLPED,U,1))_U_$PIECE(BUDLPED,U,1)
+71 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
TOBUSER(P,BDATE,EDATE) ;
+1 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB,V
+2 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+3 SET TIEN=$ORDER(^BUDDTSSC("B","T6B TOBACCO USER CODES",0))
+4 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+5 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+6 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+7 SET V=""
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVHF("AD",VIEN,X))
IF X'=+X!(V)
QUIT
Begin DoDot:2
+9 IF '$DATA(^AUPNVHF(X,0))
QUIT
+10 SET Y=$$VAL^XBDIQ1(9000010.23,X,.01)
+11 IF $DATA(^BUDDTSSC(TIEN,18,"B",Y))
SET BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
End DoDot:2
+12 ;CPT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X!(V)
QUIT
Begin DoDot:2
+14 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+15 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+16 IF Y=""
QUIT
+17 IF $DATA(^BUDDTSSC("AC",Y,TIEN))
SET BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
End DoDot:2
+18 ;V TRANS
+19 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X!(V)
QUIT
Begin DoDot:2
+20 IF '$DATA(^AUPNVTC(X,0))
QUIT
+21 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+22 IF Y=""
QUIT
+23 IF $DATA(^BUDDTSSC("AC",Y,TIEN))
SET BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
End DoDot:2
+24 ;V PROC
+25 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X!(V)
QUIT
Begin DoDot:2
+26 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+27 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+28 IF $DATA(^BUDDTSSC("AP",Y,TIEN))
SET BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
End DoDot:2
+29 ;POV/SNOMED
+30 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X!(V)
QUIT
Begin DoDot:2
+31 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+32 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
IF $DATA(^BUDDTSSC("AD",Y,TIEN))
SET BUDTOB(9999999-VDATE)=$$VAL^XBDIQ1(9000010.07,X,.01)_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+33 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+34 IF Y=""
QUIT
+35 IF $DATA(^BUDDTSSC("AS",Y,TIEN))
SET BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+36 ;PATIENT ED
End DoDot:2
+37 SET X=0
FOR
SET X=$ORDER(^AUPNVPED("AD",VIEN,X))
IF X'=+X!(V)
QUIT
Begin DoDot:2
+38 IF '$DATA(^AUPNVPED(X,0))
QUIT
+39 SET T=$$VALI^XBDIQ1(9000010.16,X,.01)
+40 IF 'T
QUIT
+41 IF '$DATA(^AUTTEDT(T,0))
QUIT
+42 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+43 ;I $P(T,"-")="TO" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
+44 ;I $P(T,"-",2)="TO" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
+45 ;I $P(T,"-",2)="SHS" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
+46 IF $PIECE(T,"-")="305.1"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+47 IF $PIECE(T,"-")="649.00"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+48 IF $PIECE(T,"-")="649.01"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+49 IF $PIECE(T,"-")="649.02"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+50 IF $PIECE(T,"-")="649.03"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+51 IF $PIECE(T,"-")="649.04"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+52 ;I $P(T,"-")="V15.82" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
+53 IF $PIECE(T,"-")="1034F"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+54 IF $PIECE(T,"-")="1035F"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+55 IF $EXTRACT($PIECE(T,"-"),1,3)="F17"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+56 IF $EXTRACT($PIECE(T,"-"),1,6)="O99.33"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+57 IF $PIECE(T,"-")="Z72.0"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+58 SET S=$PIECE(T,"-")
IF S]""
IF $DATA(^BUDDTSSC("AS",S,TIEN))
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
End DoDot:2
End DoDot:1
+59 IF $ORDER(BUDTOB(0))
SET X=$ORDER(BUDTOB(0))
SET X=BUDTOB(X)
QUIT X
+60 SET Y=$$PLCL^BUDDDU(P,"T6B TOBACCO USER CODES",EDATE,0,BDATE)
+61 IF Y
QUIT "PL USER "_$PIECE(Y,U,2)_U_$$DATE^BUDDUTL1($PIECE(Y,U,3))_U_$PIECE(Y,U,3)
+62 QUIT ""
TOBSCRN(P,BDATE,EDATE) ;
+1 ;TOBACCO SCREENING IN DATE RANGE?
+2 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB,V
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+4 SET TIEN=$ORDER(^BUDDTSSC("B","T6B TOBACCO SCREEN CODES",0))
+5 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+6 SET V=""
+7 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+8 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVHF("AD",VIEN,X))
IF X'=+X!(V)
QUIT
Begin DoDot:2
+10 IF '$DATA(^AUPNVHF(X,0))
QUIT
+11 SET Y=$$VAL^XBDIQ1(9000010.23,X,.01)
+12 IF $DATA(^BUDDTSSC(TIEN,18,"B",Y))
SET BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
End DoDot:2
+13 ;CPT
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X!(V)
QUIT
Begin DoDot:2
+15 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+16 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+17 IF Y=""
QUIT
+18 IF $DATA(^BUDDTSSC("AC",Y,TIEN))
SET BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
End DoDot:2
+19 ;V TRANS
+20 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X!(V)
QUIT
Begin DoDot:2
+21 IF '$DATA(^AUPNVTC(X,0))
QUIT
+22 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+23 IF Y=""
QUIT
+24 IF $DATA(^BUDDTSSC("AC",Y,TIEN))
SET BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
End DoDot:2
+25 ;V PROC
+26 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X!(V)
QUIT
Begin DoDot:2
+27 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+28 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+29 IF $DATA(^BUDDTSSC("AP",Y,TIEN))
SET BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
End DoDot:2
+30 ;POV/SNOMED
+31 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X!(V)
QUIT
Begin DoDot:2
+32 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+33 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
IF $DATA(^BUDDTSSC("AD",Y,TIEN))
SET V=1
SET BUDTOB(9999999-VDATE)=$$VAL^XBDIQ1(9000010.07,X,.01)_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+34 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+35 IF Y=""
QUIT
+36 IF $DATA(^BUDDTSSC("AS",Y,TIEN))
SET BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
End DoDot:2
+37 ;PATIENT ED
+38 SET X=0
FOR
SET X=$ORDER(^AUPNVPED("AD",VIEN,X))
IF X'=+X!(V)
QUIT
Begin DoDot:2
+39 IF '$DATA(^AUPNVPED(X,0))
QUIT
+40 SET T=$$VALI^XBDIQ1(9000010.16,X,.01)
+41 IF 'T
QUIT
+42 IF '$DATA(^AUTTEDT(T,0))
QUIT
+43 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+44 IF $PIECE(T,"-")="TO"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+45 IF $PIECE(T,"-",2)="TO"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+46 IF $PIECE(T,"-",2)="SHS"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+47 IF $PIECE(T,"-")="305.1"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+48 IF $PIECE(T,"-")="649.00"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+49 IF $PIECE(T,"-")="649.01"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+50 IF $PIECE(T,"-")="649.02"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+51 IF $PIECE(T,"-")="649.03"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+52 IF $PIECE(T,"-")="649.04"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+53 IF $PIECE(T,"-")="V15.82"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+54 IF $PIECE(T,"-")="1034F"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+55 IF $PIECE(T,"-")="1035F"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+56 IF $PIECE(T,"-")="1036F"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+57 IF $PIECE(T,"-")="1000F"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+58 IF $EXTRACT($PIECE(T,"-"),1,3)="F17"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+59 IF $EXTRACT($PIECE(T,"-"),1,6)="O99.33"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
+60 IF $PIECE(T,"-")="Z72.0"
SET BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE
SET V=1
QUIT
End DoDot:2
End DoDot:1
+61 IF $ORDER(BUDTOB(0))
SET X=$ORDER(BUDTOB(0))
SET X=BUDTOB(X)
QUIT X
+62 SET Y=$$PLCL^BUDDDU(P,"T6B TOBACCO SCREEN CODES",EDATE,0,BDATE)
+63 IF Y
QUIT "PL SCREEN "_$PIECE(Y,U,2)_U_$$DATE^BUDDUTL1($PIECE(Y,U,3))_U_$PIECE(Y,U,3)
+64 QUIT ""
S(V) ;
+1 SET BUDDECNT=BUDDECNT+1
+2 SET ^TMP($JOB,"BUDDEL",BUDDECNT)=$GET(V)
+3 QUIT
+4 ;------
NOSCREEN(P,BDATE,EDATE) ;
+1 NEW D,BUDG,E,%
+2 SET %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+3 NEW X,Y,G,T,V,Z,A
+4 SET T=$ORDER(^BUDDTSSC("B","T6B TOBACCO NO SCREEN",0))
+5 SET G=""
+6 SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+7 SET Y=+$PIECE(BUDG(X),U,4)
+8 SET Z=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+9 IF $DATA(^BUDDTSSC("AD",Z,T))
SET G=1
QUIT
+10 SET Y=$$VAL^XBDIQ1(9000010.07,Y,1101)
+11 IF Y=""
QUIT
+12 IF $DATA(^BUDDTSSC("AS",Y,T))
SET G=1
End DoDot:1
+13 IF G
QUIT G
+14 ;"PROBLEM SNOMED "_$P(X,U,2)
SET X=$$PLCL^BUDDDU(P,"T6B TOBACCO NO SCREEN",EDATE,0,BDATE)
IF X
QUIT 1
+15 QUIT ""
