- 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
