BUDHRP6D ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
;
TEST ;
S DFN=1717,BUDBD=3180101,BUDED=3181231
D PAPD
Q
;
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)-24)_"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
Q:$$HOSPIND^BUDHRP6C(DFN,BUDBD,BUDED) ;new v18, hospice during report period
;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^BUDHRP6M(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("BUDHRP6B",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("BUDHRP6B",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(^BUDHSITE(BUDSITE,11,L))
.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
S T=$O(^ATXAX("B","BUD 18 CPT PAP",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^BUDHDU(P,BDATE,EDATE,T,6) I X]"" Q
.S X=$$TRAN^BUDHDU(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^BUDHDU(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^BUDHDU(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(^BUDHTSSC("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(^BUDHTSSC("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(^BUDHTSSC("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(^BUDHTSSC("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(^BUDHTSSC("AD",Y,TIEN)) S G=1 Q
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDHTSSC("AS",Y,TIEN)) S G=1 Q
I G Q 1
S X=$$PLCL^BUDHDU(P,"T6B PAP HYSTERECTOMY CODES",EDATE,0) I X Q 1
Q ""
MMR(P,BDATE,EDATE) ;EP
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 BUDHVRUB,BUDHVMU,BUDHVMEA,BUDCORUB,BUDCOMU,BUDCOMEA,BUDZ
MMR1 ;
;IS THERE AN MMR CONTRAINDICATION?
;FIRST CHECK ALL VACCINES
S X=$$CONTRA^BUDHRP6C(P,$$DOB^AUPNPAT(P),EDATE,$O(^BUDHTSSC("B","T6B IMM MMR CODES",0)),"MMR")
I X Q X
;NOW CHECK IMM PKG FOR
F BUDZ=3,94,5,7,6,4 S X=$$MMRCONT^BUDHRP6C(P,BUDZ,EDATE) Q:X]""
I X]"" Q "1^MMR CONTRA: "_$P(X,U,2)_" on "_$$DATE^BUDHUTL1($P(X,U,1))_" Immunization Package"
;
;CONTRA IN ALLERGY TRACKING
S G=""
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X!(G) D
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.Q:'$$ANAREACT^BUDHRP6C(X)
.I N["NEOMYCIN" S G="1^MMR: CONTRA "_$$DATE^BUDHUTL1($P($P($G(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
I G]"" Q G
;
;SNOMED ANALPHALACTIC V POV OR PROBLEM LIST?
S T=$O(^BUDHTSSC("B","T6B IMM CONTRA VARICELLA/MMR",0))
S (X,Y,I)=0
F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) D
.Q:'$D(^AUPNPROB(X,0))
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.I $P(^AUPNPROB(X,0),U,13),$P(^AUPNPROB(X,0),U,13)>EDATE Q
.I $P(^AUPNPROB(X,0),U,13)="",$P(^AUPNPROB(X,0),U,8)>EDATE Q ;entered after report period, skip
.S S=$$VAL^XBDIQ1(9000011,X,80001)
.I S]"",$D(^BUDHTSSC("AS",S,T)) S I="1^MMR: CONTRA PL "_S Q
.Q
I I Q I
;NOW V POV SNOMED
S G="",I=""
S S="" F S S=$O(^AUPNVPOV("ASNC",P,S)) Q:S=""!(G) D
.S I=0
.I $D(^BUDHTSSC("AS",S,T)) S I="1^MMR: CONTRA POV "_S
.Q:'I
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
..S Y=9999999-D
..Q:Y>EDATE
..S G=I_"^"_$$DATE^BUDHUTL1(Y)
I G Q G
;CONTRAINDICATION TO MMR - FROM IPC LOGIC
S X=$$DIS^BUDHUTL3(P,EDATE) I X Q 1_U_"MMR: CONTRA DIS IMMUNE SYS"
S X=$$HIV^BUDHUTL3(P,EDATE) I X Q 1_U_"MMR: CONTRA HIV"
S X=$$MNLHT^BUDHUTL3(P,EDATE) I X Q 1_U_"MMR: CONTRA NEOPLASM"
MMRV ;NOW DO THEY HAVE AN MMR?
S (BUDHVRUB,BUDHVMU,BUDHVMEA,BUDCORUB,BUDCOMU,BUDCOMEA)=""
;now check contra to MMR
S (BUDX,BUDMR,BUDMU,BUDMEA,BUDRUB)=""
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S TIEN=$O(^BUDHTSSC("B","T6B IMM MMR CODES",0))
S TIENMR=$O(^BUDHTSSC("B","T6B IMM MR CODES",0))
S TIENMU=$O(^BUDHTSSC("B","T6B IMM MUMPS CODES",0))
S TIENMEA=$O(^BUDHTSSC("B","T6B IMM MEASLES CODES",0))
S TIENRUB=$O(^BUDHTSSC("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(^BUDHTSSC(TIEN,15,"B",Y)) S BUDX="CVX "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
..I $D(^BUDHTSSC(TIENMR,15,"B",Y)) S BUDMR="CVX "_Y_" on "_$$DATE^BUDHUTL1,BUDADT="CVX "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
..I $D(^BUDHTSSC(TIENMU,15,"B",Y)) S BUDMU="CVX "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
..I $D(^BUDHTSSC(TIENMEA,15,"B",Y)) S BUDMEA="CVX "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
..I $D(^BUDHTSSC(TIENRUB,15,"B",Y)) S BUDRUB="CVX "_Y_" on "_$$DATE^BUDHUTL1(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(^BUDHTSSC("AC",Y,TIEN)) S BUDX="CPT "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
..I $D(^BUDHTSSC("AC",Y,TIENMR)) S BUDMR="CPT "_Y_" on "_$$DATE^BUDHUTL1
..I $D(^BUDHTSSC("AC",Y,TIENMU)) S BUDMU="CPT "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
..I $D(^BUDHTSSC("AC",Y,TIENMEA)) S BUDMEA="CPT "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
..I $D(^BUDHTSSC("AC",Y,TIENRUB)) S BUDRUB="CPT "_Y_" on "_$$DATE^BUDHUTL1(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(^BUDHTSSC("AC",Y,TIEN)) S BUDX="CPT/TRAN "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
..I $D(^BUDHTSSC("AC",Y,TIENMR)) S BUDMR="CPT/TRAN "_Y_" on "_$$DATE^BUDHUTL1
..I $D(^BUDHTSSC("AC",Y,TIENMU)) S BUDMU="CPT/TRAN "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
..I $D(^BUDHTSSC("AC",Y,TIENMEA)) S BUDMEA="CPT/TRAN "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
..I $D(^BUDHTSSC("AC",Y,TIENRUB)) S BUDRUB="CPT/TRAN "_Y_" on "_$$DATE^BUDHUTL1(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(^BUDHTSSC("AP",Y,TIEN)) S BUDX="PROC "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
..I $D(^BUDHTSSC("AP",Y,TIENMR)) S BUDMR="PROC "_Y_" on "_$$DATE^BUDHUTL1
..I $D(^BUDHTSSC("AP",Y,TIENMU)) S BUDMU="PROC "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
..I $D(^BUDHTSSC("AP",Y,TIENMEA)) S BUDMEA="PROC "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
..I $D(^BUDHTSSC("AP",Y,TIENRUB)) S BUDRUB="PROC "_Y_" on "_$$DATE^BUDHUTL1(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(^BUDHTSSC("AS",Y,TIEN)) S BUDX="SNOMED "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
..I $D(^BUDHTSSC("AS",Y,TIENMR)) S BUDMR="SNOMED "_Y_" on "_$$DATE^BUDHUTL1
..I $D(^BUDHTSSC("AS",Y,TIENMU)) S BUDMU="SNOMED "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
..I $D(^BUDHTSSC("AS",Y,TIENMEA)) S BUDMEA="SNOMED "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
..I $D(^BUDHTSSC("AS",Y,TIENRUB)) S BUDRUB="SNOMED "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
I BUDX]"" Q "1^MMR: "_BUDX
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(^BUDHTSSC("B","T6B IMM EVIDENCE MEASLES",0))
S X=0,BUDHVMEA="" F S X=$O(BUDG(X)) Q:X'=+X!(BUDHVMEA]"") D
.S Y=+$P(BUDG(X),U,4)
.S Z=$P($G(^AUPNVPOV(Y,0)),U,1)
.I $D(^BUDHTSSC("AD",Z,T)) S BUDHVMEA="1^Measles: Evidence "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U)) Q
.S S=$$VAL^XBDIQ1(9000010.07,Y,1101) I S]"",$D(^BUDHTSSC("AS",S,T)) S BUDHVMEA="1^Measles: Evidence "_S_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U)) Q
S X=$$PLCL^BUDHDU(P,"T6B IMM EVIDENCE MEASLES",EDATE,0) I X S BUDMEA="1^Measles Evidence: "_$P(X,U,2)_" on Problem List"
I BUDHVMEA]"" S BUDMEA=BUDHVMEA
I BUDMEA]"",BUDMU]"",BUDRUB]"" Q "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
;CONTRA
S BUDCOMEA=$$CONTRA^BUDHRP6C(P,$$DOB^AUPNPAT(P),EDATE,$O(^BUDHTSSC("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(^BUDHTSSC("B","T6B IMM EVIDENCE MUMPS",0))
S X=0,BUDHVMU="" F S X=$O(BUDG(X)) Q:X'=+X!(BUDHVMU]"") D
.S Y=+$P(BUDG(X),U,4)
.S Z=$P($G(^AUPNVPOV(Y,0)),U,1)
.I $D(^BUDHTSSC("AD",Z,T)) S BUDHVMU="1^Mumps: Evidence "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U)) Q
.S S=$$VAL^XBDIQ1(9000010.07,Y,1101) I S]"",$D(^BUDHTSSC("AS",S,T)) S BUDHVMU="1^Mumps: Evidence "_S_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U)) Q
S X=$$PLCL^BUDHDU(P,"T6B IMM EVIDENCE MUMPS",EDATE,0) I X S BUDHVMU="1^Mumps: Evidence "_$P(X,U,2)_" on Problem List"
I BUDHVMU]"" S BUDMU=BUDHVMU
I BUDMEA]"",BUDMU]"",BUDRUB]"" Q "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
;CONTRA
S BUDCOMU=$$CONTRA^BUDHRP6C(P,$$DOB^AUPNPAT(P),EDATE,$O(^BUDHTSSC("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(^BUDHTSSC("B","T6B IMM EVIDENCE RUBELLA",0))
S X=0,BUDHVRUB="" F S X=$O(BUDG(X)) Q:X'=+X!(BUDHVRUB]"") D
.S Y=+$P(BUDG(X),U,4)
.S Z=$P($G(^AUPNVPOV(Y,0)),U,1)
.I $D(^BUDHTSSC("AD",Z,T)) S BUDHVRUB="1^Rubella: Evidence "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U)) Q
.S S=$$VAL^XBDIQ1(9000010.07,Y,1101) I S]"",$D(^BUDHTSSC("AS",S,T)) S BUDHVRUB="1^Rubella: Evidence "_S_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U)) Q
S X=$$PLCL^BUDHDU(P,"T6B IMM EVIDENCE RUBELLA",EDATE,0) I X S BUDHVRUB="1^Rubella: Evidence: "_$P(X,U,2)_" on Problem List"
I BUDHVRUB]"" S BUDRUB=BUDHVRUB
I BUDMEA]"",BUDMU]"",BUDRUB]"" Q "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
;CONTRA
S BUDCORUB=$$CONTRA^BUDHRP6C(P,$$DOB^AUPNPAT(P),EDATE,$O(^BUDHTSSC("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:"")
BUDHRP6D ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
+1 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
+2 ;
TEST ;
+1 SET DFN=1717
SET BUDBD=3180101
SET BUDED=3181231
+2 DO PAPD
+3 QUIT
+4 ;
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)-24)_"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 ;new v18, hospice during report period
IF $$HOSPIND^BUDHRP6C(DFN,BUDBD,BUDED)
QUIT
+17 ;THESE HAD A PAP IN PAST 3 YEARS
+18 ;denominator
SET BUDSECTD("PTS")=$GET(BUDSECTD("PTS"))+1
+19 SET BUDD=$EXTRACT(BUDED,1,3)-2_$EXTRACT(BUDBD,4,7)
+20 ;GET LAST PAP DATE
SET BUDPAP=$$PAP(DFN,$$DOB^AUPNPAT(DFN),BUDED)
+21 SET D=$PIECE(BUDPAP,U,2)
+22 SET BUDPD=$EXTRACT(BUDED,1,3)-2_$EXTRACT(BUDBD,4,7)
+23 IF D'<BUDPD
SET BUDSECTD("PAP")=$GET(BUDSECTD("PAP"))+1
SET BUDHASP=1
+24 IF BUDHASP
GOTO PAPL
+25 ;new v12 add hpv/pap same day in past 4 years for 30-64
+26 SET A=$$AGE^AUPNPAT(DFN,BUDBD)
+27 IF A<30
GOTO PAPL
+28 IF A>64
GOTO PAPL
+29 SET BUDPAPH=$$PAPHPV^BUDHRP6M(DFN,BUDED,4)
+30 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("BUDHRP6B",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("BUDHRP6B",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 IF '$DATA(^BUDHSITE(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 SET T=$ORDER(^ATXAX("B","BUD 18 CPT PAP",0))
+21 IF T
Begin DoDot:1
+22 SET X=$$CPT^BUDHDU(P,BDATE,EDATE,T,6)
IF X]""
QUIT
+23 SET X=$$TRAN^BUDHDU(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)
+24 SET T="PAP SMEAR"
SET T=$ORDER(^BWPN("B",T,0))
+25 IF T
Begin DoDot:1
+26 SET X=$$WH^BUDHDU(P,BDATE,EDATE,T,3)
End DoDot:1
IF X]""
IF $PIECE(BUDLPAP,U,2)<X
SET BUDLPAP="1^"_X_"^WH PAP SMEAR"
+27 QUIT BUDLPAP
+28 ;
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^BUDHDU(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(^BUDHTSSC("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(^BUDHTSSC("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(^BUDHTSSC("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(^BUDHTSSC("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(^BUDHTSSC("AD",Y,TIEN))
SET G=1
QUIT
+34 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+35 IF Y=""
QUIT
+36 IF $DATA(^BUDHTSSC("AS",Y,TIEN))
SET G=1
QUIT
End DoDot:2
End DoDot:1
+37 IF G
QUIT 1
+38 SET X=$$PLCL^BUDHDU(P,"T6B PAP HYSTERECTOMY CODES",EDATE,0)
IF X
QUIT 1
+39 QUIT ""
MMR(P,BDATE,EDATE) ;EP
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 BUDHVRUB,BUDHVMU,BUDHVMEA,BUDCORUB,BUDCOMU,BUDCOMEA,BUDZ
MMR1 ;
+1 ;IS THERE AN MMR CONTRAINDICATION?
+2 ;FIRST CHECK ALL VACCINES
+3 SET X=$$CONTRA^BUDHRP6C(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^BUDHTSSC("B","T6B IMM MMR CODES",0)),"MMR")
+4 IF X
QUIT X
+5 ;NOW CHECK IMM PKG FOR
+6 FOR BUDZ=3,94,5,7,6,4
SET X=$$MMRCONT^BUDHRP6C(P,BUDZ,EDATE)
IF X]""
QUIT
+7 IF X]""
QUIT "1^MMR CONTRA: "_$PIECE(X,U,2)_" on "_$$DATE^BUDHUTL1($PIECE(X,U,1))_" Immunization Package"
+8 ;
+9 ;CONTRA IN ALLERGY TRACKING
+10 SET G=""
+11 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+12 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+13 IF '$$ANAREACT^BUDHRP6C(X)
QUIT
+14 IF N["NEOMYCIN"
SET G="1^MMR: CONTRA "_$$DATE^BUDHUTL1($PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
End DoDot:1
+15 IF G]""
QUIT G
+16 ;
+17 ;SNOMED ANALPHALACTIC V POV OR PROBLEM LIST?
+18 SET T=$ORDER(^BUDHTSSC("B","T6B IMM CONTRA VARICELLA/MMR",0))
+19 SET (X,Y,I)=0
+20 FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+21 IF '$DATA(^AUPNPROB(X,0))
QUIT
+22 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+23 IF $PIECE(^AUPNPROB(X,0),U,13)
IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
QUIT
+24 ;entered after report period, skip
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+25 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+26 IF S]""
IF $DATA(^BUDHTSSC("AS",S,T))
SET I="1^MMR: CONTRA PL "_S
QUIT
+27 QUIT
End DoDot:1
+28 IF I
QUIT I
+29 ;NOW V POV SNOMED
+30 SET G=""
SET I=""
+31 SET S=""
FOR
SET S=$ORDER(^AUPNVPOV("ASNC",P,S))
IF S=""!(G)
QUIT
Begin DoDot:1
+32 SET I=0
+33 IF $DATA(^BUDHTSSC("AS",S,T))
SET I="1^MMR: CONTRA POV "_S
+34 IF 'I
QUIT
+35 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+36 SET Y=9999999-D
+37 IF Y>EDATE
QUIT
+38 SET G=I_"^"_$$DATE^BUDHUTL1(Y)
End DoDot:2
End DoDot:1
+39 IF G
QUIT G
+40 ;CONTRAINDICATION TO MMR - FROM IPC LOGIC
+41 SET X=$$DIS^BUDHUTL3(P,EDATE)
IF X
QUIT 1_U_"MMR: CONTRA DIS IMMUNE SYS"
+42 SET X=$$HIV^BUDHUTL3(P,EDATE)
IF X
QUIT 1_U_"MMR: CONTRA HIV"
+43 SET X=$$MNLHT^BUDHUTL3(P,EDATE)
IF X
QUIT 1_U_"MMR: CONTRA NEOPLASM"
MMRV ;NOW DO THEY HAVE AN MMR?
+1 SET (BUDHVRUB,BUDHVMU,BUDHVMEA,BUDCORUB,BUDCOMU,BUDCOMEA)=""
+2 ;now check contra to MMR
+3 SET (BUDX,BUDMR,BUDMU,BUDMEA,BUDRUB)=""
+4 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+5 SET TIEN=$ORDER(^BUDHTSSC("B","T6B IMM MMR CODES",0))
+6 SET TIENMR=$ORDER(^BUDHTSSC("B","T6B IMM MR CODES",0))
+7 SET TIENMU=$ORDER(^BUDHTSSC("B","T6B IMM MUMPS CODES",0))
+8 SET TIENMEA=$ORDER(^BUDHTSSC("B","T6B IMM MEASLES CODES",0))
+9 SET TIENRUB=$ORDER(^BUDHTSSC("B","T6B IMM RUBELLA CODES",0))
+10 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+11 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+12 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+14 IF '$DATA(^AUPNVIMM(X,0))
QUIT
+15 SET Y=$$VALI^XBDIQ1(9000010.11,X,.01)
+16 SET Y=+$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+17 IF 'Y
QUIT
+18 IF $DATA(^BUDHTSSC(TIEN,15,"B",Y))
SET BUDX="CVX "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
+19 IF $DATA(^BUDHTSSC(TIENMR,15,"B",Y))
SET BUDMR="CVX "_Y_" on "_$$DATE^BUDHUTL1
SET BUDADT="CVX "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
+20 IF $DATA(^BUDHTSSC(TIENMU,15,"B",Y))
SET BUDMU="CVX "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
+21 IF $DATA(^BUDHTSSC(TIENMEA,15,"B",Y))
SET BUDMEA="CVX "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
+22 IF $DATA(^BUDHTSSC(TIENRUB,15,"B",Y))
SET BUDRUB="CVX "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+23 ;CPT
+24 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+25 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+26 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+27 IF Y=""
QUIT
+28 IF $DATA(^BUDHTSSC("AC",Y,TIEN))
SET BUDX="CPT "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
+29 IF $DATA(^BUDHTSSC("AC",Y,TIENMR))
SET BUDMR="CPT "_Y_" on "_$$DATE^BUDHUTL1
+30 IF $DATA(^BUDHTSSC("AC",Y,TIENMU))
SET BUDMU="CPT "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
+31 IF $DATA(^BUDHTSSC("AC",Y,TIENMEA))
SET BUDMEA="CPT "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
+32 IF $DATA(^BUDHTSSC("AC",Y,TIENRUB))
SET BUDRUB="CPT "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+33 ;V TRANS
+34 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+35 IF '$DATA(^AUPNVTC(X,0))
QUIT
+36 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+37 IF Y=""
QUIT
+38 IF $DATA(^BUDHTSSC("AC",Y,TIEN))
SET BUDX="CPT/TRAN "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
+39 IF $DATA(^BUDHTSSC("AC",Y,TIENMR))
SET BUDMR="CPT/TRAN "_Y_" on "_$$DATE^BUDHUTL1
+40 IF $DATA(^BUDHTSSC("AC",Y,TIENMU))
SET BUDMU="CPT/TRAN "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
+41 IF $DATA(^BUDHTSSC("AC",Y,TIENMEA))
SET BUDMEA="CPT/TRAN "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
+42 IF $DATA(^BUDHTSSC("AC",Y,TIENRUB))
SET BUDRUB="CPT/TRAN "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+43 ;V PROC
+44 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+45 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+46 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+47 IF $DATA(^BUDHTSSC("AP",Y,TIEN))
SET BUDX="PROC "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
+48 IF $DATA(^BUDHTSSC("AP",Y,TIENMR))
SET BUDMR="PROC "_Y_" on "_$$DATE^BUDHUTL1
+49 IF $DATA(^BUDHTSSC("AP",Y,TIENMU))
SET BUDMU="PROC "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
+50 IF $DATA(^BUDHTSSC("AP",Y,TIENMEA))
SET BUDMEA="PROC "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
+51 IF $DATA(^BUDHTSSC("AP",Y,TIENRUB))
SET BUDRUB="PROC "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+52 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+53 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+54 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+55 IF Y=""
QUIT
+56 IF $DATA(^BUDHTSSC("AS",Y,TIEN))
SET BUDX="SNOMED "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
+57 IF $DATA(^BUDHTSSC("AS",Y,TIENMR))
SET BUDMR="SNOMED "_Y_" on "_$$DATE^BUDHUTL1
+58 IF $DATA(^BUDHTSSC("AS",Y,TIENMU))
SET BUDMU="SNOMED "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
+59 IF $DATA(^BUDHTSSC("AS",Y,TIENMEA))
SET BUDMEA="SNOMED "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
+60 IF $DATA(^BUDHTSSC("AS",Y,TIENRUB))
SET BUDRUB="SNOMED "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
End DoDot:1
+61 IF BUDX]""
QUIT "1^MMR: "_BUDX
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(^BUDHTSSC("B","T6B IMM EVIDENCE MEASLES",0))
+5 SET X=0
SET BUDHVMEA=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(BUDHVMEA]"")
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(^BUDHTSSC("AD",Z,T))
SET BUDHVMEA="1^Measles: Evidence "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U))
QUIT
+9 SET S=$$VAL^XBDIQ1(9000010.07,Y,1101)
IF S]""
IF $DATA(^BUDHTSSC("AS",S,T))
SET BUDHVMEA="1^Measles: Evidence "_S_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U))
QUIT
End DoDot:1
+10 SET X=$$PLCL^BUDHDU(P,"T6B IMM EVIDENCE MEASLES",EDATE,0)
IF X
SET BUDMEA="1^Measles Evidence: "_$PIECE(X,U,2)_" on Problem List"
+11 IF BUDHVMEA]""
SET BUDMEA=BUDHVMEA
+12 IF BUDMEA]""
IF BUDMU]""
IF BUDRUB]""
QUIT "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
+13 ;CONTRA
+14 SET BUDCOMEA=$$CONTRA^BUDHRP6C(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^BUDHTSSC("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(^BUDHTSSC("B","T6B IMM EVIDENCE MUMPS",0))
+4 SET X=0
SET BUDHVMU=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(BUDHVMU]"")
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(^BUDHTSSC("AD",Z,T))
SET BUDHVMU="1^Mumps: Evidence "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U))
QUIT
+8 SET S=$$VAL^XBDIQ1(9000010.07,Y,1101)
IF S]""
IF $DATA(^BUDHTSSC("AS",S,T))
SET BUDHVMU="1^Mumps: Evidence "_S_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U))
QUIT
End DoDot:1
+9 SET X=$$PLCL^BUDHDU(P,"T6B IMM EVIDENCE MUMPS",EDATE,0)
IF X
SET BUDHVMU="1^Mumps: Evidence "_$PIECE(X,U,2)_" on Problem List"
+10 IF BUDHVMU]""
SET BUDMU=BUDHVMU
+11 IF BUDMEA]""
IF BUDMU]""
IF BUDRUB]""
QUIT "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
+12 ;CONTRA
+13 SET BUDCOMU=$$CONTRA^BUDHRP6C(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^BUDHTSSC("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(^BUDHTSSC("B","T6B IMM EVIDENCE RUBELLA",0))
+4 SET X=0
SET BUDHVRUB=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(BUDHVRUB]"")
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(^BUDHTSSC("AD",Z,T))
SET BUDHVRUB="1^Rubella: Evidence "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U))
QUIT
+8 SET S=$$VAL^XBDIQ1(9000010.07,Y,1101)
IF S]""
IF $DATA(^BUDHTSSC("AS",S,T))
SET BUDHVRUB="1^Rubella: Evidence "_S_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U))
QUIT
End DoDot:1
+9 SET X=$$PLCL^BUDHDU(P,"T6B IMM EVIDENCE RUBELLA",EDATE,0)
IF X
SET BUDHVRUB="1^Rubella: Evidence: "_$PIECE(X,U,2)_" on Problem List"
+10 IF BUDHVRUB]""
SET BUDRUB=BUDHVRUB
+11 IF BUDMEA]""
IF BUDMU]""
IF BUDRUB]""
QUIT "1^MMR: "_BUDMEA_";"_BUDMU_";"_BUDRUB
+12 ;CONTRA
+13 SET BUDCORUB=$$CONTRA^BUDHRP6C(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^BUDHTSSC("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:"")
