BUDERP6C.m

BUDERP6C ;IHS/CMI/LAB - UDS T6B PROCESS;

 ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75

 ;

 ;

GETIMMS(P,BDATE,EDATE,C,BUDX) ;EP

 K BUDX

 NEW X,Y,I,Z,V

 S X=0 F  S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X  D

 .Q:'$D(^AUPNVIMM(X,0))  ;happens

 .S Y=$P(^AUPNVIMM(X,0),U)

 .Q:'Y  ;happens too

 .S I=$P($G(^AUTTIMM(Y,0)),U,3)  ;get HL7/CVX code

 .F Z=1:1:$L(C,U) I I=$P(C,U,Z) S V=$P(^AUPNVIMM(X,0),U,3) I V S D=$P($P($G(^AUPNVSIT(V,0)),U),".") I D]"",D'>EDATE,D'<BDATE S BUDX(D)="CVX: "_I_" on "_$$DATE^BUDEUTL1(D)

 .Q

 Q

 ;

IMM ;EP - IMM

 ;must have 2ND DOB between in the year - 2

 S BUDX2YRB=($E(BUDBD,1,3)-2)_"0101"

 S BUDX2YRE=($E(BUDED,1,3)-2)_"1231"

 S BUDDOB=$P(^DPT(DFN,0),U,3)

 Q:BUDDOB<BUDX2YRB

 Q:BUDDOB>BUDX2YRE

 S BUD2NDBD=$E(BUDDOB,1,3)+2_$E(BUDDOB,4,7)

 S BUD1STBD=$E(BUDDOB,1,3)+1_$E(BUDDOB,4,7)

 ;

 Q:BUDMEDV<1  ;didn't have at least 1 medical visit

 S BUDSECTC("PTS")=$G(BUDSECTC("PTS"))+1

 S BUDX42D=$$FMADD^XLFDT(BUDDOB,42)

 S BUDX180D=$$FMADD^XLFDT(BUDDOB,180)

 S (BUDNDTP,BUDNIPV,BUDNMMR,BUDNHEP,BUDNHIB,BUDNVAR,BUDNPNEU,BUDNHEPA,BUDNROTA,BUDNFLU)=""

 S BUDNDTP=$$DTAP^BUDERP6X(DFN,BUDX42D,BUD2NDBD)

 S BUDNIPV=$$IPV(DFN,BUDX42D,BUD2NDBD)

 S BUDNMMR=$$MMR^BUDERP6D(DFN,BUDDOB,BUD2NDBD)

 S BUDNHIB=$$HIB^BUDERP6Y(DFN,BUDX42D,BUD2NDBD)

 S BUDNHEP=$$HEPB^BUDERP6Y(DFN,BUDDOB,BUD2NDBD)

 S BUDNVAR=$$VAR^BUDERP6Y(DFN,BUD1STBD,BUD2NDBD)

 S BUDNPNEU=$$PNEU^BUDERP6Y(DFN,BUDDOB,BUD2NDBD)

 S BUDNHEPA=$$HEPA^BUDERP6H(DFN,BUDDOB,BUD2NDBD)

 S BUDNROTA=$$ROTA^BUDERP6H(DFN,BUDX42D,BUD2NDBD)

 S BUDNFLU=$$FLU^BUDERP6H(DFN,BUDX180D,BUD2NDBD)

 I $P(BUDNDTP,U,1)=1,$P(BUDNIPV,U,1)=1,$P(BUDNMMR,U,1)=1,$P(BUDNHEP,U,1)=1,$P(BUDNHIB,U,1)=1,$P(BUDNVAR,U,1)=1,$P(BUDNPNEU,U,1)=1,$P(BUDNHEPA,U,1)=1,$P(BUDNROTA,U,1)=1,$P(BUDNFLU,U,1)=1 S BUDSECTC("IMM")=$G(BUDSECTC("IMM"))+1 D  Q

 .I $G(BUDIMM1L) D

 ..S X=$P(BUDNDTP,U,2)_U_$P(BUDNIPV,U,2)_U_$P(BUDNMMR,U,2)_U_$P(BUDNHEP,U,2)_U_$P(BUDNHIB,U,2)_U_$P(BUDNVAR,U,2)_U_$P(BUDNPNEU,U,2)_U_$P(BUDNHEPA,U,2)_U_$P(BUDNROTA,U,2)_U_$P(BUDNFLU,U,2)_"|||"_U_BUDMEDVI

 ..S ^XTMP("BUDERP6B",BUDJ,BUDH,"IMM1",$P(^DPT(DFN,0),U),BUDCCOM,DFN)=X

 ..Q

 I $G(BUDIMM2L) D

 .S V=""

 .S V=$S($P(BUDNDTP,U,1)=1:"",1:$P(BUDNDTP,U,2))

 .I $P(BUDNIPV,U,1)'=1 S:V]"" V=V_"; " S V=V_$P(BUDNIPV,U,2)

 .I $P(BUDNMMR,U,1)'=1 S:V]"" V=V_"; " S V=V_$P(BUDNMMR,U,2)

 .I $P(BUDNHEP,U,1)'=1 S:V]"" V=V_"; " S V=V_$P(BUDNHEP,U,2)

 .I $P(BUDNHIB,U,1)'=1 S:V]"" V=V_"; " S V=V_$P(BUDNHIB,U,2)

 .I $P(BUDNVAR,U,1)'=1 S:V]"" V=V_"; " S V=V_$P(BUDNVAR,U,2)

 .I $P(BUDNPNEU,U,1)'=1 S:V]"" V=V_"; " S V=V_$P(BUDNPNEU,U,2)

 .I $P(BUDNHEPA,U,1)'=1 S:V]"" V=V_"; " S V=V_$P(BUDNHEPA,U,2)

 .I $P(BUDNROTA,U,1)'=1 S:V]"" V=V_"; " S V=V_$P(BUDNROTA,U,2)

 .I $P(BUDNFLU,U,1)'=1 S:V]"" V=V_"; " S V=V_$P(BUDNFLU,U,2)

 .S ^XTMP("BUDERP6B",BUDJ,BUDH,"IMM2",$P(^DPT(DFN,0),U),BUDCCOM,DFN)=V

 Q

 ;

