Routine: BGP8D36

BGP8D36 ;IHS/CMI/LAB - MEASURE IMM LOGIC;

 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66

MEN(P,EDATE) ;EP

 NEW BGPC,BGPG,BGPX,BGPMENI,C,ED,BD,V,X,Y,BGPZ,B,BGPIMM,R,G,T

 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart

 K BGPMENI

 ;get all immunizations

 ;S C="32^108^114^136^147^148"

 S C="",X=0

 S T=$O(^ATXAX("B","BGP MENINGOCOCCAL CVX CODES",0))

 F  S X=$O(^ATXAX(T,21,"B",X)) Q:X=""  S:C]"" C=C_U S C=C_X

 D GETIMMS^BGP8D32(P,EDATE,C,.BGPX)

 ;go through and set into array if 10 days apart

 I $O(BGPX(0)) Q 1_U_"Meningococcal"

 ;now get cpts

 S T=$O(^ATXAX("B","BGP CPT MENINGOCOCCAL",0))

 S ED=9999999-EDATE-1,BD=9999999-$$DOB^AUPNPAT(P),G=0

 F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)  D

 .S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V  D

 ..Q:'$D(^AUPNVSIT(V,0))

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

 ...S Y=$P(^AUPNVCPT(X,0),U) I $$ICD^ATXAPI(Y,T,1) S BGPMENI(9999999-$P(ED,"."))=""

 ..S X=0 F  S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X  D

 ...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y  I $$ICD^ATXAPI(Y,T,1) S BGPMENI(9999999-$P(ED,"."))=""

 I $D(BGPMENI) Q 1_U_"Meningococcal"

 ;check for Evidence of desease and Contraindications and if yes, then quit

 S T=$O(^ATXAX("B","BGP MENINGOCOCCAL CVX CODES",0))

 S X="",Y=0

 F  S Y=$O(^ATXAX(T,21,"B",Y)) Q:Y=""  D  Q:X]""

 .S X=$$ANCONT^BGP8D31(P,Y,EDATE) Q:X]""

 I X]"" Q 4_U_"Contra Meningococcal"

 ;now go to Refusals

 S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""

 S BGPIMM=0 F  S BGPIMM=$O(^ATXAX(T,21,"B",BGPIMM)) Q:BGPIMM=""  D     ;F BGPIMM=32,108,114,136,147  D

 .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I

 .S X=0 F  S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X  S Y=0 F  S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y  S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1

 I BGPNMI Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Meningococcal",1:"Ref Meningococcal")

 F BGPIMM=90733,90734,90644 D

 .S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I

 .S X=0 F  S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X  S Y=0 F  S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y  S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1

 I BGPNMI Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Meningococcal",1:"Ref Meningococcal")

 Q ""

