BGP9UTLC ; IHS/CMI/LAB - 27 Apr 2007 11:01 PM 30 Aug 2007 10:16 AM 30 Jun 2008 4:58 PM ;
;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
;
;
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","2009",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(BGPEI3(BGPX)) Q:BGPX'=+BGPX W BGPEI3(BGPX),!
Q3 ;
K BGPEI3
D ^%ZISC
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","2009",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(BGPEI4(BGPX)) Q:BGPX'=+BGPX W BGPEI4(BGPX),!
Q4 ;
K BGPEI4
D ^%ZISC
Q
BGP9UTLC ; IHS/CMI/LAB - 27 Apr 2007 11:01 PM 30 Aug 2007 10:16 AM 30 Jun 2008 4:58 PM ;
+1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
+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","2009",0))
SET BGPX=""
SET BGPEC=$PIECE(^BGPCTRL(BGPY,0),U,22)
+7 FOR
SET BGPP=$ORDER(^BGPCTRL(BGPY,79,BGPP))
IF BGPP'=+BGPP
QUIT
Begin DoDot:1
+8 SET BGPPP1=$PIECE(^BGPCTRL(BGPY,79,BGPP,0),U,1)
+9 SET BGPZ=$PIECE(^BGPCTRL(BGPY,79,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
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","2009",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(BGPEI4(BGPX))
IF BGPX'=+BGPX
QUIT
WRITE BGPEI4(BGPX),!
Q4 ;
+1 KILL BGPEI4
+2 DO ^%ZISC
+3 QUIT
