APCM11E8 ;IHS/CMI/LAB - IHS MU; ; 11 Feb 2011 11:13 PM
;;1.0;IHS MU PERFORMANCE REPORTS;**1,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^APCM13E8(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
APCM11E8 ;IHS/CMI/LAB - IHS MU; ; 11 Feb 2011 11:13 PM
+1 ;;1.0;IHS MU PERFORMANCE REPORTS;**1,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^APCM13E8(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