HPV(P,EDATE) ;EP

 NEW BGPC,BGPG,BGPX,BGPHPV,C,X,ED,BD,V,G,R,BGPIMM,Y,Z,B,BGPNMI

 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart

 ;get all immunizations

 ;S C="62^118^137^165"

 S C="",X=0

 S T=$O(^ATXAX("B","BGP HPV CVX CODES",0))

 F  S X=$O(^ATXAX(T,21,"B",X)) Q:X=""  S:C]"" C=C_U S C=C_X

 D GETIMMS^BGP8D32(P,EDATE,C,.BGPX)

 ;go through and set into array if 10 days apart

 S X=0 F  S X=$O(BGPX(X)) Q:X'=+X  S BGPHPV(X)=""

 ;now get cpts

 S ED=9999999-EDATE,BD=9999999-$$DOB^AUPNPAT(P),G=0

 F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)  D

 .S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V  D

 ..Q:'$D(^AUPNVSIT(V,0))

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

 ...S Y=$P(^AUPNVCPT(X,0),U) S Z=$P($$CPT^ICPTCOD(Y),U,2) I Z=90649!(Z=90650)!(Z=90651) S BGPHPV(9999999-$P(ED,"."))=""

 ..S X=0 F  S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X  D

 ...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y  S Z=$P($$CPT^ICPTCOD(Y),U,2) I Z=90649!(Z=90650)!(Z=90651) S BGPHPV(9999999-$P(ED,"."))=""

 ;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(BGPHPV(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

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

 .S Y=X

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

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

 I BGPHPV>2 Q 1_U_"3 HPV"

 I BGPHPV<2 G ED  ;didn't have at least 2 so go to check for nmi/evid

 ;v18, check for 2 doses, 1 dose prior to 15th bd and one at least 5 months later

 ;15TH BIRTDAY

 S B=$$DOB^AUPNPAT(P)

 S BGP15BD=$E(B,1,3)+15_$E(B,4,7)

 S D=0,G=0,Q=0,Z="" F  S D=$O(BGPHPV(D)) Q:D'=+D!(Q)  D

 .I D>BGP15BD S Q=1 Q   ;AFTER 15TH BD SO DON'T BOTHER

 .;get next one and check for 5 months

 .S Y=$O(BGPHPV(D))

 .;5 MONTHS AFTER D

 .S Z=$$M5(D)

 .I Y<Z Q  ;not at least 5 months

 .S G=1_U_"2 HPV"

 .S Q=1

 ;W !!,P,"  ",BGP15BD,"  ",Z,! ZW BGPHPV W !  ;LORI

 I G Q G

ED ;check for Evidence of desease and Contraindications and if yes, then quit

 ;now go to Refusals

 S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""

 F BGPIMM=62,118,137,165  D

 .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I

 .S X=0 F  S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X  S Y=0 F  S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y  S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1

 I BGPNMI Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" HPV"

 F BGPIMM=90649,90650,90651 D

 .S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I

 .S X=0 F  S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X  S Y=0 F  S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y  S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1

 I BGPNMI Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI HPV",1:"Ref HPV")

 ;now check Refusals in imm pkg

 ;F BGPIMM=62,118 S R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

 ;I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" HPV"

 F BGPZ=62,118,137,165 S X=$$ANCONT^BGP8D31(P,BGPZ,EDATE) Q:X]""

 I X]"" Q 4_U_"Contra HPV"

 Q ""

M5(E) ;

 I $G(E)="" Q ""

 NEW M,Z

 S M=$E(E,4,5)  ;month

 S M=+M

 S A=$S(M=1:6,M=2:7,M=3:8,M=4:9,M=5:10,M=6:11,M=7:12,M=8:1,M=9:2,M=10:3,M=11:4,M=12:5,1:"")

 S:$L(A)<2 A="0"_A

 I +M<8 S A=$E(E,1,3)_A_$E(E,6,7) Q A

 S A=($E(E,1,3)+1)_A_$E(E,6,7)

Q A

AGE(P,BGPZ,BGPDT) ;EP

 ;---> Return Patient's Age.

 ;---> Parameters:

 ;     1 - DFN  (req) IEN in PATIENT File.

 ;     2 - BGPZ  (opt) APCLZ=1,2,3  1=years, 2=months, 3=days.

 ;                               2 will be assumed if not passed.

 ;     3 - APCLDT (opt) Date on which Age should be calculated.

 N BGPDOB,X,X1,X2  S:$G(BGPZ)="" BGPZ=2

 Q:'$G(P) ""

 I '$D(^DPT(P,0)) Q ""

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

 Q:'BGPDOB ""

 S:'$G(DT) DT=$$DT^XLFDT

 S:'$G(BGPDT) BGPDT=DT

 Q:BGPDT<BGPDOB ""

 ;---> Age in Years.

 N BGPAGEY,BGPAGEM,BGPD1,BGPD2,BGPM1,BGPM2,BGPY1,BGPY2

 S BGPM1=$E(BGPDOB,4,7),BGPM2=$E(BGPDT,4,7)

 S BGPY1=$E(BGPDOB,1,3),BGPY2=$E(BGPDT,1,3)

 S BGPAGEY=BGPY2-BGPY1 S:BGPM2<BGPM1 BGPAGEY=BGPAGEY-1

 S:BGPAGEY<1 BGPAGEY="<1"

 Q:BGPZ=1 BGPAGEY

 ;---> Age in Months.

 S BGPD1=$E(BGPM1,3,4),BGPM1=$E(BGPM1,1,2)

 S BGPD2=$E(BGPM2,3,4),BGPM2=$E(BGPM2,1,2)

 S BGPAGEM=12*BGPAGEY

 I BGPM2=BGPM1&(BGPD2<BGPD1) S BGPAGEM=BGPAGEM+12

 I BGPM2>BGPM1 S BGPAGEM=BGPAGEM+BGPM2-BGPM1

 I BGPM2<BGPM1 S BGPAGEM=BGPAGEM+BGPM2+(12-BGPM1)

 S:BGPD2<BGPD1 BGPAGEM=BGPAGEM-1

 Q:BGPZ=2 BGPAGEM

 ;---> Age in Days.

 S X1=BGPDT,X2=BGPDOB

 D ^%DTC

