- 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 ""