Routine: BGP5CP

BGP5CP ; IHS/CMI/LAB - IHS gpra print ;

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

PRINT ;

 K ^TMP($J)

 S BGPIOSL=$S($G(BGPGUI):55,1:IOSL)

 S BGPGPG=0

 S BGPQUIT=""

 D HEADER

 I BGPQUIT G END

 D PRINT1

END ;

 K ^XTMP("BGP5C1",BGPJ,BGPH)

 K ^TMP($J)

 D EXIT

PRINT1 ;EP

 S BGPORDER=0 F  S BGPORDER=$O(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER)) Q:BGPORDER'=+BGPORDER!(BGPQUIT)  D

 .S BGPIND=0 S BGPIND=$O(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND))  D

 ..D HDR Q:BGPQUIT

 ..W !,$P(^BGPCMSIF(BGPIND,0),U,3),!

 ..I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT

 ..D HDR1

 ..Q:BGPQUIT

 ..D LIST1

HDR1 ;

 S BGPX=0 F  S BGPX=$O(^BGPCMSIF(BGPIND,51,BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D

 .I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT  W !,$P(^BGPCMSIF(BGPIND,0),U,3)," (con't)",!

 .W !,^BGPCMSIF(BGPIND,51,BGPX,0)

LIST1 ;DISPLAY LIST 1

 K BGPL2

 D HDR Q:BGPQUIT  ;W !,$P(^BGPCMSIF(BGPIND,0),U,3)," (con't)",!

 S BGPL1P1=0 D L1H S BGPL1P1=1

 Q:BGPQUIT

 D LIST11

 I $Y>(BGPIOSL-4) D HDR Q:BGPQUIT  D L1H

 W !!,"TOTAL VISITS: ",$G(BGPCOUNT("L1",BGPIND))

 W !!,"TOTAL VISITS THAT WILL BE EXCLUDED: ",($G(BGPCOUNT("L1",BGPIND))-$G(BGPCOUNT("L2",BGPIND)))

 Q:BGPQUIT

LIST2 ;display list 2

 S BGPL2=1

 D HDR K BGPL2P1 Q:BGPQUIT  W !,$P(^BGPCMSIF(BGPIND,0),U,3)," (con't)",!

 S BGPX=0 F  S BGPX=$O(^BGPCMSIF(BGPIND,52,BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D

 .I $Y>(BGPIOSL-2) D HDR Q:BGPQUIT  W !,$P(^BGPCMSIF(BGPIND,0),U,3)," (con't)",!

 .W !,^BGPCMSIF(BGPIND,52,BGPX,0)

.Q

 S BGPL2P1=1 D HDR K BGPL2P1 Q:BGPQUIT  W !,$P(^BGPCMSIF(BGPIND,0),U,3)," (con't)",!

 D L2H

 Q:BGPQUIT

 D LIST12

 I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT  W !,$P(^BGPCMSIF(BGPIND,0),U,3)," (con't)",! D L2H

 W !!,"TOTAL VISITS: ",$G(BGPCOUNT("L2",BGPIND))

LIST11 ;

 S BGPNAME="" F  S BGPNAME=$O(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",BGPNAME)) Q:BGPNAME=""!(BGPQUIT)  D

 .S DFN=0 F  S DFN=$O(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",BGPNAME,DFN)) Q:DFN'=+DFN  D

 ..S BGPVSIT=0 F  S BGPVSIT=$O(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",BGPNAME,DFN,BGPVSIT)) Q:BGPVSIT'=+BGPVSIT!(BGPQUIT)  D

 ...S BGPVAL=^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",BGPNAME,DFN,BGPVSIT)

 ...I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT  S BGPL1P1=1 D L1H

 ...W !,$E($P(BGPVAL,U,1),1,23),?25,$P(BGPVAL,U,2),?33,$P(BGPVAL,U,3),?36,$P(BGPVAL,U,4),?40,$P(BGPVAL,U,5),?60,$P(BGPVAL,U,8),!?2,"DISCHARGE TYPE: ",$P(BGPVAL,U,7),!?2,"DX: ",$P(BGPVAL,U,6)

 ...I $P(BGPVAL,U,12)]"" W !?2,$P(BGPVAL,U,12)

LIST12 ;

 S BGPNAME="" F  S BGPNAME=$O(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME)) Q:BGPNAME=""!(BGPQUIT)  D

 .S DFN=0 F  S DFN=$O(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN)) Q:DFN'=+DFN  D

 ..S BGPVSIT=0 F  S BGPVSIT=$O(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT)) Q:BGPVSIT'=+BGPVSIT!(BGPQUIT)  D

 ...S BGPVAL=^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT)

 ...I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT  W !,$P(^BGPCMSIF(BGPIND,0),U,3)," (con't)",! D L2H

 ...W !!,$E($P(BGPVAL,U,1),1,23),?25,$P(BGPVAL,U,2),?33,$P(BGPVAL,U,3),?36,$P(BGPVAL,U,4),?40,$P(BGPVAL,U,5),?60,$P(BGPVAL,U,8),!?3,"DISCHARGE TYPE: ",$P(BGPVAL,U,7),!?3,$P(BGPVAL,U,6)

 ...S BGPY=0 F  S BGPY=$O(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT)  D LIST13

LIST13 ;

 S BGPT=$O(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,""))

 I $Y>(BGPIOSL-5) D HDR Q:BGPQUIT  W !,$P(^BGPCMSIF(BGPIND,0),U,3)," (con't)",! D L2H

 W !?1,BGPT,"  ",^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,BGPT)

 S BGPC=0 F  S BGPC=$O(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,BGPT,BGPC)) Q:BGPC'=+BGPC!(BGPQUIT)  D

 .I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT   W !,$P(^BGPCMSIF(BGPIND,0),U,3)," (con't)",! D L2H

 .S X=^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,BGPT,BGPC)

 .I X["qty: " W !?3,$P(X,"qty: ",1),!?3,"qty: ",$P(X,"qty: ",2) Q

 .W !?3,^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,BGPT,BGPC)

