- LRSORB ;DALOI/RWF/RLM-SCAN PART OF LRSORA ;7/3/86 12:47 PM [ 04/14/2003 1:27 PM ]
- ;;5.2T9;LR;**1018**;Nov 17, 2004
- ;;5.2;LAB SERVICE;**272**;Sep 27, 1994
- ; Reference to $$FMTE^XLFDT supported by IA #10103
- ; Reference to $$NOW^XLFDT supported by IA #10103
- ; Reference to ^DPT supported by DBIA #10035
- ; Reference to ^%ZISC supported by IA #10089
- S LREND=0 G LRLONG:$D(LRLONG) U IO D HDR
- DT F LRPDT=LREDT-.01:0 S LRPDT=$O(^LRO(69,LRPDT)) Q:LRPDT<LREDT!(LRPDT>LRSDT) D LOC Q:LREND
- D ^%ZISC Q
- LOC S LRLLOC="" F LRLOX=0:0 S LRLLOC=$O(^LRO(69,LRPDT,1,"AN",LRLLOC)) Q:LRLLOC="" D PT Q:LREND
- Q
- PT F LRDFN=0:0 S LRDFN=$O(^LRO(69,LRPDT,1,"AN",LRLLOC,LRDFN)) Q:LRDFN<1 D 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 V S L0=$S($D(^LR(LRDFN,"CH",LRIDT,0)):^(0),1:"") Q:L0=""
- F I=1:1:LRTEST X LRTEST(I) I $T S V(I)=@LRTEST(I,3)
- D PRINT:$O(V(0))'=""
- Q
- PRINT S X=^LR(LRDFN,0),LRDPF=$P(X,U,2),DFN=$P(X,U,3) D PT^LRX
- S LRSPEC=+$P(L0,U,5)
- ;D HDR:$Y>IOSL Q:LREND W !,PNM,?35,SSN," " W:LRDPF=2 $S($D(^DPT(DFN,.1)):^(.1),1:LRLLOC) W ?60,$P(L0,U,6)
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- D HDR:$Y>IOSL Q:LREND W !,PNM,?35,HRCN," " W:LRDPF=2 $S($D(^DPT(DFN,.1)):^(.1),1:LRLLOC) W ?60,$P(L0,U,6) ;IHS/ANMC/CLS 08/18/96
- ;----- END IHS MODIFICATIONS
- F I=0:0 S I=$O(V(I)) Q:I<1 W !,?5,LRTEST(I,1),?20," ",$J($P(V(I),U,1),8),$J($P(V(I),U,2),3)," ",$S($D(^LAB(61,LRSPEC,0)):$P(^(0),U,1),1:"") D:$Y>(IOSL-7) HDR Q:LREND
- Q
- HDR U IO D WAIT Q:LREND W @IOF,"SPECIAL REPORT: SEARCHING FOR ",?30,LRTEST(1,1)," ",LRTEST(1,2)," ",$$FMTE^XLFDT($$NOW^XLFDT,"")
- I LRTEST>1 F I=2:1:LRTEST W:I>1 !,?25," or" W ?30,LRTEST(I,1)," ",LRTEST(I,2)
- D DASH^LRX
- Q
- LRLONG U IO D HDR Q:LREND S LRSDT=9999999-LRSDT,LREDT=9999999-LREDT
- F LRDFN=0:0 S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D NIDT Q:LREND
- END K %H,%ZIS,DIC,DTOUT,I,L0,LAST,LRAA,LRAD,LRDFN,LRDPF,LREDT,LREND,LRFAN,LRIDT,LRLAN,LRLLOC,LRLONG,LRLOX,LRPDT,LRSB,LRSDT,LRSPEC,LRSTAR,LRTEST
- ;K ^TMP("LR",$J,"T"),LRTSTS,LRWDTL,PNM,POP,SSN,V,Y
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1013
- K ^TMP("LR",$J,"T"),LRTSTS,LRWDTL,PNM,POP,SSN,HRCN,V,Y ;IHS/ANMC/CLS 08/18/96
- ;----- END IHS MODIFICATIONS
- D ^%ZISC Q
- NIDT F LRIDT=LRSDT:0 S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT=""!(LRIDT>LREDT) S LRLLOC=$P(^(LRIDT,0),"^",11) D LOOK Q:LREND
- Q
- WAIT Q:$E(IOST,1,2)'="C-" W $C(7) R !!?20,"Press any key to continue, ""^"" to quit.",X:DTIME S:X["^" LREND=1
- Q
- LRSORB ;DALOI/RWF/RLM-SCAN PART OF LRSORA ;7/3/86 12:47 PM [ 04/14/2003 1:27 PM ]
- +1 ;;5.2T9;LR;**1018**;Nov 17, 2004
- +2 ;;5.2;LAB SERVICE;**272**;Sep 27, 1994
- +3 ; Reference to $$FMTE^XLFDT supported by IA #10103
- +4 ; Reference to $$NOW^XLFDT supported by IA #10103
- +5 ; Reference to ^DPT supported by DBIA #10035
- +6 ; Reference to ^%ZISC supported by IA #10089
- +7 SET LREND=0
- IF $DATA(LRLONG)
- GOTO LRLONG
- USE IO
- DO HDR
- DT FOR LRPDT=LREDT-.01:0
- SET LRPDT=$ORDER(^LRO(69,LRPDT))
- IF LRPDT<LREDT!(LRPDT>LRSDT)
- QUIT
- DO LOC
- IF LREND
- QUIT
- +1 DO ^%ZISC
- QUIT
- LOC 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 FOR LRDFN=0:0
- SET LRDFN=$ORDER(^LRO(69,LRPDT,1,"AN",LRLLOC,LRDFN))
- IF LRDFN<1
- QUIT
- 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 V
- SET L0=$SELECT($DATA(^LR(LRDFN,"CH",LRIDT,0)):^(0),1:"")
- IF L0=""
- QUIT
- +1 FOR I=1:1:LRTEST
- XECUTE LRTEST(I)
- IF $TEST
- SET V(I)=@LRTEST(I,3)
- +2 IF $ORDER(V(0))'=""
- DO PRINT
- +3 QUIT
- PRINT SET X=^LR(LRDFN,0)
- SET LRDPF=$PIECE(X,U,2)
- SET DFN=$PIECE(X,U,3)
- DO PT^LRX
- +1 SET LRSPEC=+$PIECE(L0,U,5)
- +2 ;D HDR:$Y>IOSL Q:LREND W !,PNM,?35,SSN," " W:LRDPF=2 $S($D(^DPT(DFN,.1)):^(.1),1:LRLLOC) W ?60,$P(L0,U,6)
- +3 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +4 ;IHS/ANMC/CLS 08/18/96
- IF $Y>IOSL
- DO HDR
- IF LREND
- QUIT
- WRITE !,PNM,?35,HRCN," "
- IF LRDPF=2
- WRITE $SELECT($DATA(^DPT(DFN,.1)):^(.1),1:LRLLOC)
- WRITE ?60,$PIECE(L0,U,6)
- +5 ;----- END IHS MODIFICATIONS
- +6 FOR I=0:0
- SET I=$ORDER(V(I))
- IF I<1
- QUIT
- WRITE !,?5,LRTEST(I,1),?20," ",$JUSTIFY($PIECE(V(I),U,1),8),$JUSTIFY($PIECE(V(I),U,2),3)," ",$SELECT($DATA(^LAB(61,LRSPEC,0)):$PIECE(^(0),U,1),1:"")
- IF $Y>(IOSL-7)
- DO HDR
- IF LREND
- QUIT
- +7 QUIT
- HDR USE IO
- DO WAIT
- IF LREND
- QUIT
- WRITE @IOF,"SPECIAL REPORT: SEARCHING FOR ",?30,LRTEST(1,1)," ",LRTEST(1,2)," ",$$FMTE^XLFDT($$NOW^XLFDT,"")
- +1 IF LRTEST>1
- FOR I=2:1:LRTEST
- IF I>1
- WRITE !,?25," or"
- WRITE ?30,LRTEST(I,1)," ",LRTEST(I,2)
- +2 DO DASH^LRX
- +3 QUIT
- LRLONG USE IO
- DO HDR
- IF LREND
- QUIT
- SET LRSDT=9999999-LRSDT
- SET LREDT=9999999-LREDT
- +1 FOR LRDFN=0:0
- SET LRDFN=$ORDER(^LR(LRDFN))
- IF LRDFN<1
- QUIT
- DO NIDT
- IF LREND
- QUIT
- END KILL %H,%ZIS,DIC,DTOUT,I,L0,LAST,LRAA,LRAD,LRDFN,LRDPF,LREDT,LREND,LRFAN,LRIDT,LRLAN,LRLLOC,LRLONG,LRLOX,LRPDT,LRSB,LRSDT,LRSPEC,LRSTAR,LRTEST
- +1 ;K ^TMP("LR",$J,"T"),LRTSTS,LRWDTL,PNM,POP,SSN,V,Y
- +2 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1013
- +3 ;IHS/ANMC/CLS 08/18/96
- KILL ^TMP("LR",$JOB,"T"),LRTSTS,LRWDTL,PNM,POP,SSN,HRCN,V,Y
- +4 ;----- END IHS MODIFICATIONS
- +5 DO ^%ZISC
- QUIT
- NIDT FOR LRIDT=LRSDT:0
- SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
- IF LRIDT=""!(LRIDT>LREDT)
- QUIT
- SET LRLLOC=$PIECE(^(LRIDT,0),"^",11)
- DO LOOK
- IF LREND
- QUIT
- +1 QUIT
- WAIT IF $EXTRACT(IOST,1,2)'="C-"
- QUIT
- WRITE $CHAR(7)
- READ !!?20,"Press any key to continue, ""^"" to quit.",X:DTIME
- IF X["^"
- SET LREND=1
- +1 QUIT
