APCM13E8 ;IHS/CMI/LAB - IHS MU;
;;1.0;IHS MU PERFORMANCE REPORTS;**2,4,5,6**;MAR 26, 2012;Build 65
;;;;;;Build 3
TOTLAB ;EP - ep LAB
;SET ARRAY APCMLABS to APCMLABS(prov ien)=denom^numer
;IF DENOM =0 THEN PROVIDER EXCLUSION
NEW ID,C,Y,X,D,S,N,A,B,R,PAT,ED,APCMLAB,APCMX,APCML,PAR
S ED=9999999-APCMBDAT,ED=ED_".9999"
S SD=9999999-APCMEDAT
S C=0,N=0,PAT=""
S LABSNO=""
S T=$O(^ATXLAB("B","BGP PAP SMEAR TAX",0))
S PAT="" F S PAT=$O(^AUPNVSIT("AA",PAT)) Q:PAT'=+PAT D TOTLAB1
Q
TOTLAB1 ;
NEW APCMLAB,APCMLAB1
S APCMLAB="APCMLAB"
D ALLLAB(PAT,APCMBDAT,APCMEDAT,,,,.APCMLAB)
;reorder by IEN of v lab
K APCMLAB1
S APCMX=0 F S APCMX=$O(APCMLAB(APCMX)) Q:APCMX'=+APCMX D
.S V=$P(APCMLAB(APCMX),U,5)
.Q:'$D(^AUPNVSIT(V,0))
.Q:"AOSM"'[$P(^AUPNVSIT(V,0),U,7)
.S C=$$CLINIC^APCLV(V,"C")
.Q:C=30
.;Q:C=77 ;CASE MANAGEMENT
.;I C=76 Q ;no lab
.;I C=63 Q ;no radiology
.;I C=39 Q ;no pharmacy
.S Y=$P(APCMLAB(APCMX),U,4),APCMLAB1(Y)=APCMLAB(APCMX)
S Y=0 F S Y=$O(APCMLAB1(Y)) Q:Y'=+Y D
.Q:$P(APCMLAB1(Y),U,10)]"" ;already processed this one
.S R=$P($G(^AUPNVLAB(Y,12)),U,2)
.I 'R S $P(APCMLAB1(Y),U,10)="NO PROV EXCL" Q ;no ordering provider so skip it
.I '$D(APCMPRV(R)) S $P(APCMLAB1(Y),U,10)="NOT A PROV EXCL" Q ;not a provider of interest
.I $P($P($G(^AUPNVLAB(Y,12)),U,1),".")>APCMEDAT S $P(APCMLAB1(Y),U,10)="AFTER DT RANGE" Q
.I $P($G(^AUPNVLAB(Y,12)),U,1)]"",$P($P($G(^AUPNVLAB(Y,12)),U,1),".")<APCMBDAT S $P(APCMLAB1(Y),U,10)="BEFORE DT RANGE" Q ;COLLECTED BEFORE TIME PERIOD
.S A=$P(^AUPNVLAB(Y,0),U,1)
.I T,$D(^ATXLAB(T,21,"B",A)) S $P(APCMLAB1(Y),U,10)="PAP EXCL" Q ;it's a pap smear
.I $$UP^XLFSTR($P(^AUPNVLAB(Y,0),U,4))="CANC" S $P(APCMLAB1(Y),U,10)="CANC EXCL" Q
.;is this a panel and if so do panel check
.S PAR=$P($G(^AUPNVLAB(Y,12)),U,8)
.I PAR S $P(APCMLAB1(Y),U,10)="HAS PARENT SKIP/EXCL" Q ;has a parent, will deal with parent
.D SETDENL
.;now check numerator
.;if panel do panel check for 1 test that is resulted
.I $O(^LAB(60,A,2,0)) D PANEL Q
.Q:$P($G(^AUPNVLAB(Y,11)),U,9)'="R" ;if status not resulted it doesn't make the numerator
.I $$UP^XLFSTR($P(^AUPNVLAB(Y,0),U,4))="COMMENT",'$$HASCOM(Y) Q
.S $P(APCMLABS(R),U,2)=$P(APCMLABS(R),U,2)+1,$P(^TMP($J,"PATSRX",R,PAT),U,2)=$P($G(^TMP($J,"PATSRX",R,PAT)),U,2)+1 S ^TMP($J,"PATSRX",R,PAT,"ELEC",$$VAL^XBDIQ1(9000010.09,Y,1201)_" "_$$VAL^XBDIQ1(9000010.09,Y,.01))="" ;S N=N+G Q ;S N=N+G
.;S $P(APCMLABS(R),U,3)=$P(APCMLABS(R),U,3)_$$VAL^XBDIQ1(9000010.09,Y,.01)_":"_$$VAL^XBDIQ1(9000010.09,Y,.04)_";"
Q
PANEL ;
;find all children and find at least one with a result, if one found set numerator
NEW X,Z,G,P
S G=0
S X=0 F S X=$O(APCMLAB1(X)) Q:X'=+X!(G) D
.S P=$P($G(^AUPNVLAB(X,12)),U,8)
.I P'=Y Q ;not a member of this panel
.I $P($G(^AUPNVLAB(Y,11)),U,9)'="R" S $P(APCMLAB1(X),U,10)="NOT RESULTED" Q
.I $$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))="COMMENT",'$$HASCOM(X) S $P(APCMLAB1(X),U,10)="comment/no comments" Q
.S G=1
Q:'G
S $P(APCMLABS(R),U,2)=$P(APCMLABS(R),U,2)+1,$P(^TMP($J,"PATSRX",R,PAT),U,2)=$P($G(^TMP($J,"PATSRX",R,PAT)),U,2)+1 S ^TMP($J,"PATSRX",R,PAT,"ELEC",$$VAL^XBDIQ1(9000010.09,Y,1201)_" "_$$VAL^XBDIQ1(9000010.09,Y,.01))="" ;S N=N+G Q ;S N=N+G
Q
SETDENL ;
S $P(APCMLAB1(Y),U,10)=1 ;processed this test
I '$D(APCMLABS(R)) S APCMLABS(R)=""
S $P(APCMLABS(R),U,1)=$P(APCMLABS(R),U,1)+1,$P(^TMP($J,"PATSRX",R,PAT),U,1)=$P($G(^TMP($J,"PATSRX",R,PAT)),U,1)+1,^TMP($J,"PATSRX",R,PAT,"SCRIPTS",$$VAL^XBDIQ1(9000010.09,Y,1201)_" "_$$VAL^XBDIQ1(9000010.09,Y,.01))=""
Q
;
HASCOM(L) ;ARE THERE ANY COMMENTS
I '$D(^AUPNVLAB(L,21)) Q 0
NEW B,G
S G=0
S B=0 F S B=$O(^AUPNVLAB(L,21,B)) Q:B'=+B I ^AUPNVLAB(L,21,B,0)]"" S G=1 ;has comment
Q G
ALLLAB(P,BD,ED,T,LT,LN,A) ;EP
;P - patient
;BD - beginning date
;ED - ending date
;T - lab taxonomy
;LT - loinc taxonomy
;LN - lab test name
;return all lab tests that match in array A
;FORMAT: DATE^TEST NAME^RESULT^V LAB IEN^VISIT IEN
I '$G(LT) S LT=""
S LN=$G(LN)
S T=$G(T)
NEW D,V,G,X,J,B,E,C
S B=9999999-BD,C=0,E=9999999-ED ;get inverse date and begin at edate-1 and end when greater than begin date
S D=E-1,D=D_".9999" S G=0 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!($P(D,".")>B) D
.S X=0 F S X=$O(^AUPNVLAB("AE",P,D,X)) Q:X'=+X D
..S Y=0 F S Y=$O(^AUPNVLAB("AE",P,D,X,Y)) Q:Y'=+Y D
...I 'T,'LT,LN="" D SETLAB Q
...I T,$D(^ATXLAB(T,21,"B",X)) D SETLAB Q
...I LN]"",$$VAL^XBDIQ1(9000010.09,Y,.01)=LN D SETLAB Q
...Q:'LT
...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
...Q:'$$LOINC(J,LT)
...D SETLAB Q
...Q
..Q
.Q
Q
SETLAB ;
S C=C+1
S @A@(C)=(9999999-$P(D,"."))_"^"_$$VAL^XBDIQ1(9000010.09,Y,.01)_"^"_$$VAL^XBDIQ1(9000010.09,Y,.04)_"^"_Y_"^"_$P(^AUPNVLAB(Y,0),U,3)
Q
LOINC(A,LT,LI) ;
I '$G(LT),'$G(LI) Q "" ;no ien or taxonomy
S LI=$G(LI)
I A,LI,A=LI Q 1
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",LT,$D(^ATXAX(LT,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(LT,21,"B",%)) Q 1
Q ""
APCM13E8 ;IHS/CMI/LAB - IHS MU;
+1 ;;1.0;IHS MU PERFORMANCE REPORTS;**2,4,5,6**;MAR 26, 2012;Build 65
+2 ;;;;;;Build 3
TOTLAB ;EP - ep LAB
+1 ;SET ARRAY APCMLABS to APCMLABS(prov ien)=denom^numer
+2 ;IF DENOM =0 THEN PROVIDER EXCLUSION
+3 NEW ID,C,Y,X,D,S,N,A,B,R,PAT,ED,APCMLAB,APCMX,APCML,PAR
+4 SET ED=9999999-APCMBDAT
SET ED=ED_".9999"
+5 SET SD=9999999-APCMEDAT
+6 SET C=0
SET N=0
SET PAT=""
+7 SET LABSNO=""
+8 SET T=$ORDER(^ATXLAB("B","BGP PAP SMEAR TAX",0))
+9 SET PAT=""
FOR
SET PAT=$ORDER(^AUPNVSIT("AA",PAT))
IF PAT'=+PAT
QUIT
DO TOTLAB1
+10 QUIT
TOTLAB1 ;
+1 NEW APCMLAB,APCMLAB1
+2 SET APCMLAB="APCMLAB"
+3 DO ALLLAB(PAT,APCMBDAT,APCMEDAT,,,,.APCMLAB)
+4 ;reorder by IEN of v lab
+5 KILL APCMLAB1
+6 SET APCMX=0
FOR
SET APCMX=$ORDER(APCMLAB(APCMX))
IF APCMX'=+APCMX
QUIT
Begin DoDot:1
+7 SET V=$PIECE(APCMLAB(APCMX),U,5)
+8 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+9 IF "AOSM"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+10 SET C=$$CLINIC^APCLV(V,"C")
+11 IF C=30
QUIT
+12 ;Q:C=77 ;CASE MANAGEMENT
+13 ;I C=76 Q ;no lab
+14 ;I C=63 Q ;no radiology
+15 ;I C=39 Q ;no pharmacy
+16 SET Y=$PIECE(APCMLAB(APCMX),U,4)
SET APCMLAB1(Y)=APCMLAB(APCMX)
End DoDot:1
+17 SET Y=0
FOR
SET Y=$ORDER(APCMLAB1(Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+18 ;already processed this one
IF $PIECE(APCMLAB1(Y),U,10)]""
QUIT
+19 SET R=$PIECE($GET(^AUPNVLAB(Y,12)),U,2)
+20 ;no ordering provider so skip it
IF 'R
SET $PIECE(APCMLAB1(Y),U,10)="NO PROV EXCL"
QUIT
+21 ;not a provider of interest
IF '$DATA(APCMPRV(R))
SET $PIECE(APCMLAB1(Y),U,10)="NOT A PROV EXCL"
QUIT
+22 IF $PIECE($PIECE($GET(^AUPNVLAB(Y,12)),U,1),".")>APCMEDAT
SET $PIECE(APCMLAB1(Y),U,10)="AFTER DT RANGE"
QUIT
+23 ;COLLECTED BEFORE TIME PERIOD
IF $PIECE($GET(^AUPNVLAB(Y,12)),U,1)]""
IF $PIECE($PIECE($GET(^AUPNVLAB(Y,12)),U,1),".")<APCMBDAT
SET $PIECE(APCMLAB1(Y),U,10)="BEFORE DT RANGE"
QUIT
+24 SET A=$PIECE(^AUPNVLAB(Y,0),U,1)
+25 ;it's a pap smear
IF T
IF $DATA(^ATXLAB(T,21,"B",A))
SET $PIECE(APCMLAB1(Y),U,10)="PAP EXCL"
QUIT
+26 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(Y,0),U,4))="CANC"
SET $PIECE(APCMLAB1(Y),U,10)="CANC EXCL"
QUIT
+27 ;is this a panel and if so do panel check
+28 SET PAR=$PIECE($GET(^AUPNVLAB(Y,12)),U,8)
+29 ;has a parent, will deal with parent
IF PAR
SET $PIECE(APCMLAB1(Y),U,10)="HAS PARENT SKIP/EXCL"
QUIT
+30 DO SETDENL
+31 ;now check numerator
+32 ;if panel do panel check for 1 test that is resulted
+33 IF $ORDER(^LAB(60,A,2,0))
DO PANEL
QUIT
+34 ;if status not resulted it doesn't make the numerator
IF $PIECE($GET(^AUPNVLAB(Y,11)),U,9)'="R"
QUIT
+35 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(Y,0),U,4))="COMMENT"
IF '$$HASCOM(Y)
QUIT
+36 ;S N=N+G Q ;S N=N+G
SET $PIECE(APCMLABS(R),U,2)=$PIECE(APCMLABS(R),U,2)+1
SET $PIECE(^TMP($JOB,"PATSRX",R,PAT),U,2)=$PIECE($GET(^TMP($JOB,"PATSRX",R,PAT)),U,2)+1
SET ^TMP($JOB,"PATSRX",R,PAT,"ELEC",$$VAL^XBDIQ1(9000010.09,Y,1201)_" "_$$VAL^XBDIQ1(9000010.09,Y,.01))=""
+37 ;S $P(APCMLABS(R),U,3)=$P(APCMLABS(R),U,3)_$$VAL^XBDIQ1(9000010.09,Y,.01)_":"_$$VAL^XBDIQ1(9000010.09,Y,.04)_";"
End DoDot:1
+38 QUIT
PANEL ;
+1 ;find all children and find at least one with a result, if one found set numerator
+2 NEW X,Z,G,P
+3 SET G=0
+4 SET X=0
FOR
SET X=$ORDER(APCMLAB1(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+5 SET P=$PIECE($GET(^AUPNVLAB(X,12)),U,8)
+6 ;not a member of this panel
IF P'=Y
QUIT
+7 IF $PIECE($GET(^AUPNVLAB(Y,11)),U,9)'="R"
SET $PIECE(APCMLAB1(X),U,10)="NOT RESULTED"
QUIT
+8 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))="COMMENT"
IF '$$HASCOM(X)
SET $PIECE(APCMLAB1(X),U,10)="comment/no comments"
QUIT
+9 SET G=1
End DoDot:1
+10 IF 'G
QUIT
+11 ;S N=N+G Q ;S N=N+G
SET $PIECE(APCMLABS(R),U,2)=$PIECE(APCMLABS(R),U,2)+1
SET $PIECE(^TMP($JOB,"PATSRX",R,PAT),U,2)=$PIECE($GET(^TMP($JOB,"PATSRX",R,PAT)),U,2)+1
SET ^TMP($JOB,"PATSRX",R,PAT,"ELEC",$$VAL^XBDIQ1(9000010.09,Y,1201)_" "_$$VAL^XBDIQ1(9000010.09,Y,.01))=""
+12 QUIT
SETDENL ;
+1 ;processed this test
SET $PIECE(APCMLAB1(Y),U,10)=1
+2 IF '$DATA(APCMLABS(R))
SET APCMLABS(R)=""
+3 SET $PIECE(APCMLABS(R),U,1)=$PIECE(APCMLABS(R),U,1)+1
SET $PIECE(^TMP($JOB,"PATSRX",R,PAT),U,1)=$PIECE($GET(^TMP($JOB,"PATSRX",R,PAT)),U,1)+1
SET ^TMP($JOB,"PATSRX",R,PAT,"SCRIPTS",$$VAL^XBDIQ1(9000010.09,Y,1201)_" "_$$VAL^XBDIQ1(9000010.09,Y,.01))=""
+4 QUIT
+5 ;
HASCOM(L) ;ARE THERE ANY COMMENTS
+1 IF '$DATA(^AUPNVLAB(L,21))
QUIT 0
+2 NEW B,G
+3 SET G=0
+4 ;has comment
SET B=0
FOR
SET B=$ORDER(^AUPNVLAB(L,21,B))
IF B'=+B
QUIT
IF ^AUPNVLAB(L,21,B,0)]""
SET G=1
+5 QUIT G
ALLLAB(P,BD,ED,T,LT,LN,A) ;EP
+1 ;P - patient
+2 ;BD - beginning date
+3 ;ED - ending date
+4 ;T - lab taxonomy
+5 ;LT - loinc taxonomy
+6 ;LN - lab test name
+7 ;return all lab tests that match in array A
+8 ;FORMAT: DATE^TEST NAME^RESULT^V LAB IEN^VISIT IEN
+9 IF '$GET(LT)
SET LT=""
+10 SET LN=$GET(LN)
+11 SET T=$GET(T)
+12 NEW D,V,G,X,J,B,E,C
+13 ;get inverse date and begin at edate-1 and end when greater than begin date
SET B=9999999-BD
SET C=0
SET E=9999999-ED
+14 SET D=E-1
SET D=D_".9999"
SET G=0
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!($PIECE(D,".")>B)
QUIT
Begin DoDot:1
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,X))
IF X'=+X
QUIT
Begin DoDot:2
+16 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AE",P,D,X,Y))
IF Y'=+Y
QUIT
Begin DoDot:3
+17 IF 'T
IF 'LT
IF LN=""
DO SETLAB
QUIT
+18 IF T
IF $DATA(^ATXLAB(T,21,"B",X))
DO SETLAB
QUIT
+19 IF LN]""
IF $$VAL^XBDIQ1(9000010.09,Y,.01)=LN
DO SETLAB
QUIT
+20 IF 'LT
QUIT
+21 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
IF J=""
QUIT
+22 IF '$$LOINC(J,LT)
QUIT
+23 DO SETLAB
QUIT
+24 QUIT
End DoDot:3
+25 QUIT
End DoDot:2
+26 QUIT
End DoDot:1
+27 QUIT
SETLAB ;
+1 SET C=C+1
+2 SET @A@(C)=(9999999-$PIECE(D,"."))_"^"_$$VAL^XBDIQ1(9000010.09,Y,.01)_"^"_$$VAL^XBDIQ1(9000010.09,Y,.04)_"^"_Y_"^"_$PIECE(^AUPNVLAB(Y,0),U,3)
+3 QUIT
LOINC(A,LT,LI) ;
+1 ;no ien or taxonomy
IF '$GET(LT)
IF '$GET(LI)
QUIT ""
+2 SET LI=$GET(LI)
+3 IF A
IF LI
IF A=LI
QUIT 1
+4 NEW %
+5 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+6 IF %]""
IF LT
IF $DATA(^ATXAX(LT,21,"B",%))
QUIT 1
+7 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+8 IF $DATA(^ATXAX(LT,21,"B",%))
QUIT 1
+9 QUIT ""
