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

BGP0UTL.m

Go to the documentation of this file. 
  1. BGP0UTL ; IHS/CMI/LAB - 27 Apr 2008 11:01 PM 30 Aug 2008 10:16 AM 30 Jun 2009 4:58 PM 05 Aug 2010 11:40 AM ; 
  1.  ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
  1.  ;
  1. VER() ;EP
  1.  Q "CRS 2010 Version 10.0 Patch 1"  ;cmi/maw mod 7/9/08
  1. STMP ;EP
  1.  Q:BGPTIME'=1
  1.  I BGPLIST="P",$P(^AUPNPAT(DFN,0),U,14)'=BGPLPRV Q
  1.  X ^BGPINDT(BGPIC,2) Q:'$T
  1.  S BGPLIST(BGPIC)=$G(BGPLIST(BGPIC))+1
  1.  S ^XTMP("BGP0D",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),BGPAGEB,DFN)=$G(BGPVALUE)
  1.  Q
  1. D(D) ;EP
  1.  I D="" Q ""
  1.  Q (1700+$E(D,1,3))_$E(D,4,5)_$E(D,6,7)_$S($P(D,".",2)]"":$P(D,".",2),1:"")
  1. JRNL ;EP
  1.  N (DT,U,ZTQUEUED) S %=$$NOJOURN^ZIBGCHAR("BGPGPDCT"),%=$$NOJOURN^ZIBGCHAR("BGPGPDPT"),%=$$NOJOURN^ZIBGCHAR("BGPGPDBT"),%=$$NOJOURN^ZIBGCHAR("BGPHEDCT"),%=$$NOJOURN^ZIBGCHAR("BGPHEDPT"),%=$$NOJOURN^ZIBGCHAR("BGPHEDBT")
  1.  S %=$$NOJOURN^ZIBGCHAR("BGPDATA"),%=$$NOJOURN^ZIBGCHAR("BGPGUI")
  1.  S %=$$NOJOURN^ZIBGCHAR("BGPELDCT"),%=$$NOJOURN^ZIBGCHAR("BGPELDPT"),%=$$NOJOURN^ZIBGCHAR("BGPELDBT")
  1.  S %=$$NOJOURN^ZIBGCHAR("BGPEOCT"),%=$$NOJOURN^ZIBGCHAR("BGPEOPT"),%=$$NOJOURN^ZIBGCHAR("BGPEOBT")
  1.  S %=$$NOJOURN^ZIBGCHAR("BGPXPT")
  1.  Q
  1. DATE(D) ;EP
  1.  I D="" Q ""
  1.  Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
  1.  ;
  1. EDT(D) ;EP
  1.  I D="" Q ""
  1.  Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))
  1.  ;
  1. SETHDR ;
  1.  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"
  1.  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"
  1.  Q
  1. ONN1 ;EP
  1.  K BGPEXCT
  1.  S Y=$$OPEN^%ZISH(BGPUF,BGPFONN1,"W")
  1.  I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file." Q
  1.  U IO
  1.  S BGPP=0,BGPY=$O(^BGPCTRL("B","2010",0)),BGPX="",BGPEC=$P(^BGPCTRL(BGPY,0),U,2)
  1.  F  S BGPP=$O(^BGPCTRL(BGPY,36,BGPP)) Q:BGPP'=+BGPP  D
  1.  .S BGPPP1=$P(^BGPCTRL(BGPY,36,BGPP,0),U,1)
  1.  .S BGPZ=$P(^BGPCTRL(BGPY,36,BGPP,0),U,2)
  1.  .S $P(BGPX,U,BGPPP1)=BGPZ
  1.  W BGPX,!
  1.  K BGPX
  1.  S BGPX="" S P=11 F  S $P(BGPX,U,P)="Current",P=P+9 Q:P>(BGPEC-8)
  1.  S P=14 F  S $P(BGPX,U,P)="Previous",P=P+9 Q:P>(BGPEC-5)
  1.  S P=17 F  S $P(BGPX,U,P)="Baseline",P=P+9 Q:P>(BGPEC+1)
  1.  W BGPX,!
  1.  K BGPX
  1.  D SETHDR
  1.  S P=11 F  S $P(BGPX,U,P)="Num",P=P+3 Q:P>(BGPEC-2)
  1.  S P=12 F  S $P(BGPX,U,P)="Den",P=P+3 Q:P>(BGPEC-1)
  1.  S P=13 F  S $P(BGPX,U,P)="%",P=P+3 Q:P>BGPEC
  1.  W BGPX,!
  1.  S BGPX=0 F  S BGPX=$O(BGPONN1(BGPX)) Q:BGPX'=+BGPX  W BGPONN1(BGPX),!
  1.  K BGPONN1
  1.  D ^%ZISC
  1. ONN2 ;
  1.  K BGPEXCT
  1.  S Y=$$OPEN^%ZISH(BGPUF,BGPFONN2,"W")
  1.  I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file." Q
  1.  U IO
  1.  S BGPP=0,BGPY=$O(^BGPCTRL("B","2010",0)),BGPX="",BGPEC=$P(^BGPCTRL(BGPY,0),U,3)
  1.  F  S BGPP=$O(^BGPCTRL(BGPY,37,BGPP)) Q:BGPP'=+BGPP  D
  1.  .S BGPPP1=$P(^BGPCTRL(BGPY,37,BGPP,0),U,1)
  1.  .S BGPZ=$P(^BGPCTRL(BGPY,37,BGPP,0),U,2)
  1.  .S $P(BGPX,U,BGPPP1)=BGPZ
  1.  W BGPX,!
  1.  K BGPX
  1.  S BGPX="" S P=11 F  S $P(BGPX,U,P)="Current",P=P+9 Q:P>(BGPEC-8)
  1.  S P=14 F  S $P(BGPX,U,P)="Previous",P=P+9 Q:P>(BGPEC-5)
  1.  S P=17 F  S $P(BGPX,U,P)="Baseline",P=P+9 Q:P>(BGPEC+1)
  1.  W BGPX,!
  1.  K BGPX
  1.  D SETHDR
  1.  S P=11 F  S $P(BGPX,U,P)="Num",P=P+3 Q:P>(BGPEC-2)
  1.  S P=12 F  S $P(BGPX,U,P)="Den",P=P+3 Q:P>(BGPEC-1)
  1.  S P=13 F  S $P(BGPX,U,P)="%",P=P+3 Q:P>BGPEC
  1.  W BGPX,!
  1.  S BGPX=0 F  S BGPX=$O(BGPONN2(BGPX)) Q:BGPX'=+BGPX  W BGPONN2(BGPX),!
  1.  K BGPONN2
  1. ONN3 ;
  1.  K BGPEXCT
  1.  S Y=$$OPEN^%ZISH(BGPUF,BGPFONN3,"W")
  1.  I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file." Q
  1.  U IO
  1.  S BGPP=0,BGPY=$O(^BGPCTRL("B","2010",0)),BGPX="",BGPEC=$P(^BGPCTRL(BGPY,0),U,21)
  1.  F  S BGPP=$O(^BGPCTRL(BGPY,45,BGPP)) Q:BGPP'=+BGPP  D
  1.  .S BGPPP1=$P(^BGPCTRL(BGPY,45,BGPP,0),U,1)
  1.  .S BGPZ=$P(^BGPCTRL(BGPY,45,BGPP,0),U,2)
  1.  .S $P(BGPX,U,BGPPP1)=BGPZ
  1.  W BGPX,!
  1.  K BGPX
  1.  S BGPX="" S P=11 F  S $P(BGPX,U,P)="Current",P=P+9 Q:P>(BGPEC-8)
  1.  S P=14 F  S $P(BGPX,U,P)="Previous",P=P+9 Q:P>(BGPEC-5)
  1.  S P=17 F  S $P(BGPX,U,P)="Baseline",P=P+9 Q:P>(BGPEC+1)
  1.  W BGPX,!
  1.  K BGPX
  1.  D SETHDR
  1.  S P=11 F  S $P(BGPX,U,P)="Num",P=P+3 Q:P>(BGPEC-2)
  1.  S P=12 F  S $P(BGPX,U,P)="Den",P=P+3 Q:P>(BGPEC-1)
  1.  S P=13 F  S $P(BGPX,U,P)="%",P=P+3 Q:P>BGPEC
  1.  W BGPX,!
  1.  S BGPX=0 F  S BGPX=$O(BGPONN3(BGPX)) Q:BGPX'=+BGPX  W BGPONN3(BGPX),!
  1.  K BGPONN3
  1. ONNC D ^%ZISC  ;close host file
  1.  Q
  1. GNT1 ;EP - area export file
  1.  K BGPEXCT
  1.  I '$G(BGPAREAA) G Q1
  1.  S Y=$$OPEN^%ZISH(BGPUF,BGPFGNT1,"W")
  1.  I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file." Q
  1.  U IO
  1.  S BGPP=0,BGPY=$O(^BGPCTRL("B","2010",0)),BGPX="",BGPEC=$P(^BGPCTRL(BGPY,0),U,4)
  1.  F  S BGPP=$O(^BGPCTRL(BGPY,38,BGPP)) Q:BGPP'=+BGPP  D
  1.  .S BGPPP1=$P(^BGPCTRL(BGPY,38,BGPP,0),U,1)
  1.  .S BGPZ=$P(^BGPCTRL(BGPY,38,BGPP,0),U,2)
  1.  .S $P(BGPX,U,BGPPP1)=BGPZ
  1.  W BGPX,!
  1.  K BGPX
  1.  S BGPX="" S P=11 F  S $P(BGPX,U,P)="Current",P=P+9 Q:P>(BGPEC-8)
  1.  S P=14 F  S $P(BGPX,U,P)="Previous",P=P+9 Q:P>(BGPEC-5)
  1.  S P=17 F  S $P(BGPX,U,P)="Baseline",P=P+9 Q:P>(BGPEC+1)
  1.  W BGPX,!
  1.  K BGPX
  1.  D SETHDR
  1.  S P=11 F  S $P(BGPX,U,P)="Num",P=P+3 Q:P>(BGPEC-2)
  1.  S P=12 F  S $P(BGPX,U,P)="Den",P=P+3 Q:P>(BGPEC-1)
  1.  S P=13 F  S $P(BGPX,U,P)="%",P=P+3 Q:P>BGPEC
  1.  W BGPX,!
  1.  K BGPX
  1.  S BGPX=0 F  S BGPX=$O(BGPEI(BGPX)) Q:BGPX'=+BGPX  W BGPEI(BGPX),!
  1.  D ^%ZISC
  1. Q1 ;
  1.  K BGPEI
  1. GNT2 ;
  1.  K BGPEXCT
  1.  I '$G(BGPAREAA) G Q2
  1.  S Y=$$OPEN^%ZISH(BGPUF,BGPFGNT2,"W")
  1.  I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file." Q
  1.  U IO
  1.  S BGPP=0,BGPY=$O(^BGPCTRL("B","2010",0)),BGPX="",BGPEC=$P(^BGPCTRL(BGPY,0),U,16)
  1.  F  S BGPP=$O(^BGPCTRL(BGPY,40,BGPP)) Q:BGPP'=+BGPP  D
  1.  .S BGPPP1=$P(^BGPCTRL(BGPY,40,BGPP,0),U,1)
  1.  .S BGPZ=$P(^BGPCTRL(BGPY,40,BGPP,0),U,2)
  1.  .S $P(BGPX,U,BGPPP1)=BGPZ
  1.  W BGPX,!
  1.  K BGPX
  1.  S BGPX="" S P=11 F  S $P(BGPX,U,P)="Current",P=P+9 Q:P>(BGPEC-8)
  1.  S P=14 F  S $P(BGPX,U,P)="Previous",P=P+9 Q:P>(BGPEC-5)
  1.  S P=17 F  S $P(BGPX,U,P)="Baseline",P=P+9 Q:P>(BGPEC+1)
  1.  W BGPX,!
  1.  K BGPX
  1.  D SETHDR
  1.  S P=11 F  S $P(BGPX,U,P)="Num",P=P+3 Q:P>(BGPEC-2)
  1.  S P=12 F  S $P(BGPX,U,P)="Den",P=P+3 Q:P>(BGPEC-1)
  1.  S P=13 F  S $P(BGPX,U,P)="%",P=P+3 Q:P>BGPEC
  1.  W BGPX,!
  1.  K BGPX
  1.  S BGPX=0 F  S BGPX=$O(BGPEI2(BGPX)) Q:BGPX'=+BGPX  W BGPEI2(BGPX),!
  1. Q2 ;
  1.  K BGPEI2
  1.  D ^%ZISC
  1. Q3 ;
  1.  D DEV^BGP0UTLC
  1.  Q
  1. GS ;EP
  1.  K ^TMP($J)
  1.  ;I $P($G(^BGPSITE(DUZ(2),0)),U,3)="N" Q
  1.  L +^BGPDATA:300 E  W:'$D(ZTQUEUED) "Unable to lock global" Q
  1.  ;NOTE:  Kill of unscripted global.  Export to area.  Using standard name.
  1.  S BGPENDN=$S($P(^BGPSITE(DUZ(2),0),U,11)=0:88887,1:99998)
  1.  K ^BGPDATA S X="",C=0 F  S X=$O(^BGPGPDCT(BGPRPT,X)) Q:X'=+X!(X>BGPENDN)  D
  1.  .I $G(^BGPGPDCT(BGPRPT,X))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",8)=^BGPGPDCT(BGPRPT,X)
  1.  .S X2="" F  S X2=$O(^BGPGPDCT(BGPRPT,X,X2)) Q:X2'=+X2  D
  1.  ..I $G(^BGPGPDCT(BGPRPT,X,X2))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",8)=^BGPGPDCT(BGPRPT,X,X2)
  1.  ..S X3="" F  S X3=$O(^BGPGPDCT(BGPRPT,X,X2,X3)) Q:X3'=+X3  D
  1.  ...I $G(^BGPGPDCT(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)=^BGPGPDCT(BGPRPT,X,X2,X3)
  1.  ...S X4="" F  S X4=$O(^BGPGPDCT(BGPRPT,X,X2,X3,X4)) Q:X4'=+X4  D
  1.  ....I $G(^BGPGPDCT(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)=^BGPGPDCT(BGPRPT,X,X2,X3,X4)
  1.  ....S X5="" F  S X5=$O(^BGPGPDCT(BGPRPT,X,X2,X3,X4,X5)) Q:X5'=+X5  D
  1.  .....I $G(^BGPGPDCT(BGPRPT,X,X2,X3,X4,X5))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3
  1.  .....S $P(^BGPDATA(C),"|",4)=X4,$P(^BGPDATA(C),"|",5)=X5,$P(^BGPDATA(C),"|",8)=^BGPGPDCT(BGPRPT,X,X2,X3,X4,X5)
  1.  S X=0 F  S X=$O(^BGPDATA(X)) Q:X'=+X  S ^BGPDATA(X)="BGPGPDCT"_"|"_^BGPDATA(X)
  1. PRGS ;
  1.  S S=C+1,X="" F  S X=$O(^BGPGPDPT(BGPRPT,X)) Q:X'=+X!(X>99998)  D
  1.  .I $G(^BGPGPDPT(BGPRPT,X))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",8)=^BGPGPDPT(BGPRPT,X)
  1.  .S X2="" F  S X2=$O(^BGPGPDPT(BGPRPT,X,X2)) Q:X2'=+X2  D
  1.  ..I $G(^BGPGPDPT(BGPRPT,X,X2))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",8)=^BGPGPDPT(BGPRPT,X,X2)
  1.  ..S X3="" F  S X3=$O(^BGPGPDPT(BGPRPT,X,X2,X3)) Q:X3'=+X3  D
  1.  ...I $G(^BGPGPDPT(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)=^BGPGPDPT(BGPRPT,X,X2,X3)
  1.  ...S X4="" F  S X4=$O(^BGPGPDPT(BGPRPT,X,X2,X3,X4)) Q:X4'=+X4  D
  1.  ....I $G(^BGPGPDPT(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)=^BGPGPDPT(BGPRPT,X,X2,X3,X4)
  1.  ....S X5="" F  S X5=$O(^BGPGPDPT(BGPRPT,X,X2,X3,X4,X5)) Q:X5'=+X5  D
  1.  .....I $G(^BGPGPDPT(BGPRPT,X,X2,X3,X4,X5))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3
  1.  .....S $P(^BGPDATA(C),"|",4)=X4,$P(^BGPDATA(C),"|",5)=X5,$P(^BGPDATA(C),"|",8)=^BGPGPDPT(BGPRPT,X,X2,X3,X4,X5)
  1.  S X=S-1 F  S X=$O(^BGPDATA(X)) Q:X'=+X  S ^BGPDATA(X)="BGPGPDPT"_"|"_^BGPDATA(X)
  1. BLGS ;
  1.  S S=C+1,X="" F  S X=$O(^BGPGPDBT(BGPRPT,X)) Q:X'=+X!(X>99998)  D
  1.  .I $G(^BGPGPDBT(BGPRPT,X))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",8)=^BGPGPDBT(BGPRPT,X)
  1.  .S X2="" F  S X2=$O(^BGPGPDBT(BGPRPT,X,X2)) Q:X2'=+X2  D
  1.  ..I $G(^BGPGPDBT(BGPRPT,X,X2))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",8)=^BGPGPDBT(BGPRPT,X,X2)
  1.  ..S X3="" F  S X3=$O(^BGPGPDBT(BGPRPT,X,X2,X3)) Q:X3'=+X3  D
  1.  ...I $G(^BGPGPDBT(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)=^BGPGPDBT(BGPRPT,X,X2,X3)
  1.  ...S X4="" F  S X4=$O(^BGPGPDBT(BGPRPT,X,X2,X3,X4)) Q:X4'=+X4  D
  1.  ....I $G(^BGPGPDBT(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)=^BGPGPDBT(BGPRPT,X,X2,X3,X4)
  1.  ....S X5="" F  S X5=$O(^BGPGPDBT(BGPRPT,X,X2,X3,X4,X5)) Q:X5'=+X5  D
  1.  .....I $G(^BGPGPDBT(BGPRPT,X,X2,X3,X4,X5))]"" S C=C+1,$P(^BGPDATA(C),"|")=X,$P(^BGPDATA(C),"|",2)=X2,$P(^BGPDATA(C),"|",3)=X3
  1.  .....S $P(^BGPDATA(C),"|",4)=X4,$P(^BGPDATA(C),"|",5)=X5,$P(^BGPDATA(C),"|",8)=^BGPGPDBT(BGPRPT,X,X2,X3,X4,X5)
  1.  S X=S-1 F  S X=$O(^BGPDATA(X)) Q:X'=+X  S ^BGPDATA(X)="BGPGPDBT"_"|"_^BGPDATA(X)
  1.  NEW XBGL S XBGL="BGPDATA"
  1.  S F="BG10"_$P(^AUTTLOC(DUZ(2),0),U,10)_"."_$S(BGPRTYPE=7:"ONM",1:"")_BGPRPT
  1.  NEW XBFN,XBMED,XBF,XBFLT
  1.  S XBMED="F",XBFN=F,XBTLE="SAVE OF CRS DATA BY - "_$P(^VA(200,DUZ,0),U),XBF=0,XBFLT=1
  1.  D ^XBGSAVE
  1.  L -^BGPDATA
  1.  K ^TMP($J),^BGPDATA ;NOTE:  kill of unsubscripted global for use in export to area.
  1.  Q
  1. REPORT ;EP
  1.  S BGPRPT="",BGPERR=""
  1.  I '$D(BGPGUI) W !!
  1.  ;3 files must have the same ien
  1.  L +^BGPGPDCT:30 I '$T S BGPERR="Unable to lock global." G REPORTX
  1.  L +^BGPGPDPT:30 I '$T S BGPERR="Unable to lock global." G REPORTX
  1.  L +^BGPGPDBT:30 I '$T S BGPERR="Unable to lock global." G REPORTX
  1.  D GETIEN
  1.  I 'BGPIEN S BGPERR="Error in control files!" S BGPRPT="" G REPORTX
  1.  S DINUM=BGPIEN
  1.  I $G(BGPNPL) S BGPRTYPE=4
  1.  S BGPR12=$S($G(BGP0GPU):9,1:BGPRTYPE)
  1.  K DIC S X=BGPBD,DIC(0)="L",DIC="^BGPGPDCT(",DLAYGO=90377.03,DIADD=1,DIC("DR")=".02////"_BGPED_";.03////"_BGPPBD_";.04////"_BGPPED_";.05////"_BGPBBD_";.06////"_BGPBED_";.07////"_$G(BGPPER)_";.08////"_$G(BGPQTR)
  1.  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)
  1.  S DIC("DR")=DIC("DR")_";.17///"_$P(^BGPSITE(DUZ(2),0),U,6)_";.18///"_$S($G(BGPTAXI):$P(^ATXAX(BGPTAXI,0),U),1:"")
  1.  D ^DIC K DIC,DA,DR,DIADD,DLAYGO I Y=-1 S BGPERR="UNABLE TO CREATE REPORT FILE ENTRY!" S BGPQUIT=1 G REPORTX
  1.  S BGPRPT=+Y
  1.  K DIC S X=BGPBD,DIC(0)="L",DIC="^BGPGPDPT(",DLAYGO=90377.04,DIADD=1,DIC("DR")=".02////"_BGPED_";.03////"_BGPPBD_";.04////"_BGPPED_";.05////"_BGPBBD_";.06////"_BGPBED_";.07////"_$G(BGPPER)_";.08////"_$G(BGPQTR)
  1.  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)
  1.  S DIC("DR")=DIC("DR")_";.17///"_$P(^BGPSITE(DUZ(2),0),U,6)_";.18///"_$S($G(BGPTAXI):$P(^ATXAX(BGPTAXI,0),U),1:"")
  1.  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
  1.  S BGPRPTP=+Y
  1.  K DIC S X=BGPBD,DIC(0)="L",DIC="^BGPGPDBT(",DLAYGO=90377.05,DIADD=1,DIC("DR")=".02////"_BGPED_";.03////"_BGPPBD_";.04////"_BGPPED_";.05////"_BGPBBD_";.06////"_BGPBED_";.07////"_$G(BGPPER)_";.08////"_$G(BGPQTR)
  1.  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)
  1.  S DIC("DR")=DIC("DR")_";.17///"_$P(^BGPSITE(DUZ(2),0),U,6)_";.18///"_$S($G(BGPTAXI):$P(^ATXAX(BGPTAXI,0),U),1:"")
  1.  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
  1.  S BGPRPTB=+Y
  1.  ;
  1.  K ^BGPGPDCT(BGPRPT,9999)
  1.  S C=0,X="" F  S X=$O(BGPTAX(X)) Q:X=""  S C=C+1 S ^BGPGPDCT(BGPRPT,9999,C,0)=X,^BGPGPDCT(BGPRPT,9999,"B",X,C)=""
  1.  S ^BGPGPDCT(BGPRPT,9999,0)="^90377.12999A^"_C_"^"_C
  1.  K ^BGPGPDCT(BGPRPT,1111)
  1.  I $G(BGPMFITI) S C=0,X="" F  S X=$O(^ATXAX(BGPMFITI,21,"B",X)) Q:X=""  S C=C+1,Y=$P($G(^DIC(4,X,0)),U) S ^BGPGPDCT(BGPRPT,1111,C,0)=Y,^BGPGPDCT(BGPRPT,1111,"B",Y,C)=""
  1.  S ^BGPGPDCT(BGPRPT,1111,0)="^90377.031111^"_C_"^"_C
  1.  S ^BGPGPDCT(BGPRPT,99999,0)="^90377.129999A^0^0"
  1.  S ^BGPGPDPT(BGPRPT,99999,0)="^90377.139999A^0^0"
  1.  S ^BGPGPDBT(BGPRPT,99999,0)="^90377.149999A^0^0"
  1. REPORTX ;
  1.  I BGPERR]"" W !!,BGPERR
  1.  I $G(BGPNPL) S BGPRTYPE=$S($G(BGPONMR):7,1:1)
  1.  D ^XBFMK
  1.  K DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM
  1.  L -^BGPGPDCT
  1.  L -^BGPGPDPT
  1.  L -^BGPGPDBT
  1.  Q
  1. GETIEN ;EP - Get next ien available in all 3 files
  1.  S BGPF=90377.03 D ENT
  1.  S BGPF=90377.04 D ENT
  1.  S BGPF=90377.05 D ENT
  1.  S BGPIEN=$P(^BGPGPDCT(0),U,3)+1
  1. S I $D(^BGPGPDPT(BGPIEN))!($D(^BGPGPDBT(BGPIEN))) S BGPIEN=BGPIEN+1 G S
  1.  Q
  1.  ;
  1. ENT ;
  1.  NEW GBL,NXT,CTR,XBHI,XBX,XBY,ANS
  1.  S GBL=^DIC(BGPF,0,"GL")
  1.  S GBL=GBL_"NXT)"
  1.  S (XBHI,NXT,CTR)=0
  1.  F L=0:0 S NXT=$O(@(GBL)) Q:NXT'=+NXT  S XBHI=NXT,CTR=CTR+1 ;W:'(CTR#50) "."
  1.  S NXT="",XBX=$O(@(GBL)),XBX=^(0),XBY=$P(XBX,U,4),XBX=$P(XBX,U,3)
  1.  S NXT=0,$P(@(GBL),U,3)=XBHI,$P(^(0),U,4)=CTR
  1.  ;
  1. EOJ ;
  1.  KILL ANS,XBHI,XBX,XBY,CTR,DIC,FILE,GBL,L,NXT,BGPF
  1.  Q
  1.  ;
  1. LZERO(V,L) ;EP
  1.  NEW %,I
  1.  S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
  1.  Q V
  1. RZERO(V,L) ;EP
  1.  NEW %,I
  1.  S %=$L(V),Z=L-% F I=1:1:Z S V=V_"0"
  1.  Q V
  1. XTMP(N,D) ;EP
  1.  Q:$G(N)=""
  1.  S ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_$G(D)
  1.  Q