LRNINES7 ;DAL/HOAK SEARCH FOR 7 9s ; 10/14/96 16:02
;;5.2;LAB SERVICE;**156**;Sep 27, 1994
;
INIT ;
;
;
;^LR(582,"CH",9999999,0) = 0^1^2970522.101919^389^72^CH 0522 106^^MONARCH 2
CONTROL ;
K ^TMP("LR",$J,"7-9s")
D FINDLR
S LRTIC=""
;
D FIXALL
END ;
;
DONE W !!,"All occurences of 7 9s have been removed and their effects in"
W !,"your data base have been disarmed.",!
D ^LRKILL
QUIT
;
TASK ;
;-->Task the job to look for 7-9s that were created Today
;
K ^TMP("LR",$J,"7-9s")
;
S LRCOUNT=0
S LRCNTLR=500
S LRT70=LRCNTLR,LRIN=0,LRA=1,LRI=1
I IOST["C-" W @IOF D
. S DX=3,DY=10 X IOXY
. D JOBTIME
. D TITLE^XPDID("SEARCHING ^LR(")
;
S X1=DT,X2=-1 D C^%DTC S LRDT0=X
S LRDFN=0
F LRODT=LRDT0,DT D
. F S LRDFN=$O(^LRO(69,LRODT,1,"AA",LRDFN)) Q:+LRDFN'>0 D SET(LRDFN)
;
;
D SCRNOFF
I '$D(TMP("LR",$J,"7-9s")) D
. Q:IOST'["C-"
. W !!,"Mission debreifing:"
. W !,"No problems related to 7-9s have been observed for Yesterday and Today."
QUIT
;
FINDLR ;----------find ALL the 7 nines in ALL OF LR
;---> ^LR(0)=LAB DATA^63^464^355
;
S LRCNTLR=$P(^LR(0),U,4)
S LRT70=LRCNTLR,LRIN=0,LRA=1,LRI=1
;
I IOST["C-" W @IOF D
. S DX=3,DY=10 X IOXY
. D JOBTIME
. D TITLE^XPDID("SEARCHING ^LR(")
S LRDFN=0,LRCOUNT=0
F S LRDFN=$O(^LR(LRDFN)) Q:+LRDFN'>0 D
. ;--------check all ^LR(subscripts
. D SET(LRDFN)
S DX=5,DY=15 X IOXY
W "Found ",LRCOUNT," occurrances of 7 9s in ^LR" H 2
D SCRNOFF
QUIT
;
SET(LRDFN) ;
;
;
I IOST["C-" D MOVE
F LRSUB="CH","MI" D
. I $D(^LR(LRDFN,LRSUB,9999999,0)) D
.. S ^TMP("LR",$J,"7-9s",LRDFN,LRSUB)="" S LRCOUNT=LRCOUNT+1
QUIT
;
FIXALL ;
;
;
COUNT ;
S LRCOUNT=0
S LRX6=0
F S LRX6=$O(^TMP("LR",$J,"7-9s",LRX6)) Q:+LRX6'>0 S LRCOUNT=LRCOUNT+1
S LRCNTLR=LRCOUNT
I IOST["C-" W @IOF D
. S DX=3,DY=10 X IOXY
. D JOBTIME
. D TITLE^XPDID("Fixing ^LR(, ^LRO(68, ^LRO(69, and ^LAC(")
S LRDFN=0
F S LRDFN=$O(^TMP("LR",$J,"7-9s",LRDFN)) Q:+LRDFN'>0 D
. S LRSUB=""
. F S LRSUB=$O(^TMP("LR",$J,"7-9s",LRDFN,LRSUB)) Q:LRSUB="" D
.. I IOST["C-" D MOVE
.. Q:'$D(^LR(LRDFN,LRSUB,9999999,0))
.. S LRNODE=^LR(LRDFN,LRSUB,9999999,0)
.. D ACCN(LRNODE)
I IOST["C-" D MOVE
QUIT
;
;
ACCN(LRNODE) ;
;-->If LRNODE is not there or it is not an accn we still could
;--> LAC( involved
;
I '$D(LRNODE) D CHKLAC QUIT
;
K LRAA,LRAD,LRAN,LRACCN,LRODT,LRSN
;
;
BAKDOR ;-->Maybe the ^LAC can provide accn.
;
S LRACCN=$P(LRNODE,U,6) ;--CH 0522 106
S LRAA=$O(^LRO(68,"B",$P(LRACCN," "),0))
S LRAD=$E($P(LRNODE,U,3),1,3)_$P(LRACCN," ",2) ;-- 297_0522
S LRAN=$P(LRACCN," ",3) ;--106
I $G(LRAA)'>0!($L(LRAD)'>4)!($G(LRAN)'>0) S LROK=0 QUIT
LRSN ;
I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S LRSN=$P(^(0),U,5)
LRODT ;
I $G(LRSN)>0 S LRODT=+$G(^LRO(69,LRAD,1,LRSN,1))
;
;
I $G(LRODT)'>0,$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S LRODT=LRAD
I $G(LRODT)'>0,$P(LRNODE,U,3)'="" S LRODT=$P(LRNODE,U,3) D
. S LRODT1=LRODT
. S LRODT=$P(LRODT,".")
. I $G(LRODT1)>0 S LRIDT=9999999-LRODT1
. D LAC(LRDFN,LRODT1,LRIDT) K LRODT
Q:'$G(LRODT)
;
;
LRIDT ;
;
S LRODT1=LRODT
S LRODT=$P(LRODT,".")
I $G(LRODT1)>0 S LRIDT=9999999-LRODT1
;
D FIX68
;
BYE68 D LAC(LRDFN,LRODT1,LRIDT)
;
QUIT
;
LAC(LRDFN,LRODT,LRIDT) ;
K LRTOE
;^LAC("LRAC",34390,1,22,1,1,1,2970702.184153,0)
;^LAC("LRAC",582,1,4,1,1,1,0,0) = 0^58-2*^2970522.101919^CH 0522 106^9999999
;^LAC("LRAC",582,1,4,1,1,1,0,1,0) = ^64.705^7^7
;
S LRTIC=0
F S LRTIC=$O(^LAC("LRAC",LRDFN,1,LRTIC)) Q:+LRTIC'>0 D
. S LRTAC=0
. F S LRTAC=$O(^LAC("LRAC",LRDFN,1,LRTIC,1,LRTAC)) Q:+LRTAC'>0 D
.. Q:'$D(^LAC("LRAC",LRDFN,1,LRTIC,1,LRTAC,1,0,0)) S LACNODE=^(0)
.. I $P(LACNODE,U)=0 D FIXLAC
.. S LRACCN=$P(LACNODE,U,4)
.. ;I $G(LRAN)'>0,$D(LRACCN) D BAKDOR
D:'$G(LRTOE) FIXLR
Q
FIXLAC ;
;^LAC("LRAC",34390,1,22,1,1,1,2970702.184153,0)
; good girl-> /\
S LRLONG=$L(LACNODE)
S LACNODE=$E(LACNODE,2,LRLONG)
; ^LAC("LRAC",582,1,4,1,1,1,0,1,7,0) = 20.^L^8
;^LAC("LRAC",582,1,4,1,1,1,0,0) = 0^58-2*^2970522.101919^CH 0522 106^9999999-----------------------------/\<----bad girl
S %Y="^LAC(""LRAC"",LRDFN,1,LRTIC,1,LRTAC,1,LRODT1,"
S %X="^LAC(""LRAC"",LRDFN,1,LRTIC,1,LRTAC,1,0,"
D %XY^%RCR
S $P(^LAC("LRAC",LRDFN,1,LRTIC,1,LRTAC,1,LRODT1,0),U)=LRODT1
S $P(^LAC("LRAC",LRDFN,1,LRTIC,1,LRTAC,1,LRODT1,0),U,5)=LRIDT
K ^LAC("LRAC",LRDFN,1,LRTIC,1,LRTAC,1,0)
;
D FIXLR
S LRTOE=1
;^LAC("LRAC",582,1,4,1,1,1,0,1,0) = ^64.705^7^7
;^LAC("LRAC",582,1,4,1,1,1,0,1,1,0) = 76.^^2
;F S LRTOE=$
;
Q
CHKLAC ;
Q:'$D(LRNODE)
S LRODT=$P(LRNODE,U,3)
;
I '$D(LRODT) S ^TMP("LR",$J,"CANT",LRDFN)="" QUIT
;
S LRIDT=9999999-LRODT S LRODT=$P(LRODT,".")
D LAC(LRDFN,LRODT,LRIDT)
Q
FIXLR ;
;S ^LR(582,"CH",9999999,0)="0^1^2970522.101919^389^72^CH 0522 106^^MONARCH 24332^58-2*"
;
S %Y="^LR(LRDFN,LRSUB,LRIDT,"
S %X="^LR(LRDFN,LRSUB,9999999,"
D %XY^%RCR
S ^LR(LRDFN,LRSUB,LRIDT,0)=$G(^LR(LRDFN,LRSUB,9999999,0))
S $P(^LR(LRDFN,LRSUB,LRIDT,0),U)=LRODT1
K ^LR(LRDFN,LRSUB,9999999)
Q
FIX68 ;
; COLL. TIME
;^LRO(69,2970522,1,434,1)=2970522.073815^1^1658^C^^^^550
;
Q:$G(LRSN)'>0
Q:'$D(^LRO(69,LRODT,1,LRSN,1))
S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5)=LRIDT
S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U)=+^LRO(69,LRODT,1,LRSN,1)
;
Q
;
JOBTIME ;
;
Q:IOST'["C-"
;
;
K LRALT
S (LRT70,LRJT0,XPDIDVT)=LRCNTLR,LRIN=0,LRA=1,LRI=1
I IOST["C-" D INIT^XPDID
S XPDIDTOT=LRCNTLR
;
;
Q:$E(IOST,1,2)'="C-"
S OK=1
S DX=1,DY=8 X IOXY
D SCRNON
QUIT
;
MOVE ;
Q:IOST'["C-"
;
I LRJT0<80 D ALT QUIT
Q:$G(LRALT)=1
S LRECIP=+$P((LRJT0/70),".") I LRECIP<1 S LRECIP=1
S DX=(2+LRIN)/LRECIP,DY=8 X IOXY D
. I '$G(LRTIC) S LRTIC=$P((LRJT0/70),".")
. S LRTIC=LRTIC+LRECIP S LRIN=LRIN+1
. D UPDATE^XPDID(LRIN)
. QUIT
. W IORVON
. W ">"
. W IORVOFF
. S DX=38,DY=10 X IOXY
. W IOELALL
. W $P((LRIN/LRJT0)*100,"."),"%"
;I 'OK D SCRNOFF
;
;
;
Q
ALT ;
Q:IOST'["C-"
;
Q:$G(LRALT)=1
S (LRT70,LRJT0)=LRCNTLR,LRIN=0,LRA=1,LRI=1
S LRALT=1
S LRTJ0=70
F I=1:1:70 D
. S DX=(2+LRIN),DY=8 X IOXY D
. S LRIN=LRIN+1
. D UPDATE^XPDID(LRIN)
. QUIT
. W IORVON
. W ">"
. W IORVOFF
. S DX=38,DY=10 X IOXY
. W IOELALL
. S LRHUN=(LRIN/LRJT0)*100 I LRHUN>100 S LRHUN=100
. W $P(LRHUN,"."),"%"
;
Q
;
SCRNON ;
Q:IOST'["C-"
;D GSET^%ZISS W IOG1
D ENS^%ZISS S %ZIS="I"
D FLASH
Q
FLASH ;
Q
;S LRDT7=LRIDT
I '$G(LRDT7) S LRDT7=LR(1)
S DX=13,DY=20 X IOXY
;W IORVON
W IODHLT,$$CJ^XLFSTR($$FMTE^XLFDT(LRDT7,"D"),IOM)
S DY=DY+1 X IOXY
W IODHLB,$$CJ^XLFSTR($$FMTE^XLFDT(LRDT7,"D"),IOM)
;W IOIND
;W IORVOFF
;S DY=DY-1 X IOXY
;W " "
;S DY=DY+3 X IOXY
;W $G(LRI)
Q
SCRNOFF ;
Q:IOST'["C-"
;
S (LRT70,LRJT0,XPDIDVT)=LRCNTLR,LRIN=0,LRA=1,LRI=1
D EXIT^XPDID("DONE")
;W IOBOFF
;D KILL^%ZISS
;
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRNINES7 7101 printed Oct 16, 2024@18:18:53 Page 2
LRNINES7 ;DAL/HOAK SEARCH FOR 7 9s ; 10/14/96 16:02
+1 ;;5.2;LAB SERVICE;**156**;Sep 27, 1994
+2 ;
INIT ;
+1 ;
+2 ;
+3 ;^LR(582,"CH",9999999,0) = 0^1^2970522.101919^389^72^CH 0522 106^^MONARCH 2
CONTROL ;
+1 KILL ^TMP("LR",$JOB,"7-9s")
+2 DO FINDLR
+3 SET LRTIC=""
+4 ;
+5 DO FIXALL
END ;
+1 ;
DONE WRITE !!,"All occurences of 7 9s have been removed and their effects in"
+1 WRITE !,"your data base have been disarmed.",!
+2 DO ^LRKILL
+3 QUIT
+4 ;
TASK ;
+1 ;-->Task the job to look for 7-9s that were created Today
+2 ;
+3 KILL ^TMP("LR",$JOB,"7-9s")
+4 ;
+5 SET LRCOUNT=0
+6 SET LRCNTLR=500
+7 SET LRT70=LRCNTLR
SET LRIN=0
SET LRA=1
SET LRI=1
+8 IF IOST["C-"
WRITE @IOF
Begin DoDot:1
+9 SET DX=3
SET DY=10
XECUTE IOXY
+10 DO JOBTIME
+11 DO TITLE^XPDID("SEARCHING ^LR(")
End DoDot:1
+12 ;
+13 SET X1=DT
SET X2=-1
DO C^%DTC
SET LRDT0=X
+14 SET LRDFN=0
+15 FOR LRODT=LRDT0,DT
Begin DoDot:1
+16 FOR
SET LRDFN=$ORDER(^LRO(69,LRODT,1,"AA",LRDFN))
if +LRDFN'>0
QUIT
DO SET(LRDFN)
End DoDot:1
+17 ;
+18 ;
+19 DO SCRNOFF
+20 IF '$DATA(TMP("LR",$JOB,"7-9s"))
Begin DoDot:1
+21 if IOST'["C-"
QUIT
+22 WRITE !!,"Mission debreifing:"
+23 WRITE !,"No problems related to 7-9s have been observed for Yesterday and Today."
End DoDot:1
+24 QUIT
+25 ;
FINDLR ;----------find ALL the 7 nines in ALL OF LR
+1 ;---> ^LR(0)=LAB DATA^63^464^355
+2 ;
+3 SET LRCNTLR=$PIECE(^LR(0),U,4)
+4 SET LRT70=LRCNTLR
SET LRIN=0
SET LRA=1
SET LRI=1
+5 ;
+6 IF IOST["C-"
WRITE @IOF
Begin DoDot:1
+7 SET DX=3
SET DY=10
XECUTE IOXY
+8 DO JOBTIME
+9 DO TITLE^XPDID("SEARCHING ^LR(")
End DoDot:1
+10 SET LRDFN=0
SET LRCOUNT=0
+11 FOR
SET LRDFN=$ORDER(^LR(LRDFN))
if +LRDFN'>0
QUIT
Begin DoDot:1
+12 ;--------check all ^LR(subscripts
+13 DO SET(LRDFN)
End DoDot:1
+14 SET DX=5
SET DY=15
XECUTE IOXY
+15 WRITE "Found ",LRCOUNT," occurrances of 7 9s in ^LR"
HANG 2
+16 DO SCRNOFF
+17 QUIT
+18 ;
SET(LRDFN) ;
+1 ;
+2 ;
+3 IF IOST["C-"
DO MOVE
+4 FOR LRSUB="CH","MI"
Begin DoDot:1
+5 IF $DATA(^LR(LRDFN,LRSUB,9999999,0))
Begin DoDot:2
+6 SET ^TMP("LR",$JOB,"7-9s",LRDFN,LRSUB)=""
SET LRCOUNT=LRCOUNT+1
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
FIXALL ;
+1 ;
+2 ;
COUNT ;
+1 SET LRCOUNT=0
+2 SET LRX6=0
+3 FOR
SET LRX6=$ORDER(^TMP("LR",$JOB,"7-9s",LRX6))
if +LRX6'>0
QUIT
SET LRCOUNT=LRCOUNT+1
+4 SET LRCNTLR=LRCOUNT
+5 IF IOST["C-"
WRITE @IOF
Begin DoDot:1
+6 SET DX=3
SET DY=10
XECUTE IOXY
+7 DO JOBTIME
+8 DO TITLE^XPDID("Fixing ^LR(, ^LRO(68, ^LRO(69, and ^LAC(")
End DoDot:1
+9 SET LRDFN=0
+10 FOR
SET LRDFN=$ORDER(^TMP("LR",$JOB,"7-9s",LRDFN))
if +LRDFN'>0
QUIT
Begin DoDot:1
+11 SET LRSUB=""
+12 FOR
SET LRSUB=$ORDER(^TMP("LR",$JOB,"7-9s",LRDFN,LRSUB))
if LRSUB=""
QUIT
Begin DoDot:2
+13 IF IOST["C-"
DO MOVE
+14 if '$DATA(^LR(LRDFN,LRSUB,9999999,0))
QUIT
+15 SET LRNODE=^LR(LRDFN,LRSUB,9999999,0)
+16 DO ACCN(LRNODE)
End DoDot:2
End DoDot:1
+17 IF IOST["C-"
DO MOVE
+18 QUIT
+19 ;
+20 ;
ACCN(LRNODE) ;
+1 ;-->If LRNODE is not there or it is not an accn we still could
+2 ;--> LAC( involved
+3 ;
+4 IF '$DATA(LRNODE)
DO CHKLAC
QUIT
+5 ;
+6 KILL LRAA,LRAD,LRAN,LRACCN,LRODT,LRSN
+7 ;
+8 ;
BAKDOR ;-->Maybe the ^LAC can provide accn.
+1 ;
+2 ;--CH 0522 106
SET LRACCN=$PIECE(LRNODE,U,6)
+3 SET LRAA=$ORDER(^LRO(68,"B",$PIECE(LRACCN," "),0))
+4 ;-- 297_0522
SET LRAD=$EXTRACT($PIECE(LRNODE,U,3),1,3)_$PIECE(LRACCN," ",2)
+5 ;--106
SET LRAN=$PIECE(LRACCN," ",3)
+6 IF $GET(LRAA)'>0!($LENGTH(LRAD)'>4)!($GET(LRAN)'>0)
SET LROK=0
QUIT
LRSN ;
+1 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
SET LRSN=$PIECE(^(0),U,5)
LRODT ;
+1 IF $GET(LRSN)>0
SET LRODT=+$GET(^LRO(69,LRAD,1,LRSN,1))
+2 ;
+3 ;
+4 IF $GET(LRODT)'>0
IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
SET LRODT=LRAD
+5 IF $GET(LRODT)'>0
IF $PIECE(LRNODE,U,3)'=""
SET LRODT=$PIECE(LRNODE,U,3)
Begin DoDot:1
+6 SET LRODT1=LRODT
+7 SET LRODT=$PIECE(LRODT,".")
+8 IF $GET(LRODT1)>0
SET LRIDT=9999999-LRODT1
+9 DO LAC(LRDFN,LRODT1,LRIDT)
KILL LRODT
End DoDot:1
+10 if '$GET(LRODT)
QUIT
+11 ;
+12 ;
LRIDT ;
+1 ;
+2 SET LRODT1=LRODT
+3 SET LRODT=$PIECE(LRODT,".")
+4 IF $GET(LRODT1)>0
SET LRIDT=9999999-LRODT1
+5 ;
+6 DO FIX68
+7 ;
BYE68 DO LAC(LRDFN,LRODT1,LRIDT)
+1 ;
+2 QUIT
+3 ;
LAC(LRDFN,LRODT,LRIDT) ;
+1 KILL LRTOE
+2 ;^LAC("LRAC",34390,1,22,1,1,1,2970702.184153,0)
+3 ;^LAC("LRAC",582,1,4,1,1,1,0,0) = 0^58-2*^2970522.101919^CH 0522 106^9999999
+4 ;^LAC("LRAC",582,1,4,1,1,1,0,1,0) = ^64.705^7^7
+5 ;
+6 SET LRTIC=0
+7 FOR
SET LRTIC=$ORDER(^LAC("LRAC",LRDFN,1,LRTIC))
if +LRTIC'>0
QUIT
Begin DoDot:1
+8 SET LRTAC=0
+9 FOR
SET LRTAC=$ORDER(^LAC("LRAC",LRDFN,1,LRTIC,1,LRTAC))
if +LRTAC'>0
QUIT
Begin DoDot:2
+10 if '$DATA(^LAC("LRAC",LRDFN,1,LRTIC,1,LRTAC,1,0,0))
QUIT
SET LACNODE=^(0)
+11 IF $PIECE(LACNODE,U)=0
DO FIXLAC
+12 SET LRACCN=$PIECE(LACNODE,U,4)
+13 ;I $G(LRAN)'>0,$D(LRACCN) D BAKDOR
End DoDot:2
End DoDot:1
+14 if '$GET(LRTOE)
DO FIXLR
+15 QUIT
FIXLAC ;
+1 ;^LAC("LRAC",34390,1,22,1,1,1,2970702.184153,0)
+2 ; good girl-> /\
+3 SET LRLONG=$LENGTH(LACNODE)
+4 SET LACNODE=$EXTRACT(LACNODE,2,LRLONG)
+5 ; ^LAC("LRAC",582,1,4,1,1,1,0,1,7,0) = 20.^L^8
+6 ;^LAC("LRAC",582,1,4,1,1,1,0,0) = 0^58-2*^2970522.101919^CH 0522 106^9999999-----------------------------/\<----bad girl
+7 SET %Y="^LAC(""LRAC"",LRDFN,1,LRTIC,1,LRTAC,1,LRODT1,"
+8 SET %X="^LAC(""LRAC"",LRDFN,1,LRTIC,1,LRTAC,1,0,"
+9 DO %XY^%RCR
+10 SET $PIECE(^LAC("LRAC",LRDFN,1,LRTIC,1,LRTAC,1,LRODT1,0),U)=LRODT1
+11 SET $PIECE(^LAC("LRAC",LRDFN,1,LRTIC,1,LRTAC,1,LRODT1,0),U,5)=LRIDT
+12 KILL ^LAC("LRAC",LRDFN,1,LRTIC,1,LRTAC,1,0)
+13 ;
+14 DO FIXLR
+15 SET LRTOE=1
+16 ;^LAC("LRAC",582,1,4,1,1,1,0,1,0) = ^64.705^7^7
+17 ;^LAC("LRAC",582,1,4,1,1,1,0,1,1,0) = 76.^^2
+18 ;F S LRTOE=$
+19 ;
+20 QUIT
CHKLAC ;
+1 if '$DATA(LRNODE)
QUIT
+2 SET LRODT=$PIECE(LRNODE,U,3)
+3 ;
+4 IF '$DATA(LRODT)
SET ^TMP("LR",$JOB,"CANT",LRDFN)=""
QUIT
+5 ;
+6 SET LRIDT=9999999-LRODT
SET LRODT=$PIECE(LRODT,".")
+7 DO LAC(LRDFN,LRODT,LRIDT)
+8 QUIT
FIXLR ;
+1 ;S ^LR(582,"CH",9999999,0)="0^1^2970522.101919^389^72^CH 0522 106^^MONARCH 24332^58-2*"
+2 ;
+3 SET %Y="^LR(LRDFN,LRSUB,LRIDT,"
+4 SET %X="^LR(LRDFN,LRSUB,9999999,"
+5 DO %XY^%RCR
+6 SET ^LR(LRDFN,LRSUB,LRIDT,0)=$GET(^LR(LRDFN,LRSUB,9999999,0))
+7 SET $PIECE(^LR(LRDFN,LRSUB,LRIDT,0),U)=LRODT1
+8 KILL ^LR(LRDFN,LRSUB,9999999)
+9 QUIT
FIX68 ;
+1 ; COLL. TIME
+2 ;^LRO(69,2970522,1,434,1)=2970522.073815^1^1658^C^^^^550
+3 ;
+4 if $GET(LRSN)'>0
QUIT
+5 if '$DATA(^LRO(69,LRODT,1,LRSN,1))
QUIT
+6 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5)=LRIDT
+7 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U)=+^LRO(69,LRODT,1,LRSN,1)
+8 ;
+9 QUIT
+10 ;
JOBTIME ;
+1 ;
+2 if IOST'["C-"
QUIT
+3 ;
+4 ;
+5 KILL LRALT
+6 SET (LRT70,LRJT0,XPDIDVT)=LRCNTLR
SET LRIN=0
SET LRA=1
SET LRI=1
+7 IF IOST["C-"
DO INIT^XPDID
+8 SET XPDIDTOT=LRCNTLR
+9 ;
+10 ;
+11 if $EXTRACT(IOST,1,2)'="C-"
QUIT
+12 SET OK=1
+13 SET DX=1
SET DY=8
XECUTE IOXY
+14 DO SCRNON
+15 QUIT
+16 ;
MOVE ;
+1 if IOST'["C-"
QUIT
+2 ;
+3 IF LRJT0<80
DO ALT
QUIT
+4 if $GET(LRALT)=1
QUIT
+5 SET LRECIP=+$PIECE((LRJT0/70),".")
IF LRECIP<1
SET LRECIP=1
+6 SET DX=(2+LRIN)/LRECIP
SET DY=8
XECUTE IOXY
Begin DoDot:1
+7 IF '$GET(LRTIC)
SET LRTIC=$PIECE((LRJT0/70),".")
+8 SET LRTIC=LRTIC+LRECIP
SET LRIN=LRIN+1
+9 DO UPDATE^XPDID(LRIN)
+10 QUIT
+11 WRITE IORVON
+12 WRITE ">"
+13 WRITE IORVOFF
+14 SET DX=38
SET DY=10
XECUTE IOXY
+15 WRITE IOELALL
+16 WRITE $PIECE((LRIN/LRJT0)*100,"."),"%"
End DoDot:1
+17 ;I 'OK D SCRNOFF
+18 ;
+19 ;
+20 ;
+21 QUIT
ALT ;
+1 if IOST'["C-"
QUIT
+2 ;
+3 if $GET(LRALT)=1
QUIT
+4 SET (LRT70,LRJT0)=LRCNTLR
SET LRIN=0
SET LRA=1
SET LRI=1
+5 SET LRALT=1
+6 SET LRTJ0=70
+7 FOR I=1:1:70
Begin DoDot:1
+8 SET DX=(2+LRIN)
SET DY=8
XECUTE IOXY
Begin DoDot:2
End DoDot:2
+9 SET LRIN=LRIN+1
+10 DO UPDATE^XPDID(LRIN)
+11 QUIT
+12 WRITE IORVON
+13 WRITE ">"
+14 WRITE IORVOFF
+15 SET DX=38
SET DY=10
XECUTE IOXY
+16 WRITE IOELALL
+17 SET LRHUN=(LRIN/LRJT0)*100
IF LRHUN>100
SET LRHUN=100
+18 WRITE $PIECE(LRHUN,"."),"%"
End DoDot:1
+19 ;
+20 QUIT
+21 ;
SCRNON ;
+1 if IOST'["C-"
QUIT
+2 ;D GSET^%ZISS W IOG1
+3 DO ENS^%ZISS
SET %ZIS="I"
+4 DO FLASH
+5 QUIT
FLASH ;
+1 QUIT
+2 ;S LRDT7=LRIDT
+3 IF '$GET(LRDT7)
SET LRDT7=LR(1)
+4 SET DX=13
SET DY=20
XECUTE IOXY
+5 ;W IORVON
+6 WRITE IODHLT,$$CJ^XLFSTR($$FMTE^XLFDT(LRDT7,"D"),IOM)
+7 SET DY=DY+1
XECUTE IOXY
+8 WRITE IODHLB,$$CJ^XLFSTR($$FMTE^XLFDT(LRDT7,"D"),IOM)
+9 ;W IOIND
+10 ;W IORVOFF
+11 ;S DY=DY-1 X IOXY
+12 ;W " "
+13 ;S DY=DY+3 X IOXY
+14 ;W $G(LRI)
+15 QUIT
SCRNOFF ;
+1 if IOST'["C-"
QUIT
+2 ;
+3 SET (LRT70,LRJT0,XPDIDVT)=LRCNTLR
SET LRIN=0
SET LRA=1
SET LRI=1
+4 DO EXIT^XPDID("DONE")
+5 ;W IOBOFF
+6 ;D KILL^%ZISS
+7 ;
+8 ;
+9 QUIT