Q X

ENCEPH(P,EDATE) ;EP - encephalapathy on PL or V POV

 I '$G(P) Q ""

 NEW X

 S X=$$LASTDX^BGP8UTL1(P,"BGP ENCEPHALOPATHY DXS",$$DOB^AUPNPAT(P),EDATE)

 I X Q 1

 S X=$$PLTAXND^BGP8DU(P,$O(^ATXAX("B","BGP ENCEPHALOPATHY DXS",0)),EDATE)

 I X Q 1

 Q ""

IMMUNO(P,EDATE) ;EP - IMMUN on PL or V POV

 I '$G(P) Q ""

 NEW X

 S X=$$LASTDX^BGP8UTL1(P,"BGP IMMUNODEFICIENCY DXS",$$DOB^AUPNPAT(P),EDATE)

 I X Q 1

 S X=$$PLTAXND^BGP8DU(P,$O(^ATXAX("B","BGP IMMUNODEFICIENCY DXS",0)),EDATE)

 I X Q 1

 Q ""

LYMPHO(P,EDATE) ;EP - IMMUN on PL or V POV

 I '$G(P) Q ""

 NEW X

 S X=$$LASTDX^BGP8UTL1(P,"BGP LYMPHO CANCER DXS",$$DOB^AUPNPAT(P),EDATE)

 I X Q 1

 S X=$$PLTAXND^BGP8DU(P,$O(^ATXAX("B","BGP LYMPHO CANCER DXS",0)),EDATE)

 I X Q 1

 Q ""

SCID(P,EDATE) ;EP - IMMUN on PL or V POV

 I '$G(P) Q ""

 NEW X

 S X=$$LASTDX^BGP8UTL1(P,"BGP SCID DXS",$$DOB^AUPNPAT(P),EDATE)

 I X Q 1

 S X=$$PLTAXND^BGP8DU(P,$O(^ATXAX("B","BGP SCID DXS",0)),EDATE)

 I X Q 1

 Q ""

 ;BGP INTUSSUSCEPTION DXS

INTUSS(P,EDATE) ;EP

 I '$G(P) Q ""

 NEW X

 S X=$$LASTDX^BGP8UTL1(P,"BGP INTUSSUSCEPTION DXS",$$DOB^AUPNPAT(P),EDATE)

 I X Q 1

 S X=$$PLTAXND^BGP8DU(P,$O(^ATXAX("B","BGP INTUSSUSCEPTION DXS",0)),EDATE)

 I X Q 1

 Q ""

HADWARF(P,BDATE,EDATE) ;EP

 NEW BGPMEDS1,C,A,M

 K BGPMEDS1

 D GETMEDS^BGP8UTL2(P,BDATE,EDATE,"BGP PQA WARFARIN MEDS","BGP PQA WARFARIN NDC",,,.BGPMEDS1)

 I '$D(BGPMEDS1) Q ""  ; NO MEDS

 S (A,C)=0 F  S A=$O(BGPMEDS1(A)) Q:A'=+A  D

 .S M=$P(BGPMEDS1(A),U,4)  ;IEN OF V MED

 .Q:'$D(^AUPNVMED(M,0))

 .;GET PRESCRIPTION #

 .S Q=$S($D(^PSRX("APCC",M)):$O(^(M,0)),1:0)

 .I Q,$E($P($G(^PSRX(Q,0)),U,1))="X" Q  ; no POS

 .I $E($$VAL^XBDIQ1(9000010.14,M,1102))="X" Q  ;no POS

 .I $$VAL^XBDIQ1(9000010.14,M,1108)]"" Q  ;NO EHR OUTSIDE

 .I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BGPMEDS1(A) Q

 .I $P(^AUPNVMED(M,0),U,8)=$P(BGPMEDS1(A),U,1) K BGPMEDS1(A) Q  ;d/c'ed on same day as visit so no days suppply

 .I '$P(^AUPNVMED(M,0),U,7) K BGPMEDS1(A) Q  ;no days supply

 .S C=C+1

