BLR2SORD ; IHS/DIR/FJE - SLC/RWF- ABNORMAL & CRITICAL VALUE REPORT 9/26/95 14:18 ;
;;5.2;BLR;;NOV 01, 1997
;;copied routine DWLRSORD modified by Walts (PIMC) to print for selected provider. SJ
;;MODIFIED BY FJ FOR LAB 5.2 ***CLASS 3 ***
I '$D(DUZ) W "DUZ NOT SET - ABORT" Q
I '$D(^VA(200,DUZ,0)) W "NOT A VALID USER - ABORTING" Q
;;D ^DWSETSCR,^%AUCLS,HEADING
S DIC("B")=$P(^VA(200,DUZ,0),"^",1),DIC("A")="Select PROVIDER NAME:"
S DIC=200,DIC(0)="AEMQ",DIC("S")="I $L($P(^VA(200,Y,0),U,16))"
D ^DIC I Y<1 K DIC Q
S DWNA=$P(Y,"^",2)
;S DWPDFN=$O(^DIC(16,"B",DWNA,0))
S DWPDFN=+Y
;;
D HEADING
S LREDT="T-1",LREND=0 D ^LRWU3 S %ZIS="Q" D ^%ZIS Q:POP
I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^BLR2SORD" D ZTLOAD D ^%ZTLOAD G END
DQ U IO S LREND=0 D HDR:$D(AZQ21) S AZQ21=""
DT F LRPDT=LREDT-.01:0 S LRPDT=$O(^LRO(69,LRPDT)) Q:LRPDT<LREDT!(LRPDT>LRSDT) D LRLLOC Q:LREND
END D ^%ZISC
K DWNA,DWPDFN,DWPRVNUM,DWP,DWPRVNA,DIC,DWY,DWRLOW,DWRHIGH,DWR1,DWRANGE
K LRSDT,LREDT,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK
K %H,DTOUT,I,L0,LAST,LRAA,LRAD,LRDFN,LRDPF,LREND,LRFAN,LRIDT,LRLAN,LRLLOC,LRLOX,LRPDT,LRSTAR,LRTX,LRWDTL,PNM,POP,SSN,HRCN,T ;IHS/ANMC/CLS 10/11/92 HRCN
Q
;
ZTLOAD S ZTSAVE("LREDT")="",ZTSAVE("LRSDT")="",ZTSAVE("DWNA")="",ZTSAVE("DWPDFN")="",ZTSAVE("DWPRVNUM")="",ZTSAVE("DWP")="",ZTSAVE("DWPRVNA")="",ZSAVE("DWY")="",ZSAVW("DWRLOW")="",ZTSAVE("DWRHIGH")="" Q
;
LRLLOC S LRLLOC="" F LRLOX=0:0 S LRLLOC=$O(^LRO(69,LRPDT,1,"AN",LRLLOC)) Q:LRLLOC="" D PT Q:LREND
Q
PT S DWP="" F LRDFN=0:0 S LRDFN=$O(^LRO(69,LRPDT,1,"AN",LRLLOC,LRDFN)) Q:LRDFN<1 D DWSETPRV D:(DWPDFN=DWPRVNUM) LRIDT Q:LREND
Q
LRIDT F LRIDT=0:0 S LRIDT=$O(^LRO(69,LRPDT,1,"AN",LRLLOC,LRDFN,LRIDT)) Q:LRIDT<1 D LOOK Q:LREND
Q
LOOK K T S L0=$S($D(^LR(LRDFN,"CH",LRIDT,0)):^(0),1:"") Q:L0=""
S T=0 F I=1:0 S I=$O(^LR(LRDFN,"CH",LRIDT,I)) Q:I<1 I $P(^(I),U,2)'="" S T=T+1,T(I)=^(I)
D PRINT:T Q
PRINT D SETUPDT S X=^LR(LRDFN,0),LRDPF=$P(X,U,2),DFN=$P(X,U,3) D PT^LRX
D HDR:$Y>(IOSL-7) Q:LREND W !!,"Provider: "_DWPRVNA,!,PNM,?35,HRCN W:LRDPF=2 " ",$S($D(^DPT(DFN,.1)):^(.1),1:LRLLOC) W ?60,$P(L0,U,6) W:$D(DWY) !,?35,"Collection Date/Time: "_DWY ;IHS/ANMC/CLS 10/11/92
F I=0:0 S I=$O(T(I)) Q:I<1 S LRTX=$O(^LAB(60,"C","CH;"_I_";1",0)) I LRTX>0 W !,?5,$J($P(^LAB(60,LRTX,0),U,1),20),$J($P(T(I),U,1),8)," ",$P(T(I),U,2) D SETRANGE W ?45,"Low: "_DWRLOW,?60,"High: "_DWRHIGH D:$Y>(IOSL-7) HDR Q:LREND
Q
HDR D WAIT Q:LREND W @IOF,"SPECAL REPORT: SEARCHING FOR ABNORMAL & CRITICAL FLAGS ** By Selected Provider",!,?50," " D STAMP^LRX
D DASH^LRX
Q
WAIT Q:IOST'["C-" W *7 R !!?20,"Press any key to continue, ""^"" to quit.",X:DTIME S:X["^" LREND=1
Q
DWSETPRV S DWPRVNUM=""
F S DWP=$O(^LRO(69,LRPDT,1,"AA",LRDFN,DWP)) Q:DWP="" D C1
Q
C1 S DWPRVNUM=$P(^LRO(69,LRPDT,1,DWP,0),"^",6)
S DWPRVNA=$P(^VA(200,DWPRVNUM,0),"^",1)
Q
HEADING W !,?7,"AIH Search for ABNORMAL & CRITICAL Flags by Slected Provider"
W !!!,"Note: This report will only show results for which",!,DWNA," is recorded as being the ordering provider in the computer!"
W !!," Verified results display based on the ORDERING Date.",!!!
R:DTIME "Press RETURN to continue",X
Q
SETUPDT I '$D(L0) S DWY="" Q
S Y=$P(L0,"^",1)
I '$D(Y)!(Y="") S DWY="" Q
S DWY=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_" "
X ^DD("DD")
S DWT=$P(Y,"@",2),DWY=DWY_$E(DWT,1,2)_":"_$E(DWT,4,5)
Q
SETRANGE S DWRL0W="",DWRHIGH="" I '$D(L0) Q
I '$D(LRTX) Q
S DWR1=$P(L0,"^",5)
I '$D(^LAB(60,LRTX,1,DWR1,0)) Q
S DWRANGE=^LAB(60,LRTX,1,DWR1,0)
I DWRANGE["$S" S XDW="S DWRLOW="_$P(DWRANGE,"^",2) X XDW S XDW="S DWRHIGH="_$P(DWRANGE,"^",3) X XDW Q
S DWRLOW=$P(DWRANGE,"^",2),DWRHIGH=$P(DWRANGE,"^",3)
Q
BLR2SORD ; IHS/DIR/FJE - SLC/RWF- ABNORMAL & CRITICAL VALUE REPORT 9/26/95 14:18 ;
+1 ;;5.2;BLR;;NOV 01, 1997
+2 ;;copied routine DWLRSORD modified by Walts (PIMC) to print for selected provider. SJ
+3 ;;MODIFIED BY FJ FOR LAB 5.2 ***CLASS 3 ***
+4 IF '$DATA(DUZ)
WRITE "DUZ NOT SET - ABORT"
QUIT
+5 IF '$DATA(^VA(200,DUZ,0))
WRITE "NOT A VALID USER - ABORTING"
QUIT
+6 ;;D ^DWSETSCR,^%AUCLS,HEADING
+7 SET DIC("B")=$PIECE(^VA(200,DUZ,0),"^",1)
SET DIC("A")="Select PROVIDER NAME:"
+8 SET DIC=200
SET DIC(0)="AEMQ"
SET DIC("S")="I $L($P(^VA(200,Y,0),U,16))"
+9 DO ^DIC
IF Y<1
KILL DIC
QUIT
+10 SET DWNA=$PIECE(Y,"^",2)
+11 ;S DWPDFN=$O(^DIC(16,"B",DWNA,0))
+12 SET DWPDFN=+Y
+13 ;;
+14 DO HEADING
+15 SET LREDT="T-1"
SET LREND=0
DO ^LRWU3
SET %ZIS="Q"
DO ^%ZIS
IF POP
QUIT
+16 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN="DQ^BLR2SORD"
DO ZTLOAD
DO ^%ZTLOAD
GOTO END
DQ USE IO
SET LREND=0
IF $DATA(AZQ21)
DO HDR
SET AZQ21=""
DT FOR LRPDT=LREDT-.01:0
SET LRPDT=$ORDER(^LRO(69,LRPDT))
IF LRPDT<LREDT!(LRPDT>LRSDT)
QUIT
DO LRLLOC
IF LREND
QUIT
END DO ^%ZISC
+1 KILL DWNA,DWPDFN,DWPRVNUM,DWP,DWPRVNA,DIC,DWY,DWRLOW,DWRHIGH,DWR1,DWRANGE
+2 KILL LRSDT,LREDT,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK
+3 ;IHS/ANMC/CLS 10/11/92 HRCN
KILL %H,DTOUT,I,L0,LAST,LRAA,LRAD,LRDFN,LRDPF,LREND,LRFAN,LRIDT,LRLAN,LRLLOC,LRLOX,LRPDT,LRSTAR,LRTX,LRWDTL,PNM,POP,SSN,HRCN,T
+4 QUIT
+5 ;
ZTLOAD SET ZTSAVE("LREDT")=""
SET ZTSAVE("LRSDT")=""
SET ZTSAVE("DWNA")=""
SET ZTSAVE("DWPDFN")=""
SET ZTSAVE("DWPRVNUM")=""
SET ZTSAVE("DWP")=""
SET ZTSAVE("DWPRVNA")=""
SET ZSAVE("DWY")=""
SET ZSAVW("DWRLOW")=""
SET ZTSAVE("DWRHIGH")=""
QUIT
+1 ;
LRLLOC SET LRLLOC=""
FOR LRLOX=0:0
SET LRLLOC=$ORDER(^LRO(69,LRPDT,1,"AN",LRLLOC))
IF LRLLOC=""
QUIT
DO PT
IF LREND
QUIT
+1 QUIT
PT SET DWP=""
FOR LRDFN=0:0
SET LRDFN=$ORDER(^LRO(69,LRPDT,1,"AN",LRLLOC,LRDFN))
IF LRDFN<1
QUIT
DO DWSETPRV
IF (DWPDFN=DWPRVNUM)
DO LRIDT
IF LREND
QUIT
+1 QUIT
LRIDT FOR LRIDT=0:0
SET LRIDT=$ORDER(^LRO(69,LRPDT,1,"AN",LRLLOC,LRDFN,LRIDT))
IF LRIDT<1
QUIT
DO LOOK
IF LREND
QUIT
+1 QUIT
LOOK KILL T
SET L0=$SELECT($DATA(^LR(LRDFN,"CH",LRIDT,0)):^(0),1:"")
IF L0=""
QUIT
+1 SET T=0
FOR I=1:0
SET I=$ORDER(^LR(LRDFN,"CH",LRIDT,I))
IF I<1
QUIT
IF $PIECE(^(I),U,2)'=""
SET T=T+1
SET T(I)=^(I)
+2 IF T
DO PRINT
QUIT
PRINT DO SETUPDT
SET X=^LR(LRDFN,0)
SET LRDPF=$PIECE(X,U,2)
SET DFN=$PIECE(X,U,3)
DO PT^LRX
+1 ;IHS/ANMC/CLS 10/11/92
IF $Y>(IOSL-7)
DO HDR
IF LREND
QUIT
WRITE !!,"Provider: "_DWPRVNA,!,PNM,?35,HRCN
IF LRDPF=2
WRITE " ",$SELECT($DATA(^DPT(DFN,.1)):^(.1),1:LRLLOC)
WRITE ?60,$PIECE(L0,U,6)
IF $DATA(DWY)
WRITE !,?35,"Collection Date/Time: "_DWY
+2 FOR I=0:0
SET I=$ORDER(T(I))
IF I<1
QUIT
SET LRTX=$ORDER(^LAB(60,"C","CH;"_I_";1",0))
IF LRTX>0
WRITE !,?5,$JUSTIFY($PIECE(^LAB(60,LRTX,0),U,1),20),$JUSTIFY($PIECE(T(I),U,1),8)," ",$PIECE(T(I),U,2)
DO SETRANGE
WRITE ?45,"Low: "_DWRLOW,?60,"High: "_DWRHIGH
IF $Y>(IOSL-7)
DO HDR
IF LREND
QUIT
+3 QUIT
HDR DO WAIT
IF LREND
QUIT
WRITE @IOF,"SPECAL REPORT: SEARCHING FOR ABNORMAL & CRITICAL FLAGS ** By Selected Provider",!,?50," "
DO STAMP^LRX
+1 DO DASH^LRX
+2 QUIT
WAIT IF IOST'["C-"
QUIT
WRITE *7
READ !!?20,"Press any key to continue, ""^"" to quit.",X:DTIME
IF X["^"
SET LREND=1
+1 QUIT
DWSETPRV SET DWPRVNUM=""
+1 FOR
SET DWP=$ORDER(^LRO(69,LRPDT,1,"AA",LRDFN,DWP))
IF DWP=""
QUIT
DO C1
+2 QUIT
C1 SET DWPRVNUM=$PIECE(^LRO(69,LRPDT,1,DWP,0),"^",6)
+1 SET DWPRVNA=$PIECE(^VA(200,DWPRVNUM,0),"^",1)
+2 QUIT
HEADING WRITE !,?7,"AIH Search for ABNORMAL & CRITICAL Flags by Slected Provider"
+1 WRITE !!!,"Note: This report will only show results for which",!,DWNA," is recorded as being the ordering provider in the computer!"
+2 WRITE !!," Verified results display based on the ORDERING Date.",!!!
+3 IF DTIME
READ "Press RETURN to continue",X
+4 QUIT
SETUPDT IF '$DATA(L0)
SET DWY=""
QUIT
+1 SET Y=$PIECE(L0,"^",1)
+2 IF '$DATA(Y)!(Y="")
SET DWY=""
QUIT
+3 SET DWY=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_" "
+4 XECUTE ^DD("DD")
+5 SET DWT=$PIECE(Y,"@",2)
SET DWY=DWY_$EXTRACT(DWT,1,2)_":"_$EXTRACT(DWT,4,5)
+6 QUIT
SETRANGE SET DWRL0W=""
SET DWRHIGH=""
IF '$DATA(L0)
QUIT
+1 IF '$DATA(LRTX)
QUIT
+2 SET DWR1=$PIECE(L0,"^",5)
+3 IF '$DATA(^LAB(60,LRTX,1,DWR1,0))
QUIT
+4 SET DWRANGE=^LAB(60,LRTX,1,DWR1,0)
+5 IF DWRANGE["$S"
SET XDW="S DWRLOW="_$PIECE(DWRANGE,"^",2)
XECUTE XDW
SET XDW="S DWRHIGH="_$PIECE(DWRANGE,"^",3)
XECUTE XDW
QUIT
+6 SET DWRLOW=$PIECE(DWRANGE,"^",2)
SET DWRHIGH=$PIECE(DWRANGE,"^",3)
+7 QUIT
