BGP6D36 ; IHS/CMI/LAB - measure C 06 Nov 2009 2:03 PM 28 May 2015 4:23 PM ;
;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
;
MEN(P,EDATE) ;EP
NEW BGPC,BGPG,BGPX,BGPMENI,C,ED,BD,V,X,Y,BGPZ,B,BGPIMM,R,G
;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"
D GETIMMS^BGP6D32(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 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),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90733!(Y=90734) 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 S Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90733!(Y=90734) S BGPMENI(9999999-$P(ED,"."))=""
I $D(BGPMENI) Q 1_U_"Meningococcal"
;check for Evidence of desease and Contraindications and if yes, then quit
F BGPZ=32,108,114,136,147 S X=$$ANCONT^BGP6D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"Contra Meningococcal"
;now go to Refusals
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
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 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")
;now check Refusals in imm pkg
;F BGPIMM=32,108,114,136,147 S R=$$IMMREF^BGP6D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
;I R Q 3_U_"Ref imm pkg 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"
D GETIMMS^BGP6D32(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 4 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"
;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^BGP6D32(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^BGP6D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"Contra HPV"
Q ""
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
;
;
BGP6D36 ; IHS/CMI/LAB - measure C 06 Nov 2009 2:03 PM 28 May 2015 4:23 PM ;
+1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
+2 ;
MEN(P,EDATE) ;EP
+1 NEW BGPC,BGPG,BGPX,BGPMENI,C,ED,BD,V,X,Y,BGPZ,B,BGPIMM,R,G
+2 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
+3 KILL BGPMENI
+4 ;get all immunizations
+5 SET C="32^108^114^136^147"
+6 DO GETIMMS^BGP6D32(P,EDATE,C,.BGPX)
+7 ;go through and set into array if 10 days apart
+8 IF $ORDER(BGPX(0))
QUIT 1_U_"Meningococcal"
+9 ;now get cpts
+10 SET ED=9999999-EDATE-1
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+11 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+12 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+13 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+15 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90733!(Y=90734)
SET BGPMENI(9999999-$PIECE(ED,"."))=""
End DoDot:3
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+17 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90733!(Y=90734)
SET BGPMENI(9999999-$PIECE(ED,"."))=""
End DoDot:3
End DoDot:2
End DoDot:1
+18 IF $DATA(BGPMENI)
QUIT 1_U_"Meningococcal"
+19 ;check for Evidence of desease and Contraindications and if yes, then quit
+20 FOR BGPZ=32,108,114,136,147
SET X=$$ANCONT^BGP6D31(P,BGPZ,EDATE)
IF X]""
QUIT
+21 IF X]""
QUIT 4_U_"Contra Meningococcal"
+22 ;now go to Refusals
+23 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+24 FOR BGPIMM=32,108,114,136,147
Begin DoDot:1
+25 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+26 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
+27 IF BGPNMI
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI Meningococcal",1:"Ref Meningococcal")
+28 FOR BGPIMM=90733,90734
Begin DoDot:1
+29 SET I=+$$CODEN^ICPTCOD(BGPIMM)
IF 'I
QUIT
+30 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
+31 IF BGPNMI
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI Meningococcal",1:"Ref Meningococcal")
+32 ;now check Refusals in imm pkg
+33 ;F BGPIMM=32,108,114,136,147 S R=$$IMMREF^BGP6D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+34 ;I R Q 3_U_"Ref imm pkg Meningococcal"
+35 QUIT ""
+36 ;
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 SET C="62^118^137^165"
+5 DO GETIMMS^BGP6D32(P,EDATE,C,.BGPX)
+6 ;go through and set into array if 10 days apart
+7 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPHPV(X)=""
+8 ;now get cpts
+9 SET ED=9999999-EDATE
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+10 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+11 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+12 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+14 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
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+16 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
+17 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+18 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPHPV(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+19 IF C=1
SET Y=X
QUIT
+20 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPHPV(X)
QUIT
+21 SET Y=X
End DoDot:1
+22 ;now count them and see if there are 4 of them
+23 SET BGPHPV=0
SET X=0
FOR
SET X=$ORDER(BGPHPV(X))
IF X'=+X
QUIT
SET BGPHPV=BGPHPV+1
+24 IF BGPHPV>2
QUIT 1_U_"3 HPV"
+25 ;check for Evidence of desease and Contraindications and if yes, then quit
+26 ;now go to Refusals
+27 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+28 FOR BGPIMM=62,118,137,165
Begin DoDot:1
+29 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+30 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
+31 IF BGPNMI
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" HPV"
+32 FOR BGPIMM=90649,90650,90651
Begin DoDot:1
+33 SET I=+$$CODEN^ICPTCOD(BGPIMM)
IF 'I
QUIT
+34 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
+35 IF BGPNMI
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI HPV",1:"Ref HPV")
+36 ;now check Refusals in imm pkg
+37 ;F BGPIMM=62,118 S R=$$IMMREF^BGP6D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+38 ;I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" HPV"
+39 FOR BGPZ=62,118,137,165
SET X=$$ANCONT^BGP6D31(P,BGPZ,EDATE)
IF X]""
QUIT
+40 IF X]""
QUIT 4_U_"Contra HPV"
+41 QUIT ""
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 ;
