- BGP9DP ; IHS/CMI/LAB - IHS gpra print 03 Jul 2008 6:26 AM ;
- ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
- ;
- ;
- PRINT ;
- K ^TMP($J)
- K BGPDELIM
- S BGPIOSL=$S($G(BGPGUI):55,1:$G(IOSL))
- I $G(BGPAREAA) D SETEXCEL
- S BGPIFTR=""
- I BGPROT="D" G DEL
- S BGPQHDR=0
- D ^BGP9DH
- I BGPQHDR D KITM Q
- S BGPGPG=0
- S BGPQUIT=""
- D PRINT1
- K ^TMP($J)
- I BGPROT="P" D KITM Q
- ;
- DEL ;create delimited output file
- I '$D(BGPGUI) D ^%ZISC ;close printer device
- K ^TMP($J)
- D ^BGP9PDL ;create ^tmp of delimited report
- S BGPIFTR=1
- K ^XTMP("BGP9D",BGPJ,BGPH)
- K ^XTMP("BGP9DNP",BGPJ,BGPH)
- K ^XTMP("BGP08CPL",BGPJ,BGPH)
- K ^TMP($J)
- Q
- ;
- WTITLE ;EP - write title line
- NEW T,X,Y,S
- S T=$P(^BGPINDN(BGPIC,0),U,3)
- I $L(T)<81 W !,T,! Q
- F X=$E(T,1,80)
- S S=""
- F Y=80:-1:1 Q:S S I=$E(X,Y) I I=" " S S=Y
- W !,$E(T,1,S)
- W !,$E(T,(S+1),$L(T)),!
- Q
- PRINT1 ;EP
- S BGPIC=0 F S BGPIC=$O(BGPIND(BGPIC)) Q:BGPIC=""!(BGPQUIT) D
- .I $G(BGPSUMON) G CALC
- .D HEADER^BGP9DPH ;header for all measures
- .I $Y>(BGPIOSL-3) D HEADER^BGP9DPH Q:BGPQUIT
- .D WTITLE
- .;W !,$P(^BGPINDN(BGPIC,0),U,3),!
- .I $Y>(BGPIOSL-3) D HEADER^BGP9DPH Q:BGPQUIT
- .W !,"Denominator(s):"
- .S BGPX=0 F S BGPX=$O(^BGPINDN(BGPIC,61,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
- ..S BGPY=0 F S BGPY=$O(^BGPINDN(BGPIC,61,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT) D
- ...I '$D(^BGPINDN(BGPIC,61,BGPY,11,"B",BGPRTYPE)) Q ;not this report type
- ...I BGPRTYPE=4,'$D(^BGPINDN(BGPIC,61,BGPY,12,"B",BGPINDT)) Q ;not this measure type on selected
- ...S BGPZ=0 F S BGPZ=$O(^BGPINDN(BGPIC,61,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ!(BGPQUIT) D
- ....I $Y>(BGPIOSL-3) D HEADER^BGP9DPH Q:BGPQUIT
- ....W !,^BGPINDN(BGPIC,61,BGPY,1,BGPZ,0)
- ....Q
- ...;W !
- ...Q
- ..Q
- .I $Y>(BGPIOSL-3) D HEADER^BGP9DPH Q:BGPQUIT
- .W !!,"Numerator(s):"
- .S BGPX=0 F S BGPX=$O(^BGPINDN(BGPIC,62,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
- ..S BGPY=0 F S BGPY=$O(^BGPINDN(BGPIC,62,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT) D
- ...I '$D(^BGPINDN(BGPIC,62,BGPY,11,"B",BGPRTYPE)) Q ;not this report type
- ...I BGPRTYPE=4,'$D(^BGPINDN(BGPIC,62,BGPY,12,"B",BGPINDT)) Q ;not this measure type on selected
- ...S BGPZ=0 F S BGPZ=$O(^BGPINDN(BGPIC,62,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ!(BGPQUIT) D
- ....I $Y>(BGPIOSL-3) D HEADER^BGP9DPH Q:BGPQUIT
- ....W !,^BGPINDN(BGPIC,62,BGPY,1,BGPZ,0)
- ....Q
- ...;W !
- ...Q
- ..Q
- .S BGPNODE=11
- .I BGPRTYPE=1,$O(^BGPINDN(BGPIC,54,0)) S BGPNODE=54
- .I BGPRTYPE=7,$O(^BGPINDN(BGPIC,56,0)) S BGPNODE=56
- .W !!,"Logic:" S BGPX=0 F S BGPX=$O(^BGPINDN(BGPIC,BGPNODE,BGPX)) Q:BGPX'=+BGPX D
- ..I $Y>(BGPIOSL-3) D HEADER^BGP9DPH Q:BGPQUIT
- ..W !,^BGPINDN(BGPIC,BGPNODE,BGPX,0)
- .W !!,"Performance Measure Description:" S BGPX=0 F S BGPX=$O(^BGPINDN(BGPIC,$S($G(BGPNGR09):57,1:51),BGPX)) Q:BGPX'=+BGPX D
- ..I $Y>(BGPIOSL-3) D HEADER^BGP9DPH Q:BGPQUIT
- ..W !,^BGPINDN(BGPIC,$S($G(BGPNGR09):57,1:51),BGPX,0)
- .I $O(^BGPINDN(BGPIC,52,0)) W !!,"Past Performance and/or Target:" S BGPX=0 F S BGPX=$O(^BGPINDN(BGPIC,52,BGPX)) Q:BGPX'=+BGPX D
- ..I $Y>(BGPIOSL-3) D HEADER^BGP9DPH Q:BGPQUIT
- ..W !,^BGPINDN(BGPIC,52,BGPX,0)
- .I $O(^BGPINDN(BGPIC,55,0)) W !!,"Source:" S BGPX=0 F S BGPX=$O(^BGPINDN(BGPIC,55,BGPX)) Q:BGPX'=+BGPX D
- ..I $Y>(BGPIOSL-3) D HEADER^BGP9DPH Q:BGPQUIT
- ..W !,^BGPINDN(BGPIC,55,BGPX,0)
- .I '$O(^BGPINDN(BGPIC,55,0)) W !
- CALC .X ^BGPINDN(BGPIC,3) W !
- .I $G(BGPNPL),$D(BGPINDL(BGPIC)),'$D(BGP9NPLT) S BGPINDN=BGPIC D NPL1^BGP9NPLP ;printed nat gpra list
- .I $G(BGPNPL),$D(BGPINDL(BGPIC)),$D(BGP9NPLT) S BGPINDN=BGPIC D CT^BGP9DSTM ;printed nat gpra SEARCH TEMPLATE
- ;
- I BGPIC="" S BGPIFTR=1
- I BGPRTYPE=1 D ^BGP9DSPN ;NON GPRA
- I BGPRTYPE=1 D ^BGP9DSPD ;DEVELOPMENTAL
- I BGPRTYPE=1 D ^BGP9DSP ;GPRA
- I BGPRTYPE=1 D ^BGP9SDPN
- I BGPRTYPE=1 D ^BGP9SDPD
- I BGPRTYPE=1 D ^BGP9SDP
- I BGPRTYPE=7 D ^BGP9DSPO
- I BGPRTYPE=7 D ^BGP9SDPO
- D ^BGP9DS
- I $G(BGPCPPL) D CPPL1^BGP9DCLP ;print comp pt list
- D EXIT
- Q
- KITM ;
- K ^TMP($J)
- K ^XTMP("BGP9D",BGPJ,BGPH)
- K ^XTMP("BGP9DNP",BGPJ,BGPH)
- K ^XTMP("BGP08CPL",BGPJ,BGPH)
- Q
- SETEXCEL ;EP
- I $G(BGPAREAA) D Q
- .S X=0 F S X=$O(BGPSUL(X)) Q:X'=+X D
- ..S N=^BGPGPDCN(X,0)
- ..S (D,L)=""
- ..S L=$P(N,U,9) I L S L=$O(^AUTTLOC("C",L,0)) I L S D=$P($G(^AUTTLOC(L,1)),U,3),L=$S(L:$P(^DIC(4,L,0),U),1:"?????")
- ..S BGPEI(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP9UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI(X),U,P)=$$DATE^BGP9UTL($P(N,U,Y)),P=P+1
- ..S BGPEI2(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP9UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI2(X),U,P)=$$DATE^BGP9UTL($P(N,U,Y)),P=P+1
- ..S BGPEI3(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP9UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI3(X),U,P)=$$DATE^BGP9UTL($P(N,U,Y)),P=P+1
- ..S BGPEI4(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP9UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI4(X),U,P)=$$DATE^BGP9UTL($P(N,U,Y)),P=P+1
- ..S BGPONN1(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP9UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN1(X),U,P)=$$DATE^BGP9UTL($P(N,U,Y)),P=P+1
- ..S BGPONN2(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP9UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN2(X),U,P)=$$DATE^BGP9UTL($P(N,U,Y)),P=P+1
- ..S BGPONN3(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP9UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN3(X),U,P)=$$DATE^BGP9UTL($P(N,U,Y)),P=P+1
- ..Q
- .Q
- ;S X=BGPRPT
- ;S N=^BGPGPDCN(X,0)
- ;S L=$P(N,U,9),L=$O(^AUTTLOC("C",L,0)) S D=$P($G(^AUTTLOC(L,1)),U,3),L=$S(L:$P(^DIC(4,L,0),U),1:"?????")
- ;S BGPEI(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP9UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI(X),U,P)=$$DATE^BGP9UTL($P(N,U,Y)),P=P+1
- Q
- EXIT ;
- I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED) W ! S DIR(0)="EO",DIR("A")="End of report. Press ENTER" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
- Q
- C(X,X2,X3) ;
- D COMMA^%DTC
- Q X
- BGP9DP ; IHS/CMI/LAB - IHS gpra print 03 Jul 2008 6:26 AM ;
- +1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
- +2 ;
- +3 ;
- PRINT ;
- +1 KILL ^TMP($JOB)
- +2 KILL BGPDELIM
- +3 SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:$GET(IOSL))
- +4 IF $GET(BGPAREAA)
- DO SETEXCEL
- +5 SET BGPIFTR=""
- +6 IF BGPROT="D"
- GOTO DEL
- +7 SET BGPQHDR=0
- +8 DO ^BGP9DH
- +9 IF BGPQHDR
- DO KITM
- QUIT
- +10 SET BGPGPG=0
- +11 SET BGPQUIT=""
- +12 DO PRINT1
- +13 KILL ^TMP($JOB)
- +14 IF BGPROT="P"
- DO KITM
- QUIT
- +15 ;
- DEL ;create delimited output file
- +1 ;close printer device
- IF '$DATA(BGPGUI)
- DO ^%ZISC
- +2 KILL ^TMP($JOB)
- +3 ;create ^tmp of delimited report
- DO ^BGP9PDL
- +4 SET BGPIFTR=1
- +5 KILL ^XTMP("BGP9D",BGPJ,BGPH)
- +6 KILL ^XTMP("BGP9DNP",BGPJ,BGPH)
- +7 KILL ^XTMP("BGP08CPL",BGPJ,BGPH)
- +8 KILL ^TMP($JOB)
- +9 QUIT
- +10 ;
- WTITLE ;EP - write title line
- +1 NEW T,X,Y,S
- +2 SET T=$PIECE(^BGPINDN(BGPIC,0),U,3)
- +3 IF $LENGTH(T)<81
- WRITE !,T,!
- QUIT
- +4 FOR X=$EXTRACT(T,1,80)
- +5 SET S=""
- +6 FOR Y=80:-1:1
- IF S
- QUIT
- SET I=$EXTRACT(X,Y)
- IF I=" "
- SET S=Y
- +7 WRITE !,$EXTRACT(T,1,S)
- +8 WRITE !,$EXTRACT(T,(S+1),$LENGTH(T)),!
- +9 QUIT
- PRINT1 ;EP
- +1 SET BGPIC=0
- FOR
- SET BGPIC=$ORDER(BGPIND(BGPIC))
- IF BGPIC=""!(BGPQUIT)
- QUIT
- Begin DoDot:1
- +2 IF $GET(BGPSUMON)
- GOTO CALC
- +3 ;header for all measures
- DO HEADER^BGP9DPH
- +4 IF $Y>(BGPIOSL-3)
- DO HEADER^BGP9DPH
- IF BGPQUIT
- QUIT
- +5 DO WTITLE
- +6 ;W !,$P(^BGPINDN(BGPIC,0),U,3),!
- +7 IF $Y>(BGPIOSL-3)
- DO HEADER^BGP9DPH
- IF BGPQUIT
- QUIT
- +8 WRITE !,"Denominator(s):"
- +9 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPINDN(BGPIC,61,"B",BGPX))
- IF BGPX'=+BGPX!(BGPQUIT)
- QUIT
- Begin DoDot:2
- +10 SET BGPY=0
- FOR
- SET BGPY=$ORDER(^BGPINDN(BGPIC,61,"B",BGPX,BGPY))
- IF BGPY'=+BGPY!(BGPQUIT)
- QUIT
- Begin DoDot:3
- +11 ;not this report type
- IF '$DATA(^BGPINDN(BGPIC,61,BGPY,11,"B",BGPRTYPE))
- QUIT
- +12 ;not this measure type on selected
- IF BGPRTYPE=4
- IF '$DATA(^BGPINDN(BGPIC,61,BGPY,12,"B",BGPINDT))
- QUIT
- +13 SET BGPZ=0
- FOR
- SET BGPZ=$ORDER(^BGPINDN(BGPIC,61,BGPY,1,BGPZ))
- IF BGPZ'=+BGPZ!(BGPQUIT)
- QUIT
- Begin DoDot:4
- +14 IF $Y>(BGPIOSL-3)
- DO HEADER^BGP9DPH
- IF BGPQUIT
- QUIT
- +15 WRITE !,^BGPINDN(BGPIC,61,BGPY,1,BGPZ,0)
- +16 QUIT
- End DoDot:4
- +17 ;W !
- +18 QUIT
- End DoDot:3
- +19 QUIT
- End DoDot:2
- +20 IF $Y>(BGPIOSL-3)
- DO HEADER^BGP9DPH
- IF BGPQUIT
- QUIT
- +21 WRITE !!,"Numerator(s):"
- +22 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPINDN(BGPIC,62,"B",BGPX))
- IF BGPX'=+BGPX!(BGPQUIT)
- QUIT
- Begin DoDot:2
- +23 SET BGPY=0
- FOR
- SET BGPY=$ORDER(^BGPINDN(BGPIC,62,"B",BGPX,BGPY))
- IF BGPY'=+BGPY!(BGPQUIT)
- QUIT
- Begin DoDot:3
- +24 ;not this report type
- IF '$DATA(^BGPINDN(BGPIC,62,BGPY,11,"B",BGPRTYPE))
- QUIT
- +25 ;not this measure type on selected
- IF BGPRTYPE=4
- IF '$DATA(^BGPINDN(BGPIC,62,BGPY,12,"B",BGPINDT))
- QUIT
- +26 SET BGPZ=0
- FOR
- SET BGPZ=$ORDER(^BGPINDN(BGPIC,62,BGPY,1,BGPZ))
- IF BGPZ'=+BGPZ!(BGPQUIT)
- QUIT
- Begin DoDot:4
- +27 IF $Y>(BGPIOSL-3)
- DO HEADER^BGP9DPH
- IF BGPQUIT
- QUIT
- +28 WRITE !,^BGPINDN(BGPIC,62,BGPY,1,BGPZ,0)
- +29 QUIT
- End DoDot:4
- +30 ;W !
- +31 QUIT
- End DoDot:3
- +32 QUIT
- End DoDot:2
- +33 SET BGPNODE=11
- +34 IF BGPRTYPE=1
- IF $ORDER(^BGPINDN(BGPIC,54,0))
- SET BGPNODE=54
- +35 IF BGPRTYPE=7
- IF $ORDER(^BGPINDN(BGPIC,56,0))
- SET BGPNODE=56
- +36 WRITE !!,"Logic:"
- SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPINDN(BGPIC,BGPNODE,BGPX))
- IF BGPX'=+BGPX
- QUIT
- Begin DoDot:2
- +37 IF $Y>(BGPIOSL-3)
- DO HEADER^BGP9DPH
- IF BGPQUIT
- QUIT
- +38 WRITE !,^BGPINDN(BGPIC,BGPNODE,BGPX,0)
- End DoDot:2
- +39 WRITE !!,"Performance Measure Description:"
- SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPINDN(BGPIC,$SELECT($GET(BGPNGR09):57,1:51),BGPX))
- IF BGPX'=+BGPX
- QUIT
- Begin DoDot:2
- +40 IF $Y>(BGPIOSL-3)
- DO HEADER^BGP9DPH
- IF BGPQUIT
- QUIT
- +41 WRITE !,^BGPINDN(BGPIC,$SELECT($GET(BGPNGR09):57,1:51),BGPX,0)
- End DoDot:2
- +42 IF $ORDER(^BGPINDN(BGPIC,52,0))
- WRITE !!,"Past Performance and/or Target:"
- SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPINDN(BGPIC,52,BGPX))
- IF BGPX'=+BGPX
- QUIT
- Begin DoDot:2
- +43 IF $Y>(BGPIOSL-3)
- DO HEADER^BGP9DPH
- IF BGPQUIT
- QUIT
- +44 WRITE !,^BGPINDN(BGPIC,52,BGPX,0)
- End DoDot:2
- +45 IF $ORDER(^BGPINDN(BGPIC,55,0))
- WRITE !!,"Source:"
- SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPINDN(BGPIC,55,BGPX))
- IF BGPX'=+BGPX
- QUIT
- Begin DoDot:2
- +46 IF $Y>(BGPIOSL-3)
- DO HEADER^BGP9DPH
- IF BGPQUIT
- QUIT
- +47 WRITE !,^BGPINDN(BGPIC,55,BGPX,0)
- End DoDot:2
- +48 IF '$ORDER(^BGPINDN(BGPIC,55,0))
- WRITE !
- CALC XECUTE ^BGPINDN(BGPIC,3)
- WRITE !
- +1 ;printed nat gpra list
- IF $GET(BGPNPL)
- IF $DATA(BGPINDL(BGPIC))
- IF '$DATA(BGP9NPLT)
- SET BGPINDN=BGPIC
- DO NPL1^BGP9NPLP
- +2 ;printed nat gpra SEARCH TEMPLATE
- IF $GET(BGPNPL)
- IF $DATA(BGPINDL(BGPIC))
- IF $DATA(BGP9NPLT)
- SET BGPINDN=BGPIC
- DO CT^BGP9DSTM
- End DoDot:1
- +3 ;
- +4 IF BGPIC=""
- SET BGPIFTR=1
- +5 ;NON GPRA
- IF BGPRTYPE=1
- DO ^BGP9DSPN
- +6 ;DEVELOPMENTAL
- IF BGPRTYPE=1
- DO ^BGP9DSPD
- +7 ;GPRA
- IF BGPRTYPE=1
- DO ^BGP9DSP
- +8 IF BGPRTYPE=1
- DO ^BGP9SDPN
- +9 IF BGPRTYPE=1
- DO ^BGP9SDPD
- +10 IF BGPRTYPE=1
- DO ^BGP9SDP
- +11 IF BGPRTYPE=7
- DO ^BGP9DSPO
- +12 IF BGPRTYPE=7
- DO ^BGP9SDPO
- +13 DO ^BGP9DS
- +14 ;print comp pt list
- IF $GET(BGPCPPL)
- DO CPPL1^BGP9DCLP
- +15 DO EXIT
- +16 QUIT
- KITM ;
- +1 KILL ^TMP($JOB)
- +2 KILL ^XTMP("BGP9D",BGPJ,BGPH)
- +3 KILL ^XTMP("BGP9DNP",BGPJ,BGPH)
- +4 KILL ^XTMP("BGP08CPL",BGPJ,BGPH)
- +5 QUIT
- SETEXCEL ;EP
- +1 IF $GET(BGPAREAA)
- Begin DoDot:1
- +2 SET X=0
- FOR
- SET X=$ORDER(BGPSUL(X))
- IF X'=+X
- QUIT
- Begin DoDot:2
- +3 SET N=^BGPGPDCN(X,0)
- +4 SET (D,L)=""
- +5 SET L=$PIECE(N,U,9)
- IF L
- SET L=$ORDER(^AUTTLOC("C",L,0))
- IF L
- SET D=$PIECE($GET(^AUTTLOC(L,1)),U,3)
- SET L=$SELECT(L:$PIECE(^DIC(4,L,0),U),1:"?????")
- +6 SET BGPEI(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP9UTL($PIECE(N,U,13))
- SET P=5
- FOR Y=1:1:6
- SET $PIECE(BGPEI(X),U,P)=$$DATE^BGP9UTL($PIECE(N,U,Y))
- SET P=P+1
- +7 SET BGPEI2(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP9UTL($PIECE(N,U,13))
- SET P=5
- FOR Y=1:1:6
- SET $PIECE(BGPEI2(X),U,P)=$$DATE^BGP9UTL($PIECE(N,U,Y))
- SET P=P+1
- +8 SET BGPEI3(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP9UTL($PIECE(N,U,13))
- SET P=5
- FOR Y=1:1:6
- SET $PIECE(BGPEI3(X),U,P)=$$DATE^BGP9UTL($PIECE(N,U,Y))
- SET P=P+1
- +9 SET BGPEI4(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP9UTL($PIECE(N,U,13))
- SET P=5
- FOR Y=1:1:6
- SET $PIECE(BGPEI4(X),U,P)=$$DATE^BGP9UTL($PIECE(N,U,Y))
- SET P=P+1
- +10 SET BGPONN1(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP9UTL($PIECE(N,U,13))
- SET P=5
- FOR Y=1:1:6
- SET $PIECE(BGPONN1(X),U,P)=$$DATE^BGP9UTL($PIECE(N,U,Y))
- SET P=P+1
- +11 SET BGPONN2(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP9UTL($PIECE(N,U,13))
- SET P=5
- FOR Y=1:1:6
- SET $PIECE(BGPONN2(X),U,P)=$$DATE^BGP9UTL($PIECE(N,U,Y))
- SET P=P+1
- +12 SET BGPONN3(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP9UTL($PIECE(N,U,13))
- SET P=5
- FOR Y=1:1:6
- SET $PIECE(BGPONN3(X),U,P)=$$DATE^BGP9UTL($PIECE(N,U,Y))
- SET P=P+1
- +13 QUIT
- End DoDot:2
- +14 QUIT
- End DoDot:1
- QUIT
- +15 ;S X=BGPRPT
- +16 ;S N=^BGPGPDCN(X,0)
- +17 ;S L=$P(N,U,9),L=$O(^AUTTLOC("C",L,0)) S D=$P($G(^AUTTLOC(L,1)),U,3),L=$S(L:$P(^DIC(4,L,0),U),1:"?????")
- +18 ;S BGPEI(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP9UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI(X),U,P)=$$DATE^BGP9UTL($P(N,U,Y)),P=P+1
- +19 QUIT
- EXIT ;
- +1 IF $EXTRACT(IOST)="C"
- IF IO=IO(0)
- IF '$DATA(ZTQUEUED)
- WRITE !
- SET DIR(0)="EO"
- SET DIR("A")="End of report. Press ENTER"
- DO ^DIR
- KILL DIR
- IF $DATA(DUOUT)
- SET DIRUT=1
- +2 QUIT
- C(X,X2,X3) ;
- +1 DO COMMA^%DTC
- +2 QUIT X
