BGP8UTL ; IHS/CMI/LAB - UTILITIES ;
;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65
;
STMP ;EP
Q:BGPTIME'=1
I BGPLIST="P",$P(^AUPNPAT(DFN,0),U,14)'=BGPLPRV Q
X ^BGPINDR(BGPIC,2) Q:'$T
S BGPLIST(BGPIC)=$G(BGPLIST(BGPIC))+1
NEW A
I $P(^BGPINDR(BGPIC,0),U,2)=151 S A=BGPAGEE G SL
I $P(^BGPINDR(BGPIC,0),U,2)=171 S A=BGPAGEE G SL
S A=BGPAGEB
SL ;
S ^XTMP("BGP8D",BGPJ,BGPH,"LIST",BGPIC,$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$P(^DPT(DFN,0),U,2),A,DFN)=$G(BGPVALUE)
Q
D(D) ;EP
I D="" Q ""
Q (1700+$E(D,1,3))_$E(D,4,5)_$E(D,6,7)_$S($P(D,".",2)]"":$P(D,".",2),1:"")
JRNL ;EP
N (DT,U,ZTQUEUED) S %=$$NOJOURN^ZIBGCHAR("BGPGPDCR"),%=$$NOJOURN^ZIBGCHAR("BGPGPDPR"),%=$$NOJOURN^ZIBGCHAR("BGPGPDBR"),%=$$NOJOURN^ZIBGCHAR("BGPHEDCB"),%=$$NOJOURN^ZIBGCHAR("BGPHEDPB"),%=$$NOJOURN^ZIBGCHAR("BGPHEDBB")
S %=$$NOJOURN^ZIBGCHAR("BGPDATA"),%=$$NOJOURN^ZIBGCHAR("BGPGUI")
S %=$$NOJOURN^ZIBGCHAR("BGPEDLCR"),%=$$NOJOURN^ZIBGCHAR("BGPEDLPR"),%=$$NOJOURN^ZIBGCHAR("BGPEDLBR")
S %=$$NOJOURN^ZIBGCHAR("BGPEOCB"),%=$$NOJOURN^ZIBGCHAR("BGPEOPB"),%=$$NOJOURN^ZIBGCHAR("BGPEOBB")
S %=$$NOJOURN^ZIBGCHAR("BGPXPH")
Q
DATE(D) ;EP
I D="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
;
EDT(D) ;EP
I D="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))
;
SETHDR ;EP
S BGPX="",$P(BGPX,U,1)="Site Name",$P(BGPX,U,2)="ASUFAC",$P(BGPX,U,3)="DB Id",$P(BGPX,U,4)="Date Report Run",$P(BGPX,U,5)="Current Report Begin Date",$P(BGPX,U,6)="Current Report End Date",$P(BGPX,U,7)="Previous Year Begin Date"
S $P(BGPX,U,8)="Previous Year End Date",$P(BGPX,U,9)="Baseline Year Begin Date",$P(BGPX,U,10)="Baseline Year End Date"
Q
ONN1 ;EP
K BGPEXCT
S Y=$$OPEN^%ZISH(BGPUF,BGPFONN1,"W")
I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file." Q
U IO
S BGPP=0,BGPY=$O(^BGPCTRL("B","2018",0)),BGPX="",BGPEC=$P(^BGPCTRL(BGPY,0),U,2)
F S BGPP=$O(^BGPCTRL(BGPY,36,BGPP)) Q:BGPP'=+BGPP D
.S BGPPP1=$P(^BGPCTRL(BGPY,36,BGPP,0),U,1)
.S BGPZ=$P(^BGPCTRL(BGPY,36,BGPP,0),U,2)
.S $P(BGPX,U,BGPPP1)=BGPZ
W BGPX,!
K BGPX
S BGPX="" S P=11 F S $P(BGPX,U,P)="Current",P=P+9 Q:P>(BGPEC-8)
S P=14 F S $P(BGPX,U,P)="Previous",P=P+9 Q:P>(BGPEC-5)
S P=17 F S $P(BGPX,U,P)="Baseline",P=P+9 Q:P>(BGPEC+1)
W BGPX,!
K BGPX
D SETHDR
S P=11 F S $P(BGPX,U,P)="Num",P=P+3 Q:P>(BGPEC-2)
S P=12 F S $P(BGPX,U,P)="Den",P=P+3 Q:P>(BGPEC-1)
S P=13 F S $P(BGPX,U,P)="%",P=P+3 Q:P>BGPEC
W BGPX,!
S BGPX=0 F S BGPX=$O(BGPONN1(BGPX)) Q:BGPX'=+BGPX W BGPONN1(BGPX),!
K BGPONN1
D ^%ZISC
ONN2 ;
K BGPEXCT
S Y=$$OPEN^%ZISH(BGPUF,BGPFONN2,"W")
I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file." Q
U IO
S BGPP=0,BGPY=$O(^BGPCTRL("B","2018",0)),BGPX="",BGPEC=$P(^BGPCTRL(BGPY,0),U,3)
F S BGPP=$O(^BGPCTRL(BGPY,37,BGPP)) Q:BGPP'=+BGPP D
.S BGPPP1=$P(^BGPCTRL(BGPY,37,BGPP,0),U,1)
.S BGPZ=$P(^BGPCTRL(BGPY,37,BGPP,0),U,2)
.S $P(BGPX,U,BGPPP1)=BGPZ
W BGPX,!
K BGPX
S BGPX="" S P=11 F S $P(BGPX,U,P)="Current",P=P+9 Q:P>(BGPEC-8)
S P=14 F S $P(BGPX,U,P)="Previous",P=P+9 Q:P>(BGPEC-5)
S P=17 F S $P(BGPX,U,P)="Baseline",P=P+9 Q:P>(BGPEC+1)
W BGPX,!
K BGPX
D SETHDR
S P=11 F S $P(BGPX,U,P)="Num",P=P+3 Q:P>(BGPEC-2)
S P=12 F S $P(BGPX,U,P)="Den",P=P+3 Q:P>(BGPEC-1)
S P=13 F S $P(BGPX,U,P)="%",P=P+3 Q:P>BGPEC
W BGPX,!
S BGPX=0 F S BGPX=$O(BGPONN2(BGPX)) Q:BGPX'=+BGPX W BGPONN2(BGPX),!
K BGPONN2
D ^%ZISC
ONN3 ;
K BGPEXCT
S Y=$$OPEN^%ZISH(BGPUF,BGPFONN3,"W")
I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file." Q
U IO
S BGPP=0,BGPY=$O(^BGPCTRL("B","2018",0)),BGPX="",BGPEC=$P(^BGPCTRL(BGPY,0),U,21)
F S BGPP=$O(^BGPCTRL(BGPY,45,BGPP)) Q:BGPP'=+BGPP D
.S BGPPP1=$P(^BGPCTRL(BGPY,45,BGPP,0),U,1)
.S BGPZ=$P(^BGPCTRL(BGPY,45,BGPP,0),U,2)
.S $P(BGPX,U,BGPPP1)=BGPZ
W BGPX,!
K BGPX
S BGPX="" S P=11 F S $P(BGPX,U,P)="Current",P=P+9 Q:P>(BGPEC-8)
S P=14 F S $P(BGPX,U,P)="Previous",P=P+9 Q:P>(BGPEC-5)
S P=17 F S $P(BGPX,U,P)="Baseline",P=P+9 Q:P>(BGPEC+1)
W BGPX,!
K BGPX
D SETHDR
S P=11 F S $P(BGPX,U,P)="Num",P=P+3 Q:P>(BGPEC-2)
S P=12 F S $P(BGPX,U,P)="Den",P=P+3 Q:P>(BGPEC-1)
S P=13 F S $P(BGPX,U,P)="%",P=P+3 Q:P>BGPEC
W BGPX,!
S BGPX=0 F S BGPX=$O(BGPONN3(BGPX)) Q:BGPX'=+BGPX W BGPONN3(BGPX),!
K BGPONN3
ONNC D ^%ZISC
D ONN4^BGP8UTL3
Q
GNT1 ;EP - area export file
K BGPEXCT
I '$G(BGPAREAA) G Q1
S Y=$$OPEN^%ZISH(BGPUF,BGPFGNT1,"W")
I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file." Q
U IO
S BGPP=0,BGPY=$O(^BGPCTRL("B","2018",0)),BGPX="",BGPEC=$P(^BGPCTRL(BGPY,0),U,4)
F S BGPP=$O(^BGPCTRL(BGPY,38,BGPP)) Q:BGPP'=+BGPP D
.S BGPPP1=$P(^BGPCTRL(BGPY,38,BGPP,0),U,1)
.S BGPZ=$P(^BGPCTRL(BGPY,38,BGPP,0),U,2)
.S $P(BGPX,U,BGPPP1)=BGPZ
W BGPX,!
K BGPX
S BGPX="" S P=11 F S $P(BGPX,U,P)="Current",P=P+9 Q:P>(BGPEC-8)
S P=14 F S $P(BGPX,U,P)="Previous",P=P+9 Q:P>(BGPEC-5)
S P=17 F S $P(BGPX,U,P)="Baseline",P=P+9 Q:P>(BGPEC+1)
W BGPX,!
K BGPX
D SETHDR
S P=11 F S $P(BGPX,U,P)="Num",P=P+3 Q:P>(BGPEC-2)
S P=12 F S $P(BGPX,U,P)="Den",P=P+3 Q:P>(BGPEC-1)
S P=13 F S $P(BGPX,U,P)="%",P=P+3 Q:P>BGPEC
W BGPX,!
K BGPX
S BGPX=0 F S BGPX=$O(BGPEI(BGPX)) Q:BGPX'=+BGPX W BGPEI(BGPX),!
D ^%ZISC
Q1 ;
K BGPEI
GNT2 ;
K BGPEXCT
I '$G(BGPAREAA) G Q2
S Y=$$OPEN^%ZISH(BGPUF,BGPFGNT2,"W")
I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file." Q
U IO
S BGPP=0,BGPY=$O(^BGPCTRL("B","2018",0)),BGPX="",BGPEC=$P(^BGPCTRL(BGPY,0),U,16)
F S BGPP=$O(^BGPCTRL(BGPY,40,BGPP)) Q:BGPP'=+BGPP D
.S BGPPP1=$P(^BGPCTRL(BGPY,40,BGPP,0),U,1)
.S BGPZ=$P(^BGPCTRL(BGPY,40,BGPP,0),U,2)
.S $P(BGPX,U,BGPPP1)=BGPZ
W BGPX,!
K BGPX
S BGPX="" S P=11 F S $P(BGPX,U,P)="Current",P=P+9 Q:P>(BGPEC-8)
S P=14 F S $P(BGPX,U,P)="Previous",P=P+9 Q:P>(BGPEC-5)
S P=17 F S $P(BGPX,U,P)="Baseline",P=P+9 Q:P>(BGPEC+1)
W BGPX,!
K BGPX
D SETHDR
S P=11 F S $P(BGPX,U,P)="Num",P=P+3 Q:P>(BGPEC-2)
S P=12 F S $P(BGPX,U,P)="Den",P=P+3 Q:P>(BGPEC-1)
S P=13 F S $P(BGPX,U,P)="%",P=P+3 Q:P>BGPEC
W BGPX,!
K BGPX
S BGPX=0 F S BGPX=$O(BGPEI2(BGPX)) Q:BGPX'=+BGPX W BGPEI2(BGPX),!
Q2 ;
K BGPEI2
D ^%ZISC
Q3 ;
D GNT3^BGP8UTLC
Q
GS ;EP
K ^TMP($J)
L +^BGPDATA:300 E W:'$D(ZTQUEUED) "Unable to lock global" Q
;NOTE: Kill of unscripted global. Export to area. Using standard name.
S BGPENDN=$S($P(^BGPSITE(DUZ(2),0),U,11)=0:88887,1:99998)
K ^BGPDATA S X="",C=0 F S X=$O(^BGPGPDCR(BGPRPT,X)) Q:X'=+X!(X>BGPENDN) D
.I $G(^BGPGPDCR(BGPRPT,X))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",8)=^BGPGPDCR(BGPRPT,X)
.S X2="" F S X2=$O(^BGPGPDCR(BGPRPT,X,X2)) Q:X2'=+X2 D
..I $G(^BGPGPDCR(BGPRPT,X,X2))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",8)=^BGPGPDCR(BGPRPT,X,X2)
..S X3="" F S X3=$O(^BGPGPDCR(BGPRPT,X,X2,X3)) Q:X3'=+X3 D
...I $G(^BGPGPDCR(BGPRPT,X,X2,X3))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3,$P(^BGPDATA(C),"|",8)=^BGPGPDCR(BGPRPT,X,X2,X3)
...S X4="" F S X4=$O(^BGPGPDCR(BGPRPT,X,X2,X3,X4)) Q:X4'=+X4 D
....I $G(^BGPGPDCR(BGPRPT,X,X2,X3,X4))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3,$P(^BGPDATA(C),"|",4)=X4,$P(^BGPDATA(C),"|",8)=^BGPGPDCR(BGPRPT,X,X2,X3,X4)
....S X5="" F S X5=$O(^BGPGPDCR(BGPRPT,X,X2,X3,X4,X5)) Q:X5'=+X5 D
.....I $G(^BGPGPDCR(BGPRPT,X,X2,X3,X4,X5))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3
.....S $P(^BGPDATA(C),"|",4)=X4,$P(^BGPDATA(C),"|",5)=X5,$P(^BGPDATA(C),"|",8)=^BGPGPDCR(BGPRPT,X,X2,X3,X4,X5)
S X=0 F S X=$O(^BGPDATA(X)) Q:X'=+X S ^BGPDATA(X)="BGPGPDCR"_"|"_^BGPDATA(X)
PRGS ;
S S=C+1,X="" F S X=$O(^BGPGPDPR(BGPRPT,X)) Q:X'=+X!(X>99998) D
.I $G(^BGPGPDPR(BGPRPT,X))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",8)=^BGPGPDPR(BGPRPT,X)
.S X2="" F S X2=$O(^BGPGPDPR(BGPRPT,X,X2)) Q:X2'=+X2 D
..I $G(^BGPGPDPR(BGPRPT,X,X2))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",8)=^BGPGPDPR(BGPRPT,X,X2)
..S X3="" F S X3=$O(^BGPGPDPR(BGPRPT,X,X2,X3)) Q:X3'=+X3 D
...I $G(^BGPGPDPR(BGPRPT,X,X2,X3))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3,$P(^BGPDATA(C),"|",8)=^BGPGPDPR(BGPRPT,X,X2,X3)
...S X4="" F S X4=$O(^BGPGPDPR(BGPRPT,X,X2,X3,X4)) Q:X4'=+X4 D
....I $G(^BGPGPDPR(BGPRPT,X,X2,X3,X4))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3,$P(^BGPDATA(C),"|",4)=X4,$P(^BGPDATA(C),"|",8)=^BGPGPDPR(BGPRPT,X,X2,X3,X4)
....S X5="" F S X5=$O(^BGPGPDPR(BGPRPT,X,X2,X3,X4,X5)) Q:X5'=+X5 D
.....I $G(^BGPGPDPR(BGPRPT,X,X2,X3,X4,X5))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3
.....S $P(^BGPDATA(C),"|",4)=X4,$P(^BGPDATA(C),"|",5)=X5,$P(^BGPDATA(C),"|",8)=^BGPGPDPR(BGPRPT,X,X2,X3,X4,X5)
S X=S-1 F S X=$O(^BGPDATA(X)) Q:X'=+X S ^BGPDATA(X)="BGPGPDPR"_"|"_^BGPDATA(X)
BLGS ;
S S=C+1,X="" F S X=$O(^BGPGPDBR(BGPRPT,X)) Q:X'=+X!(X>99998) D
.I $G(^BGPGPDBR(BGPRPT,X))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",8)=^BGPGPDBR(BGPRPT,X)
.S X2="" F S X2=$O(^BGPGPDBR(BGPRPT,X,X2)) Q:X2'=+X2 D
..I $G(^BGPGPDBR(BGPRPT,X,X2))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",8)=^BGPGPDBR(BGPRPT,X,X2)
..S X3="" F S X3=$O(^BGPGPDBR(BGPRPT,X,X2,X3)) Q:X3'=+X3 D
...I $G(^BGPGPDBR(BGPRPT,X,X2,X3))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3,$P(^BGPDATA(C),"|",8)=^BGPGPDBR(BGPRPT,X,X2,X3)
...S X4="" F S X4=$O(^BGPGPDBR(BGPRPT,X,X2,X3,X4)) Q:X4'=+X4 D
....I $G(^BGPGPDBR(BGPRPT,X,X2,X3,X4))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3,$P(^BGPDATA(C),"|",4)=X4,$P(^BGPDATA(C),"|",8)=^BGPGPDBR(BGPRPT,X,X2,X3,X4)
....S X5="" F S X5=$O(^BGPGPDBR(BGPRPT,X,X2,X3,X4,X5)) Q:X5'=+X5 D
.....I $G(^BGPGPDBR(BGPRPT,X,X2,X3,X4,X5))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3
.....S $P(^BGPDATA(C),"|",4)=X4,$P(^BGPDATA(C),"|",5)=X5,$P(^BGPDATA(C),"|",8)=^BGPGPDBR(BGPRPT,X,X2,X3,X4,X5)
S X=S-1 F S X=$O(^BGPDATA(X)) Q:X'=+X S ^BGPDATA(X)="BGPGPDBR"_"|"_^BGPDATA(X)
I $G(BGPAMEX) D AUTOEX^BGP8AUEX Q ;AUTO
NEW XBGL S XBGL="BGPDATA"
S F="BG"_$$FV^BGP8BAN()_$P(^AUTTLOC(DUZ(2),0),U,10)_"."_$S(BGPRTYPE=7:"ONM",1:"")_BGPRPT
NEW XBFN,XBMED,XBF,XBFLT
S XBMED="F",XBFN=F,XBTLE="SAVE OF CRS DATA BY - "_$P(^VA(200,DUZ,0),U),XBF=0,XBFLT=1
S XBUF=BGPUF D ^XBGSAVE
L -^BGPDATA
K ^TMP($J),^BGPDATA ;NOTE: kill of unsubscripted global for use in export to area.
Q
REPORT ;EP
S BGPRPT="",BGPERR=""
;3 files must have the same ien
L +^BGPGPDCR:30 I '$T S BGPERR="Unable to lock global." G REPORTX
L +^BGPGPDPR:30 I '$T S BGPERR="Unable to lock global." G REPORTX
L +^BGPGPDBR:30 I '$T S BGPERR="Unable to lock global." G REPORTX
D GETIEN
I 'BGPIEN S BGPERR="Error in control files!" S BGPRPT="" G REPORTX
S DINUM=BGPIEN
I $G(BGPNPL) S BGPRTYPE=4
S BGPR12=$S($G(BGPYGPU):9,1:BGPRTYPE)
K DIC S X=BGPBD,DIC(0)="L",DIC="^BGPGPDCR(",DLAYGO=90560.03,DIADD=1,DIC("DR")=".02////"_BGPED_";.03////"_BGPPBD_";.04////"_BGPPED_";.05////"_BGPBBD_";.06////"_BGPBED_";.07////"_$G(BGPPER)_";.08////"_$G(BGPQTR)
S DIC("DR")=DIC("DR")_";.09////"_$P(^AUTTLOC(DUZ(2),0),U,10)_";.11////"_$E($P(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.12////"_BGPR12_";.13////"_DT_";.14////"_BGPBEN_";.15////"_$P($G(^AUTTLOC(DUZ(2),1)),U,3)_";.16///"_$P(^BGPSITE(DUZ(2),0),U,4)
S DIC("DR")=DIC("DR")_";.17///"_$P(^BGPSITE(DUZ(2),0),U,6)_";.18///"_$S($G(BGPTAXI):$P(^ATXAX(BGPTAXI,0),U),1:"")_";.19///"_$P(^BGPSITE(DUZ(2),0),U,13)_$S($G(BGPDESGP):";.2///1",1:"")_";.21///"_$$VER^BGP8BAN()
I $G(BGPCOMMI) S DIC("DR")=DIC("DR")_";.22///"_$P(^AUTTCOM(BGPCOMMI,0),U)
D ^DIC K DIC,DA,DR,DIADD,DLAYGO I Y=-1 S BGPERR="UNABLE TO CREATE REPORT FILE ENTRY!" S BGPQUIT=1 G REPORTX
S BGPRPT=+Y
K DIC S X=BGPBD,DIC(0)="L",DIC="^BGPGPDPR(",DLAYGO=90560.04,DIADD=1,DIC("DR")=".02////"_BGPED_";.03////"_BGPPBD_";.04////"_BGPPED_";.05////"_BGPBBD_";.06////"_BGPBED_";.07////"_$G(BGPPER)_";.08////"_$G(BGPQTR)
S DIC("DR")=DIC("DR")_";.09////"_$P(^AUTTLOC(DUZ(2),0),U,10)_";.11////"_$E($P(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.12////"_BGPR12_";.13////"_DT_";.14////"_BGPBEN_";.15////"_$P($G(^AUTTLOC(DUZ(2),1)),U,3)_";.16///"_$P(^BGPSITE(DUZ(2),0),U,4)
S DIC("DR")=DIC("DR")_";.17///"_$P(^BGPSITE(DUZ(2),0),U,6)_";.18///"_$S($G(BGPTAXI):$P(^ATXAX(BGPTAXI,0),U),1:"")_";.19///"_$P(^BGPSITE(DUZ(2),0),U,13)_";.21///"_$$VER^BGP8BAN()
I $G(BGPCOMMI) S DIC("DR")=DIC("DR")_";.22///"_$P(^AUTTCOM(BGPCOMMI,0),U)
S DINUM=BGPRPT D ^DIC K DIC,DA,DR,DIADD,DLAYGO,DINUM I Y=-1 S BGPERR="UNABLE TO CREATE REPORT FILE ENTRY!" S BGPQUIT=1 G REPORTX
S BGPRPTP=+Y
K DIC S X=BGPBD,DIC(0)="L",DIC="^BGPGPDBR(",DLAYGO=90560.05,DIADD=1,DIC("DR")=".02////"_BGPED_";.03////"_BGPPBD_";.04////"_BGPPED_";.05////"_BGPBBD_";.06////"_BGPBED_";.07////"_$G(BGPPER)_";.08////"_$G(BGPQTR)
S DIC("DR")=DIC("DR")_";.09////"_$P(^AUTTLOC(DUZ(2),0),U,10)_";.11////"_$E($P(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.12////"_BGPR12_";.13////"_DT_";.14////"_BGPBEN_";.15////"_$P($G(^AUTTLOC(DUZ(2),1)),U,3)_";.16///"_$P(^BGPSITE(DUZ(2),0),U,4)
S DIC("DR")=DIC("DR")_";.17///"_$P(^BGPSITE(DUZ(2),0),U,6)_";.18///"_$S($G(BGPTAXI):$P(^ATXAX(BGPTAXI,0),U),1:"")_";.19///"_$P(^BGPSITE(DUZ(2),0),U,13)_";.21///"_$$VER^BGP8BAN()
I $G(BGPCOMMI) S DIC("DR")=DIC("DR")_";.22///"_$P(^AUTTCOM(BGPCOMMI,0),U)
S DINUM=BGPRPT D ^DIC K DIC,DA,DR,DIADD,DLAYGO I Y=-1 S BGPERR="UNABLE TO CREATE REPORT FILE ENTRY!" S BGPQUIT=1 G REPORTX
S BGPRPTB=+Y
;
K ^BGPGPDCR(BGPRPT,9999)
S C=0,X="" F S X=$O(BGPTAX(X)) Q:X="" S C=C+1 S ^BGPGPDCR(BGPRPT,9999,C,0)=X,^BGPGPDCR(BGPRPT,9999,"B",X,C)=""
S ^BGPGPDCR(BGPRPT,9999,0)="^90560.12999A^"_C_"^"_C
S ^BGPGPDCR(BGPRPT,99999,0)="^90560.129999A^0^0"
S ^BGPGPDPR(BGPRPT,99999,0)="^90560.139999A^0^0"
S ^BGPGPDBR(BGPRPT,99999,0)="^90560.149999A^0^0"
REPORTX ;
I BGPERR]"" W !!,BGPERR
I $G(BGPNPL) S BGPRTYPE=$S($G(BGPONMR):7,1:1)
D ^XBFMK
K DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM
L -^BGPGPDCR
L -^BGPGPDPR
L -^BGPGPDBR
Q
GETIEN ;EP - Get next ien available in all 3 files
S BGPF=90560.03 D ENT
S BGPF=90560.04 D ENT
S BGPF=90560.05 D ENT
S BGPIEN=$P(^BGPGPDCR(0),U,3)+1
S I $D(^BGPGPDPR(BGPIEN))!($D(^BGPGPDBR(BGPIEN))) S BGPIEN=BGPIEN+1 G S
Q
;
ENT ;
NEW GBL,NXT,CTR,XBHI,XBX,XBY,ANS
S GBL=^DIC(BGPF,0,"GL")
S GBL=GBL_"NXT)"
S (XBHI,NXT,CTR)=0
F L=0:0 S NXT=$O(@(GBL)) Q:NXT'=+NXT S XBHI=NXT,CTR=CTR+1 ;W:'(CTR#50) "."
S NXT="",XBX=$O(@(GBL)),XBX=^(0),XBY=$P(XBX,U,4),XBX=$P(XBX,U,3)
S NXT=0,$P(@(GBL),U,3)=XBHI,$P(^(0),U,4)=CTR
;
EOJ ;
KILL ANS,XBHI,XBX,XBY,CTR,DIC,FILE,GBL,L,NXT,BGPF
Q
;
LZERO(V,L) ;EP
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
Q V
RZERO(V,L) ;EP
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=V_"0"
Q V
XTMP(N,D) ;EP
Q:$G(N)=""
S ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_$G(D)
Q
BGP8UTL ; IHS/CMI/LAB - UTILITIES ;
+1 ;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65
+2 ;
STMP ;EP
+1 IF BGPTIME'=1
QUIT
+2 IF BGPLIST="P"
IF $PIECE(^AUPNPAT(DFN,0),U,14)'=BGPLPRV
QUIT
+3 XECUTE ^BGPINDR(BGPIC,2)
IF '$TEST
QUIT
+4 SET BGPLIST(BGPIC)=$GET(BGPLIST(BGPIC))+1
+5 NEW A
+6 IF $PIECE(^BGPINDR(BGPIC,0),U,2)=151
SET A=BGPAGEE
GOTO SL
+7 IF $PIECE(^BGPINDR(BGPIC,0),U,2)=171
SET A=BGPAGEE
GOTO SL
+8 SET A=BGPAGEB
SL ;
+1 SET ^XTMP("BGP8D",BGPJ,BGPH,"LIST",BGPIC,$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$PIECE(^DPT(DFN,0),U,2),A,DFN)=$GET(BGPVALUE)
+2 QUIT
D(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT (1700+$EXTRACT(D,1,3))_$EXTRACT(D,4,5)_$EXTRACT(D,6,7)_$SELECT($PIECE(D,".",2)]"":$PIECE(D,".",2),1:"")
JRNL ;EP
+1 NEW (DT,U,ZTQUEUED)
SET %=$$NOJOURN^ZIBGCHAR("BGPGPDCR")
SET %=$$NOJOURN^ZIBGCHAR("BGPGPDPR")
SET %=$$NOJOURN^ZIBGCHAR("BGPGPDBR")
SET %=$$NOJOURN^ZIBGCHAR("BGPHEDCB")
SET %=$$NOJOURN^ZIBGCHAR("BGPHEDPB")
SET %=$$NOJOURN^ZIBGCHAR("BGPHEDBB")
+2 SET %=$$NOJOURN^ZIBGCHAR("BGPDATA")
SET %=$$NOJOURN^ZIBGCHAR("BGPGUI")
+3 SET %=$$NOJOURN^ZIBGCHAR("BGPEDLCR")
SET %=$$NOJOURN^ZIBGCHAR("BGPEDLPR")
SET %=$$NOJOURN^ZIBGCHAR("BGPEDLBR")
+4 SET %=$$NOJOURN^ZIBGCHAR("BGPEOCB")
SET %=$$NOJOURN^ZIBGCHAR("BGPEOPB")
SET %=$$NOJOURN^ZIBGCHAR("BGPEOBB")
+5 SET %=$$NOJOURN^ZIBGCHAR("BGPXPH")
+6 QUIT
DATE(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+3 ;
EDT(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+$EXTRACT(D,1,3))
+3 ;
SETHDR ;EP
+1 SET BGPX=""
SET $PIECE(BGPX,U,1)="Site Name"
SET $PIECE(BGPX,U,2)="ASUFAC"
SET $PIECE(BGPX,U,3)="DB Id"
SET $PIECE(BGPX,U,4)="Date Report Run"
SET $PIECE(BGPX,U,5)="Current Report Begin Date"
SET $PIECE(BGPX,U,6)="Current Report End Date"
SET $PIECE(BGPX,U,7)="Previous Year Begin Date"
+2 SET $PIECE(BGPX,U,8)="Previous Year End Date"
SET $PIECE(BGPX,U,9)="Baseline Year Begin Date"
SET $PIECE(BGPX,U,10)="Baseline Year End Date"
+3 QUIT
ONN1 ;EP
+1 KILL BGPEXCT
+2 SET Y=$$OPEN^%ZISH(BGPUF,BGPFONN1,"W")
+3 IF Y=1
IF '$DATA(ZTQUEUED)
WRITE !!,"Cannot open host file."
QUIT
+4 USE IO
+5 SET BGPP=0
SET BGPY=$ORDER(^BGPCTRL("B","2018",0))
SET BGPX=""
SET BGPEC=$PIECE(^BGPCTRL(BGPY,0),U,2)
+6 FOR
SET BGPP=$ORDER(^BGPCTRL(BGPY,36,BGPP))
IF BGPP'=+BGPP
QUIT
Begin DoDot:1
+7 SET BGPPP1=$PIECE(^BGPCTRL(BGPY,36,BGPP,0),U,1)
+8 SET BGPZ=$PIECE(^BGPCTRL(BGPY,36,BGPP,0),U,2)
+9 SET $PIECE(BGPX,U,BGPPP1)=BGPZ
End DoDot:1
+10 WRITE BGPX,!
+11 KILL BGPX
+12 SET BGPX=""
SET P=11
FOR
SET $PIECE(BGPX,U,P)="Current"
SET P=P+9
IF P>(BGPEC-8)
QUIT
+13 SET P=14
FOR
SET $PIECE(BGPX,U,P)="Previous"
SET P=P+9
IF P>(BGPEC-5)
QUIT
+14 SET P=17
FOR
SET $PIECE(BGPX,U,P)="Baseline"
SET P=P+9
IF P>(BGPEC+1)
QUIT
+15 WRITE BGPX,!
+16 KILL BGPX
+17 DO SETHDR
+18 SET P=11
FOR
SET $PIECE(BGPX,U,P)="Num"
SET P=P+3
IF P>(BGPEC-2)
QUIT
+19 SET P=12
FOR
SET $PIECE(BGPX,U,P)="Den"
SET P=P+3
IF P>(BGPEC-1)
QUIT
+20 SET P=13
FOR
SET $PIECE(BGPX,U,P)="%"
SET P=P+3
IF P>BGPEC
QUIT
+21 WRITE BGPX,!
+22 SET BGPX=0
FOR
SET BGPX=$ORDER(BGPONN1(BGPX))
IF BGPX'=+BGPX
QUIT
WRITE BGPONN1(BGPX),!
+23 KILL BGPONN1
+24 DO ^%ZISC
ONN2 ;
+1 KILL BGPEXCT
+2 SET Y=$$OPEN^%ZISH(BGPUF,BGPFONN2,"W")
+3 IF Y=1
IF '$DATA(ZTQUEUED)
WRITE !!,"Cannot open host file."
QUIT
+4 USE IO
+5 SET BGPP=0
SET BGPY=$ORDER(^BGPCTRL("B","2018",0))
SET BGPX=""
SET BGPEC=$PIECE(^BGPCTRL(BGPY,0),U,3)
+6 FOR
SET BGPP=$ORDER(^BGPCTRL(BGPY,37,BGPP))
IF BGPP'=+BGPP
QUIT
Begin DoDot:1
+7 SET BGPPP1=$PIECE(^BGPCTRL(BGPY,37,BGPP,0),U,1)
+8 SET BGPZ=$PIECE(^BGPCTRL(BGPY,37,BGPP,0),U,2)
+9 SET $PIECE(BGPX,U,BGPPP1)=BGPZ
End DoDot:1
+10 WRITE BGPX,!
+11 KILL BGPX
+12 SET BGPX=""
SET P=11
FOR
SET $PIECE(BGPX,U,P)="Current"
SET P=P+9
IF P>(BGPEC-8)
QUIT
+13 SET P=14
FOR
SET $PIECE(BGPX,U,P)="Previous"
SET P=P+9
IF P>(BGPEC-5)
QUIT
+14 SET P=17
FOR
SET $PIECE(BGPX,U,P)="Baseline"
SET P=P+9
IF P>(BGPEC+1)
QUIT
+15 WRITE BGPX,!
+16 KILL BGPX
+17 DO SETHDR
+18 SET P=11
FOR
SET $PIECE(BGPX,U,P)="Num"
SET P=P+3
IF P>(BGPEC-2)
QUIT
+19 SET P=12
FOR
SET $PIECE(BGPX,U,P)="Den"
SET P=P+3
IF P>(BGPEC-1)
QUIT
+20 SET P=13
FOR
SET $PIECE(BGPX,U,P)="%"
SET P=P+3
IF P>BGPEC
QUIT
+21 WRITE BGPX,!
+22 SET BGPX=0
FOR
SET BGPX=$ORDER(BGPONN2(BGPX))
IF BGPX'=+BGPX
QUIT
WRITE BGPONN2(BGPX),!
+23 KILL BGPONN2
+24 DO ^%ZISC
ONN3 ;
+1 KILL BGPEXCT
+2 SET Y=$$OPEN^%ZISH(BGPUF,BGPFONN3,"W")
+3 IF Y=1
IF '$DATA(ZTQUEUED)
WRITE !!,"Cannot open host file."
QUIT
+4 USE IO
+5 SET BGPP=0
SET BGPY=$ORDER(^BGPCTRL("B","2018",0))
SET BGPX=""
SET BGPEC=$PIECE(^BGPCTRL(BGPY,0),U,21)
+6 FOR
SET BGPP=$ORDER(^BGPCTRL(BGPY,45,BGPP))
IF BGPP'=+BGPP
QUIT
Begin DoDot:1
+7 SET BGPPP1=$PIECE(^BGPCTRL(BGPY,45,BGPP,0),U,1)
+8 SET BGPZ=$PIECE(^BGPCTRL(BGPY,45,BGPP,0),U,2)
+9 SET $PIECE(BGPX,U,BGPPP1)=BGPZ
End DoDot:1
+10 WRITE BGPX,!
+11 KILL BGPX
+12 SET BGPX=""
SET P=11
FOR
SET $PIECE(BGPX,U,P)="Current"
SET P=P+9
IF P>(BGPEC-8)
QUIT
+13 SET P=14
FOR
SET $PIECE(BGPX,U,P)="Previous"
SET P=P+9
IF P>(BGPEC-5)
QUIT
+14 SET P=17
FOR
SET $PIECE(BGPX,U,P)="Baseline"
SET P=P+9
IF P>(BGPEC+1)
QUIT
+15 WRITE BGPX,!
+16 KILL BGPX
+17 DO SETHDR
+18 SET P=11
FOR
SET $PIECE(BGPX,U,P)="Num"
SET P=P+3
IF P>(BGPEC-2)
QUIT
+19 SET P=12
FOR
SET $PIECE(BGPX,U,P)="Den"
SET P=P+3
IF P>(BGPEC-1)
QUIT
+20 SET P=13
FOR
SET $PIECE(BGPX,U,P)="%"
SET P=P+3
IF P>BGPEC
QUIT
+21 WRITE BGPX,!
+22 SET BGPX=0
FOR
SET BGPX=$ORDER(BGPONN3(BGPX))
IF BGPX'=+BGPX
QUIT
WRITE BGPONN3(BGPX),!
+23 KILL BGPONN3
ONNC DO ^%ZISC
+1 DO ONN4^BGP8UTL3
+2 QUIT
GNT1 ;EP - area export file
+1 KILL BGPEXCT
+2 IF '$GET(BGPAREAA)
GOTO Q1
+3 SET Y=$$OPEN^%ZISH(BGPUF,BGPFGNT1,"W")
+4 IF Y=1
IF '$DATA(ZTQUEUED)
WRITE !!,"Cannot open host file."
QUIT
+5 USE IO
+6 SET BGPP=0
SET BGPY=$ORDER(^BGPCTRL("B","2018",0))
SET BGPX=""
SET BGPEC=$PIECE(^BGPCTRL(BGPY,0),U,4)
+7 FOR
SET BGPP=$ORDER(^BGPCTRL(BGPY,38,BGPP))
IF BGPP'=+BGPP
QUIT
Begin DoDot:1
+8 SET BGPPP1=$PIECE(^BGPCTRL(BGPY,38,BGPP,0),U,1)
+9 SET BGPZ=$PIECE(^BGPCTRL(BGPY,38,BGPP,0),U,2)
+10 SET $PIECE(BGPX,U,BGPPP1)=BGPZ
End DoDot:1
+11 WRITE BGPX,!
+12 KILL BGPX
+13 SET BGPX=""
SET P=11
FOR
SET $PIECE(BGPX,U,P)="Current"
SET P=P+9
IF P>(BGPEC-8)
QUIT
+14 SET P=14
FOR
SET $PIECE(BGPX,U,P)="Previous"
SET P=P+9
IF P>(BGPEC-5)
QUIT
+15 SET P=17
FOR
SET $PIECE(BGPX,U,P)="Baseline"
SET P=P+9
IF P>(BGPEC+1)
QUIT
+16 WRITE BGPX,!
+17 KILL BGPX
+18 DO SETHDR
+19 SET P=11
FOR
SET $PIECE(BGPX,U,P)="Num"
SET P=P+3
IF P>(BGPEC-2)
QUIT
+20 SET P=12
FOR
SET $PIECE(BGPX,U,P)="Den"
SET P=P+3
IF P>(BGPEC-1)
QUIT
+21 SET P=13
FOR
SET $PIECE(BGPX,U,P)="%"
SET P=P+3
IF P>BGPEC
QUIT
+22 WRITE BGPX,!
+23 KILL BGPX
+24 SET BGPX=0
FOR
SET BGPX=$ORDER(BGPEI(BGPX))
IF BGPX'=+BGPX
QUIT
WRITE BGPEI(BGPX),!
+25 DO ^%ZISC
Q1 ;
+1 KILL BGPEI
GNT2 ;
+1 KILL BGPEXCT
+2 IF '$GET(BGPAREAA)
GOTO Q2
+3 SET Y=$$OPEN^%ZISH(BGPUF,BGPFGNT2,"W")
+4 IF Y=1
IF '$DATA(ZTQUEUED)
WRITE !!,"Cannot open host file."
QUIT
+5 USE IO
+6 SET BGPP=0
SET BGPY=$ORDER(^BGPCTRL("B","2018",0))
SET BGPX=""
SET BGPEC=$PIECE(^BGPCTRL(BGPY,0),U,16)
+7 FOR
SET BGPP=$ORDER(^BGPCTRL(BGPY,40,BGPP))
IF BGPP'=+BGPP
QUIT
Begin DoDot:1
+8 SET BGPPP1=$PIECE(^BGPCTRL(BGPY,40,BGPP,0),U,1)
+9 SET BGPZ=$PIECE(^BGPCTRL(BGPY,40,BGPP,0),U,2)
+10 SET $PIECE(BGPX,U,BGPPP1)=BGPZ
End DoDot:1
+11 WRITE BGPX,!
+12 KILL BGPX
+13 SET BGPX=""
SET P=11
FOR
SET $PIECE(BGPX,U,P)="Current"
SET P=P+9
IF P>(BGPEC-8)
QUIT
+14 SET P=14
FOR
SET $PIECE(BGPX,U,P)="Previous"
SET P=P+9
IF P>(BGPEC-5)
QUIT
+15 SET P=17
FOR
SET $PIECE(BGPX,U,P)="Baseline"
SET P=P+9
IF P>(BGPEC+1)
QUIT
+16 WRITE BGPX,!
+17 KILL BGPX
+18 DO SETHDR
+19 SET P=11
FOR
SET $PIECE(BGPX,U,P)="Num"
SET P=P+3
IF P>(BGPEC-2)
QUIT
+20 SET P=12
FOR
SET $PIECE(BGPX,U,P)="Den"
SET P=P+3
IF P>(BGPEC-1)
QUIT
+21 SET P=13
FOR
SET $PIECE(BGPX,U,P)="%"
SET P=P+3
IF P>BGPEC
QUIT
+22 WRITE BGPX,!
+23 KILL BGPX
+24 SET BGPX=0
FOR
SET BGPX=$ORDER(BGPEI2(BGPX))
IF BGPX'=+BGPX
QUIT
WRITE BGPEI2(BGPX),!
Q2 ;
+1 KILL BGPEI2
+2 DO ^%ZISC
Q3 ;
+1 DO GNT3^BGP8UTLC
+2 QUIT
GS ;EP
+1 KILL ^TMP($JOB)
+2 LOCK +^BGPDATA:300
IF '$TEST
IF '$DATA(ZTQUEUED)
WRITE "Unable to lock global"
QUIT
+3 ;NOTE: Kill of unscripted global. Export to area. Using standard name.
+4 SET BGPENDN=$SELECT($PIECE(^BGPSITE(DUZ(2),0),U,11)=0:88887,1:99998)
+5 KILL ^BGPDATA
SET X=""
SET C=0
FOR
SET X=$ORDER(^BGPGPDCR(BGPRPT,X))
IF X'=+X!(X>BGPENDN)
QUIT
Begin DoDot:1
+6 IF $GET(^BGPGPDCR(BGPRPT,X))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",8)=^BGPGPDCR(BGPRPT,X)
+7 SET X2=""
FOR
SET X2=$ORDER(^BGPGPDCR(BGPRPT,X,X2))
IF X2'=+X2
QUIT
Begin DoDot:2
+8 IF $GET(^BGPGPDCR(BGPRPT,X,X2))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",8)=^BGPGPDCR(BGPRPT,X,X2)
+9 SET X3=""
FOR
SET X3=$ORDER(^BGPGPDCR(BGPRPT,X,X2,X3))
IF X3'=+X3
QUIT
Begin DoDot:3
+10 IF $GET(^BGPGPDCR(BGPRPT,X,X2,X3))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
SET $PIECE(^BGPDATA(C),"|",8)=^BGPGPDCR(BGPRPT,X,X2,X3)
+11 SET X4=""
FOR
SET X4=$ORDER(^BGPGPDCR(BGPRPT,X,X2,X3,X4))
IF X4'=+X4
QUIT
Begin DoDot:4
+12 IF $GET(^BGPGPDCR(BGPRPT,X,X2,X3,X4))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
SET $PIECE(^BGPDATA(C),"|",4)=X4
SET $PIECE(^BGPDATA(C),"|",8)=^BGPGPDCR(BGPRPT,X,X2,X3,X4)
+13 SET X5=""
FOR
SET X5=$ORDER(^BGPGPDCR(BGPRPT,X,X2,X3,X4,X5))
IF X5'=+X5
QUIT
Begin DoDot:5
+14 IF $GET(^BGPGPDCR(BGPRPT,X,X2,X3,X4,X5))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
+15 SET $PIECE(^BGPDATA(C),"|",4)=X4
SET $PIECE(^BGPDATA(C),"|",5)=X5
SET $PIECE(^BGPDATA(C),"|",8)=^BGPGPDCR(BGPRPT,X,X2,X3,X4,X5)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 SET X=0
FOR
SET X=$ORDER(^BGPDATA(X))
IF X'=+X
QUIT
SET ^BGPDATA(X)="BGPGPDCR"_"|"_^BGPDATA(X)
PRGS ;
+1 SET S=C+1
SET X=""
FOR
SET X=$ORDER(^BGPGPDPR(BGPRPT,X))
IF X'=+X!(X>99998)
QUIT
Begin DoDot:1
+2 IF $GET(^BGPGPDPR(BGPRPT,X))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",8)=^BGPGPDPR(BGPRPT,X)
+3 SET X2=""
FOR
SET X2=$ORDER(^BGPGPDPR(BGPRPT,X,X2))
IF X2'=+X2
QUIT
Begin DoDot:2
+4 IF $GET(^BGPGPDPR(BGPRPT,X,X2))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",8)=^BGPGPDPR(BGPRPT,X,X2)
+5 SET X3=""
FOR
SET X3=$ORDER(^BGPGPDPR(BGPRPT,X,X2,X3))
IF X3'=+X3
QUIT
Begin DoDot:3
+6 IF $GET(^BGPGPDPR(BGPRPT,X,X2,X3))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
SET $PIECE(^BGPDATA(C),"|",8)=^BGPGPDPR(BGPRPT,X,X2,X3)
+7 SET X4=""
FOR
SET X4=$ORDER(^BGPGPDPR(BGPRPT,X,X2,X3,X4))
IF X4'=+X4
QUIT
Begin DoDot:4
+8 IF $GET(^BGPGPDPR(BGPRPT,X,X2,X3,X4))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
SET $PIECE(^BGPDATA(C),"|",4)=X4
SET $PIECE(^BGPDATA(C),"|",8)=^BGPGPDPR(BGPRPT,X,X2,X3,X4)
+9 SET X5=""
FOR
SET X5=$ORDER(^BGPGPDPR(BGPRPT,X,X2,X3,X4,X5))
IF X5'=+X5
QUIT
Begin DoDot:5
+10 IF $GET(^BGPGPDPR(BGPRPT,X,X2,X3,X4,X5))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
+11 SET $PIECE(^BGPDATA(C),"|",4)=X4
SET $PIECE(^BGPDATA(C),"|",5)=X5
SET $PIECE(^BGPDATA(C),"|",8)=^BGPGPDPR(BGPRPT,X,X2,X3,X4,X5)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+12 SET X=S-1
FOR
SET X=$ORDER(^BGPDATA(X))
IF X'=+X
QUIT
SET ^BGPDATA(X)="BGPGPDPR"_"|"_^BGPDATA(X)
BLGS ;
+1 SET S=C+1
SET X=""
FOR
SET X=$ORDER(^BGPGPDBR(BGPRPT,X))
IF X'=+X!(X>99998)
QUIT
Begin DoDot:1
+2 IF $GET(^BGPGPDBR(BGPRPT,X))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",8)=^BGPGPDBR(BGPRPT,X)
+3 SET X2=""
FOR
SET X2=$ORDER(^BGPGPDBR(BGPRPT,X,X2))
IF X2'=+X2
QUIT
Begin DoDot:2
+4 IF $GET(^BGPGPDBR(BGPRPT,X,X2))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",8)=^BGPGPDBR(BGPRPT,X,X2)
+5 SET X3=""
FOR
SET X3=$ORDER(^BGPGPDBR(BGPRPT,X,X2,X3))
IF X3'=+X3
QUIT
Begin DoDot:3
+6 IF $GET(^BGPGPDBR(BGPRPT,X,X2,X3))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
SET $PIECE(^BGPDATA(C),"|",8)=^BGPGPDBR(BGPRPT,X,X2,X3)
+7 SET X4=""
FOR
SET X4=$ORDER(^BGPGPDBR(BGPRPT,X,X2,X3,X4))
IF X4'=+X4
QUIT
Begin DoDot:4
+8 IF $GET(^BGPGPDBR(BGPRPT,X,X2,X3,X4))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
SET $PIECE(^BGPDATA(C),"|",4)=X4
SET $PIECE(^BGPDATA(C),"|",8)=^BGPGPDBR(BGPRPT,X,X2,X3,X4)
+9 SET X5=""
FOR
SET X5=$ORDER(^BGPGPDBR(BGPRPT,X,X2,X3,X4,X5))
IF X5'=+X5
QUIT
Begin DoDot:5
+10 IF $GET(^BGPGPDBR(BGPRPT,X,X2,X3,X4,X5))]""
SET C=C+1
SET $PIECE(^BGPDATA(C),"|")=X
SET $PIECE(^BGPDATA(C),"|",2)=X2
SET $PIECE(^BGPDATA(C),"|",3)=X3
+11 SET $PIECE(^BGPDATA(C),"|",4)=X4
SET $PIECE(^BGPDATA(C),"|",5)=X5
SET $PIECE(^BGPDATA(C),"|",8)=^BGPGPDBR(BGPRPT,X,X2,X3,X4,X5)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+12 SET X=S-1
FOR
SET X=$ORDER(^BGPDATA(X))
IF X'=+X
QUIT
SET ^BGPDATA(X)="BGPGPDBR"_"|"_^BGPDATA(X)
+13 ;AUTO
IF $GET(BGPAMEX)
DO AUTOEX^BGP8AUEX
QUIT
+14 NEW XBGL
SET XBGL="BGPDATA"
+15 SET F="BG"_$$FV^BGP8BAN()_$PIECE(^AUTTLOC(DUZ(2),0),U,10)_"."_$SELECT(BGPRTYPE=7:"ONM",1:"")_BGPRPT
+16 NEW XBFN,XBMED,XBF,XBFLT
+17 SET XBMED="F"
SET XBFN=F
SET XBTLE="SAVE OF CRS DATA BY - "_$PIECE(^VA(200,DUZ,0),U)
SET XBF=0
SET XBFLT=1
+18 SET XBUF=BGPUF
DO ^XBGSAVE
+19 LOCK -^BGPDATA
+20 ;NOTE: kill of unsubscripted global for use in export to area.
KILL ^TMP($JOB),^BGPDATA
+21 QUIT
REPORT ;EP
+1 SET BGPRPT=""
SET BGPERR=""
+2 ;3 files must have the same ien
+3 LOCK +^BGPGPDCR:30
IF '$TEST
SET BGPERR="Unable to lock global."
GOTO REPORTX
+4 LOCK +^BGPGPDPR:30
IF '$TEST
SET BGPERR="Unable to lock global."
GOTO REPORTX
+5 LOCK +^BGPGPDBR:30
IF '$TEST
SET BGPERR="Unable to lock global."
GOTO REPORTX
+6 DO GETIEN
+7 IF 'BGPIEN
SET BGPERR="Error in control files!"
SET BGPRPT=""
GOTO REPORTX
+8 SET DINUM=BGPIEN
+9 IF $GET(BGPNPL)
SET BGPRTYPE=4
+10 SET BGPR12=$SELECT($GET(BGPYGPU):9,1:BGPRTYPE)
+11 KILL DIC
SET X=BGPBD
SET DIC(0)="L"
SET DIC="^BGPGPDCR("
SET DLAYGO=90560.03
SET DIADD=1
SET DIC("DR")=".02////"_BGPED_";.03////"_BGPPBD_";.04////"_BGPPED_";.05////"_BGPBBD_";.06////"_BGPBED_";.07////"_$GET(BGPPER)_";.08////"_$GET(BGPQTR)
+12 SET DIC("DR")=DIC("DR")_";.09////"_$PIECE(^AUTTLOC(DUZ(2),0),U,10)_";.11////"_$EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.12////"_BGPR12_";.13////"_DT_";.14////"_BGPBEN_";.15////"_...
... $PIECE($GET(^AUTTLOC(DUZ(2),1)),U,3)_";.16///"_$PIECE(^BGPSITE(DUZ(2),0),U,4)
+13 SET DIC("DR")=DIC("DR")_";.17///"_$PIECE(^BGPSITE(DUZ(2),0),U,6)_";.18///"_$SELECT($GET(BGPTAXI):$PIECE(^ATXAX(BGPTAXI,0),U),1:"")_";.19///"_$PIECE(^BGPSITE(DUZ(2),0),U,13)_$SELECT($GET(BGPDESGP):";.2///1",1:"")_";.21///"_$$VER^BGP8BAN()
+14 IF $GET(BGPCOMMI)
SET DIC("DR")=DIC("DR")_";.22///"_$PIECE(^AUTTCOM(BGPCOMMI,0),U)
+15 DO ^DIC
KILL DIC,DA,DR,DIADD,DLAYGO
IF Y=-1
SET BGPERR="UNABLE TO CREATE REPORT FILE ENTRY!"
SET BGPQUIT=1
GOTO REPORTX
+16 SET BGPRPT=+Y
+17 KILL DIC
SET X=BGPBD
SET DIC(0)="L"
SET DIC="^BGPGPDPR("
SET DLAYGO=90560.04
SET DIADD=1
SET DIC("DR")=".02////"_BGPED_";.03////"_BGPPBD_";.04////"_BGPPED_";.05////"_BGPBBD_";.06////"_BGPBED_";.07////"_$GET(BGPPER)_";.08////"_$GET(BGPQTR)
+18 SET DIC("DR")=DIC("DR")_";.09////"_$PIECE(^AUTTLOC(DUZ(2),0),U,10)_";.11////"_$EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.12////"_BGPR12_";.13////"_DT_";.14////"_BGPBEN_";.15////"_...
... $PIECE($GET(^AUTTLOC(DUZ(2),1)),U,3)_";.16///"_$PIECE(^BGPSITE(DUZ(2),0),U,4)
+19 SET DIC("DR")=DIC("DR")_";.17///"_$PIECE(^BGPSITE(DUZ(2),0),U,6)_";.18///"_$SELECT($GET(BGPTAXI):$PIECE(^ATXAX(BGPTAXI,0),U),1:"")_";.19///"_$PIECE(^BGPSITE(DUZ(2),0),U,13)_";.21///"_$$VER^BGP8BAN()
+20 IF $GET(BGPCOMMI)
SET DIC("DR")=DIC("DR")_";.22///"_$PIECE(^AUTTCOM(BGPCOMMI,0),U)
+21 SET DINUM=BGPRPT
DO ^DIC
KILL DIC,DA,DR,DIADD,DLAYGO,DINUM
IF Y=-1
SET BGPERR="UNABLE TO CREATE REPORT FILE ENTRY!"
SET BGPQUIT=1
GOTO REPORTX
+22 SET BGPRPTP=+Y
+23 KILL DIC
SET X=BGPBD
SET DIC(0)="L"
SET DIC="^BGPGPDBR("
SET DLAYGO=90560.05
SET DIADD=1
SET DIC("DR")=".02////"_BGPED_";.03////"_BGPPBD_";.04////"_BGPPED_";.05////"_BGPBBD_";.06////"_BGPBED_";.07////"_$GET(BGPPER)_";.08////"_$GET(BGPQTR)
+24 SET DIC("DR")=DIC("DR")_";.09////"_$PIECE(^AUTTLOC(DUZ(2),0),U,10)_";.11////"_$EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),1,4)_";.12////"_BGPR12_";.13////"_DT_";.14////"_BGPBEN_";.15////"_...
... $PIECE($GET(^AUTTLOC(DUZ(2),1)),U,3)_";.16///"_$PIECE(^BGPSITE(DUZ(2),0),U,4)
+25 SET DIC("DR")=DIC("DR")_";.17///"_$PIECE(^BGPSITE(DUZ(2),0),U,6)_";.18///"_$SELECT($GET(BGPTAXI):$PIECE(^ATXAX(BGPTAXI,0),U),1:"")_";.19///"_$PIECE(^BGPSITE(DUZ(2),0),U,13)_";.21///"_$$VER^BGP8BAN()
+26 IF $GET(BGPCOMMI)
SET DIC("DR")=DIC("DR")_";.22///"_$PIECE(^AUTTCOM(BGPCOMMI,0),U)
+27 SET DINUM=BGPRPT
DO ^DIC
KILL DIC,DA,DR,DIADD,DLAYGO
IF Y=-1
SET BGPERR="UNABLE TO CREATE REPORT FILE ENTRY!"
SET BGPQUIT=1
GOTO REPORTX
+28 SET BGPRPTB=+Y
+29 ;
+30 KILL ^BGPGPDCR(BGPRPT,9999)
+31 SET C=0
SET X=""
FOR
SET X=$ORDER(BGPTAX(X))
IF X=""
QUIT
SET C=C+1
SET ^BGPGPDCR(BGPRPT,9999,C,0)=X
SET ^BGPGPDCR(BGPRPT,9999,"B",X,C)=""
+32 SET ^BGPGPDCR(BGPRPT,9999,0)="^90560.12999A^"_C_"^"_C
+33 SET ^BGPGPDCR(BGPRPT,99999,0)="^90560.129999A^0^0"
+34 SET ^BGPGPDPR(BGPRPT,99999,0)="^90560.139999A^0^0"
+35 SET ^BGPGPDBR(BGPRPT,99999,0)="^90560.149999A^0^0"
REPORTX ;
+1 IF BGPERR]""
WRITE !!,BGPERR
+2 IF $GET(BGPNPL)
SET BGPRTYPE=$SELECT($GET(BGPONMR):7,1:1)
+3 DO ^XBFMK
+4 KILL DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM
+5 LOCK -^BGPGPDCR
+6 LOCK -^BGPGPDPR
+7 LOCK -^BGPGPDBR
+8 QUIT
GETIEN ;EP - Get next ien available in all 3 files
+1 SET BGPF=90560.03
DO ENT
+2 SET BGPF=90560.04
DO ENT
+3 SET BGPF=90560.05
DO ENT
+4 SET BGPIEN=$PIECE(^BGPGPDCR(0),U,3)+1
S IF $DATA(^BGPGPDPR(BGPIEN))!($DATA(^BGPGPDBR(BGPIEN)))
SET BGPIEN=BGPIEN+1
GOTO S
+1 QUIT
+2 ;
ENT ;
+1 NEW GBL,NXT,CTR,XBHI,XBX,XBY,ANS
+2 SET GBL=^DIC(BGPF,0,"GL")
+3 SET GBL=GBL_"NXT)"
+4 SET (XBHI,NXT,CTR)=0
+5 ;W:'(CTR#50) "."
FOR L=0:0
SET NXT=$ORDER(@(GBL))
IF NXT'=+NXT
QUIT
SET XBHI=NXT
SET CTR=CTR+1
+6 SET NXT=""
SET XBX=$ORDER(@(GBL))
SET XBX=^(0)
SET XBY=$PIECE(XBX,U,4)
SET XBX=$PIECE(XBX,U,3)
+7 SET NXT=0
SET $PIECE(@(GBL),U,3)=XBHI
SET $PIECE(^(0),U,4)=CTR
+8 ;
EOJ ;
+1 KILL ANS,XBHI,XBX,XBY,CTR,DIC,FILE,GBL,L,NXT,BGPF
+2 QUIT
+3 ;
LZERO(V,L) ;EP
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V="0"_V
+3 QUIT V
RZERO(V,L) ;EP
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=V_"0"
+3 QUIT V
XTMP(N,D) ;EP
+1 IF $GET(N)=""
QUIT
+2 SET ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_$GET(D)
+3 QUIT
