| 1 | LROLOVER ;SLC/CJS/DALISC/FHS - ROLL OVER DAILY LAB ACCESSION NUMBERS ;2/19/91 11:07 ;
|
---|
| 2 | ;;5.2;LAB SERVICE;**65,98,160,153,201**;Sep 27, 1994
|
---|
| 3 | EN S:$D(ZTQUEUED) ZTREQ="@"
|
---|
| 4 | I $D(^LAB(69.9,1,"RO")),^("RO")=+$H W:'$D(ZTQUEUED) !!?20,"ROLLOVER NOT REQUIRED ",!!,$C(7) Q
|
---|
| 5 | I $P($G(^LAB(69.9,1,"RO")),U,2) W:'$D(ZTQUEUED) !,"ROLLOVER IS RUNNING. " Q
|
---|
| 6 | S $P(^LAB(69.9,1,"RO"),U,2)=1
|
---|
| 7 | D DT^DICRW S LRDT0=$$FMTE^XLFDT(DT,"5Z")
|
---|
| 8 | L +^LRO(68) S X="T-1",%DT="X" D ^%DT S LRYDT=Y,LRAD=DT
|
---|
| 9 | 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 ... "
|
---|
| 10 | D ROLLAH
|
---|
| 11 | S ^LAB(69.9,1,"RO")=+$H L -^LRO(68)
|
---|
| 12 | W:'$D(ZTQUEUED) !!?30,"ALL DONE ....."
|
---|
| 13 | 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
|
---|
| 14 | K LRMOVE,LRTS,LRVER,LRDFN,LROAD
|
---|
| 15 | Q
|
---|
| 16 | 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)
|
---|
| 17 | S:'$D(^LRO(68,LRAA,1,LRAD,1,0))#2 ^(0)="^68.02PA^"
|
---|
| 18 | 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
|
---|
| 19 | Q
|
---|
| 20 | OVER Q:'$O(^LRO(68,LRAA,1,LRYDT,1,LRAN,4,0))
|
---|
| 21 | D VERCHK
|
---|
| 22 | Q:$D(^LRO(68,LRAA,1,DT,1,LRAN,0))#2 ;DON'T ROLL OVER SOMEONE
|
---|
| 23 | REQ S (LRTS,LRMOVE)=0 F S LRTS=$O(^LRO(68,LRAA,1,LRYDT,1,LRAN,4,LRTS)) Q:LRTS<.5!($G(LRMOVE)) D
|
---|
| 24 | . Q:'$D(^(LRTS,0))#2 Q:$P(^(0),U,5)!('$D(^LAB(60,+LRTS,0))#2)
|
---|
| 25 | . S LRMOVE=$S($P($G(^LAB(60,+LRTS,0)),U,17):1,'$L($P(^(0),U,5)):1,1:0)
|
---|
| 26 | Q:'$G(LRMOVE)
|
---|
| 27 | 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
|
---|
| 28 | S LRUID=$G(^LRO(68,LRAA,1,LRYDT,1,LRAN,.3))
|
---|
| 29 | Q:LRDPF=62.3!('LRDFN)!('LRDPF)!('LRIDT)!('$L($P(LRUID,U)))
|
---|
| 30 | S LRSN=+$P(^LRO(68,LRAA,1,LRYDT,1,LRAN,0),U,5),LRODT=$P(^(0),U,4)
|
---|
| 31 | Q:'LRSN S LRSTATUS=$S($D(^LRO(69,LRODT,1,LRSN,1)):$P(^(1),U,4),1:"") Q:LRSTATUS'="C"
|
---|
| 32 | S $P(^LRO(68,LRAA,1,LRAD,1,0),U,4)=$P(^LRO(68,LRAA,1,LRAD,1,0),U,4)+1
|
---|
| 33 | XY I '$G(LRPWLX) M ^LRO(68,LRAA,1,LRAD,1,LRAN)=^LRO(68,LRAA,1,LRYDT,1,LRAN) D:$G(LRPWL) LRPWL
|
---|
| 34 | 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)=""
|
---|
| 35 | 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)=""
|
---|
| 36 | LRI S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)="^68.04PA^0^0"
|
---|
| 37 | 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
|
---|
| 38 | I $O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)) D
|
---|
| 39 | . K ^LRO(68,"C",$P(LRUID,U))
|
---|
| 40 | . K:$L($P(LRUID,U,2)) ^LRO(68,"AF",$P(LRUID,U,2))
|
---|
| 41 | . K:$L($P(LRUID,U,4)) ^LRO(68,"D",$P(LRUID,U,4))
|
---|
| 42 | . D UID
|
---|
| 43 | S LROWDT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,3),^LRO(68,LRAA,1,LROWDT,1,LRAN,9)=LRAD
|
---|
| 44 | I $P(^LRO(68,LRAA,1,LRYDT,1,LRAN,0),U,3)'=LRYDT D CLEAN
|
---|
| 45 | Q
|
---|
| 46 | LRPWL ;
|
---|
| 47 | Q:'LRPWL!($D(^LRO(68,LRPWL,1,LRAD,1,LRAN,0))#2)
|
---|
| 48 | LRPWL1 ;
|
---|
| 49 | N XX,LRPWLX,LRAAX,LRUID
|
---|
| 50 | S LRPWLX=LRPWL,LRAAX=LRAA
|
---|
| 51 | 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))
|
---|
| 52 | S LRUID=$G(^LRO(68,LRPWL,1,LRYDT,1,LRAN,.3))
|
---|
| 53 | I '$D(^LRO(68,LRPWL,1,LRAD,0))#2 S ^(0)=LRAD
|
---|
| 54 | I '$D(^LRO(68,LRPWL,1,LRAD,1,0))#2 S ^(0)="^68.02PA^"
|
---|
| 55 | S $P(^LRO(68,LRPWL,1,LRAD,1,0),U,4)=1+$P(^(0),U,4)
|
---|
| 56 | S ^LRO(68,LRPWL,1,LRAD,1,LRAN,0)=XX,^(.1)=XX(.1),^(.2)=XX(.2),^(3)=XX(3),^(.3)=LRUID,^(.4)=XX(.4)
|
---|
| 57 | S ^LRO(68,LRPWL,1,LRAD,1,"D",+XX(.1),LRAN)=""
|
---|
| 58 | S ^LRO(68,LRPWL,1,LRAD,1,"E",+$P(XX(3),U,3),LRAN)=""
|
---|
| 59 | S ^LRO(68,LRPWL,1,LRAD,1,LRAN,"AD")=$G(^LRO(68,LRPWL,1,LRYDT,1,LRAN,"AD"))
|
---|
| 60 | M ^LRO(68,LRPWL,1,LRAD,1,LRAN,5)=^LRO(68,LRPWL,1,LRYDT,1,LRAN,5)
|
---|
| 61 | K ^LRO(68,"C",$P(LRUID,U))
|
---|
| 62 | S ^LRO(68,"C",$P(LRUID,U),LRPWL,LRAD,LRAN)=""
|
---|
| 63 | N LRAA,LRPWL,XX,LRMOVE
|
---|
| 64 | S LRPWL=0,LRAA=LRPWLX
|
---|
| 65 | CHK S (LRTS,LRMOVE)=0 F S LRTS=$O(^LRO(68,LRAA,1,LRYDT,1,LRAN,4,LRTS)) Q:LRTS<.5!($G(LRMOVE)) D
|
---|
| 66 | . Q:'$D(^(LRTS,0))#2 Q:$P(^(0),U,5)!('$D(^LAB(60,+LRTS,0))#2)
|
---|
| 67 | . S LRMOVE=$S($P($G(^LAB(60,+LRTS,0)),U,17):1,'$L($P(^(0),U,5)):1,1:0)
|
---|
| 68 | Q:'$G(LRMOVE)
|
---|
| 69 | M ^LRO(68,LRAA,1,LRAD,1,LRAN,4)=LRO(68,LRAA,1,LRYDT,1,LRAN,4)
|
---|
| 70 | D LRI
|
---|
| 71 | Q
|
---|
| 72 | CLEAN Q:$G(LRDEBUG)
|
---|
| 73 | N DA,DIK,X,Y
|
---|
| 74 | 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)
|
---|
| 75 | 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)
|
---|
| 76 | S DA=LRAN,DA(1)=LRYDT,DA(2)=LRAA,DIK="^LRO(68,"_DA(2)_",1,"_DA(1)_",1,"
|
---|
| 77 | D ^DIK
|
---|
| 78 | K ^LRO(68,LRAA,1,LRYDT,1,LRAN)
|
---|
| 79 | Q
|
---|
| 80 | TEST I '+LRT D KB K ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"AB") Q
|
---|
| 81 | I $P(LRT,U,5) G KB
|
---|
| 82 | K ^LRO(68,LRAA,1,LRAD,1,LRAN,"AE") S $P(^(0),U,12)=""
|
---|
| 83 | S XX=$G(^LAB(60,+LRT,0)) I $L($P(XX,U,5)),'$P(XX,U,17) G KB
|
---|
| 84 | 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
|
---|
| 85 | K ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1)
|
---|
| 86 | 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
|
---|
| 87 | Q
|
---|
| 88 | KB K ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI),^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",LRI),XX Q
|
---|
| 89 | UID ;These fields are also set in rtn LRX
|
---|
| 90 | N DA,DIE,X,Y
|
---|
| 91 | L +^LRO(68,"C")
|
---|
| 92 | S DR="16////"_$P(LRUID,U)
|
---|
| 93 | I $P(LRUID,U,2) D
|
---|
| 94 | . 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)
|
---|
| 95 | S DA=LRAN,DA(1)=LRAD,DA(2)=LRAA,DIE="^LRO(68,"_DA(2)_",1,"_DA(1)_",1,",DLAYGO=68
|
---|
| 96 | D ^DIE
|
---|
| 97 | L -^LRO(68,"C") K DLAYGO
|
---|
| 98 | Q
|
---|
| 99 | ;
|
---|
| 100 | ROLLAH ; Checks results stored in LAH global pending verification, updates accession date
|
---|
| 101 | ; on zeroth node to reflect accessions that have rolled over in ACCESSION file #68.
|
---|
| 102 | N LRAA,LRAD,LRAN,LRLL,LRSQ,LRX,LRYDT,X,Y
|
---|
| 103 | S X="T-1",%DT="X" D ^%DT S LRYDT=Y D DT^LRX S LRAD=DT
|
---|
| 104 | S LRLL=0
|
---|
| 105 | F S LRLL=$O(^LAH(LRLL)) Q:'LRLL D
|
---|
| 106 | . L +^LAH(LRLL)
|
---|
| 107 | . S LRSQ=0
|
---|
| 108 | . F S LRSQ=$O(^LAH(LRLL,1,LRSQ)) Q:'LRSQ D
|
---|
| 109 | . . S LRX=$G(^LAH(LRLL,1,LRSQ,0))
|
---|
| 110 | . . S LRAA=+$P(LRX,"^",3),LRAN=+$P(LRX,"^",5)
|
---|
| 111 | . . I 'LRAA!('LRAN) Q ; No accession area/number
|
---|
| 112 | . . I $P(LRX,"^",4)'=LRYDT Q ; Not previous accession date
|
---|
| 113 | . . I $P($G(^LRO(68,LRAA,0)),"^",3)'="D"!($P(^LRO(68,LRAA,0),"^",10)) Q ;Not a "daily" accession area using rollover.
|
---|
| 114 | . . I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2 Q ; Accession doesn't exist.
|
---|
| 115 | . . 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.
|
---|
| 116 | . . 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.
|
---|
| 117 | . . S $P(^LAH(LRLL,1,LRSQ,0),"^",4)=LRAD ; Move accession date to accession's current date.
|
---|
| 118 | . L -^LAH(LRLL)
|
---|
| 119 | Q
|
---|
| 120 | VERCHK ;
|
---|
| 121 | N LROAD,LRDFN,LRTS,LRIDT
|
---|
| 122 | S LRDFN=+$G(^LRO(68,LRAA,1,LRYDT,1,LRAN,0)),LROAD=$P(^(0),U,3)
|
---|
| 123 | S LRIDT=$P($G(^LRO(68,LRAA,1,LRYDT,1,LRAN,3)),U,5)
|
---|
| 124 | I LROAD,LROAD'=LRYDT,$P($G(^LRO(68,LRAA,1,LROAD,1,LRAN,3)),U,5)=LRIDT D
|
---|
| 125 | . Q:+$G(^LRO(68,LRAA,1,LROAD,1,LRAN,0))'=LRDFN
|
---|
| 126 | . S LRTS=0
|
---|
| 127 | . F S LRTS=$O(^LRO(68,LRAA,1,LRYDT,1,LRAN,4,LRTS)) Q:LRTS<1 S LRNODE=$G(^(LRTS,0)) I LRNODE D
|
---|
| 128 | . . Q:$P(LRNODE,U,5)
|
---|
| 129 | . . Q:'$P($G(^LRO(68,LRAA,1,LROAD,1,LRAN,4,LRTS,0)),U,5)
|
---|
| 130 | . . S LRVER=^LRO(68,LRAA,1,LROAD,1,LRAN,4,LRTS,0) S $P(LRVER,U,7)=""
|
---|
| 131 | . . W:$G(LRDEBUG) !,"Old = ",LRNODE,!,"New = ",LRVER
|
---|
| 132 | . . S ^LRO(68,LRAA,1,LRYDT,1,LRAN,4,LRTS,0)=LRVER
|
---|
| 133 | Q
|
---|