CONTRA(P,BD,ED,T1,LABEL) ;EP

 NEW D,BUDG,E,%

 K BUDG S %=P_"^ALL DX;DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BUDG(")

 NEW X,Y,G,T,V,Z,A

 S T=$O(^BUDETSSC("B","T6B IMM CONTRA ALL VACCINES",0))

 S G=""

 S X=0 F  S X=$O(BUDG(X)) Q:X'=+X!(G]"")  D

 .S Y=+$P(BUDG(X),U,4)

 .S Y=$P($G(^AUPNVPOV(Y,0)),U,1)

 .Q:'$D(^BUDETSSC("AD",Y,T))

 .S V=$P(BUDG(X),U,5)

 .S Z=0 F  S Z=$O(^AUPNVIMM("AD",V,Z)) Q:Z'=+Z!(G)  D

 ..S A=$P(^AUPNVIMM(Z,0),U,1)

 ..S A=+$P($G(^AUTTIMM(A,0)),U,3)

 ..I A="" Q

 ..Q:'$D(^BUDETSSC(T1,15,"B",A))

 ..S G=1_U_LABEL_": CONTRA "_$P(BUDG(X),U,2)_"/"_A_" on "_$$DATE^BUDEUTL1($P(BUDG(X),U,1))

 .;CPT

 .S Z=0 F  S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z!(G)  D

 ..S A=$$VAL^XBDIQ1(9000010.18,Z,.01)

 ..I A="" Q

 ..Q:'$D(^BUDETSSC("AC",A,T1))

 ..S G=1_U_LABEL_": CONTRA "_$P(BUDG(X),U,2)_"/"_A_" on "_$$DATE^BUDEUTL1($P(BUDG(X),U,1))

 .;POV

 .S Z=0 F  S Z=$O(^AUPNVPOV("AD",V,Z)) Q:Z'=+Z!(G)  D

 ..S A=$$VALI^XBDIQ1(9000010.07,Z,.01)

 ..I A="" Q

 ..I $D(^BUDETSSC("AD",A,T1)) S G=1_U_LABEL_": CONTRA "_$P(BUDG(X),U,2)_"/"_$$VAL^XBDIQ1(9000010.07,Z,.01)_" on "_$$DATE^BUDEUTL1($P(BUDG(X),U,1))

 ..S A=$$VAL^XBDIQ1(9000010.07,Z,1101)

 ..Q:A=""

 ..I $D(^BUDETSSC("AS",Z,T1)) S G=1_U_LABEL_": CONTRA "_$P(BUDG(X),U,2)_"/"_A_" on "_$$DATE^BUDEUTL1($P(BUDG(X),U,1))

 Q G

