- 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
