BGP9D32.m

BGP9D32 ; IHS/CMI/LAB - measure C ;

 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009

 ;

I14 ;EP

 ;3 denominators, 32 numerators

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27)=0

 S (BGPI1,BGPI2,BGPI3,BGPI4,BGPI5,BGPI6,BGPI7,BGPN28,BGPN29,BGP30N,BGPN30,BGPN31,BGPN32,BGPN33,BGPN34,BGPN40,BGPN41,BGPN42)=0

 S BGPVALUE=""

 K BGPDTAP,BGPOPV,BGPMMR,BGPD,BGPT,BGPPER,BGPTET,BGPM,BGPMU,BGPME,BGPHIB,BGPHEP,BGPVAR

 I 'BGPACTUP S BGPSTOP=1 Q

 S BGPDAYS=$$FMDIFF^XLFDT(BGPBDATE,$$DOB^AUPNPAT(DFN))

 S BGPMON=BGPDAYS/30.5

 I BGPMON<7 S BGPSTOP=1 Q  ;no one less than 7 months

 I BGPMON>23 S BGPSTOP=1 Q  ;no one less than 23 months on 1st day of time frame

 I BGPACTUP S BGPD2=1

 I BGPACTCL S BGPD1=1

 I BGPACTUP,$$ACTIM(DFN,BGPBDATE,BGPEDATE),BGPTIME=1 S BGPD3=1

 I 'BGPD1,'BGPD2,'BGPD3 S BGPSTOP=1 Q

 ;BGPN1 - patients with 4 DTaP or various combinations

 K ^TMP($J,"CPT")

 S BGPVAL=$$DTAP^BGP9D34(DFN,BGPEDATE)  ;1 IS had immunizations, 3 is had refusal, 4 is disease or NMI or contraindication

 I $P(BGPVAL,U,1) S BGPN1=1  ;any hit

 I $P(BGPVAL,U,1)=1 S BGPI1=1 ;had all imms

 I $P(BGPVAL,U,1)=3 S BGPN2=1 ;refusal

 I $P(BGPVAL,U,1)=4 S BGPN3=1 ;evid disease, nmi, contraindication

 I $P(BGPVAL,U,1) S BGPVALUE=$P(BGPVAL,U,2)

 K ^TMP($J,"CPT")

 S BGPVAL=$$OPV^BGP9D33(DFN,BGPEDATE)

 I $P(BGPVAL,U,1) S BGPN4=1  ;any hit

 I $P(BGPVAL,U,1)=1 S BGPI2=1 ;had all imms

 I $P(BGPVAL,U,1)=3 S BGPN5=1 ;refusal

 I $P(BGPVAL,U,1)=4 S BGPN6=1 ;evid disease, nmi, contraindication

 I $P(BGPVAL,U,1) S BGPVALUE=BGPVALUE_";"_$P(BGPVAL,U,2)

 S BGPVAL=$$MMR^BGP9D33(DFN,BGPEDATE)

 I $P(BGPVAL,U,1) S BGPN7=1  ;any hit

 I $P(BGPVAL,U,1)=1 S BGPI3=1

 I $P(BGPVAL,U,1)=3 S BGPN8=1 ;refusal

 I $P(BGPVAL,U,1)=4 S BGPN9=1 ;evid disease, nmi, contraindication

 I $P(BGPVAL,U,1) S BGPVALUE=BGPVALUE_";"_$P(BGPVAL,U,2)

 S BGPVAL=$$HIB^BGP9D35(DFN,BGPEDATE)

 I $P(BGPVAL,U,1) S BGPN10=1  ;any hit

 I $P(BGPVAL,U,1)=1 S BGPI4=1

 I $P(BGPVAL,U,1)=3 S BGPN11=1 ;refusal

 I $P(BGPVAL,U,1)=4 S BGPN12=1 ;evid disease, nmi, contraindication

 I $P(BGPVAL,U,1) S BGPVALUE=BGPVALUE_";"_$P(BGPVAL,U,2)

 S BGPVAL=$$HEP^BGP9D35(DFN,BGPEDATE)

 I $P(BGPVAL,U,1) S BGPN13=1  ;any hit

 I $P(BGPVAL,U,1)=1 S BGPI5=1

 I $P(BGPVAL,U,1)=3 S BGPN14=1 ;refusal

 I $P(BGPVAL,U,1)=4 S BGPN15=1 ;evid disease, nmi, contraindication

 I $P(BGPVAL,U,1) S BGPVALUE=BGPVALUE_";"_$P(BGPVAL,U,2)

 S BGPVAL=$$VAR^BGP9D35(DFN,BGPEDATE)

 I $P(BGPVAL,U,1) S BGPN16=1  ;any hit

 I $P(BGPVAL,U,1)=1 S BGPI6=1

 I $P(BGPVAL,U,1)=3 S BGPN17=1 ;refusal

 I $P(BGPVAL,U,1)=4 S BGPN18=1 ;evid disease, nmi, contraindication

 I $P(BGPVAL,U,1) S BGPVALUE=BGPVALUE_";"_$P(BGPVAL,U,2)

 S BGPVAL=$$PNEUMO^BGP9D35(DFN,BGPEDATE)

 I $P(BGPVAL,U,1) S BGPN26=1  ;any hit

 I $P(BGPVAL,U,1)=1 S BGPI7=1

 I $P(BGPVAL,U,1)=3 S BGPN27=1 ;refusal

 I $P(BGPVAL,U,1)=4 S BGPN28=1 ;evid disease, nmi, contraindication

 I $P(BGPVAL,U,1) S BGPVALUE=BGPVALUE_";"_$P(BGPVAL,U,2)

 I BGPN1,BGPN4,BGPN7,BGPN10,BGPN13,BGPN16,BGPN26 S BGPN19=1  ;4313314

 I BGPN1,'BGPN2,BGPN4,'BGPN5,BGPN7,'BGPN8,BGPN10,'BGPN11,BGPN13,'BGPN14,BGPN16,'BGPN17,BGPN26,'BGPN27 S BGPN42=1  ;4313314

 I BGPN2!(BGPN5)!(BGPN8)!(BGPN11)!(BGPN14)!(BGPN17)!(BGPN27) S BGPN32=1  ;4313314 REF

 I BGPN3!(BGPN6)!(BGPN9)!(BGPN12)!(BGPN15)!(BGPN18)!(BGPN28) S BGPN33=1  ;4313314 CONTRA

 I BGPN1,BGPN4,BGPN7,BGPN10,BGPN13,BGPN16 S BGPN29=1  ;HEDIS ONLY 1.1.8 431331

 I BGPN1,'BGPN2,BGPN4,'BGPN5,BGPN7,'BGPN8,BGPN10,'BGPN11,BGPN13,'BGPN14,BGPN16,'BGPN17 S BGPN41=1  ;HEDIS ONLY 1.1.8 431331

 I BGPN2!(BGPN5)!(BGPN8)!(BGPN11)!(BGPN14)!(BGPN17) S BGPN30=1  ;431331 REFUSALS

 I BGPN3!(BGPN6)!(BGPN9)!(BGPN12)!(BGPN15)!(BGPN18) S BGPN31=1  ;431331 CONTRA/DX

 I BGPN2!(BGPN5)!(BGPN8)!(BGPN11)!(BGPN14) S BGPN22=1

 I BGPN3!(BGPN6)!(BGPN9)!(BGPN12)!(BGPN15) S BGPN23=1

 I BGPN1,BGPN4,BGPN7 S BGPN20=1

 I BGPN1,BGPN4,BGPN7,BGPN10,BGPN13 S BGPN21=1  ;4:3:1:3:3

 I BGPN1,'BGPN2,BGPN4,'BGPN5,BGPN7,'BGPN8,BGPN10,'BGPN11,BGPN13,'BGPN14 S BGPN40=1  ;4:3:1:3:3

 I BGPI1,BGPI2,BGPI3,BGPI4,BGPI5,BGPI6,BGPI7 S BGPN24=1

 I BGPI1,BGPI2,BGPI3,BGPI4,BGPI5,BGPI6 S BGPN34=1

 ;I BGPI1,BGPI2,BGPI3 S BGPN25=1

 I BGPI1,BGPI2,BGPI3,BGPI4,BGPI5 S BGPN25=1

 I BGPRTYPE=3,'BGPN19 S BGPVALUE="DID NOT HAVE: " D

 .I 'BGPN1 S BGPVALUE=BGPVALUE_"4 Dtap/DTP;"

 .I 'BGPN4 S BGPVALUE=BGPVALUE_"3 OPV;"

 .I 'BGPN7 S BGPVALUE=BGPVALUE_"MMR;"

 .I 'BGPN10 S BGPVALUE=BGPVALUE_"3 HIB;"

 .I 'BGPN13 S BGPVALUE=BGPVALUE_"3 HEP;"

 .I 'BGPN16 S BGPVALUE=BGPVALUE_"VAR;"

 .I 'BGPN26 S BGPVALUE=BGPVALUE_"4 PNEUMO"

 I $G(BGPISSO),'BGPN21 S BGPVALUE="Immunizations Overdue for: |" D

 .I 'BGPN1 S BGPVALUE=BGPVALUE_"4 Dtap/DTP;"

 .I 'BGPN4 S BGPVALUE=BGPVALUE_"3 OPV;"

 .I 'BGPN7 S BGPVALUE=BGPVALUE_"1 MMR;"

 .I 'BGPN10 S BGPVALUE=BGPVALUE_"3 HIB;"

 .I 'BGPN13 S BGPVALUE=BGPVALUE_"3 HEP;"

 S D=""

 I BGPD1 S D="UP;AC"

 E  S D="UP"

 I BGPD3 S D=D_";IMM"

 I BGPRTYPE=3 S D="AC"

 S BGPVALUE=D_"|||"_BGPVALUE

 ;I BGPN19 S BGPVALUE=$P(BGPVALUE,"|||",1)_"|||4:3:1:3:3:1"

 ;I BGPN21,'BGPN19 S $P(BGPVALUE,"|||",2)="4:3:1:3:3"

 K BGPTET,BGPDTAP,BGPDT,BGPTD,BGPPER,BGPDIP,BGPMU,BGPME,BGPMMR,BGPMR,BGPRM,BGPOPV,BGPRUB,BGPHIB,BGPHEB,BGPVAR,BGPI1,BGPI2,BGPI3,BGPI4,BGPI5,BGPI6,BGPVAL

 Q

