Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP8PC6

BGP8PC6.m

Go to the documentation of this file. 
  1. BGP8PC6 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018  11:25 AM
  1.  ;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65
  1.  ;
  1. CIZ ;EP
  1.  K BGPSTOP
  1.  S (BGPN1,BGPD1)=0
  1.  ;GET THE PATIENT'S 6 MONTH BIRTHDAY
  1.  S A=$$Y2BD(DFN)  ;FIRST DAY THEY ARE 2 YEARS OLD
  1.  S B=$$Y3BD(DFN)  ;FIRST DAY THEY ARE 3 YEARS OLD
  1.  S B=$$FMADD^XLFDT(B,-1)  ;LAST DAY THEY ARE 2 YEARS OLD
  1.  I A>BGPEDATE S BGPSTOP=1 Q  ;turned 2 YEARS after end date of report period
  1.  I B<BGPBDATE S BGPSTOP=1 Q  ;last day they are 2 is before the report period
  1.  ;
  1.  I $$HOSPIND^BGP8PC2(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 Q  ;no hospice pts
  1.  ;
  1.  S BGPDV=$$ENC6(DFN,BGPBDATE,BGPEDATE) I BGPDV="" S BGPSTOP=1 G CIZE  ;no visit
  1.  ;
  1.  S BGPDV1=""
  1.  S (BGPDTAP,BGPIPV,BGPMMR,BGPHIB,BGPHEPB,BGPVAR,BGPPNEU,BGPHEPA,BGPROTA,BGPFLU)=""
  1.  S BGPD1=1
  1.  ;
  1.  S BGPDTAP=$$DTAP(DFN)
  1.  S BGPIPV=$$IPV^BGP8PC61(DFN)
  1.  S BGPMMR=$$MMR^BGP8PC62(DFN)
  1.  S BGPHIB=$$HIB^BGP8PC63(DFN)
  1.  S BGPHEPB=$$HEPB^BGP8PC64(DFN)
  1.  S BGPVAR=$$VZV^BGP8PC65(DFN)
  1.  S BGPPNEU=$$PNEUMO^BGP8PC66(DFN)
  1.  S BGPHEPA=$$HEPA^BGP8PC67(DFN)
  1.  S BGPROTA=$$ROTA^BGP8PC68(DFN)
  1.  S BGPFLU=$$FLU^BGP8PC69(DFN)
  1.  ;W !,DFN," ",$$DOB^AUPNPAT(DFN)," ",BGPDV," ",BGPDTAP," ",BGPIPV," ",BGPMMR," ",BGPHIB," ",BGPHEPB," ",BGPVAR," ",BGPPNEU," ",BGPHEPA," ",BGPROTA,"  ",BGPFLU
  1.  I BGPDTAP,BGPIPV,BGPMMR,BGPHIB,BGPHEPB,BGPVAR,BGPPNEU,BGPHEPA,BGPROTA,BGPFLU S BGPN1=1  ;HAD ALL
  1.  I BGPN1 S V="" F X="BGPDTAP","BGPIPV","BGPMMR","BGPHIB","BGPHEPB","BGPVAR","BGPPNEU","BGPHEPA","BGPROTA","BGPFLU" S:V]"" V=V_"; " S V=V_$P(@X,U,2)
  1.  I BGPN1 S V="*** "_V
  1.  I 'BGPN1 S V="" F X="BGPDTAP","BGPIPV","BGPMMR","BGPHIB","BGPHEPB","BGPVAR","BGPPNEU","BGPHEPA","BGPROTA","BGPFLU" I $P(@X,U,1) S:V]"" V=V_"; " S V=V_$P(@X,U,2)
  1.  I 'BGPN1,V]"" S V="HAS: "_V
  1.  I 'BGPN1 S N="" F X="BGPDTAP","BGPIPV","BGPMMR","BGPHIB","BGPHEPB","BGPVAR","BGPPNEU","BGPHEPA","BGPROTA","BGPFLU" I '$P(@X,U,1) S:N]"" N=N_"; " S N=N_$E(X,4,8)
  1.  I 'BGPN1 S V=V_"   NEEDS: "_N
  1.  S BGPVALUE=""
  1.  S BGPVALUE="ENC "_$P(BGPDV,U,2)_"|||"_V   ;hit denominator
  1. CIZE ;
  1.  K BGPDV,BGPDTAP,BGPIPV,BGPMMR,BGPHIB,BGPHEPB,BGPVAR,BGPPNEU,BGPHEPA,BGPROTA,BGPFLU,V,N,BGPDV1
  1.  Q
  1. DTAP(P) ;
  1.  NEW A42,A730,X,Y,Z,TCVX,TCPT,C,BGPIMMS,D,V,BGPZ
  1.  S TCVX=$O(^ATXAX("B","BGP IPC DTAP CVX CODES",0))
  1.  S TCPT=$O(^ATXAX("B","BGP IPC DTAP CPT CODES",0))
  1.  S A42=$$FMADD^XLFDT($$DOB^AUPNPAT(P),42)
  1.  S A730=$$FMADD^XLFDT($$DOB^AUPNPAT(P),730)
  1.  S X=0 F  S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVIMM(X,0))  ;happens
  1.  .S Y=$P(^AUPNVIMM(X,0),U)
  1.  .Q:'Y  ;happens too
  1.  .S I=$P($G(^AUTTIMM(Y,0)),U,3)  ;get HL7/CVX code
  1.  .Q:'$D(^ATXAX(TCVX,21,"B",I))  ;not a DTAP
  1.  .S D=$P($P($G(^AUPNVIMM(X,12)),U,1),".")
  1.  .I D="" S V=$P(^AUPNVIMM(X,0),U,3) I V S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1.  .Q:D<A42
  1.  .Q:D>A730
  1.  .S BGPIMMS(D)=Y
  1.  .Q
  1.  ;go through and set into array if 1 days apart
  1.  S X="",Y="",C=0 F  S X=$O(BGPIMMS(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<1 K BGPIMMS(X) Q
  1.  .S Y=X
  1.  ;see if there are 4 of them, if there are quit
  1.  S BGPIMMS=0,X=0 F  S X=$O(BGPIMMS(X)) Q:X'=+X  S BGPIMMS=BGPIMMS+1
  1.  I BGPIMMS>3 Q 1_U_"4 DTAP"
  1.  ;now get cpts
  1.  S G="",X=0
  1.  F  S X=$O(^AUPNVCPT("AC",P,X)) Q:X=""  D
  1.  .Q:'$D(^AUPNVCPT(X,0))
  1.  .S Y=$P(^AUPNVCPT(X,0),U)
  1.  .Q:'$$ICD^BGP8UTL2(Y,TCPT,1)  ;not a dtap cpt
  1.  .S V=$P(^AUPNVCPT(X,0),U,3) Q:'V
  1.  .S D=$$VD^APCLV(V)
  1.  .Q:D<A42
  1.  .Q:D>A730
  1.  .S BGPIMMS(D)=""
  1.  ;get tran codes
  1.  S X=0 F  S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVTC(X,0))
  1.  .S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y
  1.  .Q:'$$ICD^BGP8UTL2(Y,TCPT,1)
  1.  .S V=$P(^AUPNVTC(X,0),U,3) Q:'V
  1.  .S D=$$VD^APCLV(V)
  1.  .Q:D<A42
  1.  .Q:D>A730
  1.  .S BGPIMMS(D)=""
  1.  ;
  1.  ;go through and set into array if 1 days apart
  1.  S X="",Y="",C=0 F  S X=$O(BGPIMMS(X)) Q:X'=+X  S C=C+1 D
  1.  .I C=1 S Y=X Q
  1.  .I $$FMDIFF^XLFDT(X,Y)<1 K BGPIMMS(X) Q
  1.  .S Y=X
  1.  ;see if there are 4 of them, if there are quit
  1.  S BGPIMMS=0,X=0 F  S X=$O(BGPIMMS(X)) Q:X'=+X  S BGPIMMS=BGPIMMS+1
  1.  I BGPIMMS>3 Q 1_U_"4 DTAP"
  1.  ;NOW CHECK FOR CONTRAINDICATION
  1.  ;IMM PKG ANAPHYLACTIS
  1.  S BGPZ=0
  1.  F  S BGPZ=$O(^ATXAX(TCVX,21,"B",BGPZ)) Q:BGPZ=""!(X]"")  D
  1.  .S X=$$ANCONT^BGP8D31(P,BGPZ,A730)
  1.  I X]"" Q 1_U_"DTAP CONTRA ANAPHYLACTIC REACTION"
  1.  S X=$$ENCEPH(P,A730) I X Q 1_U_"DTAP CONTRA ENCEPH"
  1.  S X=$$ANSNDTAP(P,A730) I X Q 1_U_"DTAP CONTRA ANAPHYLACTIC REACTION"
  1.  Q ""
  1. ENCEPH(P,EDATE) ;
  1.  ;V POV OR PROBLEM LIST
  1.  NEW X,Y,Z,G,T,S,D
  1.  I $$PLTAXND^BGP8DU(P,"BGP IPC IZ ENCEPHALOPATHY DXS",EDATE,0) Q 1
  1.  I $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC IZ ENCEPHAL",EDATE,0) Q 1
  1.  I $$LASTDX^BGP8UTL1(P,"BGP IPC IZ ENCEPHALOPATHY DXS",$$DOB^AUPNPAT(P),EDATE) Q 1
  1.  ;NOW V POV SNOMED
  1.  ;NOW SNOMED USING ASNC
  1.  S T="PXRM BGP IPC IZ ENCEPHAL"
  1.  S G=""
  1.  S S=0 F  S S=$O(^XTMP("BGPSNOMEDSUBSET",$J,T,S)) Q:S=""!(G)  D
  1.  .Q:'$D(^AUPNVPOV("ASNC",P,S))
  1.  .S D=0 F  S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G)  D
  1.  ..S Y=9999999-D
  1.  ..Q:Y>EDATE
  1.  ..S G=1
  1.  Q G
  1. ANSNDTAP(P,EDATE) ;
  1.  ;V POV OR PROBLEM LIST
  1.  NEW X,Y,Z,G,T,S,D,I
  1.  S (X,Y,I)=0
  1.  F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I)  D
  1.  .Q:'$D(^AUPNPROB(X,0))
  1.  .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1.  .I $P(^AUPNPROB(X,0),U,13),$P(^AUPNPROB(X,0),U,13)>EDATE Q  ;if there is a doo and it is after report period skip
  1.  .I $P(^AUPNPROB(X,0),U,13)="",$P(^AUPNPROB(X,0),U,8)>EDATE Q  ;entered after report period, skip
  1.  .S S=$$VAL^XBDIQ1(9000011,X,80001)
  1.  .I S=219084006 S I=1 Q
  1.  .I S=293108006 S I=1 Q
  1.  .I S=428281000124107 S I=1 Q
  1.  .I S=428291000124105 S I=1 Q
  1.  .Q
  1.  I I Q I
  1.  ;NOW V POV SNOMED
  1.  ;NOW SNOMED USING ASNC
  1.  S G="",I=""
  1.  S S="" F  S S=$O(^AUPNVPOV("ASNC",P,S)) Q:S=""!(G)  D
  1.  .S I=0
  1.  .I S=219084006 S I=1
  1.  .I S=293108006 S I=1
  1.  .I S=428281000124107 S I=1
  1.  .I S=428291000124105 S I=1
  1.  .Q:'I
  1.  .S D=0 F  S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G)  D
  1.  ..S Y=9999999-D
  1.  ..Q:Y>EDATE
  1.  ..S G=1
  1.  Q G
  1. Y2BD(P) ;
  1.  NEW B,M,D,Y
  1.  S B=$$DOB^AUPNPAT(P)  ;DOB
  1.  S M=$E(B,4,5)
  1.  S D=$E(B,6,7)
  1.  S Y=$E(B,1,3),Y=Y+2
  1.  Q Y_M_D
  1. Y3BD(P) ;
  1.  NEW B,M,D,Y
  1.  S B=$$DOB^AUPNPAT(P)  ;DOB
  1.  S M=$E(B,4,5)
  1.  S D=$E(B,6,7)
  1.  S Y=$E(B,1,3),Y=Y+3
  1.  Q Y_M_D
  1. ENC6(P,BDATE,EDATE) ;EP  - have encounter per CMS117v6
  1.  NEW X,Y,Z,G,BGPV,D,A,B
  1.  ;Let's check all Visits, looping through once
  1.  S G=""  ;return variable
  1.  ;get all visits in date range in BGPV
  1.  D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
  1.  ;now loop through and check Face to Face and .17 in visit and check v cpts attached to the visit
  1.  S X=0 F  S X=$O(BGPV(X)) Q:X'=+X!(G)  S V=$P(BGPV(X),U,5)  D
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)  ;no dependent entries
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)  ;deleted
  1.  .S D=$$VD^APCLV(V)
  1.  .S Y=$$FTOF^BGP8PC2(V) I Y]"" S G=1_U_$$DATE^BGP8UTL(D)_" FTOF: "_Y Q   ;ITEM 18
  1.  .;is .17 a cpt we want?
  1.  .S Y=$$VALI^XBDIQ1(9000010,V,.17)
  1.  .I Y,$$OFFCPT6(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2) Q
  1.  .;now check all V CPTs
  1.  .S Z=0 F  S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z!(G)  D
  1.  ..S Y=$P($G(^AUPNVCPT(Z,0)),U,1)
  1.  ..I Y,$$OFFCPT6(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2) Q
  1.  Q G
  1. OFFCPT6(C) ;EP
  1.  I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC OFFICE VISIT CPTS",0)),1) Q 1       ;ITEM 1
  1.  I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC HOMEHEALTH VISIT CPTS",0)),1) Q 1   ;ITEM 5
  1.  I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE IOV 0-17 CPTS",0)),1) Q 1  ;ITEM 4
  1.  I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE EOV 0-17 CPTS",0)),1) Q 1  ;ITEM 3
  1.  Q ""