.Q

Q C

BGP8D36   ;IHS/CMI/LAB - MEASURE IMM LOGIC;

 +1       ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66

 +2       ;

MEN(P,EDATE) ;EP

 +1        NEW BGPC,BGPG,BGPX,BGPMENI,C,ED,BD,V,X,Y,BGPZ,B,BGPIMM,R,G,T

 +2       ;gather up all immunizations, cpts, povs and check for 3 each ten days apart

 +3        KILL BGPMENI

 +4       ;get all immunizations

 +5       ;S C="32^108^114^136^147^148"

 +6        SET C=""

           SET X=0

 +7        SET T=$ORDER(^ATXAX("B","BGP MENINGOCOCCAL CVX CODES",0))

 +8        FOR

               SET X=$ORDER(^ATXAX(T,21,"B",X))

               IF X=""

                   QUIT

               IF C]""

                   SET C=C_U

               SET C=C_X

 +9        DO GETIMMS^BGP8D32(P,EDATE,C,.BGPX)

 +10      ;go through and set into array if 10 days apart

 +11       IF $ORDER(BGPX(0))

               QUIT 1_U_"Meningococcal"

 +12      ;now get cpts

 +13       SET T=$ORDER(^ATXAX("B","BGP CPT MENINGOCOCCAL",0))

 +14       SET ED=9999999-EDATE-1

           SET BD=9999999-$$DOB^AUPNPAT(P)

           SET G=0

 +15       FOR

               SET ED=$ORDER(^AUPNVSIT("AA",P,ED))

               IF ED=""!($PIECE(ED,".")>BD)

                   QUIT

               Begin DoDot:1

 +16               SET V=0

FOR

                       SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))

                       IF V'=+V

                           QUIT

                       Begin DoDot:2

 +17                       IF '$DATA(^AUPNVSIT(V,0))

                               QUIT

 +18                       SET X=0

FOR

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

                               IF X'=+X

                                   QUIT

                               Begin DoDot:3

 +19                               SET Y=$PIECE(^AUPNVCPT(X,0),U)

                                   IF $$ICD^ATXAPI(Y,T,1)

                                       SET BGPMENI(9999999-$PIECE(ED,"."))=""

                               End DoDot:3

 +20                       SET X=0

FOR

                               SET X=$ORDER(^AUPNVTC("AD",V,X))

                               IF X'=+X

                                   QUIT

                               Begin DoDot:3

 +21                               SET Y=$PIECE(^AUPNVTC(X,0),U,7)

                                   IF 'Y

                                       QUIT

                                   IF $$ICD^ATXAPI(Y,T,1)

                                       SET BGPMENI(9999999-$PIECE(ED,"."))=""

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +22       IF $DATA(BGPMENI)

               QUIT 1_U_"Meningococcal"

 +23      ;check for Evidence of desease and Contraindications and if yes, then quit

 +24       SET T=$ORDER(^ATXAX("B","BGP MENINGOCOCCAL CVX CODES",0))

 +25       SET X=""

           SET Y=0

 +26       FOR

               SET Y=$ORDER(^ATXAX(T,21,"B",Y))

               IF Y=""

                   QUIT

               Begin DoDot:1

 +27               SET X=$$ANCONT^BGP8D31(P,Y,EDATE)

                   IF X]""

                       QUIT

               End DoDot:1

               IF X]""

                   QUIT

 +28       IF X]""

               QUIT 4_U_"Contra Meningococcal"

 +29      ;now go to Refusals

 +30       SET B=$$DOB^AUPNPAT(P)

           SET E=EDATE

           SET BGPNMI=""

           SET R=""

 +31      ;F BGPIMM=32,108,114,136,147  D

           SET BGPIMM=0

FOR

               SET BGPIMM=$ORDER(^ATXAX(T,21,"B",BGPIMM))

               IF BGPIMM=""

                   QUIT

               Begin DoDot:1

 +32               SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))

                   IF 'I

                       QUIT

 +33               SET X=0

FOR

                       SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))

                       IF X'=+X

                           QUIT

                       SET Y=0

