BGPGRA.m

BGPGRA ; IHS/CMI/LAB - BGP Gui Area Reports 5/2/2005 8:38:59 PM ;

 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007

 ;

 ;

 ;

 ;area GPRA reports

 Q

 ;

DEBUG(RETVAL,BGPSTR) ;run the debugger

 ;D DEBUG^%Serenji("AGP^BGPGRA(.RETVAL,.BGPSTR)")

 Q

 ;

AGP(RETVAL,BGPSTR) ;-- queue National GPRA Report

 S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap

 N BGPI,BGPJ,BGPDATA,BGPDA,P,BGPERR,BGPAF,BGPYN,BGPOT,BGPOPT,BGPRT,BGPFN,A,R

 I $G(BGPSTR)="" D CATSTR^BGPGR(.BGPSTR,.BGPSTR)

 S P="|",A="*",R="~"

 S BGPI=0

 S BGPERR=""

 S BGPAF=$P(BGPSTR,P)

 S BGPOT=$P(BGPSTR,P,2)

 S BGPFN=$P(BGPSTR,P,3)

 S BGPOPT="BGP 05 AREA GPRA"

 S BGPRT=$P(BGPSTR,P,4)

 S BGPLSTI=$P(BGPSTR,P,5)

 N I

 F I=2:1 D  Q:$P(BGPLSTI,A,I)=""

 . Q:$P(BGPLSTI,A,I)=""

 . N BGPL

 . S BGPL=$P($P(BGPLSTI,A,I),R)

 . S BGPLIST(BGPL)=""

 K ^BGPTMP($J)

 S RETVAL="^BGPTMP("_$J_")"

 S ^BGPTMP($J,BGPI)="T00250DATA"_$C(30)

 D EP^BGP5GAGP(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPAF,.BGPLIST,BGPOT,BGPFN,BGPRT)

 S BGPI=BGPI+1

 S ^BGPTMP($J,BGPI)=+$G(BGPERR)_$C(30)

 S ^BGPTMP($J,BGPI+1)=$C(31)

 D EN^XBVK("BGP")

 Q

 ;

AELD(RETVAL,BGPSTR) ;-- area elder care report

 S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap

 N BGPI,BGPJ,BGPDATA,BGPDA,P,BGPERR,BGPCT,BGPYN,BGPOT,BGPOPT,BGPRT

 N BGPQTR,BGPRE,BGPBAS,BGPBEN,BGPFAC,A,R

 I $G(BGPSTR)="" D CATSTR^BGPGR(.BGPSTR,.BGPSTR)

 S P="|",A="*",R="~"

 S BGPI=0

 S BGPERR=""

 S BGPQTR=$P(BGPSTR,P)

 S BGPRT=$P(BGPSTR,P,2)

 S BGPRE=$P(BGPSTR,P,3)

 S BGPPER=$P(BGPSTR,P,4)

 S BGPBAS=$P(BGPSTR,P,5)

 S BGPBEN=$P(BGPSTR,P,6)

 S BGPOT=$P(BGPSTR,P,7)

 S BGPLSTI=$P(BGPSTR,P,8)

 S BGPOPT="BGP 05 AREA ELDER REPORT"

 N I

 F I=2:1 D  Q:$P(BGPLSTI,A,I)=""

 . Q:$P(BGPLSTI,A,I)=""

 . N BGPL

 . S BGPL=$P($P(BGPLSTI,A,I),R)

 . S BGPLIST(BGPL)=""

 K ^BGPTMP($J)

 S RETVAL="^BGPTMP("_$J_")"

 S ^BGPTMP($J,BGPI)="T00250DATA"_$C(30)

 D EP^BGP5GAEL(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPRT,.BGPLIST,BGPQTR,BGPPER,BGPBAS,BGPBEN,BGPOT,BGPRE)

 S BGPI=BGPI+1

 S ^BGPTMP($J,BGPI)=+$G(BGPERR)_$C(30)

 S ^BGPTMP($J,BGPI+1)=$C(31)

 D EN^XBVK("BGP")

 Q

 ;

