APCM11EP ; IHS/CMI/LAB - IHS MU ;
;;1.0;IHS MU PERFORMANCE REPORTS;**1,4,5,6**;MAR 26, 2012;Build 65
;
;
PRINT ;EP
K ^TMP($J)
S APCMIOSL=$S($G(APCMGUI):55,1:IOSL)
S APCMQUIT=""
S ^TMP($J,"APCMDEL",0)=0
I APCMROT="D" G DEL
S APCMPTYP="P"
D ^APCM11EH
S APCMGPG=0
S APCMQUIT=""
I APCMSUM="F" D PRINT1
D SUMEOP
D SUM
D W^APCM11EH(" ",0,2,APCMPTYP)
D LIST^APCM11NP
D W^APCM11EH(" ",0,2,APCMPTYP)
K ^TMP($J)
I APCMROT="P" K ^XTMP("APCM1D",APCMJ,APCMH) D EOP Q
;
DEL ;create delimited output file
D ^%ZISC
K ^TMP($J)
S ^TMP($J,"APCMDEL",0)=0
S APCMPTYP="D"
D ^APCM11EH
S APCMQUIT=""
I APCMSUM="F" D PRINT1
Q:APCMQUIT
D SUM
Q:APCMQUIT
D LIST^APCM11NP
Q:APCMQUIT
D SAVEDEL^APCM11EQ
K ^XTMP("APCM1D",APCMJ,APCMH)
K ^TMP($J)
D EOP
Q
WP ;
K ^UTILITY($J,"W")
S APCMZ=0,APCMLCNT=0
S DIWL=1,DIWR=APCMCOL,DIWF="",APCMZ=0 F S APCMZ=$O(^APCMMUM(APCMIC,APCMNODE,APCMY,1,APCMZ)) Q:APCMZ'=+APCMZ D
.S APCMLCNT=APCMLCNT+1
.S X=^APCMMUM(APCMIC,APCMNODE,APCMY,1,APCMZ,0) S:APCMLCNT=1 X=" - "_X D ^DIWP
.Q
WPS ;
S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z D
.I APCMPTYP="P",$Y>(APCMIOSL-3) D HEADER Q:APCMQUIT
.D W^APCM11EH(^UTILITY($J,"W",DIWL,Z,0),0,1,APCMPTYP)
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W"),X
Q
EOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:$D(ZTQUEUED)!(IOT'["TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR("A")="End of Report. Press Enter",DIR(0)="E" D ^DIR
Q
;
SUMEOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:$D(ZTQUEUED)!(IOT'["TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR("A")="End of Full Report. Press Enter to continue to the Summary Report.",DIR(0)="E" D ^DIR
Q
;
PRINT1 ;EP
;REORDER THE PROVIDERS ALPHABETICALLY
K APCMINDO
S X=0 F S X=$O(APCMIND(X)) Q:X'=+X D
.S C=$P(^APCMMUM(X,0),U,3)
.S O=$P(^APCMMUM(X,0),U,4)
.S APCMINDO(C,O,X)=""
I APCMRPTT=2 G PRINT1H
K APCMPROV
S X=0 F S X=$O(APCMPRV(X)) Q:X'=+X S APCMPROV($P(^VA(200,X,0),U),X)=""
S APCMPNAM="" F S APCMPNAM=$O(APCMPROV(APCMPNAM)) Q:APCMPNAM=""!(APCMQUIT) D
.S APCMPROV=0 F S APCMPROV=$O(APCMPROV(APCMPNAM,APCMPROV)) Q:APCMPROV=""!(APCMQUIT) D PRINT1N
Q
PRINT1H ;
S APCMPNAM=$P(^DIC(4,APCMFAC,0),U,1)
S APCMPROV=APCMFAC
D PRINT1N
Q
PRINT1N ;REORDER THE PRINT BY CORE,ORDER THEN MENU,ORDER
I APCMPTYP="D" D HEADER1
S APCMCM="" F S APCMCM=$O(APCMINDO(APCMCM)) Q:APCMCM=""!(APCMQUIT) D
.S APCMMO=0 F S APCMMO=$O(APCMINDO(APCMCM,APCMMO)) Q:APCMMO=""!(APCMQUIT) D
..S APCMIC=0 F S APCMIC=$O(APCMINDO(APCMCM,APCMMO,APCMIC)) Q:APCMIC=""!(APCMQUIT) D PRINT2
Q
PRINT2 ;
I APCMPTYP="P" D HEADER Q:APCMQUIT
;I APCMPTYP="D" D W^APCM11EH(" ",0,$S(APCMPTYP="D":2,1:1),APCMPTYP)
D W^APCM11EH("#"_$P(^APCMMUM(APCMIC,0),U,15)_" "_$P(^APCMMUM(APCMIC,0),U,5)_", "_$$VAL^XBDIQ1(9001300.02,APCMIC,.03),0,1,APCMPTYP)
I APCMPTYP="P",$Y>(APCMIOSL-4) D HEADER Q:APCMQUIT
D W^APCM11EH("Objective:",0,2,APCMPTYP)
S APCMNODE=11
S APCMX=0 F S APCMX=$O(^APCMMUM(APCMIC,APCMNODE,APCMX)) Q:APCMX'=+APCMX!(APCMQUIT) D
.I APCMPTYP="P",$Y>(APCMIOSL-4) D HEADER Q:APCMQUIT
.D W^APCM11EH(^APCMMUM(APCMIC,APCMNODE,APCMX,0),0,1,APCMPTYP)
Q:APCMQUIT
I APCMPTYP="P",$Y>(APCMIOSL-4) D HEADER Q:APCMQUIT
S APCMNODE=21
D W^APCM11EH("Stage 1 Measure:",0,2,APCMPTYP)
S APCMX=0 F S APCMX=$O(^APCMMUM(APCMIC,APCMNODE,APCMX)) Q:APCMX'=+APCMX!(APCMQUIT) D
.I APCMPTYP="P",$Y>(APCMIOSL-4) D HEADER Q:APCMQUIT
.D W^APCM11EH(^APCMMUM(APCMIC,APCMNODE,APCMX,0),0,1,APCMPTYP)
Q:APCMQUIT
I APCMPTYP="P",$Y>(APCMIOSL-4) D HEADER Q:APCMQUIT
D W^APCM11EH("CMS Denominator:",0,2,APCMPTYP)
S APCMNODE=14
S APCMX=0 F S APCMX=$O(^APCMMUM(APCMIC,APCMNODE,APCMX)) Q:APCMX'=+APCMX!(APCMQUIT) D
.I APCMPTYP="P",$Y>(APCMIOSL-4) D HEADER Q:APCMQUIT
.D W^APCM11EH(^APCMMUM(APCMIC,APCMNODE,APCMX,0),0,1,APCMPTYP)
Q:APCMQUIT
I APCMPTYP="P",$Y>(APCMIOSL-4) D HEADER Q:APCMQUIT
S APCMNODE=16
D W^APCM11EH("CMS Numerator:",0,2,APCMPTYP)
S APCMX=0 F S APCMX=$O(^APCMMUM(APCMIC,APCMNODE,APCMX)) Q:APCMX'=+APCMX!(APCMQUIT) D
.I APCMPTYP="P",$Y>(APCMIOSL-4) D HEADER Q:APCMQUIT
.D W^APCM11EH(^APCMMUM(APCMIC,APCMNODE,APCMX,0),0,1,APCMPTYP)
Q:APCMQUIT
I APCMPTYP="P",$Y>(APCMIOSL-4) D HEADER Q:APCMQUIT
S APCMNODE=18
D W^APCM11EH("IHS Logic:",0,2,APCMPTYP)
S APCMX=0 F S APCMX=$O(^APCMMUM(APCMIC,APCMNODE,APCMX)) Q:APCMX'=+APCMX!(APCMQUIT) D
.I APCMPTYP="P",$Y>(APCMIOSL-4) D HEADER Q:APCMQUIT
.D W^APCM11EH(^APCMMUM(APCMIC,APCMNODE,APCMX,0),0,1,APCMPTYP)
Q:APCMQUIT
D W^APCM11EH("",0,1,APCMPTYP)
D PRNTM
Q
;
SCREEN ;
S X=0 F S X=$O(^TMP($J,"APCMDEL",X)) Q:X'=+X W !,^TMP($J,"APCMDEL",X)
Q
EXIT ;
I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED) W ! S DIR(0)="EO",DIR("A")="End of report. Press ENTER" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
;
CALC(N,O) ;ENTRY POINT
NEW Z
S Z=N-O,Z=$FN(Z,"+,",1)
Q Z
;
SB(X) ;EP - Strip
NEW %
X ^DD("FUNC",$O(^DD("FUNC","B","STRIPBLANKS",0)),1)
Q X
;
C(X,X2,X3) ;
I X'?.N Q $$RBLK^APCLUTL(X,10)
D COMMA^%DTC
Q X
;
H2 ;EP
I APCMPTYP="P" D
.D W^APCM11EH($$C(APCMCYN,0,8),0,0,APCMPTYP,,26)
.D W^APCM11EH($J(APCMCYP,5,1)_"%",0,0,APCMPTYP,,36)
.D W^APCM11EH($$C(APCMPRN,0,8),0,0,APCMPTYP,,44)
.D W^APCM11EH($J(APCMPRP,5,1)_"%",0,0,APCMPTYP,,55)
.D W^APCM11EH($G(^APCMMUM(APCMIC,13,1,0)),0,0,APCMPTYP,,64)
I APCMPTYP="D" D
.S APCMX=""
.S APCMX=+APCMCYN
.S $P(APCMX,U,2)=$$SB($J(APCMCYP,5,1))
.S $P(APCMX,U,3)=+APCMPRN
.S $P(APCMX,U,4)=$$SB($J(APCMPRP,5,1))
.S $P(APCMX,U,5)=$G(^APCMMUM(APCMIC,13,1,0))
.D W^APCM11EH(APCMX,0,0,APCMPTYP,2)
Q
;
H1 ;EP
D W^APCM11EH("Current",0,2,APCMPTYP,2,26)
D W^APCM11EH("Previous",0,0,APCMPTYP,4,44)
D W^APCM11EH("Stage 1",0,0,APCMPTYP,6,64)
D W^APCM11EH("Period",0,1,APCMPTYP,2,26)
I $P(^APCMMUM(APCMIC,0),U,6)="R" D W^APCM11EH("%",0,0,APCMPTYP,3,38)
D W^APCM11EH("Period",0,0,APCMPTYP,4,44)
I $P(^APCMMUM(APCMIC,0),U,6)="R" D W^APCM11EH("%",0,0,APCMPTYP,5,57)
D W^APCM11EH("Target",0,0,APCMPTYP,6,64)
Q
;
;
G:'APCMGPG HEADER1
K DIR I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCMQUIT=1 Q
;
I APCMPTYP="P" W:$D(IOF) @IOF S APCMGPG=APCMGPG+1
I APCMPTYP="P" S X=$P(^VA(200,DUZ,0),U,2),$E(X,35)=$$FMTE^XLFDT(DT),$E(X,70)="Page "_APCMGPG D W^APCM11EH(X,0,1,APCMPTYP)
D W^APCM11EH("Indian Health Service RPMS Suite (BCER) v1.0",1,2,APCMPTYP)
I APCMRPTT=1 D W^APCM11EH("** IHS 2011 Stage 1 Meaningful Use Performance Measure Report for EPs **",1,1,APCMPTYP)
I APCMRPTT=2 D W^APCM11EH("** IHS 2011 Stage 1 MU Performance Report for Eligible Hospitals/CAHs **",1,1,APCMPTYP)
I $G(APCMPROV),APCMRPTT=1 S X="Provider Name: "_$$SN^APCM11EH($P(^VA(200,APCMPROV,0),U,1)) D W^APCM11EH(X,1,1,APCMPTYP)
I $G(APCMPROV),APCMRPTT=2 S X="Facility Name: "_$P(^DIC(4,APCMPROV,0),U,1) D W^APCM11EH(X,1,1,APCMPTYP)
I $G(APCMTOT) S X="Aggregate Report for all Selected Providers" D W^APCM11EH(X,1,1,APCMPTYP)
I APCMRPTT=1 S X="Facility Name: "_$P(^DIC(4,DUZ(2),0),U,1) D W^APCM11EH(X,1,1,APCMPTYP)
S X="Report Period: "_$$FMTE^XLFDT(APCMBD)_" to "_$$FMTE^XLFDT(APCMED) D W^APCM11EH(X,1,1,APCMPTYP)
I $G(APCMWPP) S X="Previous Period: "_$$FMTE^XLFDT(APCMPBD)_" to "_$$FMTE^XLFDT(APCMPED) D W^APCM11EH(X,1,1,APCMPTYP)
S X=$$REPEAT^XLFSTR("-",80) D W^APCM11EH(X,0,1,APCMPTYP)
Q
;
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
;----------
USR() ;EP - Return name .
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
PRNTM ;print 1 measure
;APCMPROV=provider
;APCMIC=measure ien
I APCMPTYP="P",$Y>(APCMIOSL-14) D HEADER Q:APCMQUIT
D H1
PI1 ;EP
;check exclusion field and print value if any and quit
S APCMDF=$P(^APCMMUM(APCMIC,0),U,8)
;get DENOMINATOR value
S APCMNP=$P(^DD(9001300.0311,APCMDF,0),U,4),N=$P(APCMNP,";"),P=$P(APCMNP,";",2)
S APCMCYD=$$V(1,APCMRPT,N,P,APCMPROV,$S($G(APCMTOT):"T",1:"I"),APCMRPTT)
S APCMPRD=$$V(2,APCMRPT,N,P,APCMPROV,$S($G(APCMTOT):"T",1:"I"),APCMRPTT)
;write out DENOMINATOR
K ^UTILITY($J,"W")
S APCMZ=0
S DIWL=1,DIWR=20 F S APCMZ=$O(^APCMMUM(APCMIC,15,APCMZ)) Q:APCMZ'=+APCMZ D
.S (X,APCMX)=^APCMMUM(APCMIC,15,APCMZ,0) D ^DIWP
.Q
;
I APCMPTYP="P" S APCMZ=0 F S APCMZ=$O(^UTILITY($J,"W",DIWL,APCMZ)) Q:APCMZ'=+APCMZ D W^APCM11EH(^UTILITY($J,"W",DIWL,APCMZ,0),0,1,APCMPTYP,1)
I APCMPTYP="D" D W^APCM11EH(APCMX,0,1,APCMPTYP)
K DIWL,DIWR,DIWF,APCMZ
K ^UTILITY($J,"W")
I APCMPTYP="P" D
.D W^APCM11EH($$C(APCMCYD,0,8),0,0,APCMPTYP,1,26)
.I $P(^APCMMUM(APCMIC,0),U,6)'="A" D W^APCM11EH($$C(APCMPRD,0,8),0,0,APCMPTYP,1,44)
.I $P(^APCMMUM(APCMIC,0),U,6)="A" D W^APCM11EH($$C("N/A"),0,0,APCMPTYP,1,44)
.I $P(^APCMMUM(APCMIC,0),U,6)="A" D W^APCM11EH($G(^APCMMUM(APCMIC,13,1,0)),0,0,APCMPTYP,,64)
.D W^APCM11EH("",0,1,APCMPTYP)
I APCMPTYP="D" D
.I APCMCYD="" S APCMCYD=0
.I APCMPRD="" S APCMPRD=0
.S Y=APCMCYD_"^^"_APCMPRD
.I $P(^APCMMUM(APCMIC,0),U,6)="A" S $P(Y,U,3)="N/A",Y=Y_U_U_$G(^APCMMUM(APCMIC,13,1,0)) D W^APCM11EH(Y,0,0,APCMPTYP,2),W^APCM11EH(" ",0,1,APCMPTYP)
.I $P(^APCMMUM(APCMIC,0),U,6)'="A" D W^APCM11EH(Y,0,0,APCMPTYP,2)
DENOMO ;
I $P(^APCMMUM(APCMIC,0),U,6)="A" G EXCL
S APCMNF=$P(^APCMMUM(APCMIC,0),U,9)
I APCMNF="" Q
S APCMNP=$P(^DD(9001300.0311,APCMNF,0),U,4),N=$P(APCMNP,";"),P=$P(APCMNP,";",2)
D SETN
;write header
K ^UTILITY($J,"W")
S APCMZ=0
S DIWL=1,DIWR=20 F S APCMZ=$O(^APCMMUM(APCMIC,17,APCMZ)) Q:APCMZ'=+APCMZ D
.S (X,APCMX)=^APCMMUM(APCMIC,17,APCMZ,0) D ^DIWP
.Q
;
I APCMPTYP="P" S APCMZ=0 F S APCMZ=$O(^UTILITY($J,"W",DIWL,APCMZ)) Q:APCMZ'=+APCMZ D W^APCM11EH(^UTILITY($J,"W",DIWL,APCMZ,0),0,1,APCMPTYP,1)
I APCMPTYP="D" D W^APCM11EH(APCMX,0,1,APCMPTYP,1)
K DIWL,DIWR,DIWF,APCMZ
K ^UTILITY($J,"W")
D H2
EXCL ;
S APCMEF=$P(^APCMMUM(APCMIC,0),U,11) I APCMEF]"" D
.;D H1
.S APCMNP=$P(^DD(9001300.0311,APCMEF,0),U,4),N=$P(APCMNP,";"),P=$P(APCMNP,";",2)
.S APCMEV=$$V(1,APCMRPT,N,P,APCMPROV,$S($G(APCMTOT):"T",1:"I"),APCMRPTT)
.I APCMEV]"" D
..I APCMPTYP="P",$Y>(APCMIOSL-4) D HEADER Q:APCMQUIT
..;S X=$P(^APCMMUM(APCMIC,0),U,5) D W^APCM11EH(X,0,2,APCMPTYP)
..K ^UTILITY($J,"W")
..D W^APCM11EH(" ",0,1,APCMPTYP)
..I APCMPTYP="P" D
...S DIWL=1,DIWR=78,X=APCMEV
...D ^DIWP
...S APCMZ=0 F S APCMZ=$O(^UTILITY($J,"W",DIWL,APCMZ)) Q:APCMZ'=+APCMZ D W^APCM11EH(^UTILITY($J,"W",DIWL,APCMZ,0),0,1,APCMPTYP,1,0)
...K DIWL,DIWR,DIWF,APCMZ
..I APCMPTYP="D" D W^APCM11EH(APCMEV,0,1,APCMPTYP,2)
..K ^UTILITY($J,"W")
D W^APCM11EH(" ",0,1,APCMPTYP)
Q
;
SETN ;EP - set numerator fields
S APCMCYN=$$V(1,APCMRPT,N,P,APCMPROV,$S($G(APCMTOT):"T",1:"I"),APCMRPTT) ;SPDX
S APCMPRN=$$V(2,APCMRPT,N,P,APCMPROV,$S($G(APCMTOT):"T",1:"I"),APCMRPTT) ;SPDX
I APCMCYN="" S APCMCYN=0
I APCMPRN="" S APCMPRN=0
Q:$P(^APCMMUM(APCMIC,0),U,6)="A" ;no % on attestation measures
S APCMCYP=$S(APCMCYD:((APCMCYN/APCMCYD)*100),1:"")
S APCMPRP=$S(APCMPRD:((APCMPRN/APCMPRD)*100),1:"")
Q
;
V(T,R,N,P,PROV,K,RT) ;EP ;SPDX
NEW X,Y,Z,I,J
I RT=1 S I=PROV_";VA(200,"
I RT=2 S I=PROV_";AUTTLOC("
I K="T" S I="TOTAL"
I T=1 D Q X
.S J=$O(^APCMMUDC(R,$S(K="I":11,1:12),"B",I,0))
.I 'J S X=0 Q
.S X=$P($G(^APCMMUDC(R,$S(K="I":11,1:12),J,N)),U,P)
I T=2 D Q X
.S J=$O(^APCMMUDP(R,$S(K="I":11,1:12),"B",I,0))
.I 'J S X=0 Q
.S X=$P($G(^APCMMUDP(R,$S(K="I":11,1:12),J,N)),U,P)
Q ""
SUM ;summary sheet for each provider
D SUM^APCM11ER
Q
APCM11EP ; IHS/CMI/LAB - IHS MU ;
+1 ;;1.0;IHS MU PERFORMANCE REPORTS;**1,4,5,6**;MAR 26, 2012;Build 65
+2 ;
+3 ;
PRINT ;EP
+1 KILL ^TMP($JOB)
+2 SET APCMIOSL=$SELECT($GET(APCMGUI):55,1:IOSL)
+3 SET APCMQUIT=""
+4 SET ^TMP($JOB,"APCMDEL",0)=0
+5 IF APCMROT="D"
GOTO DEL
+6 SET APCMPTYP="P"
+7 DO ^APCM11EH
+8 SET APCMGPG=0
+9 SET APCMQUIT=""
+10 IF APCMSUM="F"
DO PRINT1
+11 DO SUMEOP
+12 DO SUM
+13 DO W^APCM11EH(" ",0,2,APCMPTYP)
+14 DO LIST^APCM11NP
+15 DO W^APCM11EH(" ",0,2,APCMPTYP)
+16 KILL ^TMP($JOB)
+17 IF APCMROT="P"
KILL ^XTMP("APCM1D",APCMJ,APCMH)
DO EOP
QUIT
+18 ;
DEL ;create delimited output file
+1 DO ^%ZISC
+2 KILL ^TMP($JOB)
+3 SET ^TMP($JOB,"APCMDEL",0)=0
+4 SET APCMPTYP="D"
+5 DO ^APCM11EH
+6 SET APCMQUIT=""
+7 IF APCMSUM="F"
DO PRINT1
+8 IF APCMQUIT
QUIT
+9 DO SUM
+10 IF APCMQUIT
QUIT
+11 DO LIST^APCM11NP
+12 IF APCMQUIT
QUIT
+13 DO SAVEDEL^APCM11EQ
+14 KILL ^XTMP("APCM1D",APCMJ,APCMH)
+15 KILL ^TMP($JOB)
+16 DO EOP
+17 QUIT
WP ;
+1 KILL ^UTILITY($JOB,"W")
+2 SET APCMZ=0
SET APCMLCNT=0
+3 SET DIWL=1
SET DIWR=APCMCOL
SET DIWF=""
SET APCMZ=0
FOR
SET APCMZ=$ORDER(^APCMMUM(APCMIC,APCMNODE,APCMY,1,APCMZ))
IF APCMZ'=+APCMZ
QUIT
Begin DoDot:1
+4 SET APCMLCNT=APCMLCNT+1
+5 SET X=^APCMMUM(APCMIC,APCMNODE,APCMY,1,APCMZ,0)
IF APCMLCNT=1
SET X=" - "_X
DO ^DIWP
+6 QUIT
End DoDot:1
WPS ;
+1 SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z
QUIT
Begin DoDot:1
+2 IF APCMPTYP="P"
IF $Y>(APCMIOSL-3)
DO HEADER
IF APCMQUIT
QUIT
+3 DO W^APCM11EH(^UTILITY($JOB,"W",DIWL,Z,0),0,1,APCMPTYP)
End DoDot:1
+4 KILL DIWL,DIWR,DIWF,Z
+5 KILL ^UTILITY($JOB,"W"),X
+6 QUIT
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF $DATA(ZTQUEUED)!(IOT'["TRM")!$DATA(IO("S"))
QUIT
+3 NEW DIR
+4 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+5 SET DIR("A")="End of Report. Press Enter"
SET DIR(0)="E"
DO ^DIR
+6 QUIT
+7 ;
SUMEOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF $DATA(ZTQUEUED)!(IOT'["TRM")!$DATA(IO("S"))
QUIT
+3 NEW DIR
+4 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+5 SET DIR("A")="End of Full Report. Press Enter to continue to the Summary Report."
SET DIR(0)="E"
DO ^DIR
+6 QUIT
+7 ;
PRINT1 ;EP
+1 ;REORDER THE PROVIDERS ALPHABETICALLY
+2 KILL APCMINDO
+3 SET X=0
FOR
SET X=$ORDER(APCMIND(X))
IF X'=+X
QUIT
Begin DoDot:1
+4 SET C=$PIECE(^APCMMUM(X,0),U,3)
+5 SET O=$PIECE(^APCMMUM(X,0),U,4)
+6 SET APCMINDO(C,O,X)=""
End DoDot:1
+7 IF APCMRPTT=2
GOTO PRINT1H
+8 KILL APCMPROV
+9 SET X=0
FOR
SET X=$ORDER(APCMPRV(X))
IF X'=+X
QUIT
SET APCMPROV($PIECE(^VA(200,X,0),U),X)=""
+10 SET APCMPNAM=""
FOR
SET APCMPNAM=$ORDER(APCMPROV(APCMPNAM))
IF APCMPNAM=""!(APCMQUIT)
QUIT
Begin DoDot:1
+11 SET APCMPROV=0
FOR
SET APCMPROV=$ORDER(APCMPROV(APCMPNAM,APCMPROV))
IF APCMPROV=""!(APCMQUIT)
QUIT
DO PRINT1N
End DoDot:1
+12 QUIT
PRINT1H ;
+1 SET APCMPNAM=$PIECE(^DIC(4,APCMFAC,0),U,1)
+2 SET APCMPROV=APCMFAC
+3 DO PRINT1N
+4 QUIT
PRINT1N ;REORDER THE PRINT BY CORE,ORDER THEN MENU,ORDER
+1 IF APCMPTYP="D"
DO HEADER1
+2 SET APCMCM=""
FOR
SET APCMCM=$ORDER(APCMINDO(APCMCM))
IF APCMCM=""!(APCMQUIT)
QUIT
Begin DoDot:1
+3 SET APCMMO=0
FOR
SET APCMMO=$ORDER(APCMINDO(APCMCM,APCMMO))
IF APCMMO=""!(APCMQUIT)
QUIT
Begin DoDot:2
+4 SET APCMIC=0
FOR
SET APCMIC=$ORDER(APCMINDO(APCMCM,APCMMO,APCMIC))
IF APCMIC=""!(APCMQUIT)
QUIT
DO PRINT2
End DoDot:2
End DoDot:1
+5 QUIT
PRINT2 ;
+1 IF APCMPTYP="P"
DO HEADER
IF APCMQUIT
QUIT
+2 ;I APCMPTYP="D" D W^APCM11EH(" ",0,$S(APCMPTYP="D":2,1:1),APCMPTYP)
+3 DO W^APCM11EH("#"_$PIECE(^APCMMUM(APCMIC,0),U,15)_" "_$PIECE(^APCMMUM(APCMIC,0),U,5)_", "_$$VAL^XBDIQ1(9001300.02,APCMIC,.03),0,1,APCMPTYP)
+4 IF APCMPTYP="P"
IF $Y>(APCMIOSL-4)
DO HEADER
IF APCMQUIT
QUIT
+5 DO W^APCM11EH("Objective:",0,2,APCMPTYP)
+6 SET APCMNODE=11
+7 SET APCMX=0
FOR
SET APCMX=$ORDER(^APCMMUM(APCMIC,APCMNODE,APCMX))
IF APCMX'=+APCMX!(APCMQUIT)
QUIT
Begin DoDot:1
+8 IF APCMPTYP="P"
IF $Y>(APCMIOSL-4)
DO HEADER
IF APCMQUIT
QUIT
+9 DO W^APCM11EH(^APCMMUM(APCMIC,APCMNODE,APCMX,0),0,1,APCMPTYP)
End DoDot:1
+10 IF APCMQUIT
QUIT
+11 IF APCMPTYP="P"
IF $Y>(APCMIOSL-4)
DO HEADER
IF APCMQUIT
QUIT
+12 SET APCMNODE=21
+13 DO W^APCM11EH("Stage 1 Measure:",0,2,APCMPTYP)
+14 SET APCMX=0
FOR
SET APCMX=$ORDER(^APCMMUM(APCMIC,APCMNODE,APCMX))
IF APCMX'=+APCMX!(APCMQUIT)
QUIT
Begin DoDot:1
+15 IF APCMPTYP="P"
IF $Y>(APCMIOSL-4)
DO HEADER
IF APCMQUIT
QUIT
+16 DO W^APCM11EH(^APCMMUM(APCMIC,APCMNODE,APCMX,0),0,1,APCMPTYP)
End DoDot:1
+17 IF APCMQUIT
QUIT
+18 IF APCMPTYP="P"
IF $Y>(APCMIOSL-4)
DO HEADER
IF APCMQUIT
QUIT
+19 DO W^APCM11EH("CMS Denominator:",0,2,APCMPTYP)
+20 SET APCMNODE=14
+21 SET APCMX=0
FOR
SET APCMX=$ORDER(^APCMMUM(APCMIC,APCMNODE,APCMX))
IF APCMX'=+APCMX!(APCMQUIT)
QUIT
Begin DoDot:1
+22 IF APCMPTYP="P"
IF $Y>(APCMIOSL-4)
DO HEADER
IF APCMQUIT
QUIT
+23 DO W^APCM11EH(^APCMMUM(APCMIC,APCMNODE,APCMX,0),0,1,APCMPTYP)
End DoDot:1
+24 IF APCMQUIT
QUIT
+25 IF APCMPTYP="P"
IF $Y>(APCMIOSL-4)
DO HEADER
IF APCMQUIT
QUIT
+26 SET APCMNODE=16
+27 DO W^APCM11EH("CMS Numerator:",0,2,APCMPTYP)
+28 SET APCMX=0
FOR
SET APCMX=$ORDER(^APCMMUM(APCMIC,APCMNODE,APCMX))
IF APCMX'=+APCMX!(APCMQUIT)
QUIT
Begin DoDot:1
+29 IF APCMPTYP="P"
IF $Y>(APCMIOSL-4)
DO HEADER
IF APCMQUIT
QUIT
+30 DO W^APCM11EH(^APCMMUM(APCMIC,APCMNODE,APCMX,0),0,1,APCMPTYP)
End DoDot:1
+31 IF APCMQUIT
QUIT
+32 IF APCMPTYP="P"
IF $Y>(APCMIOSL-4)
DO HEADER
IF APCMQUIT
QUIT
+33 SET APCMNODE=18
+34 DO W^APCM11EH("IHS Logic:",0,2,APCMPTYP)
+35 SET APCMX=0
FOR
SET APCMX=$ORDER(^APCMMUM(APCMIC,APCMNODE,APCMX))
IF APCMX'=+APCMX!(APCMQUIT)
QUIT
Begin DoDot:1
+36 IF APCMPTYP="P"
IF $Y>(APCMIOSL-4)
DO HEADER
IF APCMQUIT
QUIT
+37 DO W^APCM11EH(^APCMMUM(APCMIC,APCMNODE,APCMX,0),0,1,APCMPTYP)
End DoDot:1
+38 IF APCMQUIT
QUIT
+39 DO W^APCM11EH("",0,1,APCMPTYP)
+40 DO PRNTM
+41 QUIT
+42 ;
SCREEN ;
+1 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"APCMDEL",X))
IF X'=+X
QUIT
WRITE !,^TMP($JOB,"APCMDEL",X)
+2 QUIT
EXIT ;
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
IF '$DATA(ZTQUEUED)
WRITE !
SET DIR(0)="EO"
SET DIR("A")="End of report. Press ENTER"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 QUIT
+3 ;
CALC(N,O) ;ENTRY POINT
+1 NEW Z
+2 SET Z=N-O
SET Z=$FNUMBER(Z,"+,",1)
+3 QUIT Z
+4 ;
SB(X) ;EP - Strip
+1 NEW %
+2 XECUTE ^DD("FUNC",$ORDER(^DD("FUNC","B","STRIPBLANKS",0)),1)
+3 QUIT X
+4 ;
C(X,X2,X3) ;
+1 IF X'?.N
QUIT $$RBLK^APCLUTL(X,10)
+2 DO COMMA^%DTC
+3 QUIT X
+4 ;
H2 ;EP
+1 IF APCMPTYP="P"
Begin DoDot:1
+2 DO W^APCM11EH($$C(APCMCYN,0,8),0,0,APCMPTYP,,26)
+3 DO W^APCM11EH($JUSTIFY(APCMCYP,5,1)_"%",0,0,APCMPTYP,,36)
+4 DO W^APCM11EH($$C(APCMPRN,0,8),0,0,APCMPTYP,,44)
+5 DO W^APCM11EH($JUSTIFY(APCMPRP,5,1)_"%",0,0,APCMPTYP,,55)
+6 DO W^APCM11EH($GET(^APCMMUM(APCMIC,13,1,0)),0,0,APCMPTYP,,64)
End DoDot:1
+7 IF APCMPTYP="D"
Begin DoDot:1
+8 SET APCMX=""
+9 SET APCMX=+APCMCYN
+10 SET $PIECE(APCMX,U,2)=$$SB($JUSTIFY(APCMCYP,5,1))
+11 SET $PIECE(APCMX,U,3)=+APCMPRN
+12 SET $PIECE(APCMX,U,4)=$$SB($JUSTIFY(APCMPRP,5,1))
+13 SET $PIECE(APCMX,U,5)=$GET(^APCMMUM(APCMIC,13,1,0))
+14 DO W^APCM11EH(APCMX,0,0,APCMPTYP,2)
End DoDot:1
+15 QUIT
+16 ;
H1 ;EP
+1 DO W^APCM11EH("Current",0,2,APCMPTYP,2,26)
+2 DO W^APCM11EH("Previous",0,0,APCMPTYP,4,44)
+3 DO W^APCM11EH("Stage 1",0,0,APCMPTYP,6,64)
+4 DO W^APCM11EH("Period",0,1,APCMPTYP,2,26)
+5 IF $PIECE(^APCMMUM(APCMIC,0),U,6)="R"
DO W^APCM11EH("%",0,0,APCMPTYP,3,38)
+6 DO W^APCM11EH("Period",0,0,APCMPTYP,4,44)
+7 IF $PIECE(^APCMMUM(APCMIC,0),U,6)="R"
DO W^APCM11EH("%",0,0,APCMPTYP,5,57)
+8 DO W^APCM11EH("Target",0,0,APCMPTYP,6,64)
+9 QUIT
+10 ;
+11 ;
+1 IF 'APCMGPG
GOTO HEADER1
+2 KILL DIR
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
IF '$DATA(ZTQUEUED)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCMQUIT=1
QUIT
+3 ;
+1 IF APCMPTYP="P"
IF $DATA(IOF)
WRITE @IOF
SET APCMGPG=APCMGPG+1
+2 IF APCMPTYP="P"
SET X=$PIECE(^VA(200,DUZ,0),U,2)
SET $EXTRACT(X,35)=$$FMTE^XLFDT(DT)
SET $EXTRACT(X,70)="Page "_APCMGPG
DO W^APCM11EH(X,0,1,APCMPTYP)
+3 DO W^APCM11EH("Indian Health Service RPMS Suite (BCER) v1.0",1,2,APCMPTYP)
+4 IF APCMRPTT=1
DO W^APCM11EH("** IHS 2011 Stage 1 Meaningful Use Performance Measure Report for EPs **",1,1,APCMPTYP)
+5 IF APCMRPTT=2
DO W^APCM11EH("** IHS 2011 Stage 1 MU Performance Report for Eligible Hospitals/CAHs **",1,1,APCMPTYP)
+6 IF $GET(APCMPROV)
IF APCMRPTT=1
SET X="Provider Name: "_$$SN^APCM11EH($PIECE(^VA(200,APCMPROV,0),U,1))
DO W^APCM11EH(X,1,1,APCMPTYP)
+7 IF $GET(APCMPROV)
IF APCMRPTT=2
SET X="Facility Name: "_$PIECE(^DIC(4,APCMPROV,0),U,1)
DO W^APCM11EH(X,1,1,APCMPTYP)
+8 IF $GET(APCMTOT)
SET X="Aggregate Report for all Selected Providers"
DO W^APCM11EH(X,1,1,APCMPTYP)
+9 IF APCMRPTT=1
SET X="Facility Name: "_$PIECE(^DIC(4,DUZ(2),0),U,1)
DO W^APCM11EH(X,1,1,APCMPTYP)
+10 SET X="Report Period: "_$$FMTE^XLFDT(APCMBD)_" to "_$$FMTE^XLFDT(APCMED)
DO W^APCM11EH(X,1,1,APCMPTYP)
+11 IF $GET(APCMWPP)
SET X="Previous Period: "_$$FMTE^XLFDT(APCMPBD)_" to "_$$FMTE^XLFDT(APCMPED)
DO W^APCM11EH(X,1,1,APCMPTYP)
+12 SET X=$$REPEAT^XLFSTR("-",80)
DO W^APCM11EH(X,0,1,APCMPTYP)
+13 QUIT
+14 ;
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
+3 ;----------
USR() ;EP - Return name .
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
PRNTM ;print 1 measure
+1 ;APCMPROV=provider
+2 ;APCMIC=measure ien
+3 IF APCMPTYP="P"
IF $Y>(APCMIOSL-14)
DO HEADER
IF APCMQUIT
QUIT
+4 DO H1
PI1 ;EP
+1 ;check exclusion field and print value if any and quit
+2 SET APCMDF=$PIECE(^APCMMUM(APCMIC,0),U,8)
+3 ;get DENOMINATOR value
+4 SET APCMNP=$PIECE(^DD(9001300.0311,APCMDF,0),U,4)
SET N=$PIECE(APCMNP,";")
SET P=$PIECE(APCMNP,";",2)
+5 SET APCMCYD=$$V(1,APCMRPT,N,P,APCMPROV,$SELECT($GET(APCMTOT):"T",1:"I"),APCMRPTT)
+6 SET APCMPRD=$$V(2,APCMRPT,N,P,APCMPROV,$SELECT($GET(APCMTOT):"T",1:"I"),APCMRPTT)
+7 ;write out DENOMINATOR
+8 KILL ^UTILITY($JOB,"W")
+9 SET APCMZ=0
+10 SET DIWL=1
SET DIWR=20
FOR
SET APCMZ=$ORDER(^APCMMUM(APCMIC,15,APCMZ))
IF APCMZ'=+APCMZ
QUIT
Begin DoDot:1
+11 SET (X,APCMX)=^APCMMUM(APCMIC,15,APCMZ,0)
DO ^DIWP
+12 QUIT
End DoDot:1
+13 ;
+14 IF APCMPTYP="P"
SET APCMZ=0
FOR
SET APCMZ=$ORDER(^UTILITY($JOB,"W",DIWL,APCMZ))
IF APCMZ'=+APCMZ
QUIT
DO W^APCM11EH(^UTILITY($JOB,"W",DIWL,APCMZ,0),0,1,APCMPTYP,1)
+15 IF APCMPTYP="D"
DO W^APCM11EH(APCMX,0,1,APCMPTYP)
+16 KILL DIWL,DIWR,DIWF,APCMZ
+17 KILL ^UTILITY($JOB,"W")
+18 IF APCMPTYP="P"
Begin DoDot:1
+19 DO W^APCM11EH($$C(APCMCYD,0,8),0,0,APCMPTYP,1,26)
+20 IF $PIECE(^APCMMUM(APCMIC,0),U,6)'="A"
DO W^APCM11EH($$C(APCMPRD,0,8),0,0,APCMPTYP,1,44)
+21 IF $PIECE(^APCMMUM(APCMIC,0),U,6)="A"
DO W^APCM11EH($$C("N/A"),0,0,APCMPTYP,1,44)
+22 IF $PIECE(^APCMMUM(APCMIC,0),U,6)="A"
DO W^APCM11EH($GET(^APCMMUM(APCMIC,13,1,0)),0,0,APCMPTYP,,64)
+23 DO W^APCM11EH("",0,1,APCMPTYP)
End DoDot:1
+24 IF APCMPTYP="D"
Begin DoDot:1
+25 IF APCMCYD=""
SET APCMCYD=0
+26 IF APCMPRD=""
SET APCMPRD=0
+27 SET Y=APCMCYD_"^^"_APCMPRD
+28 IF $PIECE(^APCMMUM(APCMIC,0),U,6)="A"
SET $PIECE(Y,U,3)="N/A"
SET Y=Y_U_U_$GET(^APCMMUM(APCMIC,13,1,0))
DO W^APCM11EH(Y,0,0,APCMPTYP,2)
DO W^APCM11EH(" ",0,1,APCMPTYP)
+29 IF $PIECE(^APCMMUM(APCMIC,0),U,6)'="A"
DO W^APCM11EH(Y,0,0,APCMPTYP,2)
End DoDot:1
DENOMO ;
+1 IF $PIECE(^APCMMUM(APCMIC,0),U,6)="A"
GOTO EXCL
+2 SET APCMNF=$PIECE(^APCMMUM(APCMIC,0),U,9)
+3 IF APCMNF=""
QUIT
+4 SET APCMNP=$PIECE(^DD(9001300.0311,APCMNF,0),U,4)
SET N=$PIECE(APCMNP,";")
SET P=$PIECE(APCMNP,";",2)
+5 DO SETN
+6 ;write header
+7 KILL ^UTILITY($JOB,"W")
+8 SET APCMZ=0
+9 SET DIWL=1
SET DIWR=20
FOR
SET APCMZ=$ORDER(^APCMMUM(APCMIC,17,APCMZ))
IF APCMZ'=+APCMZ
QUIT
Begin DoDot:1
+10 SET (X,APCMX)=^APCMMUM(APCMIC,17,APCMZ,0)
DO ^DIWP
+11 QUIT
End DoDot:1
+12 ;
+13 IF APCMPTYP="P"
SET APCMZ=0
FOR
SET APCMZ=$ORDER(^UTILITY($JOB,"W",DIWL,APCMZ))
IF APCMZ'=+APCMZ
QUIT
DO W^APCM11EH(^UTILITY($JOB,"W",DIWL,APCMZ,0),0,1,APCMPTYP,1)
+14 IF APCMPTYP="D"
DO W^APCM11EH(APCMX,0,1,APCMPTYP,1)
+15 KILL DIWL,DIWR,DIWF,APCMZ
+16 KILL ^UTILITY($JOB,"W")
+17 DO H2
EXCL ;
+1 SET APCMEF=$PIECE(^APCMMUM(APCMIC,0),U,11)
IF APCMEF]""
Begin DoDot:1
+2 ;D H1
+3 SET APCMNP=$PIECE(^DD(9001300.0311,APCMEF,0),U,4)
SET N=$PIECE(APCMNP,";")
SET P=$PIECE(APCMNP,";",2)
+4 SET APCMEV=$$V(1,APCMRPT,N,P,APCMPROV,$SELECT($GET(APCMTOT):"T",1:"I"),APCMRPTT)
+5 IF APCMEV]""
Begin DoDot:2
+6 IF APCMPTYP="P"
IF $Y>(APCMIOSL-4)
DO HEADER
IF APCMQUIT
QUIT
+7 ;S X=$P(^APCMMUM(APCMIC,0),U,5) D W^APCM11EH(X,0,2,APCMPTYP)
+8 KILL ^UTILITY($JOB,"W")
+9 DO W^APCM11EH(" ",0,1,APCMPTYP)
+10 IF APCMPTYP="P"
Begin DoDot:3
+11 SET DIWL=1
SET DIWR=78
SET X=APCMEV
+12 DO ^DIWP
+13 SET APCMZ=0
FOR
SET APCMZ=$ORDER(^UTILITY($JOB,"W",DIWL,APCMZ))
IF APCMZ'=+APCMZ
QUIT
DO W^APCM11EH(^UTILITY($JOB,"W",DIWL,APCMZ,0),0,1,APCMPTYP,1,0)
+14 KILL DIWL,DIWR,DIWF,APCMZ
End DoDot:3
+15 IF APCMPTYP="D"
DO W^APCM11EH(APCMEV,0,1,APCMPTYP,2)
+16 KILL ^UTILITY($JOB,"W")
End DoDot:2
End DoDot:1
+17 DO W^APCM11EH(" ",0,1,APCMPTYP)
+18 QUIT
+19 ;
SETN ;EP - set numerator fields
+1 ;SPDX
SET APCMCYN=$$V(1,APCMRPT,N,P,APCMPROV,$SELECT($GET(APCMTOT):"T",1:"I"),APCMRPTT)
+2 ;SPDX
SET APCMPRN=$$V(2,APCMRPT,N,P,APCMPROV,$SELECT($GET(APCMTOT):"T",1:"I"),APCMRPTT)
+3 IF APCMCYN=""
SET APCMCYN=0
+4 IF APCMPRN=""
SET APCMPRN=0
+5 ;no % on attestation measures
IF $PIECE(^APCMMUM(APCMIC,0),U,6)="A"
QUIT
+6 SET APCMCYP=$SELECT(APCMCYD:((APCMCYN/APCMCYD)*100),1:"")
+7 SET APCMPRP=$SELECT(APCMPRD:((APCMPRN/APCMPRD)*100),1:"")
+8 QUIT
+9 ;
V(T,R,N,P,PROV,K,RT) ;EP ;SPDX
+1 NEW X,Y,Z,I,J
+2 IF RT=1
SET I=PROV_";VA(200,"
+3 IF RT=2
SET I=PROV_";AUTTLOC("
+4 IF K="T"
SET I="TOTAL"
+5 IF T=1
Begin DoDot:1
+6 SET J=$ORDER(^APCMMUDC(R,$SELECT(K="I":11,1:12),"B",I,0))
+7 IF 'J
SET X=0
QUIT
+8 SET X=$PIECE($GET(^APCMMUDC(R,$SELECT(K="I":11,1:12),J,N)),U,P)
End DoDot:1
QUIT X
+9 IF T=2
Begin DoDot:1
+10 SET J=$ORDER(^APCMMUDP(R,$SELECT(K="I":11,1:12),"B",I,0))
+11 IF 'J
SET X=0
QUIT
+12 SET X=$PIECE($GET(^APCMMUDP(R,$SELECT(K="I":11,1:12),J,N)),U,P)
End DoDot:1
QUIT X
+13 QUIT ""
SUM ;summary sheet for each provider
+1 DO SUM^APCM11ER
+2 QUIT
