BGP8DP.m

BGP8DP ; IHS/CMI/LAB - IHS gpra print 03 Jul 2010 6:26 AM ;

 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66

 ;

 ;

PRINT ;

 I $G(BGPDASH) D ^BGP8DBPR Q  ;dashboard

 I $O(BGPDESGP(0)) D  Q  ;desg provider print

 .S BGPQUIT="",BGPFDESG=0

 .S BGPXX2=0 F  S BGPXX2=$O(BGPDESGP(BGPXX2)) Q:BGPXX2'=+BGPXX2!(BGPQUIT)  D

 ..Q:$G(BGPAREAA)

 ..Q:BGPROT="D"  ;only delimited so don't bother with print

 ..S BGPFDESG=BGPFDESG+1

 ..S BGPRPT=$P(BGPDESGP(BGPXX2),U,1)

 ..S BGPDELF=$P(BGPDESGP(BGPXX2),U,2)

 ..S BGPDESGP=BGPXX2

 ..K ^TMP($J)

 ..K BGPDELIM

 ..S BGPIOSL=$S($G(BGPGUI):55,1:$G(IOSL))

 ..S ^TMP($J,"BGPDEL",0)=0

 ..S BGPQUIT=""

 ..S BGPPTYPE="P"

 ..S BGPQHDR=0

 ..I BGPFDESG'=1 W:$D(IOF) @IOF

 ..D ^BGP8DH

 ..I BGPQHDR S BGPQUIT=1 D KITM Q

 ..S BGPGPG=0

 ..S BGPQUIT=""

 ..D PRINT1

 ..K ^TMP($J)

 ..Q

 .;NOW DO DELIMITED IF NEEDED

 .I BGPROT="P" D KITM Q

 .S BGPQUIT=""

 .I '$D(BGPGUI) D ^%ZISC ;close printer device

 .S BGPXX2=0 F  S BGPXX2=$O(BGPDESGP(BGPXX2)) Q:BGPXX2'=+BGPXX2!(BGPQUIT)  D

 ..Q:$G(BGPAREAA)

 ..S BGPRPT=$P(BGPDESGP(BGPXX2),U,1)

 ..S BGPDELF=$P(BGPDESGP(BGPXX2),U,2)

 ..S BGPDESGP=BGPXX2

 ..K ^TMP($J)

 ..K BGPDELIM

 ..S BGPIOSL=$S($G(BGPGUI):55,1:$G(IOSL))

 ..S ^TMP($J,"BGPDEL",0)=0

 ..S BGPQUIT=""

 ..S BGPPTYPE="D"

 ..S BGPQHDR=0

 ..D ^BGP8DH

 ..I BGPQHDR S BGPQUIT=1 D KITM Q

 ..S BGPGPG=0

 ..S BGPQUIT=""

 ..D PRINT1

 ..D SAVEDEL^BGP8PDL   ;D ^BGP8PDL ;create ^tmp of delimited report

 ..S BGPIFTR=1

 ..K ^XTMP("BGP8D",BGPJ,BGPH)

 ..K ^XTMP("BGP8DNP",BGPJ,BGPH)

 ..K ^XTMP("BGP28CPL",BGPJ,BGPH)

 ..K ^TMP($J)

 ..Q

 .Q

PRINTN ;

 I $G(BGPDASH) D PRINTN^BGP8DBPR Q  ;dashboard

 K ^TMP($J)

 K BGPDELIM

 S BGPIOSL=$S($G(BGPGUI):55,1:$G(IOSL))

 S BGPQUIT=""

 S ^TMP($J,"BGPDEL",0)=0

 I $G(BGPAREAA) D SETEXCEL

 S BGPIFTR=""

 I BGPROT="D" G DEL

 S BGPPTYPE="P"

 S BGPQHDR=0

 D ^BGP8DH    ;LORI

 I BGPQHDR D KITM Q

 S BGPGPG=0

 S BGPQUIT=""

 D PRINT1

 K ^TMP($J)

 I BGPROT="P" D KITM Q

 ;