AHED(RETVAL,BGPSTR) ;-- area hedis report

 S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap

 N BGPI,BGPJ,BGPDATA,BGPDA,P,BGPERR,BGPCT,BGPYN,BGPOT,BGPOPT,BGPRT

 N BGPQTR,BGPRE,BGPBAS,BGPBEN,BGPFAC

 I $G(BGPSTR)="" D CATSTR^BGPGR(.BGPSTR,.BGPSTR)

 S P="|",A="*",R="~"

 S BGPI=0

 S BGPERR=""

 S BGPQTR=$P(BGPSTR,P)

 S BGPRT=$P(BGPSTR,P,2)

 S BGPRE=$P(BGPSTR,P,3)

 S BGPPER=$P(BGPSTR,P,4)

 S BGPBAS=$P(BGPSTR,P,5)

 S BGPBEN=$P(BGPSTR,P,6)

 S BGPOT=$P(BGPSTR,P,7)

 S BGPLSTI=$P(BGPSTR,P,8)

 S BGPOPT="BGP 05 AREA HEDIS"

 N I

 F I=2:1 D  Q:$P(BGPLSTI,A,I)=""

 . Q:$P(BGPLSTI,A,I)=""

 . N BGPL

 . S BGPL=$P($P(BGPLSTI,A,I),R)

 . S BGPLIST(BGPL)=""

 K ^BGPTMP($J)

 S RETVAL="^BGPTMP("_$J_")"

 S ^BGPTMP($J,BGPI)="T00250DATA"_$C(30)

 D EP^BGP5GAHE(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPRT,.BGPLIST,BGPQTR,BGPPER,BGPBAS,BGPBEN,BGPOT,BGPRE)

 S BGPI=BGPI+1

 S ^BGPTMP($J,BGPI)=+$G(BGPERR)_$C(30)

 S ^BGPTMP($J,BGPI+1)=$C(31)

 D EN^XBVK("BGP")

 Q

 ;

APER(RETVAL,BGPSTR) ;-- area performance report

 S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap

 N BGPI,BGPJ,BGPDATA,BGPDA,P,BGPERR,BGPCT,BGPYN,BGPOT,BGPOPT,BGPRT

 N BGPQTR,BGPRE,BGPBAS,BGPBEN,BGPFAC,A,R

 I $G(BGPSTR)="" D CATSTR^BGPGR(.BGPSTR,.BGPSTR)

 S P="|",A="*",R="~"

 S BGPI=0

 S BGPERR=""

 S BGPQTR=$P(BGPSTR,P)

 S BGPRT=$P(BGPSTR,P,2)

 S BGPRE=$P(BGPSTR,P,3)

 S BGPPER=$P(BGPSTR,P,4)

 S BGPBAS=$P(BGPSTR,P,5)

 S BGPBEN=$P(BGPSTR,P,6)

 S BGPOT=$P(BGPSTR,P,7)

 S BGPLSTI=$P(BGPSTR,P,8)

 S BGPOPT="BGP 05 AREA GPU"

 N I

 F I=2:1 D  Q:$P(BGPLSTI,A,I)=""

 . Q:$P(BGPLSTI,A,I)=""

 . N BGPL

 . S BGPL=$P($P(BGPLSTI,A,I),R)

 . S BGPLIST(BGPL)=""

 K ^BGPTMP($J)

 S RETVAL="^BGPTMP("_$J_")"

 S ^BGPTMP($J,BGPI)="T00250DATA"_$C(30)

 D EP^BGP5GAPU(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPRT,.BGPLIST,BGPQTR,BGPPER,BGPBAS,BGPBEN,BGPOT,BGPRE)

 S BGPI=BGPI+1

 S ^BGPTMP($J,BGPI)=+$G(BGPERR)_$C(30)

 S ^BGPTMP($J,BGPI+1)=$C(31)

 D EN^XBVK("BGP")

 Q

 ;

BGPGRA    ; IHS/CMI/LAB - BGP Gui Area Reports 5/2/2005 8:38:59 PM ;

 +1       ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007

 +2       ;

 +3       ;

 +4       ;

 +5       ;area GPRA reports

 +6        QUIT 

 +7       ;

DEBUG(RETVAL,BGPSTR) ;run the debugger

 +1       ;D DEBUG^%Serenji("AGP^BGPGRA(.RETVAL,.BGPSTR)")

 +2        QUIT 

 +3       ;