ACTIM(P,BDATE,EDATE) ;EP is patient active on imm register as of EDATE?

 I '$G(P) Q ""

 I '$D(^BIP(P)) Q ""

 I $P(^BIP(P,0),U,8)="" Q 1

 I $P(^BIP(P,0),U,8)<EDATE Q ""

 I $P(^BIP(P,0),U,8)=EDATE Q ""

 Q 1

GETIMMS(P,EDATE,C,BGPX) ;EP

 K BGPX

 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 S BGPX(D)=Y

 .Q

 Q

IMMREF(P,IMM,BD,ED) ;EP

 NEW X,Y,G,D,R

 I 'IMM Q ""

 S (X,G)=0,Y=$O(^AUTTIMM("C",IMM,0))

 I 'Y Q ""

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

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

 .Q:R=""

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

 .Q:$P(^BICONT(R,0),U,1)'["Refusal"

 .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

 .S G=G+1

 Q G

BGP9D32   ; IHS/CMI/LAB - measure C ;

 +1       ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009

 +2       ;

I14       ;EP

 +1       ;3 denominators, 32 numerators

 +2        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27)=0

 +3        SET (BGPI1,BGPI2,BGPI3,BGPI4,BGPI5,BGPI6,BGPI7,BGPN28,BGPN29,BGP30N,BGPN30,BGPN31,BGPN32,BGPN33,BGPN34,BGPN40,BGPN41,BGPN42)=0

 +4        SET BGPVALUE=""

 +5        KILL BGPDTAP,BGPOPV,BGPMMR,BGPD,BGPT,BGPPER,BGPTET,BGPM,BGPMU,BGPME,BGPHIB,BGPHEP,BGPVAR

 +6        IF 'BGPACTUP

               SET BGPSTOP=1

               QUIT 

 +7        SET BGPDAYS=$$FMDIFF^XLFDT(BGPBDATE,$$DOB^AUPNPAT(DFN))

 +8        SET BGPMON=BGPDAYS/30.5

 +9       ;no one less than 7 months

           IF BGPMON<7

               SET BGPSTOP=1

               QUIT 

 +10      ;no one less than 23 months on 1st day of time frame

           IF BGPMON>23

               SET BGPSTOP=1

               QUIT 

 +11       IF BGPACTUP

               SET BGPD2=1

 +12       IF BGPACTCL

               SET BGPD1=1

 +13       IF BGPACTUP

               IF $$ACTIM(DFN,BGPBDATE,BGPEDATE)

                   IF BGPTIME=1

                       SET BGPD3=1

 +14       IF 'BGPD1

               IF 'BGPD2

                   IF 'BGPD3

                       SET BGPSTOP=1

                       QUIT 

 +15      ;BGPN1 - patients with 4 DTaP or various combinations

 +16       KILL ^TMP($JOB,"CPT")

 +17      ;1 IS had immunizations, 3 is had refusal, 4 is disease or NMI or contraindication

           SET BGPVAL=$$DTAP^BGP9D34(DFN,BGPEDATE)

 +18      ;any hit

           IF $PIECE(BGPVAL,U,1)

               SET BGPN1=1

 +19      ;had all imms

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

               SET BGPI1=1

 +20      ;refusal

           IF $PIECE(BGPVAL,U,1)=3

               SET BGPN2=1

 +21      ;evid disease, nmi, contraindication

           IF $PIECE(BGPVAL,U,1)=4

               SET BGPN3=1

 +22       IF $PIECE(BGPVAL,U,1)

               SET BGPVALUE=$PIECE(BGPVAL,U,2)

 +23       KILL ^TMP($JOB,"CPT")

 +24       SET BGPVAL=$$OPV^BGP9D33(DFN,BGPEDATE)

 +25      ;any hit

           IF $PIECE(BGPVAL,U,1)

               SET BGPN4=1

 +26      ;had all imms

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

               SET BGPI2=1

 +27      ;refusal

           IF $PIECE(BGPVAL,U,1)=3

               SET BGPN5=1

 +28      ;evid disease, nmi, contraindication

           IF $PIECE(BGPVAL,U,1)=4

               SET BGPN6=1

 +29       IF $PIECE(BGPVAL,U,1)

               SET BGPVALUE=BGPVALUE_";"_$PIECE(BGPVAL,U,2)

 +30       SET BGPVAL=$$MMR^BGP9D33(DFN,BGPEDATE)

 +31      ;any hit

           IF $PIECE(BGPVAL,U,1)

               SET BGPN7=1

 +32       IF $PIECE(BGPVAL,U,1)=1

               SET BGPI3=1

 +33      ;refusal

           IF $PIECE(BGPVAL,U,1)=3

               SET BGPN8=1

 +34      ;evid disease, nmi, contraindication

           IF $PIECE(BGPVAL,U,1)=4

               SET BGPN9=1

 +35       IF $PIECE(BGPVAL,U,1)

               SET BGPVALUE=BGPVALUE_";"_$PIECE(BGPVAL,U,2)

 +36       SET BGPVAL=$$HIB^BGP9D35(DFN,BGPEDATE)

 +37      ;any hit

           IF $PIECE(BGPVAL,U,1)

               SET BGPN10=1

 +38       IF $PIECE(BGPVAL,U,1)=1

               SET BGPI4=1

 +39      ;refusal

           IF $PIECE(BGPVAL,U,1)=3

               SET BGPN11=1

 +40      ;evid disease, nmi, contraindication

           IF $PIECE(BGPVAL,U,1)=4

               SET BGPN12=1

 +41       IF $PIECE(BGPVAL,U,1)

               SET BGPVALUE=BGPVALUE_";"_$PIECE(BGPVAL,U,2)

 +42       SET BGPVAL=$$HEP^BGP9D35(DFN,BGPEDATE)

 +43      ;any hit

           IF $PIECE(BGPVAL,U,1)

               SET BGPN13=1

 +44       IF $PIECE(BGPVAL,U,1)=1

               SET BGPI5=1

 +45      ;refusal

           IF $PIECE(BGPVAL,U,1)=3

               SET BGPN14=1

 +46      ;evid disease, nmi, contraindication

           IF $PIECE(BGPVAL,U,1)=4

               SET BGPN15=1

 +47       IF $PIECE(BGPVAL,U,1)

               SET BGPVALUE=BGPVALUE_";"_$PIECE(BGPVAL,U,2)

 +48       SET BGPVAL=$$VAR^BGP9D35(DFN,BGPEDATE)

 +49      ;any hit

           IF $PIECE(BGPVAL,U,1)

               SET BGPN16=1

 +50       IF $PIECE(BGPVAL,U,1)=1

               SET BGPI6=1

 +51      ;refusal

           IF $PIECE(BGPVAL,U,1)=3

               SET BGPN17=1

 +52      ;evid disease, nmi, contraindication

           IF $PIECE(BGPVAL,U,1)=4

               SET BGPN18=1

 +53       IF $PIECE(BGPVAL,U,1)

               SET BGPVALUE=BGPVALUE_";"_$PIECE(BGPVAL,U,2)

 +54       SET BGPVAL=$$PNEUMO^BGP9D35(DFN,BGPEDATE)

 +55      ;any hit

           IF $PIECE(BGPVAL,U,1)

               SET BGPN26=1

 +56       IF $PIECE(BGPVAL,U,1)=1

               SET BGPI7=1

 +57      ;refusal

           IF $PIECE(BGPVAL,U,1)=3

               SET BGPN27=1

 +58      ;evid disease, nmi, contraindication

           IF $PIECE(BGPVAL,U,1)=4

               SET BGPN28=1

 +59       IF $PIECE(BGPVAL,U,1)

               SET BGPVALUE=BGPVALUE_";"_$PIECE(BGPVAL,U,2)

 +60      ;4313314

           IF BGPN1

               IF BGPN4

                   IF BGPN7

                       IF BGPN10

                           IF BGPN13

                               IF BGPN16

                                   IF BGPN26

                                       SET BGPN19=1

 +61      ;4313314

           IF BGPN1

               IF 'BGPN2

                   IF BGPN4

                       IF 'BGPN5

                           IF BGPN7

                               IF 'BGPN8

                                   IF BGPN10

                                       IF 'BGPN11

                                           IF BGPN13

                                               IF 'BGPN14

                                                   IF BGPN16

                                                       IF 'BGPN17

                                                           IF BGPN26

                                                               IF 'BGPN27

                                                                   SET BGPN42=1

 +62      ;4313314 REF

           IF BGPN2!(BGPN5)!(BGPN8)!(BGPN11)!(BGPN14)!(BGPN17)!(BGPN27)

               SET BGPN32=1

 +63      ;4313314 CONTRA

           IF BGPN3!(BGPN6)!(BGPN9)!(BGPN12)!(BGPN15)!(BGPN18)!(BGPN28)

               SET BGPN33=1

 +64      ;HEDIS ONLY 1.1.8 431331

           IF BGPN1

               IF BGPN4

                   IF BGPN7

                       IF BGPN10

                           IF BGPN13

                               IF BGPN16

                                   SET BGPN29=1

 +65      ;HEDIS ONLY 1.1.8 431331

           IF BGPN1

               IF 'BGPN2

                   IF BGPN4

                       IF 'BGPN5

                           IF BGPN7

                               IF 'BGPN8

                                   IF BGPN10

                                       IF 'BGPN11

                                           IF BGPN13

                                               IF 'BGPN14

                                                   IF BGPN16

                                                       IF 'BGPN17

                                                           SET BGPN41=1

 +66      ;431331 REFUSALS

           IF BGPN2!(BGPN5)!(BGPN8)!(BGPN11)!(BGPN14)!(BGPN17)

               SET BGPN30=1

 +67      ;431331 CONTRA/DX

           IF BGPN3!(BGPN6)!(BGPN9)!(BGPN12)!(BGPN15)!(BGPN18)

               SET BGPN31=1

 +68       IF BGPN2!(BGPN5)!(BGPN8)!(BGPN11)!(BGPN14)

               SET BGPN22=1

 +69       IF BGPN3!(BGPN6)!(BGPN9)!(BGPN12)!(BGPN15)

               SET BGPN23=1

 +70       IF BGPN1

               IF BGPN4

                   IF BGPN7

                       SET BGPN20=1

 +71      ;4:3:1:3:3

           IF BGPN1

               IF BGPN4

                   IF BGPN7

                       IF BGPN10

                           IF BGPN13

                               SET BGPN21=1

 +72      ;4:3:1:3:3

           IF BGPN1

               IF 'BGPN2

                   IF BGPN4

                       IF 'BGPN5

                           IF BGPN7

                               IF 'BGPN8

                                   IF BGPN10

                                       IF 'BGPN11

                                           IF BGPN13

                                               IF 'BGPN14

                                                   SET BGPN40=1

 +73       IF BGPI1

               IF BGPI2

                   IF BGPI3

                       IF BGPI4

                           IF BGPI5

                               IF BGPI6

                                   IF BGPI7

                                       SET BGPN24=1

 +74       IF BGPI1

               IF BGPI2

                   IF BGPI3

                       IF BGPI4

                           IF BGPI5

                               IF BGPI6

                                   SET BGPN34=1

 +75      ;I BGPI1,BGPI2,BGPI3 S BGPN25=1

 +76       IF BGPI1

               IF BGPI2

                   IF BGPI3

                       IF BGPI4

                           IF BGPI5

                               SET BGPN25=1

 +77       IF BGPRTYPE=3

               IF 'BGPN19

                   SET BGPVALUE="DID NOT HAVE: "

                   Begin DoDot:1

 +78                   IF 'BGPN1

                           SET BGPVALUE=BGPVALUE_"4 Dtap/DTP;"

 +79                   IF 'BGPN4

                           SET BGPVALUE=BGPVALUE_"3 OPV;"

 +80                   IF 'BGPN7

                           SET BGPVALUE=BGPVALUE_"MMR;"

 +81                   IF 'BGPN10

                           SET BGPVALUE=BGPVALUE_"3 HIB;"

 +82                   IF 'BGPN13

                           SET BGPVALUE=BGPVALUE_"3 HEP;"

 +83                   IF 'BGPN16

                           SET BGPVALUE=BGPVALUE_"VAR;"

 +84                   IF 'BGPN26

                           SET BGPVALUE=BGPVALUE_"4 PNEUMO"

                   End DoDot:1

 +85       IF $GET(BGPISSO)

               IF 'BGPN21

                   SET BGPVALUE="Immunizations Overdue for: |"

                   Begin DoDot:1

 +86                   IF 'BGPN1

                           SET BGPVALUE=BGPVALUE_"4 Dtap/DTP;"

 +87                   IF 'BGPN4

                           SET BGPVALUE=BGPVALUE_"3 OPV;"

 +88                   IF 'BGPN7

                           SET BGPVALUE=BGPVALUE_"1 MMR;"

 +89                   IF 'BGPN10

                           SET BGPVALUE=BGPVALUE_"3 HIB;"

 +90                   IF 'BGPN13

                           SET BGPVALUE=BGPVALUE_"3 HEP;"

                   End DoDot:1

 +91       SET D=""

 +92       IF BGPD1

               SET D="UP;AC"

 +93      IF '$TEST

               SET D="UP"

 +94       IF BGPD3

               SET D=D_";IMM"

 +95       IF BGPRTYPE=3

               SET D="AC"

 +96       SET BGPVALUE=D_"|||"_BGPVALUE

 +97      ;I BGPN19 S BGPVALUE=$P(BGPVALUE,"|||",1)_"|||4:3:1:3:3:1"

 +98      ;I BGPN21,'BGPN19 S $P(BGPVALUE,"|||",2)="4:3:1:3:3"

 +99       KILL BGPTET,BGPDTAP,BGPDT,BGPTD,BGPPER,BGPDIP,BGPMU,BGPME,BGPMMR,BGPMR,BGPRM,BGPOPV,BGPRUB,BGPHIB,BGPHEB,BGPVAR,BGPI1,BGPI2,BGPI3,BGPI4,BGPI5,BGPI6,BGPVAL

 +100      QUIT 

