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

BGP7D24.m

Go to the documentation of this file. 
  1. BGP7D24 ; IHS/CMI/LAB - STI MEASURE 18 Oct 2009 8:37 AM 03 Jul 2010 7:56 AM ;
  1.  ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
  1.  ;
  1. STI ;EP
  1.  ;D EN^BKMSTIDS(DFN,BGPBDATE,BGPEDATE,"KEY",.BGPYAR,.BGPZAR)
  1.  ;Q
  1. ISTI ;EP
  1.  NEW BGPCIN
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN15,BGPN16,BGPN17,BGPN18,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
  1.  S BGPVALUE="",BGPDENV=""
  1.  I 'BGPACTCL S BGPSTOP=1 Q  ;only active clinical pts
  1.  S BGPZAR=$$KEYSTI^BGP7D24A(DFN,BGPBDATE,BGPEDATE)
  1.  I '$P(BGPZAR,U,1) S BGPSTOP=1 Q  ;no incidences or diagnoses
  1.  I $P($G(BGPZAR),U)=0 S BGPSTOP=1 Q  ;no incidences or diagnoses
  1.  S (BGPN1,BGPN2)=$P(BGPZAR,U,1)  ;TOTAL # OF INCIDENCES
  1.  S BGPD1=$P(BGPZAR,U,2) ;TOTAL # SCREENINGS NEEDED
  1.  S BGPN3=$P(BGPZAR,U,3) ;TOTAL # OF SCREENINGS DONE
  1.  S BGPN4=$P(BGPZAR,U,4) ;TOTAL # OF REFUSALS
  1.  S BGPVALUE="UP"_$S(BGPACTCL:";AC",1:"")_" "_$P(BGPZAR,U,5)_"|||"_$P(BGPZAR,U,6)
  1.  ;S BGPCIN=0 S X=0 F  S X=$O(BGPNUMV(X)) Q:X'=+X  S BGPCIN=BGPCIN+1 S BGPVALUE=BGPVALUE_$S(BGPCIN>1:"; ",1:"")_BGPCIN_") "_$S(BGPNUMV(X)="":"N/A",1:BGPNUMV(X))
  1.  Q
  1.  ;
  1. SBI ;EP
  1.  F X=1:1:10 S Y="BGPD"_X S @Y=""  ;9 denominators
  1.  F X=1:1:7 S Y="BGPN"_X S @Y="" ;7 numerators
  1.  S BGPVALUE=""
  1.  I 'BGPACTUP S BGPSTOP=1 Q
  1.  I BGPAGEB<9 S BGPSTOP=1 Q
  1.  I BGPAGEB>75 S BGPSTOP=1 Q
  1.  I BGPACTCB D
  1.  .S BGPD1=1
  1.  .I BGPAGEB>8,BGPAGEB<13 S BGPD2=1
  1.  .I BGPAGEB>12,BGPAGEB<19 S BGPD3=1
  1.  .I BGPAGEB>18,BGPAGEB<25 S BGPD4=1
  1.  .I BGPAGEB>24,BGPAGEB<35 S BGPD5=1
  1.  .I BGPAGEB>34,BGPAGEB<45 S BGPD6=1
  1.  .I BGPAGEB>44,BGPAGEB<55 S BGPD7=1
  1.  .I BGPAGEB>54,BGPAGEB<65 S BGPD8=1
  1.  .I BGPAGEB>64 S BGPD9=1
  1.  I BGPACTUP S BGPD10=1
  1.  K BGPALL
  1.  D ALSCRN^BGP7D55(DFN,BGPBDATE,BGPEDATE,.BGPALL,1)
  1.  I $D(BGPALL) S BGPN1=1
  1.  ;if screened, is any screen positive
  1.  I BGPD10,'BGPD1,'BGPN1 S BGPSTOP=1 Q  ;UP 9-75, NOT AC+BH, NOT SCREENED
  1.  S BGPSCRC="",BGPSCRD=""
  1.  S D=0 F  S D=$O(BGPALL(D)) Q:D'=+D!(BGPSCRC]"")  S Y=0 F  S Y=$O(BGPALL(D,Y)) Q:Y'=+Y!(BGPSCRC]"")  I $P(BGPALL(D,Y),U,5) S BGPSCRC=BGPALL(D,Y),BGPSCRD=$P(BGPALL(D,Y),U,4)
  1.  I BGPSCRC]"" S BGPN2=1
  1.  I BGPD10,'BGPD1,'BGPN2 S BGPSTOP=1 Q  ;UP 9-75
  1.  ;if no positive then take latest one
  1.  I BGPSCRC="" S D=$O(BGPALL(0)) I D S Y=$O(BGPALL(D,0)) S BGPSCRC=BGPALL(D,Y),BGPSCRD=$P(BGPALL(D,Y),U,4)
  1.  I BGPSCRD="" G SETL  ;NO SCREENING SO DON'T BOTHER WITH NUMERATOR BNI
  1.  ;GET BNI DATE/ITEM/
  1.  K BGPABNI
  1.  S BGPBNID=""
  1.  D BNI(DFN,BGPSCRD,$$FMADD^XLFDT(BGPSCRD,7),.BGPABNI)
  1.  I '$D(BGPABNI) G TRT  ;NO BNIS
  1.  ;GET 1ST ONE
  1.  S D=$O(BGPABNI(0)) I D S Y=$O(BGPABNI(D,0)) S BGPBNID=BGPABNI(D,Y)
  1.  S BGPN3=1
  1.  S X=$P(BGPBNID,U,5)
  1.  I X=0 S BGPN4=1
  1.  I X>0,X<4 S BGPN5=1
  1.  I X>3 S BGPN6=1
  1. TRT S BGPTRT=""
  1.  I BGPN2 D
  1.  .S BGPTRT=$$TXPTED(DFN,BGPSCRD,$$FMADD^XLFDT(BGPSCRD,7))
  1.  .I BGPTRT S BGPN7=1
  1. SETL ;
  1.  S BGPVALUE=$S(BGPD10&(BGPN2):"UPPOS",1:"") S:BGPD1 BGPVALUE=BGPVALUE_$S(BGPVALUE]"":",AC+BH",1:"AC+BH") S BGPVALUE=BGPVALUE_"|||"
  1.  I BGPN1 D
  1.  .S BGPVALUE=BGPVALUE_"SCREEN: "_$P(BGPSCRC,U,3)_" "_$P(BGPSCRC,U,2)_$S(BGPN2:" result=Pos",1:"")
  1.  .S BGPVALUE=BGPVALUE_"; BNI: "_$S(BGPN3:$P(BGPBNID,U,3)_" Yes ["_$P(BGPBNID,U,5)_"]",1:"No")
  1.  .S BGPVALUE=BGPVALUE_"; "_$P(BGPTRT,U,2) ;$S(BGPN7:$P(BGPTRT,U,2),1:"No")
  1. X K BGPSCRD,BGPALL,BGPABNI,BGPBNID,BGPSCRC
  1.  Q
  1.  ;
  1. TXPTED(P,BDATE,EDATE) ;
  1.  NEW BGPG
  1.  K BGPG
  1.  S Y="BGPG("
  1.  S X=P_"^FIRST EDUC AOD-TX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I '$D(BGPG) Q 0_U_"REFERRAL: No"
  1.  Q 1_U_"REFERRAL: "_$$DATE^BGP7UTL($P(BGPG(1),U))_" Yes"
  1.  ;
  1. BNI(P,BDATE,EDATE,BGPABNI) ;EP - GET FIRST BNI AVAILABLE ON A VISITS
  1.  NEW BGPG,%,E,BGPSC,V,BGPC,T,F,D,R,BGPCT,BGPX,BGPV,BGPVD,BGPIVD
  1.  K BGPABNI
  1.  S BGPSC=0
  1. PCC ;check PCC first
  1.  S BGPCT=$O(^ATXAX("B","BGP BNI CPTS",0))
  1.  K BGPG
  1.  D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPG")
  1.  S BGPX=0 F  S BGPX=$O(BGPG(BGPX)) Q:BGPX'=+BGPX  S BGPV=$P(BGPG(BGPX),U,5) D
  1.  .Q:$P(^AUPNVSIT(BGPV,0),U,7)'="A"  ;IF SBI ONLY AMBULATORY
  1.  .S BGPVD=$$VD^APCLV(BGPV)
  1. PCCCPT .;
  1.  .S E=0 F  S E=$O(^AUPNVCPT("AD",BGPV,E)) Q:E'=+E  D
  1.  ..S I=$P($G(^AUPNVCPT(E,0)),U,1)
  1.  ..Q:'I
  1.  ..Q:'$$ICD^BGP7UTL2(I,BGPCT,1)
  1.  ..S J=$P(^ICPT(I,0),U,1)
  1.  ..S BGPSC=BGPSC+1
  1.  ..S BGPABNI(BGPVD,BGPSC)=1_"^CPT "_J_"^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD_U_$$FMDIFF^XLFDT(BGPVD,BDATE)
  1. PCCPTED .;
  1.  .S E=0 F  S E=$O(^AUPNVPED("AD",BGPV,E)) Q:E'=+E  D
  1.  ..S I=$P($G(^AUPNVPED(E,0)),U,1)
  1.  ..Q:'I
  1.  ..S T=$P($G(^AUTTEDT(I,0)),U,2)
  1.  ..I T="AOD-BNI" G PCS
  1.  ..Q:$L($P(T,"-",1))'=5
  1.  ..S I=+$$CODEN^ICPTCOD($P(T,"-",1))
  1.  ..Q:'$$ICD^BGP7UTL2(I,BGPCT,1)
  1. PCS ..S BGPSC=BGPSC+1
  1.  ..S BGPABNI(BGPVD,BGPSC)=1_"^PT ED "_T_"^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD_U_$$FMDIFF^XLFDT(BGPVD,BDATE)
  1. BH ;CHECK BH VISITS
  1.  S BGPC="",T="",F=""
  1.  S E=9999999-BDATE,D=9999999-EDATE-1_".99"
  1.  F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V  D
  1. BHEX .;
  1.  .Q:$$VAL^XBDIQ1(9002011,V,.07)'="OUTPATIENT"
  1.  .S BGPVD=9999999-$P(D,".")
  1. BHCPT .;now add in CPT codes
  1.  .S X=0 F  S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X  D
  1.  ..S I=$P($G(^AMHRPROC(X,0)),U,1)
  1.  ..Q:'I
  1.  ..Q:'$$ICD^BGP7UTL2(I,BGPCT,1)
  1.  ..S J=$P(^ICPT(I,0),U,1)
  1.  ..S BGPSC=BGPSC+1
  1.  ..S BGPABNI(BGPVD,BGPSC)=1_"^CPT "_J_"^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD_U_$$FMDIFF^XLFDT(BGPVD,BDATE)
  1.  ..Q
  1. BHPTED .;
  1.  .S X=0 F  S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X  D
  1.  ..S I=$P($G(^AMHREDU(X,0)),U,1)
  1.  ..Q:'I
  1.  ..S T=$P($G(^AUTTEDT(I,0)),U,2)
  1.  ..I T="AOD-BNI" G BHS
  1.  ..Q:$L($P(T,U,1))'=5
  1.  ..Q:'$$ICD^BGP7UTL2($P(T,U,1),BGPCT,1)
  1. BHS ..S BGPSC=BGPSC+1
  1.  ..S BGPABNI(BGPVD,BGPSC)=1_"^PT ED "_T_"^"_$$DATE^BGP7UTL(BGPVD)_U_BGPVD_U_$$FMDIFF^XLFDT(BGPVD,BDATE)
  1.  .Q
  1.  Q
  1. IPC ;EP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
  1.  S BGPVALUE=""
  1.  I 'BGPACTCL Q  ;not active clinical
  1.  S BGPVAL=$$PCV(DFN,BGPBDATE,BGPEDATE)  ;return #visits^list string
  1.  S BGPN1=$P(BGPVAL,U)
  1.  I BGPAGEB<18 S BGPN2=BGPN1
  1.  I BGPAGEB>17,BGPAGEB<55 S BGPN3=BGPN1
  1.  I BGPAGEB>54 S BGPN4=BGPN1
  1.  ;I BGPCANCE,BGPN1>1 S BGPN5=1
  1.  S BGPVALUE="AC"_"|||"_BGPN1_$S(BGPN1'=1:" visits: ",1:" visit: ")_$P(BGPVAL,U,2)
  1.  K BGPVAL
  1.  Q
  1.  ;
  1. PCV(P,BDATE,EDATE) ;EP
  1.  ;all dxs BGP PALLIATIVE CARE  DXS and get unique visits count
  1.  NEW BGPG,X,Y,E
  1.  K BGPG
  1.  S Y="BGPG("
  1.  S X=P_"^ALL DX [BGP PALLIATIVE CARE DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I '$D(BGPG(1)) Q 0  ;no visits
  1.  NEW X,C,R
  1.  S R="",C=0
  1.  S X=0 F  S X=$O(BGPG(X)) Q:X'=+X  I '$D(X($P(BGPG(X),U,5))) D
  1.  .S X($P(BGPG(X),U,5))=""
  1.  .S C=C+1
  1.  .S R=R_$S(R="":"",1:", ")_$$DATE^BGP7UTL($P($P(^AUPNVSIT($P(BGPG(X),U,5),0),U),"."))
  1.  Q C_U_R