BGP3ELL.m

BGP3ELL ; IHS/CMI/LAB - IHS gpra print 01 Jul 2010 7:56 PM ;

 ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81

 ;

 ;

DEL ;

 K ^TMP($J)

 S ^TMP($J,"BGPDEL",0)=0

 D ^BGP3ELHH

 D DEL1

 D ^BGP3ELSL ;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 2013 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,^BGPGUIH(BGPGIEN,12,C,0)=^BGPDATA(X)

 .S ^BGPGUIH(BGPGIEN,12,0)="^90549.1912^"_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(^BGPELIH(BGPIC,BGPNODE,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ  D

 .S BGPLCNT=BGPLCNT+1

 .S X=^BGPELIH(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(^BGPELIH(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(^BGPELIH(BGPIC,61,"B",BGPX)) Q:BGPX'=+BGPX  D

 ..S BGPY=0 F  S BGPY=$O(^BGPELIH(BGPIC,61,"B",BGPX,BGPY)) Q:BGPY'=+BGPY  D

 ...;S BGPZ=0 F  S BGPZ=$O(^BGPELIH(BGPIC,61,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ  D

 ...;.S Y=^BGPELIH(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(^BGPELIH(BGPIC,62,"B",BGPX)) Q:BGPX'=+BGPX  D

 ..S BGPY=0 F  S BGPY=$O(^BGPELIH(BGPIC,62,"B",BGPX,BGPY)) Q:BGPY'=+BGPY  D

 ...;S BGPZ=0 F  S BGPZ=$O(^BGPELIH(BGPIC,62,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ  D

 ...;.S X=^BGPELIH(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(^BGPELIH(BGPIC,11,0)) D S("Logic",1,1) S BGPX=0 F  S BGPX=$O(^BGPELIH(BGPIC,11,BGPX)) Q:BGPX'=+BGPX  D

 ..S X=^BGPELIH(BGPIC,11,BGPX,0) D S(X,1,1)

 .I $O(^BGPELIH(BGPIC,51,0)) D S(" ",1,1) S X="Performance Measure Description" D S(X,1,1) S BGPX=0 F  S BGPX=$O(^BGPELIH(BGPIC,51,BGPX)) Q:BGPX'=+BGPX  D

 ..S X=^BGPELIH(BGPIC,51,BGPX,0) D S(X,1,1)

 .I $O(^BGPELIH(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(^BGPELIH(BGPIC,52,BGPX)) Q:BGPX'=+BGPX  D

 ..S X=^BGPELIH(BGPIC,52,BGPX,0) D S(X,1,1)

 .X ^BGPELIH(BGPIC,4)

 Q

HEADER ;EP

 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 2013 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

BGP3ELL   ; IHS/CMI/LAB - IHS gpra print 01 Jul 2010 7:56 PM ;

 +1       ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81

 +2       ;

 +3       ;

DEL       ;

 +1        KILL ^TMP($JOB)

 +2        SET ^TMP($JOB,"BGPDEL",0)=0

 +3        DO ^BGP3ELHH

 +4        DO DEL1

 +5       ;print lists to delimited file

           DO ^BGP3ELSL

 +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 2013 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 ^BGPGUIH(BGPGIEN,12,C,0)=^BGPDATA(X)

 +21               SET ^BGPGUIH(BGPGIEN,12,0)="^90549.1912^"_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(^BGPELIH(BGPIC,BGPNODE,BGPY,1,BGPZ))

               IF BGPZ'=+BGPZ

                   QUIT 

               Begin DoDot:1

 +4                SET BGPLCNT=BGPLCNT+1

 +5                SET X=^BGPELIH(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(^BGPELIH(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(^BGPELIH(BGPIC,61,"B",BGPX))

                       IF BGPX'=+BGPX

                           QUIT 

                       Begin DoDot:2

 +9                        SET BGPY=0

                           FOR 

                               SET BGPY=$ORDER(^BGPELIH(BGPIC,61,"B",BGPX,BGPY))

                               IF BGPY'=+BGPY

                                   QUIT 

                               Begin DoDot:3

 +10      ;S BGPZ=0 F  S BGPZ=$O(^BGPELIH(BGPIC,61,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ  D

 +11      ;.S Y=^BGPELIH(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(^BGPELIH(BGPIC,62,"B",BGPX))

                       IF BGPX'=+BGPX

                           QUIT 

                       Begin DoDot:2

 +19                       SET BGPY=0

                           FOR 

                               SET BGPY=$ORDER(^BGPELIH(BGPIC,62,"B",BGPX,BGPY))

                               IF BGPY'=+BGPY

                                   QUIT 

                               Begin DoDot:3

 +20      ;S BGPZ=0 F  S BGPZ=$O(^BGPELIH(BGPIC,62,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ  D

 +21      ;.S X=^BGPELIH(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(^BGPELIH(BGPIC,11,0))

                       DO S("Logic",1,1)

                       SET BGPX=0

                       FOR 

                           SET BGPX=$ORDER(^BGPELIH(BGPIC,11,BGPX))

                           IF BGPX'=+BGPX

                               QUIT 

                           Begin DoDot:2

 +27                           SET X=^BGPELIH(BGPIC,11,BGPX,0)

                               DO S(X,1,1)

                           End DoDot:2

 +28               IF $ORDER(^BGPELIH(BGPIC,51,0))

                       DO S(" ",1,1)

                       SET X="Performance Measure Description"

                       DO S(X,1,1)

                       SET BGPX=0

                       FOR 

                           SET BGPX=$ORDER(^BGPELIH(BGPIC,51,BGPX))

                           IF BGPX'=+BGPX

                               QUIT 

                           Begin DoDot:2

 +29                           SET X=^BGPELIH(BGPIC,51,BGPX,0)

                               DO S(X,1,1)

                           End DoDot:2

 +30               IF $ORDER(^BGPELIH(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(^BGPELIH(BGPIC,52,BGPX))

                           IF BGPX'=+BGPX

                               QUIT 

                           Begin DoDot:2

 +31                           SET X=^BGPELIH(BGPIC,52,BGPX,0)

                               DO S(X,1,1)

                           End DoDot:2

 +32               XECUTE ^BGPELIH(BGPIC,4)

               End DoDot:1

 +33       QUIT 

HEADER    ;EP

 +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 2013 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