ANAREACT(I) ;EP

 NEW X,Y,R

 S X=0,Y=0 F  S X=$O(^GMR(120.8,I,10,X)) Q:X'=+X  D

 .S R=$P($G(^GMR(120.8,I,10,X,0)),U)

 .Q:R=""

 .S R=$P($G(^GMRD(120.83,R,0)),U)

 .I R'="ANAPHYLAXIS" Q

 .S Y=1

 .Q

 Q Y

 ;

ANCONT(P,C,ED) ;EP - ANALPHYLAXIS CONTRA

 NEW X,G,D,R,Y

 S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G)  D

 .S R=$P(^BIPC(X,0),U,3)

 .Q:R=""

 .Q:'$D(^BICONT(R,0))

 .S D=$P(^BIPC(X,0),U,4)

 .Q:D=""

 .;Q:$P(^BIPC(X,0),U,4)<BD

 .;Q:$P(^BIPC(X,0),U,4)>ED

 .I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Anaphylaxis"

 .I $P(^BICONT(R,0),U,1)="Baker's Yeast Allergy" S G=D_U_"Baker's Yeast Allergy"

 .I $P(^BICONT(R,0),U,1)="Yeast Allergy" S G=D_U_"Yeast Allergy"

 Q G

 ;

EGGCONT(P,C,ED) ;EP - EGG CONTRA

 NEW X,G,Y,R,D

 S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G)  D

 .S R=$P(^BIPC(X,0),U,3)

 .Q:R=""

 .Q:'$D(^BICONT(R,0))

 .S D=$P(^BIPC(X,0),U,4)

 .Q:D=""

 .;Q:$P(^BIPC(X,0),U,4)<BD

 .;Q:$P(^BIPC(X,0),U,4)>ED

 .I $P(^BICONT(R,0),U,1)="Egg Allergy" S G=D_U_"Egg Allergy"

 Q G

ANNECONT(P,C,ED) ;EP - ANALPHYLAXIS/NEOMYCIN CONTRA

 NEW X,G,Y,R,D

 S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G)  D

 .S R=$P(^BIPC(X,0),U,3)

 .Q:R=""

 .Q:'$D(^BICONT(R,0))

 .S D=$P(^BIPC(X,0),U,4)

 .Q:D=""

 .I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Anaphylaxis"

 .I $P(^BICONT(R,0),U,1)="Neomycin Allergy" S G=D_U_"Neomycin Allergy"

 .I $P(^BICONT(R,0),U,1)="Streptomycin Allergy" S G=D_U_"Streptomycin Allergy"

 .I $P(^BICONT(R,0),U,1)="Polymyxin B Allergy" S G=D_U_"Polymyxin B Allergy"

 Q G

 ;

