BGP1EOS ; IHS/CMI/LAB - IHS gpra print ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
START ;
Q:$G(BGPAREAA)
;Q:'$D(BGPLIST) ;cmi/maw 7/9/08 orig line
Q:'$O(BGPLIST("")) ;cmi/maw 7/9/08 modified as BGPLIST always exists but sometimes not with the list array
S BGPQUIT="",BGPGPG=0,BGPCOUNT=0
D:BGPPTYPE="P" W^BGP1EOH("PATIENT LISTS",0,3,BGPPTYPE) D
.D W^BGP1EOH("**** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****",0,2,BGPPTYPE)
S BGPL=0 F S BGPL=$O(BGPLIST(BGPL)) Q:BGPL'=+BGPL!(BGPQUIT) D
.S BGPCOUNT=0,BGPPCNT=0
.I BGPPTYPE="P" D HEADER Q:BGPQUIT
.I BGPPTYPE="D" D W^BGP1EOH("",0,2,BGPPTYPE)
.S BGPCNT=$G(BGPLIST(BGPL))
.I 'BGPCNT S BGPCNT=0 G GO
.I BGPCNT<11!(BGPLIST'="R") S BGPCNT=1 G GO
.I BGPCNT<100 S BGPCNT=BGPCNT\10 G GO
.S BGPCNT=10
GO .;
.D W^BGP1EOH($P(^BGPEOMB(BGPL,0),U,2),0,1,BGPPTYPE)
.I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER Q:BGPQUIT
.D W^BGP1EOH("Denominator(s):",0,2,BGPPTYPE)
.S BGPX=0 F S BGPX=$O(^BGPEOMB(BGPL,61,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
..S BGPY=0 F S BGPY=$O(^BGPEOMB(BGPL,61,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT) D
...S BGPNODE=61 D WP
.I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER Q:BGPQUIT
.D W^BGP1EOH("Numerator(s):",0,2,BGPPTYPE)
.S BGPX=0 F S BGPX=$O(^BGPEOMB(BGPL,62,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
..S BGPY=0 F S BGPY=$O(^BGPEOMB(BGPL,62,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT) D
...S BGPNODE=62 D WP
.I $O(^BGPEOMB(BGPL,11,0)) D W^BGP1EOH("Logic:",0,2,BGPPTYPE) S BGPX=0 F S BGPX=$O(^BGPEOMB(BGPL,11,BGPX)) Q:BGPX'=+BGPX D
..I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER Q:BGPQUIT
..D W^BGP1EOH(^BGPEOMB(BGPL,11,BGPX,0),0,1,BGPPTYPE)
.D W^BGP1EOH("",0,1,BGPPTYPE) S BGPX=0 F S BGPX=$O(^BGPEOMB(BGPL,71,BGPX)) Q:BGPX'=+BGPX D
..I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER Q:BGPQUIT
..;D W^BGP1EOH(^BGPEOMB(BGPL,71,BGPX,0),0,1,BGPPTYPE)
.D H1
.S BGPCOM="" F S BGPCOM=$O(^XTMP("BGP1D",BGPJ,BGPH,"LIST",BGPL,BGPCOM)) Q:BGPCOM=""!(BGPQUIT) D
..S BGPSEX="" F S BGPSEX=$O(^XTMP("BGP1D",BGPJ,BGPH,"LIST",BGPL,BGPCOM,BGPSEX)) Q:BGPSEX=""!(BGPQUIT) D
...S BGPAGE="" F S BGPAGE=$O(^XTMP("BGP1D",BGPJ,BGPH,"LIST",BGPL,BGPCOM,BGPSEX,BGPAGE)) Q:BGPAGE=""!(BGPQUIT) D
....S DFN=0 F S DFN=$O(^XTMP("BGP1D",BGPJ,BGPH,"LIST",BGPL,BGPCOM,BGPSEX,BGPAGE,DFN)) Q:DFN'=+DFN!(BGPQUIT) S BGPCOUNT=BGPCOUNT+1 D PRINTL
....Q
...Q
..Q
.I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER Q:BGPQUIT
.D W^BGP1EOH("Total # of Patients on list: "_+$G(BGPPCNT),0,2,BGPPTYPE),W^BGP1EOH("",0,1,BGPPTYPE)
Q
WP ;
K ^UTILITY($J,"W")
S BGPZ=0,BGPLCNT=0
S DIWL=1,DIWR=80,DIWF="",BGPZ=0 F S BGPZ=$O(^BGPEOMB(BGPL,BGPNODE,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ D
.S BGPLCNT=BGPLCNT+1
.S X=^BGPEOMB(BGPL,BGPNODE,BGPY,1,BGPZ,0) S:BGPLCNT=1 X=" - "_X D ^DIWP
.Q
WPS ;
S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z D
.I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER Q:BGPQUIT
.D W^BGP1EOH(^UTILITY($J,"W",DIWL,Z,0),0,1,BGPPTYPE)
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W"),X
Q
;
PRINTL ;print one line
Q:(BGPCOUNT#BGPCNT)
I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER Q:BGPQUIT D
.D H1
S BGPPCNT=BGPPCNT+1
D W^BGP1EOH($E($P(^DPT(DFN,0),U),1,22),0,1,BGPPTYPE)
D W^BGP1EOH($$HRN^AUPNPAT(DFN,DUZ(2)),0,0,BGPPTYPE,2,24)
D W^BGP1EOH(BGPCOM,0,0,BGPPTYPE,3,31)
D W^BGP1EOH(BGPSEX,0,0,BGPPTYPE,4,46)
D W^BGP1EOH(BGPAGE,0,0,BGPPTYPE,5,49)
D W^BGP1EOH($P(^XTMP("BGP1D",BGPJ,BGPH,"LIST",BGPL,BGPCOM,BGPSEX,BGPAGE,DFN),"|||",1),0,0,BGPPTYPE,6,53)
D W^BGP1EOH($P(^XTMP("BGP1D",BGPJ,BGPH,"LIST",BGPL,BGPCOM,BGPSEX,BGPAGE,DFN),"|||",2),0,0,BGPPTYPE,7,59)
;W !,$E($P(^DPT(DFN,0),U),1,22),?24,$$HRN^AUPNPAT(DFN,DUZ(2)),?31,$E(BGPCOM,1,14),?46,BGPSEX,?49,BGPAGE
;W ?53,$P(^XTMP("BGP1D",BGPJ,BGPH,"LIST",BGPL,BGPCOM,BGPSEX,BGPAGE,DFN),"|||",1),?59,$P(^XTMP("BGP1D",BGPJ,BGPH,"LIST",BGPL,BGPCOM,BGPSEX,BGPAGE,DFN),"|||",2)
Q
;
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 !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BGPGPG,!
W !,$$CTR("*** IHS 2011 Executive Order Quality Transparency Measures Patient List ***",80),!
W $$CTR($P(^DIC(4,DUZ(2),0),U),80),!
S X="Reporting Period: "_$$FMTE^XLFDT(BGPBD)_" to "_$$FMTE^XLFDT(BGPED) W $$CTR(X,80),!
;W $$CTR($S(BGPLIST="A":"Entire Patient List",BGPLIST="R":"Random Patient List",1:"Patient List by Provider: "_BGPLPROV),80),!
W !,$TR($J("",80)," ","-")
Q
H1 ;
S X=$S(BGPLIST="A":"Entire Patient List",BGPLIST="R":"Random Patient List",1:"Patient List by Provider: "_BGPLPROV) D W^BGP1EOH(X,0,1,BGPPTYPE)
D W^BGP1EOH("UP=User Pop; AC=Active Clinical; AD=Active Diabetic",0,2,BGPPTYPE),W^BGP1EOH("",0,1,BGPPTYPE)
S N=$S(BGPCOUNT<2:71,1:72) S X=0 F S X=$O(^BGPEOMB(BGPL,N,X)) Q:X'=+X D W^BGP1EOH(^BGPEOMB(BGPL,N,X,0),0,1,BGPPTYPE)
D W^BGP1EOH("PATIENT NAME",0,2,BGPPTYPE)
D W^BGP1EOH("HRN",0,0,BGPPTYPE,2,24)
D W^BGP1EOH("COMMUNITY",0,0,BGPPTYPE,3,31)
D W^BGP1EOH("SEX",0,0,BGPPTYPE,4,45)
D W^BGP1EOH("AGE",0,0,BGPPTYPE,5,49)
D W^BGP1EOH("DENOM",0,0,BGPPTYPE,6,53)
D W^BGP1EOH("NUMERATOR",0,0,BGPPTYPE,7,59)
D W^BGP1EOH($TR($J("",80)," ","-"),0,1,BGPPTYPE)
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
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")
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
BGP1EOS ; IHS/CMI/LAB - IHS gpra print ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
START ;
+1 IF $GET(BGPAREAA)
QUIT
+2 ;Q:'$D(BGPLIST) ;cmi/maw 7/9/08 orig line
+3 ;cmi/maw 7/9/08 modified as BGPLIST always exists but sometimes not with the list array
IF '$ORDER(BGPLIST(""))
QUIT
+4 SET BGPQUIT=""
SET BGPGPG=0
SET BGPCOUNT=0
+5 IF BGPPTYPE="P"
DO W^BGP1EOH("PATIENT LISTS",0,3,BGPPTYPE)
Begin DoDot:1
+6 DO W^BGP1EOH("**** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****",0,2,BGPPTYPE)
End DoDot:1
+7 SET BGPL=0
FOR
SET BGPL=$ORDER(BGPLIST(BGPL))
IF BGPL'=+BGPL!(BGPQUIT)
QUIT
Begin DoDot:1
+8 SET BGPCOUNT=0
SET BGPPCNT=0
+9 IF BGPPTYPE="P"
DO HEADER
IF BGPQUIT
QUIT
+10 IF BGPPTYPE="D"
DO W^BGP1EOH("",0,2,BGPPTYPE)
+11 SET BGPCNT=$GET(BGPLIST(BGPL))
+12 IF 'BGPCNT
SET BGPCNT=0
GOTO GO
+13 IF BGPCNT<11!(BGPLIST'="R")
SET BGPCNT=1
GOTO GO
+14 IF BGPCNT<100
SET BGPCNT=BGPCNT\10
GOTO GO
+15 SET BGPCNT=10
GO ;
+1 DO W^BGP1EOH($PIECE(^BGPEOMB(BGPL,0),U,2),0,1,BGPPTYPE)
+2 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER
IF BGPQUIT
QUIT
+3 DO W^BGP1EOH("Denominator(s):",0,2,BGPPTYPE)
+4 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPEOMB(BGPL,61,"B",BGPX))
IF BGPX'=+BGPX!(BGPQUIT)
QUIT
Begin DoDot:2
+5 SET BGPY=0
FOR
SET BGPY=$ORDER(^BGPEOMB(BGPL,61,"B",BGPX,BGPY))
IF BGPY'=+BGPY!(BGPQUIT)
QUIT
Begin DoDot:3
+6 SET BGPNODE=61
DO WP
End DoDot:3
End DoDot:2
+7 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER
IF BGPQUIT
QUIT
+8 DO W^BGP1EOH("Numerator(s):",0,2,BGPPTYPE)
+9 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPEOMB(BGPL,62,"B",BGPX))
IF BGPX'=+BGPX!(BGPQUIT)
QUIT
Begin DoDot:2
+10 SET BGPY=0
FOR
SET BGPY=$ORDER(^BGPEOMB(BGPL,62,"B",BGPX,BGPY))
IF BGPY'=+BGPY!(BGPQUIT)
QUIT
Begin DoDot:3
+11 SET BGPNODE=62
DO WP
End DoDot:3
End DoDot:2
+12 IF $ORDER(^BGPEOMB(BGPL,11,0))
DO W^BGP1EOH("Logic:",0,2,BGPPTYPE)
SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPEOMB(BGPL,11,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+13 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER
IF BGPQUIT
QUIT
+14 DO W^BGP1EOH(^BGPEOMB(BGPL,11,BGPX,0),0,1,BGPPTYPE)
End DoDot:2
+15 DO W^BGP1EOH("",0,1,BGPPTYPE)
SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPEOMB(BGPL,71,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+16 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER
IF BGPQUIT
QUIT
+17 ;D W^BGP1EOH(^BGPEOMB(BGPL,71,BGPX,0),0,1,BGPPTYPE)
End DoDot:2
+18 DO H1
+19 SET BGPCOM=""
FOR
SET BGPCOM=$ORDER(^XTMP("BGP1D",BGPJ,BGPH,"LIST",BGPL,BGPCOM))
IF BGPCOM=""!(BGPQUIT)
QUIT
Begin DoDot:2
+20 SET BGPSEX=""
FOR
SET BGPSEX=$ORDER(^XTMP("BGP1D",BGPJ,BGPH,"LIST",BGPL,BGPCOM,BGPSEX))
IF BGPSEX=""!(BGPQUIT)
QUIT
Begin DoDot:3
+21 SET BGPAGE=""
FOR
SET BGPAGE=$ORDER(^XTMP("BGP1D",BGPJ,BGPH,"LIST",BGPL,BGPCOM,BGPSEX,BGPAGE))
IF BGPAGE=""!(BGPQUIT)
QUIT
Begin DoDot:4
+22 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("BGP1D",BGPJ,BGPH,"LIST",BGPL,BGPCOM,BGPSEX,BGPAGE,DFN))
IF DFN'=+DFN!(BGPQUIT)
QUIT
SET BGPCOUNT=BGPCOUNT+1
DO PRINTL
+23 QUIT
End DoDot:4
+24 QUIT
End DoDot:3
+25 QUIT
End DoDot:2
+26 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER
IF BGPQUIT
QUIT
+27 DO W^BGP1EOH("Total # of Patients on list: "_+$GET(BGPPCNT),0,2,BGPPTYPE)
DO W^BGP1EOH("",0,1,BGPPTYPE)
End DoDot:1
+28 QUIT
WP ;
+1 KILL ^UTILITY($JOB,"W")
+2 SET BGPZ=0
SET BGPLCNT=0
+3 SET DIWL=1
SET DIWR=80
SET DIWF=""
SET BGPZ=0
FOR
SET BGPZ=$ORDER(^BGPEOMB(BGPL,BGPNODE,BGPY,1,BGPZ))
IF BGPZ'=+BGPZ
QUIT
Begin DoDot:1
+4 SET BGPLCNT=BGPLCNT+1
+5 SET X=^BGPEOMB(BGPL,BGPNODE,BGPY,1,BGPZ,0)
IF BGPLCNT=1
SET X=" - "_X
DO ^DIWP
+6 QUIT
End DoDot:1
WPS ;
+1 SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z
QUIT
Begin DoDot:1
+2 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER
IF BGPQUIT
QUIT
+3 DO W^BGP1EOH(^UTILITY($JOB,"W",DIWL,Z,0),0,1,BGPPTYPE)
End DoDot:1
+4 KILL DIWL,DIWR,DIWF,Z
+5 KILL ^UTILITY($JOB,"W"),X
+6 QUIT
+7 ;
PRINTL ;print one line
+1 IF (BGPCOUNT#BGPCNT)
QUIT
+2 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER
IF BGPQUIT
QUIT
Begin DoDot:1
+3 DO H1
End DoDot:1
+4 SET BGPPCNT=BGPPCNT+1
+5 DO W^BGP1EOH($EXTRACT($PIECE(^DPT(DFN,0),U),1,22),0,1,BGPPTYPE)
+6 DO W^BGP1EOH($$HRN^AUPNPAT(DFN,DUZ(2)),0,0,BGPPTYPE,2,24)
+7 DO W^BGP1EOH(BGPCOM,0,0,BGPPTYPE,3,31)
+8 DO W^BGP1EOH(BGPSEX,0,0,BGPPTYPE,4,46)
+9 DO W^BGP1EOH(BGPAGE,0,0,BGPPTYPE,5,49)
+10 DO W^BGP1EOH($PIECE(^XTMP("BGP1D",BGPJ,BGPH,"LIST",BGPL,BGPCOM,BGPSEX,BGPAGE,DFN),"|||",1),0,0,BGPPTYPE,6,53)
+11 DO W^BGP1EOH($PIECE(^XTMP("BGP1D",BGPJ,BGPH,"LIST",BGPL,BGPCOM,BGPSEX,BGPAGE,DFN),"|||",2),0,0,BGPPTYPE,7,59)
+12 ;W !,$E($P(^DPT(DFN,0),U),1,22),?24,$$HRN^AUPNPAT(DFN,DUZ(2)),?31,$E(BGPCOM,1,14),?46,BGPSEX,?49,BGPAGE
+13 ;W ?53,$P(^XTMP("BGP1D",BGPJ,BGPH,"LIST",BGPL,BGPCOM,BGPSEX,BGPAGE,DFN),"|||",1),?59,$P(^XTMP("BGP1D",BGPJ,BGPH,"LIST",BGPL,BGPCOM,BGPSEX,BGPAGE,DFN),"|||",2)
+14 QUIT
+15 ;
+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 !,"***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****"
+4 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BGPGPG,!
+5 WRITE !,$$CTR("*** IHS 2011 Executive Order Quality Transparency Measures Patient List ***",80),!
+6 WRITE $$CTR($PIECE(^DIC(4,DUZ(2),0),U),80),!
+7 SET X="Reporting Period: "_$$FMTE^XLFDT(BGPBD)_" to "_$$FMTE^XLFDT(BGPED)
WRITE $$CTR(X,80),!
+8 ;W $$CTR($S(BGPLIST="A":"Entire Patient List",BGPLIST="R":"Random Patient List",1:"Patient List by Provider: "_BGPLPROV),80),!
+9 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")
+10 QUIT
H1 ;
+1 SET X=$SELECT(BGPLIST="A":"Entire Patient List",BGPLIST="R":"Random Patient List",1:"Patient List by Provider: "_BGPLPROV)
DO W^BGP1EOH(X,0,1,BGPPTYPE)
+2 DO W^BGP1EOH("UP=User Pop; AC=Active Clinical; AD=Active Diabetic",0,2,BGPPTYPE)
DO W^BGP1EOH("",0,1,BGPPTYPE)
+3 SET N=$SELECT(BGPCOUNT<2:71,1:72)
SET X=0
FOR
SET X=$ORDER(^BGPEOMB(BGPL,N,X))
IF X'=+X
QUIT
DO W^BGP1EOH(^BGPEOMB(BGPL,N,X,0),0,1,BGPPTYPE)
+4 DO W^BGP1EOH("PATIENT NAME",0,2,BGPPTYPE)
+5 DO W^BGP1EOH("HRN",0,0,BGPPTYPE,2,24)
+6 DO W^BGP1EOH("COMMUNITY",0,0,BGPPTYPE,3,31)
+7 DO W^BGP1EOH("SEX",0,0,BGPPTYPE,4,45)
+8 DO W^BGP1EOH("AGE",0,0,BGPPTYPE,5,49)
+9 DO W^BGP1EOH("DENOM",0,0,BGPPTYPE,6,53)
+10 DO W^BGP1EOH("NUMERATOR",0,0,BGPPTYPE,7,59)
+11 DO W^BGP1EOH($TRANSLATE($JUSTIFY("",80)," ","-"),0,1,BGPPTYPE)
+12 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
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 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
