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

BGP6D24.m

Go to the documentation of this file. 
  1. BGP6D24 ; IHS/CMI/LAB - STI MEASURE 18 Oct 2009 8:37 AM 03 Jul 2010 7:56 AM ;
  1.  ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
  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.  K BGPYAR,BGPZAR,BGPNUMV
  1.  I $T(EN^BKMSTIDS)="" S BGPSTOP=1 Q  ;no routine to execute
  1.  ; BGPTIME=1 ZW  
  1.  ;D EN^XBNEW("STI^BGP6D24","DFN;BGPBDATE;BGPEDATE;BGPYAR;BGPZAR")
  1.  D EN^BKMSTIDS(DFN,BGPBDATE,BGPEDATE,"KEY",.BGPYAR,.BGPZAR)
  1.  I '$D(BGPZAR) S BGPSTOP=1 Q  ;no incidences or diagnoses
  1.  I $P($G(BGPZAR(0)),U)=0 S BGPSTOP=1 Q  ;no incidences or diagnoses
  1.  S (BGPN1,BGPN2)=$P(BGPZAR(0),U,1)  ;TOTAL # OF INCIDENCES
  1.  S BGPD1=$P(BGPZAR(0),U,2) ;TOTAL # SCREENINGS NEEDED
  1.  S BGPN3=$P(BGPZAR(0),U,3) ;TOTAL # OF SCREENINGS DONE
  1.  S BGPN4=$P(BGPZAR(0),U,4) ;TOTAL # OF REFUSALS
  1.  S BGPN15=$P(BGPZAR(0),U,5)  ;NEW GROUPED DEN
  1.  S BGPN16=$P(BGPZAR(0),U,6)  ;NEW GROUPED NUM
  1.  S BGPN17=$P(BGPZAR(0),U,7)  ;NEW GROUPED REF
  1.  S BGPCIN=0
  1.  S X=0 F  S X=$O(BGPZAR(X)) Q:X'=+X  D
  1.  .S BGPCIN=BGPCIN+1
  1.  .S:BGPDENV]"" BGPDENV=BGPDENV_"; "
  1.  .S BGPNUMV(X)=""
  1.  .S I=0,C=0,BGPHXX="" F  S I=$O(BGPZAR(X,I)) Q:I=""  D
  1.  ..I $D(BGPZAR(X,I,0)) S C=C+1 S BGPDENV=BGPDENV_$S(C=1:BGPCIN_") ",1:", ")_$P(BGPZAR(X,I,0),U,5)
  1.  ..I $G(BGPYAR(I,"NUM","HIV"))=1 S BGPHXX=$O(BGPYAR(I,"NUM","HIV",0)) I BGPHXX S J=$P(BGPYAR(I,"NUM","HIV",BGPHXX),U,2) I J'["POV" S BGPHXX=""
  1.  ..;I BGPHXX S BGPN18=1
  1.  .D
  1.  ..;I $G(BGPZAR(X,"CHL"))]"" S Z=$G(BGPZAR(X,"CHL")) S:$P(Z,U) BGPD2=BGPD2+1 S:$P(Z,U,2) BGPN5=BGPN5+1 S:$P(Z,U,3) BGPN6=BGPN6+1 D
  1.  ..;.S:BGPNUMV(X)]"" BGPNUMV(X)=BGPNUMV(X)_", " S BGPNUMV(X)=BGPNUMV(X)_"CHL-"_$S($P(Z,U,2):"Y",1:"N")_$S($P(Z,U,4)]"":" "_$P(Z,U,4),1:"") ;_"; " ;CHL SCREENINGS NEEDED/DONE
  1.  ..;I $G(BGPZAR(X,"GC"))]"" S Z=$G(BGPZAR(X,"GC")) S:$P(Z,U) BGPD3=BGPD3+1 S:$P(Z,U,2) BGPN7=BGPN7+1 S:$P(Z,U,3) BGPN8=BGPN8+1 D
  1.  ..;.S:BGPNUMV(X)]"" BGPNUMV(X)=BGPNUMV(X)_", " S BGPNUMV(X)=BGPNUMV(X)_"GC-"_$S($P(Z,U,2):"Y",1:"N")_$S($P(Z,U,4)]"":" "_$P(Z,U,4),1:"") ;_"; " ;GON SCREENINGS NEEDED/DONE
  1.  ..I $G(BGPZAR(X,"HIV"))]"" S Z=$G(BGPZAR(X,"HIV")) S:$P(Z,U) BGPD4=BGPD4+1 S:$P(Z,U,2) BGPN9=BGPN9+1 S:$P(Z,U,3) BGPN10=BGPN10+1 D
  1.  ...S:BGPNUMV(X)]"" BGPNUMV(X)=BGPNUMV(X)_", "
  1.  ...S H=0,I="" S:'($P(Z,U,1)+$P(Z,U,2)) H=1,I="Contraind Prior DX",BGPN18=1
  1.  ...S BGPNUMV(X)=BGPNUMV(X)_"HIV-"_$S($P(Z,U,2):"Y",H:I,1:"N")_$S($P(Z,U,4)]"":" "_$P(Z,U,4),1:"") ;_"; " ;HIV SCREENINGS NEEDED/DONE
  1.  ..;I $G(BGPZAR(X,"SYP"))]"" S Z=$G(BGPZAR(X,"SYP")) S:$P(Z,U) BGPD5=BGPD5+1 S:$P(Z,U,2) BGPN11=BGPN11+1 S:$P(Z,U,3) BGPN12=BGPN12+1 D
  1.  ..;.S:BGPNUMV(X)]"" BGPNUMV(X)=BGPNUMV(X)_", " S BGPNUMV(X)=BGPNUMV(X)_"SYP-"_$S($P(Z,U,2):"Y",1:"N")_$S($P(Z,U,4)]"":" "_$P(Z,U,4),1:"") ;_"; " ;SYP SCREENINGS NEEDED/DONE
  1.  .;I H]"" S:BGPNUMV(X)]"" BGPNUMV(X)=BGPNUMV(X)_", " S BGPNUMV(X)=BGPNUMV(X)_"Prior HIV DX (Contraind): "_$$DATE^BGP6UTL(H)
  1.  .S BGPVALUE="UP"_$S(BGPACTCL:";AC",1:"")_" Visit "_BGPDENV_"|||"
  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:9 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 'BGPACTCB S BGPSTOP=1 Q
  1.  I BGPAGEB<9 S BGPSTOP=1 Q
  1.  I BGPAGEB>75 S BGPSTOP=1 Q
  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.  K BGPALL
  1.  D ALSCRN^BGP6D55(DFN,BGPBDATE,BGPEDATE,.BGPALL,1)
  1.  I $D(BGPALL) S BGPN1=1
  1.  ;if screened, is any screen positive
  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.  ;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="AC+BH|||"
  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^BGP6UTL($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^BGP6UTL2(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^BGP6UTL(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^BGP6UTL2(I,BGPCT,1)
  1. PCS ..S BGPSC=BGPSC+1
  1.  ..S BGPABNI(BGPVD,BGPSC)=1_"^PT ED "_T_"^"_$$DATE^BGP6UTL(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^BGP6UTL2(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^BGP6UTL(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^BGP6UTL2($P(T,U,1),BGPCT,1)
  1. BHS ..S BGPSC=BGPSC+1
  1.  ..S BGPABNI(BGPVD,BGPSC)=1_"^PT ED "_T_"^"_$$DATE^BGP6UTL(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^BGP6UTL($P($P(^AUPNVSIT($P(BGPG(X),U,5),0),U),"."))
  1.  Q C_U_R