LAMIAUT4 ;SLC/FHS - EDIT OR VERIFY MICRO AUTO INSTRUMENTS ;05/02/13
;;5.2;AUTOMATED LAB INSTRUMENTS;**153,80**;Sep 27, 1994;Build 19
EN ;
Q:LREND R !!," ('E'dit data, 'C'omments, 'O'rganism 'W'orklist) // ",LREDIT:DTIME Q:'$T
I $E(LREDIT)="?" D HLP,^LAMIAUT3 G EN
I $E(LREDIT)="^"!($E(LREDIT="@")) D DEL^LAMIAUT5 K LRBDUP,LRMOVE Q
K DIC,DR,DIE,DA S DA=LRIDT,DA(1)=LRDFN,LRY(0)=^LR(LRDFN,"MI",LRIDT,0),DIE="^LR("_DA(1)_",""MI"",",DIC=DIE I $E(LREDIT)="E" S ZX9=X9 D EDIT,^LAMIAUT3 S X9=ZX9 K ZX9 G EN
I $E(LREDIT)="O" S ZX9=X9 D ^LRMIBUG,^LAMIAUT3 S X9=ZX9 K ZX9 G EN
I $E(LREDIT)="C" K DR S DR=".99;1;13" D ^DIE D ^LAMIAUT3 G EN
I $E(LREDIT)="W" D EN^LRCAPV D ^LAMIAUT3 G EN
R !,"Approve for release by entering your initials: ",X:DTIME I '$T!($E(X)="^") D DEL^LAMIAUT5 Q
I X'=LRINI W !!,$C(7)," NOT APPROVED " Q
D VER Q
EXP ;Get the list of tests for this ACC.
W !!,PNM," ",SSN,!,LRACCN D INF^LRX W !!?5,$P(^LAB(61,LRSPEC,0),U)," ",$P(^LAB(62,LRSAMP,0),U),!
K ^TMP("LR",$J),LRTEST,LRNAME,LRTS S N=0 F I=0:0 S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<1 S N=N+1,LRTEST(N)=+^(I,0),LRTEST(N,"P")=$P(^(0),U,9)
S LRNTN=N F I=1:1:N S:$D(^LAB(60,+LRTEST(I),0)) LRTEST(I)=LRTEST(I)_U_^(0),LRNAME(I)=$P(LRTEST(I),U,2),LRNAME(I,+LRTEST(I))="",LRTS(I)=LRNAME(I),LRTS(I,+LRTEST(I))=""
S LRALL="" F I=1:1:LRNTN I $D(LRNAME(I)) S LRALL=LRALL_","_I W !,I," ",LRNAME(I) I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+$O(LRNAME(I,0)),0)),$P(^(0),U,5) W ?25," verified"
V9 S LRALL=$P(LRALL,",",2,99) R !!,"TEST #(s) (or ""ALL""): ",X:DTIME S:'$T X=U S:X="" X=LRALL S:X["A" X=LRALL S:$E(X)="^" LREND=1 Q:LREND
I X["?" W !,"Enter for example 1,2,5-9." G V9
Q:$E(X)="^" D RANGE^LRWU2 Q:X9="" X (X9_"S:'$D(LRNAME(T1)) X=0") I X=0 W !!?7,"Incorrect test number ",$C(7) G EXP
L10 S LRNX=0 X (X9_"D EX1^LRVER1")
Q
EDIT S LRALL="" W !?7,"Edit ? ",! F I=0:0 S I=$O(LRNAME(I)) Q:I="" W !?3,"(",I,") ",LRNAME(I) S LRALL=LRALL_","_I I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,$O(LRNAME(I,0)),0)),$P(^(0),U,5) W ?25,"Verified "
S LRALL=$P(LRALL,",",2,99) R !!,"TEST #(s) (or ""ALL""): ",X:DTIME Q:'$T!($E(X)="^") S:X["A" X=LRALL S:X="" X=LRALL
I X["?" W !?7,"Enter for example 1,2,5-9 ",! G EDIT
D RANGE^LRWU2 Q:X9="" X (X9_"S:'$D(LRNAME(T1)) X=0") I X=0 W !!?7,"Incorrect number ",$C(7),! G EDIT
X (X9_"S LRTS=+$O(LRTS(T1,0)) I LRTS D EDIT1^LAMIAUT4")
Q
EDIT1 S LRSB=1,LRCODE=$P(^LAB(60,+$O(LRNAME(T1,0)),0),U,14) D EDIT2
Q
EDIT2 I 'LRCODE W $C(7),!?7,"NO EDIT CODE FOR ",LRNAME(T1) Q
I '$D(^LAB(62.07,LRCODE,.1)) W $C(7),!?7,"EDIT CODE IS MISSING FOR ",LRNAME(T1) Q
N LRBG0
W !!?7,"Editing ",LRNAME(T1),!! K DR S LRTS=+$O(LRTS(T1,0)),(LRBG0,Y(0))=LRY(0) X:LRTS ^LAB(62.07,LRCODE,.1)
I 'LRTS W !,"NO TEST DEFINED ",!!,$C(7)
Q
VER ;
N LRBG0
Q:X9="" S (LRBG0,Y(0))=^LR(LRDFN,"MI",LRIDT,0),LRCAPOK=1,LRUNDO=0 I '$P(Y(0),U,3) S:$P(Y(0),U,9) LRUNDO=1 G VER1
I $P(^LR(LRDFN,"MI",LRIDT,0),U,3) W !,"Final report has been verified by micro supervisor,",$C(7),!,"If you proceed in editing, the report will be reprinted"
F I=0:0 W !?10,"OK" S %=1 D YN^DICN Q:% W !," Enter 'Y' or 'N' : "
I %=2!(%<0) Q
VER1 ;
D:'$P(^LAB(69.9,1,"NITE"),U) ANN^LRCAPV
;N LRADD,GLB,LRBUG,LRBUGY
S LRSB=1 W ! X (X9_"S LRPTP=$O(LRNAME(T1,0))") S LRCAPOK=1,Y(0)=^LR(LRDFN,"MI",LRIDT,0) D
. K DR S DR=11,LRSAME=0 D:LRUNDO UNDO^LRMIEDZ D ^DIE,TIME^LRMIEDZ3 S LRTS=LRPTP I $G(LRTS) D:LRCAPOK&($P(LRPARAM,U,14)) LOOK^LRCAPV1
N LRWRDVEW,LRUID
S LRWRDVEW=1
D VT^LRMIUT1 I $L($G(LRVT)) D STF^LRMIUT
;
;Ask for performing lab assignment
D EDIT^LRRPLU(LRDFN,LRSS,LRIDT)
;
;call clinical reminders
D UPDATE^LRPXRM(LRDFN,"MI",LRIDT)
;
;Ask to send CPRS alert
S LRUID=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
D ASKXQA^LRMIEDZ2
S ^LRO(68,"AVS",LRAA,LRAD,LRAN)=LRDFN_U_LRIDT
;Cleanup entry in LAH.
D ZAPALL^LRVR3(LRLL,LRIFN)
Q
HLP W !!?10,"ENTER",?20,"'E' TO EDIT ENTIRE ACCESSION. ",!?20,"'C' TO EDIT COMMENT",!?20,"'O' TO EDIT ORGANISM "
W !?20,"'^' OR '@' WILL DELETE TRANSFERRED DATA ",! H 2 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLAMIAUT4 4042 printed Oct 16, 2024@17:43:59 Page 2
LAMIAUT4 ;SLC/FHS - EDIT OR VERIFY MICRO AUTO INSTRUMENTS ;05/02/13
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**153,80**;Sep 27, 1994;Build 19
EN ;
+1 if LREND
QUIT
READ !!," ('E'dit data, 'C'omments, 'O'rganism 'W'orklist) // ",LREDIT:DTIME
if '$TEST
QUIT
+2 IF $EXTRACT(LREDIT)="?"
DO HLP
DO ^LAMIAUT3
GOTO EN
+3 IF $EXTRACT(LREDIT)="^"!($EXTRACT(LREDIT="@"))
DO DEL^LAMIAUT5
KILL LRBDUP,LRMOVE
QUIT
+4 KILL DIC,DR,DIE,DA
SET DA=LRIDT
SET DA(1)=LRDFN
SET LRY(0)=^LR(LRDFN,"MI",LRIDT,0)
SET DIE="^LR("_DA(1)_",""MI"","
SET DIC=DIE
IF $EXTRACT(LREDIT)="E"
SET ZX9=X9
DO EDIT
DO ^LAMIAUT3
SET X9=ZX9
KILL ZX9
GOTO EN
+5 IF $EXTRACT(LREDIT)="O"
SET ZX9=X9
DO ^LRMIBUG
DO ^LAMIAUT3
SET X9=ZX9
KILL ZX9
GOTO EN
+6 IF $EXTRACT(LREDIT)="C"
KILL DR
SET DR=".99;1;13"
DO ^DIE
DO ^LAMIAUT3
GOTO EN
+7 IF $EXTRACT(LREDIT)="W"
DO EN^LRCAPV
DO ^LAMIAUT3
GOTO EN
+8 READ !,"Approve for release by entering your initials: ",X:DTIME
IF '$TEST!($EXTRACT(X)="^")
DO DEL^LAMIAUT5
QUIT
+9 IF X'=LRINI
WRITE !!,$CHAR(7)," NOT APPROVED "
QUIT
+10 DO VER
QUIT
EXP ;Get the list of tests for this ACC.
+1 WRITE !!,PNM," ",SSN,!,LRACCN
DO INF^LRX
WRITE !!?5,$PIECE(^LAB(61,LRSPEC,0),U)," ",$PIECE(^LAB(62,LRSAMP,0),U),!
+2 KILL ^TMP("LR",$JOB),LRTEST,LRNAME,LRTS
SET N=0
FOR I=0:0
SET I=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I))
if I<1
QUIT
SET N=N+1
SET LRTEST(N)=+^(I,0)
SET LRTEST(N,"P")=$PIECE(^(0),U,9)
+3 SET LRNTN=N
FOR I=1:1:N
if $DATA(^LAB(60,+LRTEST(I),0))
SET LRTEST(I)=LRTEST(I)_U_^(0)
SET LRNAME(I)=$PIECE(LRTEST(I),U,2)
SET LRNAME(I,+LRTEST(I))=""
SET LRTS(I)=LRNAME(I)
SET LRTS(I,+LRTEST(I))=""
+4 SET LRALL=""
FOR I=1:1:LRNTN
IF $DATA(LRNAME(I))
SET LRALL=LRALL_","_I
WRITE !,I," ",LRNAME(I)
IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+$ORDER(LRNAME(I,0)),0))
IF $PIECE(^(0),U,5)
WRITE ?25," verified"
V9 SET LRALL=$PIECE(LRALL,",",2,99)
READ !!,"TEST #(s) (or ""ALL""): ",X:DTIME
if '$TEST
SET X=U
if X=""
SET X=LRALL
if X["A"
SET X=LRALL
if $EXTRACT(X)="^"
SET LREND=1
if LREND
QUIT
+1 IF X["?"
WRITE !,"Enter for example 1,2,5-9."
GOTO V9
+2 if $EXTRACT(X)="^"
QUIT
DO RANGE^LRWU2
if X9=""
QUIT
XECUTE (X9_"S:'$D(LRNAME(T1)) X=0")
IF X=0
WRITE !!?7,"Incorrect test number ",$CHAR(7)
GOTO EXP
L10 SET LRNX=0
XECUTE (X9_"D EX1^LRVER1")
+1 QUIT
EDIT SET LRALL=""
WRITE !?7,"Edit ? ",!
FOR I=0:0
SET I=$ORDER(LRNAME(I))
if I=""
QUIT
WRITE !?3,"(",I,") ",LRNAME(I)
SET LRALL=LRALL_","_I
IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,$ORDER(LRNAME(I,0)),0))
IF $PIECE(^(0),U,5)
WRITE ?25,"Verified "
+1 SET LRALL=$PIECE(LRALL,",",2,99)
READ !!,"TEST #(s) (or ""ALL""): ",X:DTIME
if '$TEST!($EXTRACT(X)="^")
QUIT
if X["A"
SET X=LRALL
if X=""
SET X=LRALL
+2 IF X["?"
WRITE !?7,"Enter for example 1,2,5-9 ",!
GOTO EDIT
+3 DO RANGE^LRWU2
if X9=""
QUIT
XECUTE (X9_"S:'$D(LRNAME(T1)) X=0")
IF X=0
WRITE !!?7,"Incorrect number ",$CHAR(7),!
GOTO EDIT
+4 XECUTE (X9_"S LRTS=+$O(LRTS(T1,0)) I LRTS D EDIT1^LAMIAUT4")
+5 QUIT
EDIT1 SET LRSB=1
SET LRCODE=$PIECE(^LAB(60,+$ORDER(LRNAME(T1,0)),0),U,14)
DO EDIT2
+1 QUIT
EDIT2 IF 'LRCODE
WRITE $CHAR(7),!?7,"NO EDIT CODE FOR ",LRNAME(T1)
QUIT
+1 IF '$DATA(^LAB(62.07,LRCODE,.1))
WRITE $CHAR(7),!?7,"EDIT CODE IS MISSING FOR ",LRNAME(T1)
QUIT
+2 NEW LRBG0
+3 WRITE !!?7,"Editing ",LRNAME(T1),!!
KILL DR
SET LRTS=+$ORDER(LRTS(T1,0))
SET (LRBG0,Y(0))=LRY(0)
if LRTS
XECUTE ^LAB(62.07,LRCODE,.1)
+4 IF 'LRTS
WRITE !,"NO TEST DEFINED ",!!,$CHAR(7)
+5 QUIT
VER ;
+1 NEW LRBG0
+2 if X9=""
QUIT
SET (LRBG0,Y(0))=^LR(LRDFN,"MI",LRIDT,0)
SET LRCAPOK=1
SET LRUNDO=0
IF '$PIECE(Y(0),U,3)
if $PIECE(Y(0),U,9)
SET LRUNDO=1
GOTO VER1
+3 IF $PIECE(^LR(LRDFN,"MI",LRIDT,0),U,3)
WRITE !,"Final report has been verified by micro supervisor,",$CHAR(7),!,"If you proceed in editing, the report will be reprinted"
+4 FOR I=0:0
WRITE !?10,"OK"
SET %=1
DO YN^DICN
if %
QUIT
WRITE !," Enter 'Y' or 'N' : "
+5 IF %=2!(%<0)
QUIT
VER1 ;
+1 if '$PIECE(^LAB(69.9,1,"NITE"),U)
DO ANN^LRCAPV
+2 ;N LRADD,GLB,LRBUG,LRBUGY
+3 SET LRSB=1
WRITE !
XECUTE (X9_"S LRPTP=$O(LRNAME(T1,0))")
SET LRCAPOK=1
SET Y(0)=^LR(LRDFN,"MI",LRIDT,0)
Begin DoDot:1
+4 KILL DR
SET DR=11
SET LRSAME=0
if LRUNDO
DO UNDO^LRMIEDZ
DO ^DIE
DO TIME^LRMIEDZ3
SET LRTS=LRPTP
IF $GET(LRTS)
if LRCAPOK&($PIECE(LRPARAM,U,14))
DO LOOK^LRCAPV1
End DoDot:1
+5 NEW LRWRDVEW,LRUID
+6 SET LRWRDVEW=1
+7 DO VT^LRMIUT1
IF $LENGTH($GET(LRVT))
DO STF^LRMIUT
+8 ;
+9 ;Ask for performing lab assignment
+10 DO EDIT^LRRPLU(LRDFN,LRSS,LRIDT)
+11 ;
+12 ;call clinical reminders
+13 DO UPDATE^LRPXRM(LRDFN,"MI",LRIDT)
+14 ;
+15 ;Ask to send CPRS alert
+16 SET LRUID=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
+17 DO ASKXQA^LRMIEDZ2
+18 SET ^LRO(68,"AVS",LRAA,LRAD,LRAN)=LRDFN_U_LRIDT
+19 ;Cleanup entry in LAH.
+20 DO ZAPALL^LRVR3(LRLL,LRIFN)
+21 QUIT
HLP WRITE !!?10,"ENTER",?20,"'E' TO EDIT ENTIRE ACCESSION. ",!?20,"'C' TO EDIT COMMENT",!?20,"'O' TO EDIT ORGANISM "
+1 WRITE !?20,"'^' OR '@' WILL DELETE TRANSFERRED DATA ",!
HANG 2
QUIT