L1H ;list one header

 S BGPX=0 F  S BGPX=$O(^BGPCMSIF(BGPIND,55,BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D

 .I $Y>(BGPIOSL-2) D HDR Q:BGPQUIT

 .W !,^BGPCMSIF(BGPIND,55,BGPX,0)

.Q

 I 'BGPL1P1 W ! S BGPX=0 F  S BGPX=$O(^BGPCMSIF(BGPIND,54,BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D

 .I $Y>(BGPIOSL-2) D HDR Q:BGPQUIT

 .W !,^BGPCMSIF(BGPIND,54,BGPX,0)

.Q

 W !,$TR($J("",80)," ","-")

 W !,"PATIENT NAME",?25,"HRN",?32,"SEX",?36,"AGE",?40,"HOSP DATES",?60,"ADMISSION TYPE"

 W !,$TR($J("",80)," ","-")

 W !,"* Visits will be excluded from Visit List that has RPMS exclusion",!,"logic applied."

L2H ;

 W !,$$CTR("PATIENT LIST",80)

 I BGPIND=1 D

 .W !,$$CTR("ALL PATIENTS DISCHARGED WITH AMI DX WHO WERE NOT",80)

 .W !,$$CTR("EXCLUDED BASED ON RPMS LOGIC, W/RELATED RPMS DATA",80)

 I BGPIND=2 D

 .W !,$$CTR("ALL PATIENTS DISCHARGED WITH HEART FAILURE DX WHO WERE NOT",80)

 .W !,$$CTR("EXCLUDED BASED ON RPMS LOGIC, W/RELATED RPMS DATA",80)

 I BGPIND=3 D

 .W !,$$CTR("ALL PATIENTS DISCHARGED WITH PNEUMONIA DX WHO WERE NOT",80)

 .W !,$$CTR("EXCLUDED BASED ON RPMS LOGIC, W/RELATED RPMS DATA",80)

 W !,$$CTR("PLEASE NOTE:  The patient's chart should be reviewed",80)

 W !,$$CTR("to identify other data not listed here.",80)

 W !,$TR($J("",80)," ","-")

 W !,"PATIENT NAME",?25,"HRN",?32,"SEX",?36,"AGE",?40,"HOSP DATES",?60,"ADMISSION TYPE"

 W !,$TR($J("",80)," ","-")

HDR ;

 G:'BGPGPG 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 BGPQUIT=1 Q

HEADER1 ;

 W:$D(IOF) @IOF S BGPGPG=BGPGPG+1

 I $G(BGPGUI) W !,"ZZZZZZZ",!  ;maw

 W $P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BGPGPG,!

 W $$CTR("*** IHS 2005 CMS Hospital Quality Reporting Initiative ***",80)

 W !,$$CTR("Hospital: "_$P(^DIC(4,BGPHOSP,0),U),80)

 S X="Report Period:  "_$$FMTE^XLFDT(BGPBD)_" to "_$$FMTE^XLFDT(BGPED) W !,$$CTR(X,80)

 W !,$TR($J("",80)," ","-")

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

C(X,X2,X3) ;

 D COMMA^%DTC

Q X

HEADER ;

 W:$D(IOF) @IOF

 W $$CTR("Cover Page",80)

 W !,$$CTR("*** IHS 2005 CMS Hospital Quality Reporting Initiative ***",80)

 W !,$$CTR("CRS 2005, Version 5.1",80)

 W !,$$CTR("Date Report Run: "_$$FMTE^XLFDT(DT),80)

 W !,$$CTR("Hospital: "_$P(^DIC(4,BGPHOSP,0),U),80)

 W !,$$CTR("Report Generated by: "_$$USR,80)

 S X="Report Period:  "_$$FMTE^XLFDT(BGPBD)_" to "_$$FMTE^XLFDT(BGPED) W !,$$CTR(X,80)

 D ENDTIME

W !

 S BGPX=$O(^BGPCTRL("B",2005,0))

 S BGPY=0 F  S BGPY=$O(^BGPCTRL(BGPX,21,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT)  D

 .I $Y>(BGPIOSL-1) D HDR Q:$D(BGPQUIT)

 .W !,^BGPCTRL(BGPX,21,BGPY,0)

.Q

 K BGPX

ENDTIME ;

 I $D(BGPET) S BGPTS=(86400*($P(BGPET,",")-$P(BGPBT,",")))+($P(BGPET,",",2)-$P(BGPBT,",",2)),BGPHR=$P(BGPTS/3600,".") S:BGPHR="" BGPHR=0 D

 .S BGPTS=BGPTS-(BGPHR*3600),BGPM=$P(BGPTS/60,".") S:BGPM="" BGPM=0 S BGPTS=BGPTS-(BGPM*60),BGPS=BGPTS S X="RUN TIME (H.M.S): "_BGPHR_"."_BGPM_"."_BGPS W !,$$CTR(X,80)

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:80)-$L(X)\2)_X

 ;----------

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(0)="E" D ^DIR

 ;----------

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")

 ;----------

BGP5CP    ; IHS/CMI/LAB - IHS gpra print ;

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

 +2       ;

 +3       ;

PRINT     ;

 +1        KILL ^TMP($JOB)

 +2        SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:IOSL)

 +3        SET BGPGPG=0

 +4        SET BGPQUIT=""

 +5        DO HEADER

 +6        IF BGPQUIT

               GOTO END

 +7        DO PRINT1