DEL ;create delimited output file

 I '$D(BGPGUI) D ^%ZISC ;close printer device

 K ^TMP($J)

 S ^TMP($J,"BGPDEL",0)=0

 S BGPQHDR=0

 S BGPPTYPE="D"

 D ^BGP8DH

 S BGPGPG=0

 S BGPQUIT=""

 D PRINT1

 D SAVEDEL^BGP8PDL   ;D ^BGP8PDL ;create ^tmp of delimited report

 S BGPIFTR=1

 K ^XTMP("BGP8D",BGPJ,BGPH)

 K ^XTMP("BGP8DNP",BGPJ,BGPH)

 K ^XTMP("BGP28CPL",BGPJ,BGPH)

 K ^TMP($J)

 Q

W(V,C,F,M,P,T) ;EP

 I $G(F)="" S F=1

 I $G(C)="" S C=0

 I $G(P)="" S P=1

 I $G(T)="" S T=0

 I M="P" D  Q

 .;I $Y>(BGPIOSL-2) D EOP W:$D(IOF) @IOF

 .NEW X

 .F X=1:1:F W !

 .I C W $$CJ^XLFSTR(V,80)

 .I 'C W ?T,V

 ;set up array

 I '$G(F) S F=0

 NEW %,Z

 S Z=""

 S %=$P(^TMP($J,"BGPDEL",0),U)

 F Z=1:1:F S %=%+1 S ^TMP($J,"BGPDEL",%)=""

 S $P(^TMP($J,"BGPDEL",0),U)=%

 I '$D(^TMP($J,"BGPDEL",%)) S ^TMP($J,"BGPDEL",%)=""

 S $P(^TMP($J,"BGPDEL",%),U,P)=V

 Q

 ;

WTITLE(I) ;EP - write title line

 NEW T,X,Y,S

 S T=$P(^BGPINDR(I,0),U,3)

 I BGPPTYPE="P",$L(T)<81 D W(T,0,1,BGPPTYPE),W("",0,1,BGPPTYPE) Q  ; W !,T,! Q

 I BGPPTYPE="D" D W(T,0,1,BGPPTYPE),W("",0,1,BGPPTYPE) Q

 F X=$E(T,1,80)

 S S=""

 F Y=80:-1:1 Q:S  S I=$E(X,Y) I I=" " S S=Y

 D W^BGP8DP($E(T,1,S),0,1,BGPPTYPE)  ;W !,$E(T,1,S)

 D W^BGP8DP($E(T,(S+1),$L(T)),0,1,BGPPTYPE),W("",0,1,BGPPTYPE)  ;W !,$E(T,(S+1),$L(T)),!

 Q

ANYDEV() ;

 NEW X,G,Y

 S G=0

 S X=0 F  S X=$O(BGPINDL(X)) Q:X'=+X  S Y=0 F  S Y=$O(BGPINDL(X,Y)) Q:Y'=+Y  I $P(^BGPNPLR(Y,0),U,7)=9 S G=1

 Q G

ALLDEV() ;

 NEW X,G,Y

 S G=1

 S X=0 F  S X=$O(BGPINDL(X)) Q:X'=+X  S Y=0 F  S Y=$O(BGPINDL(X,Y)) Q:Y'=+Y  I $P(^BGPNPLR(Y,0),U,7)=1 S G=0

 Q G

