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

APCM2AE2.m

Go to the documentation of this file. 
  1. APCM2AE2 ; IHS/CMI/LAB - IHS MU ;
  1.  ;;1.0;MU PERFORMANCE REPORTS;**7**;MAR 26, 2012;Build 15
  1.  ;;;;;;Build 3
  1. DEMO ;EP - CALCULATE DEMOGRAPHICS
  1.  ;for each provider or for the facility find out if this
  1.  ;patient had a visit of A, O, R, S to this provider or facility
  1.  ;if so, then check to see if they had dob, preferred language, gender, race, ethnicity recorded
  1.  NEW APCMP
  1.  S (APCMD1,APCMN1)=0
  1.  I APCMRPTT=1 D  Q
  1.  .S APCMP=0 F  S APCMP=$O(APCMPRV(APCMP)) Q:APCMP'=+APCMP  D
  1.  ..Q:'$D(APCMHVTP(APCMP))  ;DID NOT SEE THIS PATIENT
  1.  ..D DEMO1
  1.  I APCMRPTT=2 D
  1.  .S APCMP=APCMFAC
  1.  .Q:'$D(APCMHVTP(APCMP))
  1.  .D DEMO1
  1.  .Q
  1.  Q
  1. DEMO1 ;set denominator value into field
  1.  S F=$P(^APCM25OB(APCMIC,0),U,8)  ;denom field for this measure
  1.  D S^APCM2AE1(APCMRPT,APCMIC,1,APCMP,APCMRPTT,APCMTIME,F)
  1.  S APCMVALU="VISIT: "_$$DATE^APCM1UTL(APCMHVTP(APCMP))
  1.  ;numerator?
  1.  S APCMEP=$$HASDEMO(DFN,APCMBDAT,APCMEDAT,APCMRPTT,$G(APCMVDOD))
  1.  S APCMVALU=APCMVALU_"|||"_$S($P(APCMEP,U,1)=1:"MEETS OBJECTIVE: ",1:"DOES NOT MEET OBJECTIVE: ")_$P(APCMEP,U,2)_"|||"_$P(APCMEP,U,1)
  1.  S F=$P(^APCM25OB(APCMIC,0),U,9)
  1.  D S^APCM2AE1(APCMRPT,APCMIC,$P(APCMEP,U,1),APCMP,APCMRPTT,APCMTIME,F)
  1.  D SETLIST^APCM2AE1
  1.  Q
  1. HASDEMO(P,BD,ED,T,DODV) ;
  1.  NEW PL,G,R,E,D,C,Y,X,B,Z
  1.  S C=0
  1.  S T=$G(T)
  1.  S DODV=$G(DODV)
  1.  S (PL,G,R,E,D)=""
  1.  ;preferred language
  1.  S X=0 F  S X=$O(^AUPNPAT(P,86,X)) Q:X'=+X!(PL]"")  D
  1.  .S B=$P(^AUPNPAT(P,86,X,0),U)
  1.  .;Q:B>ED
  1.  .S C=C+1,PL="Preferred Language"
  1.  S G=$P(^DPT(P,0),U,2) I G]"" S C=C+1,G="Gender"
  1.  I $T(RACE^AGUTL)]"" S R=$$RACE^AGUTL(P)
  1.  I R S C=C+1,R="Race" I 1
  1.  E  S R=$$VAL^XBDIQ1(2,P,.06) I R]"" S C=C+1,R="Race"
  1.  S Z=0 F  S Z=$O(^DPT(P,.06,Z)) Q:Z'=+Z!(E]"")  D
  1.  .S E=$P($G(^DPT(P,.06,Z,0)),U,1)
  1.  .Q:E=""
  1.  .S E="Ethnicity",C=C+1
  1.  .Q
  1.  I $P(^DPT(P,0),U,3)]"" S D="DOB",C=C+1
  1.  I T=2,$G(DODV) G HASDEMOH
  1.  I C=5 Q 1_U_"Has: "_PL_";"_G_";"_R_";"_E_";"_D
  1.  Q 0_U_"Has: "_PL_";"_G_";"_R_";"_E_";"_D
  1. HASDEMOH ;did patient die in the hospital during report period?  if so is dod and underlying cause there?
  1.  NEW VDOD,L,PCD
  1.  S PCD=""
  1.  S VDOD=$$DATE^APCM1UTL($P($P(^AUPNVINP(DODV,0),U,1),"."))
  1.  I VDOD]"" S C=C+1,VDOD="DIED IN HOSP "_VDOD
  1.  S L=$$VAL^XBDIQ1(9000010.02,DODV,2101)
  1.  I L]"" S C=C+1,PCD="PCD"
  1.  I C=7 Q 1_U_"Has: "_PL_";"_G_";"_R_";"_E_";"_D_";"_VDOD_";"_PCD
  1.  Q 0_U_"Has: "_PL_";"_G_";"_R_";"_E_";"_D_";"_VDOD_";"_PCD
  1.  ;
  1. PL ;EP - CALCULATE PROBLEM LIST
  1.  ;for each provider or for the facility find out if this
  1.  ;patient had a visit of A, O, R, S to this provider or facility
  1.  ;if so, then check to see if they any problems on their problem list (skip deleted) or a NAP documented in report period
  1.  NEW APCMP
  1.  S (APCMD1,APCMN1)=0
  1.  I APCMRPTT=1 D  Q
  1.  .S APCMP=0 F  S APCMP=$O(APCMPRV(APCMP)) Q:APCMP'=+APCMP  D
  1.  ..Q:'$D(APCMHVTP(APCMP))  ;no visits to this provider for this patient so don't bother, the patient is not in the denominator
  1.  ..D PL1
  1.  ..Q
  1.  I APCMRPTT=2 D
  1.  .S APCMP=APCMFAC
  1.  .Q:'$D(APCMHVTP(APCMP))
  1.  .D PL1
  1.  .Q
  1.  Q
  1. PL1 ;set denominator value into field
  1.  S F=$P(^APCM25OB(APCMIC,0),U,8)  ;denom field for this measure
  1.  D S^APCM2AE1(APCMRPT,APCMIC,1,APCMP,APCMRPTT,APCMTIME,F)
  1.  S APCMVALU="VISIT: "_$$DATE^APCM1UTL(APCMHVTP(APCMP))
  1.  ;numerator?
  1.  S APCMEP=$$HASPL(DFN,APCMBDAT,APCMEDAT)
  1.  S APCMVALU=APCMVALU_"|||"_$P(APCMEP,U,2)_"|||"_$P(APCMEP,U,1)
  1.  S F=$P(^APCM25OB(APCMIC,0),U,9)
  1.  D S^APCM2AE1(APCMRPT,APCMIC,$P(APCMEP,U,1),APCMP,APCMRPTT,APCMTIME,F)
  1.  D SETLIST^APCM2AE1
  1.  Q
  1. HASPL(P,BD,ED) ;does patient have a problem entered before end of report period
  1.  ;
  1.  NEW A,B,C,D,E
  1.  S E=""
  1.  S A=0 F  S A=$O(^AUPNPROB("AC",P,A)) Q:A'=+A!(E]"")  D
  1.  .;if date entered is after the ED don't count it
  1.  .Q:'$D(^AUPNPROB(A,0))
  1.  .Q:$P(^AUPNPROB(A,0),U,8)>ED  ;after end date of report period
  1.  .I $P(^AUPNPROB(A,0),U,12)'="D" S E=1_U_"Problem Entry: "_$$VAL^XBDIQ1(9000011,A,.01)_" entered on "_$$VAL^XBDIQ1(9000011,A,.08) Q
  1.  .;since it's deleted, deletion date must not be before time period
  1.  .S D=$P($P($G(^AUPNPROB(A,2)),U,2),".")  ;date deleted
  1.  .Q:D>ED
  1.  .Q:D<BD
  1.  .S E="1^Problem Entry: "_$$VAL^XBDIQ1(9000011,A,.01)_" entered on "_$$VAL^XBDIQ1(9000011,A,.08)
  1.  I E]"" Q E
  1.  ;no problems on PL so how about a NAP before end of time period
  1.  S C=$O(^AUTTCRA("B","NO ACTIVE PROBLEMS",0))
  1.  I 'C Q ""
  1.  S A=0 F  S A=$O(^AUPNVRUP("AC",P,A)) Q:A'=+A!(E]"")  D
  1.  .Q:'$D(^AUPNVRUP(A,0))  ;oops
  1.  .Q:$P(^AUPNVRUP(A,0),U,1)'=C  ;not NAP
  1.  .S D=$$VD^APCLV($P(^AUPNVRUP(A,0),U,3))
  1.  .Q:D>ED
  1.  .S E="1^No Active Problems on "_$$DATE^APCM1UTL(D)
  1.  Q E
  1.  ; Return boolean flag indicating valid patient
  1. PATVRY(RX,PAT) ;EP
  1.  Q:PAT="*" 1
  1.  Q +$P($G(^PSRX(RX,0)),U,2)=PAT
  1.  ; Return release date for dispense
  1. DSPRDT(RX,TYP,SIEN) ;EP
  1.  Q $S($G(SIEN):+$P($G(^PSRX(RX,$S(TYP="ADP":"P",1:1),SIEN,0)),U,$S(TYP="ADP":19,1:18)),1:+$P(^PSRX(RX,2),U,13))
  1. EMAR ;EP
  1.  ;for each provider count each Visit that HAS a v referral
  1.  K ^TMP($J,"TRANS")
  1.  NEW EMAR
  1.  D EMAR1
  1.  NEW APCMP,N,F,O,Y
  1.  I APCMRPTT=2 S APCMP=APCMFAC  D
  1.  .I $$AVC^APCM2AEM(APCMBDAT,APCMEDAT,APCMFAC)<10 D
  1.  ..S F=$P(^APCM25OB(APCMIC,0),U,11) D S^APCM2AE1(APCMRPT,APCMIC,"Facility is excluded from this measure as the average daily census was <10 during the previous year.",APCMP,APCMRPTT,APCMTIME,F,1)
  1.  .S F=$P(^APCM25OB(APCMIC,0),U,8)  ;denom field for this measure
  1.  .S N=$P(EMAR,U,1)  ;returns
  1.  .D S^APCM2AE1(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,"BCMA","TRUD",P)) Q:P'=+P  D
  1.  ..S APCMVALU="# orders: "_$P(^TMP($J,"BCMA","TRUD",P),U,1)_"|||"_" # w/100%eMAR: "_+$P(^TMP($J,"BCMA","TRUD",P),U,2)_"|||1"
  1.  ..S DFN=P
  1.  ..D SETLIST^APCM2AE1
  1.  .;numerator?
  1.  .S F=$P(^APCM25OB(APCMIC,0),U,9)
  1.  .S N=$P(EMAR,U,2)
  1.  .D S^APCM2AE1(APCMRPT,APCMIC,N,APCMP,APCMRPTT,APCMTIME,F)
  1.  K ^TMP($J)
  1.  Q
  1. EMAR1 ;EP - ep toc
  1. START ;Set beginning/ending sort dates for ORDERS
  1.  NEW CNT,CNTT,CNTTR,CPS55,CPSDATE,CPSDFN,CPSEND,CPSFRE,CPSN,CPSN1,CPSNUM,CPSPOS,CPSPSB
  1.  NEW CPSQ,CPSRAT,CPSS1,CPSSCH,CPSTART,CPSTOP,CPSTYPE,CPSVOL
  1.  S CPSTART=APCMBDAT
  1.  S CPSEND=APCMEDAT
  1.  S EMAR=""
  1.  S (CNT("UNIT DOSE","TR"),CNT("UNIT DOSE"))=0
  1.  K ^TMP($J)
  1. P55 ;LOOP 55 UNIT DOSE
  1.  S CPSDATE=CPSTART F  S CPSDATE=$O(^PS(55,"AUDS",CPSDATE)) Q:$P(CPSDATE,".")>CPSEND!('+CPSDATE)!(CPSDATE>$$NOW^XLFDT())  D
  1.  .S CPSDFN=0 F  S CPSDFN=$O(^PS(55,"AUDS",CPSDATE,CPSDFN)) Q:'+CPSDFN  D
  1.  ..S CPS55=0 F  S CPS55=$O(^PS(55,"AUDS",CPSDATE,CPSDFN,CPS55)) Q:'+CPS55  D
  1.  ...;COUNT POSSIBLE DOSES DUE FOR ORDER.
  1.  ...S CPSPOS=0
  1.  ...S CPSFRE=$P($G(^PS(55,CPSDFN,5,+CPS55,2)),U,6),CPSTOP=$P($G(^PS(55,CPSDFN,5,+CPS55,2)),U,4)
  1.  ...S CPSSCH=$P($G(^PS(55,CPSDFN,5,+CPS55,0)),U,7)
  1.  ...Q:CPSTOP<CPSDATE
  1.  ...I CPSFRE="D"&(CPSSCH="C") S CPSN=$L($P($G(^PS(55,CPSDFN,5,+CPS55,2)),U,1),"-") S X2=CPSDATE,X1=$S(CPSTOP<DT:DT,1:CPSTOP) D ^%DTC S CPSPOS=CPSN*X
  1.  ...I +CPSFRE&(CPSSCH="C") D
  1.  ....S CPSS1=$$FMDIFF^XLFDT($S(CPSTOP>$$NOW^XLFDT():$$NOW^XLFDT(),$P(CPSTOP,".")>CPSEND:CPSEND_".24",1:CPSTOP),CPSDATE,2),CPSS1=CPSS1\60
  1.  ....S CPSPOS=CPSS1\CPSFRE  ;POSSIBLE DOSES?
  1.  ....I CPSFRE>CPSS1 S CPSPOS=1  ;FREQ IS GREATER SO ONLY ONE POSSIBLE
  1.  ....;S CPSS1=0,CPSS1=(24-$E($P(CPSDATE,".",2),1,2))*60 ;MINS FOR FIRST DATE  l
  1.  ....;IF CPSTOP>DT D NOW^%DTC S CPSS1=CPSS1+($E($P(%,".",2),1,2)*60) ; MINS FOR MIDNIGHT LAST DATE  l
  1.  ....;IF CPSTOP<DT S CPSS1=CPSS1+($E($P(CPSTOP,".",2),1,2)*60) ;MINS FOR MIDNIGHT LAST DATE  l
  1.  ....;S X1=CPSDATE,X2=+1 D C^%DTC S X2=X,X1=$S(CPSTOP>DT:DT,1:CPSTOP) D ^%DTC S CPSPOS=((X*1440)+CPSS1)/CPSFRE  l
  1.  ....;S X1=DT,X2=+1 D C^%DTC S CPSNDT=X S X2=CPSDATE,X1=$S(CPSTOP>DT:CPSNDT,1:CPSTOP) D ^%DTC S CPSPOS=((X*1440)+CPSS1)/CPSFRE
  1.  ...I CPSSCH="C"!(CPSSCH="O") S CNT("UNIT DOSE")=CNT("UNIT DOSE")+1,$P(^TMP($J,"BCMA","TRUD",CPSDFN),U,1)=$P($G(^TMP($J,"BCMA","TRUD",CPSDFN)),U,1)+1
  1.  ...;LOOK 53.79 FOR DOSE TRACKED.
  1.  ...I CPSSCH="O" S CPSPOS=1 ;PRNS TO ONE
  1.  ...Q:+CPSPOS<0!(CPSPOS=0)
  1.  ...S CPSQ=$S(CPSSCH="O":1,CPSSCH="C":1,1:0)
  1.  ...Q:CPSQ=0
  1.  ...;W !,CPSSCH
  1.  ...S (CPSPSB,CPSN1)=0 F  S CPSN1=$O(^PSB(53.79,"AORDX",CPSDFN,CPS55_"U",CPSN1)) Q:'+CPSN1  S CPSPSB=CPSPSB+1
  1.  ...Q:CPSPSB<CPSPOS
  1.  ...S CNT("UNIT DOSE","TR")=CNT("UNIT DOSE","TR")+1 S $P(^TMP($J,"BCMA","TRUD",CPSDFN),U,2)=$P(^TMP($J,"BCMA","TRUD",CPSDFN),U,2)+1
  1.  ...;W !,CPS55,U,CPSPOS,U,CPSPSB,U,CPSSCH
  1. IV ;LOOP IVS
  1.  S (CNT("IV","TR"),CNT("IV"))=0
  1.  S CPSDATE=CPSTART F  S CPSDATE=$O(^PS(55,"AIVS",CPSDATE)) Q:CPSDATE>CPSEND!('+CPSDATE)  D
  1.  .S CPSDFN=0 F  S CPSDFN=$O(^PS(55,"AIVS",CPSDATE,CPSDFN)) Q:'+CPSDFN  D
  1.  ..S CPS55=0 F  S CPS55=$O(^PS(55,"AIVS",CPSDATE,CPSDFN,CPS55)) Q:'+CPS55  D
  1.  ...S CNT("IV")=CNT("IV")+1,(CPSPSB,CPSPOS)=0,$P(^TMP($J,"BCMA","TRUD",CPSDFN),U,1)=$P($G(^TMP($J,"BCMA","TRUD",CPSDFN)),U,1)+1
  1.  ...S CPSTYPE=$P($G(^PS(55,CPSDFN,"IV",CPS55,0)),U,4)
  1.  ...I CPSTYPE="P"!(CPSTYPE="S") D
  1.  ....S CPSFRE=$P($G(^PS(55,CPSDFN,"IV",CPS55,0)),U,15) I +CPSFRE S CPSTOP=$P($G(^PS(55,CPSDFN,"IV",CPS55,0)),U,3) S X2=CPSDATE,X1=$S($P(CPSTOP,".")>CPSEND:CPSEND_".24",CPSTOP>$$NOW^XLFDT():$$NOW^XLFDT(),1:CPSTOP) D ^%DTC S CPSPOS=(X*1440)/CPSFRE
  1.  ....I CPSFRE="O" S CPSPOS=1 ;ONCE 
  1.  ...;COUND TOTAL NUMBER OF IV BAGS FOR ORDER
  1.  ...I $D(^PS(55,CPSDFN,"IV",+CPS55,"BCMA"))&(CPSTYPE'="P")&(CPSTYPE'="S") S (CPSPOS,CPSNUM)=0 F  S CPSNUM=$O(^PS(55,CPSDFN,"IV",+CPS55,"BCMA",CPSNUM)) Q:'+CPSNUM  S CPSPOS=CPSPOS+1
  1.  ...;NO LABELS
  1.  ...I '$D(^PS(55,CPSDFN,"IV",+CPS55,"BCMA"))&(CPSTYPE'="P")&(CPSTYPE'="S") D
  1.  ....S CPSVOL=$P($G(^PS(55,CPSDFN,"IV",CPS55,"SOL",1,0)),U,2),CPSRAT=$P($G(^PS(55,CPSDFN,"IV",CPS55,0)),U,8)
  1.  ....S CPSTOP=$P($G(^PS(55,CPSDFN,"IV",CPS55,0)),U,3)
  1.  ....S CPSS1=0,CPSS1=(24-$E($P(CPSDATE,".",2),1,2))*60 ;MINS FOR FIRST DATE
  1.  ....IF CPSTOP>DT D NOW^%DTC S CPSS1=CPSS1+($E($P(%,".",2),1,2)*60) ; MINS FOR MIDNIGHT LAST DATE
  1.  ....IF CPSTOP<DT S CPSS1=CPSS1+($E($P(CPSTOP,".",2),1,2)*60) ;MINS FOR MIDNIGHT LAST DATE
  1.  ....S X1=CPSDATE,X2=+1 D C^%DTC S X2=X,X1=$S(CPSTOP>DT:DT,1:CPSTOP) D ^%DTC S CPSPOS=(((((+CPSRAT*24)*X)+CPSS1)+CPSS1)\+CPSVOL)
  1.  ...Q:'+CPSPOS&('+$G(CPSRAT))  ;NO POSSIBLE FOUND AND NO INFUSTION RATE BAIL THIS ONE.
  1.  ...;LOOK IN BCMA FOR IVS
  1.  ...S (CPSNUM,CPSPSB)=0 F  S CPSNUM=$O(^PSB(53.79,"AUID",CPSDFN,CPS55_"V",CPSNUM)) Q:'+CPSNUM  S CPSPSB=CPSPSB+1
  1.  ...Q:CPSPSB<CPSPOS
  1.  ...S CNT("IV","TR")=CNT("IV","TR")+1 S $P(^TMP($J,"BCMA","TRUD",CPSDFN),U,2)=$P(^TMP($J,"BCMA","TRUD",CPSDFN),U,2)+1
  1.  ..;NEXT FIND BCMA TOTAL MEDS GIVE ON UD AND MATCH IV ORDERS. 
  1. PRT ;
  1.  S (CNTT,CNTTR)=0
  1.  ;W !,?5,"Meaningfull Use Stage II Report From " S Y=CPSTART D DD^%DT W Y_" TO " S Y=CPSEND D DD^%DT  W Y
  1.  ;D NOW^%DTC S Y=% D DD^%DT W !,?45,"Run Date/Time:"_Y
  1.  ;W !,"Order Type",?15,"Total Orders",?30," %100 Tracked"
  1.  ;W ! F J=1:1:IOM W "-"
  1.  ;W ! F I="UNIT DOSE","IV" W I,?17,$G(CNT(I)),?35,$G(CNT(I,"TR")),! S CNTT=CNTT+$G(CNT(I)),CNTTR=CNTTR+$G(CNT(I,"TR"))
  1.  ;W ! F J=1:1:IOM W "-"
  1.  ;W !,?17,CNTT,?35,CNTTR
  1.  F I="UNIT DOSE","IV" S CNTT=CNTT+$G(CNT(I)),CNTTR=CNTTR+$G(CNT(I,"TR"))
  1.  S EMAR=CNTT_U_CNTTR  ;_U_CNTTR/CNTT
  1. EXIT ;
  1.  Q