source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LROLOVER.m@ 1800

Last change on this file since 1800 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.0 KB
Line 
1LROLOVER ;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
3EN 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
9LRAA 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
16LRAN 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
20OVER 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
23REQ 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
33XY 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)=""
36LRI 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
46LRPWL ;
47 Q:'LRPWL!($D(^LRO(68,LRPWL,1,LRAD,1,LRAN,0))#2)
48LRPWL1 ;
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
65CHK 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
72CLEAN 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
80TEST 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
88KB K ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI),^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",LRI),XX Q
89UID ;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 ;
100ROLLAH ; 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
120VERCHK ;
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
Note: See TracBrowser for help on using the repository browser.