LAMIVTL2 ;VA/DAL/HOAK - 3rd vitek literal verification routine ;1/22/96 08:30 ;
;;5.2;AUTOMATED LAB INSTRUMENTS;**1030**;NOV 01, 1997
;;5.2;AUTOMATED LAB INSTRUMENTS;**12**;Sep 27,1994;Build 7
INIT ;
CONTROL ;
S OK=1
K LRBUX
K LRKEEP
D PROBE
I 'OK QUIT
K ^TMP($J,"LR"),^TMP($J,"LA"),^LAH(LRLL,1,"VITLIT"),^TMP($J,"LROUT")
S LRIFN=0
F S LRIFN=$O(LRIFN(LRIFN)) Q:LRIFN'>0 D LAH Q:'OK
D CALL
S LRIFN=0
W @IOF
F S LRIFN=$O(LRIFN(LRIFN)) Q:LRIFN'>0 D LAH1 Q:'OK
D LAH2
D ^LAMIVTL4 ;--->EDIT, OR enter itials
Q
PROBE ;---------------------------------------------------------------------
; If data here it looks like ^LR(LRDFN,"MI",LRIDT,3,LRPIC,DRUGNODE)
; where LRPIC is not the IFN in etiology, that is found at
; $P(^(3,LRBUG,0),U)
W !!,"Reviewing for previously entered results:"
I '$D(^LR(LRDFN,LRSUB,LRIDT,3)) D ;------NO DATA IN LR FOR THIS ACCN
. W !,"NO PREVIOUS DATA FOR THIS ACCN" QUIT
S LRPIC=0
DISPLAY ;
K LRDOS
W @IOF
K DIR
S DIR(0)="E"
F S LRPIC=$O(^LR(LRDFN,LRSUB,LRIDT,3,LRPIC)) Q:LRPIC'>0!('OK) D
. S LRBUG=$P(^LAB(61.2,+^LR(LRDFN,LRSUB,LRIDT,3,LRPIC,0),0),U)
. W !,"Isolate (",LRPIC," )" S LRDOS=1
. W !," ",LRBUG
. S LRRX=1
. F S LRRX=$O(^LR(LRDFN,LRSUB,LRIDT,3,LRPIC,LRRX)) Q:+LRRX'>0 D
.. S LRNTRP=^LR(LRDFN,LRSUB,LRIDT,3,LRPIC,LRRX)
.. S LRDRUG=$P(^LAB(62.06,$O(^LAB(62.06,"AD",LRRX,0)),0),U)
.. W !,$E(LRDRUG,1,30),?32,$P(LRNTRP,U),?38,$P(LRNTRP,U,2)
.. S LRD0(LRRX)=LRNTRP
. D CHK Q:'OK
K DIR
Q
CHK ;
Q:$GET(LRDOS)'>0
; what do you want to do if data in already in ^LR
W !!,"Look what I found in ",PNM,"'S report.",!,"What do you want me to do with it?"
S DIR(0)="S^1:Overwrite;2:Keep;3:Edit"
S DIR("A")="Please choose one of the courses of actions:"
D ^DIR
I $D(DTOUT)!($D(DUOUT)) S OK=0 QUIT
;I Y=3 D VERIFY^LAMIVTL4 QUIT ;edit existing isolate in ^LR
I Y=3 D EDIT^LAMIVTL6 D CHKG S LRKEEP(LRPIC)=1 QUIT ;edit existing isolate in ^LR
S LRKEEP(LRPIC)=$S(Y=1!(Y=""):0,1:1)
I Y=1&($G(LRNOTO)=1) D G CHK
. W !,"I will not overwrite verified Data!",*7,*7,!! Q
Q
CHKG ;
I $G(^LR(LRDFN,LRSUB,LRIDT,3,LRIDT)) K ^LR(LRDFN,LRSUB,LRIDT,3,LRIDT)
Q
GETBUG ;
D ASK ;Q:'OK
S $P(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,0),U,2)=$G(LRQUANT(LRISO)),$P(^(0),U,3)=""
S ^LR(LRDFN,LRSUB,LRIDT,3,LRISO,0)=$O(^LAB(61.2,"B",LRBUG,""))
;S ^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,0)="63.31A"
;S $P(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,0),U,3)=1,$P(^(0),U,4)=1
D ORGCOM
Q
;----------------------------------------------------------------------
ASK ; From LAMIAUT2 BY FHS
K X2
I $L($P(^LAH(LRLL,1,$P(LRNOD,U),3,$P(LRNOD,U,2),0),U,2)) S X2=$P(^(0),U,2)
S LREND=0
W !!,LRISO,". ENTER QUANTITY FOR ( "_LRBUG_" ) : " S LRORGCNT=LRORGCNT+1
W $S($D(X2):X2_" // ",1:" ")
R X:DTIME S:X["^" LREND=1 S:LREND OK=0 Q:'OK
I $D(X2),'$L(X),X'="@" S X=X2
S:$E(X)="^" LREND=1 S:LREND OK=0 Q:'OK
;I X="@" S $P(^LAH(LRLL,1,LRIFN,3,LRISO,0),U,2)="" Q
I $E(X)="?" W !?7,"Enter 2-68 characters or a Lab Description" K DIC S X="?",DIC="^LAB(62.5,",DIC(0)="Q",DIC("S")="I LRMICOMS[$P(^(0),U,4)" D ^DIC K DIC G ASK
I $L(X) X LRMICOM I '$D(X) W !?7,"Enter 2-68 characters " G ASK
I $L(X) W !,X_" " S %=1 D YN^DICN G:%'=1 ASK I $L(X) D
. S $P(^LAH(LRLL,1,$P(LRNOD,U),3,$P(LRNOD,U,2),0),U,2)=X
. S LRQUANT(LRISO)=X
Q
ORGCOM ;
I $D(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,1,0)) S LRCMNT=^(0)
S X2=$G(LRCMNT)
W !,"COMMENT: "
W $S($D(X2):X2_" // ",1:" ")
R X:DTIME S:X["^" LREND=1 S:LREND OK=0 Q:'OK
I $D(X2),'$L(X),X'="@" S X=X2
S:$E(X)="^" LREND=1 S:LREND OK=0 Q:'OK
I X="@" S ^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,1,0)="" G ORGCOM Q
I $E(X)="?" W !?7,"Enter 2-68 characters or a Lab Description" K DIC S X="?",DIC="^LAB(62.5,",DIC(0)="Q",DIC("S")="I LRMICOMS[$P(^(0),U,4)" D ^DIC K DIC G ASK
I $L(X) X LRMICOM I '$D(X) W !?7,"Enter 2-68 characters " G ASK
I $L(X) W !,X_" " S %=1 D YN^DICN G:%'=1 ASK I $L(X) D
. S ^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,1,0)=X
Q
LAH ;
;W @IOF
S LRISO=0
S LRORGCNT=0
; Display all bugs at begining
BUILD F S LRISO=$O(^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO)) Q:+LRISO'>0!('OK) D
. I $G(LRKEEP(LRISO)) K ^LAH(LRLL,1,LRIFN(LRIFN),3) QUIT
. S LRRX=0
. S LRCMNT=$P($G(^LAH(LRLL,1,LRIFN(LRIFN),1,LRISO,1,0)),U)
. S LRBACT=$P($G(^LAH(LRLL,1,LRIFN(LRIFN),1,LRISO,1,0)),U,2)
. S LRBUG=$P(^LAB(61.2,+^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,0),0),U)
. S ^TMP($J,"LR",LRISO,LRBUG)=LRIFN(LRIFN)_U_LRISO
. ;-----LIST TO CHECK FOR DUPS IN LAH <--------\/
. S LRBUX=^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,0)
. S ^LAH(LRLL,1,"VITLIT",3,LRISO,LRIFN(LRIFN),+LRBUX_$P(LRBUX,U,3))=""
QUIT
CALL ;
;-----------------ALL BUGS AT ONCE---------------
S LRISO=0
F S LRISO=$O(^TMP($J,"LR",LRISO)) Q:LRISO'>0 D
. S LRBUG=0
. F S LRBUG=$O(^TMP($J,"LR",LRISO,LRBUG)) Q:LRBUG="" S LRNOD=^(LRBUG) D
.. D GETBUG Q:'OK
QUIT
;-----------------------------------------------------------------------
LAH1 ; Display drugs
;W @IOF
S LRISO=0
F S LRISO=$O(^LAH(LRLL,1,"VITLIT",3,LRISO)) Q:+LRISO'>0!('OK) D
. Q:$G(LRKEEP(LRISO))
. S LRNORK=0
. F S LRNORK=$O(^LAH(LRLL,1,"VITLIT",3,LRISO,LRNORK)) Q:LRNORK'>0 D
.. S LRBUX=""
.. S LRBUX=$O(^LAH(LRLL,1,"VITLIT",3,LRISO,LRNORK,LRBUX))
.. S ^TMP($J,"LROUT",LRISO,LRBUX)=LRNORK
. D PRESTO
. S LRRX=0
. S LRBUG=$P(^LAB(61.2,+^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,0),0),U)
. S LRBUX=^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,0)
. S ^TMP($J,"LA",3,LRISO,LRIFN(LRIFN),+LRBUX_$P(LRBUX,U,3))=""
. D CHKLAH^LAMIVTL3 Q:'LRNOT
QUIT
LAH2 ;
; Print drugs
S LRISO=0
F S LRISO=$O(^TMP($J,"LROUT",LRISO)) Q:LRISO'>0 D
. S LRPIN=0
. F S LRPIN=$O(^TMP($J,"LROUT",LRISO,LRPIN)) Q:LRPIN="" S LRIFN=^(LRPIN),LRIFN(LRIFN)=LRIFN D
.. K ^TMP("VITNAME")
.. S LRBUG=$P(^LAB(61.2,+LRPIN,0),U)
.. W @IOF
.. W !,"Isolate (",LRISO," )"
.. W !," ",LRBUG
.. W !," ","CARD "_$P(^LAH(LRLL,1,LRIFN(LRIFN),2,2),U,2)
.. S LRRX=1
.. F S LRRX=$O(^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,LRRX)) Q:LRRX="" D
... S LRNTRP=^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,LRRX)
... S LRDRUG=$P(^LAB(62.06,$O(^LAB(62.06,"AD",LRRX,0)),0),U)
... S ^TMP("VITNAME",LRDRUG)=LRNTRP
... ;W !,$E(LRDRUG,1,30),?32,LRNTRP
.. S LRDRUG="" F S LRDRUG=$O(^TMP("VITNAME",LRDRUG)) Q:LRDRUG="" D
... W !,$E(LRDRUG,1,30),?32,$P(^TMP("VITNAME",LRDRUG),U),?52,$P(^(LRDRUG),U,2),?65,$P(^(LRDRUG),U,3) D CHKPAGE Q:'OK
.. Q:'OK
.. D PAUSE
.. D SET^LAMIVTL3
Q:'OK
Q:'$G(LRIFN) S:$G(LRINTER) LRIFN(LRIFN)=LRINTER
Q
PRESTO ;
; --- KEEP LRIFN FOR FUTURE USE---------------<<<<<<<<
S LRINTER=LRIFN(LRIFN)
S LRPLK=0
S LRPLK=$O(^LAH(LRLL,1,"VITLIT",3,LRISO,LRPLK))
S LRIFN(LRIFN)=LRPLK
Q
PAUSE ;
S LRDIE=$G(^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,1,0)) ;SET COMMENT
S LRCMNT=$P(LRDIE,U)
S LRBACT=$P(LRDIE,U,2)
;R !!,"Touch enter to continue",DHZX:DTIME
K DIR
S DIR(0)="E"
D ^DIR
I $D(DUOUT) S OK=0
Q
CHKPAGE ;
I IOSL-$Y>4 QUIT
K DIR
S DIR(0)="E"
D ^DIR
I Y["^" S OK=0 QUIT
W @IOF
Q
LAMIVTL2 ;VA/DAL/HOAK - 3rd vitek literal verification routine ;1/22/96 08:30 ;
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**1030**;NOV 01, 1997
+2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**12**;Sep 27,1994;Build 7
INIT ;
CONTROL ;
+1 SET OK=1
+2 KILL LRBUX
+3 KILL LRKEEP
+4 DO PROBE
+5 IF 'OK
QUIT
+6 KILL ^TMP($JOB,"LR"),^TMP($JOB,"LA"),^LAH(LRLL,1,"VITLIT"),^TMP($JOB,"LROUT")
+7 SET LRIFN=0
+8 FOR
SET LRIFN=$ORDER(LRIFN(LRIFN))
IF LRIFN'>0
QUIT
DO LAH
IF 'OK
QUIT
+9 DO CALL
+10 SET LRIFN=0
+11 WRITE @IOF
+12 FOR
SET LRIFN=$ORDER(LRIFN(LRIFN))
IF LRIFN'>0
QUIT
DO LAH1
IF 'OK
QUIT
+13 DO LAH2
+14 ;--->EDIT, OR enter itials
DO ^LAMIVTL4
+15 QUIT
PROBE ;---------------------------------------------------------------------
+1 ; If data here it looks like ^LR(LRDFN,"MI",LRIDT,3,LRPIC,DRUGNODE)
+2 ; where LRPIC is not the IFN in etiology, that is found at
+3 ; $P(^(3,LRBUG,0),U)
+4 WRITE !!,"Reviewing for previously entered results:"
+5 ;------NO DATA IN LR FOR THIS ACCN
IF '$DATA(^LR(LRDFN,LRSUB,LRIDT,3))
Begin DoDot:1
+6 WRITE !,"NO PREVIOUS DATA FOR THIS ACCN"
QUIT
End DoDot:1
+7 SET LRPIC=0
DISPLAY ;
+1 KILL LRDOS
+2 WRITE @IOF
+3 KILL DIR
+4 SET DIR(0)="E"
+5 FOR
SET LRPIC=$ORDER(^LR(LRDFN,LRSUB,LRIDT,3,LRPIC))
IF LRPIC'>0!('OK)
QUIT
Begin DoDot:1
+6 SET LRBUG=$PIECE(^LAB(61.2,+^LR(LRDFN,LRSUB,LRIDT,3,LRPIC,0),0),U)
+7 WRITE !,"Isolate (",LRPIC," )"
SET LRDOS=1
+8 WRITE !," ",LRBUG
+9 SET LRRX=1
+10 FOR
SET LRRX=$ORDER(^LR(LRDFN,LRSUB,LRIDT,3,LRPIC,LRRX))
IF +LRRX'>0
QUIT
Begin DoDot:2
+11 SET LRNTRP=^LR(LRDFN,LRSUB,LRIDT,3,LRPIC,LRRX)
+12 SET LRDRUG=$PIECE(^LAB(62.06,$ORDER(^LAB(62.06,"AD",LRRX,0)),0),U)
+13 WRITE !,$EXTRACT(LRDRUG,1,30),?32,$PIECE(LRNTRP,U),?38,$PIECE(LRNTRP,U,2)
+14 SET LRD0(LRRX)=LRNTRP
End DoDot:2
+15 DO CHK
IF 'OK
QUIT
End DoDot:1
+16 KILL DIR
+17 QUIT
CHK ;
+1 IF $GET(LRDOS)'>0
QUIT
+2 ; what do you want to do if data in already in ^LR
+3 WRITE !!,"Look what I found in ",PNM,"'S report.",!,"What do you want me to do with it?"
+4 SET DIR(0)="S^1:Overwrite;2:Keep;3:Edit"
+5 SET DIR("A")="Please choose one of the courses of actions:"
+6 DO ^DIR
+7 IF $DATA(DTOUT)!($DATA(DUOUT))
SET OK=0
QUIT
+8 ;I Y=3 D VERIFY^LAMIVTL4 QUIT ;edit existing isolate in ^LR
+9 ;edit existing isolate in ^LR
IF Y=3
DO EDIT^LAMIVTL6
DO CHKG
SET LRKEEP(LRPIC)=1
QUIT
+10 SET LRKEEP(LRPIC)=$SELECT(Y=1!(Y=""):0,1:1)
+11 IF Y=1&($GET(LRNOTO)=1)
Begin DoDot:1
+12 WRITE !,"I will not overwrite verified Data!",*7,*7,!!
QUIT
End DoDot:1
GOTO CHK
+13 QUIT
CHKG ;
+1 IF $GET(^LR(LRDFN,LRSUB,LRIDT,3,LRIDT))
KILL ^LR(LRDFN,LRSUB,LRIDT,3,LRIDT)
+2 QUIT
GETBUG ;
+1 ;Q:'OK
DO ASK
+2 SET $PIECE(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,0),U,2)=$GET(LRQUANT(LRISO))
SET $PIECE(^(0),U,3)=""
+3 SET ^LR(LRDFN,LRSUB,LRIDT,3,LRISO,0)=$ORDER(^LAB(61.2,"B",LRBUG,""))
+4 ;S ^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,0)="63.31A"
+5 ;S $P(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,0),U,3)=1,$P(^(0),U,4)=1
+6 DO ORGCOM
+7 QUIT
+8 ;----------------------------------------------------------------------
ASK ; From LAMIAUT2 BY FHS
+1 KILL X2
+2 IF $LENGTH($PIECE(^LAH(LRLL,1,$PIECE(LRNOD,U),3,$PIECE(LRNOD,U,2),0),U,2))
SET X2=$PIECE(^(0),U,2)
+3 SET LREND=0
+4 WRITE !!,LRISO,". ENTER QUANTITY FOR ( "_LRBUG_" ) : "
SET LRORGCNT=LRORGCNT+1
+5 WRITE $SELECT($DATA(X2):X2_" // ",1:" ")
+6 READ X:DTIME
IF X["^"
SET LREND=1
IF LREND
SET OK=0
IF 'OK
QUIT
+7 IF $DATA(X2)
IF '$LENGTH(X)
IF X'="@"
SET X=X2
+8 IF $EXTRACT(X)="^"
SET LREND=1
IF LREND
SET OK=0
IF 'OK
QUIT
+9 ;I X="@" S $P(^LAH(LRLL,1,LRIFN,3,LRISO,0),U,2)="" Q
+10 IF $EXTRACT(X)="?"
WRITE !?7,"Enter 2-68 characters or a Lab Description"
KILL DIC
SET X="?"
SET DIC="^LAB(62.5,"
SET DIC(0)="Q"
SET DIC("S")="I LRMICOMS[$P(^(0),U,4)"
DO ^DIC
KILL DIC
GOTO ASK
+11 IF $LENGTH(X)
XECUTE LRMICOM
IF '$DATA(X)
WRITE !?7,"Enter 2-68 characters "
GOTO ASK
+12 IF $LENGTH(X)
WRITE !,X_" "
SET %=1
DO YN^DICN
IF %'=1
GOTO ASK
IF $LENGTH(X)
Begin DoDot:1
+13 SET $PIECE(^LAH(LRLL,1,$PIECE(LRNOD,U),3,$PIECE(LRNOD,U,2),0),U,2)=X
+14 SET LRQUANT(LRISO)=X
End DoDot:1
+15 QUIT
ORGCOM ;
+1 IF $DATA(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,1,0))
SET LRCMNT=^(0)
+2 SET X2=$GET(LRCMNT)
+3 WRITE !,"COMMENT: "
+4 WRITE $SELECT($DATA(X2):X2_" // ",1:" ")
+5 READ X:DTIME
IF X["^"
SET LREND=1
IF LREND
SET OK=0
IF 'OK
QUIT
+6 IF $DATA(X2)
IF '$LENGTH(X)
IF X'="@"
SET X=X2
+7 IF $EXTRACT(X)="^"
SET LREND=1
IF LREND
SET OK=0
IF 'OK
QUIT
+8 IF X="@"
SET ^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,1,0)=""
GOTO ORGCOM
QUIT
+9 IF $EXTRACT(X)="?"
WRITE !?7,"Enter 2-68 characters or a Lab Description"
KILL DIC
SET X="?"
SET DIC="^LAB(62.5,"
SET DIC(0)="Q"
SET DIC("S")="I LRMICOMS[$P(^(0),U,4)"
DO ^DIC
KILL DIC
GOTO ASK
+10 IF $LENGTH(X)
XECUTE LRMICOM
IF '$DATA(X)
WRITE !?7,"Enter 2-68 characters "
GOTO ASK
+11 IF $LENGTH(X)
WRITE !,X_" "
SET %=1
DO YN^DICN
IF %'=1
GOTO ASK
IF $LENGTH(X)
Begin DoDot:1
+12 SET ^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,1,0)=X
End DoDot:1
+13 QUIT
LAH ;
+1 ;W @IOF
+2 SET LRISO=0
+3 SET LRORGCNT=0
+4 ; Display all bugs at begining
BUILD FOR
SET LRISO=$ORDER(^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO))
IF +LRISO'>0!('OK)
QUIT
Begin DoDot:1
+1 IF $GET(LRKEEP(LRISO))
KILL ^LAH(LRLL,1,LRIFN(LRIFN),3)
QUIT
+2 SET LRRX=0
+3 SET LRCMNT=$PIECE($GET(^LAH(LRLL,1,LRIFN(LRIFN),1,LRISO,1,0)),U)
+4 SET LRBACT=$PIECE($GET(^LAH(LRLL,1,LRIFN(LRIFN),1,LRISO,1,0)),U,2)
+5 SET LRBUG=$PIECE(^LAB(61.2,+^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,0),0),U)
+6 SET ^TMP($JOB,"LR",LRISO,LRBUG)=LRIFN(LRIFN)_U_LRISO
+7 ;-----LIST TO CHECK FOR DUPS IN LAH <--------\/
+8 SET LRBUX=^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,0)
+9 SET ^LAH(LRLL,1,"VITLIT",3,LRISO,LRIFN(LRIFN),+LRBUX_$PIECE(LRBUX,U,3))=""
End DoDot:1
+10 QUIT
CALL ;
+1 ;-----------------ALL BUGS AT ONCE---------------
+2 SET LRISO=0
+3 FOR
SET LRISO=$ORDER(^TMP($JOB,"LR",LRISO))
IF LRISO'>0
QUIT
Begin DoDot:1
+4 SET LRBUG=0
+5 FOR
SET LRBUG=$ORDER(^TMP($JOB,"LR",LRISO,LRBUG))
IF LRBUG=""
QUIT
SET LRNOD=^(LRBUG)
Begin DoDot:2
+6 DO GETBUG
IF 'OK
QUIT
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;-----------------------------------------------------------------------
LAH1 ; Display drugs
+1 ;W @IOF
+2 SET LRISO=0
+3 FOR
SET LRISO=$ORDER(^LAH(LRLL,1,"VITLIT",3,LRISO))
IF +LRISO'>0!('OK)
QUIT
Begin DoDot:1
+4 IF $GET(LRKEEP(LRISO))
QUIT
+5 SET LRNORK=0
+6 FOR
SET LRNORK=$ORDER(^LAH(LRLL,1,"VITLIT",3,LRISO,LRNORK))
IF LRNORK'>0
QUIT
Begin DoDot:2
+7 SET LRBUX=""
+8 SET LRBUX=$ORDER(^LAH(LRLL,1,"VITLIT",3,LRISO,LRNORK,LRBUX))
+9 SET ^TMP($JOB,"LROUT",LRISO,LRBUX)=LRNORK
End DoDot:2
+10 DO PRESTO
+11 SET LRRX=0
+12 SET LRBUG=$PIECE(^LAB(61.2,+^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,0),0),U)
+13 SET LRBUX=^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,0)
+14 SET ^TMP($JOB,"LA",3,LRISO,LRIFN(LRIFN),+LRBUX_$PIECE(LRBUX,U,3))=""
+15 DO CHKLAH^LAMIVTL3
IF 'LRNOT
QUIT
End DoDot:1
+16 QUIT
LAH2 ;
+1 ; Print drugs
+2 SET LRISO=0
+3 FOR
SET LRISO=$ORDER(^TMP($JOB,"LROUT",LRISO))
IF LRISO'>0
QUIT
Begin DoDot:1
+4 SET LRPIN=0
+5 FOR
SET LRPIN=$ORDER(^TMP($JOB,"LROUT",LRISO,LRPIN))
IF LRPIN=""
QUIT
SET LRIFN=^(LRPIN)
SET LRIFN(LRIFN)=LRIFN
Begin DoDot:2
+6 KILL ^TMP("VITNAME")
+7 SET LRBUG=$PIECE(^LAB(61.2,+LRPIN,0),U)
+8 WRITE @IOF
+9 WRITE !,"Isolate (",LRISO," )"
+10 WRITE !," ",LRBUG
+11 WRITE !," ","CARD "_$PIECE(^LAH(LRLL,1,LRIFN(LRIFN),2,2),U,2)
+12 SET LRRX=1
+13 FOR
SET LRRX=$ORDER(^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,LRRX))
IF LRRX=""
QUIT
Begin DoDot:3
+14 SET LRNTRP=^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,LRRX)
+15 SET LRDRUG=$PIECE(^LAB(62.06,$ORDER(^LAB(62.06,"AD",LRRX,0)),0),U)
+16 SET ^TMP("VITNAME",LRDRUG)=LRNTRP
+17 ;W !,$E(LRDRUG,1,30),?32,LRNTRP
End DoDot:3
+18 SET LRDRUG=""
FOR
SET LRDRUG=$ORDER(^TMP("VITNAME",LRDRUG))
IF LRDRUG=""
QUIT
Begin DoDot:3
+19 WRITE !,$EXTRACT(LRDRUG,1,30),?32,$PIECE(^TMP("VITNAME",LRDRUG),U),?52,$PIECE(^(LRDRUG),U,2),?65,$PIECE(^(LRDRUG),U,3)
DO CHKPAGE
IF 'OK
QUIT
End DoDot:3
+20 IF 'OK
QUIT
+21 DO PAUSE
+22 DO SET^LAMIVTL3
End DoDot:2
End DoDot:1
+23 IF 'OK
QUIT
+24 IF '$GET(LRIFN)
QUIT
IF $GET(LRINTER)
SET LRIFN(LRIFN)=LRINTER
+25 QUIT
PRESTO ;
+1 ; --- KEEP LRIFN FOR FUTURE USE---------------<<<<<<<<
+2 SET LRINTER=LRIFN(LRIFN)
+3 SET LRPLK=0
+4 SET LRPLK=$ORDER(^LAH(LRLL,1,"VITLIT",3,LRISO,LRPLK))
+5 SET LRIFN(LRIFN)=LRPLK
+6 QUIT
PAUSE ;
+1 ;SET COMMENT
SET LRDIE=$GET(^LAH(LRLL,1,LRIFN(LRIFN),3,LRISO,1,0))
+2 SET LRCMNT=$PIECE(LRDIE,U)
+3 SET LRBACT=$PIECE(LRDIE,U,2)
+4 ;R !!,"Touch enter to continue",DHZX:DTIME
+5 KILL DIR
+6 SET DIR(0)="E"
+7 DO ^DIR
+8 IF $DATA(DUOUT)
SET OK=0
+9 QUIT
CHKPAGE ;
+1 IF IOSL-$Y>4
QUIT
+2 KILL DIR
+3 SET DIR(0)="E"
+4 DO ^DIR
+5 IF Y["^"
SET OK=0
QUIT
+6 WRITE @IOF
+7 QUIT