FOR

                           SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))

                           IF Y'=+Y

                               QUIT

                           SET D=$PIECE(^AUPNPREF(Y,0),U,3)

                           IF D'<B&(D'>E)

                               IF $PIECE(^AUPNPREF(Y,0),U,7)="N"

                                   SET BGPNMI=1

                               SET R=1

               End DoDot:1

 +34       IF BGPNMI

               QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI Meningococcal",1:"Ref Meningococcal")

 +35       FOR BGPIMM=90733,90734,90644

               Begin DoDot:1

 +36               SET I=+$$CODEN^ICPTCOD(BGPIMM)

                   IF 'I

                       QUIT

 +37               SET X=0

FOR

                       SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))

                       IF X'=+X

                           QUIT

                       SET Y=0

FOR

                           SET Y=$ORDER(^AUPNPREF("AA",P,81,I,X,Y))

                           IF Y'=+Y

                               QUIT

                           SET D=$PIECE(^AUPNPREF(Y,0),U,3)

                           IF D'<B&(D'>E)

                               IF $PIECE(^AUPNPREF(Y,0),U,7)="N"

                                   SET BGPNMI=1

                               SET R=1

               End DoDot:1

 +38       IF BGPNMI

               QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI Meningococcal",1:"Ref Meningococcal")

 +39       QUIT ""

 +40      ;

HPV(P,EDATE) ;EP

 +1        NEW BGPC,BGPG,BGPX,BGPHPV,C,X,ED,BD,V,G,R,BGPIMM,Y,Z,B,BGPNMI

 +2       ;gather up all immunizations, cpts, povs and check for 3 each ten days apart

 +3       ;get all immunizations

 +4       ;S C="62^118^137^165"

 +5        SET C=""

           SET X=0

 +6        SET T=$ORDER(^ATXAX("B","BGP HPV CVX CODES",0))

 +7        FOR

               SET X=$ORDER(^ATXAX(T,21,"B",X))

               IF X=""

                   QUIT

               IF C]""

                   SET C=C_U

               SET C=C_X

 +8        DO GETIMMS^BGP8D32(P,EDATE,C,.BGPX)

 +9       ;go through and set into array if 10 days apart

 +10       SET X=0

FOR

               SET X=$ORDER(BGPX(X))

               IF X'=+X

                   QUIT

               SET BGPHPV(X)=""

 +11      ;now get cpts

 +12       SET ED=9999999-EDATE

           SET BD=9999999-$$DOB^AUPNPAT(P)

           SET G=0

 +13       FOR

               SET ED=$ORDER(^AUPNVSIT("AA",P,ED))

               IF ED=""!($PIECE(ED,".")>BD)

                   QUIT

               Begin DoDot:1

 +14               SET V=0

FOR

                       SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))

                       IF V'=+V

                           QUIT

                       Begin DoDot:2

 +15                       IF '$DATA(^AUPNVSIT(V,0))

                               QUIT

 +16                       SET X=0

FOR

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

                               IF X'=+X

                                   QUIT

                               Begin DoDot:3

 +17                               SET Y=$PIECE(^AUPNVCPT(X,0),U)

                                   SET Z=$PIECE($$CPT^ICPTCOD(Y),U,2)

                                   IF Z=90649!(Z=90650)!(Z=90651)

                                       SET BGPHPV(9999999-$PIECE(ED,"."))=""

                               End DoDot:3

 +18                       SET X=0

FOR

                               SET X=$ORDER(^AUPNVTC("AD",V,X))

                               IF X'=+X

                                   QUIT

                               Begin DoDot:3

 +19                               SET Y=$PIECE(^AUPNVTC(X,0),U,7)

                                   IF 'Y

                                       QUIT

                                   SET Z=$PIECE($$CPT^ICPTCOD(Y),U,2)

                                   IF Z=90649!(Z=90650)!(Z=90651)

                                       SET BGPHPV(9999999-$PIECE(ED,"."))=""

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +20      ;

 +21      ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones

 +22       SET X=""

           SET Y=""

           SET C=0

FOR

               SET X=$ORDER(BGPHPV(X))

               IF X'=+X

                   QUIT

               SET C=C+1

               Begin DoDot:1

 +23               IF C=1

                       SET Y=X

                       QUIT

 +24               IF $$FMDIFF^XLFDT(X,Y)<11

                       KILL BGPHPV(X)

                       QUIT

 +25               SET Y=X

               End DoDot:1

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

 +27       SET BGPHPV=0

           SET X=0