END       ;

 +1        KILL ^XTMP("BGP5C1",BGPJ,BGPH)

 +2        KILL ^TMP($JOB)

 +3        DO EXIT

 +4        QUIT

 +5       ;

PRINT1    ;EP

 +1        SET BGPORDER=0

FOR

               SET BGPORDER=$ORDER(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER))

               IF BGPORDER'=+BGPORDER!(BGPQUIT)

                   QUIT

               Begin DoDot:1

 +2                SET BGPIND=0

                   SET BGPIND=$ORDER(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND))

                   Begin DoDot:2

 +3                    DO HDR

                       IF BGPQUIT

                           QUIT

 +4                    WRITE !,$PIECE(^BGPCMSIF(BGPIND,0),U,3),!

 +5                    IF $Y>(BGPIOSL-3)

                           DO HDR

                           IF BGPQUIT

                               QUIT

 +6                    DO HDR1

 +7                    IF BGPQUIT

                           QUIT

 +8                    DO LIST1

                   End DoDot:2

               End DoDot:1

 +9        QUIT

HDR1      ;

 +1        SET BGPX=0

FOR

               SET BGPX=$ORDER(^BGPCMSIF(BGPIND,51,BGPX))

               IF BGPX'=+BGPX!(BGPQUIT)

                   QUIT

               Begin DoDot:1

 +2                IF $Y>(BGPIOSL-3)

                       DO HDR

                       IF BGPQUIT

                           QUIT

                       WRITE !,$PIECE(^BGPCMSIF(BGPIND,0),U,3)," (con't)",!

 +3                WRITE !,^BGPCMSIF(BGPIND,51,BGPX,0)

               End DoDot:1

 +4        QUIT

