BGP8PC4 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
FLU ;EP
S (BGPN1,BGPD1)=0
S BGPDV="",BGPDV1=""
;GET THE PATIENT'S 6 MONTH BIRTHDAY
S A=$$M6BD(DFN)
I A>BGPEDATE S BGPSTOP=1 Q ;turned 6 months after end date of report period
;
S BGPDV=$$ENC4(DFN,BGPBDATE,BGPEDATE) I BGPDV="" S BGPSTOP=1 Q ;no visit
;did they have item #2 92 days prior to bdate through 89 days after bdate
S BGPDV1=$$ENC42(DFN,$$FMADD^XLFDT(BGPBDATE,-92),$$FMADD^XLFDT(BGPBDATE,89)) I BGPDV1="" S BGPSTOP=1 Q
;
;now what about exclusions?
I $$FLUREF(DFN,$$FMADD^XLFDT(BGPBDATE,-153),$$FMADD^XLFDT(BGPBDATE,89)) S BGPSTOP=1 Q ;refused
I $$FLUALG(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,89),BGPEDATE) S BGPSTOP=1 Q ;ALLERGY
;
S BGPD1=1
S X=$$FLUVAC(DFN,$$FMADD^XLFDT(BGPBDATE,-153),$$FMADD^XLFDT(BGPBDATE,89))
I $E(X)=1 S BGPN1=1
S BGPVALUE=""
S BGPVALUE="ENC "_$P(BGPDV,U,2)_"|||" ;hit denominator
I BGPN1 S BGPVALUE=BGPVALUE_"*** "_$P(X,U,2)_" "_$P(X,U,3)
K V,BGPDV
Q
FLUALG(P,BDATE,BDATE89,EDATE) ;
NEW X,Y,Z,A,B,BGPT,BGPZ,TCVX,TCPT,T,I,D,S,G,ID,F
;P is dfn
;a is taxonomy name
I $G(P)="" Q ""
NEW T
S T=$O(^ATXAX("B","BGP IPC EGG ALLERGY DXS",0))
I 'T Q "" ;bad taxonomy??
NEW X,Y,I,D
S (X,Y,I)=0
F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) D
.Q:'$D(^AUPNPROB(X,0))
.I $P(^AUPNPROB(X,0),U,12)="D" Q ;S D=$P($$VALI^XBDIQ1(9000011,X,2.02),".") I D'>BDATE89
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.S Y=$P(^AUPNPROB(X,0),U)
.I $P(^AUPNPROB(X,0),U,13),$P(^AUPNPROB(X,0),U,13)>BDATE89 Q ;if there is a doo and it is after report period skip
.I $P(^AUPNPROB(X,0),U,13)="",$P(^AUPNPROB(X,0),U,8)>BDATE89 Q ;entered after report period, skip
.I $$ICD^BGP8UTL2(Y,T,9) S I=1 Q
.S S=$$VAL^XBDIQ1(9000011,X,80001)
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC EGG ALLERGY",S)) S I=1 Q
.I S=294647003 S I=1 Q
.I S=294648008 S I=1 Q
.I S=294649000 S I=1 Q
.I S=293112000 S I=1 Q
.I S=293113005 S I=1 Q
.I S=390796006 S I=1 Q
.I S=420113004 S I=1 Q
.Q
I I Q 1
S BGPT=$O(^ATXAX("B","BGP FLU IZ CVX CODES",0))
S BGPZ=0,X="" F S BGPZ=$O(^ATXAX(BGPT,21,"B",BGPZ)) Q:BGPZ=""!(X]"") S X=$$FLUIPCON(P,BGPZ,$$DOB^AUPNPAT(P),BDATE89)
I X]"" Q 1
;NMI REFUSALS
S TCVX=$O(^ATXAX("B","BGP IPC INFLUENZA CVX CODES",0))
S TCPT=$O(^ATXAX("B","BGP IPC INFLUENZA CPT CODES",0))
S F=0,G="" F S F=$O(^AUPNPREF("AA",P,F)) Q:F'=+F!(G) D
.S I="" F S I=$O(^AUPNPREF("AA",P,F,I)) Q:I=""!(G) D
..;check all file vs item combos
..I F=9002318.4,I'=315640000 Q ;IF IT'S SNOMED, MUST BE THAT ONE
..I F=9999999.14 S C=$P($G(^AUTTIMM(I,0)),U,3) Q:'$D(^ATXAX(TCVX,21,"B",C)) ;immunization but not a flu one
..I F=81 I '$$ICD^BGP8UTL2(I,TCPT,1) Q ;cpt but not a flu cpt
..S ID=0 F S ID=$O(^AUPNPREF("AA",P,F,I,ID)) Q:ID=""!(G) D
...S D=9999999-ID
...Q:D<BDATE
...Q:D>BDATE89
...S X=0 F S X=$O(^AUPNPREF("AA",P,F,I,ID,X)) Q:X'=+X!(G) D
....;get REASON AND IT MUST BE NMI
....S R=$$VALI^XBDIQ1(9000022,X,.07) ; REASON NOT DONE
....I R="N" S G=1 Q
I G Q G
;NOW VPOV FOR ALLERY TO EGGS DX OR SNOMED
K BGPT
S Y="BGPT("
S X=P_"^FIRST DX [BGP IPC EGG ALLERGY;DURING "_$$DOB^AUPNPAT(P)_"-"_BDATE89 S E=$$START1^APCLDF(X,Y)
I $D(BGPT(1)) Q 1
;NOW SNOMED USING ASNC
S T="PXRM BGP IPC EGG ALLERGY"
S G=""
S S=0 F S S=$O(^XTMP("BGPSNOMEDSUBSET",$J,T,S)) Q:S=""!(G) D
.Q:'$D(^AUPNVPOV("ASNC",P,S))
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
..S Y=9999999-D
..Q:Y<BDATE
..Q:Y>BDATE89
..S G=1
I G Q 1
Q ""
;
FLUREF(P,BDATE,EDATE) ;
NEW A,B,C,X,Y,Z,F,D,I,ID,G,C,TCVX,TCPT,R,BGPT,BGPZ
S BGPT=$O(^ATXAX("B","BGP IPC INFLUENZA CVX CODES",0))
S BGPZ=0,X="" F S BGPZ=$O(^ATXAX(BGPT,21,"B",BGPZ)) Q:BGPZ=""!(X]"") S X=$$FLUPREF(P,BGPZ,BDATE,EDATE)
I X]"" Q 1
;CHECK REFUSAL FILE FIRST FOR FLU CVX OR FLU CPT AND MEDICAL REASON NOT DONE SNOMED OR PATIENT REASON NOT DONE SNOMED OR SYSTEM REASON NOT DONE SNOMED
;ITEM 1-2, 1-3, 1-4
S TCVX=$O(^ATXAX("B","BGP IPC INFLUENZA CVX CODES",0))
S TCPT=$O(^ATXAX("B","BGP IPC INFLUENZA CPT CODES",0))
S F=0,G="" F S F=$O(^AUPNPREF("AA",P,F)) Q:F'=+F!(G) D
.S I="" F S I=$O(^AUPNPREF("AA",P,F,I)) Q:I=""!(G) D
..;check all file vs item combos
..I F=9002318.4,I'=315640000 Q ;IF IT'S SNOMED, MUST BE THAT ONE
..I F=9999999.14 S C=$P($G(^AUTTIMM(I,0)),U,3) Q:'$D(^ATXAX(TCVX,21,"B",C)) ;immunization but not a flu one
..I F=81 I '$$ICD^BGP8UTL2(I,TCPT,1) Q ;cpt but not a flu cpt
..S ID=0 F S ID=$O(^AUPNPREF("AA",P,F,I,ID)) Q:ID=""!(G) D
...S D=9999999-ID
...Q:D<BDATE
...Q:D>EDATE
...S X=0 F S X=$O(^AUPNPREF("AA",P,F,I,ID,X)) Q:X'=+X!(G) D
....;get snomed reason not done and it must be in one of the subsets
....S R=$$VALI^XBDIQ1(9000022,X,1.01) ;SNOMED REASON NOT DONE
....I R]"",R="443390004" S G=1 Q
....I R]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC NO IZ MED",R)) S G=1 Q
....I R]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC NO IZ PAT",R)) S G=1 Q
....I R]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC NO IZ SYS",R)) S G=1 Q
I G Q G
;IS 315640000 ON THE PROBLEM LIST WITH DOO AND/OR DATE ADDED FROM BDATE TO EDATE
S X=0,G=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G=1) D
.Q:'$D(^AUPNPROB(X,0))
.I $P(^AUPNPROB(X,0),U,12)="D" Q
.S S=$$VAL^XBDIQ1(9000011,X,80001)
.Q:S'=315640000
.S D=$P(^AUPNPROB(X,0),U,13)
.I 'D S D=$P(^AUPNPROB(X,0),U,8)
.Q:D<BDATE
.Q:D>EDATE
.S G=1
.Q
I G Q G
;what about V POVs
S S=315640000
S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
.S Y=9999999-D
.Q:Y<BDATE
.Q:Y>EDATE
.S G=1
I G Q G
Q ""
M6BD(P) ;
NEW B,M,D,Y
S B=$$DOB^AUPNPAT(P) ;DOB
S M=+$E(B,4,5)
S D=$E(B,6,7)
S Y=$E(B,1,3)
S M=$S(M<7:M+6,1:M-6) S:$L(M)=1 M="0"_M
S Y=$S(M<7:Y+1,1:Y)
Q Y_M_D
ENC4(P,BDATE,EDATE) ;EP - have encounter per CMS122v6
NEW X,Y,Z,G,BGPV,D,A,B
;Let's check all Visits, looping through once
S G="" ;return variable
;get all visits in date range in BGPV
D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
;now loop through and check Face to Face and .17 in visit and check v cpts attached to the visit
S X=0 F S X=$O(BGPV(X)) Q:X'=+X!(G) S V=$P(BGPV(X),U,5) D
.Q:'$P(^AUPNVSIT(V,0),U,9) ;no dependent entries
.Q:$P(^AUPNVSIT(V,0),U,11) ;deleted
.S D=$$VD^APCLV(V)
.S Y=$$FTOF^BGP8PC2(V) I Y]"" S G=1_U_$$DATE^BGP8UTL(D)_" FTOF: "_Y Q ;ITEM 18
.S Y=$$PROVINT(V) I Y]"" S G=1_U_$$DATE^BGP8UTL(D)_" PAT/PROV INT: "_Y Q ;ITEM 5
.;is .17 a cpt we want?
.S Y=$$VALI^XBDIQ1(9000010,V,.17)
.I Y,$$OFFCPT4(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2) Q
.;now check all V CPTs
.S Z=0 F S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z!(G) D
..S Y=$P($G(^AUPNVCPT(Z,0)),U,1)
..I Y,$$OFFCPT4(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2) Q
Q G
ENC42(P,BDATE,EDATE) ;EP - have encounter per CMS147
NEW X,Y,Z,G,BGPV,D,A,B
;Let's check all Visits, looping through once
S G="" ;return variable
;get all visits in date range in BGPV
D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
;now loop through and check Face to Face and .17 in visit and check v cpts attached to the visit
S X=0 F S X=$O(BGPV(X)) Q:X'=+X!(G) S V=$P(BGPV(X),U,5) D
.Q:'$P(^AUPNVSIT(V,0),U,9) ;no dependent entries
.Q:$P(^AUPNVSIT(V,0),U,11) ;deleted
.S D=$$VD^APCLV(V)
.S Y=$$VALI^XBDIQ1(9000010,V,.17)
.I Y,$$FLUCPT(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2) Q
.;now check all V CPTs
.S Z=0 F S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z!(G) D
..S Y=$P($G(^AUPNVCPT(Z,0)),U,1)
..I Y,$$FLUCPT(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2) Q
..;CHECK VISIT 26 NODE FOR SNOMED
.S A=0 F S A=$O(^AUPNVSIT(V,26,"B",A)) Q:A=""!(G]"") D
..I $D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC FLU ENCOUNTER",A)) S G=1_U_$$DATE^BGP8UTL(D)_" SNOMED: "_A Q
.;CHECK VISIT 28 NODE FOR SNOMED
.S A=0 F S A=$O(^AUPNVSIT(V,28,"B",A)) Q:A=""!(G]"") D
..I $D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC FLU ENCOUNTER",A)) S G=1_U_$$DATE^BGP8UTL(D)_" SNOMED: "_A Q
.;CHECK POV'S FOR SNOMED
.S Z=0 F S Z=$O(^AUPNVPOV("AD",V,Z)) Q:Z'=+Z!(G]"") D
..S A=$P($G(^AUPNVPOV(Z,11)),U,1)
..I A]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC FLU ENCOUNTER",A)) S G=1_U_$$DATE^BGP8UTL(D)_" SNOMED: "_A
Q G
PROVINT(V) ;EP
NEW A,B,C
S A=0,B=""
F S A=$O(^AUPNVSIT(V,28,"B",A)) Q:A=""!(B]"") D
.I $D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC PAT PROV INT",A)) S B=A
Q B
OFFCPT4(C) ;EP
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC OFFICE VISIT CPTS",0)),1) Q 1 ;ITEM 1
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC OUTPT CONSULT CPTS",0)),1) Q 1 ;ITEM 2
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC LT RES FACILITY CPTS",0)),1) Q 1 ;ITEM 3
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC HOMEHEALTH VISIT CPTS",0)),1) Q 1 ;ITEM 4
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE IOV 0-17 CPTS",0)),1) Q 1 ;ITEM 6
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE IOV >=18 CPTS",0)),1) Q 1 ;ITEM 7
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE IND COUN CPTS",0)),1) Q 1 ;ITEM 8
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE GRP COUN CPTS",0)),1) Q 1 ;ITEM 9
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE OTHER CPTS",0)),1) Q 1 ;ITEM 10
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC DSCH SRV NURS FAC CPTS",0)),1) Q 1 ;ITEM 11
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC NURS FAC VISIT CPTS",0)),1) Q 1 ;ITEM 12
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC ANNUAL WELLNESS CPTS",0)),1) Q 1 ;ITEM 13
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PERI DIALYSIS CPTS",0)),1) Q 1 ;ITEM 14
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC HEMO DIALYSIS CPTS",0)),1) Q 1 ;ITEM 15
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE EOV 0-17 CPTS",0)),1) Q 1 ;ITEM 16
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE EOV >=18 CPTS",0)),1) Q 1 ;ITEM 17
Q ""
FLUCPT(C) ;EP
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC FLU ENCOUNTER CPTS",0)),1) Q 1
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PERI DIALYSIS CPTS",0)),1) Q 1
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC HEMO DIALYSIS CPTS",0)),1) Q 1
Q ""
FLUIPCON(P,C,BD,ED) ;EP
NEW X,G,Y,R,D
S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.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
.I $P(^BICONT(R,0),U,1)="Egg Allergy" S G=D_U_"Contra: Egg Allergy"
.I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Contra Anaphylaxis"
Q G
FLUPREF(P,C,BD,ED) ;EP
NEW X,G,Y,R,D,A
S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.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
.I $P(^BICONT(R,0),U,1)="Patient Refusal" S G=D_U_"Patient Refusal 315640000" Q
.I $P(^BICONT(R,0),U,1)="Parent Refusal" S G=D_U_"Parent Refusal 315640000" Q
.S A="" F S A=$O(^BIPC(X,1,"B",A)) Q:A=""!(G) D
..I A=315640000 S G=D_U_"Imm Pkg Refusal 315640000" Q
..I A]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC NO IZ MED",A)) S G=D_U_"Imm Pkg SNOMED "_A Q
..I A]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC NO IZ PAT",A)) S G=D_U_"Imm Pkg SNOMED "_A Q
..I A]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC NO IZ SYS",A)) S G=D_U_"Imm Pkg SNOMED "_A Q
Q G
FLUVAC(P,BDATE,EDATE) ;
NEW BGPG,BGPLFLU,X,E,%,I,T,J,V,G,D,R,CVX,BGPT,TCVX,TCPT
S TCVX=$O(^ATXAX("B","BGP IPC INFLUENZA CVX CODES",0))
S TCPT=$O(^ATXAX("B","BGP IPC INFLUENZA CPT CODES",0))
K BGPG
S BGPLFLU=""
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.S I=$P($G(^AUPNVIMM(X,0)),U,1)
.I 'I Q
.S CVX=$P($G(^AUTTIMM(I,0)),U,3)
.Q:CVX=""
.I '$D(^ATXAX(TCVX,21,"B",CVX)) Q ;NOT IN TAXONOMY
.S D=$$VD^APCLV($P(^AUPNVIMM(X,0),U,3))
.Q:D<BDATE
.Q:D>EDATE
.S BGPLFLU=1_U_$$DATE^BGP8UTL(D)_U_"Imm "_CVX
I BGPLFLU Q BGPLFLU
;CPT
I TCPT D
.S X=$$CPT^BGP8DU(P,BDATE,EDATE,TCPT,5) I X]"" Q
.S X=$$TRAN^BGP8DU(P,BDATE,EDATE,TCPT,5)
I X]"" Q 1_U_$$DATE^BGP8UTL($P(X,U,1))_U_"CPT: "_$P(X,U,2)
;NOW CHECK PROBLEM LIST AND V POV FOR DURING BDATE AND EDATE
S X=0,G=0,I="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G=1) D
.S I=""
.Q:'$D(^AUPNPROB(X,0))
.I $P(^AUPNPROB(X,0),U,12)="D" Q
.S S=$$VAL^XBDIQ1(9000011,X,80001)
.I S=185900003 S I=1
.I S=185901004 S I=1
.I S=185902006 S I=1
.I S=416928007 S I=1
.Q:'I
.S D=$P(^AUPNPROB(X,0),U,13)
.I 'D S D=$P(^AUPNPROB(X,0),U,8)
.Q:D<BDATE
.Q:D>EDATE
.S G=1_U_$$DATE^BGP8UTL(D)_U_"PL: "_S
.Q
I G Q G
;what about V POVs
S G=""
F S=185900003,185901004,185902006,416928007 D Q:G
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
..S Y=9999999-D
..Q:Y<BDATE
..Q:Y>EDATE
..S G=1_U_$$DATE^BGP8UTL(Y)_U_"POV: "_S
I G Q G
Q ""
BGP8PC4 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
FLU ;EP
+1 SET (BGPN1,BGPD1)=0
+2 SET BGPDV=""
SET BGPDV1=""
+3 ;GET THE PATIENT'S 6 MONTH BIRTHDAY
+4 SET A=$$M6BD(DFN)
+5 ;turned 6 months after end date of report period
IF A>BGPEDATE
SET BGPSTOP=1
QUIT
+6 ;
+7 ;no visit
SET BGPDV=$$ENC4(DFN,BGPBDATE,BGPEDATE)
IF BGPDV=""
SET BGPSTOP=1
QUIT
+8 ;did they have item #2 92 days prior to bdate through 89 days after bdate
+9 SET BGPDV1=$$ENC42(DFN,$$FMADD^XLFDT(BGPBDATE,-92),$$FMADD^XLFDT(BGPBDATE,89))
IF BGPDV1=""
SET BGPSTOP=1
QUIT
+10 ;
+11 ;now what about exclusions?
+12 ;refused
IF $$FLUREF(DFN,$$FMADD^XLFDT(BGPBDATE,-153),$$FMADD^XLFDT(BGPBDATE,89))
SET BGPSTOP=1
QUIT
+13 ;ALLERGY
IF $$FLUALG(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,89),BGPEDATE)
SET BGPSTOP=1
QUIT
+14 ;
+15 SET BGPD1=1
+16 SET X=$$FLUVAC(DFN,$$FMADD^XLFDT(BGPBDATE,-153),$$FMADD^XLFDT(BGPBDATE,89))
+17 IF $EXTRACT(X)=1
SET BGPN1=1
+18 SET BGPVALUE=""
+19 ;hit denominator
SET BGPVALUE="ENC "_$PIECE(BGPDV,U,2)_"|||"
+20 IF BGPN1
SET BGPVALUE=BGPVALUE_"*** "_$PIECE(X,U,2)_" "_$PIECE(X,U,3)
+21 KILL V,BGPDV
+22 QUIT
FLUALG(P,BDATE,BDATE89,EDATE) ;
+1 NEW X,Y,Z,A,B,BGPT,BGPZ,TCVX,TCPT,T,I,D,S,G,ID,F
+2 ;P is dfn
+3 ;a is taxonomy name
+4 IF $GET(P)=""
QUIT ""
+5 NEW T
+6 SET T=$ORDER(^ATXAX("B","BGP IPC EGG ALLERGY DXS",0))
+7 ;bad taxonomy??
IF 'T
QUIT ""
+8 NEW X,Y,I,D
+9 SET (X,Y,I)=0
+10 FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+11 IF '$DATA(^AUPNPROB(X,0))
QUIT
+12 ;S D=$P($$VALI^XBDIQ1(9000011,X,2.02),".") I D'>BDATE89
IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+13 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+14 SET Y=$PIECE(^AUPNPROB(X,0),U)
+15 ;if there is a doo and it is after report period skip
IF $PIECE(^AUPNPROB(X,0),U,13)
IF $PIECE(^AUPNPROB(X,0),U,13)>BDATE89
QUIT
+16 ;entered after report period, skip
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF $PIECE(^AUPNPROB(X,0),U,8)>BDATE89
QUIT
+17 IF $$ICD^BGP8UTL2(Y,T,9)
SET I=1
QUIT
+18 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+19 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC EGG ALLERGY",S))
SET I=1
QUIT
+20 IF S=294647003
SET I=1
QUIT
+21 IF S=294648008
SET I=1
QUIT
+22 IF S=294649000
SET I=1
QUIT
+23 IF S=293112000
SET I=1
QUIT
+24 IF S=293113005
SET I=1
QUIT
+25 IF S=390796006
SET I=1
QUIT
+26 IF S=420113004
SET I=1
QUIT
+27 QUIT
End DoDot:1
+28 IF I
QUIT 1
+29 SET BGPT=$ORDER(^ATXAX("B","BGP FLU IZ CVX CODES",0))
+30 SET BGPZ=0
SET X=""
FOR
SET BGPZ=$ORDER(^ATXAX(BGPT,21,"B",BGPZ))
IF BGPZ=""!(X]"")
QUIT
SET X=$$FLUIPCON(P,BGPZ,$$DOB^AUPNPAT(P),BDATE89)
+31 IF X]""
QUIT 1
+32 ;NMI REFUSALS
+33 SET TCVX=$ORDER(^ATXAX("B","BGP IPC INFLUENZA CVX CODES",0))
+34 SET TCPT=$ORDER(^ATXAX("B","BGP IPC INFLUENZA CPT CODES",0))
+35 SET F=0
SET G=""
FOR
SET F=$ORDER(^AUPNPREF("AA",P,F))
IF F'=+F!(G)
QUIT
Begin DoDot:1
+36 SET I=""
FOR
SET I=$ORDER(^AUPNPREF("AA",P,F,I))
IF I=""!(G)
QUIT
Begin DoDot:2
+37 ;check all file vs item combos
+38 ;IF IT'S SNOMED, MUST BE THAT ONE
IF F=9002318.4
IF I'=315640000
QUIT
+39 ;immunization but not a flu one
IF F=9999999.14
SET C=$PIECE($GET(^AUTTIMM(I,0)),U,3)
IF '$DATA(^ATXAX(TCVX,21,"B",C))
QUIT
+40 ;cpt but not a flu cpt
IF F=81
IF '$$ICD^BGP8UTL2(I,TCPT,1)
QUIT
+41 SET ID=0
FOR
SET ID=$ORDER(^AUPNPREF("AA",P,F,I,ID))
IF ID=""!(G)
QUIT
Begin DoDot:3
+42 SET D=9999999-ID
+43 IF D<BDATE
QUIT
+44 IF D>BDATE89
QUIT
+45 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,ID,X))
IF X'=+X!(G)
QUIT
Begin DoDot:4
+46 ;get REASON AND IT MUST BE NMI
+47 ; REASON NOT DONE
SET R=$$VALI^XBDIQ1(9000022,X,.07)
+48 IF R="N"
SET G=1
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+49 IF G
QUIT G
+50 ;NOW VPOV FOR ALLERY TO EGGS DX OR SNOMED
+51 KILL BGPT
+52 SET Y="BGPT("
+53 SET X=P_"^FIRST DX [BGP IPC EGG ALLERGY;DURING "_$$DOB^AUPNPAT(P)_"-"_BDATE89
SET E=$$START1^APCLDF(X,Y)
+54 IF $DATA(BGPT(1))
QUIT 1
+55 ;NOW SNOMED USING ASNC
+56 SET T="PXRM BGP IPC EGG ALLERGY"
+57 SET G=""
+58 SET S=0
FOR
SET S=$ORDER(^XTMP("BGPSNOMEDSUBSET",$JOB,T,S))
IF S=""!(G)
QUIT
Begin DoDot:1
+59 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+60 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+61 SET Y=9999999-D
+62 IF Y<BDATE
QUIT
+63 IF Y>BDATE89
QUIT
+64 SET G=1
End DoDot:2
End DoDot:1
+65 IF G
QUIT 1
+66 QUIT ""
+67 ;
FLUREF(P,BDATE,EDATE) ;
+1 NEW A,B,C,X,Y,Z,F,D,I,ID,G,C,TCVX,TCPT,R,BGPT,BGPZ
+2 SET BGPT=$ORDER(^ATXAX("B","BGP IPC INFLUENZA CVX CODES",0))
+3 SET BGPZ=0
SET X=""
FOR
SET BGPZ=$ORDER(^ATXAX(BGPT,21,"B",BGPZ))
IF BGPZ=""!(X]"")
QUIT
SET X=$$FLUPREF(P,BGPZ,BDATE,EDATE)
+4 IF X]""
QUIT 1
+5 ;CHECK REFUSAL FILE FIRST FOR FLU CVX OR FLU CPT AND MEDICAL REASON NOT DONE SNOMED OR PATIENT REASON NOT DONE SNOMED OR SYSTEM REASON NOT DONE SNOMED
+6 ;ITEM 1-2, 1-3, 1-4
+7 SET TCVX=$ORDER(^ATXAX("B","BGP IPC INFLUENZA CVX CODES",0))
+8 SET TCPT=$ORDER(^ATXAX("B","BGP IPC INFLUENZA CPT CODES",0))
+9 SET F=0
SET G=""
FOR
SET F=$ORDER(^AUPNPREF("AA",P,F))
IF F'=+F!(G)
QUIT
Begin DoDot:1
+10 SET I=""
FOR
SET I=$ORDER(^AUPNPREF("AA",P,F,I))
IF I=""!(G)
QUIT
Begin DoDot:2
+11 ;check all file vs item combos
+12 ;IF IT'S SNOMED, MUST BE THAT ONE
IF F=9002318.4
IF I'=315640000
QUIT
+13 ;immunization but not a flu one
IF F=9999999.14
SET C=$PIECE($GET(^AUTTIMM(I,0)),U,3)
IF '$DATA(^ATXAX(TCVX,21,"B",C))
QUIT
+14 ;cpt but not a flu cpt
IF F=81
IF '$$ICD^BGP8UTL2(I,TCPT,1)
QUIT
+15 SET ID=0
FOR
SET ID=$ORDER(^AUPNPREF("AA",P,F,I,ID))
IF ID=""!(G)
QUIT
Begin DoDot:3
+16 SET D=9999999-ID
+17 IF D<BDATE
QUIT
+18 IF D>EDATE
QUIT
+19 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,ID,X))
IF X'=+X!(G)
QUIT
Begin DoDot:4
+20 ;get snomed reason not done and it must be in one of the subsets
+21 ;SNOMED REASON NOT DONE
SET R=$$VALI^XBDIQ1(9000022,X,1.01)
+22 IF R]""
IF R="443390004"
SET G=1
QUIT
+23 IF R]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC NO IZ MED",R))
SET G=1
QUIT
+24 IF R]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC NO IZ PAT",R))
SET G=1
QUIT
+25 IF R]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC NO IZ SYS",R))
SET G=1
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+26 IF G
QUIT G
+27 ;IS 315640000 ON THE PROBLEM LIST WITH DOO AND/OR DATE ADDED FROM BDATE TO EDATE
+28 SET X=0
SET G=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G=1)
QUIT
Begin DoDot:1
+29 IF '$DATA(^AUPNPROB(X,0))
QUIT
+30 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+31 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+32 IF S'=315640000
QUIT
+33 SET D=$PIECE(^AUPNPROB(X,0),U,13)
+34 IF 'D
SET D=$PIECE(^AUPNPROB(X,0),U,8)
+35 IF D<BDATE
QUIT
+36 IF D>EDATE
QUIT
+37 SET G=1
+38 QUIT
End DoDot:1
+39 IF G
QUIT G
+40 ;what about V POVs
+41 SET S=315640000
+42 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:1
+43 SET Y=9999999-D
+44 IF Y<BDATE
QUIT
+45 IF Y>EDATE
QUIT
+46 SET G=1
End DoDot:1
+47 IF G
QUIT G
+48 QUIT ""
M6BD(P) ;
+1 NEW B,M,D,Y
+2 ;DOB
SET B=$$DOB^AUPNPAT(P)
+3 SET M=+$EXTRACT(B,4,5)
+4 SET D=$EXTRACT(B,6,7)
+5 SET Y=$EXTRACT(B,1,3)
+6 SET M=$SELECT(M<7:M+6,1:M-6)
IF $LENGTH(M)=1
SET M="0"_M
+7 SET Y=$SELECT(M<7:Y+1,1:Y)
+8 QUIT Y_M_D
ENC4(P,BDATE,EDATE) ;EP - have encounter per CMS122v6
+1 NEW X,Y,Z,G,BGPV,D,A,B
+2 ;Let's check all Visits, looping through once
+3 ;return variable
SET G=""
+4 ;get all visits in date range in BGPV
+5 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
+6 ;now loop through and check Face to Face and .17 in visit and check v cpts attached to the visit
+7 SET X=0
FOR
SET X=$ORDER(BGPV(X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(BGPV(X),U,5)
Begin DoDot:1
+8 ;no dependent entries
IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+9 ;deleted
IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+10 SET D=$$VD^APCLV(V)
+11 ;ITEM 18
SET Y=$$FTOF^BGP8PC2(V)
IF Y]""
SET G=1_U_$$DATE^BGP8UTL(D)_" FTOF: "_Y
QUIT
+12 ;ITEM 5
SET Y=$$PROVINT(V)
IF Y]""
SET G=1_U_$$DATE^BGP8UTL(D)_" PAT/PROV INT: "_Y
QUIT
+13 ;is .17 a cpt we want?
+14 SET Y=$$VALI^XBDIQ1(9000010,V,.17)
+15 IF Y
IF $$OFFCPT4(Y)
SET G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$PIECE($$CPT^ICPTCOD(Y),U,2)
QUIT
+16 ;now check all V CPTs
+17 SET Z=0
FOR
SET Z=$ORDER(^AUPNVCPT("AD",V,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:2
+18 SET Y=$PIECE($GET(^AUPNVCPT(Z,0)),U,1)
+19 IF Y
IF $$OFFCPT4(Y)
SET G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$PIECE($$CPT^ICPTCOD(Y),U,2)
QUIT
End DoDot:2
End DoDot:1
+20 QUIT G
ENC42(P,BDATE,EDATE) ;EP - have encounter per CMS147
+1 NEW X,Y,Z,G,BGPV,D,A,B
+2 ;Let's check all Visits, looping through once
+3 ;return variable
SET G=""
+4 ;get all visits in date range in BGPV
+5 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
+6 ;now loop through and check Face to Face and .17 in visit and check v cpts attached to the visit
+7 SET X=0
FOR
SET X=$ORDER(BGPV(X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(BGPV(X),U,5)
Begin DoDot:1
+8 ;no dependent entries
IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+9 ;deleted
IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+10 SET D=$$VD^APCLV(V)
+11 SET Y=$$VALI^XBDIQ1(9000010,V,.17)
+12 IF Y
IF $$FLUCPT(Y)
SET G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$PIECE($$CPT^ICPTCOD(Y),U,2)
QUIT
+13 ;now check all V CPTs
+14 SET Z=0
FOR
SET Z=$ORDER(^AUPNVCPT("AD",V,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:2
+15 SET Y=$PIECE($GET(^AUPNVCPT(Z,0)),U,1)
+16 IF Y
IF $$FLUCPT(Y)
SET G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$PIECE($$CPT^ICPTCOD(Y),U,2)
QUIT
+17 ;CHECK VISIT 26 NODE FOR SNOMED
End DoDot:2
+18 SET A=0
FOR
SET A=$ORDER(^AUPNVSIT(V,26,"B",A))
IF A=""!(G]"")
QUIT
Begin DoDot:2
+19 IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC FLU ENCOUNTER",A))
SET G=1_U_$$DATE^BGP8UTL(D)_" SNOMED: "_A
QUIT
End DoDot:2
+20 ;CHECK VISIT 28 NODE FOR SNOMED
+21 SET A=0
FOR
SET A=$ORDER(^AUPNVSIT(V,28,"B",A))
IF A=""!(G]"")
QUIT
Begin DoDot:2
+22 IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC FLU ENCOUNTER",A))
SET G=1_U_$$DATE^BGP8UTL(D)_" SNOMED: "_A
QUIT
End DoDot:2
+23 ;CHECK POV'S FOR SNOMED
+24 SET Z=0
FOR
SET Z=$ORDER(^AUPNVPOV("AD",V,Z))
IF Z'=+Z!(G]"")
QUIT
Begin DoDot:2
+25 SET A=$PIECE($GET(^AUPNVPOV(Z,11)),U,1)
+26 IF A]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC FLU ENCOUNTER",A))
SET G=1_U_$$DATE^BGP8UTL(D)_" SNOMED: "_A
End DoDot:2
End DoDot:1
+27 QUIT G
PROVINT(V) ;EP
+1 NEW A,B,C
+2 SET A=0
SET B=""
+3 FOR
SET A=$ORDER(^AUPNVSIT(V,28,"B",A))
IF A=""!(B]"")
QUIT
Begin DoDot:1
+4 IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC PAT PROV INT",A))
SET B=A
End DoDot:1
+5 QUIT B
OFFCPT4(C) ;EP
+1 ;ITEM 1
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC OFFICE VISIT CPTS",0)),1)
QUIT 1
+2 ;ITEM 2
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC OUTPT CONSULT CPTS",0)),1)
QUIT 1
+3 ;ITEM 3
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC LT RES FACILITY CPTS",0)),1)
QUIT 1
+4 ;ITEM 4
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC HOMEHEALTH VISIT CPTS",0)),1)
QUIT 1
+5 ;ITEM 6
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PREVCARE IOV 0-17 CPTS",0)),1)
QUIT 1
+6 ;ITEM 7
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PREVCARE IOV >=18 CPTS",0)),1)
QUIT 1
+7 ;ITEM 8
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PREVCARE IND COUN CPTS",0)),1)
QUIT 1
+8 ;ITEM 9
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PREVCARE GRP COUN CPTS",0)),1)
QUIT 1
+9 ;ITEM 10
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PREVCARE OTHER CPTS",0)),1)
QUIT 1
+10 ;ITEM 11
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC DSCH SRV NURS FAC CPTS",0)),1)
QUIT 1
+11 ;ITEM 12
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC NURS FAC VISIT CPTS",0)),1)
QUIT 1
+12 ;ITEM 13
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC ANNUAL WELLNESS CPTS",0)),1)
QUIT 1
+13 ;ITEM 14
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PERI DIALYSIS CPTS",0)),1)
QUIT 1
+14 ;ITEM 15
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC HEMO DIALYSIS CPTS",0)),1)
QUIT 1
+15 ;ITEM 16
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PREVCARE EOV 0-17 CPTS",0)),1)
QUIT 1
+16 ;ITEM 17
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PREVCARE EOV >=18 CPTS",0)),1)
QUIT 1
+17 QUIT ""
FLUCPT(C) ;EP
+1 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC FLU ENCOUNTER CPTS",0)),1)
QUIT 1
+2 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PERI DIALYSIS CPTS",0)),1)
QUIT 1
+3 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC HEMO DIALYSIS CPTS",0)),1)
QUIT 1
+4 QUIT ""
FLUIPCON(P,C,BD,ED) ;EP
+1 NEW X,G,Y,R,D
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 IF $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+9 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+10 IF $PIECE(^BICONT(R,0),U,1)="Egg Allergy"
SET G=D_U_"Contra: Egg Allergy"
+11 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Contra Anaphylaxis"
End DoDot:1
+12 QUIT G
FLUPREF(P,C,BD,ED) ;EP
+1 NEW X,G,Y,R,D,A
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 IF $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+9 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+10 IF $PIECE(^BICONT(R,0),U,1)="Patient Refusal"
SET G=D_U_"Patient Refusal 315640000"
QUIT
+11 IF $PIECE(^BICONT(R,0),U,1)="Parent Refusal"
SET G=D_U_"Parent Refusal 315640000"
QUIT
+12 SET A=""
FOR
SET A=$ORDER(^BIPC(X,1,"B",A))
IF A=""!(G)
QUIT
Begin DoDot:2
+13 IF A=315640000
SET G=D_U_"Imm Pkg Refusal 315640000"
QUIT
+14 IF A]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC NO IZ MED",A))
SET G=D_U_"Imm Pkg SNOMED "_A
QUIT
+15 IF A]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC NO IZ PAT",A))
SET G=D_U_"Imm Pkg SNOMED "_A
QUIT
+16 IF A]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC NO IZ SYS",A))
SET G=D_U_"Imm Pkg SNOMED "_A
QUIT
End DoDot:2
End DoDot:1
+17 QUIT G
FLUVAC(P,BDATE,EDATE) ;
+1 NEW BGPG,BGPLFLU,X,E,%,I,T,J,V,G,D,R,CVX,BGPT,TCVX,TCPT
+2 SET TCVX=$ORDER(^ATXAX("B","BGP IPC INFLUENZA CVX CODES",0))
+3 SET TCPT=$ORDER(^ATXAX("B","BGP IPC INFLUENZA CPT CODES",0))
+4 KILL BGPG
+5 SET BGPLFLU=""
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+7 SET I=$PIECE($GET(^AUPNVIMM(X,0)),U,1)
+8 IF 'I
QUIT
+9 SET CVX=$PIECE($GET(^AUTTIMM(I,0)),U,3)
+10 IF CVX=""
QUIT
+11 ;NOT IN TAXONOMY
IF '$DATA(^ATXAX(TCVX,21,"B",CVX))
QUIT
+12 SET D=$$VD^APCLV($PIECE(^AUPNVIMM(X,0),U,3))
+13 IF D<BDATE
QUIT
+14 IF D>EDATE
QUIT
+15 SET BGPLFLU=1_U_$$DATE^BGP8UTL(D)_U_"Imm "_CVX
End DoDot:1
+16 IF BGPLFLU
QUIT BGPLFLU
+17 ;CPT
+18 IF TCPT
Begin DoDot:1
+19 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,TCPT,5)
IF X]""
QUIT
+20 SET X=$$TRAN^BGP8DU(P,BDATE,EDATE,TCPT,5)
End DoDot:1
+21 IF X]""
QUIT 1_U_$$DATE^BGP8UTL($PIECE(X,U,1))_U_"CPT: "_$PIECE(X,U,2)
+22 ;NOW CHECK PROBLEM LIST AND V POV FOR DURING BDATE AND EDATE
+23 SET X=0
SET G=0
SET I=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G=1)
QUIT
Begin DoDot:1
+24 SET I=""
+25 IF '$DATA(^AUPNPROB(X,0))
QUIT
+26 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+27 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+28 IF S=185900003
SET I=1
+29 IF S=185901004
SET I=1
+30 IF S=185902006
SET I=1
+31 IF S=416928007
SET I=1
+32 IF 'I
QUIT
+33 SET D=$PIECE(^AUPNPROB(X,0),U,13)
+34 IF 'D
SET D=$PIECE(^AUPNPROB(X,0),U,8)
+35 IF D<BDATE
QUIT
+36 IF D>EDATE
QUIT
+37 SET G=1_U_$$DATE^BGP8UTL(D)_U_"PL: "_S
+38 QUIT
End DoDot:1
+39 IF G
QUIT G
+40 ;what about V POVs
+41 SET G=""
+42 FOR S=185900003,185901004,185902006,416928007
Begin DoDot:1
+43 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+44 SET Y=9999999-D
+45 IF Y<BDATE
QUIT
+46 IF Y>EDATE
QUIT
+47 SET G=1_U_$$DATE^BGP8UTL(Y)_U_"POV: "_S
End DoDot:2
End DoDot:1
IF G
QUIT
+48 IF G
QUIT G
+49 QUIT ""