FOR

               SET X=$ORDER(BGPHPV(X))

               IF X'=+X

                   QUIT

               SET BGPHPV=BGPHPV+1

 +28       IF BGPHPV>2

               QUIT 1_U_"3 HPV"

 +29      ;didn't have at least 2 so go to check for nmi/evid

           IF BGPHPV<2

               GOTO ED

 +30      ;v18, check for 2 doses, 1 dose prior to 15th bd and one at least 5 months later

 +31      ;15TH BIRTDAY

 +32       SET B=$$DOB^AUPNPAT(P)

 +33       SET BGP15BD=$EXTRACT(B,1,3)+15_$EXTRACT(B,4,7)

 +34       SET D=0

           SET G=0

           SET Q=0

           SET Z=""

FOR

               SET D=$ORDER(BGPHPV(D))

               IF D'=+D!(Q)

                   QUIT

               Begin DoDot:1

 +35      ;AFTER 15TH BD SO DON'T BOTHER

                   IF D>BGP15BD

                       SET Q=1

                       QUIT

 +36      ;get next one and check for 5 months

 +37               SET Y=$ORDER(BGPHPV(D))

 +38      ;5 MONTHS AFTER D

 +39               SET Z=$$M5(D)

 +40      ;not at least 5 months

                   IF Y<Z

                       QUIT

 +41               SET G=1_U_"2 HPV"

 +42               SET Q=1

               End DoDot:1

 +43      ;W !!,P,"  ",BGP15BD,"  ",Z,! ZW BGPHPV W !  ;LORI

 +44       IF G

               QUIT G

ED        ;check for Evidence of desease and Contraindications and if yes, then quit

 +1       ;now go to Refusals

 +2        SET B=$$DOB^AUPNPAT(P)

           SET E=EDATE

           SET BGPNMI=""

           SET R=""

 +3        FOR BGPIMM=62,118,137,165

               Begin DoDot:1

 +4                SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))

                   IF 'I

                       QUIT

 +5                SET X=0

FOR

                       SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))

                       IF X'=+X

                           QUIT

                       SET Y=0

FOR

                           SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))

                           IF Y'=+Y

                               QUIT

                           SET D=$PIECE(^AUPNPREF(Y,0),U,3)

                           IF D'<B&(D'>E)

                               IF $PIECE(^AUPNPREF(Y,0),U,7)="N"

                                   SET BGPNMI=1

                               SET R=1

               End DoDot:1

 +6        IF BGPNMI

               QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" HPV"

 +7        FOR BGPIMM=90649,90650,90651

               Begin DoDot:1

 +8                SET I=+$$CODEN^ICPTCOD(BGPIMM)

                   IF 'I

                       QUIT

 +9                SET X=0

FOR

                       SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))

                       IF X'=+X

                           QUIT

                       SET Y=0

FOR

                           SET Y=$ORDER(^AUPNPREF("AA",P,81,I,X,Y))

                           IF Y'=+Y

                               QUIT

                           SET D=$PIECE(^AUPNPREF(Y,0),U,3)

                           IF D'<B&(D'>E)

                               IF $PIECE(^AUPNPREF(Y,0),U,7)="N"

                                   SET BGPNMI=1

                               SET R=1

               End DoDot:1

 +10       IF BGPNMI

               QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI HPV",1:"Ref HPV")

 +11      ;now check Refusals in imm pkg

 +12      ;F BGPIMM=62,118 S R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

 +13      ;I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" HPV"

 +14       FOR BGPZ=62,118,137,165

               SET X=$$ANCONT^BGP8D31(P,BGPZ,EDATE)

               IF X]""

                   QUIT

 +15       IF X]""

               QUIT 4_U_"Contra HPV"

 +16       QUIT ""

M5(E)     ;

 +1        IF $GET(E)=""

               QUIT ""

 +2        NEW M,Z

 +3       ;month

           SET M=$EXTRACT(E,4,5)

 +4        SET M=+M

 +5        SET A=$SELECT(M=1:6,M=2:7,M=3:8,M=4:9,M=5:10,M=6:11,M=7:12,M=8:1,M=9:2,M=10:3,M=11:4,M=12:5,1:"")

 +6        IF $LENGTH(A)<2

               SET A="0"_A

 +7        IF +M<8

               SET A=$EXTRACT(E,1,3)_A_$EXTRACT(E,6,7)

               QUIT A

 +8        SET A=($EXTRACT(E,1,3)+1)_A_$EXTRACT(E,6,7)

 +9        QUIT A