MMRCONT(P,C,ED) ;EP - ANALPHYLAXIS/NEOMYCIN/IMMUNE CONTRA

 NEW X,R,Y,D

 S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G)  D

 .S R=$P(^BIPC(X,0),U,3)

 .Q:R=""

 .Q:'$D(^BICONT(R,0))

 .S D=$P(^BIPC(X,0),U,4)

 .Q:D=""

 .;Q:$P(^BIPC(X,0),U,4)<BD

 .;Q:$P(^BIPC(X,0),U,4)>ED

 .I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Anaphylaxis"

 .I $P(^BICONT(R,0),U,1)="Neomycin Allergy" S G=D_U_"Neomycin Allergy"

 .I $P(^BICONT(R,0),U,1)="Immune Deficiency" S G=D_U_"Immune Deficiency"

 .I $P(^BICONT(R,0),U,1)["Immune Deficient" S G=D_U_"Immune Deficient"

 .I $P(^BICONT(R,0),U,1)="Immune" S G=D_U_"Immune"

 Q G

 ;

IPV(P,BDATE,EDATE) ;EP

 ;check for a contraindication from DOB to 2nd birthday

 NEW G,X,N,T,BUDZ,BUDG,%,E,Y,BUDD,BUDX,BUDOPV,BUDVS,TIEN,CTR,VIEN,VDATE,C

IPVCONT ;check 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)

 .I N["STREPTOMYCIN"!(N["POLYMYXIN B")!(N["NEOMYCIN") S G="1^IPV: CONTRA "_$$DATE^BUDEUTL1($P($P($G(^GMR(120.8,X,0)),U,4),"."))_"  Allergy Tracking: "_N

 .Q:'$$ANAREACT(X)  ;quit if anaphylactic is not a reaction/sign/symptom

 I G]"" Q G

 ;now check immunization package

 S T=$O(^BUDETSSC("B","T6B IMM IPV CODES",0))

 S X=""

 S BUDZ=0 F  S BUDZ=$O(^BUDETSSC(T,15,"B",BUDZ)) Q:BUDZ'=+BUDZ!(X]"")  D

 .S X=$$ANNECONT(P,BUDZ,EDATE)

 I X]"" Q "1^IPV: CONTRA IMM package: "_$$DATE^BUDEUTL1($P(X,U))_" "_$P(X,U,2)

 S T=$O(^BUDETSSC("B","T6B IMM IPV CODES",0))

 S BUDZ=0 F  S BUDZ=$O(^BUDETSSC(T,15,"B",BUDZ)) Q:BUDZ'=+BUDZ!(X]"")  D

 .S X=$$MMRCONT(P,BUDZ,EDATE)

 I X]"" Q "1^IPV: CONTRA IMM package: "_$$DATE^BUDEUTL1($P(X,U))_" "_$P(X,U,2)

 ;999.4 THING

 S X=$$CONTRA(P,$$DOB^AUPNPAT(P),EDATE,$O(^BUDETSSC("B","T6B IMM IPV CODES",0)),"IPV")

 I X]"" Q X

 ;now check for evidence of disease

IPVEVID ;

 ;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 EVIDENCE IPV",0))

 S T1=$O(^BUDETSSC("B","T6B IMM CONTRA IPV",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^IPV: 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,T1)) S G="1^IPV: CONTRA "_S_" on "_$$DATE^BUDEUTL1($P(BUDG(X),U))

 I G]"" Q G

 S X=$$PLCL^BUDEDU(P,"T6B IMM EVIDENCE IPV",EDATE,0) I X Q "1^IPV: Evidence: "_$P(X,U,2)_" on Problem List"

 S X=$$PLCL^BUDEDU(P,"T6B IMM CONTRA IPV",EDATE,0) I X Q "1^IPV: CONTRA: "_$P(X,U,2)_" on Problem List"

 K BUDD,BUDG,BUDX

 K BUDOPV,BUDAPOV

