BGP8UTLC.m

BGP8UTLC ; IHS/CMI/LAB - UTILITIES ;

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

 ;

 ;

SETHDR ;

 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

GNT3 ;EP - area export file

 K BGPEXCT

 I '$G(BGPAREAA) G Q3

 S Y=$$OPEN^%ZISH(BGPUF,BGPFGNT3,"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,27)

 F  S BGPP=$O(^BGPCTRL(BGPY,97,BGPP)) Q:BGPP'=+BGPP  D

 .S BGPPP1=$P(^BGPCTRL(BGPY,97,BGPP,0),U,1)

 .S BGPZ=$P(^BGPCTRL(BGPY,97,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(BGPEI3(BGPX)) Q:BGPX'=+BGPX  W BGPEI3(BGPX),!

Q3 ;

 K BGPEI3

 D ^%ZISC

 G DEV   ;V18 P1

GNT4 ;

 K BGPEXCT

 I '$G(BGPAREAA) G Q4

 S Y=$$OPEN^%ZISH(BGPUF,BGPFGNT4,"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,29)

 F  S BGPP=$O(^BGPCTRL(BGPY,971,BGPP)) Q:BGPP'=+BGPP  D

 .S BGPPP1=$P(^BGPCTRL(BGPY,971,BGPP,0),U,1)

 .S BGPZ=$P(^BGPCTRL(BGPY,971,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(BGPEI4(BGPX)) Q:BGPX'=+BGPX  W BGPEI4(BGPX),!

Q4 ;

 K BGPEI4

 D ^%ZISC

GNT5 ;

 K BGPEXCT

 I '$G(BGPAREAA) G Q4

 S Y=$$OPEN^%ZISH(BGPUF,BGPFGNT5,"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,31)

 F  S BGPP=$O(^BGPCTRL(BGPY,972,BGPP)) Q:BGPP'=+BGPP  D

 .S BGPPP1=$P(^BGPCTRL(BGPY,972,BGPP,0),U,1)

 .S BGPZ=$P(^BGPCTRL(BGPY,972,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(BGPEI5(BGPX)) Q:BGPX'=+BGPX  W BGPEI5(BGPX),!

Q5 ;

 K BGPEI5

 D ^%ZISC

GNT6 ;

 K BGPEXCT

 I '$G(BGPAREAA) G Q6

 S Y=$$OPEN^%ZISH(BGPUF,BGPFGNT6,"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,32)

 F  S BGPP=$O(^BGPCTRL(BGPY,973,BGPP)) Q:BGPP'=+BGPP  D

 .S BGPPP1=$P(^BGPCTRL(BGPY,973,BGPP,0),U,1)

 .S BGPZ=$P(^BGPCTRL(BGPY,973,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(BGPEI6(BGPX)) Q:BGPX'=+BGPX  W BGPEI6(BGPX),!

Q6 ;

 K BGPEI6

 D ^%ZISC

DEV ;EP - area export file

 ;DEV FILES

 K BGPEXCT

 I '$G(BGPAREAA) G QD3

 S Y=$$OPEN^%ZISH(BGPUF,BGPFDEV1,"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,22)

 F  S BGPP=$O(^BGPCTRL(BGPY,79,BGPP)) Q:BGPP'=+BGPP  D

 .S BGPPP1=$P(^BGPCTRL(BGPY,79,BGPP,0),U,1)

 .S BGPZ=$P(^BGPCTRL(BGPY,79,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(BGPEIDV1(BGPX)) Q:BGPX'=+BGPX  W BGPEIDV1(BGPX),!

QD3 ;

 K BGPEIDV1

 D ^%ZISC

DEV2 ;

 K BGPEXCT

 I '$G(BGPAREAA) G D2

 S Y=$$OPEN^%ZISH(BGPUF,BGPFDEV2,"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,23)

 F  S BGPP=$O(^BGPCTRL(BGPY,81,BGPP)) Q:BGPP'=+BGPP  D

 .S BGPPP1=$P(^BGPCTRL(BGPY,81,BGPP,0),U,1)

 .S BGPZ=$P(^BGPCTRL(BGPY,81,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(BGPEIDV2(BGPX)) Q:BGPX'=+BGPX  W BGPEIDV2(BGPX),!

D2 ;

 K BGPEIDV2

 D ^%ZISC

DEV3 ;

 K BGPEXCT

 I '$G(BGPAREAA) G D3

 S Y=$$OPEN^%ZISH(BGPUF,BGPFDEV3,"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,24)

 F  S BGPP=$O(^BGPCTRL(BGPY,85,BGPP)) Q:BGPP'=+BGPP  D

 .S BGPPP1=$P(^BGPCTRL(BGPY,85,BGPP,0),U,1)

 .S BGPZ=$P(^BGPCTRL(BGPY,85,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(BGPEIDV3(BGPX)) Q:BGPX'=+BGPX  W BGPEIDV3(BGPX),!

D3 ;

 K BGPEIDV3

 D ^%ZISC

DEV4 ;

 K BGPEXCT

 I '$G(BGPAREAA) G Q6

 S Y=$$OPEN^%ZISH(BGPUF,BGPFDEV4,"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,28)

 F  S BGPP=$O(^BGPCTRL(BGPY,851,BGPP)) Q:BGPP'=+BGPP  D

 .S BGPPP1=$P(^BGPCTRL(BGPY,851,BGPP,0),U,1)

 .S BGPZ=$P(^BGPCTRL(BGPY,851,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(BGPEIDV4(BGPX)) Q:BGPX'=+BGPX  W BGPEIDV4(BGPX),!

QD4 ;

 K BGPEIDV4

 D ^%ZISC

 Q

BGP8UTLC  ; IHS/CMI/LAB - UTILITIES ;

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

 +2       ;

 +3       ;

SETHDR    ;

 +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 

GNT3      ;EP - area export file

 +1        KILL BGPEXCT

 +2        IF '$GET(BGPAREAA)

               GOTO Q3

 +3        SET Y=$$OPEN^%ZISH(BGPUF,BGPFGNT3,"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,27)

 +7        FOR 

               SET BGPP=$ORDER(^BGPCTRL(BGPY,97,BGPP))

               IF BGPP'=+BGPP

                   QUIT 

               Begin DoDot:1

 +8                SET BGPPP1=$PIECE(^BGPCTRL(BGPY,97,BGPP,0),U,1)

 +9                SET BGPZ=$PIECE(^BGPCTRL(BGPY,97,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(BGPEI3(BGPX))

               IF BGPX'=+BGPX

                   QUIT 

               WRITE BGPEI3(BGPX),!

Q3        ;

 +1        KILL BGPEI3

 +2        DO ^%ZISC

 +3       ;V18 P1

           GOTO DEV

GNT4      ;

 +1        KILL BGPEXCT

 +2        IF '$GET(BGPAREAA)

               GOTO Q4

 +3        SET Y=$$OPEN^%ZISH(BGPUF,BGPFGNT4,"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,29)

 +7        FOR 

               SET BGPP=$ORDER(^BGPCTRL(BGPY,971,BGPP))

               IF BGPP'=+BGPP

                   QUIT 

               Begin DoDot:1

 +8                SET BGPPP1=$PIECE(^BGPCTRL(BGPY,971,BGPP,0),U,1)

 +9                SET BGPZ=$PIECE(^BGPCTRL(BGPY,971,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(BGPEI4(BGPX))

               IF BGPX'=+BGPX

                   QUIT 

               WRITE BGPEI4(BGPX),!

Q4        ;

 +1        KILL BGPEI4

 +2        DO ^%ZISC

GNT5      ;

 +1        KILL BGPEXCT

 +2        IF '$GET(BGPAREAA)

               GOTO Q4

 +3        SET Y=$$OPEN^%ZISH(BGPUF,BGPFGNT5,"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,31)

 +7        FOR 

               SET BGPP=$ORDER(^BGPCTRL(BGPY,972,BGPP))

               IF BGPP'=+BGPP

                   QUIT 

               Begin DoDot:1

 +8                SET BGPPP1=$PIECE(^BGPCTRL(BGPY,972,BGPP,0),U,1)

 +9                SET BGPZ=$PIECE(^BGPCTRL(BGPY,972,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(BGPEI5(BGPX))

               IF BGPX'=+BGPX

                   QUIT 

               WRITE BGPEI5(BGPX),!

Q5        ;

 +1        KILL BGPEI5

 +2        DO ^%ZISC

GNT6      ;

 +1        KILL BGPEXCT

 +2        IF '$GET(BGPAREAA)

               GOTO Q6

 +3        SET Y=$$OPEN^%ZISH(BGPUF,BGPFGNT6,"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,32)

 +7        FOR 

               SET BGPP=$ORDER(^BGPCTRL(BGPY,973,BGPP))

               IF BGPP'=+BGPP

                   QUIT 

               Begin DoDot:1

 +8                SET BGPPP1=$PIECE(^BGPCTRL(BGPY,973,BGPP,0),U,1)

 +9                SET BGPZ=$PIECE(^BGPCTRL(BGPY,973,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(BGPEI6(BGPX))

               IF BGPX'=+BGPX

                   QUIT 

               WRITE BGPEI6(BGPX),!

Q6        ;

 +1        KILL BGPEI6

 +2        DO ^%ZISC

DEV       ;EP - area export file

 +1       ;DEV FILES

 +2        KILL BGPEXCT

 +3        IF '$GET(BGPAREAA)

               GOTO QD3

 +4        SET Y=$$OPEN^%ZISH(BGPUF,BGPFDEV1,"W")

 +5        IF Y=1

               IF '$DATA(ZTQUEUED)

                   WRITE !!,"Cannot open host file."

               QUIT 

 +6        USE IO

 +7        SET BGPP=0

           SET BGPY=$ORDER(^BGPCTRL("B","2018",0))

           SET BGPX=""

           SET BGPEC=$PIECE(^BGPCTRL(BGPY,0),U,22)

 +8        FOR 

               SET BGPP=$ORDER(^BGPCTRL(BGPY,79,BGPP))

               IF BGPP'=+BGPP

                   QUIT 

               Begin DoDot:1

 +9                SET BGPPP1=$PIECE(^BGPCTRL(BGPY,79,BGPP,0),U,1)

 +10               SET BGPZ=$PIECE(^BGPCTRL(BGPY,79,BGPP,0),U,2)

 +11               SET $PIECE(BGPX,U,BGPPP1)=BGPZ

               End DoDot:1

 +12       WRITE BGPX,!

 +13       KILL BGPX

 +14       SET BGPX=""

           SET P=11

           FOR 

               SET $PIECE(BGPX,U,P)="Current"

               SET P=P+9

               IF P>(BGPEC-8)

                   QUIT 

 +15       SET P=14

           FOR 

               SET $PIECE(BGPX,U,P)="Previous"

               SET P=P+9

               IF P>(BGPEC-5)

                   QUIT 

 +16       SET P=17

           FOR 

               SET $PIECE(BGPX,U,P)="Baseline"

               SET P=P+9

               IF P>(BGPEC+1)

                   QUIT 

 +17       WRITE BGPX,!

 +18       KILL BGPX

 +19       DO SETHDR

 +20       SET P=11

           FOR 

               SET $PIECE(BGPX,U,P)="Num"

               SET P=P+3