BGP6CP ; 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("BGP6C1",BGPJ,BGPH)
K ^TMP($J)
D EXIT
Q
;
PRINT1 ;EP
S BGPORDER=0 F S BGPORDER=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER)) Q:BGPORDER'=+BGPORDER!(BGPQUIT) D
.S BGPIND=0 S BGPIND=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND)) D
..D HDR Q:BGPQUIT
..W !,$P(^BGPCMSIS(BGPIND,0),U,3),!
..I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT
..D HDR1
..Q:BGPQUIT
..D LIST1
Q
HDR1 ;
S BGPX=0 F S BGPX=$O(^BGPCMSIS(BGPIND,51,BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
.I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT W !,$P(^BGPCMSIS(BGPIND,0),U,3)," (con't)",!
.W !,^BGPCMSIS(BGPIND,51,BGPX,0)
Q
LIST1 ;DISPLAY LIST 1
K BGPL2
D HDR Q:BGPQUIT ;W !,$P(^BGPCMSIS(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(^BGPCMSIS(BGPIND,0),U,3)," (con't)",!
S BGPX=0 F S BGPX=$O(^BGPCMSIS(BGPIND,52,BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
.I $Y>(BGPIOSL-2) D HDR Q:BGPQUIT W !,$P(^BGPCMSIS(BGPIND,0),U,3)," (con't)",!
.W !,^BGPCMSIS(BGPIND,52,BGPX,0)
.Q
S BGPL2P1=1 D HDR K BGPL2P1 Q:BGPQUIT W !,$P(^BGPCMSIS(BGPIND,0),U,3)," (con't)",!
D L2H
Q:BGPQUIT
D LIST12
I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT W !,$P(^BGPCMSIS(BGPIND,0),U,3)," (con't)",! D L2H
W !!,"TOTAL VISITS: ",$G(BGPCOUNT("L2",BGPIND))
Q
LIST11 ;
S BGPNAME="" F S BGPNAME=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",BGPNAME)) Q:BGPNAME=""!(BGPQUIT) D
.S DFN=0 F S DFN=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",BGPNAME,DFN)) Q:DFN'=+DFN D
..S BGPVSIT=0 F S BGPVSIT=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",BGPNAME,DFN,BGPVSIT)) Q:BGPVSIT'=+BGPVSIT!(BGPQUIT) D
...S BGPVAL=^XTMP("BGP6C1",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)
...;I $$DOD^AUPNPAT(DFN)]"" W !!?2,"Date of Death: ",$$DOD^AUPNPAT(DFN,"E")
...W !?2,"DISCHARGE TYPE: ",$P(BGPVAL,U,7)
...W !?2,"DX: ",$P(BGPVAL,U,6)
...I $P(BGPVAL,U,12)]"" W !?2,$P(BGPVAL,U,12)
Q
LIST12 ;
S BGPNAME="" F S BGPNAME=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME)) Q:BGPNAME=""!(BGPQUIT) D
.S DFN=0 F S DFN=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN)) Q:DFN'=+DFN D
..S BGPVSIT=0 F S BGPVSIT=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT)) Q:BGPVSIT'=+BGPVSIT!(BGPQUIT) D
...S BGPVAL=^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT)
...I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT W !,$P(^BGPCMSIS(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)
...I $$DOD^AUPNPAT(DFN)]"" W !?2,"Date of Death: ",$$DOD^AUPNPAT(DFN,"E")
...W !?3,"DISCHARGE TYPE: ",$P(BGPVAL,U,7),!?3,$P(BGPVAL,U,6)
...S BGPY=0 F S BGPY=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT) D LIST13
Q
LIST13 ;
S BGPT=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,""))
I $Y>(BGPIOSL-5) D HDR Q:BGPQUIT W !,$P(^BGPCMSIS(BGPIND,0),U,3)," (con't)",! D L2H
W !?1,BGPT," ",^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,BGPT)
S BGPC=0 F S BGPC=$O(^XTMP("BGP6C1",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(^BGPCMSIS(BGPIND,0),U,3)," (con't)",! D L2H
.S X=^XTMP("BGP6C1",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("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,BGPT,BGPC)
Q
L1H ;list one header
S BGPX=0 F S BGPX=$O(^BGPCMSIS(BGPIND,55,BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
.I $Y>(BGPIOSL-2) D HDR Q:BGPQUIT
.W !,^BGPCMSIS(BGPIND,55,BGPX,0)
.Q
I 'BGPL1P1 W ! S BGPX=0 F S BGPX=$O(^BGPCMSIS(BGPIND,54,BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
.I $Y>(BGPIOSL-2) D HDR Q:BGPQUIT
.W !,^BGPCMSIS(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."
Q
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)," ","-")
Q
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
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 2006 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)," ","-")
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
C(X,X2,X3) ;
D COMMA^%DTC
Q X
W:$D(IOF) @IOF
W $$CTR("Cover Page",80)
W !,$$CTR("*** IHS 2006 CMS Hospital Quality Reporting Initiative ***",80)
W !,$$CTR("CRS 2006, Version 6.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",2006,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
Q
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)
Q
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
Q
;----------
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")
;----------
BGP6CP ; 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("BGP6C1",BGPJ,BGPH)
+2 KILL ^TMP($JOB)
+3 DO EXIT
+4 QUIT
+5 ;
PRINT1 ;EP
+1 SET BGPORDER=0
FOR
SET BGPORDER=$ORDER(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER))
IF BGPORDER'=+BGPORDER!(BGPQUIT)
QUIT
Begin DoDot:1
+2 SET BGPIND=0
SET BGPIND=$ORDER(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND))
Begin DoDot:2
+3 DO HDR
IF BGPQUIT
QUIT
+4 WRITE !,$PIECE(^BGPCMSIS(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(^BGPCMSIS(BGPIND,51,BGPX))
IF BGPX'=+BGPX!(BGPQUIT)
QUIT
Begin DoDot:1
+2 IF $Y>(BGPIOSL-3)
DO HDR
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPCMSIS(BGPIND,0),U,3)," (con't)",!
+3 WRITE !,^BGPCMSIS(BGPIND,51,BGPX,0)
End DoDot:1
+4 QUIT
LIST1 ;DISPLAY LIST 1
+1 KILL BGPL2
+2 ;W !,$P(^BGPCMSIS(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(^BGPCMSIS(BGPIND,0),U,3)," (con't)",!
+3 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPCMSIS(BGPIND,52,BGPX))
IF BGPX'=+BGPX!(BGPQUIT)
QUIT
Begin DoDot:1
+4 IF $Y>(BGPIOSL-2)
DO HDR
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPCMSIS(BGPIND,0),U,3)," (con't)",!
+5 WRITE !,^BGPCMSIS(BGPIND,52,BGPX,0)
+6 QUIT
End DoDot:1
+7 SET BGPL2P1=1
DO HDR
KILL BGPL2P1
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPCMSIS(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(^BGPCMSIS(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("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",BGPNAME))
IF BGPNAME=""!(BGPQUIT)
QUIT
Begin DoDot:1
+2 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",BGPNAME,DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:2
+3 SET BGPVSIT=0
FOR
SET BGPVSIT=$ORDER(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",BGPNAME,DFN,BGPVSIT))
IF BGPVSIT'=+BGPVSIT!(BGPQUIT)
QUIT
Begin DoDot:3
+4 SET BGPVAL=^XTMP("BGP6C1",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)
+7 ;I $$DOD^AUPNPAT(DFN)]"" W !!?2,"Date of Death: ",$$DOD^AUPNPAT(DFN,"E")
+8 WRITE !?2,"DISCHARGE TYPE: ",$PIECE(BGPVAL,U,7)
+9 WRITE !?2,"DX: ",$PIECE(BGPVAL,U,6)
+10 IF $PIECE(BGPVAL,U,12)]""
WRITE !?2,$PIECE(BGPVAL,U,12)
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
LIST12 ;
+1 SET BGPNAME=""
FOR
SET BGPNAME=$ORDER(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME))
IF BGPNAME=""!(BGPQUIT)
QUIT
Begin DoDot:1
+2 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:2
+3 SET BGPVSIT=0
FOR
SET BGPVSIT=$ORDER(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT))
IF BGPVSIT'=+BGPVSIT!(BGPQUIT)
QUIT
Begin DoDot:3
+4 SET BGPVAL=^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT)
+5 IF $Y>(BGPIOSL-3)
DO HDR
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPCMSIS(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)
+7 IF $$DOD^AUPNPAT(DFN)]""
WRITE !?2,"Date of Death: ",$$DOD^AUPNPAT(DFN,"E")
+8 WRITE !?3,"DISCHARGE TYPE: ",$PIECE(BGPVAL,U,7),!?3,$PIECE(BGPVAL,U,6)
+9 SET BGPY=0
FOR
SET BGPY=$ORDER(^XTMP("BGP6C1",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
+10 QUIT
LIST13 ;
+1 SET BGPT=$ORDER(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,""))
+2 IF $Y>(BGPIOSL-5)
DO HDR
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPCMSIS(BGPIND,0),U,3)," (con't)",!
DO L2H
+3 WRITE !?1,BGPT," ",^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,BGPT)
+4 SET BGPC=0
FOR
SET BGPC=$ORDER(^XTMP("BGP6C1",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(^BGPCMSIS(BGPIND,0),U,3)," (con't)",!
DO L2H
+6 SET X=^XTMP("BGP6C1",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("BGP6C1",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(^BGPCMSIS(BGPIND,55,BGPX))
IF BGPX'=+BGPX!(BGPQUIT)
QUIT
Begin DoDot:1
+2 IF $Y>(BGPIOSL-2)
DO HDR
IF BGPQUIT
QUIT
+3 WRITE !,^BGPCMSIS(BGPIND,55,BGPX,0)
+4 QUIT
End DoDot:1
+5 IF 'BGPL1P1
WRITE !
SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPCMSIS(BGPIND,54,BGPX))
IF BGPX'=+BGPX!(BGPQUIT)
QUIT
Begin DoDot:1
+6 IF $Y>(BGPIOSL-2)
DO HDR
IF BGPQUIT
QUIT
+7 WRITE !,^BGPCMSIS(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
+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 2006 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
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE $$CTR("Cover Page",80)
+3 WRITE !,$$CTR("*** IHS 2006 CMS Hospital Quality Reporting Initiative ***",80)
+4 WRITE !,$$CTR("CRS 2006, Version 6.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",2006,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 ;----------
