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

BGP8D21A.m

Go to the documentation of this file.
  1. BGP8D21A ; IHS/CMI/LAB - measure 6 ;
  1. ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
  1. ;
  1. LOINC(A,B) ;EP
  1. NEW %
  1. S %=$P($G(^LAB(95.3,A,9999999)),U,2)
  1. I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
  1. S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1. I $D(^ATXAX(B,21,"B",%)) Q 1
  1. Q ""
  1. EYEENUC(P,EDATE) ;EP
  1. NEW X,T,G,R,L,Y,C,RI,LF,BGPX,C,Y,M
  1. ;first check for PROCEDURES
  1. S BDATE=$$DOB^AUPNPAT(P)
  1. S RI=$$LASTPRC^BGP8UTL1(P,"BGP RIGHT EYE ENUCLEATION PROC",BDATE,EDATE)
  1. S LF=$$LASTPRC^BGP8UTL1(P,"BGP LEFT EYE ENUCLEATION PROCS",BDATE,EDATE)
  1. I RI,LF Q 1
  1. ;NOW CHECK CPTS
  1. ;ONE WITH MODIFER 50 09950 OR 2 AT LEAST 14 DAYS APART
  1. ;check cpt codes for bilateral
  1. ;loop through all cpt codes up to Edate and if any match quit
  1. S (X,Y,Z,G)=0 K BGPX
  1. S T=$O(^ATXAX("B","BGP EYE ENUCLEATION CPTS",0))
  1. I T S %="" D I %]"" Q 1
  1. .S Y=0 F S Y=$O(^AUPNVCPT("AC",P,Y)) Q:Y'=+Y!(%]"") D
  1. ..S D=$P($G(^AUPNVCPT(Y,0)),U,3)
  1. ..Q:D=""
  1. ..S D=$P($P($G(^AUPNVSIT(D,0)),U),".") ;date done
  1. ..Q:D=""
  1. ..I D>EDATE Q
  1. ..S X=$P(^AUPNVCPT(Y,0),U)
  1. ..Q:'$$ICD^BGP8UTL2(X,T,1)
  1. ..S BGPX(D)=""
  1. ..I ^DD(9000010.18,.08,0)["AUTTCMOD" S M=$P(^AUPNVCPT(Y,0),U,8) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
  1. ..I ^DD(9000010.18,.09,0)["AUTTCMOD" S M=$P(^AUPNVCPT(Y,0),U,9) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
  1. ..I ^DD(9000010.18,.08,0)["DIC(81.3" S M=$P(^AUPNVCPT(Y,0),U,8) I M S M=$P($G(^DIC(81.3,M,0)),U) I M=50 S %=1
  1. ..I ^DD(9000010.18,.09,0)["DIC(81.3" S M=$P(^AUPNVCPT(Y,0),U,9) I M S M=$P($G(^DIC(81.3,M,0)),U) I M=50 S %=1
  1. ..Q:%
  1. .Q
  1. ; now check tran codes
  1. I T,$D(^AUPNVTC("AC",P)) S %="" D I %]"" Q 1
  1. .S E=0 F S E=$O(^AUPNVTC("AC",P,E)) Q:E'=+E!(%]"") D
  1. ..S D=$P($G(^AUPNVTC(E,0)),U,3) Q:'D S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
  1. ..Q:'$$ICD^BGP8UTL2($P(^AUPNVTC(E,0),U,7),T,1)
  1. ..I D>EDATE Q
  1. ..S BGPX(D)=""
  1. ..I '$D(^DIC(81.3,0)) S M=$P(^AUPNVTC(E,0),U,12) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
  1. ..I '$D(^DIC(81.3,0)) S M=$P(^AUPNVTC(E,0),U,15) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1
  1. ..I $D(^DIC(81.3,0)) S M=$P(^AUPNVTC(E,0),U,12) I M S M=$P($G(^DIC(81.3,M,0)),U) I M=50 S %=1
  1. ..I $D(^DIC(81.3,0)) S M=$P(^AUPNVTC(E,0),U,15) I M S M=$P($G(^DIC(81.3,M,0)),U) I M=50 S %=1
  1. ..Q:%
  1. ..S M=""
  1. ..Q
  1. .Q
  1. ;see if 2 on different dates 14 DAYS APART
  1. S (X,Y)="",C=0 F S X=$O(BGPX(X)) Q:X'=+X S C=C+1 D
  1. .I C=1 S Y=X Q
  1. .I $$FMDIFF^XLFDT(X,Y)<14 K BGPX(X) Q
  1. .S Y=X
  1. ;count
  1. S C=0,X=0 F S X=$O(BGPX(X)) Q:X'=+X S C=C+1
  1. I C>1 Q 1
  1. Q ""
  1. BLINDPL(P,EDATE) ;EP
  1. NEW X,T,G,R,L,Y,C
  1. S X=$$PLTAXND^BGP8DU(P,"BGP BILATERAL BLINDNESS DXS",EDATE)
  1. I X Q 1
  1. S X=$$IPLSNOND^BGP8DU(P,"PXRM BGP BILAT BLINDNESS",EDATE)
  1. I X Q 1
  1. S T="PXRM BGP BLINDNESS UNSPECIFIED" ;CODE WITH LATERALITY=BILATERAL
  1. ;LOOP PROBLEM LIST
  1. S (X,G,R,L)=""
  1. F S X=$O(^AUPNPROB("APCT",P,X)) Q:X=""!(G) D
  1. .S Y=0 F S Y=$O(^AUPNPROB("APCT",P,X,Y)) Q:Y'=+Y!(G) D
  1. ..Q:'$D(^AUPNPROB(Y,0))
  1. ..Q:$P(^AUPNPROB(Y,0),U,12)="D" ;deleted
  1. ..Q:'$D(^XTMP("BGPSNOMEDSUBSET",$J,T,X))
  1. ..I EDATE,$P(^AUPNPROB(Y,0),U,13)>EDATE Q ;if there is a doo and it is after report period skip
  1. ..I $P(^AUPNPROB(Y,0),U,13)="",EDATE,$P(^AUPNPROB(Y,0),U,8)>EDATE Q ;no doo, entered after report period, skip
  1. ..;IS LATERALITY BILATERAL:
  1. ..S C=$$VAL^XBDIQ1(9000011,Y,.22)
  1. ..I $$UP^XLFSTR(C)["BILATERAL" S G=1_U_"Problem List: "_X Q ;$$CONCPT^AUPNVUTL(X)
  1. ..I $$UP^XLFSTR(C)["LEFT" S L=1
  1. ..I $$UP^XLFSTR(C)["RIGHT" S R=1
  1. I G Q G
  1. I R,L Q 1_U_"Problem List: "_X
  1. ;NOW CHECK RIGHT AND LEFT SNOMED SUBSETS
  1. NEW TR,TL
  1. I 'R D
  1. .S TR="PXRM BGP RIGHT EYE BLIND"
  1. .;LOOP PROBLEM LIST
  1. .S (X,G)=""
  1. .F S X=$O(^AUPNPROB("APCT",P,X)) Q:X=""!(G) D
  1. ..S Y=0 F S Y=$O(^AUPNPROB("APCT",P,X,Y)) Q:Y'=+Y!(G) D
  1. ...Q:'$D(^AUPNPROB(Y,0))
  1. ...Q:$P(^AUPNPROB(Y,0),U,12)="D" ;deleted
  1. ...Q:'$D(^XTMP("BGPSNOMEDSUBSET",$J,TR,X))
  1. ...I EDATE,$P(^AUPNPROB(Y,0),U,13)>EDATE Q ;if there is a doo and it is after report period skip
  1. ...I $P(^AUPNPROB(Y,0),U,13)="",EDATE,$P(^AUPNPROB(Y,0),U,8)>EDATE Q ;no doo, entered after report period, skip
  1. ...S R=1
  1. I R,L Q 1_U_"Problem List: "_X
  1. I 'L D
  1. .S TL="PXRM BGP LEFT EYE BLIND"
  1. .;LOOP PROBLEM LIST
  1. .S (X,G)=""
  1. .F S X=$O(^AUPNPROB("APCT",P,X)) Q:X=""!(G) D
  1. ..S Y=0 F S Y=$O(^AUPNPROB("APCT",P,X,Y)) Q:Y'=+Y!(G) D
  1. ...Q:'$D(^AUPNPROB(Y,0))
  1. ...Q:$P(^AUPNPROB(Y,0),U,12)="D" ;deleted
  1. ...Q:'$D(^XTMP("BGPSNOMEDSUBSET",$J,TL,X))
  1. ...I EDATE,$P(^AUPNPROB(Y,0),U,13)>EDATE Q ;if there is a doo and it is after report period skip
  1. ...I $P(^AUPNPROB(Y,0),U,13)="",EDATE,$P(^AUPNPROB(Y,0),U,8)>EDATE Q ;no doo, entered after report period, skip
  1. ...S L=1
  1. I R,L Q 1_U_"Problem List: "_X
  1. Q ""
  1. CHDPL(P,EDATE) ;EP - is dx on problem list as either active or inactive?
  1. NEW T,T1,T2,T3,SN1,SN2,SN3,SN4,T4,T5,SN5,SN6,SN7,SN8
  1. S T=$O(^ATXAX("B","BGP CHD DXS",0))
  1. S T1=$O(^ATXAX("B","BGP AMI DXS PAMT",0))
  1. S T2=$O(^ATXAX("B","BGP IVD DXS",0))
  1. S T3=$O(^ATXAX("B","BGP TIA DXS",0))
  1. S T4=$O(^ATXAX("B","BGP ARTERIAL DISEASE DXS",0))
  1. S SN1="PXRM ISCHEMIC HEART DISEASE"
  1. S SN2="PXRM BGP AMI"
  1. S SN3="PXRM BGP IVD"
  1. S SN4="PXRM BGP ISCHEMIC STROKE TIA"
  1. S SN5="PXRM BGP ARTERIAL DISEASE"
  1. S SN6="PXRM BGP CABG"
  1. S SN7="PXRM BGP PCI"
  1. S SN8="PXRM BGP CAROTID INTERVENTION"
  1. PL ;
  1. NEW X,Y,I,S
  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. .Q:$P(^AUPNPROB(X,0),U,12)="I"
  1. .S Y=$P(^AUPNPROB(X,0),U)
  1. .I EDATE,$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)="",EDATE,$P(^AUPNPROB(X,0),U,8)>EDATE Q ;no doo, entered after report period, skip
  1. .S S=$$VAL^XBDIQ1(9000011,X,80001)
  1. .I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN1,S)) S I=1 Q
  1. .I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN2,S)) S I=1 Q
  1. .I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN3,S)) S I=1 Q
  1. .I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN4,S)) S I=1 Q
  1. .I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN5,S)) S I=1 Q
  1. .I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN6,S)) S I=1 Q
  1. .I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN7,S)) S I=1 Q
  1. .I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN8,S)) S I=1 Q
  1. .I $$ICD^BGP8UTL2(Y,T,9) S I=1 Q ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
  1. .I $$ICD^BGP8UTL2(Y,T1,9) S I=1 Q ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
  1. .I $$ICD^BGP8UTL2(Y,T2,9) S I=1 Q ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
  1. .I $$ICD^BGP8UTL2(Y,T3,9) S I=1 Q ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
  1. .I $$ICD^BGP8UTL2(Y,T4,9) S I=1 Q ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
  1. .Q
  1. Q I
  1. HEPA(P,BDATE,EDATE) ;
  1. ;EP
  1. NEW BGPG,E,Y,X
  1. ;S BDATE=$$DOB^AUPNPAT(P)
  1. K BGPG
  1. S Y="BGPG("
  1. S X=P_"^LAST DX [BGP HEPATITIS A EVIDENCE;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1. I $D(BGPG(1)) Q 1
  1. I $$PLTAXND^BGP8DU(P,"BGP HEPATITIS A EVIDENCE",EDATE) Q 1
  1. I $$IPLSNOND^BGP8DU(P,"PXRM BGP HEPATITIS A",EDATE) Q 1
  1. Q 0
  1. HEPB(P,BDATE,EDATE) ;
  1. ;EP
  1. NEW BGPG,E,Y,X
  1. ;S BDATE=$$DOB^AUPNPAT(P)
  1. K BGPG
  1. S Y="BGPG("
  1. S X=P_"^LAST DX [BGP HEP EVIDENCE;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1. I $D(BGPG(1)) Q 1
  1. I $$PLTAXND^BGP8DU(P,"BGP HEP EVIDENCE",EDATE) Q 1
  1. I $$IPLSNOND^BGP8DU(P,"PXRM BGP HEPATITIS B",EDATE) Q 1
  1. Q 0