LRTSTJAN ;SLC/RWF/DCN - JAM TESTS ONTO (OR OFF) ACCESSIONS PART2 ;02/28/12 19:53
;;5.2;LAB SERVICE;**67,100,121,128,202,221,337,350**;Sep 27, 1994;Build 230
;
DELOG ;This tag is no longer available - Routine LRTSTOUT replaces this call.
W @IOF,!,$$CJ^XLFSTR(" The ability to DELETE an entire ORDER/ACCESSION ",IOM)
W !,$$CJ^XLFSTR("has been REPLACED. The test(s) will now be marked",IOM)
W !,$$CJ^XLFSTR("as Not Performed and a reason for 'NP' will be stored",IOM)
W !,$$CJ^XLFSTR("with each test. Accession numbers can't be reused",IOM)
W !,$$CJ^XLFSTR("after it has been assigned to a specimen.",IOM)
;
EN ;
D ^LRPARAM G:$G(LREND) END
I '$D(LRLABKY) W !?5,"You are not authorized to change test status.",! G END
K LRSCNXB
;
EN1 ;
N LRTOTL,LRIFN
S (LREND,LRNOP)=0 K LRNATURE
D FIX^LRTSTOUT G END:$G(LREND) I $G(LRNOP) D END G EN1
W ! K DIR S DIR(0)="Y",DIR("A")=" Change Entire accession to Not Performed",DIR("B")="NO" D ^DIR K DIR
I $D(DIRUT) G EN1
S LRTOTL=Y,LRIFN=0
I LRTOTL>0 D
.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)=""
;I Y=0 D CHG^LRTSTOUT W !!! G EN1
I LRTOTL=0 D CHG^LRTSTOUT W !!! G EN1
D FX2^LRTSTOUT I $G(LREND) D END W @IOF G EN1
D
. N LROTA,LRTSTS
. 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
. . I $D(^LAB(60,LRTSTS,0)) S LRTNM=$P(^(0),U) D
. . . D SET^LRTSTOUT
. . . D LEDICHK^LRTSTOUT ; If LEDI test, add test to LROTA array - ccr_6164n
. I $D(LROTA) D LEDISET^LRTSTOUT(.LROTA) ; ccr_6164n
L -^LRO(68,LRAA,1,LRAD,1,LRAN)
I $G(LRSS)'="" L -^LR(+$G(LRDFN),LRSS,+$G(LRIDT))
W @IOF,!!,"All accessioned test(s) changed",!!
D END G EN1
Q
;
;
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
K LRF,LRI,LRJ,LRMSTATI
K I,X,X1,X2,X3,X4,DA,DR,DIC,DFN,AGE,DOB,PNM,SSN,VAIN,VADM,VAERR,VA,VA200,SSN,SEX
D END^LRTSTOUT
Q
;
;
ULK ;Unlock ^LRO(68,
I ($G(LRAA)&($G(LRAD))&($G(LRAN))) L -^LRO(68,LRAA,1,LRAD,1,LRAN)
Q
;
;
NEWSTART ;Set new starting accession #
N LRAA,LRAD,LRAN,LRIDIV,LRX,LRACC,LREND,LRNEW
S LREND=0
D ^LRWU4 Q:LRAD<1
;
N1 G NEWSTART:'$D(^LRO(68,LRAA,1,LRAD,1,0))
R !,"""Next"" accession number: ",LRNEW:DTIME
G NEWSTART:LRNEW="^"!(LRNEW="")
K:(LRNEW<1)!(LRNEW>999999)!(LRNEW'=+LRNEW) LRNEW S:$D(LRNEW) LRNEW=LRNEW-1
I '$D(LRNEW) W !,"Must be whole number between 1 and 999999, accession remains unchanged." G N1
S $P(^LRO(68,LRAA,1,LRAD,1,0),U,3)=LRNEW
G NEWSTART
;
;;
US ;ck if units selected
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
Q
;
;
OE ;
I $G(LRGCOM)'="",$P($G(LRNATURE),"^",5)'="",$P(LRNATURE,"^",5)'["=>" S $P(LRNATURE,"^",5)=LRCM
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))
Q
;
;
LRACC S LREND=0 D ^LRWU4 S DA(2)=LRAA,DA(1)=LRAD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRTSTJAN 3273 printed Nov 22, 2024@17:31:10 Page 2
LRTSTJAN ;SLC/RWF/DCN - JAM TESTS ONTO (OR OFF) ACCESSIONS PART2 ;02/28/12 19:53
+1 ;;5.2;LAB SERVICE;**67,100,121,128,202,221,337,350**;Sep 27, 1994;Build 230
+2 ;
DELOG ;This tag is no longer available - Routine LRTSTOUT replaces this call.
+1 WRITE @IOF,!,$$CJ^XLFSTR(" The ability to DELETE an entire ORDER/ACCESSION ",IOM)
+2 WRITE !,$$CJ^XLFSTR("has been REPLACED. The test(s) will now be marked",IOM)
+3 WRITE !,$$CJ^XLFSTR("as Not Performed and a reason for 'NP' will be stored",IOM)
+4 WRITE !,$$CJ^XLFSTR("with each test. Accession numbers can't be reused",IOM)
+5 WRITE !,$$CJ^XLFSTR("after it has been assigned to a specimen.",IOM)
+6 ;
EN ;
+1 DO ^LRPARAM
if $GET(LREND)
GOTO END
+2 IF '$DATA(LRLABKY)
WRITE !?5,"You are not authorized to change test status.",!
GOTO END
+3 KILL LRSCNXB
+4 ;
EN1 ;
+1 NEW LRTOTL,LRIFN
+2 SET (LREND,LRNOP)=0
KILL LRNATURE
+3 DO FIX^LRTSTOUT
if $GET(LREND)
GOTO END
IF $GET(LRNOP)
DO END
GOTO EN1
+4 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("A")=" Change Entire accession to Not Performed"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
GOTO EN1
+6 SET LRTOTL=Y
SET LRIFN=0
+7 IF LRTOTL>0
Begin DoDot:1
+8 FOR
SET LRIFN=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRIFN))
if LRIFN=""
QUIT
if $PIECE($GET(^LR(LRDFN,LRSS,LRIDT,LRIFN)),U)="pending"
SET $PIECE(^LR(LRDFN,LRSS,LRIDT,LRIFN),U)=""
End DoDot:1
+9 ;I Y=0 D CHG^LRTSTOUT W !!! G EN1
+10 IF LRTOTL=0
DO CHG^LRTSTOUT
WRITE !!!
GOTO EN1
+11 DO FX2^LRTSTOUT
IF $GET(LREND)
DO END
WRITE @IOF
GOTO EN1
+12 Begin DoDot:1
+13 NEW LROTA,LRTSTS
+14 SET LRTSTS=0
SET LRNOW=$$NOW^XLFDT
FOR
SET LRTSTS=+$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS))
if LRTSTS<1
QUIT
IF $DATA(^(LRTSTS,0))#2
IF '$PIECE(^(0),U,5)
Begin DoDot:2
+15 IF $DATA(^LAB(60,LRTSTS,0))
SET LRTNM=$PIECE(^(0),U)
Begin DoDot:3
+16 DO SET^LRTSTOUT
+17 ; If LEDI test, add test to LROTA array - ccr_6164n
DO LEDICHK^LRTSTOUT
End DoDot:3
End DoDot:2
+18 ; ccr_6164n
IF $DATA(LROTA)
DO LEDISET^LRTSTOUT(.LROTA)
End DoDot:1
+19 LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)
+20 IF $GET(LRSS)'=""
LOCK -^LR(+$GET(LRDFN),LRSS,+$GET(LRIDT))
+21 WRITE @IOF,!!,"All accessioned test(s) changed",!!
+22 DO END
GOTO EN1
+23 QUIT
+24 ;
+25 ;
END KILL 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
+1 KILL LRF,LRI,LRJ,LRMSTATI
+2 KILL I,X,X1,X2,X3,X4,DA,DR,DIC,DFN,AGE,DOB,PNM,SSN,VAIN,VADM,VAERR,VA,VA200,SSN,SEX
+3 DO END^LRTSTOUT
+4 QUIT
+5 ;
+6 ;
ULK ;Unlock ^LRO(68,
+1 IF ($GET(LRAA)&($GET(LRAD))&($GET(LRAN)))
LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)
+2 QUIT
+3 ;
+4 ;
NEWSTART ;Set new starting accession #
+1 NEW LRAA,LRAD,LRAN,LRIDIV,LRX,LRACC,LREND,LRNEW
+2 SET LREND=0
+3 DO ^LRWU4
if LRAD<1
QUIT
+4 ;
N1 if '$DATA(^LRO(68,LRAA,1,LRAD,1,0))
GOTO NEWSTART
+1 READ !,"""Next"" accession number: ",LRNEW:DTIME
+2 if LRNEW="^"!(LRNEW="")
GOTO NEWSTART
+3 if (LRNEW<1)!(LRNEW>999999)!(LRNEW'=+LRNEW)
KILL LRNEW
if $DATA(LRNEW)
SET LRNEW=LRNEW-1
+4 IF '$DATA(LRNEW)
WRITE !,"Must be whole number between 1 and 999999, accession remains unchanged."
GOTO N1
+5 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,0),U,3)=LRNEW
+6 GOTO NEWSTART
+7 ;
+8 ;;
US ;ck if units selected
+1 SET A=0
FOR
SET A=$ORDER(^LR(LRDFN,1.8,A))
if A<1!($DATA(C))
QUIT
SET B=0
FOR
SET B=$ORDER(^LR(LRDFN,1.8,A,1,B))
if B<1!($DATA(C))
QUIT
IF $PIECE(^(B,0),"^",2)=LRIDT
SET C=1
QUIT
+2 QUIT
+3 ;
+4 ;
OE ;
+1 IF $GET(LRGCOM)'=""
IF $PIECE($GET(LRNATURE),"^",5)'=""
IF $PIECE(LRNATURE,"^",5)'["=>"
SET $PIECE(LRNATURE,"^",5)=LRCM
+2 NEW I
if $GET(LRTS)
SET I(+LRTS)=""
DO NEW^LR7OB1(LRODT,LRSN,$SELECT($GET(LRMSTATI)=""!($GET(LRMSTATI)=1):"OC",1:"SC"),$GET(LRNATURE),.I,$GET(LRMSTATI))
+3 QUIT
+4 ;
+5 ;
LRACC SET LREND=0
DO ^LRWU4
SET DA(2)=LRAA
SET DA(1)=LRAD
+1 QUIT
