LROLOVER ;SLC/CJS/DALISC/FHS - ROLL OVER DAILY LAB ACCESSION NUMBERS ;2/19/91 11:07 ;
;;5.2;LAB SERVICE;**65,98,160,153,201**;Sep 27, 1994
EN S:$D(ZTQUEUED) ZTREQ="@"
I $D(^LAB(69.9,1,"RO")),^("RO")=+$H W:'$D(ZTQUEUED) !!?20,"ROLLOVER NOT REQUIRED ",!!,$C(7) Q
I $P($G(^LAB(69.9,1,"RO")),U,2) W:'$D(ZTQUEUED) !,"ROLLOVER IS RUNNING. " Q
S $P(^LAB(69.9,1,"RO"),U,2)=1
D DT^DICRW S LRDT0=$$FMTE^XLFDT(DT,"5Z")
L +^LRO(68) S X="T-1",%DT="X" D ^%DT S LRYDT=Y,LRAD=DT
LRAA F LRAA=0:0 S LRAA=$O(^LRO(68,LRAA)) Q:LRAA<1 I $D(^LRO(68,LRAA,0))#2 D LRAN:$P(^(0),U,3)="D"&('$P(^(0),U,10)) W:'$D(ZTQUEUED) !,$P($G(^LRO(68,LRAA,0)),U),?40," Completed ... "
D ROLLAH
S ^LAB(69.9,1,"RO")=+$H L -^LRO(68)
W:'$D(ZTQUEUED) !!?30,"ALL DONE ....."
K %,%H,%X,%Y,LRI,LRAA,LRAD,LRAN,LRDFN,LRDPF,LRIDT,LRIOZERO,LRLL,LRLL2,LRLL3,LRODT,LRORD,LROWDT,LRPWL,LRSN,LRSS,LRSTATUS,LRYDT,POP,LRT,X,Y,Z
K LRMOVE,LRTS,LRVER,LRDFN,LROAD
Q
LRAN S LRPWL=$P(^LRO(68,LRAA,0),U,4),LRSS=$P(^(0),U,2) S:'$D(^LRO(68,LRAA,1,0)) ^(0)="^68.01DA^" S:'$D(^LRO(68,LRAA,1,LRAD,0)) ^(0)=DT,$P(^LRO(68,LRAA,1,0),U,3)=DT,$P(^(0),U,4)=1+$P(^(0),U,4)
S:'$D(^LRO(68,LRAA,1,LRAD,1,0))#2 ^(0)="^68.02PA^"
F LRAN=0:0 S LRAN=$O(^LRO(68,LRAA,1,LRYDT,1,LRAN)) Q:LRAN<1 I $D(^(LRAN,3)),'$L($P(^(3),U,4)) D OVER
Q
OVER Q:'$O(^LRO(68,LRAA,1,LRYDT,1,LRAN,4,0))
D VERCHK
Q:$D(^LRO(68,LRAA,1,DT,1,LRAN,0))#2 ;DON'T ROLL OVER SOMEONE
REQ S (LRTS,LRMOVE)=0 F S LRTS=$O(^LRO(68,LRAA,1,LRYDT,1,LRAN,4,LRTS)) Q:LRTS<.5!($G(LRMOVE)) D
. Q:'$D(^(LRTS,0))#2 Q:$P(^(0),U,5)!('$D(^LAB(60,+LRTS,0))#2)
. S LRMOVE=$S($P($G(^LAB(60,+LRTS,0)),U,17):1,'$L($P(^(0),U,5)):1,1:0)
Q:'$G(LRMOVE)
S XX=$G(^LRO(68,LRAA,1,LRYDT,1,LRAN,0)),LRDFN=+XX,LRDPF=+$P(XX,U,2),LRIDT=$P($G(^(3)),U,5) K XX
S LRUID=$G(^LRO(68,LRAA,1,LRYDT,1,LRAN,.3))
Q:LRDPF=62.3!('LRDFN)!('LRDPF)!('LRIDT)!('$L($P(LRUID,U)))
S LRSN=+$P(^LRO(68,LRAA,1,LRYDT,1,LRAN,0),U,5),LRODT=$P(^(0),U,4)
Q:'LRSN S LRSTATUS=$S($D(^LRO(69,LRODT,1,LRSN,1)):$P(^(1),U,4),1:"") Q:LRSTATUS'="C"
S $P(^LRO(68,LRAA,1,LRAD,1,0),U,4)=$P(^LRO(68,LRAA,1,LRAD,1,0),U,4)+1
XY I '$G(LRPWLX) M ^LRO(68,LRAA,1,LRAD,1,LRAN)=^LRO(68,LRAA,1,LRYDT,1,LRAN) D:$G(LRPWL) LRPWL
S LRORD=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)):+^(.1),1:0) S:LRORD ^LRO(68,LRAA,1,LRAD,1,"D",LRORD,LRAN)=""
I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) S X=+$P(^(3),U,3) I X S ^LRO(68,LRAA,1,LRAD,1,"E",X,LRAN)=""
LRI S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)="^68.04PA^0^0"
S LRI=0 F S LRI=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI)) Q:LRI<.5 S LRT=$S($D(^(LRI,0)):^(0),1:"") D TEST
I $O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)) D
. K ^LRO(68,"C",$P(LRUID,U))
. K:$L($P(LRUID,U,2)) ^LRO(68,"AF",$P(LRUID,U,2))
. K:$L($P(LRUID,U,4)) ^LRO(68,"D",$P(LRUID,U,4))
. D UID
S LROWDT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,3),^LRO(68,LRAA,1,LROWDT,1,LRAN,9)=LRAD
I $P(^LRO(68,LRAA,1,LRYDT,1,LRAN,0),U,3)'=LRYDT D CLEAN
Q
LRPWL ;
Q:'LRPWL!($D(^LRO(68,LRPWL,1,LRAD,1,LRAN,0))#2)
LRPWL1 ;
N XX,LRPWLX,LRAAX,LRUID
S LRPWLX=LRPWL,LRAAX=LRAA
S XX=^LRO(68,LRPWL,1,LRYDT,1,LRAN,0),XX(.1)=$G(^(.1)),XX(.2)=$G(^(.2)),XX(3)=$G(^(3)),XX(.4)=$G(^(.4))
S LRUID=$G(^LRO(68,LRPWL,1,LRYDT,1,LRAN,.3))
I '$D(^LRO(68,LRPWL,1,LRAD,0))#2 S ^(0)=LRAD
I '$D(^LRO(68,LRPWL,1,LRAD,1,0))#2 S ^(0)="^68.02PA^"
S $P(^LRO(68,LRPWL,1,LRAD,1,0),U,4)=1+$P(^(0),U,4)
S ^LRO(68,LRPWL,1,LRAD,1,LRAN,0)=XX,^(.1)=XX(.1),^(.2)=XX(.2),^(3)=XX(3),^(.3)=LRUID,^(.4)=XX(.4)
S ^LRO(68,LRPWL,1,LRAD,1,"D",+XX(.1),LRAN)=""
S ^LRO(68,LRPWL,1,LRAD,1,"E",+$P(XX(3),U,3),LRAN)=""
S ^LRO(68,LRPWL,1,LRAD,1,LRAN,"AD")=$G(^LRO(68,LRPWL,1,LRYDT,1,LRAN,"AD"))
M ^LRO(68,LRPWL,1,LRAD,1,LRAN,5)=^LRO(68,LRPWL,1,LRYDT,1,LRAN,5)
K ^LRO(68,"C",$P(LRUID,U))
S ^LRO(68,"C",$P(LRUID,U),LRPWL,LRAD,LRAN)=""
N LRAA,LRPWL,XX,LRMOVE
S LRPWL=0,LRAA=LRPWLX
CHK S (LRTS,LRMOVE)=0 F S LRTS=$O(^LRO(68,LRAA,1,LRYDT,1,LRAN,4,LRTS)) Q:LRTS<.5!($G(LRMOVE)) D
. Q:'$D(^(LRTS,0))#2 Q:$P(^(0),U,5)!('$D(^LAB(60,+LRTS,0))#2)
. S LRMOVE=$S($P($G(^LAB(60,+LRTS,0)),U,17):1,'$L($P(^(0),U,5)):1,1:0)
Q:'$G(LRMOVE)
M ^LRO(68,LRAA,1,LRAD,1,LRAN,4)=LRO(68,LRAA,1,LRYDT,1,LRAN,4)
D LRI
Q
CLEAN Q:$G(LRDEBUG)
N DA,DIK,X,Y
I $D(^LRO(68,LRAA,1,LRYDT,1,LRAN,3)) S X=+$P(^(3),U,3) I X K ^LRO(68,LRAA,1,LRYDT,1,"E",X,LRAN)
S LRORD=$S($D(^LRO(68,LRAA,1,LRYDT,1,LRAN,.1)):+^(.1),1:0) K:LRORD ^LRO(68,LRAA,1,LRYDT,1,"D",LRORD,LRAN)
S DA=LRAN,DA(1)=LRYDT,DA(2)=LRAA,DIK="^LRO(68,"_DA(2)_",1,"_DA(1)_",1,"
D ^DIK
K ^LRO(68,LRAA,1,LRYDT,1,LRAN)
Q
TEST I '+LRT D KB K ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"AB") Q
I $P(LRT,U,5) G KB
K ^LRO(68,LRAA,1,LRAD,1,LRAN,"AE") S $P(^(0),U,12)=""
S XX=$G(^LAB(60,+LRT,0)) I $L($P(XX,U,5)),'$P(XX,U,17) G KB
S X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),$P(X,U,3)=LRI,$P(X,U,4)=($P(X,U,4)+1),^(0)=X
K ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1)
I $P(LRT,U,3) S X=$P(LRT,U,3),LRLL=$P(X,";",1),LRLL2=$P(X,";",2),LRLL3=$P(X,";",3) I $D(^LRO(68.2,LRLL,1,LRLL2,1,LRLL3,0)),$P(^(0),U,2)=LRYDT,$P(^(0),U,3)=LRAN S $P(^(0),U,2)=DT
Q
KB K ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI),^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",LRI),XX Q
UID ;These fields are also set in rtn LRX
N DA,DIE,X,Y
L +^LRO(68,"C")
S DR="16////"_$P(LRUID,U)
I $P(LRUID,U,2) D
. S DR=DR_";16.1////"_$P(LRUID,U,2)_";16.2////"_$P(LRUID,U,3)_";16.3////"_$P(LRUID,U,4)_";16.4////"_$P(LRUID,U,5)
S DA=LRAN,DA(1)=LRAD,DA(2)=LRAA,DIE="^LRO(68,"_DA(2)_",1,"_DA(1)_",1,",DLAYGO=68
D ^DIE
L -^LRO(68,"C") K DLAYGO
Q
;
ROLLAH ; Checks results stored in LAH global pending verification, updates accession date
; on zeroth node to reflect accessions that have rolled over in ACCESSION file #68.
N LRAA,LRAD,LRAN,LRLL,LRSQ,LRX,LRYDT,X,Y
S X="T-1",%DT="X" D ^%DT S LRYDT=Y D DT^LRX S LRAD=DT
S LRLL=0
F S LRLL=$O(^LAH(LRLL)) Q:'LRLL D
. L +^LAH(LRLL)
. S LRSQ=0
. F S LRSQ=$O(^LAH(LRLL,1,LRSQ)) Q:'LRSQ D
. . S LRX=$G(^LAH(LRLL,1,LRSQ,0))
. . S LRAA=+$P(LRX,"^",3),LRAN=+$P(LRX,"^",5)
. . I 'LRAA!('LRAN) Q ; No accession area/number
. . I $P(LRX,"^",4)'=LRYDT Q ; Not previous accession date
. . I $P($G(^LRO(68,LRAA,0)),"^",3)'="D"!($P(^LRO(68,LRAA,0),"^",10)) Q ;Not a "daily" accession area using rollover.
. . I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2 Q ; Accession doesn't exist.
. . I $P(LRX,"^",4)<$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",3) Q ; This entry not within range of accession's original accession date.
. . I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^")'=$P($G(^LRO(68,LRAA,1,+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",3),1,LRAN,0)),"^") Q ; LRDFN of original and rolled over accesion do not match.
. . S $P(^LAH(LRLL,1,LRSQ,0),"^",4)=LRAD ; Move accession date to accession's current date.
. L -^LAH(LRLL)
Q
VERCHK ;
N LROAD,LRDFN,LRTS,LRIDT
S LRDFN=+$G(^LRO(68,LRAA,1,LRYDT,1,LRAN,0)),LROAD=$P(^(0),U,3)
S LRIDT=$P($G(^LRO(68,LRAA,1,LRYDT,1,LRAN,3)),U,5)
I LROAD,LROAD'=LRYDT,$P($G(^LRO(68,LRAA,1,LROAD,1,LRAN,3)),U,5)=LRIDT D
. Q:+$G(^LRO(68,LRAA,1,LROAD,1,LRAN,0))'=LRDFN
. S LRTS=0
. F S LRTS=$O(^LRO(68,LRAA,1,LRYDT,1,LRAN,4,LRTS)) Q:LRTS<1 S LRNODE=$G(^(LRTS,0)) I LRNODE D
. . Q:$P(LRNODE,U,5)
. . Q:'$P($G(^LRO(68,LRAA,1,LROAD,1,LRAN,4,LRTS,0)),U,5)
. . S LRVER=^LRO(68,LRAA,1,LROAD,1,LRAN,4,LRTS,0) S $P(LRVER,U,7)=""
. . W:$G(LRDEBUG) !,"Old = ",LRNODE,!,"New = ",LRVER
. . S ^LRO(68,LRAA,1,LRYDT,1,LRAN,4,LRTS,0)=LRVER
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLROLOVER 7339 printed Dec 13, 2024@02:18:33 Page 2
LROLOVER ;SLC/CJS/DALISC/FHS - ROLL OVER DAILY LAB ACCESSION NUMBERS ;2/19/91 11:07 ;
+1 ;;5.2;LAB SERVICE;**65,98,160,153,201**;Sep 27, 1994
EN if $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 IF $DATA(^LAB(69.9,1,"RO"))
IF ^("RO")=+$HOROLOG
if '$DATA(ZTQUEUED)
WRITE !!?20,"ROLLOVER NOT REQUIRED ",!!,$CHAR(7)
QUIT
+2 IF $PIECE($GET(^LAB(69.9,1,"RO")),U,2)
if '$DATA(ZTQUEUED)
WRITE !,"ROLLOVER IS RUNNING. "
QUIT
+3 SET $PIECE(^LAB(69.9,1,"RO"),U,2)=1
+4 DO DT^DICRW
SET LRDT0=$$FMTE^XLFDT(DT,"5Z")
+5 LOCK +^LRO(68)
SET X="T-1"
SET %DT="X"
DO ^%DT
SET LRYDT=Y
SET LRAD=DT
LRAA FOR LRAA=0:0
SET LRAA=$ORDER(^LRO(68,LRAA))
if LRAA<1
QUIT
IF $DATA(^LRO(68,LRAA,0))#2
if $PIECE(^(0),U,3)="D"&('$PIECE(^(0),U,10))
DO LRAN
if '$DATA(ZTQUEUED)
WRITE !,$PIECE($GET(^LRO(68,LRAA,0)),U),?40," Completed ... "
+1 DO ROLLAH
+2 SET ^LAB(69.9,1,"RO")=+$HOROLOG
LOCK -^LRO(68)
+3 if '$DATA(ZTQUEUED)
WRITE !!?30,"ALL DONE ....."
+4 KILL %,%H,%X,%Y,LRI,LRAA,LRAD,LRAN,LRDFN,LRDPF,LRIDT,LRIOZERO,LRLL,LRLL2,LRLL3,LRODT,LRORD,LROWDT,LRPWL,LRSN,LRSS,LRSTATUS,LRYDT,POP,LRT,X,Y,Z
+5 KILL LRMOVE,LRTS,LRVER,LRDFN,LROAD
+6 QUIT
LRAN SET LRPWL=$PIECE(^LRO(68,LRAA,0),U,4)
SET LRSS=$PIECE(^(0),U,2)
if '$DATA(^LRO(68,LRAA,1,0))
SET ^(0)="^68.01DA^"
if '$DATA(^LRO(68,LRAA,1,LRAD,0))
SET ^(0)=DT
SET $PIECE(^LRO(68,LRAA,1,0),U,3)=DT
SET $PIECE(^(0),U,4)=1+$PIECE(^(0),U,4)
+1 if '$DATA(^LRO(68,LRAA,1,LRAD,1,0))#2
SET ^(0)="^68.02PA^"
+2 FOR LRAN=0:0
SET LRAN=$ORDER(^LRO(68,LRAA,1,LRYDT,1,LRAN))
if LRAN<1
QUIT
IF $DATA(^(LRAN,3))
IF '$LENGTH($PIECE(^(3),U,4))
DO OVER
+3 QUIT
OVER if '$ORDER(^LRO(68,LRAA,1,LRYDT,1,LRAN,4,0))
QUIT
+1 DO VERCHK
+2 ;DON'T ROLL OVER SOMEONE
if $DATA(^LRO(68,LRAA,1,DT,1,LRAN,0))#2
QUIT
REQ SET (LRTS,LRMOVE)=0
FOR
SET LRTS=$ORDER(^LRO(68,LRAA,1,LRYDT,1,LRAN,4,LRTS))
if LRTS<.5!($GET(LRMOVE))
QUIT
Begin DoDot:1
+1 if '$DATA(^(LRTS,0))#2
QUIT
if $PIECE(^(0),U,5)!('$DATA(^LAB(60,+LRTS,0))#2)
QUIT
+2 SET LRMOVE=$SELECT($PIECE($GET(^LAB(60,+LRTS,0)),U,17):1,'$LENGTH($PIECE(^(0),U,5)):1,1:0)
End DoDot:1
+3 if '$GET(LRMOVE)
QUIT
+4 SET XX=$GET(^LRO(68,LRAA,1,LRYDT,1,LRAN,0))
SET LRDFN=+XX
SET LRDPF=+$PIECE(XX,U,2)
SET LRIDT=$PIECE($GET(^(3)),U,5)
KILL XX
+5 SET LRUID=$GET(^LRO(68,LRAA,1,LRYDT,1,LRAN,.3))
+6 if LRDPF=62.3!('LRDFN)!('LRDPF)!('LRIDT)!('$LENGTH($PIECE(LRUID,U)))
QUIT
+7 SET LRSN=+$PIECE(^LRO(68,LRAA,1,LRYDT,1,LRAN,0),U,5)
SET LRODT=$PIECE(^(0),U,4)
+8 if 'LRSN
QUIT
SET LRSTATUS=$SELECT($DATA(^LRO(69,LRODT,1,LRSN,1)):$PIECE(^(1),U,4),1:"")
if LRSTATUS'="C"
QUIT
+9 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,0),U,4)=$PIECE(^LRO(68,LRAA,1,LRAD,1,0),U,4)+1
XY IF '$GET(LRPWLX)
MERGE ^LRO(68,LRAA,1,LRAD,1,LRAN)=^LRO(68,LRAA,1,LRYDT,1,LRAN)
if $GET(LRPWL)
DO LRPWL
+1 SET LRORD=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)):+^(.1),1:0)
if LRORD
SET ^LRO(68,LRAA,1,LRAD,1,"D",LRORD,LRAN)=""
+2 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
SET X=+$PIECE(^(3),U,3)
IF X
SET ^LRO(68,LRAA,1,LRAD,1,"E",X,LRAN)=""
LRI SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)="^68.04PA^0^0"
+1 SET LRI=0
FOR
SET LRI=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI))
if LRI<.5
QUIT
SET LRT=$SELECT($DATA(^(LRI,0)):^(0),1:"")
DO TEST
+2 IF $ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
Begin DoDot:1
+3 KILL ^LRO(68,"C",$PIECE(LRUID,U))
+4 if $LENGTH($PIECE(LRUID,U,2))
KILL ^LRO(68,"AF",$PIECE(LRUID,U,2))
+5 if $LENGTH($PIECE(LRUID,U,4))
KILL ^LRO(68,"D",$PIECE(LRUID,U,4))
+6 DO UID
End DoDot:1
+7 SET LROWDT=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,3)
SET ^LRO(68,LRAA,1,LROWDT,1,LRAN,9)=LRAD
+8 IF $PIECE(^LRO(68,LRAA,1,LRYDT,1,LRAN,0),U,3)'=LRYDT
DO CLEAN
+9 QUIT
LRPWL ;
+1 if 'LRPWL!($DATA(^LRO(68,LRPWL,1,LRAD,1,LRAN,0))#2)
QUIT
LRPWL1 ;
+1 NEW XX,LRPWLX,LRAAX,LRUID
+2 SET LRPWLX=LRPWL
SET LRAAX=LRAA
+3 SET XX=^LRO(68,LRPWL,1,LRYDT,1,LRAN,0)
SET XX(.1)=$GET(^(.1))
SET XX(.2)=$GET(^(.2))
SET XX(3)=$GET(^(3))
SET XX(.4)=$GET(^(.4))
+4 SET LRUID=$GET(^LRO(68,LRPWL,1,LRYDT,1,LRAN,.3))
+5 IF '$DATA(^LRO(68,LRPWL,1,LRAD,0))#2
SET ^(0)=LRAD
+6 IF '$DATA(^LRO(68,LRPWL,1,LRAD,1,0))#2
SET ^(0)="^68.02PA^"
+7 SET $PIECE(^LRO(68,LRPWL,1,LRAD,1,0),U,4)=1+$PIECE(^(0),U,4)
+8 SET ^LRO(68,LRPWL,1,LRAD,1,LRAN,0)=XX
SET ^(.1)=XX(.1)
SET ^(.2)=XX(.2)
SET ^(3)=XX(3)
SET ^(.3)=LRUID
SET ^(.4)=XX(.4)
+9 SET ^LRO(68,LRPWL,1,LRAD,1,"D",+XX(.1),LRAN)=""
+10 SET ^LRO(68,LRPWL,1,LRAD,1,"E",+$PIECE(XX(3),U,3),LRAN)=""
+11 SET ^LRO(68,LRPWL,1,LRAD,1,LRAN,"AD")=$GET(^LRO(68,LRPWL,1,LRYDT,1,LRAN,"AD"))
+12 MERGE ^LRO(68,LRPWL,1,LRAD,1,LRAN,5)=^LRO(68,LRPWL,1,LRYDT,1,LRAN,5)
+13 KILL ^LRO(68,"C",$PIECE(LRUID,U))
+14 SET ^LRO(68,"C",$PIECE(LRUID,U),LRPWL,LRAD,LRAN)=""
+15 NEW LRAA,LRPWL,XX,LRMOVE
+16 SET LRPWL=0
SET LRAA=LRPWLX
CHK SET (LRTS,LRMOVE)=0
FOR
SET LRTS=$ORDER(^LRO(68,LRAA,1,LRYDT,1,LRAN,4,LRTS))
if LRTS<.5!($GET(LRMOVE))
QUIT
Begin DoDot:1
+1 if '$DATA(^(LRTS,0))#2
QUIT
if $PIECE(^(0),U,5)!('$DATA(^LAB(60,+LRTS,0))#2)
QUIT
+2 SET LRMOVE=$SELECT($PIECE($GET(^LAB(60,+LRTS,0)),U,17):1,'$LENGTH($PIECE(^(0),U,5)):1,1:0)
End DoDot:1
+3 if '$GET(LRMOVE)
QUIT
+4 MERGE ^LRO(68,LRAA,1,LRAD,1,LRAN,4)=LRO(68,LRAA,1,LRYDT,1,LRAN,4)
+5 DO LRI
+6 QUIT
CLEAN if $GET(LRDEBUG)
QUIT
+1 NEW DA,DIK,X,Y
+2 IF $DATA(^LRO(68,LRAA,1,LRYDT,1,LRAN,3))
SET X=+$PIECE(^(3),U,3)
IF X
KILL ^LRO(68,LRAA,1,LRYDT,1,"E",X,LRAN)
+3 SET LRORD=$SELECT($DATA(^LRO(68,LRAA,1,LRYDT,1,LRAN,.1)):+^(.1),1:0)
if LRORD
KILL ^LRO(68,LRAA,1,LRYDT,1,"D",LRORD,LRAN)
+4 SET DA=LRAN
SET DA(1)=LRYDT
SET DA(2)=LRAA
SET DIK="^LRO(68,"_DA(2)_",1,"_DA(1)_",1,"
+5 DO ^DIK
+6 KILL ^LRO(68,LRAA,1,LRYDT,1,LRAN)
+7 QUIT
TEST IF '+LRT
DO KB
KILL ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"AB")
QUIT
+1 IF $PIECE(LRT,U,5)
GOTO KB
+2 KILL ^LRO(68,LRAA,1,LRAD,1,LRAN,"AE")
SET $PIECE(^(0),U,12)=""
+3 SET XX=$GET(^LAB(60,+LRT,0))
IF $LENGTH($PIECE(XX,U,5))
IF '$PIECE(XX,U,17)
GOTO KB
+4 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)
SET $PIECE(X,U,3)=LRI
SET $PIECE(X,U,4)=($PIECE(X,U,4)+1)
SET ^(0)=X
+5 KILL ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1)
+6 IF $PIECE(LRT,U,3)
SET X=$PIECE(LRT,U,3)
SET LRLL=$PIECE(X,";",1)
SET LRLL2=$PIECE(X,";",2)
SET LRLL3=$PIECE(X,";",3)
IF $DATA(^LRO(68.2,LRLL,1,LRLL2,1,LRLL3,0))
IF $PIECE(^(0),U,2)=LRYDT
IF $PIECE(^(0),U,3)=LRAN
SET $PIECE(^(0),U,2)=DT
+7 QUIT
KB KILL ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI),^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",LRI),XX
QUIT
UID ;These fields are also set in rtn LRX
+1 NEW DA,DIE,X,Y
+2 LOCK +^LRO(68,"C")
+3 SET DR="16////"_$PIECE(LRUID,U)
+4 IF $PIECE(LRUID,U,2)
Begin DoDot:1
+5 SET DR=DR_";16.1////"_$PIECE(LRUID,U,2)_";16.2////"_$PIECE(LRUID,U,3)_";16.3////"_$PIECE(LRUID,U,4)_";16.4////"_$PIECE(LRUID,U,5)
End DoDot:1
+6 SET DA=LRAN
SET DA(1)=LRAD
SET DA(2)=LRAA
SET DIE="^LRO(68,"_DA(2)_",1,"_DA(1)_",1,"
SET DLAYGO=68
+7 DO ^DIE
+8 LOCK -^LRO(68,"C")
KILL DLAYGO
+9 QUIT
+10 ;
ROLLAH ; Checks results stored in LAH global pending verification, updates accession date
+1 ; on zeroth node to reflect accessions that have rolled over in ACCESSION file #68.
+2 NEW LRAA,LRAD,LRAN,LRLL,LRSQ,LRX,LRYDT,X,Y
+3 SET X="T-1"
SET %DT="X"
DO ^%DT
SET LRYDT=Y
DO DT^LRX
SET LRAD=DT
+4 SET LRLL=0
+5 FOR
SET LRLL=$ORDER(^LAH(LRLL))
if 'LRLL
QUIT
Begin DoDot:1
+6 LOCK +^LAH(LRLL)
+7 SET LRSQ=0
+8 FOR
SET LRSQ=$ORDER(^LAH(LRLL,1,LRSQ))
if 'LRSQ
QUIT
Begin DoDot:2
+9 SET LRX=$GET(^LAH(LRLL,1,LRSQ,0))
+10 SET LRAA=+$PIECE(LRX,"^",3)
SET LRAN=+$PIECE(LRX,"^",5)
+11 ; No accession area/number
IF 'LRAA!('LRAN)
QUIT
+12 ; Not previous accession date
IF $PIECE(LRX,"^",4)'=LRYDT
QUIT
+13 ;Not a "daily" accession area using rollover.
IF $PIECE($GET(^LRO(68,LRAA,0)),"^",3)'="D"!($PIECE(^LRO(68,LRAA,0),"^",10))
QUIT
+14 ; Accession doesn't exist.
IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2
QUIT
+15 ; This entry not within range of accession's original accession date.
IF $PIECE(LRX,"^",4)<$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",3)
QUIT
+16 ; LRDFN of original and rolled over accesion do not match.
IF $PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^")'=$PIECE($GET(^LRO(68,LRAA,1,+$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",3),1,LRAN,0)),"^")
QUIT
+17 ; Move accession date to accession's current date.
SET $PIECE(^LAH(LRLL,1,LRSQ,0),"^",4)=LRAD
End DoDot:2
+18 LOCK -^LAH(LRLL)
End DoDot:1
+19 QUIT
VERCHK ;
+1 NEW LROAD,LRDFN,LRTS,LRIDT
+2 SET LRDFN=+$GET(^LRO(68,LRAA,1,LRYDT,1,LRAN,0))
SET LROAD=$PIECE(^(0),U,3)
+3 SET LRIDT=$PIECE($GET(^LRO(68,LRAA,1,LRYDT,1,LRAN,3)),U,5)
+4 IF LROAD
IF LROAD'=LRYDT
IF $PIECE($GET(^LRO(68,LRAA,1,LROAD,1,LRAN,3)),U,5)=LRIDT
Begin DoDot:1
+5 if +$GET(^LRO(68,LRAA,1,LROAD,1,LRAN,0))'=LRDFN
QUIT
+6 SET LRTS=0
+7 FOR
SET LRTS=$ORDER(^LRO(68,LRAA,1,LRYDT,1,LRAN,4,LRTS))
if LRTS<1
QUIT
SET LRNODE=$GET(^(LRTS,0))
IF LRNODE
Begin DoDot:2
+8 if $PIECE(LRNODE,U,5)
QUIT
+9 if '$PIECE($GET(^LRO(68,LRAA,1,LROAD,1,LRAN,4,LRTS,0)),U,5)
QUIT
+10 SET LRVER=^LRO(68,LRAA,1,LROAD,1,LRAN,4,LRTS,0)
SET $PIECE(LRVER,U,7)=""
+11 if $GET(LRDEBUG)
WRITE !,"Old = ",LRNODE,!,"New = ",LRVER
+12 SET ^LRO(68,LRAA,1,LRYDT,1,LRAN,4,LRTS,0)=LRVER
End DoDot:2
End DoDot:1
+13 QUIT
