- LAMIAUT2 ; IHS/DIR/FJE - CONTINUE MICRO AUTO INSTRUMENT PROGRAM VITEK 7/20/90 09:33 ;
- ;;5.2;LA;;NOV 01, 1997
- ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
- EN ;
- K LRMOVE,LRCNODE,LRORG
- S LRTS=+$O(LRTS(+$G(T1),0)) I 'LRTS W !!,"NO TEST DEFINED",!!,$C(7) Q
- S LRORG=0 F I=0:0 S I=$O(^LAH(LRLL,1,LRIFN,3,I)) Q:I="" I $D(^(I,0)) S LRORG(+^(0))=I D COM K LR6331
- D COM2,COM^LAMIAUT6 K LR6333 S LREND=0 F IR=0:0 S IR=$O(^LAH(LRLL,1,LRIFN,3,IR)) Q:LREND!(IR="") I $D(^(IR,0)) S (LRORGN,X)=+^(0) I X,'$D(LRMOVE(IR)) D NEXT,MOVE
- I $D(^LAH(LRLL,1,LRIFN,4,0)) S %X="^LAH("_LRLL_",1,"_LRIFN_",4,",%Y="^LR("_LRDFN_",""MI"","_LRIDT_",4," D %XY^%RCR
- S $P(^LR(LRDFN,"MI",LRIDT,1),U,3)=DUZ Q
- MOVE ;Move data into ^LR(LRDFN,"MI",LRIDT,3,
- I LREND S LREND=0,^LAH(LRLL,1,LRIFN,3,IR,0)=LRCNODE K LRMOVE(IR) Q
- I IR'=LRORG S %X="^LAH("_LRLL_",1,"_LRIFN_",3,"_IR_",",%Y="^LAH("_LRLL_",1,"_LRIFN_",3,"_LRORG_"," D %XY^%RCR K ^LAH(LRLL,1,LRIFN,3,IR)
- S %X="^LAH("_LRLL_",1,"_LRIFN_",3,"_LRORG_",",%Y="^LR("_LRDFN_",""MI"","_LRIDT_",3,"_LRORG_"," D %XY^%RCR
- S ^LAH(LRLL,1,LRIFN,3,LRORG,0)=LRCNODE
- Q
- NEXT ;
- S LREND=0 D ^LAMIAUT6 Q:LREND I $D(LRBDUP(X)) D DUP^LAMIAUT6 Q
- I '$D(^LR(LRDFN,"MI",LRIDT,3,IR)) S LRMOVE(IR)="A",LRORG=IR,$P(^(0),U,3)=IR,$P(^(0),U,4)=$P(^(0),U,4)+1 Q
- F II=1:1 Q:'$D(^LR(LRDFN,"MI",LRIDT,3,II))&('$D(^LAH(LRLL,1,LRIFN,3,II)))
- S LRMOVE(II)="A",LRORG=II,$P(^LR(LRDFN,"MI",LRIDT,3,0),U,3)=LRORG,$P(^(0),U,4)=$P(^(0),U,4)+1
- Q
- ORG ;
- S LRORG=+$S($D(^LAH(LRLL,1,LRIFN,3,II,0)):^(0),1:0),LRORGN=$S($D(^LAB(61.2,LRORG,0)):$P(^(0),U),1:"")
- I 'LRORG K ^LAH(LRLL,1,LRIFN,3,II)
- I '$L(LRORGN) W !!,$C(7),LRORG_" IS NOT IN THE ETIOLOGY FILE #61.2 " K ^LAH(LRLL,1,LRIFN,3,II) Q
- ASK ;
- K X2 I $L($P(^LAH(LRLL,1,LRIFN,3,II,0),U,2)) S X2=$P(^(0),U,2)
- S LREND=0 W !!,"ENTER QUANTITY FOR ( "_LRORGN_" ) : ",$S($D(X2):X2_" // ",1:" ") R X:DTIME S:'$T!($E(X)="^") LREND=1 Q:LREND I $D(X2),'$L(X),X'="@" S X=X2
- S:$E(X)="^" LREND=1 Q:LREND I X="@" S $P(^LAH(LRLL,1,LRIFN,3,II,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 $E(X)="?" W !?7,"Enter 1-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 ;IHS/ANMC/CLS 11/1/95
- ;I $L(X) X LRMICOM I '$D(X) W !?7,"Enter 2-68 characters " G ASK
- I $L(X) X LRMICOM I '$D(X) W !?7,"Enter 1-68 characters " G ASK ;IHS/ANMC/CLS 11/1/95
- I $L(X) W !,X_" " S %=1 D YN^DICN G:%'=1 ASK I $L(X) S $P(^LAH(LRLL,1,LRIFN,3,II,0),U,2)=X
- Q
- COM ;Set descriptor block for comments
- S LR6331=$O(^LAH(LRLL,1,LRIFN,3,I,1,0)) I LR6331 S ^(0)="^63.31A^"_LR6331_"^1" F LR6331=LR6331:0 S LR6331=$O(^(LR6331)) Q:LR6331="" S $P(^(0),U,3)=LR6331,$P(^(0),U,4)=$P(^(0),U,4)+1
- Q
- COM2 ;Set descriptor block for remarks
- S LR6333=$O(^LAH(LRLL,1,LRIFN,4,0)) I LR6333 S ^(0)="^63.33A^"_LR6333_"^1" F LR6333=LR6333:0 S LR6333=$O(^(LR6333)) Q:LR6333="" S $P(^(0),U,3)=LR6333,$P(^(0),U,4)=$P(^(0),U,4)+1
- Q
- LAMIAUT2 ; IHS/DIR/FJE - CONTINUE MICRO AUTO INSTRUMENT PROGRAM VITEK 7/20/90 09:33 ;
- +1 ;;5.2;LA;;NOV 01, 1997
- +2 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
- EN ;
- +1 KILL LRMOVE,LRCNODE,LRORG
- +2 SET LRTS=+$ORDER(LRTS(+$GET(T1),0))
- IF 'LRTS
- WRITE !!,"NO TEST DEFINED",!!,$CHAR(7)
- QUIT
- +3 SET LRORG=0
- FOR I=0:0
- SET I=$ORDER(^LAH(LRLL,1,LRIFN,3,I))
- IF I=""
- QUIT
- IF $DATA(^(I,0))
- SET LRORG(+^(0))=I
- DO COM
- KILL LR6331
- +4 DO COM2
- DO COM^LAMIAUT6
- KILL LR6333
- SET LREND=0
- FOR IR=0:0
- SET IR=$ORDER(^LAH(LRLL,1,LRIFN,3,IR))
- IF LREND!(IR="")
- QUIT
- IF $DATA(^(IR,0))
- SET (LRORGN,X)=+^(0)
- IF X
- IF '$DATA(LRMOVE(IR))
- DO NEXT
- DO MOVE
- +5 IF $DATA(^LAH(LRLL,1,LRIFN,4,0))
- SET %X="^LAH("_LRLL_",1,"_LRIFN_",4,"
- SET %Y="^LR("_LRDFN_",""MI"","_LRIDT_",4,"
- DO %XY^%RCR
- +6 SET $PIECE(^LR(LRDFN,"MI",LRIDT,1),U,3)=DUZ
- QUIT
- MOVE ;Move data into ^LR(LRDFN,"MI",LRIDT,3,
- +1 IF LREND
- SET LREND=0
- SET ^LAH(LRLL,1,LRIFN,3,IR,0)=LRCNODE
- KILL LRMOVE(IR)
- QUIT
- +2 IF IR'=LRORG
- SET %X="^LAH("_LRLL_",1,"_LRIFN_",3,"_IR_","
- SET %Y="^LAH("_LRLL_",1,"_LRIFN_",3,"_LRORG_","
- DO %XY^%RCR
- KILL ^LAH(LRLL,1,LRIFN,3,IR)
- +3 SET %X="^LAH("_LRLL_",1,"_LRIFN_",3,"_LRORG_","
- SET %Y="^LR("_LRDFN_",""MI"","_LRIDT_",3,"_LRORG_","
- DO %XY^%RCR
- +4 SET ^LAH(LRLL,1,LRIFN,3,LRORG,0)=LRCNODE
- +5 QUIT
- NEXT ;
- +1 SET LREND=0
- DO ^LAMIAUT6
- IF LREND
- QUIT
- IF $DATA(LRBDUP(X))
- DO DUP^LAMIAUT6
- QUIT
- +2 IF '$DATA(^LR(LRDFN,"MI",LRIDT,3,IR))
- SET LRMOVE(IR)="A"
- SET LRORG=IR
- SET $PIECE(^(0),U,3)=IR
- SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
- QUIT
- +3 FOR II=1:1
- IF '$DATA(^LR(LRDFN,"MI",LRIDT,3,II))&('$DATA(^LAH(LRLL,1,LRIFN,3,II)))
- QUIT
- +4 SET LRMOVE(II)="A"
- SET LRORG=II
- SET $PIECE(^LR(LRDFN,"MI",LRIDT,3,0),U,3)=LRORG
- SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
- +5 QUIT
- ORG ;
- +1 SET LRORG=+$SELECT($DATA(^LAH(LRLL,1,LRIFN,3,II,0)):^(0),1:0)
- SET LRORGN=$SELECT($DATA(^LAB(61.2,LRORG,0)):$PIECE(^(0),U),1:"")
- +2 IF 'LRORG
- KILL ^LAH(LRLL,1,LRIFN,3,II)
- +3 IF '$LENGTH(LRORGN)
- WRITE !!,$CHAR(7),LRORG_" IS NOT IN THE ETIOLOGY FILE #61.2 "
- KILL ^LAH(LRLL,1,LRIFN,3,II)
- QUIT
- ASK ;
- +1 KILL X2
- IF $LENGTH($PIECE(^LAH(LRLL,1,LRIFN,3,II,0),U,2))
- SET X2=$PIECE(^(0),U,2)
- +2 SET LREND=0
- WRITE !!,"ENTER QUANTITY FOR ( "_LRORGN_" ) : ",$SELECT($DATA(X2):X2_" // ",1:" ")
- READ X:DTIME
- IF '$TEST!($EXTRACT(X)="^")
- SET LREND=1
- IF LREND
- QUIT
- IF $DATA(X2)
- IF '$LENGTH(X)
- IF X'="@"
- SET X=X2
- +3 IF $EXTRACT(X)="^"
- SET LREND=1
- IF LREND
- QUIT
- IF X="@"
- SET $PIECE(^LAH(LRLL,1,LRIFN,3,II,0),U,2)=""
- QUIT
- +4 ;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
- +5 ;IHS/ANMC/CLS 11/1/95
- IF $EXTRACT(X)="?"
- WRITE !?7,"Enter 1-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
- +6 ;I $L(X) X LRMICOM I '$D(X) W !?7,"Enter 2-68 characters " G ASK
- +7 ;IHS/ANMC/CLS 11/1/95
- IF $LENGTH(X)
- XECUTE LRMICOM
- IF '$DATA(X)
- WRITE !?7,"Enter 1-68 characters "
- GOTO ASK
- +8 IF $LENGTH(X)
- WRITE !,X_" "
- SET %=1
- DO YN^DICN
- IF %'=1
- GOTO ASK
- IF $LENGTH(X)
- SET $PIECE(^LAH(LRLL,1,LRIFN,3,II,0),U,2)=X
- +9 QUIT
- COM ;Set descriptor block for comments
- +1 SET LR6331=$ORDER(^LAH(LRLL,1,LRIFN,3,I,1,0))
- IF LR6331
- SET ^(0)="^63.31A^"_LR6331_"^1"
- FOR LR6331=LR6331:0
- SET LR6331=$ORDER(^(LR6331))
- IF LR6331=""
- QUIT
- SET $PIECE(^(0),U,3)=LR6331
- SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
- +2 QUIT
- COM2 ;Set descriptor block for remarks
- +1 SET LR6333=$ORDER(^LAH(LRLL,1,LRIFN,4,0))
- IF LR6333
- SET ^(0)="^63.33A^"_LR6333_"^1"
- FOR LR6333=LR6333:0
- SET LR6333=$ORDER(^(LR6333))
- IF LR6333=""
- QUIT
- SET $PIECE(^(0),U,3)=LR6333
- SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
- +2 QUIT
