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

LAKDIFF2.m

Go to the documentation of this file.
  1. LAKDIFF2 ;DALOI/RWF/LL/RES - RBC MORPHOLOGY ; 7/14/87 08:01
  1. ;;5.2;AUTOMATED LAB INSTRUMENTS;**52**;Sep 27, 1994
  1. ;
  1. A ;
  1. K KEY,NC,TY,T1,T2
  1. S KEY=""
  1. ;
  1. S I=0
  1. F S I=$O(^TMP($J,"R",I)) Q:I="" S X=^(I),KEY(X)=I,KEY=KEY_X
  1. ;
  1. S T1=1,(T1(T1),T2(T1))=""
  1. F I=31:1:58 D Q:$O(^TMP("LA",$J,I))=""
  1. . S T2=I
  1. . S X=$G(^TMP("LA",$J,I,4))
  1. . S Y=$G(^TMP("LA",$J,I,.1))
  1. . S T1(T1)=T1(T1)_$J(X,8)
  1. . S T2(T1)=T2(T1)_$J(Y,8)
  1. . Q:$O(^TMP("LA",$J,I))=""
  1. . I '(I-30#9) S T1=T1+1,(T1(T1),T2(T1))=""
  1. ;
  1. S (DONE,FLAG)=0
  1. D HD1^LAKDIFF1,HD2
  1. ;
  1. F Q:FLAG!DONE D
  1. . N DTOUT
  1. . D SAY^XGF(IOSL-1,0,"RBC: ")
  1. . S TYPE=$$READ^XGF(1,DTIME)
  1. . I TYPE="^"!($D(DTOUT)) S FLAG=1
  1. . S LINE=$S(TYPE="":"STOP",TYPE="!":"COM",TYPE="\":"WBC",KEY'[TYPE:"HELP",1:"RESULT")
  1. . D @LINE
  1. ;
  1. I DONE D STORE
  1. K X,A,DATYP,X,CODE,TYPE,CONT,DONE,J,K
  1. Q
  1. ;
  1. RESULT ;
  1. ;
  1. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1. ;
  1. S DIR(0)="63.04,"_^TMP("LA",$J,KEY(TYPE),.2)
  1. S DIR("A")=$P(^LAB(60,^TMP("LA",$J,KEY(TYPE),0),0),U,1)
  1. S DIR("B")=$G(TY(TYPE))
  1. D ^DIR
  1. I $D(DIRUT) D
  1. . I X="",Y="" Q
  1. . I X="@",$D(TY(TYPE)) K TY(TYPE) Q
  1. . S FLAG=1
  1. I $L(Y) S TY(TYPE)=$P(Y,"^")
  1. ;
  1. D HD1^LAKDIFF1,HD2
  1. Q
  1. ;
  1. HELP ;
  1. I TYPE'="?" D Q
  1. . D SAY^XGF(IOSL-1,0,$C(7)_"INVALID RBC CELL KEY")
  1. . H 2
  1. . D CLEAR^XGF(IOSL-1,0,IOSL-1,IOM-1)
  1. ;
  1. ;
  1. ; Display current morphology results
  1. S $Y=LRDY
  1. F I1=1:9:T2-30 D
  1. . S $Y=$Y+4,$X=6
  1. . F I=I1:1:I1+8 Q:I+30>T2 D
  1. . . S X=$G(^TMP($J,"R",I+30),"^"),K=$G(TY(X))
  1. . . I '$L(K) S $X=$X+8
  1. . . E D SAY^XGF($Y,$X+(9-$L(K)),K,"R1")
  1. ;
  1. D CLEAR^XGF(IOSL-1,0,IOSL-1,IOM-1)
  1. Q
  1. ;
  1. WBC ;
  1. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,K,X,Y
  1. ;
  1. D HD1^LAKDIFF1
  1. ;
  1. W !!,?30,"> CELL DIFFERENTIAL <",!
  1. S K=0
  1. F S K=$O(^TMP($J,"W",K)) Q:K'>0 D
  1. . S X=^TMP("LA",$J,K,1)
  1. . I $D(@X) W !,?3,$$LJ^XLFSTR(^TMP("LA",$J,K,.1),8,".")," ",$J(@X,3)
  1. ;
  1. S DIR(0)="E" D ^DIR
  1. D HD1^LAKDIFF1,HD2
  1. Q
  1. ;
  1. STOP ;
  1. N DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
  1. ;
  1. D EVAL
  1. ;
  1. W !
  1. S DIR(0)="YO",DIR("A")="Are you finished with this patient",DIR("B")="Y"
  1. D ^DIR
  1. I $D(DIRUT) S FLAG=1 Q
  1. I Y=1 S DONE=1
  1. I FLAG=DONE D HD1^LAKDIFF1,HD2
  1. Q
  1. ;
  1. EVAL ;
  1. D HD1^LAKDIFF1
  1. W !
  1. S X=""
  1. F I=0:0 S I=$O(^TMP($J,"R",I)) Q:I="" D
  1. . S Y=^(I)
  1. . I $D(TY(Y)) D
  1. . . W !?2,$J(^TMP("LA",$J,I,.1),8),": ",?12
  1. . . S V=TY(Y)
  1. . . X ^TMP("LA",$J,I,2)
  1. . . W $J(V,3)
  1. Q
  1. ;
  1. STORE ;
  1. ;
  1. N I,X,Y
  1. ;
  1. S X="",I=0
  1. F S I=$O(^TMP($J,"R",I)) Q:I="" D
  1. . S Y=^(I)
  1. . I '$D(TY(Y)) Q
  1. . S V=TY(Y)
  1. . X ^TMP("LA",$J,I,2)
  1. . S @^TMP("LA",$J,I,1)=V
  1. Q
  1. ;
  1. HD2 ;
  1. ; Display morphology headers
  1. ;
  1. S LRDY=$Y+2
  1. D SAY^XGF(LRDY,4,"RBC MORPHOLOGY ('?' = DISPLAY, '!' = COMMENTS, '\' = WBC, <RETURN> = EXIT)")
  1. S $Y=$Y+1
  1. F I=1:1:T1 D
  1. . D SAY^XGF("+",0,$$LJ^XLFSTR("KEY",7)_T1(I))
  1. . D SAY^XGF("+",0,$$LJ^XLFSTR("TEST",7)_T2(I))
  1. . S $Y=$Y+2
  1. ;
  1. HD3 ;
  1. I LAUPDATE=0 Q
  1. S TYPE="?"
  1. D HELP
  1. Q
  1. ;
  1. COM ;
  1. D COM1^LAKDIFF1,HD1^LAKDIFF1,HD2
  1. Q