Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP6CP

BGP6CP.m

Go to the documentation of this file. 
  1. BGP6CP ; IHS/CMI/LAB - IHS gpra print ;
  1.  ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
  1.  ;
  1.  ;
  1. PRINT ;
  1.  K ^TMP($J)
  1.  S BGPIOSL=$S($G(BGPGUI):55,1:IOSL)
  1.  S BGPGPG=0
  1.  S BGPQUIT=""
  1.  D HEADER
  1.  I BGPQUIT G END
  1.  D PRINT1
  1. END ;
  1.  K ^XTMP("BGP6C1",BGPJ,BGPH)
  1.  K ^TMP($J)
  1.  D EXIT
  1.  Q
  1.  ;
  1. PRINT1 ;EP
  1.  S BGPORDER=0 F  S BGPORDER=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER)) Q:BGPORDER'=+BGPORDER!(BGPQUIT)  D
  1.  .S BGPIND=0 S BGPIND=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND))  D
  1.  ..D HDR Q:BGPQUIT
  1.  ..W !,$P(^BGPCMSIS(BGPIND,0),U,3),!
  1.  ..I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT
  1.  ..D HDR1
  1.  ..Q:BGPQUIT
  1.  ..D LIST1
  1.  Q
  1. HDR1 ;
  1.  S BGPX=0 F  S BGPX=$O(^BGPCMSIS(BGPIND,51,BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D
  1.  .I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT  W !,$P(^BGPCMSIS(BGPIND,0),U,3)," (con't)",!
  1.  .W !,^BGPCMSIS(BGPIND,51,BGPX,0)
  1.  Q
  1. LIST1 ;DISPLAY LIST 1
  1.  K BGPL2
  1.  D HDR Q:BGPQUIT  ;W !,$P(^BGPCMSIS(BGPIND,0),U,3)," (con't)",!
  1.  S BGPL1P1=0 D L1H S BGPL1P1=1
  1.  Q:BGPQUIT
  1.  D LIST11
  1.  I $Y>(BGPIOSL-4) D HDR Q:BGPQUIT  D L1H
  1.  W !!,"TOTAL VISITS: ",$G(BGPCOUNT("L1",BGPIND))
  1.  W !!,"TOTAL VISITS THAT WILL BE EXCLUDED: ",($G(BGPCOUNT("L1",BGPIND))-$G(BGPCOUNT("L2",BGPIND)))
  1.  Q:BGPQUIT
  1. LIST2 ;display list 2
  1.  S BGPL2=1
  1.  D HDR K BGPL2P1 Q:BGPQUIT  W !,$P(^BGPCMSIS(BGPIND,0),U,3)," (con't)",!
  1.  S BGPX=0 F  S BGPX=$O(^BGPCMSIS(BGPIND,52,BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D
  1.  .I $Y>(BGPIOSL-2) D HDR Q:BGPQUIT  W !,$P(^BGPCMSIS(BGPIND,0),U,3)," (con't)",!
  1.  .W !,^BGPCMSIS(BGPIND,52,BGPX,0)
  1.  .Q
  1.  S BGPL2P1=1 D HDR K BGPL2P1 Q:BGPQUIT  W !,$P(^BGPCMSIS(BGPIND,0),U,3)," (con't)",!
  1.  D L2H
  1.  Q:BGPQUIT
  1.  D LIST12
  1.  I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT  W !,$P(^BGPCMSIS(BGPIND,0),U,3)," (con't)",! D L2H
  1.  W !!,"TOTAL VISITS: ",$G(BGPCOUNT("L2",BGPIND))
  1.  Q
  1. LIST11 ;
  1.  S BGPNAME="" F  S BGPNAME=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",BGPNAME)) Q:BGPNAME=""!(BGPQUIT)  D
  1.  .S DFN=0 F  S DFN=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",BGPNAME,DFN)) Q:DFN'=+DFN  D
  1.  ..S BGPVSIT=0 F  S BGPVSIT=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",BGPNAME,DFN,BGPVSIT)) Q:BGPVSIT'=+BGPVSIT!(BGPQUIT)  D
  1.  ...S BGPVAL=^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",BGPNAME,DFN,BGPVSIT)
  1.  ...I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT  S BGPL1P1=1 D L1H
  1.  ...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)
  1.  ...;I $$DOD^AUPNPAT(DFN)]"" W !!?2,"Date of Death: ",$$DOD^AUPNPAT(DFN,"E")
  1.  ...W !?2,"DISCHARGE TYPE: ",$P(BGPVAL,U,7)
  1.  ...W !?2,"DX: ",$P(BGPVAL,U,6)
  1.  ...I $P(BGPVAL,U,12)]"" W !?2,$P(BGPVAL,U,12)
  1.  Q
  1. LIST12 ;
  1.  S BGPNAME="" F  S BGPNAME=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME)) Q:BGPNAME=""!(BGPQUIT)  D
  1.  .S DFN=0 F  S DFN=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN)) Q:DFN'=+DFN  D
  1.  ..S BGPVSIT=0 F  S BGPVSIT=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT)) Q:BGPVSIT'=+BGPVSIT!(BGPQUIT)  D
  1.  ...S BGPVAL=^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT)
  1.  ...I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT  W !,$P(^BGPCMSIS(BGPIND,0),U,3)," (con't)",! D L2H
  1.  ...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)
  1.  ...I $$DOD^AUPNPAT(DFN)]"" W !?2,"Date of Death: ",$$DOD^AUPNPAT(DFN,"E")
  1.  ...W !?3,"DISCHARGE TYPE: ",$P(BGPVAL,U,7),!?3,$P(BGPVAL,U,6)
  1.  ...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
  1.  Q
  1. LIST13 ;
  1.  S BGPT=$O(^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,""))
  1.  I $Y>(BGPIOSL-5) D HDR Q:BGPQUIT  W !,$P(^BGPCMSIS(BGPIND,0),U,3)," (con't)",! D L2H
  1.  W !?1,BGPT,"  ",^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,BGPT)
  1.  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
  1.  .I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT   W !,$P(^BGPCMSIS(BGPIND,0),U,3)," (con't)",! D L2H
  1.  .S X=^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,BGPT,BGPC)
  1.  .I X["qty: " W !?3,$P(X,"qty: ",1),!?3,"qty: ",$P(X,"qty: ",2) Q
  1.  .W !?3,^XTMP("BGP6C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",BGPNAME,DFN,BGPVSIT,BGPY,BGPT,BGPC)
  1.  Q
  1. L1H ;list one header
  1.  S BGPX=0 F  S BGPX=$O(^BGPCMSIS(BGPIND,55,BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D
  1.  .I $Y>(BGPIOSL-2) D HDR Q:BGPQUIT
  1.  .W !,^BGPCMSIS(BGPIND,55,BGPX,0)
  1.  .Q
  1.  I 'BGPL1P1 W ! S BGPX=0 F  S BGPX=$O(^BGPCMSIS(BGPIND,54,BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D
  1.  .I $Y>(BGPIOSL-2) D HDR Q:BGPQUIT
  1.  .W !,^BGPCMSIS(BGPIND,54,BGPX,0)
  1.  .Q
  1.  W !,$TR($J("",80)," ","-")
  1.  W !,"PATIENT NAME",?25,"HRN",?32,"SEX",?36,"AGE",?40,"HOSP DATES",?60,"ADMISSION TYPE"
  1.  W !,$TR($J("",80)," ","-")
  1.  W !,"* Visits will be excluded from Visit List that has RPMS exclusion",!,"logic applied."
  1.  Q
  1. L2H ;
  1.  W !,$$CTR("PATIENT LIST",80)
  1.  I BGPIND=1 D
  1.  .W !,$$CTR("ALL PATIENTS DISCHARGED WITH AMI DX WHO WERE NOT",80)
  1.  .W !,$$CTR("EXCLUDED BASED ON RPMS LOGIC, W/RELATED RPMS DATA",80)
  1.  I BGPIND=2 D
  1.  .W !,$$CTR("ALL PATIENTS DISCHARGED WITH HEART FAILURE DX WHO WERE NOT",80)
  1.  .W !,$$CTR("EXCLUDED BASED ON RPMS LOGIC, W/RELATED RPMS DATA",80)
  1.  I BGPIND=3 D
  1.  .W !,$$CTR("ALL PATIENTS DISCHARGED WITH PNEUMONIA DX WHO WERE NOT",80)
  1.  .W !,$$CTR("EXCLUDED BASED ON RPMS LOGIC, W/RELATED RPMS DATA",80)
  1.  W !,$$CTR("PLEASE NOTE:  The patient's chart should be reviewed",80)
  1.  W !,$$CTR("to identify other data not listed here.",80)
  1.  W !,$TR($J("",80)," ","-")
  1.  W !,"PATIENT NAME",?25,"HRN",?32,"SEX",?36,"AGE",?40,"HOSP DATES",?60,"ADMISSION TYPE"
  1.  W !,$TR($J("",80)," ","-")
  1.  Q
  1. HDR ;
  1.  G:'BGPGPG HEADER1
  1.  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
  1. HEADER1 ;
  1.  W:$D(IOF) @IOF S BGPGPG=BGPGPG+1
  1.  I $G(BGPGUI) W "ZZZZZZZ",!  ;maw
  1.  W $P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BGPGPG,!
  1.  W $$CTR("*** IHS 2006 CMS Hospital Quality Reporting Initiative ***",80)
  1.  W !,$$CTR("Hospital: "_$P(^DIC(4,BGPHOSP,0),U),80)
  1.  S X="Report Period:  "_$$FMTE^XLFDT(BGPBD)_" to "_$$FMTE^XLFDT(BGPED) W !,$$CTR(X,80)
  1.  W !,$TR($J("",80)," ","-")
  1.  Q
  1. EXIT ;
  1.  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
  1.  Q
  1. C(X,X2,X3) ;
  1.  D COMMA^%DTC
  1.  Q X
  1.  W:$D(IOF) @IOF
  1.  W $$CTR("Cover Page",80)
  1.  W !,$$CTR("*** IHS 2006 CMS Hospital Quality Reporting Initiative ***",80)
  1.  W !,$$CTR("CRS 2006, Version 6.1",80)
  1.  W !,$$CTR("Date Report Run: "_$$FMTE^XLFDT(DT),80)
  1.  W !,$$CTR("Hospital: "_$P(^DIC(4,BGPHOSP,0),U),80)
  1.  W !,$$CTR("Report Generated by: "_$$USR,80)
  1.  S X="Report Period:  "_$$FMTE^XLFDT(BGPBD)_" to "_$$FMTE^XLFDT(BGPED) W !,$$CTR(X,80)
  1.  D ENDTIME
  1.  W !
  1.  S BGPX=$O(^BGPCTRL("B",2006,0))
  1.  S BGPY=0 F  S BGPY=$O(^BGPCTRL(BGPX,21,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT)  D
  1.  .I $Y>(BGPIOSL-1) D HDR Q:$D(BGPQUIT)
  1.  .W !,^BGPCTRL(BGPX,21,BGPY,0)
  1.  .Q
  1.  K BGPX
  1.  Q
  1. ENDTIME ;
  1.  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
  1.  .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)
  1.  Q
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:80)-$L(X)\2)_X
  1.  ;----------
  1. EOP ;EP - End of page.
  1.  Q:$E(IOST)'="C"
  1.  Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
  1.  NEW DIR
  1.  K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1.  S DIR(0)="E" D ^DIR
  1.  Q
  1.  ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------