AGE(P,BGPZ,BGPDT) ;EP

 +1       ;---> Return Patient's Age.

 +2       ;---> Parameters:

 +3       ;     1 - DFN  (req) IEN in PATIENT File.

 +4       ;     2 - BGPZ  (opt) APCLZ=1,2,3  1=years, 2=months, 3=days.

 +5       ;                               2 will be assumed if not passed.

 +6       ;     3 - APCLDT (opt) Date on which Age should be calculated.

 +7       ;

 +8        NEW BGPDOB,X,X1,X2

           IF $GET(BGPZ)=""

               SET BGPZ=2

 +9        IF '$GET(P)

               QUIT ""

 +10       IF '$DATA(^DPT(P,0))

               QUIT ""

 +11       SET BGPDOB=$PIECE(^DPT(P,0),U,3)

 +12       IF 'BGPDOB

               QUIT ""

 +13       IF '$GET(DT)

               SET DT=$$DT^XLFDT

 +14       IF '$GET(BGPDT)

               SET BGPDT=DT

 +15       IF BGPDT<BGPDOB

               QUIT ""

 +16      ;

 +17      ;---> Age in Years.

 +18       NEW BGPAGEY,BGPAGEM,BGPD1,BGPD2,BGPM1,BGPM2,BGPY1,BGPY2

 +19       SET BGPM1=$EXTRACT(BGPDOB,4,7)

           SET BGPM2=$EXTRACT(BGPDT,4,7)

 +20       SET BGPY1=$EXTRACT(BGPDOB,1,3)

           SET BGPY2=$EXTRACT(BGPDT,1,3)

 +21       SET BGPAGEY=BGPY2-BGPY1

           IF BGPM2<BGPM1

               SET BGPAGEY=BGPAGEY-1

 +22       IF BGPAGEY<1

               SET BGPAGEY="<1"

 +23       IF BGPZ=1

               QUIT BGPAGEY

 +24      ;

 +25      ;---> Age in Months.

 +26       SET BGPD1=$EXTRACT(BGPM1,3,4)

           SET BGPM1=$EXTRACT(BGPM1,1,2)

 +27       SET BGPD2=$EXTRACT(BGPM2,3,4)

           SET BGPM2=$EXTRACT(BGPM2,1,2)

 +28       SET BGPAGEM=12*BGPAGEY

 +29       IF BGPM2=BGPM1&(BGPD2<BGPD1)

               SET BGPAGEM=BGPAGEM+12

 +30       IF BGPM2>BGPM1

               SET BGPAGEM=BGPAGEM+BGPM2-BGPM1

 +31       IF BGPM2<BGPM1

               SET BGPAGEM=BGPAGEM+BGPM2+(12-BGPM1)

 +32       IF BGPD2<BGPD1

               SET BGPAGEM=BGPAGEM-1

 +33       IF BGPZ=2

               QUIT BGPAGEM

 +34      ;

 +35      ;---> Age in Days.

 +36       SET X1=BGPDT

           SET X2=BGPDOB

 +37       DO ^%DTC

 +38       QUIT X

 +39      ;

 +40      ;

ENCEPH(P,EDATE) ;EP - encephalapathy on PL or V POV

 +1        IF '$GET(P)

               QUIT ""

 +2        NEW X

 +3        SET X=$$LASTDX^BGP8UTL1(P,"BGP ENCEPHALOPATHY DXS",$$DOB^AUPNPAT(P),EDATE)

 +4        IF X

               QUIT 1

 +5        SET X=$$PLTAXND^BGP8DU(P,$ORDER(^ATXAX("B","BGP ENCEPHALOPATHY DXS",0)),EDATE)

 +6        IF X

               QUIT 1

 +7        QUIT ""

 +8       ;

