BUDHRP6Y ;IHS/CMI/LAB - UDS REPORT T6B;
;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
;
;
;
HEPB(P,BDATE,EDATE) ;EP
;check for a contraindication from DOB to 2nd birthday
NEW G,X,N,BUDZ,T,%,E,Y,Z,BUDG,BUDD,BUDX,BUDHEPB,BUDVS,TIEN,CTR,VDATE,VIEN
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^BUDHRP6C(X) ;quit if anaphylactic is not a reaction/sign/symptom
.I N["BAKER'S YEAST"!(N["BAKERS YEAST")!(N["YEAST") S G="1^HEP B: CONTRA "_$$DATE^BUDHUTL1($P($P($G(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
I G]"" Q G
S BUDZ=0,X="",T=$O(^BUDHTSSC("B","T6B IMM HEP B CODES",0))
F S BUDZ=$O(^BUDHTSSC(T,15,"B",BUDZ)) Q:BUDZ=""!(X]"") S X=$$ANCONT^BUDHRP6C(P,BUDZ,EDATE) Q:X]""
I X]"" Q "1^HEP B: CONTRA IMM package "_$$DATE^BUDHUTL1($P(X,U))_" "_$P(X,U,2)
;V11.0 ICD10
K BUDG S %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDHTSSC("B","T6B IMM CONTRA HEP B",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(^BUDHTSSC("AD",Z,T)) S G="1^HEP B: CONTRA DX "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U))
.S S=$$VAL^XBDIQ1(9000010.07,Y,1101) I S]"",$D(^BUDHTSSC("AS",S,T)) S G="1^HEP B: CONTRA DX "_S_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U))
I G]"" Q G
S X=$$PLCL^BUDHDU(P,"T6B IMM CONTRA HEP B",EDATE,0) I X Q "1^HEP B: CONTRA DX "_$P(X,U,2)_" on Problem List"
;999.4 THING
S X=$$CONTRA^BUDHRP6C(P,$$DOB^AUPNPAT(P),EDATE,$O(^BUDHTSSC("B","T6B IMM HEP B CODES",0)),"HEP B")
I X]"" Q X
;now check for evidence of disease
HEPBEVID ;
S G=$$EVIDHEPB^BUDHUTL3(P,EDATE) I G Q 1_U_"HEB B: EVID"
K BUDD,BUDG,BUDX
K BUDHEPB
HEPBIMM ;get all immunizations
S BUDHEPB=0
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS") ;all visits in 42 days to end
S TIEN=$O(^BUDHTSSC("B","T6B IMM HEP B 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 BUDHEPB(VDATE)="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 BUDHEPB(VDATE)="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 BUDHEPB(VDATE)="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 BUDHEPB(VDATE)="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 BUDHEPB(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S (X,Y)="",C=0 F S X=$O(BUDHEPB(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDHEPB(X) Q
.S Y=X
;now count them and see if there are 3 of them
S BUDHEPB=0,X=0 F S X=$O(BUDHEPB(X)) Q:X'=+X S BUDHEPB=BUDHEPB+1
I BUDHEPB>2 S Y="1^HEP B: total #: "_BUDHEPB,X="" F S X=$O(BUDHEPB(X)) Q:X'=+X S Y=Y_" "_BUDHEPB(X)
I BUDHEPB>2 Q Y
Q "0^"_(3-BUDHEPB)_" HEP B"
HIB(P,BDATE,EDATE) ;EP
;check for a contraindication from DOB to 2nd birthday
NEW BUDZ,X,T,BUDG,G,S,Z,BUDD,BUDX,BUDHIB,BUDVS,TIEN,CTR,VIEN,VDATE,Y
;now check for evidence of disease
S BUDZ=0,X="",T=$O(^BUDHTSSC("B","T6B IMM HIB CODES",0))
F S BUDZ=$O(^BUDHTSSC(T,15,"B",BUDZ)) Q:BUDZ=""!(X]"") S X=$$ANCONT^BUDHRP6C(P,BUDZ,EDATE) Q:X]""
I X]"" Q "1^HIB: CONTRA IMM package "_$$DATE^BUDHUTL1($P(X,U))_" "_$P(X,U,2)
;V11.0 ICD10
K BUDG S %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDHTSSC("B","T6B IMM CONTRA HIB",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(^BUDHTSSC("AD",Z,T)) S G="1^HIB: CONTRA DX "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U))
.S S=$$VAL^XBDIQ1(9000010.07,Y,1101) I S]"",$D(^BUDHTSSC("AS",S,T)) S G="1^HIB: CONTRA DX "_S_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U))
I G]"" Q G
S X=$$PLCL^BUDHDU(P,"T6B IMM CONTRA HIB",EDATE,0) I X Q "1^HIB: CONTRA DX "_$P(X,U,2)_" on Problem List"
;999.4 THING
S X=$$CONTRA^BUDHRP6C(P,$$DOB^AUPNPAT(P),EDATE,$O(^BUDHTSSC("B","T6B IMM HIB CODES",0)),"HIB")
I X]"" Q X
;now check for evidence of disease
HIBEVID ;
;V11.0 ICD10
K BUDG S %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDHTSSC("B","T6B IMM EVIDENCE HIB",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(^BUDHTSSC("AD",Z,T)) S G="1^HIB: 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 BUDG="1^HIB: Evidence "_S_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U)) Q
I G]"" Q G
S X=$$PLCL^BUDHDU(P,"T6B IMM EVIDENCE HIB",EDATE,0) I X Q "1^HIB: Evidence "_$P(X,U,2)_" on Problem List"
K BUDD,BUDG,BUDX
K BUDHIB
HIBIMM ;get all immunizations
S BUDHIB=0
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS") ;all visits in 42 days to end
S TIEN=$O(^BUDHTSSC("B","T6B IMM HIB 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 BUDHIB(VDATE)="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 BUDHIB(VDATE)="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 BUDHIB(VDATE)="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 BUDHIB(VDATE)="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 BUDHIB(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S (X,Y)="",C=0 F S X=$O(BUDHIB(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDHIB(X) Q
.S Y=X
;now count them and see if there are 3 of them
S BUDHIB=0,X=0 F S X=$O(BUDHIB(X)) Q:X'=+X S BUDHIB=BUDHIB+1
I BUDHIB>2 S Y="1^HIB: total #: "_BUDHIB,X="" F S X=$O(BUDHIB(X)) Q:X'=+X S Y=Y_" "_BUDHIB(X)
I BUDHIB>2 Q Y
Q "0^"_(3-BUDHIB)_" HIB (3 recommended)"
VAR(P,BDATE,EDATE) ;EP
;first check for contraindications
VARC ;
NEW BUDG,%,E,T,X,G,Y,Z,BUDZ,BUDVAR,BUDVS,TIEN,CTR,VIEN,VDATE
;IS THERE AN MMR CONTRAINDICATION?
;FIRST CHECK ALL VACCINES
S X=$$CONTRA^BUDHRP6C(P,$$DOB^AUPNPAT(P),EDATE,$O(^BUDHTSSC("B","T6B IMM VARICELLA 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^VAR 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
.;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^BUDHRP6C(X) ;quit if anaphylactic is not a reaction/sign/symptom
.I N["NEOMYCIN" S G="1^VAR: 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 ;if there is a doo and it is after report period skip
.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^VAR: 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^VAR: 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_"VAR: CONTRA DIS IMMUNE SYS"
S X=$$HIV^BUDHUTL3(P,EDATE) I X Q 1_U_"VAR: CONTRA HIV"
S X=$$MNLHT^BUDHUTL3(P,EDATE) I X Q 1_U_"VAR: CONTRA NEOPLASM"
VAREVID ;
;any evidence of VAR?
K BUDG S %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDHTSSC("B","T6B IMM EVIDENCE VARICELLA",0))
S X=0,G="" F S X=$O(BUDG(X)) Q:X'=+X!(G]"") D
.S Y=+$P(BUDG(X),U,4)
.S Y=$P($G(^AUPNVPOV(Y,0)),U,1)
.I $D(^BUDHTSSC("AD",Y,T)) S G="1^Varicella: Evidence "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U)) Q
.S S=$$VAL^XBDIQ1(9000010.07,Y,.01) I S]"",$D(^BUDHTSSC("AS",S,T)) S G="1^Varicella: Evidence "_S_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U))
I G]"" Q G
S X=$$PLCL^BUDHDU(P,"T6B IMM EVIDENCE VARICELLA",EDATE,0) I X Q "1^Varicella: Evidence "_$P(X,U,2)_" on Problem List"
VARI ;
S BUDVAR=""
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS") ;all visits in 42 days to end
S TIEN=$O(^BUDHTSSC("B","T6B IMM VARICELLA 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 BUDVAR="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 BUDVAR="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 BUDVAR="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 BUDVAR="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 BUDVAR="SNOMED: "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
I BUDVAR]"" Q "1^VAR "_BUDVAR
;
Q "0^1 VAR"
;
PNEU(P,BDATE,EDATE) ;EP
NEW BUDD,BUDG,BUDX,BUDZ,X,Y,G,Z,BUDPNEU,BUDV,TIEN,CTR,VIEN,VDATE,C,BUDVS
F BUDZ=33,100,109,133,152 S X=$$ANCONT^BUDHRP6C(P,BUDZ,EDATE)
I X]"" Q "1^PNEUMO: CONTRA IMM package: "_$$DATE^BUDHUTL1($P(X,U))_" "_$P(X,U,2)
K BUDG S %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDHTSSC("B","T6B IMM CONTRA PNEUMO",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(^BUDHTSSC("AD",Z,T)) S G="1^PNEUMO: CONTRA DX "_$P(BUDG(X),U,2)_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U))
.S S=$$VAL^XBDIQ1(9000010.07,Y,1101) I S]"",$D(^BUDHTSSC("AS",S,T)) S G="1^PNEUMO: CONTRA DX "_S_" on "_$$DATE^BUDHUTL1($P(BUDG(X),U))
I G]"" Q G
S X=$$PLCL^BUDHDU(P,"T6B IMM CONTRA PNEUMO",EDATE,0) I X Q "1^PNEUMO: CONTRA DX "_$P(X,U,2)_" on Problem List"
S X=$$CONTRA^BUDHRP6C(P,$$DOB^AUPNPAT(P),EDATE,$O(^BUDHTSSC("B","T6B IMM PNEUMO CODES",0)),"PNEUMO")
I X]"" Q X
PNEUIMM ;get all immunizations
S BUDPNEU=""
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS") ;all visits in 42 days to end
S TIEN=$O(^BUDHTSSC("B","T6B IMM PNEUMO 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 BUDPNEU(VDATE)="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 BUDPNEU(VDATE)="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 BUDPNEU(VDATE)="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 BUDPNEU(VDATE)="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 BUDPNEU(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDHUTL1(VDATE) Q
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S (X,Y)="",C=0 F S X=$O(BUDPNEU(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BUDPNEU(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BUDPNEU=0,X=0 F S X=$O(BUDPNEU(X)) Q:X'=+X S BUDPNEU=BUDPNEU+1
I BUDPNEU>3 S Y="1^PNEUMO: total #: "_BUDPNEU,X="" F S X=$O(BUDPNEU(X)) Q:X'=+X S Y=Y_" "_BUDPNEU(X)
I BUDPNEU>3 Q Y
S X=4-BUDPNEU
Q "0^"_X_" PNEUMO"
BUDHRP6Y ;IHS/CMI/LAB - UDS REPORT T6B;
+1 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
+2 ;
+3 ;
+4 ;
HEPB(P,BDATE,EDATE) ;EP
+1 ;check for a contraindication from DOB to 2nd birthday
+2 NEW G,X,N,BUDZ,T,%,E,Y,Z,BUDG,BUDD,BUDX,BUDHEPB,BUDVS,TIEN,CTR,VDATE,VIEN
+3 SET G=""
+4 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+5 ;Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE ;entered after 2ND birthday
+6 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+7 ;quit if anaphylactic is not a reaction/sign/symptom
IF '$$ANAREACT^BUDHRP6C(X)
QUIT
+8 IF N["BAKER'S YEAST"!(N["BAKERS YEAST")!(N["YEAST")
SET G="1^HEP B: CONTRA "_$$DATE^BUDHUTL1($PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
End DoDot:1
+9 IF G]""
QUIT G
+10 SET BUDZ=0
SET X=""
SET T=$ORDER(^BUDHTSSC("B","T6B IMM HEP B CODES",0))
+11 FOR
SET BUDZ=$ORDER(^BUDHTSSC(T,15,"B",BUDZ))
IF BUDZ=""!(X]"")
QUIT
SET X=$$ANCONT^BUDHRP6C(P,BUDZ,EDATE)
IF X]""
QUIT
+12 IF X]""
QUIT "1^HEP B: CONTRA IMM package "_$$DATE^BUDHUTL1($PIECE(X,U))_" "_$PIECE(X,U,2)
+13 ;V11.0 ICD10
+14 KILL BUDG
SET %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+15 SET T=$ORDER(^BUDHTSSC("B","T6B IMM CONTRA HEP B",0))
+16 SET X=0
SET G=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+17 SET Y=+$PIECE(BUDG(X),U,4)
+18 SET Z=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+19 IF $DATA(^BUDHTSSC("AD",Z,T))
SET G="1^HEP B: CONTRA DX "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U))
+20 SET S=$$VAL^XBDIQ1(9000010.07,Y,1101)
IF S]""
IF $DATA(^BUDHTSSC("AS",S,T))
SET G="1^HEP B: CONTRA DX "_S_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U))
End DoDot:1
+21 IF G]""
QUIT G
+22 SET X=$$PLCL^BUDHDU(P,"T6B IMM CONTRA HEP B",EDATE,0)
IF X
QUIT "1^HEP B: CONTRA DX "_$PIECE(X,U,2)_" on Problem List"
+23 ;999.4 THING
+24 SET X=$$CONTRA^BUDHRP6C(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^BUDHTSSC("B","T6B IMM HEP B CODES",0)),"HEP B")
+25 IF X]""
QUIT X
+26 ;now check for evidence of disease
HEPBEVID ;
+1 SET G=$$EVIDHEPB^BUDHUTL3(P,EDATE)
IF G
QUIT 1_U_"HEB B: EVID"
+2 KILL BUDD,BUDG,BUDX
+3 KILL BUDHEPB
HEPBIMM ;get all immunizations
+1 SET BUDHEPB=0
+2 ;all visits in 42 days to end
DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+3 SET TIEN=$ORDER(^BUDHTSSC("B","T6B IMM HEP B 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 X=0
FOR
SET X=$ORDER(^AUPNVIMM("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+8 IF '$DATA(^AUPNVIMM(X,0))
QUIT
+9 SET Y=$$VALI^XBDIQ1(9000010.11,X,.01)
+10 SET Y=+$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+11 IF 'Y
QUIT
+12 IF $DATA(^BUDHTSSC(TIEN,15,"B",Y))
SET BUDHEPB(VDATE)="CVX "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+13 ;CPT
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X
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(^BUDHTSSC("AC",Y,TIEN))
SET BUDHEPB(VDATE)="CPT "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+19 ;V TRANS
+20 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X
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(^BUDHTSSC("AC",Y,TIEN))
SET BUDHEPB(VDATE)="CPT/TRAN "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+25 ;V PROC
+26 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+27 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+28 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+29 IF $DATA(^BUDHTSSC("AP",Y,TIEN))
SET BUDHEPB(VDATE)="PROC "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+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=$$VAL^XBDIQ1(9000010.07,X,1101)
+33 IF Y=""
QUIT
+34 IF $DATA(^BUDHTSSC("AS",Y,TIEN))
SET BUDHEPB(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
End DoDot:1
+35 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+36 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDHEPB(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+37 IF C=1
SET Y=X
QUIT
+38 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDHEPB(X)
QUIT
+39 SET Y=X
End DoDot:1
+40 ;now count them and see if there are 3 of them
+41 SET BUDHEPB=0
SET X=0
FOR
SET X=$ORDER(BUDHEPB(X))
IF X'=+X
QUIT
SET BUDHEPB=BUDHEPB+1
+42 IF BUDHEPB>2
SET Y="1^HEP B: total #: "_BUDHEPB
SET X=""
FOR
SET X=$ORDER(BUDHEPB(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDHEPB(X)
+43 IF BUDHEPB>2
QUIT Y
+44 QUIT "0^"_(3-BUDHEPB)_" HEP B"
HIB(P,BDATE,EDATE) ;EP
+1 ;check for a contraindication from DOB to 2nd birthday
+2 NEW BUDZ,X,T,BUDG,G,S,Z,BUDD,BUDX,BUDHIB,BUDVS,TIEN,CTR,VIEN,VDATE,Y
+3 ;now check for evidence of disease
+4 SET BUDZ=0
SET X=""
SET T=$ORDER(^BUDHTSSC("B","T6B IMM HIB CODES",0))
+5 FOR
SET BUDZ=$ORDER(^BUDHTSSC(T,15,"B",BUDZ))
IF BUDZ=""!(X]"")
QUIT
SET X=$$ANCONT^BUDHRP6C(P,BUDZ,EDATE)
IF X]""
QUIT
+6 IF X]""
QUIT "1^HIB: CONTRA IMM package "_$$DATE^BUDHUTL1($PIECE(X,U))_" "_$PIECE(X,U,2)
+7 ;V11.0 ICD10
+8 KILL BUDG
SET %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+9 SET T=$ORDER(^BUDHTSSC("B","T6B IMM CONTRA HIB",0))
+10 SET X=0
SET G=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+11 SET Y=+$PIECE(BUDG(X),U,4)
+12 SET Z=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+13 IF $DATA(^BUDHTSSC("AD",Z,T))
SET G="1^HIB: CONTRA DX "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U))
+14 SET S=$$VAL^XBDIQ1(9000010.07,Y,1101)
IF S]""
IF $DATA(^BUDHTSSC("AS",S,T))
SET G="1^HIB: CONTRA DX "_S_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U))
End DoDot:1
+15 IF G]""
QUIT G
+16 SET X=$$PLCL^BUDHDU(P,"T6B IMM CONTRA HIB",EDATE,0)
IF X
QUIT "1^HIB: CONTRA DX "_$PIECE(X,U,2)_" on Problem List"
+17 ;999.4 THING
+18 SET X=$$CONTRA^BUDHRP6C(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^BUDHTSSC("B","T6B IMM HIB CODES",0)),"HIB")
+19 IF X]""
QUIT X
+20 ;now check for evidence of disease
HIBEVID ;
+1 ;V11.0 ICD10
+2 KILL BUDG
SET %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+3 SET T=$ORDER(^BUDHTSSC("B","T6B IMM EVIDENCE HIB",0))
+4 SET X=0
SET G=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G]"")
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 G="1^HIB: 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 BUDG="1^HIB: Evidence "_S_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U))
QUIT
End DoDot:1
+9 IF G]""
QUIT G
+10 SET X=$$PLCL^BUDHDU(P,"T6B IMM EVIDENCE HIB",EDATE,0)
IF X
QUIT "1^HIB: Evidence "_$PIECE(X,U,2)_" on Problem List"
+11 KILL BUDD,BUDG,BUDX
+12 KILL BUDHIB
HIBIMM ;get all immunizations
+1 SET BUDHIB=0
+2 ;all visits in 42 days to end
DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+3 SET TIEN=$ORDER(^BUDHTSSC("B","T6B IMM HIB 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 X=0
FOR
SET X=$ORDER(^AUPNVIMM("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+8 IF '$DATA(^AUPNVIMM(X,0))
QUIT
+9 SET Y=$$VALI^XBDIQ1(9000010.11,X,.01)
+10 SET Y=+$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+11 IF 'Y
QUIT
+12 IF $DATA(^BUDHTSSC(TIEN,15,"B",Y))
SET BUDHIB(VDATE)="CVX "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+13 ;CPT
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X
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(^BUDHTSSC("AC",Y,TIEN))
SET BUDHIB(VDATE)="CPT "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+19 ;V TRANS
+20 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X
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(^BUDHTSSC("AC",Y,TIEN))
SET BUDHIB(VDATE)="CPT/TRAN "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+25 ;V PROC
+26 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+27 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+28 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+29 IF $DATA(^BUDHTSSC("AP",Y,TIEN))
SET BUDHIB(VDATE)="PROC "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+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=$$VAL^XBDIQ1(9000010.07,X,1101)
+33 IF Y=""
QUIT
+34 IF $DATA(^BUDHTSSC("AS",Y,TIEN))
SET BUDHIB(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
End DoDot:1
+35 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+36 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDHIB(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+37 IF C=1
SET Y=X
QUIT
+38 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDHIB(X)
QUIT
+39 SET Y=X
End DoDot:1
+40 ;now count them and see if there are 3 of them
+41 SET BUDHIB=0
SET X=0
FOR
SET X=$ORDER(BUDHIB(X))
IF X'=+X
QUIT
SET BUDHIB=BUDHIB+1
+42 IF BUDHIB>2
SET Y="1^HIB: total #: "_BUDHIB
SET X=""
FOR
SET X=$ORDER(BUDHIB(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDHIB(X)
+43 IF BUDHIB>2
QUIT Y
+44 QUIT "0^"_(3-BUDHIB)_" HIB (3 recommended)"
VAR(P,BDATE,EDATE) ;EP
+1 ;first check for contraindications
VARC ;
+1 NEW BUDG,%,E,T,X,G,Y,Z,BUDZ,BUDVAR,BUDVS,TIEN,CTR,VIEN,VDATE
+2 ;IS THERE AN MMR CONTRAINDICATION?
+3 ;FIRST CHECK ALL VACCINES
+4 SET X=$$CONTRA^BUDHRP6C(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^BUDHTSSC("B","T6B IMM VARICELLA CODES",0)),"MMR")
+5 IF X
QUIT X
+6 ;NOW CHECK IMM PKG FOR
+7 FOR BUDZ=3,94,5,7,6,4
SET X=$$MMRCONT^BUDHRP6C(P,BUDZ,EDATE)
IF X]""
QUIT
+8 IF X]""
QUIT "1^VAR CONTRA: "_$PIECE(X,U,2)_" on "_$$DATE^BUDHUTL1($PIECE(X,U,1))_" Immunization Package"
+9 ;
+10 ;CONTRA IN ALLERGY TRACKING
+11 SET G=""
+12 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+13 ;Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE ;entered after 2ND birthday
+14 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+15 ;quit if anaphylactic is not a reaction/sign/symptom
IF '$$ANAREACT^BUDHRP6C(X)
QUIT
+16 IF N["NEOMYCIN"
SET G="1^VAR: CONTRA "_$$DATE^BUDHUTL1($PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),"."))_" Allergy Tracking: "_N
End DoDot:1
+17 IF G]""
QUIT G
+18 ;
+19 ;SNOMED ANALPHALACTIC V POV OR PROBLEM LIST?
+20 SET T=$ORDER(^BUDHTSSC("B","T6B IMM CONTRA VARICELLA/MMR",0))
+21 SET (X,Y,I)=0
+22 FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+23 IF '$DATA(^AUPNPROB(X,0))
QUIT
+24 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+25 ;if there is a doo and it is after report period skip
IF $PIECE(^AUPNPROB(X,0),U,13)
IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
QUIT
+26 ;entered after report period, skip
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+27 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+28 IF S]""
IF $DATA(^BUDHTSSC("AS",S,T))
SET I="1^VAR: CONTRA PL "_S
QUIT
+29 QUIT
End DoDot:1
+30 IF I
QUIT I
+31 ;NOW V POV SNOMED
+32 SET G=""
SET I=""
+33 SET S=""
FOR
SET S=$ORDER(^AUPNVPOV("ASNC",P,S))
IF S=""!(G)
QUIT
Begin DoDot:1
+34 SET I=0
+35 IF $DATA(^BUDHTSSC("AS",S,T))
SET I="1^VAR: CONTRA POV "_S
+36 IF 'I
QUIT
+37 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+38 SET Y=9999999-D
+39 IF Y>EDATE
QUIT
+40 SET G=I_"^"_$$DATE^BUDHUTL1(Y)
End DoDot:2
End DoDot:1
+41 IF G
QUIT G
+42 ;CONTRAINDICATION TO MMR - FROM IPC LOGIC
+43 SET X=$$DIS^BUDHUTL3(P,EDATE)
IF X
QUIT 1_U_"VAR: CONTRA DIS IMMUNE SYS"
+44 SET X=$$HIV^BUDHUTL3(P,EDATE)
IF X
QUIT 1_U_"VAR: CONTRA HIV"
+45 SET X=$$MNLHT^BUDHUTL3(P,EDATE)
IF X
QUIT 1_U_"VAR: CONTRA NEOPLASM"
VAREVID ;
+1 ;any evidence of VAR?
+2 KILL BUDG
SET %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+3 SET T=$ORDER(^BUDHTSSC("B","T6B IMM EVIDENCE VARICELLA",0))
+4 SET X=0
SET G=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+5 SET Y=+$PIECE(BUDG(X),U,4)
+6 SET Y=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+7 IF $DATA(^BUDHTSSC("AD",Y,T))
SET G="1^Varicella: Evidence "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U))
QUIT
+8 SET S=$$VAL^XBDIQ1(9000010.07,Y,.01)
IF S]""
IF $DATA(^BUDHTSSC("AS",S,T))
SET G="1^Varicella: Evidence "_S_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U))
End DoDot:1
+9 IF G]""
QUIT G
+10 SET X=$$PLCL^BUDHDU(P,"T6B IMM EVIDENCE VARICELLA",EDATE,0)
IF X
QUIT "1^Varicella: Evidence "_$PIECE(X,U,2)_" on Problem List"
VARI ;
+1 SET BUDVAR=""
+2 ;all visits in 42 days to end
DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+3 SET TIEN=$ORDER(^BUDHTSSC("B","T6B IMM VARICELLA 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 X=0
FOR
SET X=$ORDER(^AUPNVIMM("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+8 IF '$DATA(^AUPNVIMM(X,0))
QUIT
+9 SET Y=$$VALI^XBDIQ1(9000010.11,X,.01)
+10 SET Y=+$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+11 IF 'Y
QUIT
+12 IF $DATA(^BUDHTSSC(TIEN,15,"B",Y))
SET BUDVAR="CVX "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+13 ;CPT
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X
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(^BUDHTSSC("AC",Y,TIEN))
SET BUDVAR="CPT "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+19 ;V TRANS
+20 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X
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(^BUDHTSSC("AC",Y,TIEN))
SET BUDVAR="CPT/TRAN "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+25 ;V PROC
+26 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+27 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+28 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+29 IF $DATA(^BUDHTSSC("AP",Y,TIEN))
SET BUDVAR="PROC "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+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=$$VAL^XBDIQ1(9000010.07,X,1101)
+33 IF Y=""
QUIT
+34 IF $DATA(^BUDHTSSC("AS",Y,TIEN))
SET BUDVAR="SNOMED: "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
End DoDot:1
+35 IF BUDVAR]""
QUIT "1^VAR "_BUDVAR
+36 ;
+37 QUIT "0^1 VAR"
+38 ;
PNEU(P,BDATE,EDATE) ;EP
+1 NEW BUDD,BUDG,BUDX,BUDZ,X,Y,G,Z,BUDPNEU,BUDV,TIEN,CTR,VIEN,VDATE,C,BUDVS
+2 FOR BUDZ=33,100,109,133,152
SET X=$$ANCONT^BUDHRP6C(P,BUDZ,EDATE)
+3 IF X]""
QUIT "1^PNEUMO: CONTRA IMM package: "_$$DATE^BUDHUTL1($PIECE(X,U))_" "_$PIECE(X,U,2)
+4 KILL BUDG
SET %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+5 SET T=$ORDER(^BUDHTSSC("B","T6B IMM CONTRA PNEUMO",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(^BUDHTSSC("AD",Z,T))
SET G="1^PNEUMO: CONTRA DX "_$PIECE(BUDG(X),U,2)_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U))
+10 SET S=$$VAL^XBDIQ1(9000010.07,Y,1101)
IF S]""
IF $DATA(^BUDHTSSC("AS",S,T))
SET G="1^PNEUMO: CONTRA DX "_S_" on "_$$DATE^BUDHUTL1($PIECE(BUDG(X),U))
End DoDot:1
+11 IF G]""
QUIT G
+12 SET X=$$PLCL^BUDHDU(P,"T6B IMM CONTRA PNEUMO",EDATE,0)
IF X
QUIT "1^PNEUMO: CONTRA DX "_$PIECE(X,U,2)_" on Problem List"
+13 SET X=$$CONTRA^BUDHRP6C(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^BUDHTSSC("B","T6B IMM PNEUMO CODES",0)),"PNEUMO")
+14 IF X]""
QUIT X
PNEUIMM ;get all immunizations
+1 SET BUDPNEU=""
+2 ;all visits in 42 days to end
DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+3 SET TIEN=$ORDER(^BUDHTSSC("B","T6B IMM PNEUMO 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 X=0
FOR
SET X=$ORDER(^AUPNVIMM("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+8 IF '$DATA(^AUPNVIMM(X,0))
QUIT
+9 SET Y=$$VALI^XBDIQ1(9000010.11,X,.01)
+10 SET Y=+$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+11 IF 'Y
QUIT
+12 IF $DATA(^BUDHTSSC(TIEN,15,"B",Y))
SET BUDPNEU(VDATE)="CVX "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+13 ;CPT
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X
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(^BUDHTSSC("AC",Y,TIEN))
SET BUDPNEU(VDATE)="CPT "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+19 ;V TRANS
+20 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X
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(^BUDHTSSC("AC",Y,TIEN))
SET BUDPNEU(VDATE)="CPT/TRAN "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+25 ;V PROC
+26 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+27 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+28 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+29 IF $DATA(^BUDHTSSC("AP",Y,TIEN))
SET BUDPNEU(VDATE)="PROC "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+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=$$VAL^XBDIQ1(9000010.07,X,1101)
+33 IF Y=""
QUIT
+34 IF $DATA(^BUDHTSSC("AS",Y,TIEN))
SET BUDPNEU(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
End DoDot:1
+35 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+36 SET (X,Y)=""
SET C=0
FOR
SET X=$ORDER(BUDPNEU(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+37 IF C=1
SET Y=X
QUIT
+38 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BUDPNEU(X)
QUIT
+39 SET Y=X
End DoDot:1
+40 ;now count them and see if there are 4 of them
+41 SET BUDPNEU=0
SET X=0
FOR
SET X=$ORDER(BUDPNEU(X))
IF X'=+X
QUIT
SET BUDPNEU=BUDPNEU+1
+42 IF BUDPNEU>3
SET Y="1^PNEUMO: total #: "_BUDPNEU
SET X=""
FOR
SET X=$ORDER(BUDPNEU(X))
IF X'=+X
QUIT
SET Y=Y_" "_BUDPNEU(X)
+43 IF BUDPNEU>3
QUIT Y
+44 SET X=4-BUDPNEU
+45 QUIT "0^"_X_" PNEUMO"
