LAKDIFF2 ;DALOI/RWF/LL/RES - RBC MORPHOLOGY ; 7/14/87 08:01
;;5.2;AUTOMATED LAB INSTRUMENTS;**52**;Sep 27, 1994
;
A ;
K KEY,NC,TY,T1,T2
S KEY=""
;
S I=0
F S I=$O(^TMP($J,"R",I)) Q:I="" S X=^(I),KEY(X)=I,KEY=KEY_X
;
S T1=1,(T1(T1),T2(T1))=""
F I=31:1:58 D Q:$O(^TMP("LA",$J,I))=""
. S T2=I
. S X=$G(^TMP("LA",$J,I,4))
. S Y=$G(^TMP("LA",$J,I,.1))
. S T1(T1)=T1(T1)_$J(X,8)
. S T2(T1)=T2(T1)_$J(Y,8)
. Q:$O(^TMP("LA",$J,I))=""
. I '(I-30#9) S T1=T1+1,(T1(T1),T2(T1))=""
;
S (DONE,FLAG)=0
D HD1^LAKDIFF1,HD2
;
F Q:FLAG!DONE D
. N DTOUT
. D SAY^XGF(IOSL-1,0,"RBC: ")
. S TYPE=$$READ^XGF(1,DTIME)
. I TYPE="^"!($D(DTOUT)) S FLAG=1
. S LINE=$S(TYPE="":"STOP",TYPE="!":"COM",TYPE="\":"WBC",KEY'[TYPE:"HELP",1:"RESULT")
. D @LINE
;
I DONE D STORE
K X,A,DATYP,X,CODE,TYPE,CONT,DONE,J,K
Q
;
RESULT ;
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
;
S DIR(0)="63.04,"_^TMP("LA",$J,KEY(TYPE),.2)
S DIR("A")=$P(^LAB(60,^TMP("LA",$J,KEY(TYPE),0),0),U,1)
S DIR("B")=$G(TY(TYPE))
D ^DIR
I $D(DIRUT) D
. I X="",Y="" Q
. I X="@",$D(TY(TYPE)) K TY(TYPE) Q
. S FLAG=1
I $L(Y) S TY(TYPE)=$P(Y,"^")
;
D HD1^LAKDIFF1,HD2
Q
;
HELP ;
I TYPE'="?" D Q
. D SAY^XGF(IOSL-1,0,$C(7)_"INVALID RBC CELL KEY")
. H 2
. D CLEAR^XGF(IOSL-1,0,IOSL-1,IOM-1)
;
;
; Display current morphology results
S $Y=LRDY
F I1=1:9:T2-30 D
. S $Y=$Y+4,$X=6
. F I=I1:1:I1+8 Q:I+30>T2 D
. . S X=$G(^TMP($J,"R",I+30),"^"),K=$G(TY(X))
. . I '$L(K) S $X=$X+8
. . E D SAY^XGF($Y,$X+(9-$L(K)),K,"R1")
;
D CLEAR^XGF(IOSL-1,0,IOSL-1,IOM-1)
Q
;
WBC ;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,K,X,Y
;
D HD1^LAKDIFF1
;
W !!,?30,"> CELL DIFFERENTIAL <",!
S K=0
F S K=$O(^TMP($J,"W",K)) Q:K'>0 D
. S X=^TMP("LA",$J,K,1)
. I $D(@X) W !,?3,$$LJ^XLFSTR(^TMP("LA",$J,K,.1),8,".")," ",$J(@X,3)
;
S DIR(0)="E" D ^DIR
D HD1^LAKDIFF1,HD2
Q
;
STOP ;
N DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
;
D EVAL
;
W !
S DIR(0)="YO",DIR("A")="Are you finished with this patient",DIR("B")="Y"
D ^DIR
I $D(DIRUT) S FLAG=1 Q
I Y=1 S DONE=1
I FLAG=DONE D HD1^LAKDIFF1,HD2
Q
;
EVAL ;
D HD1^LAKDIFF1
W !
S X=""
F I=0:0 S I=$O(^TMP($J,"R",I)) Q:I="" D
. S Y=^(I)
. I $D(TY(Y)) D
. . W !?2,$J(^TMP("LA",$J,I,.1),8),": ",?12
. . S V=TY(Y)
. . X ^TMP("LA",$J,I,2)
. . W $J(V,3)
Q
;
STORE ;
;
N I,X,Y
;
S X="",I=0
F S I=$O(^TMP($J,"R",I)) Q:I="" D
. S Y=^(I)
. I '$D(TY(Y)) Q
. S V=TY(Y)
. X ^TMP("LA",$J,I,2)
. S @^TMP("LA",$J,I,1)=V
Q
;
HD2 ;
; Display morphology headers
;
S LRDY=$Y+2
D SAY^XGF(LRDY,4,"RBC MORPHOLOGY ('?' = DISPLAY, '!' = COMMENTS, '\' = WBC, <RETURN> = EXIT)")
S $Y=$Y+1
F I=1:1:T1 D
. D SAY^XGF("+",0,$$LJ^XLFSTR("KEY",7)_T1(I))
. D SAY^XGF("+",0,$$LJ^XLFSTR("TEST",7)_T2(I))
. S $Y=$Y+2
;
HD3 ;
I LAUPDATE=0 Q
S TYPE="?"
D HELP
Q
;
COM ;
D COM1^LAKDIFF1,HD1^LAKDIFF1,HD2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLAKDIFF2 2964 printed Dec 13, 2024@01:42:51 Page 2
LAKDIFF2 ;DALOI/RWF/LL/RES - RBC MORPHOLOGY ; 7/14/87 08:01
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**52**;Sep 27, 1994
+2 ;
A ;
+1 KILL KEY,NC,TY,T1,T2
+2 SET KEY=""
+3 ;
+4 SET I=0
+5 FOR
SET I=$ORDER(^TMP($JOB,"R",I))
if I=""
QUIT
SET X=^(I)
SET KEY(X)=I
SET KEY=KEY_X
+6 ;
+7 SET T1=1
SET (T1(T1),T2(T1))=""
+8 FOR I=31:1:58
Begin DoDot:1
+9 SET T2=I
+10 SET X=$GET(^TMP("LA",$JOB,I,4))
+11 SET Y=$GET(^TMP("LA",$JOB,I,.1))
+12 SET T1(T1)=T1(T1)_$JUSTIFY(X,8)
+13 SET T2(T1)=T2(T1)_$JUSTIFY(Y,8)
+14 if $ORDER(^TMP("LA",$JOB,I))=""
QUIT
+15 IF '(I-30#9)
SET T1=T1+1
SET (T1(T1),T2(T1))=""
End DoDot:1
if $ORDER(^TMP("LA",$JOB,I))=""
QUIT
+16 ;
+17 SET (DONE,FLAG)=0
+18 DO HD1^LAKDIFF1
DO HD2
+19 ;
+20 FOR
if FLAG!DONE
QUIT
Begin DoDot:1
+21 NEW DTOUT
+22 DO SAY^XGF(IOSL-1,0,"RBC: ")
+23 SET TYPE=$$READ^XGF(1,DTIME)
+24 IF TYPE="^"!($DATA(DTOUT))
SET FLAG=1
+25 SET LINE=$SELECT(TYPE="":"STOP",TYPE="!":"COM",TYPE="\":"WBC",KEY'[TYPE:"HELP",1:"RESULT")
+26 DO @LINE
End DoDot:1
+27 ;
+28 IF DONE
DO STORE
+29 KILL X,A,DATYP,X,CODE,TYPE,CONT,DONE,J,K
+30 QUIT
+31 ;
RESULT ;
+1 ;
+2 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+3 ;
+4 SET DIR(0)="63.04,"_^TMP("LA",$JOB,KEY(TYPE),.2)
+5 SET DIR("A")=$PIECE(^LAB(60,^TMP("LA",$JOB,KEY(TYPE),0),0),U,1)
+6 SET DIR("B")=$GET(TY(TYPE))
+7 DO ^DIR
+8 IF $DATA(DIRUT)
Begin DoDot:1
+9 IF X=""
IF Y=""
QUIT
+10 IF X="@"
IF $DATA(TY(TYPE))
KILL TY(TYPE)
QUIT
+11 SET FLAG=1
End DoDot:1
+12 IF $LENGTH(Y)
SET TY(TYPE)=$PIECE(Y,"^")
+13 ;
+14 DO HD1^LAKDIFF1
DO HD2
+15 QUIT
+16 ;
HELP ;
+1 IF TYPE'="?"
Begin DoDot:1
+2 DO SAY^XGF(IOSL-1,0,$CHAR(7)_"INVALID RBC CELL KEY")
+3 HANG 2
+4 DO CLEAR^XGF(IOSL-1,0,IOSL-1,IOM-1)
End DoDot:1
QUIT
+5 ;
+6 ;
+7 ; Display current morphology results
+8 SET $Y=LRDY
+9 FOR I1=1:9:T2-30
Begin DoDot:1
+10 SET $Y=$Y+4
SET $X=6
+11 FOR I=I1:1:I1+8
if I+30>T2
QUIT
Begin DoDot:2
+12 SET X=$GET(^TMP($JOB,"R",I+30),"^")
SET K=$GET(TY(X))
+13 IF '$LENGTH(K)
SET $X=$X+8
+14 IF '$TEST
DO SAY^XGF($Y,$X+(9-$LENGTH(K)),K,"R1")
End DoDot:2
End DoDot:1
+15 ;
+16 DO CLEAR^XGF(IOSL-1,0,IOSL-1,IOM-1)
+17 QUIT
+18 ;
WBC ;
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,K,X,Y
+2 ;
+3 DO HD1^LAKDIFF1
+4 ;
+5 WRITE !!,?30,"> CELL DIFFERENTIAL <",!
+6 SET K=0
+7 FOR
SET K=$ORDER(^TMP($JOB,"W",K))
if K'>0
QUIT
Begin DoDot:1
+8 SET X=^TMP("LA",$JOB,K,1)
+9 IF $DATA(@X)
WRITE !,?3,$$LJ^XLFSTR(^TMP("LA",$JOB,K,.1),8,".")," ",$JUSTIFY(@X,3)
End DoDot:1
+10 ;
+11 SET DIR(0)="E"
DO ^DIR
+12 DO HD1^LAKDIFF1
DO HD2
+13 QUIT
+14 ;
STOP ;
+1 NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,X,Y
+2 ;
+3 DO EVAL
+4 ;
+5 WRITE !
+6 SET DIR(0)="YO"
SET DIR("A")="Are you finished with this patient"
SET DIR("B")="Y"
+7 DO ^DIR
+8 IF $DATA(DIRUT)
SET FLAG=1
QUIT
+9 IF Y=1
SET DONE=1
+10 IF FLAG=DONE
DO HD1^LAKDIFF1
DO HD2
+11 QUIT
+12 ;
EVAL ;
+1 DO HD1^LAKDIFF1
+2 WRITE !
+3 SET X=""
+4 FOR I=0:0
SET I=$ORDER(^TMP($JOB,"R",I))
if I=""
QUIT
Begin DoDot:1
+5 SET Y=^(I)
+6 IF $DATA(TY(Y))
Begin DoDot:2
+7 WRITE !?2,$JUSTIFY(^TMP("LA",$JOB,I,.1),8),": ",?12
+8 SET V=TY(Y)
+9 XECUTE ^TMP("LA",$JOB,I,2)
+10 WRITE $JUSTIFY(V,3)
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
STORE ;
+1 ;
+2 NEW I,X,Y
+3 ;
+4 SET X=""
SET I=0
+5 FOR
SET I=$ORDER(^TMP($JOB,"R",I))
if I=""
QUIT
Begin DoDot:1
+6 SET Y=^(I)
+7 IF '$DATA(TY(Y))
QUIT
+8 SET V=TY(Y)
+9 XECUTE ^TMP("LA",$JOB,I,2)
+10 SET @^TMP("LA",$JOB,I,1)=V
End DoDot:1
+11 QUIT
+12 ;
HD2 ;
+1 ; Display morphology headers
+2 ;
+3 SET LRDY=$Y+2
+4 DO SAY^XGF(LRDY,4,"RBC MORPHOLOGY ('?' = DISPLAY, '!' = COMMENTS, '\' = WBC, <RETURN> = EXIT)")
+5 SET $Y=$Y+1
+6 FOR I=1:1:T1
Begin DoDot:1
+7 DO SAY^XGF("+",0,$$LJ^XLFSTR("KEY",7)_T1(I))
+8 DO SAY^XGF("+",0,$$LJ^XLFSTR("TEST",7)_T2(I))
+9 SET $Y=$Y+2
End DoDot:1
+10 ;
HD3 ;
+1 IF LAUPDATE=0
QUIT
+2 SET TYPE="?"
+3 DO HELP
+4 QUIT
+5 ;
COM ;
+1 DO COM1^LAKDIFF1
DO HD1^LAKDIFF1
DO HD2
+2 QUIT