AGP(RETVAL,BGPSTR) ;-- queue National GPRA Report

 +1       ; m error trap

           SET X="MERR^BGPGU"

           SET @^%ZOSF("TRAP")

 +2        NEW BGPI,BGPJ,BGPDATA,BGPDA,P,BGPERR,BGPAF,BGPYN,BGPOT,BGPOPT,BGPRT,BGPFN,A,R

 +3        IF $GET(BGPSTR)=""

               DO CATSTR^BGPGR(.BGPSTR,.BGPSTR)

 +4        SET P="|"

           SET A="*"

           SET R="~"

 +5        SET BGPI=0

 +6        SET BGPERR=""

 +7        SET BGPAF=$PIECE(BGPSTR,P)

 +8        SET BGPOT=$PIECE(BGPSTR,P,2)

 +9        SET BGPFN=$PIECE(BGPSTR,P,3)

 +10       SET BGPOPT="BGP 05 AREA GPRA"

 +11       SET BGPRT=$PIECE(BGPSTR,P,4)

 +12       SET BGPLSTI=$PIECE(BGPSTR,P,5)

 +13       NEW I

 +14       FOR I=2:1

               Begin DoDot:1

 +15               IF $PIECE(BGPLSTI,A,I)=""

                       QUIT 

 +16               NEW BGPL

 +17               SET BGPL=$PIECE($PIECE(BGPLSTI,A,I),R)

 +18               SET BGPLIST(BGPL)=""

               End DoDot:1

               IF $PIECE(BGPLSTI,A,I)=""

                   QUIT 

 +19       KILL ^BGPTMP($JOB)

 +20       SET RETVAL="^BGPTMP("_$JOB_")"

 +21       SET ^BGPTMP($JOB,BGPI)="T00250DATA"_$CHAR(30)

 +22       DO EP^BGP5GAGP(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPAF,.BGPLIST,BGPOT,BGPFN,BGPRT)

 +23       SET BGPI=BGPI+1

 +24       SET ^BGPTMP($JOB,BGPI)=+$GET(BGPERR)_$CHAR(30)

 +25       SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)

 +26       DO EN^XBVK("BGP")

 +27       QUIT 

 +28      ;

AELD(RETVAL,BGPSTR) ;-- area elder care report

 +1       ; m error trap

           SET X="MERR^BGPGU"

           SET @^%ZOSF("TRAP")

 +2        NEW BGPI,BGPJ,BGPDATA,BGPDA,P,BGPERR,BGPCT,BGPYN,BGPOT,BGPOPT,BGPRT

 +3        NEW BGPQTR,BGPRE,BGPBAS,BGPBEN,BGPFAC,A,R

 +4        IF $GET(BGPSTR)=""

               DO CATSTR^BGPGR(.BGPSTR,.BGPSTR)

 +5        SET P="|"

           SET A="*"

           SET R="~"

 +6        SET BGPI=0

 +7        SET BGPERR=""

 +8        SET BGPQTR=$PIECE(BGPSTR,P)

 +9        SET BGPRT=$PIECE(BGPSTR,P,2)

 +10       SET BGPRE=$PIECE(BGPSTR,P,3)

 +11       SET BGPPER=$PIECE(BGPSTR,P,4)

 +12       SET BGPBAS=$PIECE(BGPSTR,P,5)

 +13       SET BGPBEN=$PIECE(BGPSTR,P,6)

 +14       SET BGPOT=$PIECE(BGPSTR,P,7)

 +15       SET BGPLSTI=$PIECE(BGPSTR,P,8)

 +16       SET BGPOPT="BGP 05 AREA ELDER REPORT"

 +17       NEW I

 +18       FOR I=2:1

               Begin DoDot:1

 +19               IF $PIECE(BGPLSTI,A,I)=""

                       QUIT 

 +20               NEW BGPL

 +21               SET BGPL=$PIECE($PIECE(BGPLSTI,A,I),R)

 +22               SET BGPLIST(BGPL)=""

               End DoDot:1

               IF $PIECE(BGPLSTI,A,I)=""

                   QUIT 

 +23       KILL ^BGPTMP($JOB)

 +24       SET RETVAL="^BGPTMP("_$JOB_")"

 +25       SET ^BGPTMP($JOB,BGPI)="T00250DATA"_$CHAR(30)

 +26       DO EP^BGP5GAEL(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPRT,.BGPLIST,BGPQTR,BGPPER,BGPBAS,BGPBEN,BGPOT,BGPRE)

 +27       SET BGPI=BGPI+1

 +28       SET ^BGPTMP($JOB,BGPI)=+$GET(BGPERR)_$CHAR(30)

 +29       SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)

 +30       DO EN^XBVK("BGP")

 +31       QUIT 

 +32      ;

