BGP1ELL ; IHS/CMI/LAB - IHS gpra print 01 Jul 2010 7:56 PM ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
;
DEL ;
K ^TMP($J)
S ^TMP($J,"BGPDEL",0)=0
D ^BGP1ELHH
D DEL1
D ^BGP1ELSL ;print lists to delimited file
;if screen selected do screen
I BGPDELT="S" D SCREEN,EXIT Q
;call xbgsave to create output file
K ^TMP($J,"SUMMARYDEL")
S XBGL="BGPDATA"
L +^BGPDATA:300 E W:'$D(ZTQUEUED) "Unable to lock global" Q
K ^BGPDATA ;NOTE: kill of unsubscripted export global
S X=0 F S X=$O(^TMP($J,"BGPDEL",X)) Q:X'=+X S ^BGPDATA(X)=^TMP($J,"BGPDEL",X)
I '$D(BGPGUI) D
.S XBFLT=1,XBFN=BGPDELF_".txt",XBMED="F",XBTLE="CRS 2011 ELDER DELIMITED OUTPUT",XBQ="N",XBF=0
.;S XBUF=BGPUF
.D ^XBGSAVE
.K XBFLT,XBFN,XBMED,XBTLE,XBE,XBF
I $D(BGPGUI) D
.S (C,X)=0 F S X=$O(^BGPDATA(X)) Q:X'=+X S C=C+1,^BGPGUIB(BGPGIEN,12,C,0)=^BGPDATA(X)
.S ^BGPGUIB(BGPGIEN,12,0)="^90546.0812^"_C_"^"_C_"^"_DT
L -^BGPDATA
K ^BGPDATA ;NOTE: kill of unsubscripted export global
D EXIT
Q
;
WP ;
K ^UTILITY($J,"W")
S BGPZ=0,BGPLCNT=0
S DIWL=1,DIWR=80,DIWF="" F S BGPZ=$O(^BGPELIB(BGPIC,BGPNODE,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ D
.S BGPLCNT=BGPLCNT+1
.S X=^BGPELIB(BGPIC,BGPNODE,BGPY,1,BGPZ,0) S:BGPLCNT=1 X=" - "_X D ^DIWP
.Q
WPS ;
S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z D
.D S(^UTILITY($J,"W",DIWL,Z,0),1,1)
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W"),X
Q
SCREEN ;
S X=0 F S X=$O(^TMP($J,"BGPDEL",X)) Q:X'=+X W !,^TMP($J,"BGPDEL",X)
Q
DEL1 ;EP
S BGPIC=0 F S BGPIC=$O(BGPIND(BGPIC)) Q:BGPIC="" D
.;now print individual measure
.S X=" " D S(X,1,1),S(X,1,1)
.S X=$P(^BGPELIB(BGPIC,0),U,3) D S(X,1,1)
.S X=" " D S(X,1,1)
.S X="Denominator(s):" D S(X,1,1)
.S BGPNODE=61
.S BGPX=0 F S BGPX=$O(^BGPELIB(BGPIC,61,"B",BGPX)) Q:BGPX'=+BGPX D
..S BGPY=0 F S BGPY=$O(^BGPELIB(BGPIC,61,"B",BGPX,BGPY)) Q:BGPY'=+BGPY D
...;S BGPZ=0 F S BGPZ=$O(^BGPELIB(BGPIC,61,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ D
...;.S Y=^BGPELIB(BGPIC,61,BGPY,1,BGPZ,0) D S(Y,1,1)
...D WP ;.Q
...Q
..Q
.S X=" " D S(X,1,1)
.S X="Numerator(s):" D S(X,1,1)
.S BGPNODE=62
.S BGPX=0 F S BGPX=$O(^BGPELIB(BGPIC,62,"B",BGPX)) Q:BGPX'=+BGPX D
..S BGPY=0 F S BGPY=$O(^BGPELIB(BGPIC,62,"B",BGPX,BGPY)) Q:BGPY'=+BGPY D
...;S BGPZ=0 F S BGPZ=$O(^BGPELIB(BGPIC,62,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ D
...;.S X=^BGPELIB(BGPIC,62,BGPY,1,BGPZ,0) D S(X,1,1)
...D WP ;.Q
...Q
..Q
.S X=" " D S(X,1,1)
.I $O(^BGPELIB(BGPIC,11,0)) D S("Logic",1,1) S BGPX=0 F S BGPX=$O(^BGPELIB(BGPIC,11,BGPX)) Q:BGPX'=+BGPX D
..S X=^BGPELIB(BGPIC,11,BGPX,0) D S(X,1,1)
.I $O(^BGPELIB(BGPIC,51,0)) D S(" ",1,1) S X="Performance Measure Description" D S(X,1,1) S BGPX=0 F S BGPX=$O(^BGPELIB(BGPIC,51,BGPX)) Q:BGPX'=+BGPX D
..S X=^BGPELIB(BGPIC,51,BGPX,0) D S(X,1,1)
.I $O(^BGPELIB(BGPIC,52,0)) S X=" " D S(X,1,1) D S("Past Performance and/or Target",1,1) S BGPX=0 F S BGPX=$O(^BGPELIB(BGPIC,52,BGPX)) Q:BGPX'=+BGPX D
..S X=^BGPELIB(BGPIC,52,BGPX,0) D S(X,1,1)
.X ^BGPELIB(BGPIC,4)
Q
S Y=$P(^VA(200,DUZ,0),U,2),$E(Y,35)=$$FMTE^XLFDT(DT) D S(Y,1,1)
I BGPRTYPE=3 S Y="*** IHS 2011 ELDER CARE Clinical Performance Report***" D S(Y,1,1)
I $G(BGPAREAA) S Y="AREA AGGREGATE" D S(Y,1,1)
S X="Date Report Run: "_$$FMTE^XLFDT(DT) D S(X,1,1)
I '$G(BGPAREAA) S Y=$P(^DIC(4,DUZ(2),0),U) D S(Y,1,1)
S X="Report Period: "_$$FMTE^XLFDT(BGPBD)_" to "_$$FMTE^XLFDT(BGPED) D S(X,1,1)
S X="Previous Year Period: "_$$FMTE^XLFDT(BGPPBD)_" to "_$$FMTE^XLFDT(BGPPED) D S(X,1,1)
S X="Baseline Period: "_$$FMTE^XLFDT(BGPBBD)_" to "_$$FMTE^XLFDT(BGPBED) D S(X,1,1)
S X=$TR($J(""," ","-"),80) D S(X,1,1)
Q
EXIT ;
K ^TMP($J)
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 of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
S(Y,F,P) ;set up array
I '$G(F) S F=0
S %=$P(^TMP($J,"BGPDEL",0),U)+F,$P(^TMP($J,"BGPDEL",0),U)=%
I '$D(^TMP($J,"BGPDEL",%)) S ^TMP($J,"BGPDEL",%)=""
S $P(^TMP($J,"BGPDEL",%),U,P)=Y
Q
C(X,X2,X3) ;
D COMMA^%DTC
Q X
BGP1ELL ; IHS/CMI/LAB - IHS gpra print 01 Jul 2010 7:56 PM ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
+3 ;
DEL ;
+1 KILL ^TMP($JOB)
+2 SET ^TMP($JOB,"BGPDEL",0)=0
+3 DO ^BGP1ELHH
+4 DO DEL1
+5 ;print lists to delimited file
DO ^BGP1ELSL
+6 ;if screen selected do screen
+7 IF BGPDELT="S"
DO SCREEN
DO EXIT
QUIT
+8 ;call xbgsave to create output file
+9 KILL ^TMP($JOB,"SUMMARYDEL")
+10 SET XBGL="BGPDATA"
+11 LOCK +^BGPDATA:300
IF '$TEST
IF '$DATA(ZTQUEUED)
WRITE "Unable to lock global"
QUIT
+12 ;NOTE: kill of unsubscripted export global
KILL ^BGPDATA
+13 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"BGPDEL",X))
IF X'=+X
QUIT
SET ^BGPDATA(X)=^TMP($JOB,"BGPDEL",X)
+14 IF '$DATA(BGPGUI)
Begin DoDot:1
+15 SET XBFLT=1
SET XBFN=BGPDELF_".txt"
SET XBMED="F"
SET XBTLE="CRS 2011 ELDER DELIMITED OUTPUT"
SET XBQ="N"
SET XBF=0
+16 ;S XBUF=BGPUF
+17 DO ^XBGSAVE
+18 KILL XBFLT,XBFN,XBMED,XBTLE,XBE,XBF
End DoDot:1
+19 IF $DATA(BGPGUI)
Begin DoDot:1
+20 SET (C,X)=0
FOR
SET X=$ORDER(^BGPDATA(X))
IF X'=+X
QUIT
SET C=C+1
SET ^BGPGUIB(BGPGIEN,12,C,0)=^BGPDATA(X)
+21 SET ^BGPGUIB(BGPGIEN,12,0)="^90546.0812^"_C_"^"_C_"^"_DT
End DoDot:1
+22 LOCK -^BGPDATA
+23 ;NOTE: kill of unsubscripted export global
KILL ^BGPDATA
+24 DO EXIT
+25 QUIT
+26 ;
WP ;
+1 KILL ^UTILITY($JOB,"W")
+2 SET BGPZ=0
SET BGPLCNT=0
+3 SET DIWL=1
SET DIWR=80
SET DIWF=""
FOR
SET BGPZ=$ORDER(^BGPELIB(BGPIC,BGPNODE,BGPY,1,BGPZ))
IF BGPZ'=+BGPZ
QUIT
Begin DoDot:1
+4 SET BGPLCNT=BGPLCNT+1
+5 SET X=^BGPELIB(BGPIC,BGPNODE,BGPY,1,BGPZ,0)
IF BGPLCNT=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 DO S(^UTILITY($JOB,"W",DIWL,Z,0),1,1)
End DoDot:1
+3 KILL DIWL,DIWR,DIWF,Z
+4 KILL ^UTILITY($JOB,"W"),X
+5 QUIT
SCREEN ;
+1 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"BGPDEL",X))
IF X'=+X
QUIT
WRITE !,^TMP($JOB,"BGPDEL",X)
+2 QUIT
DEL1 ;EP
+1 SET BGPIC=0
FOR
SET BGPIC=$ORDER(BGPIND(BGPIC))
IF BGPIC=""
QUIT
Begin DoDot:1
+2 ;now print individual measure
+3 SET X=" "
DO S(X,1,1)
DO S(X,1,1)
+4 SET X=$PIECE(^BGPELIB(BGPIC,0),U,3)
DO S(X,1,1)
+5 SET X=" "
DO S(X,1,1)
+6 SET X="Denominator(s):"
DO S(X,1,1)
+7 SET BGPNODE=61
+8 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPELIB(BGPIC,61,"B",BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+9 SET BGPY=0
FOR
SET BGPY=$ORDER(^BGPELIB(BGPIC,61,"B",BGPX,BGPY))
IF BGPY'=+BGPY
QUIT
Begin DoDot:3
+10 ;S BGPZ=0 F S BGPZ=$O(^BGPELIB(BGPIC,61,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ D
+11 ;.S Y=^BGPELIB(BGPIC,61,BGPY,1,BGPZ,0) D S(Y,1,1)
+12 ;.Q
DO WP
+13 QUIT
End DoDot:3
+14 QUIT
End DoDot:2
+15 SET X=" "
DO S(X,1,1)
+16 SET X="Numerator(s):"
DO S(X,1,1)
+17 SET BGPNODE=62
+18 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPELIB(BGPIC,62,"B",BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+19 SET BGPY=0
FOR
SET BGPY=$ORDER(^BGPELIB(BGPIC,62,"B",BGPX,BGPY))
IF BGPY'=+BGPY
QUIT
Begin DoDot:3
+20 ;S BGPZ=0 F S BGPZ=$O(^BGPELIB(BGPIC,62,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ D
+21 ;.S X=^BGPELIB(BGPIC,62,BGPY,1,BGPZ,0) D S(X,1,1)
+22 ;.Q
DO WP
+23 QUIT
End DoDot:3
+24 QUIT
End DoDot:2
+25 SET X=" "
DO S(X,1,1)
+26 IF $ORDER(^BGPELIB(BGPIC,11,0))
DO S("Logic",1,1)
SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPELIB(BGPIC,11,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+27 SET X=^BGPELIB(BGPIC,11,BGPX,0)
DO S(X,1,1)
End DoDot:2
+28 IF $ORDER(^BGPELIB(BGPIC,51,0))
DO S(" ",1,1)
SET X="Performance Measure Description"
DO S(X,1,1)
SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPELIB(BGPIC,51,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+29 SET X=^BGPELIB(BGPIC,51,BGPX,0)
DO S(X,1,1)
End DoDot:2
+30 IF $ORDER(^BGPELIB(BGPIC,52,0))
SET X=" "
DO S(X,1,1)
DO S("Past Performance and/or Target",1,1)
SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPELIB(BGPIC,52,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+31 SET X=^BGPELIB(BGPIC,52,BGPX,0)
DO S(X,1,1)
End DoDot:2
+32 XECUTE ^BGPELIB(BGPIC,4)
End DoDot:1
+33 QUIT
+1 SET Y=$PIECE(^VA(200,DUZ,0),U,2)
SET $EXTRACT(Y,35)=$$FMTE^XLFDT(DT)
DO S(Y,1,1)
+2 IF BGPRTYPE=3
SET Y="*** IHS 2011 ELDER CARE Clinical Performance Report***"
DO S(Y,1,1)
+3 IF $GET(BGPAREAA)
SET Y="AREA AGGREGATE"
DO S(Y,1,1)
+4 SET X="Date Report Run: "_$$FMTE^XLFDT(DT)
DO S(X,1,1)
+5 IF '$GET(BGPAREAA)
SET Y=$PIECE(^DIC(4,DUZ(2),0),U)
DO S(Y,1,1)
+6 SET X="Report Period: "_$$FMTE^XLFDT(BGPBD)_" to "_$$FMTE^XLFDT(BGPED)
DO S(X,1,1)
+7 SET X="Previous Year Period: "_$$FMTE^XLFDT(BGPPBD)_" to "_$$FMTE^XLFDT(BGPPED)
DO S(X,1,1)
+8 SET X="Baseline Period: "_$$FMTE^XLFDT(BGPBBD)_" to "_$$FMTE^XLFDT(BGPBED)
DO S(X,1,1)
+9 SET X=$TRANSLATE($JUSTIFY(""," ","-"),80)
DO S(X,1,1)
+10 QUIT
EXIT ;
+1 KILL ^TMP($JOB)
+2 QUIT
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 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
S(Y,F,P) ;set up array
+1 IF '$GET(F)
SET F=0
+2 SET %=$PIECE(^TMP($JOB,"BGPDEL",0),U)+F
SET $PIECE(^TMP($JOB,"BGPDEL",0),U)=%
+3 IF '$DATA(^TMP($JOB,"BGPDEL",%))
SET ^TMP($JOB,"BGPDEL",%)=""
+4 SET $PIECE(^TMP($JOB,"BGPDEL",%),U,P)=Y
+5 QUIT
C(X,X2,X3) ;
+1 DO COMMA^%DTC
+2 QUIT X
