BGP4UTLC ; IHS/CMI/LAB - 27 Apr 2009 11:01 PM 30 Aug 2009 10:16 AM 30 Jun 2010 4:58 PM ;
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
;
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","2014",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
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","2014",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
GNT4 ;
K BGPEXCT
I '$G(BGPAREAA) G Q4
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","2014",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),!
Q4 ;
K BGPEIDV2
D ^%ZISC
GNT5 ;
K BGPEXCT
I '$G(BGPAREAA) G Q5
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","2014",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),!
Q5 ;
K BGPEIDV3
D ^%ZISC
GNT6 ;
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","2014",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),!
Q6 ;
K BGPEIDV4
D ^%ZISC
Q
BGP4UTLC ; IHS/CMI/LAB - 27 Apr 2009 11:01 PM 30 Aug 2009 10:16 AM 30 Jun 2010 4:58 PM ;
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+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","2014",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
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","2014",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
IF P>(BGPEC-2)
QUIT
+21 SET P=12
FOR
SET $PIECE(BGPX,U,P)="Den"
SET P=P+3
IF P>(BGPEC-1)
QUIT
+22 SET P=13
FOR
SET $PIECE(BGPX,U,P)="%"
SET P=P+3
IF P>BGPEC
QUIT
+23 WRITE BGPX,!
+24 KILL BGPX
+25 SET BGPX=0
FOR
SET BGPX=$ORDER(BGPEIDV1(BGPX))
IF BGPX'=+BGPX
QUIT
WRITE BGPEIDV1(BGPX),!
QD3 ;
+1 KILL BGPEIDV1
+2 DO ^%ZISC
GNT4 ;
+1 KILL BGPEXCT
+2 IF '$GET(BGPAREAA)
GOTO Q4
+3 SET Y=$$OPEN^%ZISH(BGPUF,BGPFDEV2,"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","2014",0))
SET BGPX=""
SET BGPEC=$PIECE(^BGPCTRL(BGPY,0),U,23)
+7 FOR
SET BGPP=$ORDER(^BGPCTRL(BGPY,81,BGPP))
IF BGPP'=+BGPP
QUIT
Begin DoDot:1
+8 SET BGPPP1=$PIECE(^BGPCTRL(BGPY,81,BGPP,0),U,1)
+9 SET BGPZ=$PIECE(^BGPCTRL(BGPY,81,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(BGPEIDV2(BGPX))
IF BGPX'=+BGPX
QUIT
WRITE BGPEIDV2(BGPX),!
Q4 ;
+1 KILL BGPEIDV2
+2 DO ^%ZISC
GNT5 ;
+1 KILL BGPEXCT
+2 IF '$GET(BGPAREAA)
GOTO Q5
+3 SET Y=$$OPEN^%ZISH(BGPUF,BGPFDEV3,"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","2014",0))
SET BGPX=""
SET BGPEC=$PIECE(^BGPCTRL(BGPY,0),U,24)
+7 FOR
SET BGPP=$ORDER(^BGPCTRL(BGPY,85,BGPP))
IF BGPP'=+BGPP
QUIT
Begin DoDot:1
+8 SET BGPPP1=$PIECE(^BGPCTRL(BGPY,85,BGPP,0),U,1)
+9 SET BGPZ=$PIECE(^BGPCTRL(BGPY,85,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(BGPEIDV3(BGPX))
IF BGPX'=+BGPX
QUIT
WRITE BGPEIDV3(BGPX),!
Q5 ;
+1 KILL BGPEIDV3
+2 DO ^%ZISC
GNT6 ;
+1 KILL BGPEXCT
+2 IF '$GET(BGPAREAA)
GOTO Q6
+3 SET Y=$$OPEN^%ZISH(BGPUF,BGPFDEV4,"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","2014",0))
SET BGPX=""
SET BGPEC=$PIECE(^BGPCTRL(BGPY,0),U,28)
+7 FOR
SET BGPP=$ORDER(^BGPCTRL(BGPY,851,BGPP))
IF BGPP'=+BGPP
QUIT
Begin DoDot:1
+8 SET BGPPP1=$PIECE(^BGPCTRL(BGPY,851,BGPP,0),U,1)
+9 SET BGPZ=$PIECE(^BGPCTRL(BGPY,851,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(BGPEIDV4(BGPX))
IF BGPX'=+BGPX
QUIT
WRITE BGPEIDV4(BGPX),!
Q6 ;
+1 KILL BGPEIDV4
+2 DO ^%ZISC
+3 QUIT