PRINT1 ;EP

 ;if in NGR or GPU now print gpra dev measures and divider page

 I BGPRTYPE=1 D

 .I $G(BGPNPL),'$$ANYDEV() Q  ;in lists and no developmental lists so skip this

 .I '$G(BGPSUMON) D HEADER^BGP8DPH

 .I '$G(BGPSUMON) D W^BGP8DP("The following section contains GPRA Developmental topics and measures",0,2,BGPPTYPE)

 .I '$G(BGPSUMON) D W^BGP8DP("followed by the GPRA Developmental Measures Clinical Performance Summary.",0,1,BGPPTYPE)

 .I '$G(BGPSUMON) D W^BGP8DP("",0,1,BGPPTYPE)

 .S BGPGDEV=1,BGPRTYPE=9  ;control variable

 .S BGPDEVOR=0 F  S BGPDEVOR=$O(^BGPINDR("ADEVO",BGPDEVOR)) Q:BGPDEVOR'=+BGPDEVOR!(BGPQUIT)  D

 ..S BGPIC=$O(^BGPINDR("ADEVO",BGPDEVOR,0)) Q:BGPIC=""

 ..I $P(^BGPINDR(BGPIC,0),U,14),$D(BGPIND(BGPIC)) D PRINT2

 ..Q:BGPQUIT

 ..I $G(BGPNPL),$D(BGPINDL(BGPIC)),'$D(BGPYNPLT) S BGPINDG=BGPIC D NPL1^BGP8NPLP ;printed nat gpra list

 ..I $G(BGPNPL),$D(BGPINDL(BGPIC)),$D(BGPYNPLT) S BGPINDG=BGPIC D CT^BGP8DSTM ;printed nat gpra SEARCH TEMPLATE

 .S BGPRTYPE=1 K BGPGDEV

 .Q:BGPQUIT

 .;NOW PRINT developmental summary sheet

 .D ^BGP8DSPD  ;DEVELOPMENTAL

 .D ^BGP8SDPD  ;SUMMARY DETAIL

 .;now print gpra divider page

 .;if no lists except developmental skip this

 .I $G(BGPNPL),$$ALLDEV() Q

 .I '$G(BGPSUMON) D HEADER^BGP8DPH

 .I '$G(BGPSUMON) D W^BGP8DP("The following section contains GPRA/GPRAMA and Non-GPRA Selected Topics",0,3,BGPPTYPE)

 .I '$G(BGPSUMON) D W^BGP8DP("and measures followed by the Clinical Performance Summaries for Non-GPRA",0,1,BGPPTYPE)

 .I '$G(BGPSUMON) D W^BGP8DP("Measures and GPRA/GPRAMA Measures.",0,1,BGPPTYPE)

 .I '$G(BGPSUMON) D W^BGP8DP("",0,1,BGPPTYPE)

 ;set back to report 1

 I BGPRTYPE=1,$G(BGPNPL),$$ALLDEV() Q

 S BGPORDSE=0 F  S BGPORDSE=$O(^BGPINDR("AOI",BGPORDSE)) Q:BGPORDSE'=+BGPORDSE!(BGPQUIT)  S BGPIC=$O(^BGPINDR("AOI",BGPORDSE,0)) I $D(BGPIND(BGPIC)) D

 .Q:BGPQUIT

 .I BGPRTYPE=1 Q:$P($G(^BGPINDR(BGPIC,13)),U,3)  ;dev only, not nat gpra report

 .I BGPRTYPE=4 Q:$P($G(^BGPINDR(BGPIC,13)),U,4)  ;not on selected measures report

 .I BGPRTYPE=2 Q:'$P($G(^BGPINDR(BGPIC,12)),U,7)  ;not on ipc report

 .D PRINT2

 .I $G(BGPNPL),$D(BGPINDL(BGPIC)),'$D(BGPYNPLT) S BGPINDG=BGPIC D NPL1^BGP8NPLP ;printed nat gpra list

 .I $G(BGPNPL),$D(BGPINDL(BGPIC)),$D(BGPYNPLT) S BGPINDG=BGPIC D CT^BGP8DSTM ;printed nat gpra SEARCH TEMPLATE

 Q:BGPQUIT

PRINT3 ;

 D SUMP

 Q

