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

BGP5D55.m

Go to the documentation of this file. 
  1. BGP5D55 ; IHS/CMI/LAB - measure calc ;
  1.  ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
  1.  ;
  1. IASCRN ;EP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13,BGPD14,BGPD15,BGPD16)=0
  1.  I 'BGPACTUP S BGPSTOP=1 Q
  1.  ;I 'BGPACTCB S BGPSTOP=1 Q
  1.  I BGPAGEB<12 S BGPSTOP=1 Q
  1.  I BGPAGEB>75 S BGPSTOP=1 Q
  1.  I BGPACTCB D
  1.  .S BGPD1=1
  1.  .I BGPAGEB>11,BGPAGEB<20 S BGPD2=1
  1.  .I BGPAGEB>19,BGPAGEB<25 S BGPD3=1
  1.  .I BGPAGEB>24,BGPAGEB<35 S BGPD4=1
  1.  .I BGPAGEB>34,BGPAGEB<45 S BGPD5=1
  1.  .I BGPAGEB>44,BGPAGEB<55 S BGPD6=1
  1.  .I BGPAGEB>54,BGPAGEB<76 S BGPD7=1
  1.  I BGPSEX="F",BGPAGEB>13,BGPAGEB<47,BGPACTCL S BGPD8=1
  1.  I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8) S BGPSTOP=1 Q
  1.  ;BGPN1 - had screen or dx
  1.  ;BGPN2 - had educ
  1.  ;BGPN3 - had screening
  1.  ;BGPN4 - had positive screen
  1.  ;did they have screening?
  1.  K BGPALL
  1.  D ALSCRN(DFN,BGPBDATE,BGPEDATE,.BGPALL)
  1.  I $D(BGPALL) S BGPN1=1,BGPN3=1
  1.  ;if screened, is any screen positive
  1.  S C=""
  1.  S D=0 F  S D=$O(BGPALL(D)) Q:D'=+D!(C]"")  S Y=0 F  S Y=$O(BGPALL(D,Y)) Q:Y'=+Y!(C]"")  I $P(BGPALL(D,Y),U,5) S C=BGPALL(D,Y)
  1.  I C]"" S BGPN4=1
  1.  ;if no positive then take latest one
  1.  I C="" S D=$O(BGPALL(0)) I D S Y=$O(BGPALL(D,0)) S C=BGPALL(D,Y)
  1.  ;if didn't have screen then check dx/proc
  1.  S BGPALDX="" I 'BGPN1 S BGPALDX=$$ALDX(DFN,BGPBDATE,BGPEDATE)
  1.  I BGPALDX S BGPN1=1  ;BGPALDX
  1.  ;set numerators
  1.  S BGPN2=$$ALPED^BGP5D5(DFN,BGPBDATE,BGPEDATE)
  1.  I BGPN1!(BGPN2) S BGPN5=1 ;HAD EITHER SCREENING OR EDUC G.B.7
  1.  ;
  1.  S BGPVALUE=$S(BGPD8:"AC",1:"")_$S(BGPD8&(BGPD1):",",1:"")_$S(BGPD1:"AC+BH",1:"")_"|||"
  1.  I $P(BGPN1,U)=1,BGPN3 S BGPVALUE=BGPVALUE_"SCREEN: "_$P(C,U,3)_" "_$P(C,U,2)_"-"_$S($P(C,U,6)]"":$P(C,U,6),1:"NO RESULT")
  1.  I BGPN1,'BGPN3 S BGPVALUE=BGPVALUE_"DX/PROC: "_$P(BGPALDX,U,3)_" "_$P(BGPALDX,U,2)
  1.  ;I $P(BGPN1,U)=1,BGPN3!(BGPN5) S BGPVALUE=BGPVALUE_"SCREEN: "_$P(C,U,3)_" "_$P(C,U,2)_"-"_$S($P(C,U,6)]"":$P(C,U,6),1:"NO RESULT")
  1.  ;I $P(BGPN1,U)=1,'BGPN3!(BGPN5) S BGPVALUE=BGPVALUE_"DX/PROC: "_$P(BGPALDX,U,3)_" "_$P(BGPALDX,U,2)
  1.  I $P(BGPN2,U)=1 S BGPVALUE=BGPVALUE_$S(BGPN1:"; ",1:""),BGPVALUE=BGPVALUE_"PT ED: "_$P(BGPN2,U,3)_" "_$P(BGPN2,U,2)
  1.  K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPALL
  1.  Q
  1. ALDX(P,BDATE,EDATE) ;EP
  1.  NEW T,X,BGPC,E,Y,V,D,BGPLAL,BGPP,G,BGPG,BGPJ,BGPT
  1.  S BGPLAL=""
  1.  I $G(P)="" Q ""
  1.  K BGPG
  1.  S Y="BGPG("
  1.  S X=P_"^LAST DX [BGP ALCOHOL DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I $D(BGPG(1)) S BGPLAL=1_U_"DX "_$P(BGPG(1),U,2)_U_$$DATE^BGP5UTL($P(BGPG(1),U))_U_$P(BGPG(1),U)
  1.  S BGPC=""
  1.  ;go through BH record file and find up to 1 visits in date range
  1.  S BGPT=$O(^ATXAX("B","BGP ALCOHOL DXS",0))
  1.  I 'BGPT W !,BGPBOMB
  1.  S BGPJ=$O(^ATXAX("B","BGP BH PC ALCOHOL DXS",0))
  1.  I 'BGPJ W !,BGPBOMB
  1.  S E=9999999-BDATE,D=9999999-EDATE-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC)  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC)  D
  1.  .S X=0 F  S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(BGPC)  S BGPP=$P($G(^AMHRPRO(X,0)),U) D
  1.  ..Q:'BGPP
  1.  ..;S BGPP=$P($G(^AMHPROB(BGPP,0)),U)
  1.  ..I $$ICD^BGP5UTL2(BGPP,BGPT,9) S BGPC=1_U_"BH POV "_$P(^AMHPROB(BGPP,0),U)_U_$$DATE^BGP5UTL((9999999-$P(D,".")))_U_(9999999-$P(D,".")) Q
  1.  ..S BGPP=$P($G(^AMHPROB(BGPP,0)),U)
  1.  ..I $D(^ATXAX(BGPJ,21,"B",BGPP)) S BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP5UTL((9999999-$P(D,".")))_U_(9999999-$P(D,".")) Q
  1.  ..Q
  1.  I $P(BGPLAL,U,4)<$P(BGPC,U,4) S BGPLAL=BGPC
  1.  ;now check pcc and bh problem lists
  1.  S (X,G)=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G)  D
  1.  .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1.  .Q:$P(^AUPNPROB(X,0),U,12)="I"
  1.  .Q:$P(^AUPNPROB(X,0),U,3)>EDATE
  1.  .Q:$P(^AUPNPROB(X,0),U,3)<BDATE
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .Q:'$$ICD^BGP5UTL2(Y,BGPT,9)
  1.  .S D=$P(^AUPNPROB(X,0),U,3)
  1.  .S G=1_U_"PROB LIST "_$P($$ICDDX^BGP5UTL2(Y),U,2)_U_$$DATE^BGP5UTL((D))_U_(D)
  1.  .Q
  1.  I $P(BGPLAL,U,4)<$P(G,U,4) S BGPLAL=G
  1.  S (X,G)=0 F  S X=$O(^AMHPPROB("AC",P,X)) Q:X'=+X!(G)  D
  1.  .Q:$P(^AMHPPROB(X,0),U,12)'="A"
  1.  .Q:$P(^AMHPPROB(X,0),U,3)>EDATE
  1.  .Q:$P(^AMHPPROB(X,0),U,3)<BDATE
  1.  .S Y=$P(^AMHPPROB(X,0),U)
  1.  .I $$ICD^BGP5UTL2(Y,BGPT,9) S G=1_U_"BH PL "_Y_U_$$DATE^BGP5UTL($P(^AMHPPROB(X,0),U,3))_U_$P(^AMHPPROB(X,0),U,3) Q
  1.  .S Y=$P($G(^AMHPROB(Y,0)),U)
  1.  .I $D(^ATXAX(BGPJ,21,"B",Y)) S G=1_U_"BH PL "_Y_U_$$DATE^BGP5UTL($P(^AMHPPROB(X,0),U,3))_U_$P(^AMHPPROB(X,0),U,3) Q
  1.  .Q
  1.  I $P(BGPLAL,U,4)<$P(G,U,4) S BGPLAL=G
  1.  ;
  1.  K BGPG
  1.  S BGPG=$$LASTPRC^BGP5UTL1(P,"BGP ALCOHOL PROCEDURES",BDATE,EDATE)
  1.  I $P(BGPLAL,U,4)<$P(BGPG,U,3) S BGPLAL=1_U_"Proc "_$P(BGPG,U,2)_U_$$DATE^BGP5UTL($P(BGPG,U,3))_U_$P(BGPG,U,3)
  1.  Q BGPLAL
  1. ALSCRN(P,BDATE,EDATE,BGPALL) ;EP - alcohol hf or screening pov
  1.  NEW BGPG,%,E,BGPSC,V,BGPC,T,F,D,R,BGPCT,BGPX,BGPV,BGPVD,BGPIVD
  1.  K BGPALL
  1.  S BGPSC=0
  1. PCC ;check PCC first
  1.  S BGPCT=$O(^ATXAX("B","BGP ALCOHOL SCREENING 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.  .S BGPVD=$$VD^APCLV(BGPV)
  1.  .S BGPIVD=9999999-BGPVD
  1. PCCEX .;
  1.  .S E=0 F  S E=$O(^AUPNVXAM("AD",BGPV,E)) Q:E'=+E  D
  1.  ..S I=$P($G(^AUPNVXAM(E,0)),U,1)
  1.  ..Q:'I
  1.  ..Q:$P($G(^AUTTEXAM(I,0)),U,2)'=35
  1.  ..S BGPSC=BGPSC+1
  1.  ..S R=$$VAL^XBDIQ1(9000010.13,E,.04)
  1.  ..S BGPALL(BGPIVD,BGPSC)=1_"^Ex 35^"_$$DATE^BGP5UTL(BGPVD)_U_BGPVD_U_$S(R="POSITIVE":1,1:0)_U_R
  1. PCCHF .;
  1.  .S E=0 F  S E=$O(^AUPNVHF("AD",BGPV,E)) Q:E'=+E  D
  1.  ..S I=$P($G(^AUPNVHF(E,0)),U,1)
  1.  ..S I=$P($G(^AUTTHF(I,0)),U,1)
  1.  ..I I'="CAGE 0/4",I'="CAGE 1/4",I'="CAGE 2/4",I'="CAGE 3/4",I'="CAGE 4/4" Q  ;cage only
  1.  ..S R=$S(I["0":"NEGATIVE",1:"POSITIVE")
  1.  ..S BGPSC=BGPSC+1,BGPALL(BGPIVD,BGPSC)=1_"^HF "_I_"^"_$$DATE^BGP5UTL(BGPVD)_U_BGPVD_U_$S(R="POSITIVE":1,1:0)_U_R
  1. PCCDX .;
  1.  .S E=0 F  S E=$O(^AUPNVPOV("AD",BGPV,E)) Q:E'=+E  D
  1.  ..S I=$$VAL^XBDIQ1(9000010.07,E,.01)
  1.  ..I '$$ICD^BGP5UTL2($$VALI^XBDIQ1(9000010.07,E,.01),$O(^ATXAX("B","BGP ALCOHOL SCREEN DXS",0)),9) Q
  1.  ..S BGPSC=BGPSC+1,BGPALL(BGPIVD,BGPSC)=1_U_"POV "_I_U_$$DATE^BGP5UTL(BGPVD)_U_BGPVD
  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^BGP5UTL2(I,BGPCT,1)
  1.  ..S J=$P(^ICPT(I,0),U,1)
  1.  ..S R=$S($$ICD^BGP5UTL2(I,$O(^ATXAX("B","BGP ALCOHOL POSITIVE SCRN CPTS",0)),1):"POSITIVE",1:"")
  1.  ..S BGPSC=BGPSC+1
  1.  ..S BGPALL(BGPIVD,BGPSC)=1_"^CPT "_J_"^"_$$DATE^BGP5UTL(BGPVD)_U_BGPVD_U_$S(R="POSITIVE":1,1:0)_U_R
  1. PCCMEAS .;now add in v measurements
  1.  .S E=0 F  S E=$O(^AUPNVCPT("AD",BGPV,E)) Q:E'=+E  D
  1.  ..S I=$$VAL^XBDIQ1(9000010.01,E,.01)
  1.  ..I I'="AUDT",I'="AUDC",I'="CRFT" Q
  1.  ..S BGPSC=BGPSC+1
  1.  ..S R=$$VAL^XBDIQ1(9000010.01,E,.04)
  1.  ..S T=""
  1.  ..I I="AUDT",R>7 S T=1
  1.  ..I I="AUDC",$P(^DPT(P,0),U,2)="M",R>3 S T=1
  1.  ..I I="AUDC",$P(^DPT(P,0),U,2)="F",R>2 S T=1
  1.  ..I I="CRFT",R>1,R<7 S T=1
  1.  ..S BGPALL(BGPVD,BGPSC)=1_"^Meas "_I_"^"_$$DATE^BGP5UTL(BGPVD)_U_BGPVD_U_T_U_$S(T:"POSITIVE: "_R,1:"NEGATIVE: "_R)
  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.  .S BGPVD=9999999-$P(D,"."),BGPIVD=$P(D,".")
  1.  .S X=$P($G(^AMHREC(V,14)),U,3)
  1.  .I X="P"!(X="N") D
  1.  ..S R=$S(X="P":"POSITIVE",1:"NEGATIVE")
  1.  ..S BGPSC=BGPSC+1
  1.  ..S BGPALL(BGPIVD,BGPSC)=1_"^BH Ex^"_$$DATE^BGP5UTL(BGPVD)_U_BGPVD_U_$S(R="POSITIVE":1,1:0)_U_R
  1. BHHF .;
  1.  .S X=0 F  S X=$O(^AMHRHF("AD",V,X)) Q:X'=+X  D
  1.  ..S I=$P($G(^AMHRHF(X,0)),U,1)
  1.  ..Q:'I
  1.  ..S I=$P($G(^AUTTHF(I,0)),U,1)
  1.  ..I I'="CAGE 0/4",I'="CAGE 1/4",I'="CAGE 2/4",I'="CAGE 3/4",I'="CAGE 4/4" Q  ;cage only
  1.  ..S R=$S(I["0":"NEGATIVE",1:"POSITIVE")
  1.  ..S BGPSC=BGPSC+1,BGPALL(BGPIVD,BGPSC)=1_"^BH HF "_I_"^"_$$DATE^BGP5UTL(BGPVD)_U_BGPVD_U_$S(R="POSITIVE":1,1:0)_U_R
  1.  ..Q
  1. BHDX .;
  1.  .S X=0 F  S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X  D
  1.  ..S I=$$VAL^XBDIQ1(9002011.01,X,.01)
  1.  ..I '$$ICD^BGP5UTL2($$VALI^XBDIQ1(9002011.01,X,.01),$O(^ATXAX("B","BGP ALCOHOL SCREEN DXS",0)),9),I'="29.1" Q
  1.  ..S BGPSC=BGPSC+1,BGPALL(BGPIVD,BGPSC)=1_U_"BH POV "_I_U_$$DATE^BGP5UTL(BGPVD)_U_BGPVD
  1.  ..Q
  1. BHMEAS .;
  1.  .S X=0 F  S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X  D
  1.  ..S I=$$VAL^XBDIQ1(9002011.12,X,.01)
  1.  ..I I'="AUDT",I'="AUDC",I'="CRFT" Q
  1.  ..S BGPSC=BGPSC+1
  1.  ..S R=$$VAL^XBDIQ1(9002011.12,X,.04)
  1.  ..S T=""
  1.  ..I I="AUDT",R>7 S T=1
  1.  ..I I="AUDC",$P(^DPT(P,0),U,2)="M",R>3 S T=1
  1.  ..I I="AUDC",$P(^DPT(P,0),U,2)="F",R>2 S T=1
  1.  ..I I="CRFT",R>1,R<7 S T=1
  1.  ..S BGPALL(BGPIVD,BGPSC)=1_"^BH Meas "_I_"^"_$$DATE^BGP5UTL(BGPVD)_U_BGPVD_U_T_U_$S(T=1:"POSITIVE: "_R,1:"NEGATIVE")
  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(^AUPNVCPT(X,0)),U,1)
  1.  ..Q:'I
  1.  ..Q:'$$ICD^BGP5UTL2(I,BGPCT,1)
  1.  ..S J=$P(^ICPT(I,0),U,1)
  1.  ..S R=$S($$ICD^BGP5UTL2(I,$O(^ATXAX("B","BGP ALCOHOL POSITIVE SCRN CPTS",0)),1):"POSITIVE",1:"")
  1.  ..S BGPSC=BGPSC+1
  1.  ..S BGPALL(BGPIVD,BGPSC)=1_"^BH CPT "_J_"^"_$$DATE^BGP5UTL(BGPVD)_U_BGPVD_U_$S(R="POSITIVE":1,1:0)_U_R
  1.  ..Q
  1.  .Q
  1.  Q