Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LAMIVTL2

LAMIVTL2.m

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