BGP7D21A ; IHS/CMI/LAB - measure 6 ;
;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
;
LOINC(A,B) ;EP
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
BLINDPL(P,EDATE) ;EP
NEW X,T,G,R,L,Y,C
S X=$$PLTAXND^BGP7DU(P,"BGP BILATERAL BLINDNESS DXS",EDATE)
I X Q 1
S X=$$IPLSNOND^BGP7DU(P,"PXRM BGP BILAT BLINDNESS",EDATE)
I X Q 1
S T="PXRM BGP BLINDNESS UNSPECIFIED" ;CODE WITH LATERALITY=BILATERAL
;LOOP PROBLEM LIST
S (X,G,R,L)=""
F S X=$O(^AUPNPROB("APCT",P,X)) Q:X=""!(G) D
.S Y=0 F S Y=$O(^AUPNPROB("APCT",P,X,Y)) Q:Y'=+Y!(G) D
..Q:'$D(^AUPNPROB(Y,0))
..Q:$P(^AUPNPROB(Y,0),U,12)="D" ;deleted
..Q:'$D(^XTMP("BGPSNOMEDSUBSET",$J,T,X))
..I EDATE,$P(^AUPNPROB(Y,0),U,13)>EDATE Q ;if there is a doo and it is after report period skip
..I $P(^AUPNPROB(Y,0),U,13)="",EDATE,$P(^AUPNPROB(Y,0),U,8)>EDATE Q ;no doo, entered after report period, skip
..;IS LATERALITY BILATERAL:
..S C=$$VAL^XBDIQ1(9000011,Y,.22)
..I $$UP^XLFSTR(C)["BILATERAL" S G=1_U_"Problem List: "_X Q ;$$CONCPT^AUPNVUTL(X)
..I $$UP^XLFSTR(C)["LEFT" S L=1
..I $$UP^XLFSTR(C)["RIGHT" S R=1
I G Q G
I R,L Q 1_U_"Problem List: "_X
;NOW CHECK RIGHT AND LEFT SNOMED SUBSETS
NEW TR,TL
I 'R D
.S TR="PXRM BGP RIGHT EYE BLIND"
.;LOOP PROBLEM LIST
.S (X,G)=""
.F S X=$O(^AUPNPROB("APCT",P,X)) Q:X=""!(G) D
..S Y=0 F S Y=$O(^AUPNPROB("APCT",P,X,Y)) Q:Y'=+Y!(G) D
...Q:'$D(^AUPNPROB(Y,0))
...Q:$P(^AUPNPROB(Y,0),U,12)="D" ;deleted
...Q:'$D(^XTMP("BGPSNOMEDSUBSET",$J,TR,X))
...I EDATE,$P(^AUPNPROB(Y,0),U,13)>EDATE Q ;if there is a doo and it is after report period skip
...I $P(^AUPNPROB(Y,0),U,13)="",EDATE,$P(^AUPNPROB(Y,0),U,8)>EDATE Q ;no doo, entered after report period, skip
...S R=1
I R,L Q 1_U_"Problem List: "_X
I 'L D
.S TL="PXRM BGP LEFT EYE BLIND"
.;LOOP PROBLEM LIST
.S (X,G)=""
.F S X=$O(^AUPNPROB("APCT",P,X)) Q:X=""!(G) D
..S Y=0 F S Y=$O(^AUPNPROB("APCT",P,X,Y)) Q:Y'=+Y!(G) D
...Q:'$D(^AUPNPROB(Y,0))
...Q:$P(^AUPNPROB(Y,0),U,12)="D" ;deleted
...Q:'$D(^XTMP("BGPSNOMEDSUBSET",$J,TL,X))
...I EDATE,$P(^AUPNPROB(Y,0),U,13)>EDATE Q ;if there is a doo and it is after report period skip
...I $P(^AUPNPROB(Y,0),U,13)="",EDATE,$P(^AUPNPROB(Y,0),U,8)>EDATE Q ;no doo, entered after report period, skip
...S L=1
I R,L Q 1_U_"Problem List: "_X
Q ""
CHDPL(P,EDATE) ;EP - is dx on problem list as either active or inactive?
NEW T,T1,T2,T3,SN1,SN2,SN3,SN4
S T=$O(^ATXAX("B","BGP CHD DXS",0))
S T1=$O(^ATXAX("B","BGP AMI DXS PAMT",0))
S T2=$O(^ATXAX("B","BGP IVD DXS",0))
S T3=$O(^ATXAX("B","BGP TIA DXS",0))
S SN1="PXRM ISCHEMIC HEART DISEASE"
S SN2="PXRM BGP AMI"
S SN3="PXRM BGP IVD"
S SN4="PXRM BGP ISCHEMIC STROKE TIA"
PL ;
NEW X,Y,I,S
S (X,Y,I)=0
F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) D
.Q:'$D(^AUPNPROB(X,0))
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.S Y=$P(^AUPNPROB(X,0),U)
.I EDATE,$P(^AUPNPROB(X,0),U,13)>EDATE Q ;if there is a doo and it is after report period skip
.I $P(^AUPNPROB(X,0),U,13)="",EDATE,$P(^AUPNPROB(X,0),U,8)>EDATE Q ;no doo, entered after report period, skip
.S S=$$VAL^XBDIQ1(9000011,X,80001) I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN1,S)) S I=1 Q
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN2,S)) S I=1 Q
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN3,S)) S I=1 Q
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,SN4,S)) S I=1 Q
.I $$ICD^BGP7UTL2(Y,T,9) S I=1 Q ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
.I $$ICD^BGP7UTL2(Y,T1,9) S I=1 Q ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
.I $$ICD^BGP7UTL2(Y,T2,9) S I=1 Q ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
.I $$ICD^BGP7UTL2(Y,T3,9) S I=1 Q ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
.Q
Q I
BGP7D21A ; IHS/CMI/LAB - measure 6 ;
+1 ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
+2 ;
LOINC(A,B) ;EP
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
BLINDPL(P,EDATE) ;EP
+1 NEW X,T,G,R,L,Y,C
+2 SET X=$$PLTAXND^BGP7DU(P,"BGP BILATERAL BLINDNESS DXS",EDATE)
+3 IF X
QUIT 1
+4 SET X=$$IPLSNOND^BGP7DU(P,"PXRM BGP BILAT BLINDNESS",EDATE)
+5 IF X
QUIT 1
+6 ;CODE WITH LATERALITY=BILATERAL
SET T="PXRM BGP BLINDNESS UNSPECIFIED"
+7 ;LOOP PROBLEM LIST
+8 SET (X,G,R,L)=""
+9 FOR
SET X=$ORDER(^AUPNPROB("APCT",P,X))
IF X=""!(G)
QUIT
Begin DoDot:1
+10 SET Y=0
FOR
SET Y=$ORDER(^AUPNPROB("APCT",P,X,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNPROB(Y,0))
QUIT
+12 ;deleted
IF $PIECE(^AUPNPROB(Y,0),U,12)="D"
QUIT
+13 IF '$DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,T,X))
QUIT
+14 ;if there is a doo and it is after report period skip
IF EDATE
IF $PIECE(^AUPNPROB(Y,0),U,13)>EDATE
QUIT
+15 ;no doo, entered after report period, skip
IF $PIECE(^AUPNPROB(Y,0),U,13)=""
IF EDATE
IF $PIECE(^AUPNPROB(Y,0),U,8)>EDATE
QUIT
+16 ;IS LATERALITY BILATERAL:
+17 SET C=$$VAL^XBDIQ1(9000011,Y,.22)
+18 ;$$CONCPT^AUPNVUTL(X)
IF $$UP^XLFSTR(C)["BILATERAL"
SET G=1_U_"Problem List: "_X
QUIT
+19 IF $$UP^XLFSTR(C)["LEFT"
SET L=1
+20 IF $$UP^XLFSTR(C)["RIGHT"
SET R=1
End DoDot:2
End DoDot:1
+21 IF G
QUIT G
+22 IF R
IF L
QUIT 1_U_"Problem List: "_X
+23 ;NOW CHECK RIGHT AND LEFT SNOMED SUBSETS
+24 NEW TR,TL
+25 IF 'R
Begin DoDot:1
+26 SET TR="PXRM BGP RIGHT EYE BLIND"
+27 ;LOOP PROBLEM LIST
+28 SET (X,G)=""
+29 FOR
SET X=$ORDER(^AUPNPROB("APCT",P,X))
IF X=""!(G)
QUIT
Begin DoDot:2
+30 SET Y=0
FOR
SET Y=$ORDER(^AUPNPROB("APCT",P,X,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:3
+31 IF '$DATA(^AUPNPROB(Y,0))
QUIT
+32 ;deleted
IF $PIECE(^AUPNPROB(Y,0),U,12)="D"
QUIT
+33 IF '$DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,TR,X))
QUIT
+34 ;if there is a doo and it is after report period skip
IF EDATE
IF $PIECE(^AUPNPROB(Y,0),U,13)>EDATE
QUIT
+35 ;no doo, entered after report period, skip
IF $PIECE(^AUPNPROB(Y,0),U,13)=""
IF EDATE
IF $PIECE(^AUPNPROB(Y,0),U,8)>EDATE
QUIT
+36 SET R=1
End DoDot:3
End DoDot:2
End DoDot:1
+37 IF R
IF L
QUIT 1_U_"Problem List: "_X
+38 IF 'L
Begin DoDot:1
+39 SET TL="PXRM BGP LEFT EYE BLIND"
+40 ;LOOP PROBLEM LIST
+41 SET (X,G)=""
+42 FOR
SET X=$ORDER(^AUPNPROB("APCT",P,X))
IF X=""!(G)
QUIT
Begin DoDot:2
+43 SET Y=0
FOR
SET Y=$ORDER(^AUPNPROB("APCT",P,X,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:3
+44 IF '$DATA(^AUPNPROB(Y,0))
QUIT
+45 ;deleted
IF $PIECE(^AUPNPROB(Y,0),U,12)="D"
QUIT
+46 IF '$DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,TL,X))
QUIT
+47 ;if there is a doo and it is after report period skip
IF EDATE
IF $PIECE(^AUPNPROB(Y,0),U,13)>EDATE
QUIT
+48 ;no doo, entered after report period, skip
IF $PIECE(^AUPNPROB(Y,0),U,13)=""
IF EDATE
IF $PIECE(^AUPNPROB(Y,0),U,8)>EDATE
QUIT
+49 SET L=1
End DoDot:3
End DoDot:2
End DoDot:1
+50 IF R
IF L
QUIT 1_U_"Problem List: "_X
+51 QUIT ""
CHDPL(P,EDATE) ;EP - is dx on problem list as either active or inactive?
+1 NEW T,T1,T2,T3,SN1,SN2,SN3,SN4
+2 SET T=$ORDER(^ATXAX("B","BGP CHD DXS",0))
+3 SET T1=$ORDER(^ATXAX("B","BGP AMI DXS PAMT",0))
+4 SET T2=$ORDER(^ATXAX("B","BGP IVD DXS",0))
+5 SET T3=$ORDER(^ATXAX("B","BGP TIA DXS",0))
+6 SET SN1="PXRM ISCHEMIC HEART DISEASE"
+7 SET SN2="PXRM BGP AMI"
+8 SET SN3="PXRM BGP IVD"
+9 SET SN4="PXRM BGP ISCHEMIC STROKE TIA"
PL ;
+1 NEW X,Y,I,S
+2 SET (X,Y,I)=0
+3 FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+4 IF '$DATA(^AUPNPROB(X,0))
QUIT
+5 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+7 SET Y=$PIECE(^AUPNPROB(X,0),U)
+8 ;if there is a doo and it is after report period skip
IF EDATE
IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
QUIT
+9 ;no doo, entered after report period, skip
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF EDATE
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+10 SET S=$$VAL^XBDIQ1(9000011,X,80001)
IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,SN1,S))
SET I=1
QUIT
+11 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,SN2,S))
SET I=1
QUIT
+12 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,SN3,S))
SET I=1
QUIT
+13 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,SN4,S))
SET I=1
QUIT
+14 ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
IF $$ICD^BGP7UTL2(Y,T,9)
SET I=1
QUIT
+15 ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
IF $$ICD^BGP7UTL2(Y,T1,9)
SET I=1
QUIT
+16 ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
IF $$ICD^BGP7UTL2(Y,T2,9)
SET I=1
QUIT
+17 ;_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)
IF $$ICD^BGP7UTL2(Y,T3,9)
SET I=1
QUIT
+18 QUIT
End DoDot:1
+19 QUIT I
