Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BUDDRP6R

BUDDRP6R.m

Go to the documentation of this file.
  1. BUDDRP6R ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
  1. ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
  1. ;
  1. G ;EP
  1. NEW BUDGOT,BUDX18RB,BUDX18TH,X,BUDTOBS,BUDTOBD,BUDTOBDD,BUDB24M
  1. S BUDGOT=""
  1. S BUDDOB=$P(^DPT(DFN,0),U,3)
  1. S BUDX18RB=($E(BUDBD,1,3)-18)_"1231"
  1. Q:BUDDOB>BUDX18RB
  1. S BUDX18TH=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)
  1. I '$$VBBD^BUDDRP6V(DFN,BUDX18TH,BUDED) Q ; seen after 18th birthday
  1. I BUDMEDV>1 G N ;AT LEAST 2 MED VISITS OR 1 PREVENTATIVE
  1. S X=$$PREVV^BUDDRP6U(DFN,BUDBD,BUDED)
  1. Q:X<1
  1. Q:$$NOSCREEN(DFN,BUDBD,BUDED)
  1. N ;
  1. S (BUDTOBS,BUDCESS,BUDUSER)=""
  1. S BUDTOBDD=$E(BUDBD,1,3)-1_$E(BUDBD,4,7)
  1. S BUDB24M=$$VD^APCLV(BUDLASTV),BUDB24M=$E(BUDB24M,1,3)-2_$E(BUDB24M,4,7)
  1. S BUDUSER=$$TOBUSER(DFN,BUDB24M,$$VD^APCLV(BUDLASTV))
  1. I BUDUSER]"" S BUDTOBS=BUDUSER G C
  1. S BUDTOBS=$$TOBSCRN(DFN,BUDB24M,$$VD^APCLV(BUDLASTV)) ;SCREENED IN 24 MONTHS PRIOR TO OR ON LAST VISIT
  1. C S BUDCESS=""
  1. I BUDTOBS]"",BUDUSER="" S BUDGOT=1
  1. I BUDTOBS]"",BUDUSER]"" S BUDCESS=$$TOBCESS(DFN,BUDB24M,BUDED) I BUDCESS]"" S BUDGOT=1
  1. I BUDGOT S BUDSECG1("ABM")=$G(BUDSECG1("ABM"))+1
  1. S1 ;put the rest in demoninator
  1. S BUDSECG1("PTS")=$G(BUDSECG1("PTS"))+1 D
  1. .I $G(BUDTUA2L) D
  1. ..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:"")
  1. .I $G(BUDTUA1L) D
  1. ..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:"")
  1. Q
  1. ;
  1. TOBCESS(P,BDATE,EDATE,PDATE) ;EP
  1. ;TOBACCO SCREENING IN DATE RANGE?
  1. NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB,TIEN1
  1. D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
  1. S TIEN=$O(^BUDDTSSC("B","T6B TOBACCO CESSATION CODES",0))
  1. S TIEN1=$O(^BUDDTSSC("B","T6B TOBACCO USER CODES",0))
  1. S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR D
  1. .S VIEN=$P(BUDVS(CTR),U,5)
  1. .S VDATE=$P(BUDVS(CTR),U,1)
  1. .S C=$$CLINIC^APCLV(VIEN) I C=94 S BUDTOB(9999999-VDATE)="Cl 94"_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
  1. .;CPT
  1. .S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X D
  1. ..Q:'$D(^AUPNVCPT(X,0))
  1. ..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
  1. ..Q:Y=""
  1. ..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
  1. .;V TRANS
  1. .S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X D
  1. ..Q:'$D(^AUPNVTC(X,0))
  1. ..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
  1. ..Q:Y=""
  1. ..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
  1. .;V PROC
  1. .S X=0 F S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X D
  1. ..Q:'$D(^AUPNVPRC(X,0))
  1. ..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
  1. ..I $D(^BUDDTSSC("AP",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
  1. .;POV/SNOMED
  1. .S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X D
  1. ..Q:'$D(^AUPNVPOV(X,0))
  1. ..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
  1. ..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
  1. ..Q:Y=""
  1. ..I $D(^BUDDTSSC("AS",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
  1. .;PATIENT ED
  1. .S X=0 F S X=$O(^AUPNVPED("AD",VIEN,X)) Q:X'=+X D
  1. ..Q:'$D(^AUPNVPED(X,0))
  1. ..S T=$$VALI^XBDIQ1(9000010.16,X,.01)
  1. ..Q:'T
  1. ..Q:'$D(^AUTTEDT(T,0))
  1. ..S T=$P(^AUTTEDT(T,0),U,2)
  1. ..I $P(T,"-")="TO" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
  1. ..I $P(T,"-",2)="TO" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
  1. ..I $P(T,"-",2)="SHS" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
  1. ..I $P(T,"-")="99406" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
  1. ..I $P(T,"-")="99407" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
  1. ..I $P(T,"-")="4000F" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
  1. ..I $P(T,"-")="4001F" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
  1. ..S S=$P(T,"-") I S]"",$D(^BUDDTSSC("AS",S,TIEN1)) S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
  1. ..S S=$P(T,"-") I S]"",$D(^BUDDTSSC("AS",S,TIEN)) S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
  1. I $O(BUDTOB(0)) S X=$O(BUDTOB(0)),X=BUDTOB(X) Q X
  1. S Y=$$PLCL^BUDDDU(P,"T6B TOBACCO CESSATION CODES",EDATE,0,BDATE)
  1. I Y Q "PL SCREEN "_$P(Y,U,2)_U_$$DATE^BUDDUTL1($P(Y,U,3))_U_$P(Y,U,3)
  1. NEW BUDMEDS1,T1,M,E,G,Z,N,C,BUDLPED
  1. S BUDLPED=""
  1. D GETMEDS^BUDDUTL2(P,BDATE,EDATE,,,,,.BUDMEDS1)
  1. ;I '$D(BUDMEDS1) G PEDREF
  1. S T=$O(^ATXAX("B","BGP CMS SMOKING CESSATION MEDS",0))
  1. S T1=$O(^ATXAX("B","BGP CMS SMOKING CESSATION NDC",0))
  1. 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
  1. .Q:'$D(^AUPNVSIT(V,0))
  1. .Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
  1. .S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
  1. .Q:'Z
  1. .S N=$P($G(^PSDRUG(Z,0)),U)
  1. .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
  1. .I $D(^ATXAX(T,21,"B",Z))!(N["NICOTINE PATCH")!(N["NICOTINE POLACRILEX")!(N["NICOTINE INHALER")!(N["NICOTINE NASAL SPRAY") D
  1. ..I $P(BUDLPED,U)<$P($P(^AUPNVSIT(V,0),U),".") S BUDLPED=$P($P(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
  1. .S C=$P($G(^PSDRUG(Z,2)),U,4)
  1. .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
  1. I BUDLPED]"" Q $P(BUDLPED,U,2)_U_$$DATE^BUDDUTL1($P(BUDLPED,U,1))_U_$P(BUDLPED,U,1) ;BUDLPED
  1. Q ""
  1. NDC(A,B) ;
  1. ;a is drug ien
  1. ;b is taxonomy ien
  1. NEW BUDNDC
  1. S BUDNDC=$P($G(^PSDRUG(A,2)),U,4)
  1. I BUDNDC]"",B,$D(^ATXAX(B,21,"B",BUDNDC)) Q 1
  1. Q 0
  1. TOBUSER(P,BDATE,EDATE) ;
  1. NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB,V
  1. D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
  1. S TIEN=$O(^BUDDTSSC("B","T6B TOBACCO USER CODES",0))
  1. S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR D
  1. .S VIEN=$P(BUDVS(CTR),U,5)
  1. .S VDATE=$P(BUDVS(CTR),U,1)
  1. .S V=""
  1. .S X=0 F S X=$O(^AUPNVHF("AD",VIEN,X)) Q:X'=+X!(V) D
  1. ..Q:'$D(^AUPNVHF(X,0))
  1. ..S Y=$$VAL^XBDIQ1(9000010.23,X,.01)
  1. ..I $D(^BUDDTSSC(TIEN,18,"B",Y)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. .;CPT
  1. .S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X!(V) D
  1. ..Q:'$D(^AUPNVCPT(X,0))
  1. ..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
  1. ..Q:Y=""
  1. ..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. .;V TRANS
  1. .S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X!(V) D
  1. ..Q:'$D(^AUPNVTC(X,0))
  1. ..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
  1. ..Q:Y=""
  1. ..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. .;V PROC
  1. .S X=0 F S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X!(V) D
  1. ..Q:'$D(^AUPNVPRC(X,0))
  1. ..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
  1. ..I $D(^BUDDTSSC("AP",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. .;POV/SNOMED
  1. .S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X!(V) D
  1. ..Q:'$D(^AUPNVPOV(X,0))
  1. ..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
  1. ..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
  1. ..Q:Y=""
  1. ..I $D(^BUDDTSSC("AS",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..;PATIENT ED
  1. .S X=0 F S X=$O(^AUPNVPED("AD",VIEN,X)) Q:X'=+X!(V) D
  1. ..Q:'$D(^AUPNVPED(X,0))
  1. ..S T=$$VALI^XBDIQ1(9000010.16,X,.01)
  1. ..Q:'T
  1. ..Q:'$D(^AUTTEDT(T,0))
  1. ..S T=$P(^AUTTEDT(T,0),U,2)
  1. ..;I $P(T,"-")="TO" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..;I $P(T,"-",2)="TO" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..;I $P(T,"-",2)="SHS" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="305.1" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="649.00" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="649.01" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="649.02" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="649.03" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="649.04" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..;I $P(T,"-")="V15.82" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="1034F" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="1035F" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $E($P(T,"-"),1,3)="F17" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $E($P(T,"-"),1,6)="O99.33" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="Z72.0" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..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
  1. I $O(BUDTOB(0)) S X=$O(BUDTOB(0)),X=BUDTOB(X) Q X
  1. S Y=$$PLCL^BUDDDU(P,"T6B TOBACCO USER CODES",EDATE,0,BDATE)
  1. I Y Q "PL USER "_$P(Y,U,2)_U_$$DATE^BUDDUTL1($P(Y,U,3))_U_$P(Y,U,3)
  1. Q ""
  1. TOBSCRN(P,BDATE,EDATE) ;
  1. ;TOBACCO SCREENING IN DATE RANGE?
  1. NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB,V
  1. D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
  1. S TIEN=$O(^BUDDTSSC("B","T6B TOBACCO SCREEN CODES",0))
  1. S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR D
  1. .S V=""
  1. .S VIEN=$P(BUDVS(CTR),U,5)
  1. .S VDATE=$P(BUDVS(CTR),U,1)
  1. .S X=0 F S X=$O(^AUPNVHF("AD",VIEN,X)) Q:X'=+X!(V) D
  1. ..Q:'$D(^AUPNVHF(X,0))
  1. ..S Y=$$VAL^XBDIQ1(9000010.23,X,.01)
  1. ..I $D(^BUDDTSSC(TIEN,18,"B",Y)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. .;CPT
  1. .S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X!(V) D
  1. ..Q:'$D(^AUPNVCPT(X,0))
  1. ..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
  1. ..Q:Y=""
  1. ..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. .;V TRANS
  1. .S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X!(V) D
  1. ..Q:'$D(^AUPNVTC(X,0))
  1. ..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
  1. ..Q:Y=""
  1. ..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. .;V PROC
  1. .S X=0 F S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X!(V) D
  1. ..Q:'$D(^AUPNVPRC(X,0))
  1. ..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
  1. ..I $D(^BUDDTSSC("AP",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. .;POV/SNOMED
  1. .S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X!(V) D
  1. ..Q:'$D(^AUPNVPOV(X,0))
  1. ..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
  1. ..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
  1. ..Q:Y=""
  1. ..I $D(^BUDDTSSC("AS",Y,TIEN)) S BUDTOB(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. .;PATIENT ED
  1. .S X=0 F S X=$O(^AUPNVPED("AD",VIEN,X)) Q:X'=+X!(V) D
  1. ..Q:'$D(^AUPNVPED(X,0))
  1. ..S T=$$VALI^XBDIQ1(9000010.16,X,.01)
  1. ..Q:'T
  1. ..Q:'$D(^AUTTEDT(T,0))
  1. ..S T=$P(^AUTTEDT(T,0),U,2)
  1. ..I $P(T,"-")="TO" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-",2)="TO" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-",2)="SHS" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="305.1" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="649.00" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="649.01" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="649.02" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="649.03" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="649.04" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="V15.82" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="1034F" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="1035F" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="1036F" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="1000F" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $E($P(T,"-"),1,3)="F17" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $E($P(T,"-"),1,6)="O99.33" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. ..I $P(T,"-")="Z72.0" S BUDTOB(9999999-VDATE)=T_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE,V=1 Q
  1. I $O(BUDTOB(0)) S X=$O(BUDTOB(0)),X=BUDTOB(X) Q X
  1. S Y=$$PLCL^BUDDDU(P,"T6B TOBACCO SCREEN CODES",EDATE,0,BDATE)
  1. I Y Q "PL SCREEN "_$P(Y,U,2)_U_$$DATE^BUDDUTL1($P(Y,U,3))_U_$P(Y,U,3)
  1. Q ""
  1. S(V) ;
  1. S BUDDECNT=BUDDECNT+1
  1. S ^TMP($J,"BUDDEL",BUDDECNT)=$G(V)
  1. Q
  1. ;------
  1. NOSCREEN(P,BDATE,EDATE) ;
  1. NEW D,BUDG,E,%
  1. S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
  1. NEW X,Y,G,T,V,Z,A
  1. S T=$O(^BUDDTSSC("B","T6B TOBACCO NO SCREEN",0))
  1. S G=""
  1. S X=0 F S X=$O(BUDG(X)) Q:X'=+X!(G) D
  1. .S Y=+$P(BUDG(X),U,4)
  1. .S Z=$P($G(^AUPNVPOV(Y,0)),U,1)
  1. .I $D(^BUDDTSSC("AD",Z,T)) S G=1 Q
  1. .S Y=$$VAL^XBDIQ1(9000010.07,Y,1101)
  1. .Q:Y=""
  1. .I $D(^BUDDTSSC("AS",Y,T)) S G=1
  1. I G Q G
  1. S X=$$PLCL^BUDDDU(P,"T6B TOBACCO NO SCREEN",EDATE,0,BDATE) I X Q 1 ;"PROBLEM SNOMED "_$P(X,U,2)
  1. Q ""