LAMIAUT7 ; IHS/DIR/AAB - CREATE LOAD LIST FOR VITEK 7/20/90 09:34 ; [ 7/20/90 10:15 AM ]
;;5.2;LA;**1003**;SEP 01, 1998
;
;;5.2;AUTOMATED LAB INSTRUMENTS;**42**;Sep 27, 1994
EN ;
S U="^",(LROPEN,LREND)=0 D DT^LRX S LRAD=DT K ^TMP("LR",$J,"T"),DIC,LRHOLD,LRTSTS
K DIC S DIC="^LRO(68.2,",DIC(0)="AEMZ" D ^DIC S LRINST=+Y Q:Y<1
I $P(Y(0),U,12) S LRP=12 D ACCESS I LREND W !!?10,"Access denied to this Load Work list " G EXIT
I $S($D(^LRO(68.2,LRINST,3)):$P(^(3),U,1),1:0) W !?10,"Load list is busy now. Try later" G EXIT
L ^LRO(68.2,LRINST,3):1 I '$T W !!?7,$C(7),"Some one else is editing this List",!! G EXIT
S $P(^LRO(68.2,LRINST,3),U,1)=1,LROPEN=1 L
CLEAR ;
K LRCTRL,LRDSPEC,LRTP
G:'$D(^LRO(68.2,LRINST,0)) EXIT S Y(0)=^(0),LRTRANS=+$P(Y(0),U,2),LRTYPE=+$P(Y(0),U,3),LRFULL=$P(Y(0),U,5),LRINSTIT=+$P(Y(0),U,7),LRMAXCUP=$S($P(Y(0),U,4):$P(Y(0),U,4),1:30)
D CLEAR^LAMIAUT8
S Y(2)=$S($D(^LRO(68.2,LRINST,2)):^(2),1:""),LRTRAY=$S($P(Y(2),U,4):$P(Y(2),U,4),1:1),LRCUP=$S($P(Y(2),U,5):$P(Y(2),U,5),1:0)
S LRTRANS=$S($D(^LAB(62.07,LRTRANS,.1)):^(.1),1:"S LRCUP=LRCUP+1"),LRINSTIT=$S($D(^LAB(62.07,LRINSTIT,.1)):^(.1),1:"Q")
S LRP=$P(^LRO(68.2,LRINST,10,$O(^LRO(68.2,LRINST,10,0)),0),U,2),LRP=$P(^LRO(68,LRP,0),U,3)
S %DT="AEP",%DT("A")=" Accession Date : ",%DT("B")=$S(LRP="D":LRDT0,1:$$FMTE^XLFDT($E(DT,1,3)_"0000","1D")) D DATE^LRWU I Y<1 S LRO(68.2,LRINST,3)=0 G EXIT
S LRAD=+Y,LRALL=0 S:'LRTYPE LRTRAY=1 I '$O(^LRO(68.2,LRINST,10,0)) W !!?10,"No profile defined for this Load/List ",$C(7) G EXIT
PROF ;
;S LRALL=0 W !?5,"ALL PROFILES " S %=2 D YN^DICN G:%<0 EXIT S:%=1 LRALL=1 I %=2 K DIC S DIC="^LRO(68.2,"_LRINST_",10,",DIC(0)="AQEZ" D ^DIC G:Y<1 EXIT S LRPROF=+Y D PROF^LAMIAUT8 I LREND D EXIT Q
S LRALL=0 W !?5,"ALL PROFILES " S %=1 D YN^DICN G:%<0 EXIT S:%=1 LRALL=1 I %=2 K DIC S DIC="^LRO(68.2,"_LRINST_",10,",DIC(0)="AQEZ" D ^DIC G:Y<1 EXIT S LRPROF=+Y D PROF^LAMIAUT8 I LREND D EXIT Q ;IHS/ANMC/CLS 11/1/95
I %=0 W !!?5,"You may select a single profile or all profiles defined. ",!! G PROF
I LRALL F LRPROF=0:0 S LRPROF=$O(^LRO(68.2,LRINST,10,LRPROF)) Q:LRPROF<1 D PROF^LAMIAUT8 I LREND D EXIT Q
I '$D(LRAA) W !!?10,"No Accession area defined ",! D EXIT Q
I 'LRAA W !!?10,"No Accession area defined",! D EXIT Q
ACCN ;get list of accession numbers
K LRACNL W !?5,"Enter your list of accession numbers separated by ',' or - ",!,"You can string them together, example 1,2,3-6,7,110. ",!
F A=1:1 R !,"Enter Acc #(s) ",X:DTIME S:'$T LREND=1 Q:X=""!(LREND) G EXIT:$E(X)="^" D ^LRWU2 S:$L(X9) LRACNL(A)=X9 I '$L(X9) W !!?10,"Incorrect format ",$C(7),!!
G EXIT:'$O(LRACNL(0))!(LREND) D CHK G EXIT:LREND
I $O(^TMP("LR",$J,"T",0)) D STUFF^LAMIAUT8 S LRINSTS=LRINST D ^LRLLP S LRINST=LRINSTS
EXIT ;
S:LROPEN ^LRO(68.2,LRINST,3)=0 K LROPEN,%,AA,C,DUOUT,I,J,LAST,LRAA,LRAD,LRAN,LRCT,LRCTRL,LRCUP,LRDSPEC,LREND,LRINST,LRKEY,LRP,LRPROF,LRINSTS,LRSPEC,LRTP,LRTRANS,LRTRAY
K LRURG,T,X,Y,LRFULL,LRACNL,LRALL,LRINSTIT,^TMP("LR",$J,"T")
Q
ACCESS ;
S LRKEY=+$P(Y(0),U,LRP),LRKEY=$S($D(^DIC(19.1,LRKEY,0)):$P(^(0),U),1:0),LREND=$S($D(^XUSEC(LRKEY,DUZ)):0,1:1)
Q
CHK ;
S P=0 F A=0:0 S A=$O(LRACNL(A)) Q:A="" X LRACNL(A)_"S:$D(^LRO(68,LRAA,1,LRAD,1,T1,0)) X=+^(0)_U_+^(5,1,0),^TMP(""LR"",$J,""T"",T1)=X"
SHOW ;
;S A=0 D HDR F A=A:0 S A=$O(^TMP("LR",$J,"T",A)) Q:A="" S LRDFN=+^(A),X=^LR(LRDFN,0),LRDPF=$P(X,U,2),DFN=$P(X,U,3) D PT^LRX W !,A_")",?15,PNM,?35,SSN D:$Y>20 WAIT Q:LREND
S A=0 D HDR F A=A:0 S A=$O(^TMP("LR",$J,"T",A)) Q:A="" S LRDFN=+^(A),X=^LR(LRDFN,0),LRDPF=$P(X,U,2),DFN=$P(X,U,3) D PT^LRX W !,A_")",?15,PNM,?35,HRCN D:$Y>20 WAIT Q:LREND ;IHS/ANMC/CLS 11/1/95
WAIT ;
W !!,?10,$S(A>0:"Is this partial list correct ",1:" All OK ? ") S %=1 D YN^DICN I %=1 D HDR Q
I %<1 S LREND=1 Q
W1 W !!,"(A)dd OR (D)elete " R W:DTIME I '$T!($E(W)="^") S LREND=1 Q
Q:W="" I "AD"'[W W !,$C(7) G W1
F WW=0:0 W !?5,"Enter number to "_$S(W="A":"Add ",1:"Delete ") R X:DTIME Q:'$T!(X="")!($E(X)="^") D:X'="?" @($S(W="A":"ADD",1:"DELETE")_"^LAMIAUT8") I X="?" W !?10,"Enter accession number, one at a time."
HDR ;
;W @IOF,!!!,"Acc #)",?15," Patient Name SSN ",!! Q
W @IOF,!!!,"Acc #)",?15," Patient Name HRCN ",!! Q ;IHS/ANMC/CLS 11/1/95
LAMIAUT7 ; IHS/DIR/AAB - CREATE LOAD LIST FOR VITEK 7/20/90 09:34 ; [ 7/20/90 10:15 AM ]
+1 ;;5.2;LA;**1003**;SEP 01, 1998
+2 ;
+3 ;;5.2;AUTOMATED LAB INSTRUMENTS;**42**;Sep 27, 1994
EN ;
+1 SET U="^"
SET (LROPEN,LREND)=0
DO DT^LRX
SET LRAD=DT
KILL ^TMP("LR",$JOB,"T"),DIC,LRHOLD,LRTSTS
+2 KILL DIC
SET DIC="^LRO(68.2,"
SET DIC(0)="AEMZ"
DO ^DIC
SET LRINST=+Y
IF Y<1
QUIT
+3 IF $PIECE(Y(0),U,12)
SET LRP=12
DO ACCESS
IF LREND
WRITE !!?10,"Access denied to this Load Work list "
GOTO EXIT
+4 IF $SELECT($DATA(^LRO(68.2,LRINST,3)):$PIECE(^(3),U,1),1:0)
WRITE !?10,"Load list is busy now. Try later"
GOTO EXIT
+5 LOCK ^LRO(68.2,LRINST,3):1
IF '$TEST
WRITE !!?7,$CHAR(7),"Some one else is editing this List",!!
GOTO EXIT
+6 SET $PIECE(^LRO(68.2,LRINST,3),U,1)=1
SET LROPEN=1
LOCK
CLEAR ;
+1 KILL LRCTRL,LRDSPEC,LRTP
+2 IF '$DATA(^LRO(68.2,LRINST,0))
GOTO EXIT
SET Y(0)=^(0)
SET LRTRANS=+$PIECE(Y(0),U,2)
SET LRTYPE=+$PIECE(Y(0),U,3)
SET LRFULL=$PIECE(Y(0),U,5)
SET LRINSTIT=+$PIECE(Y(0),U,7)
SET LRMAXCUP=$SELECT($PIECE(Y(0),U,4):$PIECE(Y(0),U,4),1:30)
+3 DO CLEAR^LAMIAUT8
+4 SET Y(2)=$SELECT($DATA(^LRO(68.2,LRINST,2)):^(2),1:"")
SET LRTRAY=$SELECT($PIECE(Y(2),U,4):$PIECE(Y(2),U,4),1:1)
SET LRCUP=$SELECT($PIECE(Y(2),U,5):$PIECE(Y(2),U,5),1:0)
+5 SET LRTRANS=$SELECT($DATA(^LAB(62.07,LRTRANS,.1)):^(.1),1:"S LRCUP=LRCUP+1")
SET LRINSTIT=$SELECT($DATA(^LAB(62.07,LRINSTIT,.1)):^(.1),1:"Q")
+6 SET LRP=$PIECE(^LRO(68.2,LRINST,10,$ORDER(^LRO(68.2,LRINST,10,0)),0),U,2)
SET LRP=$PIECE(^LRO(68,LRP,0),U,3)
+7 SET %DT="AEP"
SET %DT("A")=" Accession Date : "
SET %DT("B")=$SELECT(LRP="D":LRDT0,1:$$FMTE^XLFDT($EXTRACT(DT,1,3)_"0000","1D"))
DO DATE^LRWU
IF Y<1
SET LRO(68.2,LRINST,3)=0
GOTO EXIT
+8 SET LRAD=+Y
SET LRALL=0
IF 'LRTYPE
SET LRTRAY=1
IF '$ORDER(^LRO(68.2,LRINST,10,0))
WRITE !!?10,"No profile defined for this Load/List ",$CHAR(7)
GOTO EXIT
PROF ;
+1 ;S LRALL=0 W !?5,"ALL PROFILES " S %=2 D YN^DICN G:%<0 EXIT S:%=1 LRALL=1 I %=2 K DIC S DIC="^LRO(68.2,"_LRINST_",10,",DIC(0)="AQEZ" D ^DIC G:Y<1 EXIT S LRPROF=+Y D PROF^LAMIAUT8 I LREND D EXIT Q
+2 ;IHS/ANMC/CLS 11/1/95
SET LRALL=0
WRITE !?5,"ALL PROFILES "
SET %=1
DO YN^DICN
IF %<0
GOTO EXIT
IF %=1
SET LRALL=1
IF %=2
KILL DIC
SET DIC="^LRO(68.2,"_LRINST_",10,"
SET DIC(0)="AQEZ"
DO ^DIC
IF Y<1
GOTO EXIT
SET LRPROF=+Y
DO PROF^LAMIAUT8
IF LREND
DO EXIT
QUIT
+3 IF %=0
WRITE !!?5,"You may select a single profile or all profiles defined. ",!!
GOTO PROF
+4 IF LRALL
FOR LRPROF=0:0
SET LRPROF=$ORDER(^LRO(68.2,LRINST,10,LRPROF))
IF LRPROF<1
QUIT
DO PROF^LAMIAUT8
IF LREND
DO EXIT
QUIT
+5 IF '$DATA(LRAA)
WRITE !!?10,"No Accession area defined ",!
DO EXIT
QUIT
+6 IF 'LRAA
WRITE !!?10,"No Accession area defined",!
DO EXIT
QUIT
ACCN ;get list of accession numbers
+1 KILL LRACNL
WRITE !?5,"Enter your list of accession numbers separated by ',' or - ",!,"You can string them together, example 1,2,3-6,7,110. ",!
+2 FOR A=1:1
READ !,"Enter Acc #(s) ",X:DTIME
IF '$TEST
SET LREND=1
IF X=""!(LREND)
QUIT
IF $EXTRACT(X)="^"
GOTO EXIT
DO ^LRWU2
IF $LENGTH(X9)
SET LRACNL(A)=X9
IF '$LENGTH(X9)
WRITE !!?10,"Incorrect format ",$CHAR(7),!!
+3 IF '$ORDER(LRACNL(0))!(LREND)
GOTO EXIT
DO CHK
IF LREND
GOTO EXIT
+4 IF $ORDER(^TMP("LR",$JOB,"T",0))
DO STUFF^LAMIAUT8
SET LRINSTS=LRINST
DO ^LRLLP
SET LRINST=LRINSTS
EXIT ;
+1 IF LROPEN
SET ^LRO(68.2,LRINST,3)=0
KILL LROPEN,%,AA,C,DUOUT,I,J,LAST,LRAA,LRAD,LRAN,LRCT,LRCTRL,LRCUP,LRDSPEC,LREND,LRINST,LRKEY,LRP,LRPROF,LRINSTS,LRSPEC,LRTP,LRTRANS,LRTRAY
+2 KILL LRURG,T,X,Y,LRFULL,LRACNL,LRALL,LRINSTIT,^TMP("LR",$JOB,"T")
+3 QUIT
ACCESS ;
+1 SET LRKEY=+$PIECE(Y(0),U,LRP)
SET LRKEY=$SELECT($DATA(^DIC(19.1,LRKEY,0)):$PIECE(^(0),U),1:0)
SET LREND=$SELECT($DATA(^XUSEC(LRKEY,DUZ)):0,1:1)
+2 QUIT
CHK ;
+1 SET P=0
FOR A=0:0
SET A=$ORDER(LRACNL(A))
IF A=""
QUIT
XECUTE LRACNL(A)_"S:$D(^LRO(68,LRAA,1,LRAD,1,T1,0)) X=+^(0)_U_+^(5,1,0),^TMP(""LR"",$J,""T"",T1)=X"
SHOW ;
+1 ;S A=0 D HDR F A=A:0 S A=$O(^TMP("LR",$J,"T",A)) Q:A="" S LRDFN=+^(A),X=^LR(LRDFN,0),LRDPF=$P(X,U,2),DFN=$P(X,U,3) D PT^LRX W !,A_")",?15,PNM,?35,SSN D:$Y>20 WAIT Q:LREND
+2 ;IHS/ANMC/CLS 11/1/95
SET A=0
DO HDR
FOR A=A:0
SET A=$ORDER(^TMP("LR",$JOB,"T",A))
IF A=""
QUIT
SET LRDFN=+^(A)
SET X=^LR(LRDFN,0)
SET LRDPF=$PIECE(X,U,2)
SET DFN=$PIECE(X,U,3)
DO PT^LRX
WRITE !,A_")",?15,PNM,?35,HRCN
IF $Y>20
DO WAIT
IF LREND
QUIT
WAIT ;
+1 WRITE !!,?10,$SELECT(A>0:"Is this partial list correct ",1:" All OK ? ")
SET %=1
DO YN^DICN
IF %=1
DO HDR
QUIT
+2 IF %<1
SET LREND=1
QUIT
W1 WRITE !!,"(A)dd OR (D)elete "
READ W:DTIME
IF '$TEST!($EXTRACT(W)="^")
SET LREND=1
QUIT
+1 IF W=""
QUIT
IF "AD"'[W
WRITE !,$CHAR(7)
GOTO W1
+2 FOR WW=0:0
WRITE !?5,"Enter number to "_$SELECT(W="A":"Add ",1:"Delete ")
READ X:DTIME
IF '$TEST!(X="")!($EXTRACT(X)="^")
QUIT
IF X'="?"
DO @($SELECT(W="A":"ADD",1:"DELETE")_"^LAMIAUT8")
IF X="?"
WRITE !?10,"Enter accession number, one at a time."
HDR ;
+1 ;W @IOF,!!!,"Acc #)",?15," Patient Name SSN ",!! Q
+2 ;IHS/ANMC/CLS 11/1/95
WRITE @IOF,!!!,"Acc #)",?15," Patient Name HRCN ",!!
QUIT
