LROLOVER.m

LROLOVER ;SLC/CJS/DALISC/FHS - ROLL OVER DAILY LAB ACCESSION NUMBERS ; 22-Oct-2013 09:22 ; MKK

 ;;5.2;LR;**65,98,160,153,1018,1033**;NOV 01, 1997

 ;;

EN S:$D(ZTQUEUED) ZTREQ="@"

 I $D(^LAB(69.9,1,"RO")),^("RO")=+$H W:'$D(ZTQUEUED) !!?20,"ROLLOVER NOT REQUIRED ",!!,$C(7) Q

 S U="^"

 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

 ; L +^LRO(68) S X="T-1",%DT="X" D ^%DT S LRYDT=Y D DT^LRX S LRAD=DT

 L +^LRO(68):5  S X="T-1",%DT="X" D ^%DT S LRYDT=Y D DT^LRX S LRAD=DT     ; IHS/MSC/MKK - LR*5.2*1033 -- Adding Lock Timeout

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

 K ^TMP("BLRRLMUU")     ; IHS/MSC/MKK - LR*5.2*1033

 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))  ;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")

 L +^LRO(68,"C"):5      ; IHS/MSC/MKK - LR*5.2*1033 -- Adding Lock Timeout

 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^XLFDT

 S LRLL=0

 F  S LRLL=$O(^LAH(LRLL)) Q:'LRLL  D

 . ; L +^LAH(LRLL)

 . L +^LAH(LRLL):5      ; IHS/MSC/MKK - LR*5.2*1033 -- Adding Lock Timeout

 . 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($G(^LRO(68,LRAA,0)),"^",10)) Q  ;Not a "daily" accession area using rollover.

 . . I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) 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

LROLOVER  ;SLC/CJS/DALISC/FHS - ROLL OVER DAILY LAB ACCESSION NUMBERS ; 22-Oct-2013 09:22 ; MKK

 +1       ;;5.2;LR;**65,98,160,153,1018,1033**;NOV 01, 1997

 +2       ;;

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        SET U="^"

 +3        IF $PIECE($GET(^LAB(69.9,1,"RO")),U,2)

               IF '$DATA(ZTQUEUED)

                   WRITE !,"ROLLOVER IS RUNNING. "

               QUIT 

 +4        SET $PIECE(^LAB(69.9,1,"RO"),U,2)=1

 +5       ; L +^LRO(68) S X="T-1",%DT="X" D ^%DT S LRYDT=Y D DT^LRX S LRAD=DT

 +6       ; IHS/MSC/MKK - LR*5.2*1033 -- Adding Lock Timeout

           LOCK +^LRO(68):5

           SET X="T-1"

           SET %DT="X"

           DO ^%DT

           SET LRYDT=Y

           DO DT^LRX

           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       ; IHS/MSC/MKK - LR*5.2*1033

           KILL ^TMP("BLRRLMUU")

 +7        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))

               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       ; L +^LRO(68,"C")

 +3       ; IHS/MSC/MKK - LR*5.2*1033 -- Adding Lock Timeout

           LOCK +^LRO(68,"C"):5

 +4        SET DR="16////"_$PIECE(LRUID,U)

 +5        IF $PIECE(LRUID,U,2)

               Begin DoDot:1

 +6                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

 +7        SET DA=LRAN

           SET DA(1)=LRAD

           SET DA(2)=LRAA

           SET DIE="^LRO(68,"_DA(2)_",1,"_DA(1)_",1,"

           SET DLAYGO=68

 +8        DO ^DIE

 +9        LOCK -^LRO(68,"C")

           KILL DLAYGO

 +10       QUIT 

 +11      ;

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

 +4        SET LRAD=$$DT^XLFDT

 +5        SET LRLL=0

 +6        FOR 

               SET LRLL=$ORDER(^LAH(LRLL))

               IF 'LRLL

                   QUIT 

               Begin DoDot:1

 +7       ; L +^LAH(LRLL)

 +8       ; IHS/MSC/MKK - LR*5.2*1033 -- Adding Lock Timeout

                   LOCK +^LAH(LRLL):5

 +9                SET LRSQ=0