- 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 Feb 18, 2025@23:09:14 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