- 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
