Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCM13E8

APCM13E8.m

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