BUDERP6D ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
;
;
PAPD ;EP - called from xbdbque
;must have DOB between 1/1/06 and 12/31/06
NEW BUDPAP,BUDHASP
S (BUDPAP,BUDHASP,BUDPAPH)=""
Q:$P(^DPT(DFN,0),U,2)'="F"
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUD64RB=($E(BUDBD,1,3)-64)_"0101"
S BUDX23RB=($E(BUDED,1,3)-23)_"1231"
S BUDDOB=$P(^DPT(DFN,0),U,3)
Q:BUDDOB<BUD64RB
Q:BUDDOB>BUDX23RB
Q:BUDMEDV<1
S BUD65TH=$E(BUDDOB,1,3)+65_$E(BUDDOB,4,7)
I '$$VBBD(DFN,BUDDOB,$$FMADD^XLFDT(BUD65TH,-1)) Q ;quit if no visiT before 65TH birthday
K BUDPAP ;
I $$HYSTER(DFN,BUDED) Q ;IF HYSTERECTOMY DON'T PUT IN DENOMINATOR
;THESE HAD A PAP IN PAST 3 YEARS
S BUDSECTD("PTS")=$G(BUDSECTD("PTS"))+1 ;denominator
S BUDD=$E(BUDED,1,3)-2_$E(BUDBD,4,7)
S BUDPAP=$$PAP(DFN,$$DOB^AUPNPAT(DFN),BUDED) ;GET LAST PAP DATE
S D=$P(BUDPAP,U,2)
S BUDPD=$E(BUDED,1,3)-2_$E(BUDBD,4,7)
I D'<BUDPD S BUDSECTD("PAP")=$G(BUDSECTD("PAP"))+1,BUDHASP=1
I BUDHASP G PAPL
;new v12 add hpv/pap same day in past 4 years for 30-64
S A=$$AGE^AUPNPAT(DFN,BUDBD)
I A<30 G PAPL
I A>64 G PAPL
S BUDPAPH=$$PAPHPV^BUDERP6M(DFN,BUDED,4)
I BUDPAPH]"" S BUDSECTD("PAP")=$G(BUDSECTD("PAP"))+1,BUDHASP=1
PAPL ;
I $G(BUDPAP1L),BUDHASP D
.I BUDPAPH]"" S BUDPAP=BUDPAPH
.S Y=$$FMTE^XLFDT($P(BUDPAP,U,2))_U_$P(BUDPAP,U,3)_U I $P(BUDPAP,U,4) S Y=Y_$$PRIMPROV^APCLV($P(BUDPAP,U,4),"D")_U_$P(^AUPNVSIT($P(BUDPAP,U,4),0),U,7)_U_$$CLINIC^APCLV($P(BUDPAP,U,4),"E")_U_$$LOCENC^APCLV($P(BUDPAP,U,4),"E")
.S ^XTMP("BUDERP6B",BUDJ,BUDH,"PAP1",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=Y
I $G(BUDPAP2L),'BUDHASP D
.S Y="" I BUDPAP="" S Y="Never"
.I Y="" S Y=$$FMTE^XLFDT($P(BUDPAP,U,2))_U_$P(BUDPAP,U,3)_U I $P(BUDPAP,U,4) S Y=Y_$$PRIMPROV^APCLV($P(BUDPAP,U,4),"D")_U_$P(^AUPNVSIT($P(BUDPAP,U,4),0),U,7)_U_$$CLINIC^APCLV($P(BUDPAP,U,4),"E")_U_$$LOCENC^APCLV($P(BUDPAP,U,4),"E")
.S ^XTMP("BUDERP6B",BUDJ,BUDH,"PAP2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=Y
Q
;
;
VBBD(P,BDATE,EDATE) ;EP
NEW BUDVL,G
K BUDVL
S G=""
S A="BUDVL(",B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(BUDVL) Q ""
S X=0 F S X=$O(BUDVL(X)) Q:X'=+X S V=$P(BUDVL(X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:'$D(^AUPNVPRV("AD",V))
.Q:'$D(^AUPNVPOV("AD",V))
.S L=$P(^AUPNVSIT(V,0),U,6)
.Q:L=""
.Q:'$D(^BUDESITE(BUDSITE,11,L)) ;not valid location
.Q:$P(^AUPNVSIT(V,0),U,7)="C"
.Q:$P(^AUPNVSIT(V,0),U,7)="T"
.Q:$P(^AUPNVSIT(V,0),U,7)="N"
.Q:$P(^AUPNVSIT(V,0),U,7)="D"
.Q:$P(^AUPNVSIT(V,0),U,7)="X"
.Q:$P(^AUPNVSIT(V,0),U,7)="E"
.S G=V
.Q
Q G
;
PAP(P,BDATE,EDATE) ;EP
NEW BUDD,BUDLPAP,T,BUDLT,B,E,D,L,X,Z,J,T,BUD
K BUDD
S BUDD=""
S BUDLPAP=""
S T=$O(^ATXAX("B","BGP PAP LOINC CODES",0))
S BUDLT=$O(^ATXLAB("B","BGP PAP SMEAR TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BUDD]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BUDD]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BUDD]"") D
...Q:'$D(^AUPNVLAB(X,0))
...S Z=$P(^AUPNVLAB(X,0),U),Z=$P($G(^LAB(60,Z,0)),U) I Z="PAP SMEAR" S BUDD="1^"_(9999999-D)_"^Lab "_Z_U_$P(^AUPNVLAB(X,0),U,3) Q
...I BUDLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BUDLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BUDD="1^"_(9999999-D)_"^Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_U_$P(^AUPNVLAB(X,0),U,3) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S BUDD="1^"_(9999999-D)_"^Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_U_$P(^AUPNVLAB(X,0),U,3) Q
...Q
S BUDLPAP=BUDD
K BUD
K BUD S %=P_"^LAST PROCEDURE 91.46;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BUD(")
I $D(BUD(1)),$P(BUDLPAP,U,2)<$P(BUD(1),U,1) S BUDLPAP="1^"_$P(BUD(1),U)_"^PROC 91.46^"_$P(BUD(1),U,5)
K BUD S %=P_"^LAST DX V72.32;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BUD(")
I $D(BUD(1)),$P(BUDLPAP,U,2)<$P(BUD(1),U,1) S BUDLPAP="1^"_$P(BUD(1),U)_"^DX: V72.32^"_$P(BUD(1),U,5)
K BUD S %=P_"^LAST DX Z01.42;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BUD(")
I $D(BUD(1)),$P(BUDLPAP,U,2)<$P(BUD(1),U,1) S BUDLPAP="1^"_$P(BUD(1),U)_"^DX: Z01.42^"_$P(BUD(1),U,5)
S T=$O(^ATXAX("B","BUD CPT PAP UDS 17",0))
I T D I X]"",$P(BUDLPAP,U,2)<$P(X,U,2) S BUDLPAP="1^"_$P(X,U,2)_"^CPT "_$P(X,U,3)_"^"_$P(X,U,5)
.S X=$$CPT^BUDEDU(P,BDATE,EDATE,T,6) I X]"" Q
.S X=$$TRAN^BUDEDU(P,BDATE,EDATE,T,6)
S T="PAP SMEAR",T=$O(^BWPN("B",T,0))
I T D I X]"",$P(BUDLPAP,U,2)<X S BUDLPAP="1^"_X_"^WH PAP SMEAR"
.S X=$$WH^BUDEDU(P,BDATE,EDATE,T,3)
Q BUDLPAP
;
LOINC(A,B) ;EP
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
;
HYSTER(P,EDATE) ;EP
I '$G(P) Q ""
NEW BUDG,VIEN,VDATE,CTR,X,Y,Z,T,BUDVS,TIEN
;
S T="HYSTERECTOMY",T=$O(^BWPN("B",T,0))
I T D I X]"" Q 1
.S X=$$WH^BUDEDU(P,$$DOB^AUPNPAT(P),EDATE,T,2)
D ALLV^APCLAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BUDVS") ;all visits in 42 days to end
S TIEN=$O(^BUDETSSC("B","T6B PAP HYSTERECTOMY CODES",0))
S CTR=0,G="" F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR!(G) D
.S VIEN=$P(BUDVS(CTR),U,5)
.S VDATE=$P(BUDVS(CTR),U,1)
.;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(^BUDETSSC("AC",Y,TIEN)) S G=1 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(^BUDETSSC("AC",Y,TIEN)) S G=1 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(^BUDETSSC("AP",Y,TIEN)) S G=1 Q
.;SNOMED/DX
.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(^BUDETSSC("AD",Y,TIEN)) S G=1 Q
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDETSSC("AS",Y,TIEN)) S G=1 Q
I G Q 1
S X=$$PLCL^BUDEDU(P,"T6B PAP HYSTERECTOMY CODES",EDATE,0) I X Q 1
Q ""
MMR(P,BDATE,EDATE) ;EP
;first check for contraindications
MMRC ;
NEW BUDG,%,E,T,X,G,Y,Z,S,N,BUDZ,BUDX,BUDMR,BUDMU,BUDMEA,BUDRUB,BUDVS,TIEN,TIENMR,TIENMU,TIENMEA,TIENRUB,CTR,VIEN,VDATE
NEW BUDEVRUB,BUDEVMU,BUDEVMEA,BUDCORUB,BUDCOMU,BUDCOMEA
;V11.0 ICD10
K BUDG S %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDETSSC("B","T6B IMM CONTRA VARICELLA/MMR",0))
S X=0,G="" 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(^BUDETSSC("AD",Z,T)) S G="1^MMR: CONTRA DX "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDEUTL1($P(BUDG(X),U))
.S S=$$VAL^XBDIQ1(9000010.07,Y,1101) I S]"",$D(^BUDETSSC("AS",S,T)) S G="1^MMR: CONTRA DX "_S_" on "_$$DATE^BUDEUTL1($P(BUDG(X),U))
I G]"" Q G
S X=$$PLCL^BUDEDU(P,"T6B IMM CONTRA VARICELLA/MMR",EDATE,0) I X Q "1^MMR: CONTRA DX "_$P(X,U,2)_" on Problem List"
S G=""
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X!(G) D
.;Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE ;entered after 2ND birthday
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.Q:'$$ANAREACT^BUDERP6C(X) ;quit if anaphylactic is not a reaction/sign/symptom
.I N["NEOMYCIN" S G="1^MMR: CONTRA "_$$DATE^BUDEUTL1($P($P($G(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
I G]"" Q G
F BUDZ=3,94,5,7,6 S X=$$MMRCONT^BUDERP6C(P,BUDZ,EDATE) Q:X]""
I X]"" Q "1^MMR CONTRA: "_$P(X,U,2)_" on "_$$DATE^BUDEUTL1($P(X,U,1))_" Immunization Package"
MMR1 ;
;
S (BUDX,BUDMR,BUDMU,BUDMEA,BUDRUB)=""
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS") ;all visits in 42 days to end
S TIEN=$O(^BUDETSSC("B","T6B IMM MMR CODES",0))
S TIENMR=$O(^BUDETSSC("B","T6B IMM MR CODES",0))
S TIENMU=$O(^BUDETSSC("B","T6B IMM MUMPS CODES",0))
S TIENMEA=$O(^BUDETSSC("B","T6B IMM MEASLES CODES",0))
S TIENRUB=$O(^BUDETSSC("B","T6B IMM RUBELLA 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 X=0 F S X=$O(^AUPNVIMM("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVIMM(X,0))
..S Y=$$VALI^XBDIQ1(9000010.11,X,.01)
..S Y=+$P($G(^AUTTIMM(Y,0)),U,3)
..Q:'Y
..I $D(^BUDETSSC(TIEN,15,"B",Y)) S BUDX="CVX "_Y_" on "_$$DATE^BUDEUTL1(VDATE) Q
..I $D(^BUDETSSC(TIENMR,15,"B",Y)) S BUDMR="CVX "_Y_" on "_$$DATE^BUDEUTL1,BUDADT="CVX "_Y_" on "_$$DATE^BUDEUTL1(VDATE) Q
..I $D(^BUDETSSC(TIENMU,15,"B",Y)) S BUDMU="CVX "_Y_" on "_$$DATE^BUDEUTL1(VDATE) Q
..I $D(^BUDETSSC(TIENMEA,15,"B",Y)) S BUDMEA="CVX "_Y_" on "_$$DATE^BUDEUTL1(VDATE) Q
..I $D(^BUDETSSC(TIENRUB,15,"B",Y)) S BUDRUB="CVX "_Y_" on "_$$DATE^BUDEUTL1(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(^BUDETSSC("AC",Y,TIEN)) S BUDX="CPT "_Y_" on "_$$DATE^BUDEUTL1(VDATE) Q
..I $D(^BUDETSSC("AC",Y,TIENMR)) S BUDMR="CPT "_Y_" on "_$$DATE^BUDEUTL1
..I $D(^BUDETSSC("AC",Y,TIENMU)) S BUDMU="CPT "_Y_" on "_$$DATE^BUDEUTL1(VDATE) Q
..I $D(^BUDETSSC("AC",Y,TIENMEA)) S BUDMEA="CPT "_Y_" on "_$$DATE^BUDEUTL1(VDATE) Q
..I $D(^BUDETSSC("AC",Y,TIENRUB)) S BUDRUB="CPT "_Y_" on "_$$DATE^BUDEUTL1(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(^BUDETSSC("AC",Y,TIEN)) S BUDX="CPT/TRAN "_Y_" on "_$$DATE^BUDEUTL1(VDATE) Q
..I $D(^BUDETSSC("AC",Y,TIENMR)) S BUDMR="CPT/TRAN "_Y_" on "_$$DATE^BUDEUTL1
..I $D(^BUDETSSC("AC",Y,TIENMU)) S BUDMU="CPT/TRAN "_Y_" on "_$$DATE^BUDEUTL1(VDATE) Q
..I $D(^BUDETSSC("AC",Y,TIENMEA)) S BUDMEA="CPT/TRAN "_Y_" on "_$$DATE^BUDEUTL1(VDATE) Q
..I $D(^BUDETSSC("AC",Y,TIENRUB)) S BUDRUB="CPT/TRAN "_Y_" on "_$$DATE^BUDEUTL1(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(^BUDETSSC("AP",Y,TIEN)) S BUDX="PROC "_Y_" on "_$$DATE^BUDEUTL1(VDATE) Q
..I $D(^BUDETSSC("AP",Y,TIENMR)) S BUDMR="PROC "_Y_" on "_$$DATE^BUDEUTL1
..I $D(^BUDETSSC("AP",Y,TIENMU)) S BUDMU="PROC "_Y_" on "_$$DATE^BUDEUTL1(VDATE) Q
..I $D(^BUDETSSC("AP",Y,TIENMEA)) S BUDMEA="PROC "_Y_" on "_$$DATE^BUDEUTL1(VDATE) Q
..I $D(^BUDETSSC("AP",Y,TIENRUB)) S BUDRUB="PROC "_Y_" on "_$$DATE^BUDEUTL1(VDATE) Q
.S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDETSSC("AS",Y,TIEN)) S BUDX="SNOMED "_Y_" on "_$$DATE^BUDEUTL1(VDATE) Q
..I $D(^BUDETSSC("AS",Y,TIENMR)) S BUDMR="SNOMED "_Y_" on "_$$DATE^BUDEUTL1
..I $D(^BUDETSSC("AS",Y,TIENMU)) S BUDMU="SNOMED "_Y_" on "_$$DATE^BUDEUTL1(VDATE) Q
..I $D(^BUDETSSC("AS",Y,TIENMEA)) S BUDMEA="SNOMED "_Y_" on "_$$DATE^BUDEUTL1(VDATE) Q
..I $D(^BUDETSSC("AS",Y,TIENRUB)) S BUDRUB="SNOMED "_Y_" on "_$$DATE^BUDEUTL1(VDATE) Q
I BUDX]"" Q "1^MMR: "_BUDX
S (BUDEVRUB,BUDEVMU,BUDEVMEA,BUDCORUB,BUDCOMU,BUDCOMEA)=""
;now check contra to DTap
S X=$$CONTRA^BUDERP6C(P,$$DOB^AUPNPAT(P),EDATE,$O(^BUDETSSC("B","T6B IMM MMR CODES",0)),"MMR")
I X Q X
MR1 ;
S (X,Y)="",C=0 F S X=$O(BUDMR(X)) Q:X'=+X S BUDMU(X)="",BUDRUB(X)=""
;HAS ONE OF EACH
I BUDMEA]"",BUDMU]"",BUDRUB]"" Q "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
;
MEAEVCO ;
I BUDMEA]"" G MUEVCO
;V10.0 ICD10
K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDETSSC("B","T6B IMM EVIDENCE MEASLES",0))
S X=0,BUDEVMEA="" F S X=$O(BUDG(X)) Q:X'=+X!(BUDEVMEA]"") D
.S Y=+$P(BUDG(X),U,4)
.S Z=$P($G(^AUPNVPOV(Y,0)),U,1)
.I $D(^BUDETSSC("AD",Z,T)) S BUDEVMEA="1^Measles: Evidence "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDEUTL1($P(BUDG(X),U)) Q
.S S=$$VAL^XBDIQ1(9000010.07,Y,1101) I S]"",$D(^BUDETSSC("AS",S,T)) S BUDEVMEA="1^Measles: Evidence "_S_" on "_$$DATE^BUDEUTL1($P(BUDG(X),U)) Q
S X=$$PLCL^BUDEDU(P,"T6B IMM EVIDENCE MEASLES",EDATE,0) I X S BUDMEA="1^Measles Evidence: "_$P(X,U,2)_" on Problem List"
I BUDEVMEA]"" S BUDMEA=BUDEVMEA
I BUDMEA]"",BUDMU]"",BUDRUB]"" Q "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
;CONTRA
S BUDCOMEA=$$CONTRA^BUDERP6C(P,$$DOB^AUPNPAT(P),EDATE,$O(^BUDETSSC("B","T6B IMM MEASLES CODES",0)),"MEASLES")
I BUDCOMEA]"" S BUDMEA=BUDCOMEA
I BUDMEA]"",BUDMU]"",BUDRUB]"" Q "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
;
MUEVCO ;
I BUDMU]"" G RUBEVCO
K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDETSSC("B","T6B IMM EVIDENCE MUMPS",0))
S X=0,BUDEVMU="" F S X=$O(BUDG(X)) Q:X'=+X!(BUDEVMU]"") D
.S Y=+$P(BUDG(X),U,4)
.S Z=$P($G(^AUPNVPOV(Y,0)),U,1)
.I $D(^BUDETSSC("AD",Z,T)) S BUDEVMU="1^Mumps: Evidence "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDEUTL1($P(BUDG(X),U)) Q
.S S=$$VAL^XBDIQ1(9000010.07,Y,1101) I S]"",$D(^BUDETSSC("AS",S,T)) S BUDEVMU="1^Mumps: Evidence "_S_" on "_$$DATE^BUDEUTL1($P(BUDG(X),U)) Q
S X=$$PLCL^BUDEDU(P,"T6B IMM EVIDENCE MUMPS",EDATE,0) I X S BUDEVMU="1^Mumps: Evidence "_$P(X,U,2)_" on Problem List"
I BUDEVMU]"" S BUDMU=BUDEVMU
I BUDMEA]"",BUDMU]"",BUDRUB]"" Q "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
;CONTRA
S BUDCOMU=$$CONTRA^BUDERP6C(P,$$DOB^AUPNPAT(P),EDATE,$O(^BUDETSSC("B","T6B IMM MUMPS CODES",0)),"MUMPS")
I BUDCOMU]"" S BUDMU=BUDCOMU
I BUDMEA]"",BUDMU]"",BUDRUB]"" Q "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
RUBEVCO ;
I BUDRUB]"" G MMRQ
K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDETSSC("B","T6B IMM EVIDENCE RUBELLA",0))
S X=0,BUDEVRUB="" F S X=$O(BUDG(X)) Q:X'=+X!(BUDEVRUB]"") D
.S Y=+$P(BUDG(X),U,4)
.S Z=$P($G(^AUPNVPOV(Y,0)),U,1)
.I $D(^BUDETSSC("AD",Z,T)) S BUDEVRUB="1^Rubella: Evidence "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDEUTL1($P(BUDG(X),U)) Q
.S S=$$VAL^XBDIQ1(9000010.07,Y,1101) I S]"",$D(^BUDETSSC("AS",S,T)) S BUDEVRUB="1^Rubella: Evidence "_S_" on "_$$DATE^BUDEUTL1($P(BUDG(X),U)) Q
S X=$$PLCL^BUDEDU(P,"T6B IMM EVIDENCE RUBELLA",EDATE,0) I X S BUDEVRUB="1^Rubella: Evidence: "_$P(X,U,2)_" on Problem List"
I BUDEVRUB]"" S BUDRUB=BUDEVRUB
I BUDMEA]"",BUDMU]"",BUDRUB]"" Q "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
;CONTRA
S BUDCORUB=$$CONTRA^BUDERP6C(P,$$DOB^AUPNPAT(P),EDATE,$O(^BUDETSSC("B","T6B IMM RUBELLA CODES",0)),"RUBELLA")
I BUDCORUB]"" S BUDRUB=BUDCORUB
I BUDMEA]"",BUDMU]"",BUDRUB]"" Q "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
MMRQ ;
I BUDMEA="",BUDMU="",BUDRUB="" Q "0^1 MEASLES MUMPS RUBBELLA"
Q "0^"_$S(BUDMEA="":" 1 MEASLES",1:"")_$S(BUDMU="":" 1 MUMPS",1:"")_$S(BUDRUB="":" 1 RUBELLA",1:"")
BUDERP6D ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
+1 ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
+2 ;
+3 ;
PAPD ;EP - called from xbdbque
+1 ;must have DOB between 1/1/06 and 12/31/06
+2 NEW BUDPAP,BUDHASP
+3 SET (BUDPAP,BUDHASP,BUDPAPH)=""
+4 IF $PIECE(^DPT(DFN,0),U,2)'="F"
QUIT
+5 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+6 SET BUD64RB=($EXTRACT(BUDBD,1,3)-64)_"0101"
+7 SET BUDX23RB=($EXTRACT(BUDED,1,3)-23)_"1231"
+8 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+9 IF BUDDOB<BUD64RB
QUIT
+10 IF BUDDOB>BUDX23RB
QUIT
+11 IF BUDMEDV<1
QUIT
+12 SET BUD65TH=$EXTRACT(BUDDOB,1,3)+65_$EXTRACT(BUDDOB,4,7)
+13 ;quit if no visiT before 65TH birthday
IF '$$VBBD(DFN,BUDDOB,$$FMADD^XLFDT(BUD65TH,-1))
QUIT
+14 ;
KILL BUDPAP
+15 ;IF HYSTERECTOMY DON'T PUT IN DENOMINATOR
IF $$HYSTER(DFN,BUDED)
QUIT
+16 ;THESE HAD A PAP IN PAST 3 YEARS
+17 ;denominator
SET BUDSECTD("PTS")=$GET(BUDSECTD("PTS"))+1
+18 SET BUDD=$EXTRACT(BUDED,1,3)-2_$EXTRACT(BUDBD,4,7)
+19 ;GET LAST PAP DATE
SET BUDPAP=$$PAP(DFN,$$DOB^AUPNPAT(DFN),BUDED)
+20 SET D=$PIECE(BUDPAP,U,2)
+21 SET BUDPD=$EXTRACT(BUDED,1,3)-2_$EXTRACT(BUDBD,4,7)
+22 IF D'<BUDPD
SET BUDSECTD("PAP")=$GET(BUDSECTD("PAP"))+1
SET BUDHASP=1
+23 IF BUDHASP
GOTO PAPL
+24 ;new v12 add hpv/pap same day in past 4 years for 30-64
+25 SET A=$$AGE^AUPNPAT(DFN,BUDBD)
+26 IF A<30
GOTO PAPL
+27 IF A>64
GOTO PAPL
+28 SET BUDPAPH=$$PAPHPV^BUDERP6M(DFN,BUDED,4)
+29 IF BUDPAPH]""
SET BUDSECTD("PAP")=$GET(BUDSECTD("PAP"))+1
SET BUDHASP=1
PAPL ;
+1 IF $GET(BUDPAP1L)
IF BUDHASP
Begin DoDot:1
+2 IF BUDPAPH]""
SET BUDPAP=BUDPAPH
+3 SET Y=$$FMTE^XLFDT($PIECE(BUDPAP,U,2))_U_$PIECE(BUDPAP,U,3)_U
IF $PIECE(BUDPAP,U,4)
SET Y=Y_$$PRIMPROV^APCLV($PIECE(BUDPAP,U,4),"D")_U_$PIECE(^AUPNVSIT($PIECE(BUDPAP,U,4),0),U,7)_U_$$CLINIC^APCLV($PIECE(BUDPAP,U,4),"E")_U_$$LOCENC^APCLV($PIECE(BUDPAP,U,4),"E")
+4 SET ^XTMP("BUDERP6B",BUDJ,BUDH,"PAP1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=Y
End DoDot:1
+5 IF $GET(BUDPAP2L)
IF 'BUDHASP
Begin DoDot:1
+6 SET Y=""
IF BUDPAP=""
SET Y="Never"
+7 IF Y=""
SET Y=$$FMTE^XLFDT($PIECE(BUDPAP,U,2))_U_$PIECE(BUDPAP,U,3)_U
IF $PIECE(BUDPAP,U,4)
SET Y=Y_$$PRIMPROV^APCLV($PIECE(BUDPAP,U,4),"D")_U_$PIECE(^AUPNVSIT($PIECE(BUDPAP,U,4),0),U,7)_U_$$CLINIC^APCLV($PIECE(BUDPAP,U,4),"E")_U_$$LOCENC^APCLV($PIECE(BUDPAP,U,4),"E")
+8 SET ^XTMP("BUDERP6B",BUDJ,BUDH,"PAP2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=Y
End DoDot:1
+9 QUIT
+10 ;
+11 ;
VBBD(P,BDATE,EDATE) ;EP
+1 NEW BUDVL,G
+2 KILL BUDVL
+3 SET G=""
+4 SET A="BUDVL("
SET B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+5 IF '$DATA(BUDVL)
QUIT ""
+6 SET X=0
FOR
SET X=$ORDER(BUDVL(X))
IF X'=+X
QUIT
SET V=$PIECE(BUDVL(X),U,5)
Begin DoDot:1
+7 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+8 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+9 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+10 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+11 IF '$DATA(^AUPNVPOV("AD",V))
QUIT
+12 SET L=$PIECE(^AUPNVSIT(V,0),U,6)
+13 IF L=""
QUIT
+14 ;not valid location
IF '$DATA(^BUDESITE(BUDSITE,11,L))
QUIT
+15 IF $PIECE(^AUPNVSIT(V,0),U,7)="C"
QUIT
+16 IF $PIECE(^AUPNVSIT(V,0),U,7)="T"
QUIT
+17 IF $PIECE(^AUPNVSIT(V,0),U,7)="N"
QUIT
+18 IF $PIECE(^AUPNVSIT(V,0),U,7)="D"
QUIT
+19 IF $PIECE(^AUPNVSIT(V,0),U,7)="X"
QUIT
+20 IF $PIECE(^AUPNVSIT(V,0),U,7)="E"
QUIT
+21 SET G=V
+22 QUIT
End DoDot:1
+23 QUIT G
+24 ;
PAP(P,BDATE,EDATE) ;EP
+1 NEW BUDD,BUDLPAP,T,BUDLT,B,E,D,L,X,Z,J,T,BUD
+2 KILL BUDD
+3 SET BUDD=""
+4 SET BUDLPAP=""
+5 SET T=$ORDER(^ATXAX("B","BGP PAP LOINC CODES",0))
+6 SET BUDLT=$ORDER(^ATXLAB("B","BGP PAP SMEAR TAX",0))
+7 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BUDD]"")
QUIT
Begin DoDot:1
+8 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BUDD]"")
QUIT
Begin DoDot:2
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BUDD]"")
QUIT
Begin DoDot:3
+10 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+11 SET Z=$PIECE(^AUPNVLAB(X,0),U)
SET Z=$PIECE($GET(^LAB(60,Z,0)),U)
IF Z="PAP SMEAR"
SET BUDD="1^"_(9999999-D)_"^Lab "_Z_U_$PIECE(^AUPNVLAB(X,0),U,3)
QUIT
+12 IF BUDLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BUDLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BUDD="1^"_(9999999-D)_"^Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_U_$PIECE(^AUPNVLAB(X,0),U,3)
QUIT
+13 IF 'T
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC(J,T)
QUIT
+16 SET BUDD="1^"_(9999999-D)_"^Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_U_$PIECE(^AUPNVLAB(X,0),U,3)
QUIT
+17 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 SET BUDLPAP=BUDD
+19 KILL BUD
+20 KILL BUD
SET %=P_"^LAST PROCEDURE 91.46;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BUD(")
+21 IF $DATA(BUD(1))
IF $PIECE(BUDLPAP,U,2)<$PIECE(BUD(1),U,1)
SET BUDLPAP="1^"_$PIECE(BUD(1),U)_"^PROC 91.46^"_$PIECE(BUD(1),U,5)
+22 KILL BUD
SET %=P_"^LAST DX V72.32;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BUD(")
+23 IF $DATA(BUD(1))
IF $PIECE(BUDLPAP,U,2)<$PIECE(BUD(1),U,1)
SET BUDLPAP="1^"_$PIECE(BUD(1),U)_"^DX: V72.32^"_$PIECE(BUD(1),U,5)
+24 KILL BUD
SET %=P_"^LAST DX Z01.42;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BUD(")
+25 IF $DATA(BUD(1))
IF $PIECE(BUDLPAP,U,2)<$PIECE(BUD(1),U,1)
SET BUDLPAP="1^"_$PIECE(BUD(1),U)_"^DX: Z01.42^"_$PIECE(BUD(1),U,5)
+26 SET T=$ORDER(^ATXAX("B","BUD CPT PAP UDS 17",0))
+27 IF T
Begin DoDot:1
+28 SET X=$$CPT^BUDEDU(P,BDATE,EDATE,T,6)
IF X]""
QUIT
+29 SET X=$$TRAN^BUDEDU(P,BDATE,EDATE,T,6)
End DoDot:1
IF X]""
IF $PIECE(BUDLPAP,U,2)<$PIECE(X,U,2)
SET BUDLPAP="1^"_$PIECE(X,U,2)_"^CPT "_$PIECE(X,U,3)_"^"_$PIECE(X,U,5)
+30 SET T="PAP SMEAR"
SET T=$ORDER(^BWPN("B",T,0))
+31 IF T
Begin DoDot:1
+32 SET X=$$WH^BUDEDU(P,BDATE,EDATE,T,3)
End DoDot:1
IF X]""
IF $PIECE(BUDLPAP,U,2)<X
SET BUDLPAP="1^"_X_"^WH PAP SMEAR"
+33 QUIT BUDLPAP
+34 ;
LOINC(A,B) ;EP
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
+7 ;
HYSTER(P,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW BUDG,VIEN,VDATE,CTR,X,Y,Z,T,BUDVS,TIEN
+3 ;
+4 SET T="HYSTERECTOMY"
SET T=$ORDER(^BWPN("B",T,0))
+5 IF T
Begin DoDot:1
+6 SET X=$$WH^BUDEDU(P,$$DOB^AUPNPAT(P),EDATE,T,2)
End DoDot:1
IF X]""
QUIT 1
+7 ;all visits in 42 days to end
DO ALLV^APCLAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BUDVS")
+8 SET TIEN=$ORDER(^BUDETSSC("B","T6B PAP HYSTERECTOMY CODES",0))
+9 SET CTR=0
SET G=""
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR!(G)
QUIT
Begin DoDot:1
+10 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+11 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+12 ;CPT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X
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(^BUDETSSC("AC",Y,TIEN))
SET G=1
QUIT
End DoDot:2
+18 ;V TRANS
+19 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X
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(^BUDETSSC("AC",Y,TIEN))
SET G=1
QUIT
End DoDot:2
+24 ;V PROC
+25 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+26 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+27 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+28 IF $DATA(^BUDETSSC("AP",Y,TIEN))
SET G=1
QUIT
End DoDot:2
+29 ;SNOMED/DX
+30 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+31 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+32 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
+33 IF $DATA(^BUDETSSC("AD",Y,TIEN))
SET G=1
QUIT
+34 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+35 IF Y=""
QUIT
+36 IF $DATA(^BUDETSSC("AS",Y,TIEN))
SET G=1
QUIT
End DoDot:2
End DoDot:1
+37 IF G
QUIT 1
+38 SET X=$$PLCL^BUDEDU(P,"T6B PAP HYSTERECTOMY CODES",EDATE,0)
IF X
QUIT 1
+39 QUIT ""
MMR(P,BDATE,EDATE) ;EP
+1 ;first check for contraindications
MMRC ;
+1 NEW BUDG,%,E,T,X,G,Y,Z,S,N,BUDZ,BUDX,BUDMR,BUDMU,BUDMEA,BUDRUB,BUDVS,TIEN,TIENMR,TIENMU,TIENMEA,TIENRUB,CTR,VIEN,VDATE
+2 NEW BUDEVRUB,BUDEVMU,BUDEVMEA,BUDCORUB,BUDCOMU,BUDCOMEA
+3 ;V11.0 ICD10
+4 KILL BUDG
SET %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+5 SET T=$ORDER(^BUDETSSC("B","T6B IMM CONTRA VARICELLA/MMR",0))
+6 SET X=0
SET G=""
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(^BUDETSSC("AD",Z,T))
SET G="1^MMR: CONTRA DX "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDEUTL1($PIECE(BUDG(X),U))
+10 SET S=$$VAL^XBDIQ1(9000010.07,Y,1101)
IF S]""
IF $DATA(^BUDETSSC("AS",S,T))
SET G="1^MMR: CONTRA DX "_S_" on "_$$DATE^BUDEUTL1($PIECE(BUDG(X),U))
End DoDot:1
+11 IF G]""
QUIT G
+12 SET X=$$PLCL^BUDEDU(P,"T6B IMM CONTRA VARICELLA/MMR",EDATE,0)
IF X
QUIT "1^MMR: CONTRA DX "_$PIECE(X,U,2)_" on Problem List"
+13 SET G=""
+14 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+15 ;Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE ;entered after 2ND birthday
+16 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+17 ;quit if anaphylactic is not a reaction/sign/symptom
IF '$$ANAREACT^BUDERP6C(X)
QUIT
+18 IF N["NEOMYCIN"
SET G="1^MMR: CONTRA "_$$DATE^BUDEUTL1($PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
End DoDot:1
+19 IF G]""
QUIT G
+20 FOR BUDZ=3,94,5,7,6
SET X=$$MMRCONT^BUDERP6C(P,BUDZ,EDATE)
IF X]""
QUIT
+21 IF X]""
QUIT "1^MMR CONTRA: "_$PIECE(X,U,2)_" on "_$$DATE^BUDEUTL1($PIECE(X,U,1))_" Immunization Package"
MMR1 ;
+1 ;
+2 SET (BUDX,BUDMR,BUDMU,BUDMEA,BUDRUB)=""
+3 ;all visits in 42 days to end
DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+4 SET TIEN=$ORDER(^BUDETSSC("B","T6B IMM MMR CODES",0))
+5 SET TIENMR=$ORDER(^BUDETSSC("B","T6B IMM MR CODES",0))
+6 SET TIENMU=$ORDER(^BUDETSSC("B","T6B IMM MUMPS CODES",0))
+7 SET TIENMEA=$ORDER(^BUDETSSC("B","T6B IMM MEASLES CODES",0))
+8 SET TIENRUB=$ORDER(^BUDETSSC("B","T6B IMM RUBELLA CODES",0))
+9 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+10 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+11 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+12 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+13 IF '$DATA(^AUPNVIMM(X,0))
QUIT
+14 SET Y=$$VALI^XBDIQ1(9000010.11,X,.01)
+15 SET Y=+$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+16 IF 'Y
QUIT
+17 IF $DATA(^BUDETSSC(TIEN,15,"B",Y))
SET BUDX="CVX "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
+18 IF $DATA(^BUDETSSC(TIENMR,15,"B",Y))
SET BUDMR="CVX "_Y_" on "_$$DATE^BUDEUTL1
SET BUDADT="CVX "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
+19 IF $DATA(^BUDETSSC(TIENMU,15,"B",Y))
SET BUDMU="CVX "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
+20 IF $DATA(^BUDETSSC(TIENMEA,15,"B",Y))
SET BUDMEA="CVX "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
+21 IF $DATA(^BUDETSSC(TIENRUB,15,"B",Y))
SET BUDRUB="CVX "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
End DoDot:2
+22 ;CPT
+23 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+24 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+25 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+26 IF Y=""
QUIT
+27 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET BUDX="CPT "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
+28 IF $DATA(^BUDETSSC("AC",Y,TIENMR))
SET BUDMR="CPT "_Y_" on "_$$DATE^BUDEUTL1
+29 IF $DATA(^BUDETSSC("AC",Y,TIENMU))
SET BUDMU="CPT "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
+30 IF $DATA(^BUDETSSC("AC",Y,TIENMEA))
SET BUDMEA="CPT "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
+31 IF $DATA(^BUDETSSC("AC",Y,TIENRUB))
SET BUDRUB="CPT "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
End DoDot:2
+32 ;V TRANS
+33 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+34 IF '$DATA(^AUPNVTC(X,0))
QUIT
+35 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+36 IF Y=""
QUIT
+37 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET BUDX="CPT/TRAN "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
+38 IF $DATA(^BUDETSSC("AC",Y,TIENMR))
SET BUDMR="CPT/TRAN "_Y_" on "_$$DATE^BUDEUTL1
+39 IF $DATA(^BUDETSSC("AC",Y,TIENMU))
SET BUDMU="CPT/TRAN "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
+40 IF $DATA(^BUDETSSC("AC",Y,TIENMEA))
SET BUDMEA="CPT/TRAN "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
+41 IF $DATA(^BUDETSSC("AC",Y,TIENRUB))
SET BUDRUB="CPT/TRAN "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
End DoDot:2
+42 ;V PROC
+43 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+44 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+45 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+46 IF $DATA(^BUDETSSC("AP",Y,TIEN))
SET BUDX="PROC "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
+47 IF $DATA(^BUDETSSC("AP",Y,TIENMR))
SET BUDMR="PROC "_Y_" on "_$$DATE^BUDEUTL1
+48 IF $DATA(^BUDETSSC("AP",Y,TIENMU))
SET BUDMU="PROC "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
+49 IF $DATA(^BUDETSSC("AP",Y,TIENMEA))
SET BUDMEA="PROC "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
+50 IF $DATA(^BUDETSSC("AP",Y,TIENRUB))
SET BUDRUB="PROC "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
End DoDot:2
+51 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+52 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+53 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+54 IF Y=""
QUIT
+55 IF $DATA(^BUDETSSC("AS",Y,TIEN))
SET BUDX="SNOMED "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
+56 IF $DATA(^BUDETSSC("AS",Y,TIENMR))
SET BUDMR="SNOMED "_Y_" on "_$$DATE^BUDEUTL1
+57 IF $DATA(^BUDETSSC("AS",Y,TIENMU))
SET BUDMU="SNOMED "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
+58 IF $DATA(^BUDETSSC("AS",Y,TIENMEA))
SET BUDMEA="SNOMED "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
+59 IF $DATA(^BUDETSSC("AS",Y,TIENRUB))
SET BUDRUB="SNOMED "_Y_" on "_$$DATE^BUDEUTL1(VDATE)
QUIT
End DoDot:2
End DoDot:1
+60 IF BUDX]""
QUIT "1^MMR: "_BUDX
+61 SET (BUDEVRUB,BUDEVMU,BUDEVMEA,BUDCORUB,BUDCOMU,BUDCOMEA)=""
+62 ;now check contra to DTap
+63 SET X=$$CONTRA^BUDERP6C(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^BUDETSSC("B","T6B IMM MMR CODES",0)),"MMR")
+64 IF X
QUIT X
MR1 ;
+1 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDMR(X))
IF X'=+X
QUIT
SET BUDMU(X)=""
SET BUDRUB(X)=""
+2 ;HAS ONE OF EACH
+3 IF BUDMEA]""
IF BUDMU]""
IF BUDRUB]""
QUIT "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
+4 ;
MEAEVCO ;
+1 IF BUDMEA]""
GOTO MUEVCO
+2 ;V10.0 ICD10
+3 KILL BUDG
SET %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+4 SET T=$ORDER(^BUDETSSC("B","T6B IMM EVIDENCE MEASLES",0))
+5 SET X=0
SET BUDEVMEA=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(BUDEVMEA]"")
QUIT
Begin DoDot:1
+6 SET Y=+$PIECE(BUDG(X),U,4)
+7 SET Z=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+8 IF $DATA(^BUDETSSC("AD",Z,T))
SET BUDEVMEA="1^Measles: Evidence "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDEUTL1($PIECE(BUDG(X),U))
QUIT
+9 SET S=$$VAL^XBDIQ1(9000010.07,Y,1101)
IF S]""
IF $DATA(^BUDETSSC("AS",S,T))
SET BUDEVMEA="1^Measles: Evidence "_S_" on "_$$DATE^BUDEUTL1($PIECE(BUDG(X),U))
QUIT
End DoDot:1
+10 SET X=$$PLCL^BUDEDU(P,"T6B IMM EVIDENCE MEASLES",EDATE,0)
IF X
SET BUDMEA="1^Measles Evidence: "_$PIECE(X,U,2)_" on Problem List"
+11 IF BUDEVMEA]""
SET BUDMEA=BUDEVMEA
+12 IF BUDMEA]""
IF BUDMU]""
IF BUDRUB]""
QUIT "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
+13 ;CONTRA
+14 SET BUDCOMEA=$$CONTRA^BUDERP6C(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^BUDETSSC("B","T6B IMM MEASLES CODES",0)),"MEASLES")
+15 IF BUDCOMEA]""
SET BUDMEA=BUDCOMEA
+16 IF BUDMEA]""
IF BUDMU]""
IF BUDRUB]""
QUIT "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
+17 ;
MUEVCO ;
+1 IF BUDMU]""
GOTO RUBEVCO
+2 KILL BUDG
SET %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+3 SET T=$ORDER(^BUDETSSC("B","T6B IMM EVIDENCE MUMPS",0))
+4 SET X=0
SET BUDEVMU=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(BUDEVMU]"")
QUIT
Begin DoDot:1
+5 SET Y=+$PIECE(BUDG(X),U,4)
+6 SET Z=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+7 IF $DATA(^BUDETSSC("AD",Z,T))
SET BUDEVMU="1^Mumps: Evidence "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDEUTL1($PIECE(BUDG(X),U))
QUIT
+8 SET S=$$VAL^XBDIQ1(9000010.07,Y,1101)
IF S]""
IF $DATA(^BUDETSSC("AS",S,T))
SET BUDEVMU="1^Mumps: Evidence "_S_" on "_$$DATE^BUDEUTL1($PIECE(BUDG(X),U))
QUIT
End DoDot:1
+9 SET X=$$PLCL^BUDEDU(P,"T6B IMM EVIDENCE MUMPS",EDATE,0)
IF X
SET BUDEVMU="1^Mumps: Evidence "_$PIECE(X,U,2)_" on Problem List"
+10 IF BUDEVMU]""
SET BUDMU=BUDEVMU
+11 IF BUDMEA]""
IF BUDMU]""
IF BUDRUB]""
QUIT "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
+12 ;CONTRA
+13 SET BUDCOMU=$$CONTRA^BUDERP6C(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^BUDETSSC("B","T6B IMM MUMPS CODES",0)),"MUMPS")
+14 IF BUDCOMU]""
SET BUDMU=BUDCOMU
+15 IF BUDMEA]""
IF BUDMU]""
IF BUDRUB]""
QUIT "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
RUBEVCO ;
+1 IF BUDRUB]""
GOTO MMRQ
+2 KILL BUDG
SET %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+3 SET T=$ORDER(^BUDETSSC("B","T6B IMM EVIDENCE RUBELLA",0))
+4 SET X=0
SET BUDEVRUB=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(BUDEVRUB]"")
QUIT
Begin DoDot:1
+5 SET Y=+$PIECE(BUDG(X),U,4)
+6 SET Z=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+7 IF $DATA(^BUDETSSC("AD",Z,T))
SET BUDEVRUB="1^Rubella: Evidence "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDEUTL1($PIECE(BUDG(X),U))
QUIT
+8 SET S=$$VAL^XBDIQ1(9000010.07,Y,1101)
IF S]""
IF $DATA(^BUDETSSC("AS",S,T))
SET BUDEVRUB="1^Rubella: Evidence "_S_" on "_$$DATE^BUDEUTL1($PIECE(BUDG(X),U))
QUIT
End DoDot:1
+9 SET X=$$PLCL^BUDEDU(P,"T6B IMM EVIDENCE RUBELLA",EDATE,0)
IF X
SET BUDEVRUB="1^Rubella: Evidence: "_$PIECE(X,U,2)_" on Problem List"
+10 IF BUDEVRUB]""
SET BUDRUB=BUDEVRUB
+11 IF BUDMEA]""
IF BUDMU]""
IF BUDRUB]""
QUIT "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
+12 ;CONTRA
+13 SET BUDCORUB=$$CONTRA^BUDERP6C(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^BUDETSSC("B","T6B IMM RUBELLA CODES",0)),"RUBELLA")
+14 IF BUDCORUB]""
SET BUDRUB=BUDCORUB
+15 IF BUDMEA]""
IF BUDMU]""
IF BUDRUB]""
QUIT "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
MMRQ ;
+1 IF BUDMEA=""
IF BUDMU=""
IF BUDRUB=""
QUIT "0^1 MEASLES MUMPS RUBBELLA"
+2 QUIT "0^"_$SELECT(BUDMEA="":" 1 MEASLES",1:"")_$SELECT(BUDMU="":" 1 MUMPS",1:"")_$SELECT(BUDRUB="":" 1 RUBELLA",1:"")