IMMUNO(P,EDATE) ;EP - IMMUN on PL or V POV

 +1        IF '$GET(P)

               QUIT ""

 +2        NEW X

 +3        SET X=$$LASTDX^BGP8UTL1(P,"BGP IMMUNODEFICIENCY DXS",$$DOB^AUPNPAT(P),EDATE)

 +4        IF X

               QUIT 1

 +5        SET X=$$PLTAXND^BGP8DU(P,$ORDER(^ATXAX("B","BGP IMMUNODEFICIENCY DXS",0)),EDATE)

 +6        IF X

               QUIT 1

 +7        QUIT ""

 +8       ;

LYMPHO(P,EDATE) ;EP - IMMUN on PL or V POV

 +1        IF '$GET(P)

               QUIT ""

 +2        NEW X

 +3        SET X=$$LASTDX^BGP8UTL1(P,"BGP LYMPHO CANCER DXS",$$DOB^AUPNPAT(P),EDATE)

 +4        IF X

               QUIT 1

 +5        SET X=$$PLTAXND^BGP8DU(P,$ORDER(^ATXAX("B","BGP LYMPHO CANCER DXS",0)),EDATE)

 +6        IF X

               QUIT 1

 +7        QUIT ""

 +8       ;

SCID(P,EDATE) ;EP - IMMUN on PL or V POV

 +1        IF '$GET(P)

               QUIT ""

 +2        NEW X

 +3        SET X=$$LASTDX^BGP8UTL1(P,"BGP SCID DXS",$$DOB^AUPNPAT(P),EDATE)

 +4        IF X

               QUIT 1

 +5        SET X=$$PLTAXND^BGP8DU(P,$ORDER(^ATXAX("B","BGP SCID DXS",0)),EDATE)

 +6        IF X

               QUIT 1

 +7        QUIT ""

 +8       ;BGP INTUSSUSCEPTION DXS

INTUSS(P,EDATE) ;EP

 +1        IF '$GET(P)

               QUIT ""

 +2        NEW X

 +3        SET X=$$LASTDX^BGP8UTL1(P,"BGP INTUSSUSCEPTION DXS",$$DOB^AUPNPAT(P),EDATE)

 +4        IF X

               QUIT 1

 +5        SET X=$$PLTAXND^BGP8DU(P,$ORDER(^ATXAX("B","BGP INTUSSUSCEPTION DXS",0)),EDATE)

 +6        IF X

               QUIT 1

 +7        QUIT ""

HADWARF(P,BDATE,EDATE) ;EP

 +1        NEW BGPMEDS1,C,A,M

 +2        KILL BGPMEDS1

 +3        DO GETMEDS^BGP8UTL2(P,BDATE,EDATE,"BGP PQA WARFARIN MEDS","BGP PQA WARFARIN NDC",,,.BGPMEDS1)

 +4       ; NO MEDS

           IF '$DATA(BGPMEDS1)

               QUIT ""

 +5        SET (A,C)=0

FOR

               SET A=$ORDER(BGPMEDS1(A))

               IF A'=+A

                   QUIT

               Begin DoDot:1

 +6       ;IEN OF V MED

                   SET M=$PIECE(BGPMEDS1(A),U,4)

 +7                IF '$DATA(^AUPNVMED(M,0))

                       QUIT

 +8       ;GET PRESCRIPTION #

 +9                SET Q=$SELECT($DATA(^PSRX("APCC",M)):$ORDER(^(M,0)),1:0)

 +10      ; no POS

                   IF Q

                       IF $EXTRACT($PIECE($GET(^PSRX(Q,0)),U,1))="X"

                           QUIT

 +11      ;no POS

                   IF $EXTRACT($$VAL^XBDIQ1(9000010.14,M,1102))="X"

                       QUIT

 +12      ;NO EHR OUTSIDE

                   IF $$VAL^XBDIQ1(9000010.14,M,1108)]""

                       QUIT

 +13               IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"

                       KILL BGPMEDS1(A)

                       QUIT

 +14      ;d/c'ed on same day as visit so no days suppply

                   IF $PIECE(^AUPNVMED(M,0),U,8)=$PIECE(BGPMEDS1(A),U,1)

                       KILL BGPMEDS1(A)

                       QUIT

 +15      ;no days supply

                   IF '$PIECE(^AUPNVMED(M,0),U,7)

                       KILL BGPMEDS1(A)

                       QUIT

 +16               SET C=C+1

 +17               QUIT

               End DoDot:1

 +18       QUIT C

BGP8D36.m