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

BGP2EOP.m

Go to the documentation of this file. 
  1. BGP2EOP ; IHS/CMI/LAB - IHS EO REPORT print 05 Jul 2010 9:20 AM ;
  1.  ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
  1.  ;
  1.  ;
  1. PRINT ;EP
  1.  K ^TMP($J)
  1.  S BGPIOSL=$S($G(BGPGUI):55,1:IOSL)
  1.  S BGPQUIT=""
  1.  S ^TMP($J,"BGPDEL",0)=0
  1.  I $G(BGPAREAA) S BGPRPT=0
  1.  D SETEXP
  1.  I BGPROT="D" G DEL
  1.  S BGPPTYPE="P"
  1.  D ^BGP2EOH
  1.  S BGPGPG=0
  1.  S BGPQUIT=""
  1.  D PRINT1
  1.  K ^TMP($J)
  1.  I BGPROT="P",'$G(BGPAREAA) K ^XTMP("BGP2D",BGPJ,BGPH) Q
  1.  I BGPROT="P" Q
  1.  ;
  1. DEL ;create delimited output file
  1.  D ^%ZISC ;close printer device
  1.  K ^TMP($J)
  1.  S ^TMP($J,"BGPDEL",0)=0
  1.  S BGPPTYPE="D"
  1.  D ^BGP2EOH
  1.  S BGPQUIT=""
  1.  D PRINT1
  1.  I '$G(BGPAREAA) K ^XTMP("BGP2D",BGPJ,BGPH)
  1.  K ^TMP($J)
  1.  Q
  1. WP ;
  1.  K ^UTILITY($J,"W")
  1.  S BGPZ=0,BGPLCNT=0
  1.  S DIWL=1,DIWR=80,DIWF="",BGPZ=0 F  S BGPZ=$O(^BGPEOMB(BGPIC,BGPNODE,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ  D
  1.  .S BGPLCNT=BGPLCNT+1
  1.  .S X=^BGPEOMB(BGPIC,BGPNODE,BGPY,1,BGPZ,0) S:BGPLCNT=1 X=" - "_X D ^DIWP
  1.  .Q
  1. WPS ;
  1.  S Z=0 F  S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z  D
  1.  .I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER Q:BGPQUIT
  1.  .D W^BGP2EOH(^UTILITY($J,"W",DIWL,Z,0),0,1,BGPPTYPE)
  1.  K DIWL,DIWR,DIWF,Z
  1.  K ^UTILITY($J,"W"),X
  1.  Q
  1.  ;
  1. PRINT1 ;EP
  1.  S BGPIC=0 F  S BGPIC=$O(BGPIND(BGPIC)) Q:BGPIC=""!(BGPQUIT)  D
  1.  .I BGPPTYPE="P" D HEADER ;header for all measures
  1.  .I BGPPTYPE="P",$Y>(BGPIOSL-4) D HEADER Q:BGPQUIT
  1.  .I BGPPTYPE="D" D W^BGP2EOH(" ",0,2,BGPPTYPE)
  1.  .D W^BGP2EOH($P(^BGPEOMB(BGPIC,0),U,2),0,1,BGPPTYPE)
  1.  .I BGPPTYPE="P",$Y>(BGPIOSL-4) D HEADER Q:BGPQUIT
  1.  .D W^BGP2EOH("Denominator(s):",0,2,BGPPTYPE)
  1.  .S BGPNODE=61
  1.  .S BGPX=0 F  S BGPX=$O(^BGPEOMB(BGPIC,61,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D
  1.  ..S BGPY=0 F  S BGPY=$O(^BGPEOMB(BGPIC,61,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT)  D
  1.  ...;S BGPZ=0 F  S BGPZ=$O(^BGPEOMB(BGPIC,61,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ!(BGPQUIT)  D
  1.  ...;.I BGPPTYPE="P",$Y>(BGPIOSL-4) D HEADER Q:BGPQUIT
  1.  ...;.D W^BGP2EOH(^BGPEOMB(BGPIC,61,BGPY,1,BGPZ,0),0,1,BGPPTYPE)
  1.  ...D WP
  1.  ...Q
  1.  ..Q
  1.  .I BGPPTYPE="P",$Y>(BGPIOSL-4) D HEADER Q:BGPQUIT
  1.  .D W^BGP2EOH("Numerator(s):",0,2,BGPPTYPE)
  1.  .S BGPNODE=62
  1.  .S BGPX=0 F  S BGPX=$O(^BGPEOMB(BGPIC,62,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D
  1.  ..S BGPY=0 F  S BGPY=$O(^BGPEOMB(BGPIC,62,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT)  D
  1.  ...D WP
  1.  ...Q
  1.  .I $O(^BGPEOMB(BGPIC,11,0)) D W^BGP2EOH("Logic:",0,2,BGPPTYPE) S BGPX=0 F  S BGPX=$O(^BGPEOMB(BGPIC,11,BGPX)) Q:BGPX'=+BGPX  D
  1.  ..I BGPPTYPE="P",$Y>(BGPIOSL-4) D HEADER Q:BGPQUIT
  1.  ..D W^BGP2EOH(^BGPEOMB(BGPIC,11,BGPX,0),0,1,BGPPTYPE)
  1.  .D W^BGP2EOH("",0,1,BGPPTYPE)
  1.  .;I BGPPTYPE="D" D W^BGP2EOH(" ",0,2,BGPPTYPE)
  1.  .X ^BGPEOMB(BGPIC,3)
  1.  ;
  1.  I BGPIC="" S BGPIFTR=1
  1.  D ^BGP2EOY
  1.  D ^BGP2EOS
  1.  I BGPPTYPE="P" D EXIT Q
  1.  I BGPDELT="S" D SCREEN K ^TMP($J) Q
  1.  ;call xbgsave to create output file
  1.  K ^TMP($J,"SUMMARYDEL")
  1.  S XBGL="BGPDATA"
  1.  L +^BGPDATA:300 E  W:'$D(ZTQUEUED) "Unable to lock global" Q
  1.  K ^BGPDATA ;NOTE: kill of unsubscripted export global
  1.  S X=0 F  S X=$O(^TMP($J,"BGPDEL",X)) Q:X'=+X  S ^BGPDATA(X)=^TMP($J,"BGPDEL",X)
  1.  I '$D(BGPGUI) D
  1.  .S XBFLT=1,XBFN=BGPDELF_".txt",XBMED="F",XBTLE="CRS 2012 EXECUTIVE ORDER REPORT DELIMITED OUTPUT",XBQ="N",XBF=0
  1.  .S XBUF=BGPUF D ^XBGSAVE
  1.  .K XBFLT,XBFN,XBMED,XBTLE,XBE,XBF
  1.  I $D(BGPGUI) D
  1.  .S (C,X)=0 F  S X=$O(^BGPDATA(X)) Q:X'=+X  S C=C+1,^BGPGUIW(BGPGIEN,12,C,0)=^BGPDATA(X)
  1.  .S ^BGPGUIW(BGPGIEN,12,0)="^90546.1912^"_C_"^"_C_"^"_DT
  1.  L -^BGPDATA
  1.  K ^BGPDATA ;NOTE: kill of unsubscripted export global
  1.  K ^TMP($J)
  1.  Q
  1.  ;
  1. SCREEN ;
  1.  S X=0 F  S X=$O(^TMP($J,"BGPDEL",X)) Q:X'=+X  W !,^TMP($J,"BGPDEL",X)
  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.  ;
  1. CALC(N,O) ;ENTRY POINT
  1.  NEW Z
  1.  S Z=N-O,Z=$FN(Z,"+,",1)
  1.  Q Z
  1.  ;
  1. SB(X) ;EP - Strip leading and trailing blanks from X.
  1.  NEW %
  1.  X ^DD("FUNC",$O(^DD("FUNC","B","STRIPBLANKS",0)),1)
  1.  Q X
  1.  ;
  1. C(X,X2,X3) ;
  1.  D COMMA^%DTC
  1.  Q X
  1.  ;
  1. H2 ;EP
  1.  I BGPPTYPE="P" D
  1.  .S BGPX="",BGPX=$$C(BGPCYN,0,8),$E(BGPX,9)=$J(BGPCYP,5,1),$E(BGPX,16)=$$C(BGPPRN,0,8),$E(BGPX,24)=$J(BGPPRP,5,1),$E(BGPX,32)=$J($$CALC(BGPCYP,BGPPRP),6),$E(BGPX,39)=$$C(BGPBLN,0,8),$E(BGPX,47)=$J(BGPBLP,5,1)
  1.  .S $E(BGPX,55)=$J($$CALC(BGPCYP,BGPBLP),6)
  1.  .D W^BGP2EOH(BGPX,0,0,BGPPTYPE,1,20)
  1.  I BGPPTYPE="D" D
  1.  .S BGPX="",BGPX=BGPCYN,$P(BGPX,U,2)=$$SB($J(BGPCYP,5,1)),$P(BGPX,U,3)=BGPPRN,$P(BGPX,U,4)=$$SB($J(BGPPRP,5,1)),$P(BGPX,U,5)=$$SB($J($$CALC(BGPCYP,BGPPRP),6)),$P(BGPX,U,6)=BGPBLN,$P(BGPX,U,7)=$$SB($J(BGPBLP,5,1))
  1.  .S $P(BGPX,U,8)=$$SB($J($$CALC(BGPCYP,BGPBLP),6))
  1.  .D W^BGP2EOH(BGPX,0,0,BGPPTYPE,2)
  1.  Q
  1.  ;
  1. H1 ;EP
  1.  D W^BGP2EOH("REPORT",0,2,BGPPTYPE,2,21)
  1.  D W^BGP2EOH("%",0,0,BGPPTYPE,3,31)
  1.  D W^BGP2EOH("PREV YR",0,0,BGPPTYPE,4,35)
  1.  D W^BGP2EOH("%",0,0,BGPPTYPE,5,46)
  1.  D W^BGP2EOH("CHG from",0,0,BGPPTYPE,6,49)
  1.  D W^BGP2EOH("BASE",0,0,BGPPTYPE,7,59)
  1.  D W^BGP2EOH("%",0,0,BGPPTYPE,8,69)
  1.  D W^BGP2EOH("CHG from",0,0,BGPPTYPE,9,72)
  1.  D W^BGP2EOH("PERIOD",0,1,BGPPTYPE,2,21)
  1.  D W^BGP2EOH("PERIOD",0,0,BGPPTYPE,4,35)
  1.  D W^BGP2EOH("PREV YR %",0,0,BGPPTYPE,6,49)
  1.  D W^BGP2EOH("PERIOD",0,0,BGPPTYPE,7,59)
  1.  D W^BGP2EOH("BASE %",0,0,BGPPTYPE,9,72)
  1.  Q
  1.  ;
  1.  ;
  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.  ;
  1. HEADER1 ;
  1.  I BGPPTYPE="P" W:$D(IOF) @IOF S BGPGPG=BGPGPG+1
  1.  I $G(BGPGUI),BGPPTYPE="P" D W^BGP2EOH("ZZZZZZZ",0,0,BGPPTYPE),W^BGP2EOH("",0,1,BGPPTYPE)  ;GUI
  1.  I BGPPTYPE="P" S X=$P(^VA(200,DUZ,0),U,2),$E(X,35)=$$FMTE^XLFDT(DT),$E(X,70)="Page "_BGPGPG D W^BGP2EOH(X,0,1,BGPPTYPE)
  1.  D W^BGP2EOH("*** IHS 2012 Executive Order Quality Transparency Measures Report ***",1,2,BGPPTYPE)
  1.  D W^BGP2EOH($$RPTVER^BGP2BAN,1,2,BGPPTYPE)
  1.  I $G(BGPAREAA) S X="AREA AGGREGATE" D W^BGP2EOH(X,1,1,BGPPTYPE)
  1.  I '$G(BGPAREAA) D W^BGP2EOH($P(^DIC(4,DUZ(2),0),U),1,1,BGPPTYPE)
  1.  S X="Report Period:  "_$$FMTE^XLFDT(BGPBD)_" to "_$$FMTE^XLFDT(BGPED) D W^BGP2EOH(X,1,1,BGPPTYPE)
  1.  S X="Previous Year Period:  "_$$FMTE^XLFDT(BGPPBD)_" to "_$$FMTE^XLFDT(BGPPED) D W^BGP2EOH(X,1,1,BGPPTYPE)
  1.  S X="Baseline Period:  "_$$FMTE^XLFDT(BGPBBD)_" to "_$$FMTE^XLFDT(BGPBED) D W^BGP2EOH(X,1,1,BGPPTYPE)
  1.  S X=$TR($J("",80)," ","-") D W^BGP2EOH(X,0,1,BGPPTYPE)
  1.  Q
  1.  ;
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$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.  ;----------
  1. SETEXP ;EP
  1.  I $G(BGPAREAA) D  Q
  1.  .S X=0 F  S X=$O(BGPSUL(X)) Q:X'=+X  D
  1.  ..S N=^BGPEOCB(X,0)
  1.  ..S (D,L)=""
  1.  ..S L=$P(N,U,9) I L S L=$O(^AUTTLOC("C",L,0)) I L S D=$P($G(^AUTTLOC(L,1)),U,3),L=$S(L:$P(^DIC(4,L,0),U),1:"?????")
  1.  ..S BGPEI(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP2UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI(X),U,P)=$$DATE^BGP2UTL($P(N,U,Y)),P=P+1
  1.  ..Q
  1.  .Q
  1.  Q