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
