- 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