WP ;

 K ^UTILITY($J,"W")

 S BGPZ=0,BGPLCNT=0

 S DIWL=1,DIWR=80,DIWF="",BGPZ=0 F  S BGPZ=$O(^BGPINDR(BGPIC,BGPNODE,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ  D

 .S BGPLCNT=BGPLCNT+1

 .S X=^BGPINDR(BGPIC,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^BGP8DPH Q:BGPQUIT

 .D W^BGP8DP(^UTILITY($J,"W",DIWL,Z,0),0,1,BGPPTYPE)

 K DIWL,DIWR,DIWF,Z

 K ^UTILITY($J,"W"),X

 Q

PRINT2 ;

 D

 .I $G(BGPSUMON) G CALC

 .D HEADER^BGP8DPH ;header for all measures

 .I $G(BGPDNT) G CALC

 .I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP8DPH Q:BGPQUIT

 .D WTITLE(BGPIC)

 .;W !,$P(^BGPINDR(BGPIC,0),U,3),!

 .I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP8DPH Q:BGPQUIT

 .D W^BGP8DP("Denominator(s):",0,1,BGPPTYPE)

 .S BGPNODE=$S(BGPRTYPE=1:81,BGPRTYPE=4:61,BGPRTYPE=7:83,BGPRTYPE=9:85,BGPRTYPE=2:94,1:61)

 .I BGPRTYPE=4 S BGPNODE=$S(BGPINDG="D":87,BGPINDG="C":89,BGPINDG="W":92,BGPINDG="I":94,BGPINDG="P":96,1:BGPNODE)

 .S BGPX=0 F  S BGPX=$O(^BGPINDR(BGPIC,BGPNODE,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D

 ..S BGPY=0 F  S BGPY=$O(^BGPINDR(BGPIC,BGPNODE,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT)  D

 ...;I BGPRTYPE=4,'$D(^BGPINDR(BGPIC,BGPNODE,BGPY,12,"B",BGPINDR)) Q  ;not this measure type on selected

 ...D WP

 ...Q

 ..Q

 .Q:BGPQUIT

 .I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP8DPH Q:BGPQUIT

 .D W^BGP8DP("Numerator(s):",0,2,BGPPTYPE)

 .S BGPNODE=$S(BGPRTYPE=1:82,BGPRTYPE=4:62,BGPRTYPE=7:84,BGPRTYPE=9:86,BGPRTYPE=2:95,1:62)

 .I BGPRTYPE=4 S BGPNODE=$S(BGPINDG="D":88,BGPINDG="C":91,BGPINDG="W":93,BGPINDG="I":95,BGPINDG="P":97,1:BGPNODE)

 .S BGPX=0 F  S BGPX=$O(^BGPINDR(BGPIC,BGPNODE,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D

 ..S BGPY=0 F  S BGPY=$O(^BGPINDR(BGPIC,BGPNODE,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT)  D

 ...;I BGPRTYPE=4,'$D(^BGPINDR(BGPIC,BGPNODE,BGPY,12,"B",BGPINDR)) Q  ;not this measure type on selected

 ...D WP

 ...Q

 ..Q

 .Q:BGPQUIT

 .S BGPNODE=11

 .I BGPRTYPE=1,$O(^BGPINDR(BGPIC,54,0)) S BGPNODE=54

 .I BGPRTYPE=7,$O(^BGPINDR(BGPIC,56,0)) S BGPNODE=56

 .I BGPRTYPE=9,$O(^BGPINDR(BGPIC,58,0)) S BGPNODE=58

 .I BGPRTYPE=2,$O(^BGPINDR(BGPIC,21,0)) S BGPNODE=21

 .D W^BGP8DP("Logic:",0,2,BGPPTYPE) S BGPX=0 F  S BGPX=$O(^BGPINDR(BGPIC,BGPNODE,BGPX)) Q:BGPX'=+BGPX  D

 ..I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP8DPH Q:BGPQUIT

 ..D W^BGP8DP(^BGPINDR(BGPIC,BGPNODE,BGPX,0),0,1,BGPPTYPE)

 .I BGPRTYPE=9 G CALC

 .I BGPRTYPE=2 G S

 .D W^BGP8DP("Performance Measure Description:",0,2,BGPPTYPE) S BGPX=0 F  S BGPX=$O(^BGPINDR(BGPIC,$S($G(BGPNGR09):57,1:51),BGPX)) Q:BGPX'=+BGPX  D

 ..I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP8DPH Q:BGPQUIT

 ..D W^BGP8DP(^BGPINDR(BGPIC,$S($G(BGPNGR09):57,1:51),BGPX,0),0,1,BGPPTYPE)

 .I $O(^BGPINDR(BGPIC,52,0)) D W^BGP8DP("Past Performance and/or Target:",0,2,BGPPTYPE) S BGPX=0 F  S BGPX=$O(^BGPINDR(BGPIC,52,BGPX)) Q:BGPX'=+BGPX  D

 ..I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP8DPH Q:BGPQUIT

 ..D W^BGP8DP(^BGPINDR(BGPIC,52,BGPX,0),0,1,BGPPTYPE)

S .I $O(^BGPINDR(BGPIC,55,0)) D W^BGP8DP("Source:",0,2,BGPPTYPE) S BGPX=0 F  S BGPX=$O(^BGPINDR(BGPIC,55,BGPX)) Q:BGPX'=+BGPX  D

 ..I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP8DPH Q:BGPQUIT

 ..D W^BGP8DP(^BGPINDR(BGPIC,55,BGPX,0),0,1,BGPPTYPE)

 .I '$O(^BGPINDR(BGPIC,55,0)) D W^BGP8DP("",0,1,BGPPTYPE)

CALC .I '$G(BGPSUMON) D W^BGP8DP($P(^BGPINDR(BGPIC,0),U,3),0,2,BGPPTYPE),W^BGP8DP(" ",0,1,BGPPTYPE)

 .S BGPFONE=1 I BGPPTYPE="P" X ^BGPINDR(BGPIC,3) D W^BGP8DP("",0,1,BGPPTYPE) S BGPFONE=0

 .S BGPFONE=1 I BGPPTYPE="D" X ^BGPINDR(BGPIC,4) D W^BGP8DP("",0,1,BGPPTYPE) S BGPFONE=0

 .;I $G(BGPNPL),$D(BGPINDL(BGPIC)),'$D(BGPYNPLT) S BGPINDG=BGPIC D NPL1^BGP8NPLP ;printed nat gpra list

 .;I $G(BGPNPL),$D(BGPINDL(BGPIC)),$D(BGPYNPLT) S BGPINDG=BGPIC D CT^BGP8DSTM ;printed nat gpra SEARCH TEMPLATE

 Q

SUMP ;

 I BGPIC="" S BGPIFTR=1

 I BGPRTYPE=1 D ^BGP8DSPN  ;NON GPRA

 I BGPRTYPE=1 D ^BGP8DSP   ;GPRA

 I BGPRTYPE=1 D ^BGP8SDPN

 I BGPRTYPE=1 D ^BGP8SDP

 I BGPRTYPE=7 D ^BGP8DSPO

 I BGPRTYPE=7 D ^BGP8SDPO

 D ^BGP8DS

 I $G(BGPCPPL) D CPPL1^BGP8DCLP  ;print comp pt list

 D EXIT

 Q

KITM ;

 K ^TMP($J)

 K ^XTMP("BGP8D",BGPJ,BGPH)

 K ^XTMP("BGP8DNP",BGPJ,BGPH)

 K ^XTMP("BGP28CPL",BGPJ,BGPH)

 Q

SETEXCEL ;EP

 I $G(BGPAREAA) D  Q

 .S X=0 F  S X=$O(BGPSUL(X)) Q:X'=+X  D

 ..S N=^BGPGPDCR(X,0)

 ..S (D,L)=""

 ..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:"?????")

 ..S BGPEI(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1

 ..S BGPEI2(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI2(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1

 ..S BGPEI3(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI3(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1

 ..;S BGPEI4(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI4(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1

 ..;S BGPEI5(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI5(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1

 ..;S BGPEI6(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI6(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1

 ..S BGPEIDV1(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEIDV1(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1

 ..S BGPEIDV2(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEIDV2(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1

 ..S BGPEIDV3(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEIDV3(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1

 ..S BGPEIDV4(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEIDV4(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1

 ..S BGPONN1(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN1(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1

 ..S BGPONN2(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN2(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1

 ..S BGPONN3(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN3(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1

 ..S BGPONN4(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN4(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1

 ..;S BGPONN5(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN5(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1

 ..Q

 .Q

 Q

EXIT ;

 Q:BGPPTYPE'="P"

 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

BGP8DP    ; IHS/CMI/LAB - IHS gpra print 03 Jul 2010 6:26 AM ;

 +1       ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66

 +2       ;

 +3       ;

PRINT     ;

 +1       ;dashboard

           IF $GET(BGPDASH)

               DO ^BGP8DBPR

               QUIT 

 +2       ;desg provider print

           IF $ORDER(BGPDESGP(0))

               Begin DoDot:1

 +3                SET BGPQUIT=""

                   SET BGPFDESG=0

 +4                SET BGPXX2=0

                   FOR 

                       SET BGPXX2=$ORDER(BGPDESGP(BGPXX2))

                       IF BGPXX2'=+BGPXX2!(BGPQUIT)

                           QUIT 

                       Begin DoDot:2

 +5                        IF $GET(BGPAREAA)

                               QUIT 

 +6       ;only delimited so don't bother with print

                           IF BGPROT="D"

                               QUIT 

 +7                        SET BGPFDESG=BGPFDESG+1

 +8                        SET BGPRPT=$PIECE(BGPDESGP(BGPXX2),U,1)

 +9                        SET BGPDELF=$PIECE(BGPDESGP(BGPXX2),U,2)

 +10                       SET BGPDESGP=BGPXX2

 +11                       KILL ^TMP($JOB)

 +12                       KILL BGPDELIM

 +13                       SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:$GET(IOSL))

 +14                       SET ^TMP($JOB,"BGPDEL",0)=0

 +15                       SET BGPQUIT=""

 +16                       SET BGPPTYPE="P"

 +17                       SET BGPQHDR=0

 +18                       IF BGPFDESG'=1

                               IF $DATA(IOF)

                                   WRITE @IOF

 +19                       DO ^BGP8DH

 +20                       IF BGPQHDR

                               SET BGPQUIT=1

                               DO KITM

                               QUIT 

 +21                       SET BGPGPG=0

 +22                       SET BGPQUIT=""

 +23                       DO PRINT1

 +24                       KILL ^TMP($JOB)

 +25                       QUIT 

                       End DoDot:2

 +26      ;NOW DO DELIMITED IF NEEDED

 +27               IF BGPROT="P"

                       DO KITM

                       QUIT 

 +28               SET BGPQUIT=""

 +29      ;close printer device

                   IF '$DATA(BGPGUI)

                       DO ^%ZISC

 +30               SET BGPXX2=0

                   FOR 

                       SET BGPXX2=$ORDER(BGPDESGP(BGPXX2))

                       IF BGPXX2'=+BGPXX2!(BGPQUIT)

                           QUIT 

                       Begin DoDot:2

 +31                       IF $GET(BGPAREAA)

                               QUIT 

 +32                       SET BGPRPT=$PIECE(BGPDESGP(BGPXX2),U,1)

 +33                       SET BGPDELF=$PIECE(BGPDESGP(BGPXX2),U,2)

 +34                       SET BGPDESGP=BGPXX2

 +35                       KILL ^TMP($JOB)

 +36                       KILL BGPDELIM

 +37                       SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:$GET(IOSL))

 +38                       SET ^TMP($JOB,"BGPDEL",0)=0

 +39                       SET BGPQUIT=""

 +40                       SET BGPPTYPE="D"

 +41                       SET BGPQHDR=0

 +42                       DO ^BGP8DH

 +43                       IF BGPQHDR

                               SET BGPQUIT=1

                               DO KITM

                               QUIT 

 +44                       SET BGPGPG=0

 +45                       SET BGPQUIT=""

 +46                       DO PRINT1

 +47      ;D ^BGP8PDL ;create ^tmp of delimited report

                           DO SAVEDEL^BGP8PDL

 +48                       SET BGPIFTR=1

 +49                       KILL ^XTMP("BGP8D",BGPJ,BGPH)

 +50                       KILL ^XTMP("BGP8DNP",BGPJ,BGPH)

 +51                       KILL ^XTMP("BGP28CPL",BGPJ,BGPH)

 +52                       KILL ^TMP($JOB)

 +53                       QUIT 

                       End DoDot:2

 +54               QUIT 

               End DoDot:1

               QUIT 

PRINTN    ;

 +1       ;dashboard

           IF $GET(BGPDASH)

               DO PRINTN^BGP8DBPR

               QUIT 

 +2        KILL ^TMP($JOB)

 +3        KILL BGPDELIM

 +4        SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:$GET(IOSL))

 +5        SET BGPQUIT=""

 +6        SET ^TMP($JOB,"BGPDEL",0)=0

 +7        IF $GET(BGPAREAA)

               DO SETEXCEL

 +8        SET BGPIFTR=""

 +9        IF BGPROT="D"

               GOTO DEL

 +10       SET BGPPTYPE="P"

 +11       SET BGPQHDR=0

 +12      ;LORI

           DO ^BGP8DH

 +13       IF BGPQHDR

               DO KITM

               QUIT 

 +14       SET BGPGPG=0

 +15       SET BGPQUIT=""

 +16       DO PRINT1

 +17       KILL ^TMP($JOB)

 +18       IF BGPROT="P"

               DO KITM

               QUIT 

 +19      ;

DEL       ;create delimited output file

 +1       ;close printer device

           IF '$DATA(BGPGUI)

               DO ^%ZISC

 +2        KILL ^TMP($JOB)

 +3        SET ^TMP($JOB,"BGPDEL",0)=0

 +4        SET BGPQHDR=0

 +5        SET BGPPTYPE="D"

 +6        DO ^BGP8DH

 +7        SET BGPGPG=0

 +8        SET BGPQUIT=""

 +9        DO PRINT1

 +10      ;D ^BGP8PDL ;create ^tmp of delimited report

           DO SAVEDEL^BGP8PDL

 +11       SET BGPIFTR=1

 +12       KILL ^XTMP("BGP8D",BGPJ,BGPH)

 +13       KILL ^XTMP("BGP8DNP",BGPJ,BGPH)

 +14       KILL ^XTMP("BGP28CPL",BGPJ,BGPH)

 +15       KILL ^TMP($JOB)

 +16       QUIT 

W(V,C,F,M,P,T) ;EP

 +1        IF $GET(F)=""

               SET F=1

 +2        IF $GET(C)=""

               SET C=0

 +3        IF $GET(P)=""

               SET P=1

 +4        IF $GET(T)=""

               SET T=0

 +5        IF M="P"

               Begin DoDot:1

 +6       ;I $Y>(BGPIOSL-2) D EOP W:$D(IOF) @IOF

 +7                NEW X

 +8                FOR X=1:1:F

                       WRITE !

 +9                IF C

                       WRITE $$CJ^XLFSTR(V,80)

 +10               IF 'C

                       WRITE ?T,V

               End DoDot:1

               QUIT 

 +11      ;set up array

 +12       IF '$GET(F)

               SET F=0

 +13       NEW %,Z

 +14       SET Z=""

 +15       SET %=$PIECE(^TMP($JOB,"BGPDEL",0),U)

 +16       FOR Z=1:1:F

               SET %=%+1

               SET ^TMP($JOB,"BGPDEL",%)=""

 +17       SET $PIECE(^TMP($JOB,"BGPDEL",0),U)=%

 +18       IF '$DATA(^TMP($JOB,"BGPDEL",%))

               SET ^TMP($JOB,"BGPDEL",%)=""

 +19       SET $PIECE(^TMP($JOB,"BGPDEL",%),U,P)=V

 +20       QUIT 

 +21      ;

WTITLE(I) ;EP - write title line

 +1        NEW T,X,Y,S

 +2        SET T=$PIECE(^BGPINDR(I,0),U,3)

 +3       ; W !,T,! Q

           IF BGPPTYPE="P"

               IF $LENGTH(T)<81

                   DO W(T,0,1,BGPPTYPE)

                   DO W("",0,1,BGPPTYPE)

                   QUIT 

 +4        IF BGPPTYPE="D"

               DO W(T,0,1,BGPPTYPE)

               DO W("",0,1,BGPPTYPE)

               QUIT 

 +5        FOR X=$EXTRACT(T,1,80)

 +6        SET S=""

 +7        FOR Y=80:-1:1

               IF S

                   QUIT 

               SET I=$EXTRACT(X,Y)

               IF I=" "

                   SET S=Y

 +8       ;W !,$E(T,1,S)

           DO W^BGP8DP($EXTRACT(T,1,S),0,1,BGPPTYPE)

 +9       ;W !,$E(T,(S+1),$L(T)),!

           DO W^BGP8DP($EXTRACT(T,(S+1),$LENGTH(T)),0,1,BGPPTYPE)

           DO W("",0,1,BGPPTYPE)

 +10       QUIT 

ANYDEV()  ;

 +1        NEW X,G,Y

 +2        SET G=0

 +3        SET X=0

           FOR 

               SET X=$ORDER(BGPINDL(X))

               IF X'=+X

                   QUIT 

               SET Y=0