LIST1     ;DISPLAY LIST 1

 +1        KILL BGPL2

 +2       ;W !,$P(^BGPCMSIF(BGPIND,0),U,3)," (con't)",!

           DO HDR

           IF BGPQUIT

               QUIT

 +3        SET BGPL1P1=0

           DO L1H

           SET BGPL1P1=1

 +4        IF BGPQUIT

               QUIT

 +5        DO LIST11

 +6        IF $Y>(BGPIOSL-4)

               DO HDR

               IF BGPQUIT

                   QUIT

               DO L1H

 +7        WRITE !!,"TOTAL VISITS: ",$GET(BGPCOUNT("L1",BGPIND))

 +8        WRITE !!,"TOTAL VISITS THAT WILL BE EXCLUDED: ",($GET(BGPCOUNT("L1",BGPIND))-$GET(BGPCOUNT("L2",BGPIND)))

 +9        IF BGPQUIT

               QUIT

LIST2     ;display list 2

 +1        SET BGPL2=1

 +2        DO HDR

           KILL BGPL2P1

           IF BGPQUIT

               QUIT

           WRITE !,$PIECE(^BGPCMSIF(BGPIND,0),U,3)," (con't)",!

 +3        SET BGPX=0

FOR

               SET BGPX=$ORDER(^BGPCMSIF(BGPIND,52,BGPX))

               IF BGPX'=+BGPX!(BGPQUIT)

                   QUIT

               Begin DoDot:1

 +4                IF $Y>(BGPIOSL-2)

                       DO HDR

                       IF BGPQUIT

                           QUIT

                       WRITE !,$PIECE(^BGPCMSIF(BGPIND,0),U,3)," (con't)",!

 +5                WRITE !,^BGPCMSIF(BGPIND,52,BGPX,0)

 +6                QUIT

               End DoDot:1

 +7        SET BGPL2P1=1

           DO HDR

           KILL BGPL2P1

           IF BGPQUIT

               QUIT

           WRITE !,$PIECE(^BGPCMSIF(BGPIND,0),U,3)," (con't)",!

 +8        DO L2H

 +9        IF BGPQUIT

               QUIT

 +10       DO LIST12

 +11       IF $Y>(BGPIOSL-3)

               DO HDR

               IF BGPQUIT

                   QUIT

               WRITE !,$PIECE(^BGPCMSIF(BGPIND,0),U,3)," (con't)",!

               DO L2H

 +12       WRITE !!,"TOTAL VISITS: ",$GET(BGPCOUNT("L2",BGPIND))

 +13       QUIT

LIST11    ;

 +1        SET BGPNAME=""

FOR

               SET BGPNAME=$ORDER(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",BGPNAME))

               IF BGPNAME=""!(BGPQUIT)

                   QUIT

               Begin DoDot:1

 +2                SET DFN=0

FOR

                       SET DFN=$ORDER(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",BGPNAME,DFN))

                       IF DFN'=+DFN

                           QUIT

                       Begin DoDot:2

 +3                        SET BGPVSIT=0

FOR

                               SET BGPVSIT=$ORDER(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",BGPNAME,DFN,BGPVSIT))

                               IF BGPVSIT'=+BGPVSIT!(BGPQUIT)

                                   QUIT

                               Begin DoDot:3

 +4                                SET BGPVAL=^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",BGPNAME,DFN,BGPVSIT)

 +5                                IF $Y>(BGPIOSL-3)

                                       DO HDR

                                       IF BGPQUIT

                                           QUIT

                                       SET BGPL1P1=1

                                       DO L1H

 +6                                WRITE !,$EXTRACT($PIECE(BGPVAL,U,1),1,23),?25,$PIECE(BGPVAL,U,2),?33,$PIECE(BGPVAL,U,3),?36,$PIECE(BGPVAL,U,4),?40,$PIECE(BGPVAL,U,5),?60,$PIECE(BGPVAL,U,8),!?2,"DISCHARGE TYPE: ",$PIECE(BGPVAL,U,7),!?2,"DX: ",$PIECE(BGP

VAL,U,6)

 +7                                IF $PIECE(BGPVAL,U,12)]""

                                       WRITE !?2,$PIECE(BGPVAL,U,12)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +8        QUIT

LIST12    ;

 +1        SET BGPNAME=""

FOR

               SET BGPNAME=$ORDER(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME))

               IF BGPNAME=""!(BGPQUIT)

                   QUIT

               Begin DoDot:1

 +2                SET DFN=0

FOR

                       SET DFN=$ORDER(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN))

                       IF DFN'=+DFN

                           QUIT

                       Begin DoDot:2

 +3                        SET BGPVSIT=0

