- 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