LAMIVTL1 ;VA/DAL/HOAK - 2nd Vitek literal verify rtn ;1/22/96 08:30 ;
;;5.2;AUTOMATED LAB INSTRUMENTS;**1030**;NOV 1, 1997
;;5.2;AUTOMATED LAB INSTRUMENTS;**12,29**;Sep 27,1994;Build 7
INIT ;
S OK=1
S LREND=0
D CONTROL
Q
CONTROL ;
W @IOF
D SETUP Q:'OK
D EXP Q:'OK
D ^LAMIVTL2
Q
SETUP ;
; Set up variables for PROCESSING
S LRAN=LRANX
;I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN)) S OK=0 QUIT ;-----Back to Control
S LRNODE=^LRO(68,LRAA,1,LRAD,1,LRAN,0) S LRACCN=^(.2)
S LRDFN=+LRNODE
S LRDPF=$P(LRNODE,U,2)
S LRLLOC=$P(LRNODE,U,7)
S LRPHY=$P(LRNODE,U,8)
S LRODT=$P(LRNODE,U,4)
S LRSN=$P(LRNODE,U,5)
;---------------------------------------------------------------------
; Reset LRNODE----------------------------------------------\/
S LRIDT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5) S LRNODE=^(3)
S LRCDT=$P(LRNODE,U)
S LRDTR=$P(LRNODE,U,3)
S LREAL=$P(LRNODE,U,2)
S LRSUB=$P(^LRO(68,LRAA,0),U,2)
;----------------------------------------------------------------------
EN ; From LAMIAUT0 BY FHS
S LRI=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0)) I $D(^(LRI,0)) D
. S LRSPEC=+^LRO(68,LRAA,1,LRAD,1,LRAN,5,LRI,0),LRSAMP=+$P(^(0),U,2)
S DFN=$P(^LR(LRDFN,0),U,3)
S LRPHYN=$S($D(^VA(200,+LRPHY,0)):$P(^(0),U),1:"Unknown")
;----------------------------------------------------------------------
PAT ;
D PT^LRX
W !,"ACC # (",LRAN,") "
; W $$DTF^LRAFUNC1(LRCDT),!!?10,PNM," SSN: ",SSN," LOC: ",LRLLOC
W $$DTF^LRAFUNC1(LRCDT),!!?10,PNM," HRCN: ",HRCN," LOC: ",LRLLOC ;IHS/OIRM TUC/AAB 12/10/97
W !?5,"Specimen: "
W $S($D(^LAB(61,+LRSPEC,0)):$P(^(0),U),1:"Unknown")
W " Sample: ",$S($D(^LAB(62,+LRSAMP,0)):$P(^(0),U),1:"Unknown"),!
I $D(^LRO(69,LRODT,1,LRSN,6,+$O(^LRO(69,LRODT,1,LRSN,6,0)),0)) D
. W !," Comment on Specimem "
S I=0
F A=0:0 S I=$O(^LRO(69,LRODT,1,LRSN,6,I)) Q:I="" W ?30,^(I,0),!
I $D(^LR(LRDFN,"MI",LRIDT,2,+$O(^LR(LRDFN,"MI",LRIDT,2,0)),0)) D
. W !,"GRAM STAIN "
. S I=0
. F A=0:0 S I=$O(^LR(LRDFN,"MI",LRIDT,2,I)) Q:I="" W ?15,^(I,0),!
I $D(^LR(LRDFN,"MI",LRIDT,99)) W !,"Comment on Specimen : ",^(99)
S %=1
W !!?10,"Is this the correct patient/specimen? "
D YN^DICN
I %'=1 S OK=0 QUIT
QUIT
EXP ; From LAMIAUT4 BY FHS
;---------------------------------------------------------------------
;Get the list of tests for this ACC.
; W !!,PNM," ",SSN,!,LRACCN
W !!,PNM," ",HRCN,!,LRACCN ;IHS/OIRM TUC/AAB 12/10/97
D INF^LRX
W !!?5,$P(^LAB(61,LRSPEC,0),U)," ",$P(^LAB(62,LRSAMP,0),U),!
K ^TMP("LR",$J),LRTEST,LRNAME,LRTS
S N=0
F I=0:0 S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<1 D
. S N=N+1,LRTEST(N)=+^(I,0)
S LRNTN=N
F I=1:1:N D
. S:$D(^LAB(60,+LRTEST(I),0)) LRTEST(I)=LRTEST(I)_U_^(0) D
.. S LRNAME(I)=$P(LRTEST(I),U,2)
.. S LRNAME(I,+LRTEST(I))=""
.. S LRTS(I)=LRNAME(I)
.. S LRTS(I,+LRTEST(I))=""
S LRALL=""
F I=1:1:LRNTN I $D(LRNAME(I)) D
. S LRTS=+$O(LRNAME(I,0))
. S LRALL=LRALL_","_I
. W !,I," ",LRNAME(I) D
.. I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+$O(LRNAME(I,0)),0)),$P(^(0),U,5) W ?25," verified" S LRNOTO=1
;-----------------------------------------------------------------------
V9 ;
W !
S LRALL=$P(LRALL,",",2,99)
S DIR(0)="F"
S DIR("A")="Please enter the test number(s) or "
S DIR("B")="ALL"
S DIR("?")="Enter ALL, a number, or a range separated by `,' ie 1,2,3."
D ^DIR
S:$D(DUOUT)!($D(DTOUT)) OK=0 I 'OK S LREND=1
S:Y="ALL" Y=LRALL S:Y["A" Y=LRALL
D RANGE^LRWU2 Q:X9="" X (X9_"S:'$D(LRNAME(T1)) X=0") I X=0 W !!?7,"Incorrect test number ",$C(7) G EXP
Q
LAMIVTL1 ;VA/DAL/HOAK - 2nd Vitek literal verify rtn ;1/22/96 08:30 ;
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**1030**;NOV 1, 1997
+2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**12,29**;Sep 27,1994;Build 7
INIT ;
+1 SET OK=1
+2 SET LREND=0
+3 DO CONTROL
+4 QUIT
CONTROL ;
+1 WRITE @IOF
+2 DO SETUP
IF 'OK
QUIT
+3 DO EXP
IF 'OK
QUIT
+4 DO ^LAMIVTL2
+5 QUIT
SETUP ;
+1 ; Set up variables for PROCESSING
+2 SET LRAN=LRANX
+3 ;I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN)) S OK=0 QUIT ;-----Back to Control
+4 SET LRNODE=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRACCN=^(.2)
+5 SET LRDFN=+LRNODE
+6 SET LRDPF=$PIECE(LRNODE,U,2)
+7 SET LRLLOC=$PIECE(LRNODE,U,7)
+8 SET LRPHY=$PIECE(LRNODE,U,8)
+9 SET LRODT=$PIECE(LRNODE,U,4)
+10 SET LRSN=$PIECE(LRNODE,U,5)
+11 ;---------------------------------------------------------------------
+12 ; Reset LRNODE----------------------------------------------\/
+13 SET LRIDT=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5)
SET LRNODE=^(3)
+14 SET LRCDT=$PIECE(LRNODE,U)
+15 SET LRDTR=$PIECE(LRNODE,U,3)
+16 SET LREAL=$PIECE(LRNODE,U,2)
+17 SET LRSUB=$PIECE(^LRO(68,LRAA,0),U,2)
+18 ;----------------------------------------------------------------------
EN ; From LAMIAUT0 BY FHS
+1 SET LRI=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0))
IF $DATA(^(LRI,0))
Begin DoDot:1
+2 SET LRSPEC=+^LRO(68,LRAA,1,LRAD,1,LRAN,5,LRI,0)
SET LRSAMP=+$PIECE(^(0),U,2)
End DoDot:1
+3 SET DFN=$PIECE(^LR(LRDFN,0),U,3)
+4 SET LRPHYN=$SELECT($DATA(^VA(200,+LRPHY,0)):$PIECE(^(0),U),1:"Unknown")
+5 ;----------------------------------------------------------------------
PAT ;
+1 DO PT^LRX
+2 WRITE !,"ACC # (",LRAN,") "
+3 ; W $$DTF^LRAFUNC1(LRCDT),!!?10,PNM," SSN: ",SSN," LOC: ",LRLLOC
+4 ;IHS/OIRM TUC/AAB 12/10/97
WRITE $$DTF^LRAFUNC1(LRCDT),!!?10,PNM," HRCN: ",HRCN," LOC: ",LRLLOC
+5 WRITE !?5,"Specimen: "
+6 WRITE $SELECT($DATA(^LAB(61,+LRSPEC,0)):$PIECE(^(0),U),1:"Unknown")
+7 WRITE " Sample: ",$SELECT($DATA(^LAB(62,+LRSAMP,0)):$PIECE(^(0),U),1:"Unknown"),!
+8 IF $DATA(^LRO(69,LRODT,1,LRSN,6,+$ORDER(^LRO(69,LRODT,1,LRSN,6,0)),0))
Begin DoDot:1
+9 WRITE !," Comment on Specimem "
End DoDot:1
+10 SET I=0
+11 FOR A=0:0
SET I=$ORDER(^LRO(69,LRODT,1,LRSN,6,I))
IF I=""
QUIT
WRITE ?30,^(I,0),!
+12 IF $DATA(^LR(LRDFN,"MI",LRIDT,2,+$ORDER(^LR(LRDFN,"MI",LRIDT,2,0)),0))
Begin DoDot:1
+13 WRITE !,"GRAM STAIN "
+14 SET I=0
+15 FOR A=0:0
SET I=$ORDER(^LR(LRDFN,"MI",LRIDT,2,I))
IF I=""
QUIT
WRITE ?15,^(I,0),!
End DoDot:1
+16 IF $DATA(^LR(LRDFN,"MI",LRIDT,99))
WRITE !,"Comment on Specimen : ",^(99)
+17 SET %=1
+18 WRITE !!?10,"Is this the correct patient/specimen? "
+19 DO YN^DICN
+20 IF %'=1
SET OK=0
QUIT
+21 QUIT
EXP ; From LAMIAUT4 BY FHS
+1 ;---------------------------------------------------------------------
+2 ;Get the list of tests for this ACC.
+3 ; W !!,PNM," ",SSN,!,LRACCN
+4 ;IHS/OIRM TUC/AAB 12/10/97
WRITE !!,PNM," ",HRCN,!,LRACCN
+5 DO INF^LRX
+6 WRITE !!?5,$PIECE(^LAB(61,LRSPEC,0),U)," ",$PIECE(^LAB(62,LRSAMP,0),U),!
+7 KILL ^TMP("LR",$JOB),LRTEST,LRNAME,LRTS
+8 SET N=0
+9 FOR I=0:0
SET I=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I))
IF I<1
QUIT
Begin DoDot:1
+10 SET N=N+1
SET LRTEST(N)=+^(I,0)
End DoDot:1
+11 SET LRNTN=N
+12 FOR I=1:1:N
Begin DoDot:1
+13 IF $DATA(^LAB(60,+LRTEST(I),0))
SET LRTEST(I)=LRTEST(I)_U_^(0)
Begin DoDot:2
+14 SET LRNAME(I)=$PIECE(LRTEST(I),U,2)
+15 SET LRNAME(I,+LRTEST(I))=""
+16 SET LRTS(I)=LRNAME(I)
+17 SET LRTS(I,+LRTEST(I))=""
End DoDot:2
End DoDot:1
+18 SET LRALL=""
+19 FOR I=1:1:LRNTN
IF $DATA(LRNAME(I))
Begin DoDot:1
+20 SET LRTS=+$ORDER(LRNAME(I,0))
+21 SET LRALL=LRALL_","_I
+22 WRITE !,I," ",LRNAME(I)
Begin DoDot:2
+23 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+$ORDER(LRNAME(I,0)),0))
IF $PIECE(^(0),U,5)
WRITE ?25," verified"
SET LRNOTO=1
End DoDot:2
End DoDot:1
+24 ;-----------------------------------------------------------------------
V9 ;
+1 WRITE !
+2 SET LRALL=$PIECE(LRALL,",",2,99)
+3 SET DIR(0)="F"
+4 SET DIR("A")="Please enter the test number(s) or "
+5 SET DIR("B")="ALL"
+6 SET DIR("?")="Enter ALL, a number, or a range separated by `,' ie 1,2,3."
+7 DO ^DIR
+8 IF $DATA(DUOUT)!($DATA(DTOUT))
SET OK=0
IF 'OK
SET LREND=1
+9 IF Y="ALL"
SET Y=LRALL
IF Y["A"
SET Y=LRALL
+10 DO RANGE^LRWU2
IF X9=""
QUIT
XECUTE (X9_"S:'$D(LRNAME(T1)) X=0")
IF X=0
WRITE !!?7,"Incorrect test number ",$CHAR(7)
GOTO EXP
+11 QUIT
