Routine: APCM11E8

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

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)_";"

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

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))=""

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

APCM11E8.m