LAKDIFF ;DALOI/RWF - KEYBOARD DIFFERENTIAL COUNTER ;8/16/90 10:38
;;5.2;AUTOMATED LAB INSTRUMENTS;**13,52**;Sep 27, 1994
;
; Cross link by id = accession
;
LA1 ;
I '$D(LRPARAM) D ^LRPARAM
;
D HOME^%ZIS
;
S LANM=$T(+0),TSK=$O(^LAB(62.4,"C",LANM,0)),U="^"
I TSK<1 D Q
. W !,"Unable to find entry in AUTO INSTRUMENT file using ",LANM," as PROGRAM NAME"
. D QUIT
;
W !!?20,"KEYPAD DIFF ENTRY",!!
;
S LREND=0,LRTOP=$P(^LAB(69.9,1,1),U,1)
D ^LASET
I 'TSK D Q
. W $C(7),!!,"AUTO INSTRUMENT file is incompletly defined for the Keypad Diff."
. D QUIT
;
I LALCT="N" D Q
. W $C(7),!!,"Field LOAD CHEM TESTS is configured incorrectly in AUTO INSTRUMENT File"
. W !,"Set it to either 'TC ARRAY' or 'TMP GLOBAL'."
. D QUIT
;
K ^LA("LOCK",TSK)
;
S DTIME=$$DTIME^XUP(DUZ)
S DT=$$DT^XLFDT
;
D DISPLAY
I LREND D QUIT Q
;
; Select accession date to use
S LRAA=+$G(WL)
I LRAA<1 D QUIT Q
D ADATE^LRWU
I LREND D QUIT Q
;
; Get last accession used on this date if any
S LRAN=+$P($G(^LRO(68,LRAA,1,LRAD,2)),"^",4)
;
I $P(LRPARAM,U,14),$P($G(^LRO(68,LRAA,0)),U,16) D ^LRCAPV
I LREND D QUIT Q
;
D INT
;
; Setup screen and keyboard
S LAXGF=1 D PREP^XGF
;
; Set read terminator to <CR>. Otherwise problems in scroll&roll sections.
D INITKB^XGF($C(13))
;
; Turn on echo, cursor, keypad in numeric mode
X ^%ZOSF("EON") W IOCUON_IOKPNM
;
; Get code to erase entire display
S X="IOEDALL" D ENDR^%ZISS
;
F D LA2 Q:LREND
D QUIT
;
Q
;
LA2 ;
N CUP,FLAG,I,ID,IDE,LADFN,LADT,LAOK,TRAY,TV,X,Y
;
S RMK=""
F D WLN Q:LREND!(LAOK)
I LREND Q
S FLAG=0
;
; Save value of LRDFN, call to LAGEN sets it to 0
S LADFN=LRDFN
S (ID,LOG)=LRAN,IDE=0,LADT=LRAD
S TRAY=1,CUP=""
;Can be changed by the cross-link code
X LAGEN
I 'ISQN D Q
. W !!,$C(7),"Unable to create entry in LAH global",!
;
S LRDFN=LADFN
;
D ^LAKDIFF1
I 'FLAG D ^LAKDIFF2
I FLAG Q
;
S I=0
F S I=$O(TV(I)) Q:I<1 S:TV(I,1)]"" ^LAH(LWL,1,ISQN,I)=TV(I,1)
I $L($G(RMK)) D RMK^LASET
;
D ^LAKDIFF3
Q
;
WLN ; Select accession/patient to work with
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
;
S LAOK=0
S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN))
I LRAN'>0 S LRAN="^"
S DIR(0)="NO^1:9999999:0^K:'$D(^LRO(68,LRAA,1,LRAD,1,X,0)) X"
S DIR("A")="Accession Number",DIR("B")=LRAN
S DIR("?")="Enter a valid accession number to enter DIFF results on."
D ^DIR
I $D(DIRUT) S LREND=1 Q
S LRAN=Y
;
S LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRACC=$S($D(^(.2)):^(.2),1:"")
S LRODT=$S($P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4):$P(^(0),U,4),1:$P(^(0),U,3)),LRSN=$P(^(0),U,5)
S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
;
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
D PT^LRX
;
K DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
;
S DIR(0)="YO"
S DIR("A",1)="Patient name: "_PNM_" SSN: "_SSN_" Acc: "_LRACC
S DIR("A")="Is this the correct patient"
S DIR("B")="YES"
D ^DIR
;
I $D(DIRUT) S LREND=1 Q
I Y=1 S LAOK=1
Q
;
INT ;
N I1,I2,I3,I4,LAI,LAJ,X
;
K KEY
;
I LALCT="T" D
. M ^TMP("LA",$J)=TC
. K TC
;
S LAI=0
F S LAI=$O(^TMP("LA",$J,LAI)) Q:LAI'>0 D
. S LAJ=$S(LAI<30:"W",1:"R")
. S I3=^(LAI,3),I4=^(4),X=^(0)
. ;
. I $D(KEY(LAJ,I4)) D Q
. . W $C(7),!!,">> The same KEY (",I4,") is set for more than one TEST<<",!!,$C(7)
. ;
. S I1=$P(^LAB(60,X,.1),U,1),I2=+^(.2)
. S ^TMP("LA",$J,LAI,.1)=I1,^(.2)=I2
. S ^TMP($J,LAJ,LAI)=I4,KEY(LAJ,I4)=""
. I I3=2 S ^TMP($J,"NC",LAI)=""
Q
;
DISPLAY ; Ask user if display should be updated on each key press
;
N DIR,DIROUT,DIRUT,DTOUT,LAXPAR,X,Y
;
; Get stored value from parameter tool
S X=$$GET^XPAR("USR","LA KDIFF DISPLAY UPDATE",1,"E")
;
I $L(X) S DIR("B")=X
E S DIR("B")="YES"
S DIR(0)="YO"
S DIR("A")="Update display on each key press"
D ^DIR
I $D(DIRUT) S LREND=1 Q
;
S LAUPDATE=Y
; Save parameter for future use
D EN^XPAR("USR","LA KDIFF DISPLAY UPDATE",1,Y,.LAXPAR)
Q
;
QUIT ;
;
I $D(ZTQUEUED) S ZTREQ="@"
;
I $G(LAXGF) D
. D CLEAN^XGF
. D KILL^%ZISS
;
S LREND=0
I $D(LRCSQ),'$O(^XTMP("LRCAP",LRCSQ,DUZ,0)) D
. K ^XTMP("LRCAP",LRCSQ,DUZ)
. K LRCSQ
;
I $D(LRCSQ),$G(LRAA),$P($G(^LRO(68,+LRAA,0)),U,16) D STD^LRCAPV
;
D STOP^LRCAPV
D ^LRGVK
;
K %,ACK,ASK,BASE,C,CENUM,CHK,CNT,CODE,CONT,CUP,DA,DATYP,DFN,DONE,DPF,ECHOALL,ER,FLAG,HDR,HOME,HRD,I,I1,I3,I4,ID,IDE,IDENT,IDT,IN,ISQN,J,K,KEY,L,LAGEN,LACT,LALCT,LANM,LAUPDATE,LAXGF,LINE
K LINK,LOG,LRAA,LRACC,LRAD,LRAN,LRDFN,LRDPF,LRDY,LREND,LRIDT,LRIO,LRLL,LRODT,LROVER,LRPGM,LRSET,LRSN,LRSUBS,LRTIME,LRTOP,LRTST,LWL,M,METH,NAK,NC,NOW,OUT,PNM,Q,RMK,RT,SS
K SSN,STORE,T,T1,T2,TC,TEMP,TOTAL,TOUT,TP,TQ,TRAP,TRAY,TRY,TSK,TV,TY,TYPE,V,WDT,WL,X,Y,YY,Z,ZTSK
;
K ^TMP($J),^TMP("LA",$J),^TMP("LR",$J)
Q
;
TRAP ; Error Trap
D ^LABERR
S T=TSK D SET^LAB
G @("LA2^"_LANM)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLAKDIFF 4910 printed Apr 09, 2024@20:46:39 Page 2
LAKDIFF ;DALOI/RWF - KEYBOARD DIFFERENTIAL COUNTER ;8/16/90 10:38
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**13,52**;Sep 27, 1994
+2 ;
+3 ; Cross link by id = accession
+4 ;
LA1 ;
+1 IF '$DATA(LRPARAM)
DO ^LRPARAM
+2 ;
+3 DO HOME^%ZIS
+4 ;
+5 SET LANM=$TEXT(+0)
SET TSK=$ORDER(^LAB(62.4,"C",LANM,0))
SET U="^"
+6 IF TSK<1
Begin DoDot:1
+7 WRITE !,"Unable to find entry in AUTO INSTRUMENT file using ",LANM," as PROGRAM NAME"
+8 DO QUIT
End DoDot:1
QUIT
+9 ;
+10 WRITE !!?20,"KEYPAD DIFF ENTRY",!!
+11 ;
+12 SET LREND=0
SET LRTOP=$PIECE(^LAB(69.9,1,1),U,1)
+13 DO ^LASET
+14 IF 'TSK
Begin DoDot:1
+15 WRITE $CHAR(7),!!,"AUTO INSTRUMENT file is incompletly defined for the Keypad Diff."
+16 DO QUIT
End DoDot:1
QUIT
+17 ;
+18 IF LALCT="N"
Begin DoDot:1
+19 WRITE $CHAR(7),!!,"Field LOAD CHEM TESTS is configured incorrectly in AUTO INSTRUMENT File"
+20 WRITE !,"Set it to either 'TC ARRAY' or 'TMP GLOBAL'."
+21 DO QUIT
End DoDot:1
QUIT
+22 ;
+23 KILL ^LA("LOCK",TSK)
+24 ;
+25 SET DTIME=$$DTIME^XUP(DUZ)
+26 SET DT=$$DT^XLFDT
+27 ;
+28 DO DISPLAY
+29 IF LREND
DO QUIT
QUIT
+30 ;
+31 ; Select accession date to use
+32 SET LRAA=+$GET(WL)
+33 IF LRAA<1
DO QUIT
QUIT
+34 DO ADATE^LRWU
+35 IF LREND
DO QUIT
QUIT
+36 ;
+37 ; Get last accession used on this date if any
+38 SET LRAN=+$PIECE($GET(^LRO(68,LRAA,1,LRAD,2)),"^",4)
+39 ;
+40 IF $PIECE(LRPARAM,U,14)
IF $PIECE($GET(^LRO(68,LRAA,0)),U,16)
DO ^LRCAPV
+41 IF LREND
DO QUIT
QUIT
+42 ;
+43 DO INT
+44 ;
+45 ; Setup screen and keyboard
+46 SET LAXGF=1
DO PREP^XGF
+47 ;
+48 ; Set read terminator to <CR>. Otherwise problems in scroll&roll sections.
+49 DO INITKB^XGF($CHAR(13))
+50 ;
+51 ; Turn on echo, cursor, keypad in numeric mode
+52 XECUTE ^%ZOSF("EON")
WRITE IOCUON_IOKPNM
+53 ;
+54 ; Get code to erase entire display
+55 SET X="IOEDALL"
DO ENDR^%ZISS
+56 ;
+57 FOR
DO LA2
if LREND
QUIT
+58 DO QUIT
+59 ;
+60 QUIT
+61 ;
LA2 ;
+1 NEW CUP,FLAG,I,ID,IDE,LADFN,LADT,LAOK,TRAY,TV,X,Y
+2 ;
+3 SET RMK=""
+4 FOR
DO WLN
if LREND!(LAOK)
QUIT
+5 IF LREND
QUIT
+6 SET FLAG=0
+7 ;
+8 ; Save value of LRDFN, call to LAGEN sets it to 0
+9 SET LADFN=LRDFN
+10 SET (ID,LOG)=LRAN
SET IDE=0
SET LADT=LRAD
+11 SET TRAY=1
SET CUP=""
+12 ;Can be changed by the cross-link code
+13 XECUTE LAGEN
+14 IF 'ISQN
Begin DoDot:1
+15 WRITE !!,$CHAR(7),"Unable to create entry in LAH global",!
End DoDot:1
QUIT
+16 ;
+17 SET LRDFN=LADFN
+18 ;
+19 DO ^LAKDIFF1
+20 IF 'FLAG
DO ^LAKDIFF2
+21 IF FLAG
QUIT
+22 ;
+23 SET I=0
+24 FOR
SET I=$ORDER(TV(I))
if I<1
QUIT
if TV(I,1)]""
SET ^LAH(LWL,1,ISQN,I)=TV(I,1)
+25 IF $LENGTH($GET(RMK))
DO RMK^LASET
+26 ;
+27 DO ^LAKDIFF3
+28 QUIT
+29 ;
WLN ; Select accession/patient to work with
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+2 ;
+3 SET LAOK=0
+4 SET LRAN=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN))
+5 IF LRAN'>0
SET LRAN="^"
+6 SET DIR(0)="NO^1:9999999:0^K:'$D(^LRO(68,LRAA,1,LRAD,1,X,0)) X"
+7 SET DIR("A")="Accession Number"
SET DIR("B")=LRAN
+8 SET DIR("?")="Enter a valid accession number to enter DIFF results on."
+9 DO ^DIR
+10 IF $DATA(DIRUT)
SET LREND=1
QUIT
+11 SET LRAN=Y
+12 ;
+13 SET LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRACC=$SELECT($DATA(^(.2)):^(.2),1:"")
+14 SET LRODT=$SELECT($PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4):$PIECE(^(0),U,4),1:$PIECE(^(0),U,3))
SET LRSN=$PIECE(^(0),U,5)
+15 SET LRIDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
+16 ;
+17 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+18 DO PT^LRX
+19 ;
+20 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+21 ;
+22 SET DIR(0)="YO"
+23 SET DIR("A",1)="Patient name: "_PNM_" SSN: "_SSN_" Acc: "_LRACC
+24 SET DIR("A")="Is this the correct patient"
+25 SET DIR("B")="YES"
+26 DO ^DIR
+27 ;
+28 IF $DATA(DIRUT)
SET LREND=1
QUIT
+29 IF Y=1
SET LAOK=1
+30 QUIT
+31 ;
INT ;
+1 NEW I1,I2,I3,I4,LAI,LAJ,X
+2 ;
+3 KILL KEY
+4 ;
+5 IF LALCT="T"
Begin DoDot:1
+6 MERGE ^TMP("LA",$JOB)=TC
+7 KILL TC
End DoDot:1
+8 ;
+9 SET LAI=0
+10 FOR
SET LAI=$ORDER(^TMP("LA",$JOB,LAI))
if LAI'>0
QUIT
Begin DoDot:1
+11 SET LAJ=$SELECT(LAI<30:"W",1:"R")
+12 SET I3=^(LAI,3)
SET I4=^(4)
SET X=^(0)
+13 ;
+14 IF $DATA(KEY(LAJ,I4))
Begin DoDot:2
+15 WRITE $CHAR(7),!!,">> The same KEY (",I4,") is set for more than one TEST<<",!!,$CHAR(7)
End DoDot:2
QUIT
+16 ;
+17 SET I1=$PIECE(^LAB(60,X,.1),U,1)
SET I2=+^(.2)
+18 SET ^TMP("LA",$JOB,LAI,.1)=I1
SET ^(.2)=I2
+19 SET ^TMP($JOB,LAJ,LAI)=I4
SET KEY(LAJ,I4)=""
+20 IF I3=2
SET ^TMP($JOB,"NC",LAI)=""
End DoDot:1
+21 QUIT
+22 ;
DISPLAY ; Ask user if display should be updated on each key press
+1 ;
+2 NEW DIR,DIROUT,DIRUT,DTOUT,LAXPAR,X,Y
+3 ;
+4 ; Get stored value from parameter tool
+5 SET X=$$GET^XPAR("USR","LA KDIFF DISPLAY UPDATE",1,"E")
+6 ;
+7 IF $LENGTH(X)
SET DIR("B")=X
+8 IF '$TEST
SET DIR("B")="YES"
+9 SET DIR(0)="YO"
+10 SET DIR("A")="Update display on each key press"
+11 DO ^DIR
+12 IF $DATA(DIRUT)
SET LREND=1
QUIT
+13 ;
+14 SET LAUPDATE=Y
+15 ; Save parameter for future use
+16 DO EN^XPAR("USR","LA KDIFF DISPLAY UPDATE",1,Y,.LAXPAR)
+17 QUIT
+18 ;
QUIT ;
+1 ;
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 ;
+4 IF $GET(LAXGF)
Begin DoDot:1
+5 DO CLEAN^XGF
+6 DO KILL^%ZISS
End DoDot:1
+7 ;
+8 SET LREND=0
+9 IF $DATA(LRCSQ)
IF '$ORDER(^XTMP("LRCAP",LRCSQ,DUZ,0))
Begin DoDot:1
+10 KILL ^XTMP("LRCAP",LRCSQ,DUZ)
+11 KILL LRCSQ
End DoDot:1
+12 ;
+13 IF $DATA(LRCSQ)
IF $GET(LRAA)
IF $PIECE($GET(^LRO(68,+LRAA,0)),U,16)
DO STD^LRCAPV
+14 ;
+15 DO STOP^LRCAPV
+16 DO ^LRGVK
+17 ;
+18 KILL %,ACK,ASK,BASE,C,CENUM,CHK,CNT,CODE,CONT,CUP,DA,DATYP,DFN,DONE,DPF,ECHOALL,ER,FLAG,HDR,HOME,HRD,I,I1,I3,I4,ID,IDE,IDENT,IDT,IN,ISQN,J,K,KEY,L,LAGEN,LACT,LALCT,LANM,LAUPDATE,LAXGF,LINE
+19 KILL LINK,LOG,LRAA,LRACC,LRAD,LRAN,LRDFN,LRDPF,LRDY,LREND,LRIDT,LRIO,LRLL,LRODT,LROVER,LRPGM,LRSET,LRSN,LRSUBS,LRTIME,LRTOP,LRTST,LWL,M,METH,NAK,NC,NOW,OUT,PNM,Q,RMK,RT,SS
+20 KILL SSN,STORE,T,T1,T2,TC,TEMP,TOTAL,TOUT,TP,TQ,TRAP,TRAY,TRY,TSK,TV,TY,TYPE,V,WDT,WL,X,Y,YY,Z,ZTSK
+21 ;
+22 KILL ^TMP($JOB),^TMP("LA",$JOB),^TMP("LR",$JOB)
+23 QUIT
+24 ;
TRAP ; Error Trap
+1 DO ^LABERR
+2 SET T=TSK
DO SET^LAB
+3 GOTO @("LA2^"_LANM)