IPVIMM ;get all immunizations

 S BUDOPV=0

 D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")  ;all visits in 42 days to end

 S TIEN=$O(^BUDETSSC("B","T6B IMM IPV 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 BUDOPV(VDATE)="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 BUDOPV(VDATE)="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 BUDOPV(VDATE)="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 BUDOPV(VDATE)="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 BUDOPV(VDATE)="SNOMED "_Y_" on "_$$DATE^BUDEUTL1(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(BUDOPV(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

 .I $$FMDIFF^XLFDT(X,Y)<11 K BUDOPV(X) Q

 .S Y=X

 ;now count them and see if there are 3 of them

 S BUDOPV=0,X=0 F  S X=$O(BUDOPV(X)) Q:X'=+X  S BUDOPV=BUDOPV+1

 I BUDOPV>2 S Y="1^IPV: total #: "_BUDOPV,X="" F  S X=$O(BUDOPV(X)) Q:X'=+X  S Y=Y_"  "_BUDOPV(X)

 I BUDOPV>2 Q Y

 Q "0^"_(3-BUDOPV)_" IPV"

 ;

BUDERP6C  ;IHS/CMI/LAB - UDS T6B PROCESS;

 +1       ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75

 +2       ;

 +3       ;

GETIMMS(P,BDATE,EDATE,C,BUDX) ;EP

 +1        KILL BUDX

 +2        NEW X,Y,I,Z,V

 +3        SET X=0

           FOR 

               SET X=$ORDER(^AUPNVIMM("AC",P,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +4       ;happens

                   IF '$DATA(^AUPNVIMM(X,0))

                       QUIT 

 +5                SET Y=$PIECE(^AUPNVIMM(X,0),U)

 +6       ;happens too

                   IF 'Y

                       QUIT 

 +7       ;get HL7/CVX code

                   SET I=$PIECE($GET(^AUTTIMM(Y,0)),U,3)

 +8                FOR Z=1:1:$LENGTH(C,U)

                       IF I=$PIECE(C,U,Z)

                           SET V=$PIECE(^AUPNVIMM(X,0),U,3)

                           IF V

                               SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")

                               IF D]""

                                   IF D'>EDATE

                                       IF D'<BDATE

                                           SET BUDX(D)="CVX: "_I_" on "_$$DATE^BUDEUTL1(D)

 +9                QUIT 

               End DoDot:1

 +10       QUIT 

 +11      ;

IMM       ;EP - IMM

 +1       ;must have 2ND DOB between in the year - 2

 +2        SET BUDX2YRB=($EXTRACT(BUDBD,1,3)-2)_"0101"

 +3        SET BUDX2YRE=($EXTRACT(BUDED,1,3)-2)_"1231"

 +4        SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)

 +5        IF BUDDOB<BUDX2YRB

               QUIT 

 +6        IF BUDDOB>BUDX2YRE

               QUIT 

 +7        SET BUD2NDBD=$EXTRACT(BUDDOB,1,3)+2_$EXTRACT(BUDDOB,4,7)

 +8        SET BUD1STBD=$EXTRACT(BUDDOB,1,3)+1_$EXTRACT(BUDDOB,4,7)

 +9       ;

 +10      ;didn't have at least 1 medical visit

           IF BUDMEDV<1

               QUIT 

 +11       SET BUDSECTC("PTS")=$GET(BUDSECTC("PTS"))+1

 +12       SET BUDX42D=$$FMADD^XLFDT(BUDDOB,42)

 +13       SET BUDX180D=$$FMADD^XLFDT(BUDDOB,180)

 +14       SET (BUDNDTP,BUDNIPV,BUDNMMR,BUDNHEP,BUDNHIB,BUDNVAR,BUDNPNEU,BUDNHEPA,BUDNROTA,BUDNFLU)=""

 +15       SET BUDNDTP=$$DTAP^BUDERP6X(DFN,BUDX42D,BUD2NDBD)

 +16       SET BUDNIPV=$$IPV(DFN,BUDX42D,BUD2NDBD)

 +17       SET BUDNMMR=$$MMR^BUDERP6D(DFN,BUDDOB,BUD2NDBD)

 +18       SET BUDNHIB=$$HIB^BUDERP6Y(DFN,BUDX42D,BUD2NDBD)

 +19       SET BUDNHEP=$$HEPB^BUDERP6Y(DFN,BUDDOB,BUD2NDBD)

 +20       SET BUDNVAR=$$VAR^BUDERP6Y(DFN,BUD1STBD,BUD2NDBD)

 +21       SET BUDNPNEU=$$PNEU^BUDERP6Y(DFN,BUDDOB,BUD2NDBD)

 +22       SET BUDNHEPA=$$HEPA^BUDERP6H(DFN,BUDDOB,BUD2NDBD)

 +23       SET BUDNROTA=$$ROTA^BUDERP6H(DFN,BUDX42D,BUD2NDBD)

 +24       SET BUDNFLU=$$FLU^BUDERP6H(DFN,BUDX180D,BUD2NDBD)

 +25       IF $PIECE(BUDNDTP,U,1)=1

               IF $PIECE(BUDNIPV,U,1)=1

                   IF $PIECE(BUDNMMR,U,1)=1

                       IF $PIECE(BUDNHEP,U,1)=1

                           IF $PIECE(BUDNHIB,U,1)=1

                               IF $PIECE(BUDNVAR,U,1)=1

                                   IF $PIECE(BUDNPNEU,U,1)=1

                                       IF $PIECE(BUDNHEPA,U,1)=1

                                           IF $PIECE(BUDNROTA,U,1)=1

                                               IF $PIECE(BUDNFLU,U,1)=1

                                                   SET BUDSECTC("IMM")=$GET(BUDSECTC("IMM"))+1

                                                   Begin DoDot:1

 +26                                                   IF $GET(BUDIMM1L)

                                                           Begin DoDot:2

 +27                                                           SET X=$PIECE(BUDNDTP,U,2)_U_$PIECE(BUDNIPV,U,2)_U_$PIECE(BUDNMMR,U,2)_U_$PIECE(BUDNHEP,U,2)_U_$PIECE(BUDNHIB,U,2)_U_$PIECE(BUDNVAR,U,2)_U_$PIECE(BUDNPNEU,U,2)_U_$PIECE(BUDNHEPA,U,2)_U_$PIECE(B

UDNROTA,U,2)_U_$PIECE(BUDNFLU,U,2)_"|||"_U_BUDMEDVI

 +28                                                           SET ^XTMP("BUDERP6B",BUDJ,BUDH,"IMM1",$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=X

 +29                                                           QUIT 

                                                           End DoDot:2

                                                   End DoDot:1

                                                   QUIT 

 +30       IF $GET(BUDIMM2L)

               Begin DoDot:1

 +31               SET V=""

 +32               SET V=$SELECT($PIECE(BUDNDTP,U,1)=1:"",1:$PIECE(BUDNDTP,U,2))

 +33               IF $PIECE(BUDNIPV,U,1)'=1

                       IF V]""

                           SET V=V_"; "

                       SET V=V_$PIECE(BUDNIPV,U,2)

 +34               IF $PIECE(BUDNMMR,U,1)'=1

                       IF V]""

                           SET V=V_"; "

                       SET V=V_$PIECE(BUDNMMR,U,2)

 +35               IF $PIECE(BUDNHEP,U,1)'=1

                       IF V]""

                           SET V=V_"; "

                       SET V=V_$PIECE(BUDNHEP,U,2)

 +36               IF $PIECE(BUDNHIB,U,1)'=1

                       IF V]""

                           SET V=V_"; "

                       SET V=V_$PIECE(BUDNHIB,U,2)

 +37               IF $PIECE(BUDNVAR,U,1)'=1

                       IF V]""

                           SET V=V_"; "

                       SET V=V_$PIECE(BUDNVAR,U,2)

 +38               IF $PIECE(BUDNPNEU,U,1)'=1

                       IF V]""

                           SET V=V_"; "

                       SET V=V_$PIECE(BUDNPNEU,U,2)

 +39               IF $PIECE(BUDNHEPA,U,1)'=1

                       IF V]""

                           SET V=V_"; "

                       SET V=V_$PIECE(BUDNHEPA,U,2)

 +40               IF $PIECE(BUDNROTA,U,1)'=1

                       IF V]""

                           SET V=V_"; "

                       SET V=V_$PIECE(BUDNROTA,U,2)

 +41               IF $PIECE(BUDNFLU,U,1)'=1

                       IF V]""

                           SET V=V_"; "

                       SET V=V_$PIECE(BUDNFLU,U,2)

 +42               SET ^XTMP("BUDERP6B",BUDJ,BUDH,"IMM2",$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=V

               End DoDot:1

 +43       QUIT 

 +44      ;

CONTRA(P,BD,ED,T1,LABEL) ;EP

 +1        NEW D,BUDG,E,%

 +2        KILL BUDG

           SET %=P_"^ALL DX;DURING "_BD_"-"_ED

           SET E=$$START1^APCLDF(%,"BUDG(")

 +3        NEW X,Y,G,T,V,Z,A

 +4        SET T=$ORDER(^BUDETSSC("B","T6B IMM CONTRA ALL VACCINES",0))

 +5        SET G=""

 +6        SET X=0

           FOR 

               SET X=$ORDER(BUDG(X))

               IF X'=+X!(G]"")

                   QUIT 

               Begin DoDot:1

 +7                SET Y=+$PIECE(BUDG(X),U,4)

 +8                SET Y=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)

 +9                IF '$DATA(^BUDETSSC("AD",Y,T))

                       QUIT 

 +10               SET V=$PIECE(BUDG(X),U,5)

 +11               SET Z=0

                   FOR 

                       SET Z=$ORDER(^AUPNVIMM("AD",V,Z))

                       IF Z'=+Z!(G)

                           QUIT 

                       Begin DoDot:2

 +12                       SET A=$PIECE(^AUPNVIMM(Z,0),U,1)

 +13                       SET A=+$PIECE($GET(^AUTTIMM(A,0)),U,3)

 +14                       IF A=""

                               QUIT 

 +15                       IF '$DATA(^BUDETSSC(T1,15,"B",A))

                               QUIT 

 +16                       SET G=1_U_LABEL_": CONTRA "_$PIECE(BUDG(X),U,2)_"/"_A_" on "_$$DATE^BUDEUTL1($PIECE(BUDG(X),U,1))

                       End DoDot:2

 +17      ;CPT

 +18               SET Z=0

                   FOR 

                       SET Z=$ORDER(^AUPNVCPT("AD",V,Z))

                       IF Z'=+Z!(G)

                           QUIT 

                       Begin DoDot:2

 +19                       SET A=$$VAL^XBDIQ1(9000010.18,Z,.01)

 +20                       IF A=""

                               QUIT 

 +21                       IF '$DATA(^BUDETSSC("AC",A,T1))

                               QUIT 

 +22                       SET G=1_U_LABEL_": CONTRA "_$PIECE(BUDG(X),U,2)_"/"_A_" on "_$$DATE^BUDEUTL1($PIECE(BUDG(X),U,1))

                       End DoDot:2

 +23      ;POV

 +24               SET Z=0

                   FOR 

                       SET Z=$ORDER(^AUPNVPOV("AD",V,Z))

                       IF Z'=+Z!(G)

                           QUIT 

                       Begin DoDot:2

 +25                       SET A=$$VALI^XBDIQ1(9000010.07,Z,.01)

 +26                       IF A=""

                               QUIT 

 +27                       IF $DATA(^BUDETSSC("AD",A,T1))

                               SET G=1_U_LABEL_": CONTRA "_$PIECE(BUDG(X),U,2)_"/"_$$VAL^XBDIQ1(9000010.07,Z,.01)_" on "_$$DATE^BUDEUTL1($PIECE(BUDG(X),U,1))

 +28                       SET A=$$VAL^XBDIQ1(9000010.07,Z,1101)

 +29                       IF A=""

                               QUIT 

 +30                       IF $DATA(^BUDETSSC("AS",Z,T1))

                               SET G=1_U_LABEL_": CONTRA "_$PIECE(BUDG(X),U,2)_"/"_A_" on "_$$DATE^BUDEUTL1($PIECE(BUDG(X),U,1))