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

BGP0CP.m

Go to the documentation of this file. 
  1. BGP0CP ; IHS/CMI/LAB - IHS gpra print 02 Jul 2009 9:06 AM ;
  1.  ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
  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("BGP0C1",BGPJ,BGPH)
  1.  K ^TMP($J)
  1.  D EXIT
  1.  Q
  1.  ;
  1. PRINT1 ;EP
  1.  S BGPIND=0 F  S BGPIND=$O(BGPPLSTL(BGPIND)) Q:BGPIND'=+BGPIND!(BGPQUIT)  D
  1.  .S BGPPLSTL=0 F  S BGPPLSTL=$O(BGPPLSTL(BGPIND,BGPPLSTL))  Q:BGPPLSTL'=+BGPPLSTL!(BGPQUIT)  D
  1.  ..S BGPL1P1=1
  1.  ..D HDR
  1.  ..Q:BGPQUIT
  1.  ..D HDR1
  1.  ..Q:BGPQUIT
  1.  ..S BGPL1P1=0
  1.  ..D LIST1
  1.  Q
  1. HDR1 ;
  1.  Q:'BGPTEXD
  1.  S BGPX=0 F  S BGPX=$O(^BGPCMSMT(BGPPLSTL,21,BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D
  1.  .I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT
  1.  .W !,^BGPCMSMT(BGPPLSTL,21,BGPX,0)
  1.  Q
  1. LIST1 ;DISPLAY LIST 1
  1.  K BGPL2
  1.  I $O(^BGPCMSMT(BGPPLSTL,73,0)) D:BGPTEXD HDR D  ;if there is a first page header
  1.  .S BGPX=0 F  S BGPX=$O(^BGPCMSMT(BGPPLSTL,73,BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D
  1.  ..I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT
  1.  ..W !,^BGPCMSMT(BGPPLSTL,73,BGPX,0)
  1.  I $O(^BGPCMSMT(BGPPLSTL,73,0)) W !,$TR($J("",80)," ","-")
  1.  Q:BGPQUIT
  1.  D L1H
  1.  Q:BGPQUIT
  1.  S BGPAST=0
  1.  I '$D(^XTMP("BGP0C1",BGPJ,BGPH,"LIST",BGPIND,BGPPLSTL)) W !!,"No Visits to report" Q
  1.  S BGPNAME="" F  S BGPNAME=$O(^XTMP("BGP0C1",BGPJ,BGPH,"LIST",BGPIND,BGPPLSTL,BGPNAME)) Q:BGPNAME=""!(BGPQUIT)  D
  1.  .S DFN=0 F  S DFN=$O(^XTMP("BGP0C1",BGPJ,BGPH,"LIST",BGPIND,BGPPLSTL,BGPNAME,DFN)) Q:DFN'=+DFN!(BGPQUIT)  D
  1.  ..S BGPVSIT=0 F  S BGPVSIT=$O(^XTMP("BGP0C1",BGPJ,BGPH,"LIST",BGPIND,BGPPLSTL,BGPNAME,DFN,BGPVSIT)) Q:BGPVSIT'=+BGPVSIT!(BGPQUIT)  D
  1.  ...S BGPVSIT0=$G(^AUPNVSIT(BGPVSIT,0))
  1.  ...S BGPVINP=$O(^AUPNVINP("AD",BGPVSIT,0))
  1.  ...I $Y>(BGPIOSL-4) D HDR Q:BGPQUIT  D L1H
  1.  ...W !!
  1.  ...S BGPPEX=^XTMP("BGP0C1",BGPJ,BGPH,"LIST",BGPIND,BGPPLSTL,BGPNAME,DFN,BGPVSIT)
  1.  ...I BGPPEX]"" W "*" S BGPEXCP(BGPIND,BGPPLSTL)=$G(BGPEXCP(BGPIND,BGPPLSTL))+1
  1.  ...W $E(BGPNAME,1,25),?27,$$HRN^AUPNPAT(DFN,DUZ(2)),?35,$P(^DPT(DFN,0),U,2),?38,$$AGE^AUPNPAT(DFN,$P($P(BGPVSIT0,U),"."))
  1.  ...I '$P(^BGPCMSMT(BGPPLSTL,0),U,6) D
  1.  ....W ?42,$$DATE^BGP0UTL($P($P(BGPVSIT0,U),"."))_"-"_$$DATE^BGP0UTL($$DSCH^BGP0CU(BGPVINP)) I BGPIND=1!(BGPIND=3) W $S(BGPPEX[2!(BGPPEX[1):"*",1:"")
  1.  ....W ?62,$E($$VAL^XBDIQ1(9000010.02,BGPVINP,.07),1,18)
  1.  ...I $P(^BGPCMSMT(BGPPLSTL,0),U,6) D
  1.  ....W ?42,$E($$VAL^XBDIQ1(9000001,DFN,1111),1,19)
  1.  ....W ?62,$$DATE^BGP0UTL($P($P(BGPVSIT0,U),"."))_"-"_$$DATE^BGP0UTL($$DSCH^BGP0CU(BGPVINP))
  1.  ...S BGPCOUNT(BGPIND,BGPPLSTL)=$G(BGPCOUNT(BGPIND,BGPPLSTL))+1
  1.  ...X ^BGPCMSMT(BGPPLSTL,1)
  1.  Q:BGPQUIT
  1.  I $Y>(BGPIOSL-4) D HDR Q:BGPQUIT  D L1H
  1.  W !!,"TOTAL VISITS: ",+$G(BGPCOUNT(BGPIND,BGPPLSTL))
  1.  Q:'$P(^BGPCMSMT(BGPPLSTL,0),U,5)
  1.  W !!,"TOTAL VISITS THAT WOULD BE EXCLUDED: ",+$G(BGPEXCP(BGPIND,BGPPLSTL))
  1.  Q
  1. L1H ;EP - list one header
  1.  I $Y>(BGPIOSL-3) D HDR Q:BGPQUIT
  1.  ;W !,$TR($J("",80)," ","-")
  1.  I '$P(^BGPCMSMT(BGPPLSTL,0),U,6) W !,"PATIENT NAME",?27,"HRN",?34,"SEX",?38,"AGE",?42,"HOSP DATES",?62,"ADMISSION TYPE"
  1.  I $P(^BGPCMSMT(BGPPLSTL,0),U,6) W !,"PATIENT NAME",?27,"HRN",?34,"SEX",?38,"AGE",?42,"CLASS/BENEFICIARY",?64,"HOSP DATES"
  1.  W !,$TR($J("",80)," ","-")
  1.  ;I $G(BGPEXCL)=1 Q
  1.  I '$P(^BGPCMSMT(BGPPLSTL,0),U,5) Q
  1.  W !,"*Indicates CRS would have excluded this patient based on this data if RPMS"
  1.  W !,"exclusion logic had been applied.",!
  1.  Q
  1. HDR ;EP
  1.  NEW X,Y,Z
  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 2010 CMS Hospital Quality Reporting Initiative ***",80)
  1.  W !,$$CTR($$RPTVER^BGP0BAN,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.  I $G(BGPIND) S X="Topic:  "_$P(^BGPCMSIT(BGPIND,0),U,3) W !,$$CTR(X,80)
  1.  I $G(BGPPLSTL),$P($G(^BGPCMSMT(BGPPLSTL,71)),U,2)]"" S X="Performance Measure: "_$P(^BGPCMSMT(BGPPLSTL,71),U,2) W !,$$CTR(X,80)
  1.  I $G(BGPPLSTL) S X="Patient List:  "_$P(^BGPCMSMT(BGPPLSTL,0),U,4) W !,$$CTR(X,80)
  1.  W !,$TR($J("",80)," ","-")
  1.  ;I $G(BGPPLSTL) W !,$P($G(^BGPCMSMT(BGPPLSTL,71)),U) D
  1.  ;.I $P($G(^BGPCMSMT(BGPPLSTL,71)),U,3)]"" W !,$P($G(^BGPCMSMT(BGPPLSTL,71)),U,3)
  1.  ;.W $S(BGPL1P1=0:" (cont'd)",1:""),!
  1.  S BGPL1P1=0
  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.  Q:'BGPTEXD
  1.  ;W:$D(IOF) @IOF
  1.  W $$CTR("Cover Page",80)
  1.  W !,$$CTR("*** IHS 2010 CMS Hospital Quality Reporting Initiative ***",80)
  1.  W !,$$CTR($$RPTVER^BGP0BAN,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",2010,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.  ;----------