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