| [613] | 1 | LRTSTJAN ;SLC/RWF,DCN-JAM TESTS ONTO (OR OFF) ACCESSIONS PART2 ;8/11/97
|
|---|
| 2 | ;;5.2;LAB SERVICE;**67,100,121,128,202,221,337**;Sep 27, 1994;Build 2
|
|---|
| 3 | DELOG ;This tag is no longer available - Routine LRTSTOUT replaces this call.
|
|---|
| 4 | W @IOF,!,$$CJ^XLFSTR(" The ability to DELETE an entire ORDER/ACCESSION ",80)
|
|---|
| 5 | W $$CJ^XLFSTR("has been REPLACED. The test(s) will now be marked",80)
|
|---|
| 6 | W $$CJ^XLFSTR("as Not Performed and a reason for 'NP' will be stored",80)
|
|---|
| 7 | W $$CJ^XLFSTR("with each test. Accession numbers can't be reused",80)
|
|---|
| 8 | W $$CJ^XLFSTR("after it has been assigned to a specimen.",80)
|
|---|
| 9 | EN D ^LRPARAM G:$G(LREND) END
|
|---|
| 10 | I '$D(LRLABKY) W !?5,"You are not authorized to change test status.",! G END
|
|---|
| 11 | K LRSCNXB
|
|---|
| 12 | EN1 ;
|
|---|
| 13 | N LRTOTL,LRIFN
|
|---|
| 14 | S (LREND,LRNOP)=0 K LRNATURE
|
|---|
| 15 | D FIX^LRTSTOUT G END:$G(LREND) I $G(LRNOP) D END G EN1
|
|---|
| 16 | W ! K DIR S DIR(0)="Y",DIR("A")=" Change Entire accession to Not Perform !! ",DIR("B")="NO" D ^DIR K DIR
|
|---|
| 17 | I $D(DIRUT) G EN1
|
|---|
| 18 | S LRTOTL=Y,LRIFN=0
|
|---|
| 19 | I LRTOTL>0 D
|
|---|
| 20 | .F S LRIFN=$O(^LR(LRDFN,LRSS,LRIDT,LRIFN)) Q:LRIFN="" S:$P($G(^LR(LRDFN,LRSS,LRIDT,LRIFN)),U)="pending" $P(^LR(LRDFN,LRSS,LRIDT,LRIFN),U)=""
|
|---|
| 21 | ;I Y=0 D CHG^LRTSTOUT W !!! G EN1
|
|---|
| 22 | I LRTOTL=0 D CHG^LRTSTOUT W !!! G EN1
|
|---|
| 23 | D FX2^LRTSTOUT I $G(LREND) D END W @IOF G EN1
|
|---|
| 24 | D
|
|---|
| 25 | . N LRTSTS
|
|---|
| 26 | . S LRTSTS=0,LRNOW=$$NOW^XLFDT F S LRTSTS=+$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS)) Q:LRTSTS<1 I $D(^(LRTSTS,0))#2,'$P(^(0),U,5) D
|
|---|
| 27 | . . I $D(^LAB(60,LRTSTS,0)) S LRTNM=$P(^(0),U) D SET^LRTSTOUT
|
|---|
| 28 | L -^LRO(68,LRAA,1,LRAD,1,LRAN)
|
|---|
| 29 | I $L($G(LRSS)) L -^LR(+$G(LRDFN),LRSS,+$G(LRIDT))
|
|---|
| 30 | W @IOF,!!,"All accessioned test(s) changed",!!
|
|---|
| 31 | D END G EN1
|
|---|
| 32 | Q
|
|---|
| 33 | END K LRWRD,LRWDT1,LRTREA,LRRB,LRPRAC,LREND,LRAA,LRAD,LRAN,LRACC,LRTEST,LRTSTN,LRNATURE,LRX,LRIDIV,LRSAMP,LRGCOM,LRCOM,LRTCOM,LRDFN,LRDPF,LRACD,LRACN,LRACN0,LRDOC,LRLL,LROD0,LROD1,LROD3,LRODT,LROOS,LROS,LROSD,LROT,LRROD,LRSN,LRTSTS,LRTT,LRWL1
|
|---|
| 34 | K LRF,LRI,LRJ,LRMSTATI
|
|---|
| 35 | K I,X,X1,X2,X3,X4,DA,DR,DIC,DFN,AGE,DOB,PNM,SSN,VAIN,VADM,VAERR,VA,VA200,SSN,SEX
|
|---|
| 36 | D END^LRTSTOUT
|
|---|
| 37 | Q
|
|---|
| 38 | ULK ;Unlock ^LRO(68,
|
|---|
| 39 | I ($G(LRAA)&($G(LRAD))&($G(LRAN))) L -^LRO(68,LRAA,1,LRAD,1,LRAN)
|
|---|
| 40 | Q
|
|---|
| 41 | NEWSTART ;Set new starting accession #
|
|---|
| 42 | N LRAA,LRAD,LRAN,LRIDIV,LRX,LRACC,LREND,LRNEW
|
|---|
| 43 | S LREND=0
|
|---|
| 44 | D ^LRWU4 Q:LRAD<1
|
|---|
| 45 | N1 G NEWSTART:'$D(^LRO(68,LRAA,1,LRAD,1,0))
|
|---|
| 46 | R !,"""Next"" accession number: ",LRNEW:DTIME
|
|---|
| 47 | G NEWSTART:LRNEW="^"!(LRNEW="")
|
|---|
| 48 | K:(LRNEW<1)!(LRNEW>999999)!(LRNEW'=+LRNEW) LRNEW S:$D(LRNEW) LRNEW=LRNEW-1
|
|---|
| 49 | I '$D(LRNEW) W !,"Must be whole number between 1 and 999999, accession remains unchanged." G N1
|
|---|
| 50 | S $P(^LRO(68,LRAA,1,LRAD,1,0),U,3)=LRNEW
|
|---|
| 51 | G NEWSTART
|
|---|
| 52 | US ;ck if units selected
|
|---|
| 53 | S A=0 F S A=$O(^LR(LRDFN,1.8,A)) Q:A<1!($D(C)) S B=0 F S B=$O(^LR(LRDFN,1.8,A,1,B)) Q:B<1!($D(C)) I $P(^(B,0),"^",2)=LRIDT S C=1 Q
|
|---|
| 54 | Q
|
|---|
| 55 | OE ;
|
|---|
| 56 | I $$VER^LR7OU1<3 S ORIFN=$P(LRTS,"^",7) I ORIFN D DC^LRCENDE1
|
|---|
| 57 | I $L($G(LRGCOM)),$L($P($G(LRNATURE),"^",5)),$P(LRNATURE,"^",5)'["=>" S $P(LRNATURE,"^",5)=LRCM
|
|---|
| 58 | N I S:$G(LRTS) I(+LRTS)="" D NEW^LR7OB1(LRODT,LRSN,$S($G(LRMSTATI)=""!($G(LRMSTATI)=1):"OC",1:"SC"),$G(LRNATURE),.I,$G(LRMSTATI))
|
|---|
| 59 | Q
|
|---|
| 60 | LRACC S LREND=0 D ^LRWU4 S DA(2)=LRAA,DA(1)=LRAD
|
|---|
| 61 | Q
|
|---|
