BQIRGHEP ;GDHD/HCD/ALA-Hepatitis Immunizations ; 25 May 2016 12:09 PM
;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17
;
HEPA(P,EDATE) ;EP
NEW BGPC,BGPG,BGPX,BGPHEPA,C,X,ED,BD,G,V,Y,T,I,R,BGPIMM,BGPNMI
K BGPC,BGPG,BGPX,HCT
;gather up all immunizations, cpts, povs and check for 3 each ten days apart
K BGPHEPA
;get all immunizations
S C="31^52^83^84^85^104"
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 BGPHEPA(X)=""
;now get cpts
S ED=9999999-EDATE,BD=9999999-$$DOB^AUPNPAT(P),G=0
S T=$O(^ATXAX("B","BGP HEPATITIS A CPTS",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 $$ICD^BGP6UTL2(Y,T,1) S BGPHEPA(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 $$ICD^BGP6UTL2(Y,T,1) S BGPHEPA(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(BGPHEPA(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPHEPA(X) Q
.S Y=X
;now count them and see if there are 2 of them
S HCT=0,X=0 F S X=$O(BGPHEPA(X)) Q:X'=+X S HCT=HCT+1
I HCT=1 Q "1 dose Hep A"
I HCT>1 Q "YES"
;check for Evidence of disease and Contraindications and if yes, then quit
K BGPG S %=P_"^LAST DX [BGP HEPATITIS A EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "Evidence of Hep A"
I $$PLTAX^BGP6DU(P,"BGP HEPATITIS A EVIDENCE") Q "Evidence of Hep A"
;
F BGPZ=31,52,83,84,85,104 S X=$$ANCONT^BGP6D31(P,BGPZ,EDATE) Q:X]"" ;cmi/maw 12/17/07 missing edate
I X]"" Q "Contra Hep A"
;
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM=31,52,83,84,85,104 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) I $P(^AUPNPREF(Y,0),U,7)="N" S BGPNMI=1 S R=1
I R Q $S(BGPNMI:"NMI",1:"Ref")_" Hep A"
S R=$$CPTREFT^BGP6UTL1(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP HEPATITIS A CPTS",0)))
I R,$P(R,U,3)="N" S BGPNMI=1 Q $S(BGPNMI:"NMI",1:"Ref")_" Hep A"
Q ""
BQIRGHEP ;GDHD/HCD/ALA-Hepatitis Immunizations ; 25 May 2016 12:09 PM
+1 ;;2.5;ICARE MANAGEMENT SYSTEM;**1**;May 24, 2016;Build 17
+2 ;
HEPA(P,EDATE) ;EP
+1 NEW BGPC,BGPG,BGPX,BGPHEPA,C,X,ED,BD,G,V,Y,T,I,R,BGPIMM,BGPNMI
+2 KILL BGPC,BGPG,BGPX,HCT
+3 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
+4 KILL BGPHEPA
+5 ;get all immunizations
+6 SET C="31^52^83^84^85^104"
+7 DO GETIMMS^BGP6D32(P,EDATE,C,.BGPX)
+8 ;go through and set into array if 10 days apart
+9 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPHEPA(X)=""
+10 ;now get cpts
+11 SET ED=9999999-EDATE
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+12 SET T=$ORDER(^ATXAX("B","BGP HEPATITIS A CPTS",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 $$ICD^BGP6UTL2(Y,T,1)
SET BGPHEPA(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 $$ICD^BGP6UTL2(Y,T,1)
SET BGPHEPA(9999999-$PIECE(ED,"."))=""
End DoDot:3
End DoDot:2
End DoDot:1
+20 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+21 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPHEPA(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+22 IF C=1
SET Y=X
QUIT
+23 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPHEPA(X)
QUIT
+24 SET Y=X
End DoDot:1
+25 ;now count them and see if there are 2 of them
+26 SET HCT=0
SET X=0
FOR
SET X=$ORDER(BGPHEPA(X))
IF X'=+X
QUIT
SET HCT=HCT+1
+27 IF HCT=1
QUIT "1 dose Hep A"
+28 IF HCT>1
QUIT "YES"
+29 ;check for Evidence of disease and Contraindications and if yes, then quit
+30 KILL BGPG
SET %=P_"^LAST DX [BGP HEPATITIS A EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+31 IF $DATA(BGPG(1))
QUIT "Evidence of Hep A"
+32 IF $$PLTAX^BGP6DU(P,"BGP HEPATITIS A EVIDENCE")
QUIT "Evidence of Hep A"
+33 ;
+34 ;cmi/maw 12/17/07 missing edate
FOR BGPZ=31,52,83,84,85,104
SET X=$$ANCONT^BGP6D31(P,BGPZ,EDATE)
IF X]""
QUIT
+35 IF X]""
QUIT "Contra Hep A"
+36 ;
+37 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+38 FOR BGPIMM=31,52,83,84,85,104
Begin DoDot:1
+39 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+40 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
+41 IF R
QUIT $SELECT(BGPNMI:"NMI",1:"Ref")_" Hep A"
+42 SET R=$$CPTREFT^BGP6UTL1(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^ATXAX("B","BGP HEPATITIS A CPTS",0)))
+43 IF R
IF $PIECE(R,U,3)="N"
SET BGPNMI=1
QUIT $SELECT(BGPNMI:"NMI",1:"Ref")_" Hep A"
+44 QUIT ""