FOR

                               SET BGPVSIT=$ORDER(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT))

                               IF BGPVSIT'=+BGPVSIT!(BGPQUIT)

                                   QUIT

                               Begin DoDot:3

 +4                                SET BGPVAL=^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT)

 +5                                IF $Y>(BGPIOSL-3)

                                       DO HDR

                                       IF BGPQUIT

                                           QUIT

                                       WRITE !,$PIECE(^BGPCMSIF(BGPIND,0),U,3)," (con't)",!

                                       DO L2H

 +6                                WRITE !!,$EXTRACT($PIECE(BGPVAL,U,1),1,23),?25,$PIECE(BGPVAL,U,2),?33,$PIECE(BGPVAL,U,3),?36,$PIECE(BGPVAL,U,4),?40,$PIECE(BGPVAL,U,5),?60,$PIECE(BGPVAL,U,8),!?3,"DISCHARGE TYPE: ",$PIECE(BGPVAL,U,7),!?3,$PIECE(BGPVAL,U,

6)

 +7                                SET BGPY=0

FOR

                                       SET BGPY=$ORDER(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY))

                                       IF BGPY'=+BGPY!(BGPQUIT)

                                           QUIT

                                       DO LIST13

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +8        QUIT

LIST13    ;

 +1        SET BGPT=$ORDER(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,""))

 +2        IF $Y>(BGPIOSL-5)

               DO HDR

               IF BGPQUIT

                   QUIT

               WRITE !,$PIECE(^BGPCMSIF(BGPIND,0),U,3)," (con't)",!

               DO L2H

 +3        WRITE !?1,BGPT,"  ",^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,BGPT)

 +4        SET BGPC=0

FOR

               SET BGPC=$ORDER(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,BGPT,BGPC))

               IF BGPC'=+BGPC!(BGPQUIT)

                   QUIT

               Begin DoDot:1

 +5                IF $Y>(BGPIOSL-3)

                       DO HDR

                       IF BGPQUIT

                           QUIT

                       WRITE !,$PIECE(^BGPCMSIF(BGPIND,0),U,3)," (con't)",!

                       DO L2H

 +6                SET X=^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,BGPT,BGPC)

 +7                IF X["qty: "

                       WRITE !?3,$PIECE(X,"qty: ",1),!?3,"qty: ",$PIECE(X,"qty: ",2)

                       QUIT

 +8                WRITE !?3,^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,BGPT,BGPC)

               End DoDot:1

 +9        QUIT

L1H       ;list one header

 +1        SET BGPX=0

FOR

               SET BGPX=$ORDER(^BGPCMSIF(BGPIND,55,BGPX))

               IF BGPX'=+BGPX!(BGPQUIT)

                   QUIT

               Begin DoDot:1

 +2                IF $Y>(BGPIOSL-2)

                       DO HDR

                       IF BGPQUIT

                           QUIT

 +3                WRITE !,^BGPCMSIF(BGPIND,55,BGPX,0)

 +4                QUIT

               End DoDot:1

 +5        IF 'BGPL1P1

               WRITE !

               SET BGPX=0

FOR

                   SET BGPX=$ORDER(^BGPCMSIF(BGPIND,54,BGPX))

                   IF BGPX'=+BGPX!(BGPQUIT)

                       QUIT

                   Begin DoDot:1

 +6                    IF $Y>(BGPIOSL-2)

                           DO HDR

                           IF BGPQUIT

                               QUIT

 +7                    WRITE !,^BGPCMSIF(BGPIND,54,BGPX,0)

 +8                    QUIT

                   End DoDot:1

 +9        WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")

 +10       WRITE !,"PATIENT NAME",?25,"HRN",?32,"SEX",?36,"AGE",?40,"HOSP DATES",?60,"ADMISSION TYPE"

 +11       WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")

 +12       WRITE !,"* Visits will be excluded from Visit List that has RPMS exclusion",!,"logic applied."

 +13       QUIT

