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

APCM25EB.m

Go to the documentation of this file. 
  1. APCM25EB ;IHS/CMI/LAB - IHS MU;  ; 30 Jul 2013  8:15 AM
  1.  ;;1.0;MU PERFORMANCE REPORTS;**7**;MAR 26, 2012;Build 15
  1. EPRES ;EP - CALCULATE EPRESCRIBING
  1.  ;for each provider or for the facility count all prescriptions that meet criteria and if it is not written it meets numerator
  1.  K ^TMP($J,"PATSRX")
  1.  K APCMRXS
  1.  D TOTRX
  1.  NEW APCMP,N,F
  1.  S (APCMD1,APCMN1)=0
  1.  I APCMRPTT=1 S APCMP=0 F  S APCMP=$O(APCMPRV(APCMP)) Q:APCMP'=+APCMP  D
  1.  .I $D(APCM100R(APCMP,APCMTIME)) S F=$P(^APCM25OB(APCMIC,0),U,11) D  G D
  1.  ..D S^APCM25E1(APCMRPT,APCMIC,"Provider is excluded from this measure as he/she had < 100 prescriptions issued during the EHR reporting period.",APCMP,APCMRPTT,APCMTIME,F,1)
  1.  .I $G(APCMADDQ("ANS",APCMIC,24,APCMP))="No",$G(APCMADDQ("ANS",APCMIC,25,APCMP))="No" S F=$P(^APCM25OB(APCMIC,0),U,11) D
  1.  ..D S^APCM25E1(APCMRPT,APCMIC,"Provider may be eligible for an exclusion on this measure as they not have an onsite pharmacy and do not have a pharmacy within 10 miles accepting electronic prescriptions.",APCMP,APCMRPTT,APCMTIME,F,1)
  1. D .;set denominator value into field
  1.  .S F=$P(^APCM25OB(APCMIC,0),U,8)  ;denom field for this measure
  1.  .S N=$P($G(APCMRXS(APCMP)),U,1)  ;returns # of prescriptions^# not written by nature of order
  1.  .D S^APCM25E1(APCMRPT,APCMIC,N,APCMP,APCMRPTT,APCMTIME,F)
  1.  .;now set patient list for this provider
  1.  .S P=0 F  S P=$O(^TMP($J,"PATSRX",APCMP,P)) Q:P'=+P  D
  1.  ..;Q:'$P(^TMP($J,"PATSRX",APCMP,P),U,1)
  1.  ..I $P(^TMP($J,"PATSRX",APCMP,P),U,1)=$P(^TMP($J,"PATSRX",APCMP,P),U,2) S APCMVALU="# Prescriptions: "_$P(^TMP($J,"PATSRX",APCMP,P),U,1)_"|||"_" # transmitted electronically: "_+$P(^TMP($J,"PATSRX",APCMP,P),U,2)_"|||1" D  Q
  1.  ...S DFN=P D SETLIST^APCM25E1 Q
  1.  ..S S="",APCMVALU="Not transmitted electronically: "
  1.  ..F  S S=$O(^TMP($J,"PATSRX",APCMP,P,"SCRIPTS",S)) Q:S=""  D
  1.  ...I '$D(^TMP($J,"PATSRX",APCMP,P,"ELEC",S)) D
  1.  ....S APCMVALU=APCMVALU_S_";"
  1.  ..S DFN=P,APCMVALU="# of Prescriptions: "_$P(^TMP($J,"PATSRX",APCMP,P),U,1)_" # transmitted electronically: "_+$P(^TMP($J,"PATSRX",APCMP,P),U,2)_"|||"_APCMVALU,$P(APCMVALU,"|||",3)=0 D SETLIST^APCM25E1
  1.  .;numerator?
  1.  .S F=$P(^APCM25OB(APCMIC,0),U,9)
  1.  .S N=$P($G(APCMRXS(APCMP)),U,2)
  1.  .D S^APCM25E1(APCMRPT,APCMIC,N,APCMP,APCMRPTT,APCMTIME,F)
  1.  K ^TMP($J,"PATSRX")
  1.  Q
  1. TOTRX ;EP - did patient have a RX in file 52 with an issue date
  1.  ;between BD and ED
  1.  ;SET ARRAY APCMRXS to APCMRXS(prov ien)=denom^numer
  1.  NEW ID,C,Y,X,D,S,N,A,B,R,PAT,G
  1.  S C=0,N=0
  1.  S ID=$$FMADD^XLFDT(APCMBDAT,-1)
  1.  F  S ID=$O(^PSRX("AC",ID)) Q:ID'=+ID!(ID>APCMEDAT)  D
  1.  .S X=0 F  S X=$O(^PSRX("AC",ID,X)) Q:X'=+X  D
  1.  ..S R=$P($G(^PSRX(X,0)),U,4)
  1.  ..Q:'R
  1.  ..;I '$D(APCMPRV(R)) Q  ;not a provider of interest
  1.  ..I '$D(APCMRXS(R)) S APCMRXS(R)=""
  1.  ..Q:$$GET1^DIQ(52,X,9999999.28)="YES"  ;MUST NOT BE A DISCHARGE MED
  1.  ..Q:$P($G(^PSRX(X,"STA")),"^")=13
  1.  ..S D=$P(^PSRX(X,0),U,6)
  1.  ..S S=$P($G(^PSDRUG(D,0)),U,3)
  1.  ..Q:S[5
  1.  ..Q:S[4
  1.  ..Q:S[3
  1.  ..Q:S[2
  1.  ..Q:S[1
  1.  ..S S=$P($G(^PSRX(X,3)),U,7)
  1.  ..Q:$$UP^XLFSTR(S)["ADMINISTERED IN CLINIC"
  1.  ..S PAT=$P(^PSRX(X,0),U,2)
  1.  ..;quit if demo patient
  1.  ..Q:$$DEMO^APCLUTL(PAT,$G(APCMDEMO))
  1.  ..S $P(APCMRXS(R),U,1)=$P(APCMRXS(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",$P(^PSRX(X,0),U,1))=""
  1.  ..;
  1.  ..;now check to see if it has a nature of order not equal to 1-written
  1.  ..S G=0
  1.  ..I $E($P(^PSRX(X,0),U,1))?1N D
  1.  ...S O=$P($G(^PSRX(X,"OR1")),U,2)  ;order number
  1.  ...Q:O=""
  1.  ...S B=$P($G(^OR(100,O,0)),U,6)
  1.  ...Q:B=""
  1.  ...S A=0,G=0 F  S A=$O(^OR(100,O,8,A)) Q:A'=+A!(G)  D
  1.  ....S B=$P($G(^OR(100,O,8,A,0)),U,12)
  1.  ....Q:B=1
  1.  ....Q:B=""
  1.  ....S G=1
  1.  ...S $P(APCMRXS(R),U,2)=$P(APCMRXS(R),U,2)+G,$P(^TMP($J,"PATSRX",R,PAT),U,2)=$P($G(^TMP($J,"PATSRX",R,PAT)),U,2)+G I G S ^TMP($J,"PATSRX",R,PAT,"ELEC",$P(^PSRX(X,0),U,1))=""  ;S N=N+G
  1.  ..S B=0 I $E($P(^PSRX(X,0),U,1))="X" D
  1.  ...S A=0 F  S A=$O(^PSRX(X,"A",A)) Q:A'=+A!(B)  D
  1.  ....I $P(^PSRX(X,"A",A,0),U,5)["E-Prescribe" S B=1
  1.  ....I $P(^PSRX(X,"A",A,0),U,5)["eRx" S B=1
  1.  ...S $P(APCMRXS(R),U,2)=$P(APCMRXS(R),U,2)+B,$P(^TMP($J,"PATSRX",R,PAT),U,2)=$P($G(^TMP($J,"PATSRX",R,PAT)),U,2)+B I B S ^TMP($J,"PATSRX",R,PAT,"ELEC",$P(^PSRX(X,0),U,1))=""
  1.  Q
  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 ""
  1. LTAP ;EP - CALCULATE LTAP
  1.  K ^TMP($J,"PATSLAB")
  1.  K APCMLABS
  1.  D LTAP1
  1.  NEW APCMP,N,F
  1.  S (APCMD1,APCMN1)=0
  1.  S APCMP=APCMFAC
  1.  S F=$P(^APCM25OB(APCMIC,0),U,8)  ;denom field for this measure
  1.  S N=$P($G(APCMLABS(APCMFAC)),U,1)  ;returns # of lab orders^# not written by nature of order
  1.  D S^APCM25E1(APCMRPT,APCMIC,N,APCMFAC,APCMRPTT,APCMTIME,F)
  1.  ;now set patient list for this FACILITY
  1.  S P=0 F  S P=$O(^TMP($J,"PATSLAB",APCMFAC,P)) Q:P'=+P  D
  1.  .S D=$P(^TMP($J,"PATSLAB",APCMFAC,P),U,1),N=$P(^TMP($J,"PATSLAB",APCMFAC,P),U,2) S APCMVALU="# Orders: "_D_"|||"_"# RESULTED: "_N_" # NOT RESULTED: "_(D-N)
  1.  .S DFN=P D SETLIST^APCM25E1
  1.  ;numerator?
  1.  S F=$P(^APCM25OB(APCMIC,0),U,9)
  1.  S N=$P($G(APCMLABS(APCMFAC)),U,2)
  1.  D S^APCM25E1(APCMRPT,APCMIC,N,APCMFAC,APCMRPTT,APCMTIME,F)
  1.  K ^TMP($J,"PATSLAB"),^TMP($J,"ORDERSPROCESSED")
  1.  Q
  1. LTAP1 ;EP - 
  1.  ;between BD and ED
  1.  ;SET ARRAY APCMLABS to APCMLABS(prov ien)=denom^numer
  1.  K ^TMP($J,"PATSLAB")
  1.  NEW ID,C,Y,X,D,S,N,A,B,R,PAT,G,SPECNO,ORPFILE,ORPTST,ORNS,PATLOC,ORACT0,ORORD,ORDEB,LRPAT
  1.  S ID=$$FMADD^XLFDT(APCMBDAT,-1),ID=ID_".9999"
  1.  F  S ID=$O(^LRO(69,ID)) Q:ID'=+ID!($P(ID,".")>APCMEDAT)  D
  1.  .;GET FIRST SPECIMEN IN MULTIPLE
  1.  .S SPECNO=0 F  S SPECNO=$O(^LRO(69,ID,1,SPECNO)) Q:SPECNO'=+SPECNO  D
  1.  ..;S ^TMP($J,"ORDERSPROCESSED",SPECNO)=""
  1.  ..S LRPAT=+$P($G(^LRO(69,ID,1,SPECNO,0)),U,1) ;GET Patient lRDFN
  1.  ..;GET DFN
  1.  ..S A=$P($G(^LR(LRPAT,0)),U,2) Q:A'=2
  1.  ..S PAT=$P($G(^LR(LRPAT,0)),U,3)
  1.  ..Q:$$DEMO^APCLUTL(PAT,APCMDEMO)  ;Quit if demo patient
  1.  ..S PATLOC=+$P($G(^LRO(69,ID,1,SPECNO,0)),U,9) ;FILE 44 IEN
  1.  ..S C="" I PATLOC,$D(^SC(PATLOC,0)) S C=$P(^SC(PATLOC,0),U,7) I C Q:$P($G(^DIC(40.7,C,0)),U,2)=30  ;IF ER LOC Q
  1.  ..;quit if there is a ward on the file 44 entry
  1.  ..Q:$P($G(^SC(PATLOC,42)),U,1)  ;HAS A WARD POINTER
  1.  ..;SET DENOM COUNT
  1.  ..;I DUZ=2793 W !,"PAT: ",$P(^DPT(PAT,0),U,1),"DATE: ",$$FMTE^XLFDT(ID)," ORDER: ",SPECNO,"  NATURE: ",ORORD
  1.  ..S $P(APCMLABS(APCMFAC),U,1)=$P($G(APCMLABS(APCMFAC)),U,1)+1,$P(^TMP($J,"PATSLAB",APCMFAC,PAT),U,1)=$P($G(^TMP($J,"PATSLAB",APCMFAC,PAT)),U,1)+1
  1.  ..;
  1.  ..;now check to see if it has a RESULT, IF NOT, quit and don't set numerator
  1.  ..;USE FIRST TEST ONLY
  1.  ..S A=0 S A=$O(^LRO(69,ID,1,SPECNO,2,A)) Q:'A  D
  1.  ...S T=A  ;$P(^LRO(69,ID,1,SPECNO,2,A,0),U,1) ;TEST IEN
  1.  ...S B=$$RESULT(ID,SPECNO,T)
  1.  ...Q:$P(B,U)="-1"
  1.  ...S $P(APCMLABS(APCMFAC),U,2)=$P(APCMLABS(APCMFAC),U,2)+1,$P(^TMP($J,"PATSLAB",APCMFAC,PAT),U,2)=$P($G(^TMP($J,"PATSLAB",APCMFAC,PAT)),U,2)+1
  1.  Q
  1.  ;
  1.  ; ^LRO(69,LRODT,1,LRSP,2,LRAT)
  1.  ;      LRODT = DATE ORDERED
  1.  ;      LRSP = SPECIMEN #
  1.  ;      LRAT = TEST
  1. RESULT(LRODT,LRSP,LRAT) ; EP - Return the RESULT of a "CH" subscripted test given Order data
  1.  ;NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IEN,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRODT,LRSP,LRAT,U,XPARSYS,XQXFLG)
  1.  NEW LROIENS,LRAA,LRAD,LRAN,F6OPTR,F6ODN,LRAIENS,LRDFN,LRIDT,RESULT
  1.  ;
  1.  S LROIENS=LRAT_","_LRSP_","_LRODT
  1.  S LRAA=$$GET1^DIQ(69.03,LROIENS,"ACCESSION AREA","I")
  1.  S LRAD=$$GET1^DIQ(69.03,LROIENS,"ACCESSION DATE","I")
  1.  S LRAN=$$GET1^DIQ(69.03,LROIENS,"ACCESSION NUMBER","I")
  1.  ;
  1.  S F60PTR=$$GET1^DIQ(69.03,LROIENS,"TEST/PROCEDURE","I")
  1.  S F60DN=$$GET1^DIQ(60,F60PTR,"DATA NAME","I")
  1.  ;
  1.  S LRAIENS=LRAN_","_LRAD_","_LRAA
  1.  S LRDFN=$$GET1^DIQ(68.02,LRAIENS,"LRDFN","I")
  1.  S LRIDT=$$GET1^DIQ(68.02,LRAIENS,"INVERSE DATE","I")
  1.  ;
  1.  S RESULT=$$GET1^DIQ(63.04,LRIDT_","_LRDFN,F60DN)
  1.  Q $S($L(RESULT):RESULT,1:"-1^MISSING RESULT")