APCM24EB ;IHS/CMI/LAB - IHS MU; ; 30 Jul 2013 8:15 AM
;;1.0;IHS MU PERFORMANCE REPORTS;**5,6**;MAR 26, 2012;Build 65
EPRES ;EP - CALCULATE EPRESCRIBING
;for each provider or for the facility count all prescriptions that meet criteria and if it is not written it meets numerator
K ^TMP($J,"PATSRX")
K APCMRXS
D TOTRX
NEW APCMP,N,F
S (APCMD1,APCMN1)=0
I APCMRPTT=1 S APCMP=0 F S APCMP=$O(APCMPRV(APCMP)) Q:APCMP'=+APCMP D
.I $D(APCM100R(APCMP,APCMTIME)) S F=$P(^APCM24OB(APCMIC,0),U,11) D G D
..D S^APCM24E1(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)
.I $G(APCMADDQ("ANS",APCMIC,24,APCMP))="No",$G(APCMADDQ("ANS",APCMIC,25,APCMP))="No" S F=$P(^APCM24OB(APCMIC,0),U,11) D
..D S^APCM24E1(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)
D .;set denominator value into field
.S F=$P(^APCM24OB(APCMIC,0),U,8) ;denom field for this measure
.S N=$P($G(APCMRXS(APCMP)),U,1) ;returns # of prescriptions^# not written by nature of order
.D S^APCM24E1(APCMRPT,APCMIC,N,APCMP,APCMRPTT,APCMTIME,F)
.;now set patient list for this provider
.S P=0 F S P=$O(^TMP($J,"PATSRX",APCMP,P)) Q:P'=+P D
..;Q:'$P(^TMP($J,"PATSRX",APCMP,P),U,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
...S DFN=P D SETLIST^APCM24E1 Q
..S S="",APCMVALU="Not transmitted electronically: "
..F S S=$O(^TMP($J,"PATSRX",APCMP,P,"SCRIPTS",S)) Q:S="" D
...I '$D(^TMP($J,"PATSRX",APCMP,P,"ELEC",S)) D
....S APCMVALU=APCMVALU_S_";"
..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^APCM24E1
.;numerator?
.S F=$P(^APCM24OB(APCMIC,0),U,9)
.S N=$P($G(APCMRXS(APCMP)),U,2)
.D S^APCM24E1(APCMRPT,APCMIC,N,APCMP,APCMRPTT,APCMTIME,F)
K ^TMP($J,"PATSRX")
Q
TOTRX ;EP - did patient have a RX in file 52 with an issue date
;between BD and ED
;SET ARRAY APCMRXS to APCMRXS(prov ien)=denom^numer
NEW ID,C,Y,X,D,S,N,A,B,R,PAT,G
S C=0,N=0
S ID=$$FMADD^XLFDT(APCMBDAT,-1)
F S ID=$O(^PSRX("AC",ID)) Q:ID'=+ID!(ID>APCMEDAT) D
.S X=0 F S X=$O(^PSRX("AC",ID,X)) Q:X'=+X D
..S R=$P($G(^PSRX(X,0)),U,4)
..Q:'R
..;I '$D(APCMPRV(R)) Q ;not a provider of interest
..I '$D(APCMRXS(R)) S APCMRXS(R)=""
..Q:$$GET1^DIQ(52,X,9999999.28)="YES" ;MUST NOT BE A DISCHARGE MED
..Q:$P($G(^PSRX(X,"STA")),"^")=13
..S D=$P(^PSRX(X,0),U,6)
..S S=$P($G(^PSDRUG(D,0)),U,3)
..Q:S[5
..Q:S[4
..Q:S[3
..Q:S[2
..Q:S[1
..S S=$P($G(^PSRX(X,3)),U,7)
..Q:$$UP^XLFSTR(S)["ADMINISTERED IN CLINIC"
..S PAT=$P(^PSRX(X,0),U,2)
..;quit if demo patient
..Q:$$DEMO^APCLUTL(PAT,$G(APCMDEMO))
..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))=""
..;
..;now check to see if it has a nature of order not equal to 1-written
..S G=0
..I $E($P(^PSRX(X,0),U,1))?1N D
...S O=$P($G(^PSRX(X,"OR1")),U,2) ;order number
...Q:O=""
...S B=$P($G(^OR(100,O,0)),U,6)
...Q:B=""
...S A=0,G=0 F S A=$O(^OR(100,O,8,A)) Q:A'=+A!(G) D
....S B=$P($G(^OR(100,O,8,A,0)),U,12)
....Q:B=1
....Q:B=""
....S G=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
..S B=0 I $E($P(^PSRX(X,0),U,1))="X" D
...S A=0 F S A=$O(^PSRX(X,"A",A)) Q:A'=+A!(B) D
....I $P(^PSRX(X,"A",A,0),U,5)["E-Prescribe" S B=1
....I $P(^PSRX(X,"A",A,0),U,5)["eRx" S B=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))=""
Q
ALLLAB(P,BD,ED,T,LT,LN,A) ;EP
;P - patient
;BD - beginning date
;ED - ending date
;T - lab taxonomy
;LT - loinc taxonomy
;LN - lab test name
;return all lab tests that match in array A
;FORMAT: DATE^TEST NAME^RESULT^V LAB IEN^VISIT IEN
I '$G(LT) S LT=""
S LN=$G(LN)
S T=$G(T)
NEW D,V,G,X,J,B,E,C
S B=9999999-BD,C=0,E=9999999-ED ;get inverse date and begin at edate-1 and end when greater than begin date
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
.S X=0 F S X=$O(^AUPNVLAB("AE",P,D,X)) Q:X'=+X D
..S Y=0 F S Y=$O(^AUPNVLAB("AE",P,D,X,Y)) Q:Y'=+Y D
...I 'T,'LT,LN="" D SETLAB Q
...I T,$D(^ATXLAB(T,21,"B",X)) D SETLAB Q
...I LN]"",$$VAL^XBDIQ1(9000010.09,Y,.01)=LN D SETLAB Q
...Q:'LT
...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
...Q:'$$LOINC(J,LT)
...D SETLAB Q
...Q
..Q
.Q
Q
SETLAB ;
S C=C+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)
Q
LOINC(A,LT,LI) ;
I '$G(LT),'$G(LI) Q "" ;no ien or taxonomy
S LI=$G(LI)
I A,LI,A=LI Q 1
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",LT,$D(^ATXAX(LT,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(LT,21,"B",%)) Q 1
Q ""
LTAP ;EP - CALCULATE LTAP
K ^TMP($J,"PATSLAB")
K APCMLABS
D LTAP1
NEW APCMP,N,F
S (APCMD1,APCMN1)=0
S APCMP=APCMFAC
S F=$P(^APCM24OB(APCMIC,0),U,8) ;denom field for this measure
S N=$P($G(APCMLABS(APCMFAC)),U,1) ;returns # of lab orders^# not written by nature of order
D S^APCM24E1(APCMRPT,APCMIC,N,APCMFAC,APCMRPTT,APCMTIME,F)
;now set patient list for this FACILITY
S P=0 F S P=$O(^TMP($J,"PATSLAB",APCMFAC,P)) Q:P'=+P D
.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)
.S DFN=P D SETLIST^APCM24E1
;numerator?
S F=$P(^APCM24OB(APCMIC,0),U,9)
S N=$P($G(APCMLABS(APCMFAC)),U,2)
D S^APCM24E1(APCMRPT,APCMIC,N,APCMFAC,APCMRPTT,APCMTIME,F)
K ^TMP($J,"PATSLAB"),^TMP($J,"ORDERSPROCESSED")
Q
LTAP1 ;EP -
;between BD and ED
;SET ARRAY APCMLABS to APCMLABS(prov ien)=denom^numer
K ^TMP($J,"PATSLAB")
NEW ID,C,Y,X,D,S,N,A,B,R,PAT,G,SPECNO,ORPFILE,ORPTST,ORNS,PATLOC,ORACT0,ORORD,ORDEB,LRPAT
S ID=$$FMADD^XLFDT(APCMBDAT,-1),ID=ID_".9999"
F S ID=$O(^LRO(69,ID)) Q:ID'=+ID!($P(ID,".")>APCMEDAT) D
.;GET FIRST SPECIMEN IN MULTIPLE
.S SPECNO=0 F S SPECNO=$O(^LRO(69,ID,1,SPECNO)) Q:SPECNO'=+SPECNO D
..;S ^TMP($J,"ORDERSPROCESSED",SPECNO)=""
..S LRPAT=+$P($G(^LRO(69,ID,1,SPECNO,0)),U,1) ;GET Patient lRDFN
..;GET DFN
..S A=$P($G(^LR(LRPAT,0)),U,2) Q:A'=2
..S PAT=$P($G(^LR(LRPAT,0)),U,3)
..Q:$$DEMO^APCLUTL(PAT,APCMDEMO) ;Quit if demo patient
..S PATLOC=+$P($G(^LRO(69,ID,1,SPECNO,0)),U,9) ;FILE 44 IEN
..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
..;quit if there is a ward on the file 44 entry
..Q:$P($G(^SC(PATLOC,42)),U,1) ;HAS A WARD POINTER
..;SET DENOM COUNT
..;I DUZ=2793 W !,"PAT: ",$P(^DPT(PAT,0),U,1),"DATE: ",$$FMTE^XLFDT(ID)," ORDER: ",SPECNO," NATURE: ",ORORD
..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
..;
..;now check to see if it has a RESULT, IF NOT, quit and don't set numerator
..;USE FIRST TEST ONLY
..S A=0 S A=$O(^LRO(69,ID,1,SPECNO,2,A)) Q:'A D
...S T=A ;$P(^LRO(69,ID,1,SPECNO,2,A,0),U,1) ;TEST IEN
...S B=$$RESULT(ID,SPECNO,T)
...Q:$P(B,U)="-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
Q
;
; ^LRO(69,LRODT,1,LRSP,2,LRAT)
; LRODT = DATE ORDERED
; LRSP = SPECIMEN #
; LRAT = TEST
RESULT(LRODT,LRSP,LRAT) ; EP - Return the RESULT of a "CH" subscripted test given Order data
;NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IEN,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRODT,LRSP,LRAT,U,XPARSYS,XQXFLG)
NEW LROIENS,LRAA,LRAD,LRAN,F6OPTR,F6ODN,LRAIENS,LRDFN,LRIDT,RESULT
;
S LROIENS=LRAT_","_LRSP_","_LRODT
S LRAA=$$GET1^DIQ(69.03,LROIENS,"ACCESSION AREA","I")
S LRAD=$$GET1^DIQ(69.03,LROIENS,"ACCESSION DATE","I")
S LRAN=$$GET1^DIQ(69.03,LROIENS,"ACCESSION NUMBER","I")
;
S F60PTR=$$GET1^DIQ(69.03,LROIENS,"TEST/PROCEDURE","I")
S F60DN=$$GET1^DIQ(60,F60PTR,"DATA NAME","I")
;
S LRAIENS=LRAN_","_LRAD_","_LRAA
S LRDFN=$$GET1^DIQ(68.02,LRAIENS,"LRDFN","I")
S LRIDT=$$GET1^DIQ(68.02,LRAIENS,"INVERSE DATE","I")
;
S RESULT=$$GET1^DIQ(63.04,LRIDT_","_LRDFN,F60DN)
Q $S($L(RESULT):RESULT,1:"-1^MISSING RESULT")
APCM24EB ;IHS/CMI/LAB - IHS MU; ; 30 Jul 2013 8:15 AM
+1 ;;1.0;IHS MU PERFORMANCE REPORTS;**5,6**;MAR 26, 2012;Build 65
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
+2 KILL ^TMP($JOB,"PATSRX")
+3 KILL APCMRXS
+4 DO TOTRX
+5 NEW APCMP,N,F
+6 SET (APCMD1,APCMN1)=0
+7 IF APCMRPTT=1
SET APCMP=0
FOR
SET APCMP=$ORDER(APCMPRV(APCMP))
IF APCMP'=+APCMP
QUIT
Begin DoDot:1
+8 IF $DATA(APCM100R(APCMP,APCMTIME))
SET F=$PIECE(^APCM24OB(APCMIC,0),U,11)
Begin DoDot:2
+9 DO S^APCM24E1(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)
End DoDot:2
GOTO D
+10 IF $GET(APCMADDQ("ANS",APCMIC,24,APCMP))="No"
IF $GET(APCMADDQ("ANS",APCMIC,25,APCMP))="No"
SET F=$PIECE(^APCM24OB(APCMIC,0),U,11)
Begin DoDot:2
+11 DO S^APCM24E1(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,A
PCMTIME,F,1)
End DoDot:2
D ;set denominator value into field
+1 ;denom field for this measure
SET F=$PIECE(^APCM24OB(APCMIC,0),U,8)
+2 ;returns # of prescriptions^# not written by nature of order
SET N=$PIECE($GET(APCMRXS(APCMP)),U,1)
+3 DO S^APCM24E1(APCMRPT,APCMIC,N,APCMP,APCMRPTT,APCMTIME,F)
+4 ;now set patient list for this provider
+5 SET P=0
FOR
SET P=$ORDER(^TMP($JOB,"PATSRX",APCMP,P))
IF P'=+P
QUIT
Begin DoDot:2
+6 ;Q:'$P(^TMP($J,"PATSRX",APCMP,P),U,1)
+7 IF $PIECE(^TMP($JOB,"PATSRX",APCMP,P),U,1)=$PIECE(^TMP($JOB,"PATSRX",APCMP,P),U,2)
SET APCMVALU="# Prescriptions: "_$PIECE(^TMP($JOB,"PATSRX",APCMP,P),U,1)_"|||"_" # transmitted electronically: "_+$PIECE(^TMP($JOB,"PATSRX",APCMP,P),U,2)_"|||1"
Begin DoDot:3
+8 SET DFN=P
DO SETLIST^APCM24E1
QUIT
End DoDot:3
QUIT
+9 SET S=""
SET APCMVALU="Not transmitted electronically: "
+10 FOR
SET S=$ORDER(^TMP($JOB,"PATSRX",APCMP,P,"SCRIPTS",S))
IF S=""
QUIT
Begin DoDot:3
+11 IF '$DATA(^TMP($JOB,"PATSRX",APCMP,P,"ELEC",S))
Begin DoDot:4
+12 SET APCMVALU=APCMVALU_S_";"
End DoDot:4
End DoDot:3
+13 SET DFN=P
SET APCMVALU="# of Prescriptions: "_$PIECE(^TMP($JOB,"PATSRX",APCMP,P),U,1)_" # transmitted electronically: "_+$PIECE(^TMP($JOB,"PATSRX",APCMP,P),U,2)_"|||"_APCMVALU
SET $PIECE(APCMVALU,"|||",3)=0
DO SETLIST^APCM24E1
End DoDot:2
+14 ;numerator?
+15 SET F=$PIECE(^APCM24OB(APCMIC,0),U,9)
+16 SET N=$PIECE($GET(APCMRXS(APCMP)),U,2)
+17 DO S^APCM24E1(APCMRPT,APCMIC,N,APCMP,APCMRPTT,APCMTIME,F)
End DoDot:1
+18 KILL ^TMP($JOB,"PATSRX")
+19 QUIT
TOTRX ;EP - did patient have a RX in file 52 with an issue date
+1 ;between BD and ED
+2 ;SET ARRAY APCMRXS to APCMRXS(prov ien)=denom^numer
+3 NEW ID,C,Y,X,D,S,N,A,B,R,PAT,G
+4 SET C=0
SET N=0
+5 SET ID=$$FMADD^XLFDT(APCMBDAT,-1)
+6 FOR
SET ID=$ORDER(^PSRX("AC",ID))
IF ID'=+ID!(ID>APCMEDAT)
QUIT
Begin DoDot:1
+7 SET X=0
FOR
SET X=$ORDER(^PSRX("AC",ID,X))
IF X'=+X
QUIT
Begin DoDot:2
+8 SET R=$PIECE($GET(^PSRX(X,0)),U,4)
+9 IF 'R
QUIT
+10 ;I '$D(APCMPRV(R)) Q ;not a provider of interest
+11 IF '$DATA(APCMRXS(R))
SET APCMRXS(R)=""
+12 ;MUST NOT BE A DISCHARGE MED
IF $$GET1^DIQ(52,X,9999999.28)="YES"
QUIT
+13 IF $PIECE($GET(^PSRX(X,"STA")),"^")=13
QUIT
+14 SET D=$PIECE(^PSRX(X,0),U,6)
+15 SET S=$PIECE($GET(^PSDRUG(D,0)),U,3)
+16 IF S[5
QUIT
+17 IF S[4
QUIT
+18 IF S[3
QUIT
+19 IF S[2
QUIT
+20 IF S[1
QUIT
+21 SET S=$PIECE($GET(^PSRX(X,3)),U,7)
+22 IF $$UP^XLFSTR(S)["ADMINISTERED IN CLINIC"
QUIT
+23 SET PAT=$PIECE(^PSRX(X,0),U,2)
+24 ;quit if demo patient
+25 IF $$DEMO^APCLUTL(PAT,$GET(APCMDEMO))
QUIT
+26 SET $PIECE(APCMRXS(R),U,1)=$PIECE(APCMRXS(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",$PIECE(^PSRX(X,0),U,1))=""
+27 ;
+28 ;now check to see if it has a nature of order not equal to 1-written
+29 SET G=0
+30 IF $EXTRACT($PIECE(^PSRX(X,0),U,1))?1N
Begin DoDot:3
+31 ;order number
SET O=$PIECE($GET(^PSRX(X,"OR1")),U,2)
+32 IF O=""
QUIT
+33 SET B=$PIECE($GET(^OR(100,O,0)),U,6)
+34 IF B=""
QUIT
+35 SET A=0
SET G=0
FOR
SET A=$ORDER(^OR(100,O,8,A))
IF A'=+A!(G)
QUIT
Begin DoDot:4
+36 SET B=$PIECE($GET(^OR(100,O,8,A,0)),U,12)
+37 IF B=1
QUIT
+38 IF B=""
QUIT
+39 SET G=1
End DoDot:4
+40 ;S N=N+G
SET $PIECE(APCMRXS(R),U,2)=$PIECE(APCMRXS(R),U,2)+G
SET $PIECE(^TMP($JOB,"PATSRX",R,PAT),U,2)=$PIECE($GET(^TMP($JOB,"PATSRX",R,PAT)),U,2)+G
IF G
SET ^TMP($JOB,"PATSRX",R,PAT,"ELEC",$PIECE(^PSRX(X,0),U,1))=""
End DoDot:3
+41 SET B=0
IF $EXTRACT($PIECE(^PSRX(X,0),U,1))="X"
Begin DoDot:3
+42 SET A=0
FOR
SET A=$ORDER(^PSRX(X,"A",A))
IF A'=+A!(B)
QUIT
Begin DoDot:4
+43 IF $PIECE(^PSRX(X,"A",A,0),U,5)["E-Prescribe"
SET B=1
+44 IF $PIECE(^PSRX(X,"A",A,0),U,5)["eRx"
SET B=1
End DoDot:4
+45 SET $PIECE(APCMRXS(R),U,2)=$PIECE(APCMRXS(R),U,2)+B
SET $PIECE(^TMP($JOB,"PATSRX",R,PAT),U,2)=$PIECE($GET(^TMP($JOB,"PATSRX",R,PAT)),U,2)+B
IF B
SET ^TMP($JOB,"PATSRX",R,PAT,"ELEC",$PIECE(^PSRX(X,0),U,1))=""
End DoDot:3
End DoDot:2
End DoDot:1
+46 QUIT
ALLLAB(P,BD,ED,T,LT,LN,A) ;EP
+1 ;P - patient
+2 ;BD - beginning date
+3 ;ED - ending date
+4 ;T - lab taxonomy
+5 ;LT - loinc taxonomy
+6 ;LN - lab test name
+7 ;return all lab tests that match in array A
+8 ;FORMAT: DATE^TEST NAME^RESULT^V LAB IEN^VISIT IEN
+9 IF '$GET(LT)
SET LT=""
+10 SET LN=$GET(LN)
+11 SET T=$GET(T)
+12 NEW D,V,G,X,J,B,E,C
+13 ;get inverse date and begin at edate-1 and end when greater than begin date
SET B=9999999-BD
SET C=0
SET E=9999999-ED
+14 SET D=E-1
SET D=D_".9999"
SET G=0
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!($PIECE(D,".")>B)
QUIT
Begin DoDot:1
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,X))
IF X'=+X
QUIT
Begin DoDot:2
+16 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AE",P,D,X,Y))
IF Y'=+Y
QUIT
Begin DoDot:3
+17 IF 'T
IF 'LT
IF LN=""
DO SETLAB
QUIT
+18 IF T
IF $DATA(^ATXLAB(T,21,"B",X))
DO SETLAB
QUIT
+19 IF LN]""
IF $$VAL^XBDIQ1(9000010.09,Y,.01)=LN
DO SETLAB
QUIT
+20 IF 'LT
QUIT
+21 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
IF J=""
QUIT
+22 IF '$$LOINC(J,LT)
QUIT
+23 DO SETLAB
QUIT
+24 QUIT
End DoDot:3
+25 QUIT
End DoDot:2
+26 QUIT
End DoDot:1
+27 QUIT
SETLAB ;
+1 SET C=C+1
+2 SET @A@(C)=(9999999-$PIECE(D,"."))_"^"_$$VAL^XBDIQ1(9000010.09,Y,.01)_"^"_$$VAL^XBDIQ1(9000010.09,Y,.04)_"^"_Y_"^"_$PIECE(^AUPNVLAB(Y,0),U,3)
+3 QUIT
LOINC(A,LT,LI) ;
+1 ;no ien or taxonomy
IF '$GET(LT)
IF '$GET(LI)
QUIT ""
+2 SET LI=$GET(LI)
+3 IF A
IF LI
IF A=LI
QUIT 1
+4 NEW %
+5 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+6 IF %]""
IF LT
IF $DATA(^ATXAX(LT,21,"B",%))
QUIT 1
+7 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+8 IF $DATA(^ATXAX(LT,21,"B",%))
QUIT 1
+9 QUIT ""
LTAP ;EP - CALCULATE LTAP
+1 KILL ^TMP($JOB,"PATSLAB")
+2 KILL APCMLABS
+3 DO LTAP1
+4 NEW APCMP,N,F
+5 SET (APCMD1,APCMN1)=0
+6 SET APCMP=APCMFAC
+7 ;denom field for this measure
SET F=$PIECE(^APCM24OB(APCMIC,0),U,8)
+8 ;returns # of lab orders^# not written by nature of order
SET N=$PIECE($GET(APCMLABS(APCMFAC)),U,1)
+9 DO S^APCM24E1(APCMRPT,APCMIC,N,APCMFAC,APCMRPTT,APCMTIME,F)
+10 ;now set patient list for this FACILITY
+11 SET P=0
FOR
SET P=$ORDER(^TMP($JOB,"PATSLAB",APCMFAC,P))
IF P'=+P
QUIT
Begin DoDot:1
+12 SET D=$PIECE(^TMP($JOB,"PATSLAB",APCMFAC,P),U,1)
SET N=$PIECE(^TMP($JOB,"PATSLAB",APCMFAC,P),U,2)
SET APCMVALU="# Orders: "_D_"|||"_"# RESULTED: "_N_" # NOT RESULTED: "_(D-N)
+13 SET DFN=P
DO SETLIST^APCM24E1
End DoDot:1
+14 ;numerator?
+15 SET F=$PIECE(^APCM24OB(APCMIC,0),U,9)
+16 SET N=$PIECE($GET(APCMLABS(APCMFAC)),U,2)
+17 DO S^APCM24E1(APCMRPT,APCMIC,N,APCMFAC,APCMRPTT,APCMTIME,F)
+18 KILL ^TMP($JOB,"PATSLAB"),^TMP($JOB,"ORDERSPROCESSED")
+19 QUIT
LTAP1 ;EP -
+1 ;between BD and ED
+2 ;SET ARRAY APCMLABS to APCMLABS(prov ien)=denom^numer
+3 KILL ^TMP($JOB,"PATSLAB")
+4 NEW ID,C,Y,X,D,S,N,A,B,R,PAT,G,SPECNO,ORPFILE,ORPTST,ORNS,PATLOC,ORACT0,ORORD,ORDEB,LRPAT
+5 SET ID=$$FMADD^XLFDT(APCMBDAT,-1)
SET ID=ID_".9999"
+6 FOR
SET ID=$ORDER(^LRO(69,ID))
IF ID'=+ID!($PIECE(ID,".")>APCMEDAT)
QUIT
Begin DoDot:1
+7 ;GET FIRST SPECIMEN IN MULTIPLE
+8 SET SPECNO=0
FOR
SET SPECNO=$ORDER(^LRO(69,ID,1,SPECNO))
IF SPECNO'=+SPECNO
QUIT
Begin DoDot:2
+9 ;S ^TMP($J,"ORDERSPROCESSED",SPECNO)=""
+10 ;GET Patient lRDFN
SET LRPAT=+$PIECE($GET(^LRO(69,ID,1,SPECNO,0)),U,1)
+11 ;GET DFN
+12 SET A=$PIECE($GET(^LR(LRPAT,0)),U,2)
IF A'=2
QUIT
+13 SET PAT=$PIECE($GET(^LR(LRPAT,0)),U,3)
+14 ;Quit if demo patient
IF $$DEMO^APCLUTL(PAT,APCMDEMO)
QUIT
+15 ;FILE 44 IEN
SET PATLOC=+$PIECE($GET(^LRO(69,ID,1,SPECNO,0)),U,9)
+16 ;IF ER LOC Q
SET C=""
IF PATLOC
IF $DATA(^SC(PATLOC,0))
SET C=$PIECE(^SC(PATLOC,0),U,7)
IF C
IF $PIECE($GET(^DIC(40.7,C,0)),U,2)=30
QUIT
+17 ;quit if there is a ward on the file 44 entry
+18 ;HAS A WARD POINTER
IF $PIECE($GET(^SC(PATLOC,42)),U,1)
QUIT
+19 ;SET DENOM COUNT
+20 ;I DUZ=2793 W !,"PAT: ",$P(^DPT(PAT,0),U,1),"DATE: ",$$FMTE^XLFDT(ID)," ORDER: ",SPECNO," NATURE: ",ORORD
+21 SET $PIECE(APCMLABS(APCMFAC),U,1)=$PIECE($GET(APCMLABS(APCMFAC)),U,1)+1
SET $PIECE(^TMP($JOB,"PATSLAB",APCMFAC,PAT),U,1)=$PIECE($GET(^TMP($JOB,"PATSLAB",APCMFAC,PAT)),U,1)+1
+22 ;
+23 ;now check to see if it has a RESULT, IF NOT, quit and don't set numerator
+24 ;USE FIRST TEST ONLY
+25 SET A=0
SET A=$ORDER(^LRO(69,ID,1,SPECNO,2,A))
IF 'A
QUIT
Begin DoDot:3
+26 ;$P(^LRO(69,ID,1,SPECNO,2,A,0),U,1) ;TEST IEN
SET T=A
+27 SET B=$$RESULT(ID,SPECNO,T)
+28 IF $PIECE(B,U)="-1"
QUIT
+29 SET $PIECE(APCMLABS(APCMFAC),U,2)=$PIECE(APCMLABS(APCMFAC),U,2)+1
SET $PIECE(^TMP($JOB,"PATSLAB",APCMFAC,PAT),U,2)=$PIECE($GET(^TMP($JOB,"PATSLAB",APCMFAC,PAT)),U,2)+1
End DoDot:3
End DoDot:2
End DoDot:1
+30 QUIT
+31 ;
+32 ; ^LRO(69,LRODT,1,LRSP,2,LRAT)
+33 ; LRODT = DATE ORDERED
+34 ; LRSP = SPECIMEN #
+35 ; LRAT = TEST
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)
+2 NEW LROIENS,LRAA,LRAD,LRAN,F6OPTR,F6ODN,LRAIENS,LRDFN,LRIDT,RESULT
+3 ;
+4 SET LROIENS=LRAT_","_LRSP_","_LRODT
+5 SET LRAA=$$GET1^DIQ(69.03,LROIENS,"ACCESSION AREA","I")
+6 SET LRAD=$$GET1^DIQ(69.03,LROIENS,"ACCESSION DATE","I")
+7 SET LRAN=$$GET1^DIQ(69.03,LROIENS,"ACCESSION NUMBER","I")
+8 ;
+9 SET F60PTR=$$GET1^DIQ(69.03,LROIENS,"TEST/PROCEDURE","I")
+10 SET F60DN=$$GET1^DIQ(60,F60PTR,"DATA NAME","I")
+11 ;
+12 SET LRAIENS=LRAN_","_LRAD_","_LRAA
+13 SET LRDFN=$$GET1^DIQ(68.02,LRAIENS,"LRDFN","I")
+14 SET LRIDT=$$GET1^DIQ(68.02,LRAIENS,"INVERSE DATE","I")
+15 ;
+16 SET RESULT=$$GET1^DIQ(63.04,LRIDT_","_LRDFN,F60DN)
+17 QUIT $SELECT($LENGTH(RESULT):RESULT,1:"-1^MISSING RESULT")