AHED(RETVAL,BGPSTR) ;-- area hedis report

 +1       ; m error trap

           SET X="MERR^BGPGU"

           SET @^%ZOSF("TRAP")

 +2        NEW BGPI,BGPJ,BGPDATA,BGPDA,P,BGPERR,BGPCT,BGPYN,BGPOT,BGPOPT,BGPRT

 +3        NEW BGPQTR,BGPRE,BGPBAS,BGPBEN,BGPFAC

 +4        IF $GET(BGPSTR)=""

               DO CATSTR^BGPGR(.BGPSTR,.BGPSTR)

 +5        SET P="|"

           SET A="*"

           SET R="~"

 +6        SET BGPI=0

 +7        SET BGPERR=""

 +8        SET BGPQTR=$PIECE(BGPSTR,P)

 +9        SET BGPRT=$PIECE(BGPSTR,P,2)

 +10       SET BGPRE=$PIECE(BGPSTR,P,3)

 +11       SET BGPPER=$PIECE(BGPSTR,P,4)

 +12       SET BGPBAS=$PIECE(BGPSTR,P,5)

 +13       SET BGPBEN=$PIECE(BGPSTR,P,6)

 +14       SET BGPOT=$PIECE(BGPSTR,P,7)

 +15       SET BGPLSTI=$PIECE(BGPSTR,P,8)

 +16       SET BGPOPT="BGP 05 AREA HEDIS"

 +17       NEW I

 +18       FOR I=2:1

               Begin DoDot:1

 +19               IF $PIECE(BGPLSTI,A,I)=""

                       QUIT 

 +20               NEW BGPL

 +21               SET BGPL=$PIECE($PIECE(BGPLSTI,A,I),R)

 +22               SET BGPLIST(BGPL)=""

               End DoDot:1

               IF $PIECE(BGPLSTI,A,I)=""

                   QUIT 

 +23       KILL ^BGPTMP($JOB)

 +24       SET RETVAL="^BGPTMP("_$JOB_")"

 +25       SET ^BGPTMP($JOB,BGPI)="T00250DATA"_$CHAR(30)

 +26       DO EP^BGP5GAHE(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPRT,.BGPLIST,BGPQTR,BGPPER,BGPBAS,BGPBEN,BGPOT,BGPRE)

 +27       SET BGPI=BGPI+1

 +28       SET ^BGPTMP($JOB,BGPI)=+$GET(BGPERR)_$CHAR(30)

 +29       SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)

 +30       DO EN^XBVK("BGP")

 +31       QUIT 

 +32      ;

APER(RETVAL,BGPSTR) ;-- area performance report

 +1       ; m error trap

           SET X="MERR^BGPGU"

           SET @^%ZOSF("TRAP")

 +2        NEW BGPI,BGPJ,BGPDATA,BGPDA,P,BGPERR,BGPCT,BGPYN,BGPOT,BGPOPT,BGPRT

 +3        NEW BGPQTR,BGPRE,BGPBAS,BGPBEN,BGPFAC,A,R

 +4        IF $GET(BGPSTR)=""

               DO CATSTR^BGPGR(.BGPSTR,.BGPSTR)

 +5        SET P="|"

           SET A="*"

           SET R="~"

 +6        SET BGPI=0

 +7        SET BGPERR=""

 +8        SET BGPQTR=$PIECE(BGPSTR,P)

 +9        SET BGPRT=$PIECE(BGPSTR,P,2)

 +10       SET BGPRE=$PIECE(BGPSTR,P,3)

 +11       SET BGPPER=$PIECE(BGPSTR,P,4)

 +12       SET BGPBAS=$PIECE(BGPSTR,P,5)

 +13       SET BGPBEN=$PIECE(BGPSTR,P,6)

 +14       SET BGPOT=$PIECE(BGPSTR,P,7)

 +15       SET BGPLSTI=$PIECE(BGPSTR,P,8)

 +16       SET BGPOPT="BGP 05 AREA GPU"

 +17       NEW I

 +18       FOR I=2:1

               Begin DoDot:1

 +19               IF $PIECE(BGPLSTI,A,I)=""

                       QUIT 

 +20               NEW BGPL

 +21               SET BGPL=$PIECE($PIECE(BGPLSTI,A,I),R)

 +22               SET BGPLIST(BGPL)=""

               End DoDot:1

               IF $PIECE(BGPLSTI,A,I)=""

                   QUIT 

 +23       KILL ^BGPTMP($JOB)

 +24       SET RETVAL="^BGPTMP("_$JOB_")"

 +25       SET ^BGPTMP($JOB,BGPI)="T00250DATA"_$CHAR(30)

 +26       DO EP^BGP5GAPU(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPRT,.BGPLIST,BGPQTR,BGPPER,BGPBAS,BGPBEN,BGPOT,BGPRE)

 +27       SET BGPI=BGPI+1

 +28       SET ^BGPTMP($JOB,BGPI)=+$GET(BGPERR)_$CHAR(30)

 +29       SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)

 +30       DO EN^XBVK("BGP")

 +31       QUIT 

 +32      ;