L2H       ;

 +1        WRITE !,$$CTR("PATIENT LIST",80)

 +2        IF BGPIND=1

               Begin DoDot:1

 +3                WRITE !,$$CTR("ALL PATIENTS DISCHARGED WITH AMI DX WHO WERE NOT",80)

 +4                WRITE !,$$CTR("EXCLUDED BASED ON RPMS LOGIC, W/RELATED RPMS DATA",80)

               End DoDot:1

 +5        IF BGPIND=2

               Begin DoDot:1

 +6                WRITE !,$$CTR("ALL PATIENTS DISCHARGED WITH HEART FAILURE DX WHO WERE NOT",80)

 +7                WRITE !,$$CTR("EXCLUDED BASED ON RPMS LOGIC, W/RELATED RPMS DATA",80)

               End DoDot:1

 +8        IF BGPIND=3

               Begin DoDot:1

 +9                WRITE !,$$CTR("ALL PATIENTS DISCHARGED WITH PNEUMONIA DX WHO WERE NOT",80)

 +10               WRITE !,$$CTR("EXCLUDED BASED ON RPMS LOGIC, W/RELATED RPMS DATA",80)

               End DoDot:1

 +11       WRITE !,$$CTR("PLEASE NOTE:  The patient's chart should be reviewed",80)

 +12       WRITE !,$$CTR("to identify other data not listed here.",80)

 +13       WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")

 +14       WRITE !,"PATIENT NAME",?25,"HRN",?32,"SEX",?36,"AGE",?40,"HOSP DATES",?60,"ADMISSION TYPE"

 +15       WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")

 +16       QUIT

HDR       ;

 +1        IF 'BGPGPG

               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 BGPQUIT=1

                           QUIT

HEADER1   ;

 +1        IF $DATA(IOF)

               WRITE @IOF

           SET BGPGPG=BGPGPG+1

 +2       ;maw

           IF $GET(BGPGUI)

               WRITE !,"ZZZZZZZ",!

 +3        WRITE $PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BGPGPG,!

 +4        WRITE $$CTR("*** IHS 2005 CMS Hospital Quality Reporting Initiative ***",80)

 +5        WRITE !,$$CTR("Hospital: "_$PIECE(^DIC(4,BGPHOSP,0),U),80)

 +6        SET X="Report Period:  "_$$FMTE^XLFDT(BGPBD)_" to "_$$FMTE^XLFDT(BGPED)

           WRITE !,$$CTR(X,80)

 +7        WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")

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

C(X,X2,X3) ;

 +1        DO COMMA^%DTC

 +2        QUIT X

HEADER    ;

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        WRITE $$CTR("Cover Page",80)

 +3        WRITE !,$$CTR("*** IHS 2005 CMS Hospital Quality Reporting Initiative ***",80)

 +4        WRITE !,$$CTR("CRS 2005, Version 5.1",80)

 +5        WRITE !,$$CTR("Date Report Run: "_$$FMTE^XLFDT(DT),80)

 +6        WRITE !,$$CTR("Hospital: "_$PIECE(^DIC(4,BGPHOSP,0),U),80)

 +7        WRITE !,$$CTR("Report Generated by: "_$$USR,80)

 +8        SET X="Report Period:  "_$$FMTE^XLFDT(BGPBD)_" to "_$$FMTE^XLFDT(BGPED)

           WRITE !,$$CTR(X,80)

 +9        DO ENDTIME

 +10       WRITE !

 +11       SET BGPX=$ORDER(^BGPCTRL("B",2005,0))

 +12       SET BGPY=0

FOR

               SET BGPY=$ORDER(^BGPCTRL(BGPX,21,BGPY))

               IF BGPY'=+BGPY!(BGPQUIT)

                   QUIT

               Begin DoDot:1

 +13               IF $Y>(BGPIOSL-1)

                       DO HDR

                       IF $DATA(BGPQUIT)

                           QUIT

 +14               WRITE !,^BGPCTRL(BGPX,21,BGPY,0)

 +15               QUIT

               End DoDot:1

 +16       KILL BGPX

 +17       QUIT

ENDTIME   ;

 +1        IF $DATA(BGPET)

               SET BGPTS=(86400*($PIECE(BGPET,",")-$PIECE(BGPBT,",")))+($PIECE(BGPET,",",2)-$PIECE(BGPBT,",",2))

               SET BGPHR=$PIECE(BGPTS/3600,".")

               IF BGPHR=""

                   SET BGPHR=0

               Begin DoDot:1

 +2                SET BGPTS=BGPTS-(BGPHR*3600)

                   SET BGPM=$PIECE(BGPTS/60,".")

                   IF BGPM=""

                       SET BGPM=0

                   SET BGPTS=BGPTS-(BGPM*60)

                   SET BGPS=BGPTS

                   SET X="RUN TIME (H.M.S): "_BGPHR_"."_BGPM_"."_BGPS

                   WRITE !,$$CTR(X,80)

               End DoDot:1

 +3        QUIT

CTR(X,Y)  ;EP - Center X in a field Y wide.

 +1        QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:80)-$LENGTH(X)\2)_X

 +2       ;----------

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(0)="E"

           DO ^DIR

 +6        QUIT

 +7       ;----------

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

BGP5CP.m