ACTIM(P,BDATE,EDATE) ;EP is patient active on imm register as of EDATE?

 +1        IF '$GET(P)

               QUIT ""

 +2        IF '$DATA(^BIP(P))

               QUIT ""

 +3        IF $PIECE(^BIP(P,0),U,8)=""

               QUIT 1

 +4        IF $PIECE(^BIP(P,0),U,8)<EDATE

               QUIT ""

 +5        IF $PIECE(^BIP(P,0),U,8)=EDATE

               QUIT ""

 +6        QUIT 1

GETIMMS(P,EDATE,C,BGPX) ;EP

 +1        KILL BGPX

 +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

                                       SET BGPX(D)=Y

 +9                QUIT 

               End DoDot:1

 +10       QUIT 

IMMREF(P,IMM,BD,ED) ;EP

 +1        NEW X,Y,G,D,R

 +2        IF 'IMM

               QUIT ""

 +3        SET (X,G)=0

           SET Y=$ORDER(^AUTTIMM("C",IMM,0))

 +4        IF 'Y

               QUIT ""

 +5        FOR 

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

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +6                SET R=$PIECE(^BIPC(X,0),U,3)

 +7                IF R=""

                       QUIT 

 +8                IF '$DATA(^BICONT(R,0))

                       QUIT 

 +9                IF $PIECE(^BICONT(R,0),U,1)'["Refusal"

                       QUIT 

 +10               SET D=$PIECE(^BIPC(X,0),U,4)

 +11               IF D=""

                       QUIT 

 +12               IF $PIECE(^BIPC(X,0),U,4)<BD

                       QUIT 

 +13               IF $PIECE(^BIPC(X,0),U,4)>ED

                       QUIT 

 +14               SET G=G+1

               End DoDot:1

 +15       QUIT G