- BGP2UTL3 ; IHS/CMI/LAB - 27 Apr 2009 11:01 PM 30 Aug 2009 10:16 AM 30 Jun 2010 4:58 PM 05 Aug 2012 11:40 AM 26 Mar 2012 2:40 PM ;
- ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
- ;
- ONN4 ;EP
- K BGPEXCT
- S Y=$$OPEN^%ZISH(BGPUF,BGPFONN4,"W")
- I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file." Q
- U IO
- S BGPP=0,BGPY=$O(^BGPCTRL("B","2012",0)),BGPX="",BGPEC=$P(^BGPCTRL(BGPY,0),U,25)
- F S BGPP=$O(^BGPCTRL(BGPY,86,BGPP)) Q:BGPP'=+BGPP D
- .S BGPPP1=$P(^BGPCTRL(BGPY,86,BGPP,0),U,1)
- .S BGPZ=$P(^BGPCTRL(BGPY,86,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^BGP2UTL
- 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,!
- S BGPX=0 F S BGPX=$O(BGPONN4(BGPX)) Q:BGPX'=+BGPX W BGPONN4(BGPX),!
- K BGPONN4
- D ^%ZISC
- ONN5 ;
- K BGPEXCT
- S Y=$$OPEN^%ZISH(BGPUF,BGPFONN5,"W")
- I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file." Q
- U IO
- S BGPP=0,BGPY=$O(^BGPCTRL("B","2012",0)),BGPX="",BGPEC=$P(^BGPCTRL(BGPY,0),U,26)
- F S BGPP=$O(^BGPCTRL(BGPY,87,BGPP)) Q:BGPP'=+BGPP D
- .S BGPPP1=$P(^BGPCTRL(BGPY,87,BGPP,0),U,1)
- .S BGPZ=$P(^BGPCTRL(BGPY,87,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^BGP2UTL
- 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,!
- S BGPX=0 F S BGPX=$O(BGPONN5(BGPX)) Q:BGPX'=+BGPX W BGPONN5(BGPX),!
- K BGPONN5
- ONNC D ^%ZISC ;close host file
- Q
- BGP2UTL3 ; IHS/CMI/LAB - 27 Apr 2009 11:01 PM 30 Aug 2009 10:16 AM 30 Jun 2010 4:58 PM 05 Aug 2012 11:40 AM 26 Mar 2012 2:40 PM ;
- +1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
- +2 ;
- ONN4 ;EP
- +1 KILL BGPEXCT
- +2 SET Y=$$OPEN^%ZISH(BGPUF,BGPFONN4,"W")
- +3 IF Y=1
- IF '$DATA(ZTQUEUED)
- WRITE !!,"Cannot open host file."
- QUIT
- +4 USE IO
- +5 SET BGPP=0
- SET BGPY=$ORDER(^BGPCTRL("B","2012",0))
- SET BGPX=""
- SET BGPEC=$PIECE(^BGPCTRL(BGPY,0),U,25)
- +6 FOR
- SET BGPP=$ORDER(^BGPCTRL(BGPY,86,BGPP))
- IF BGPP'=+BGPP
- QUIT
- Begin DoDot:1
- +7 SET BGPPP1=$PIECE(^BGPCTRL(BGPY,86,BGPP,0),U,1)
- +8 SET BGPZ=$PIECE(^BGPCTRL(BGPY,86,BGPP,0),U,2)
- +9 SET $PIECE(BGPX,U,BGPPP1)=BGPZ
- End DoDot:1
- +10 WRITE BGPX,!
- +11 KILL BGPX
- +12 SET BGPX=""
- SET P=11
- FOR
- SET $PIECE(BGPX,U,P)="Current"
- SET P=P+9
- IF P>(BGPEC-8)
- QUIT
- +13 SET P=14
- FOR
- SET $PIECE(BGPX,U,P)="Previous"
- SET P=P+9
- IF P>(BGPEC-5)
- QUIT
- +14 SET P=17
- FOR
- SET $PIECE(BGPX,U,P)="Baseline"
- SET P=P+9
- IF P>(BGPEC+1)
- QUIT
- +15 WRITE BGPX,!
- +16 KILL BGPX
- +17 DO SETHDR^BGP2UTL
- +18 SET P=11
- FOR
- SET $PIECE(BGPX,U,P)="Num"
- SET P=P+3
- IF P>(BGPEC-2)
- QUIT
- +19 SET P=12
- FOR
- SET $PIECE(BGPX,U,P)="Den"
- SET P=P+3
- IF P>(BGPEC-1)
- QUIT
- +20 SET P=13
- FOR
- SET $PIECE(BGPX,U,P)="%"
- SET P=P+3
- IF P>BGPEC
- QUIT
- +21 WRITE BGPX,!
- +22 SET BGPX=0
- FOR
- SET BGPX=$ORDER(BGPONN4(BGPX))
- IF BGPX'=+BGPX
- QUIT
- WRITE BGPONN4(BGPX),!
- +23 KILL BGPONN4
- +24 DO ^%ZISC
- ONN5 ;
- +1 KILL BGPEXCT
- +2 SET Y=$$OPEN^%ZISH(BGPUF,BGPFONN5,"W")
- +3 IF Y=1
- IF '$DATA(ZTQUEUED)
- WRITE !!,"Cannot open host file."
- QUIT
- +4 USE IO
- +5 SET BGPP=0
- SET BGPY=$ORDER(^BGPCTRL("B","2012",0))
- SET BGPX=""
- SET BGPEC=$PIECE(^BGPCTRL(BGPY,0),U,26)
- +6 FOR
- SET BGPP=$ORDER(^BGPCTRL(BGPY,87,BGPP))
- IF BGPP'=+BGPP
- QUIT
- Begin DoDot:1
- +7 SET BGPPP1=$PIECE(^BGPCTRL(BGPY,87,BGPP,0),U,1)
- +8 SET BGPZ=$PIECE(^BGPCTRL(BGPY,87,BGPP,0),U,2)
- +9 SET $PIECE(BGPX,U,BGPPP1)=BGPZ
- End DoDot:1
- +10 WRITE BGPX,!
- +11 KILL BGPX
- +12 SET BGPX=""
- SET P=11
- FOR
- SET $PIECE(BGPX,U,P)="Current"
- SET P=P+9
- IF P>(BGPEC-8)
- QUIT
- +13 SET P=14
- FOR
- SET $PIECE(BGPX,U,P)="Previous"
- SET P=P+9
- IF P>(BGPEC-5)
- QUIT
- +14 SET P=17
- FOR
- SET $PIECE(BGPX,U,P)="Baseline"
- SET P=P+9
- IF P>(BGPEC+1)
- QUIT
- +15 WRITE BGPX,!
- +16 KILL BGPX
- +17 DO SETHDR^BGP2UTL
- +18 SET P=11
- FOR
- SET $PIECE(BGPX,U,P)="Num"
- SET P=P+3
- IF P>(BGPEC-2)
- QUIT
- +19 SET P=12
- FOR
- SET $PIECE(BGPX,U,P)="Den"
- SET P=P+3
- IF P>(BGPEC-1)
- QUIT
- +20 SET P=13
- FOR
- SET $PIECE(BGPX,U,P)="%"
- SET P=P+3
- IF P>BGPEC
- QUIT
- +21 WRITE BGPX,!
- +22 SET BGPX=0
- FOR
- SET BGPX=$ORDER(BGPONN5(BGPX))
- IF BGPX'=+BGPX
- QUIT
- WRITE BGPONN5(BGPX),!
- +23 KILL BGPONN5
- ONNC ;close host file
- DO ^%ZISC
- +1 QUIT
