- LAMIAUT0 ;SLC/FHS - MICRO AUTO INSTRUMENT PROGRAM VITEK ;7/20/90 09:31 ;
- ;;5.2;AUTOMATED LAB INSTRUMENTS;**42,91**;Sep 27, 1994;Build 4
- EN ;
- D CLEAN,^LRPARAM S LRMIDEF=$P(^LAB(69.9,1,1),U,10),LRMIOTH=$P(^(1),U,11),LRINI=$P(^VA(200,DUZ,0),U,2),LRMICOM=$S($D(^DD(63.31,.01,0)):$P(^(0),U,5,99),1:"S Q9=""1,68,KM"" D COM^LRNUM"),LRMICOMS=$P($P(LRMICOM,",",3),"""",1)
- S LRTEC=LRINI K DIC S DIC=68,DIC(0)="ZMAQE",DIC("S")="I $P(^(0),U,2)=""MI""" D ^DIC G CLEAN:Y<1 S (LRCAPMS,LRAAD,LRCAPWA)=+Y,LAMIAUTO=1
- ACCESS I $P(Y(0),U,14),'$D(^XUSEC($P(^DIC(19.1,$P(Y(0),U,14),0),U),DUZ)) W !!?10,"ACCESS IS DENIED ",$C(7) G CLEAN
- S TAB1="?20",TAB2="?30",TAB3="?35",LREND=0,LRFIFO=0
- S LRTRAN=$P(^LRO(68,LRAAD,0),U,3)
- S DT=$$DT^XLFDT
- S %DT="AEP",%DT("A")="Select "_$S(LRTRAN=""!("WMQD"]LRTRAN):"Accession Date: ",1:"Accession Year: ")
- S %DT("B")=$$FMTE^XLFDT($$CADT^LA7UTIL(LRAAD),"1") ; Calculate default date based on accession transform.
- D DATE^LRWU S LRADDF=+Y I LRADDF<1 G CLEAN
- K DIC S LREND=0,LRACC="",LRSS="MI",DIC=62.4,DIC("S")="I +Y<1000",DIC(0)="AQEZ",DIC("A")="Select Auto Instrument: " D ^DIC G:Y<1 CLEAN S LRLL=$P(Y(0),U,4),LRINST=+Y I '$L(LRLL) W $C(7),!!!,?10,"No Load List For "_$P(Y,U,2),! G CLEAN
- I '$O(^LAH(LRLL,1,"C",0)) W !!,$C(7),$P(Y(0),U)," Has no data TRY LATER " D CLEAN Q
- S LRVT="VS" I $L($P(Y(0),U,15)) S LRVT=$P(Y(0),U,15)
- S LRFMT=$P(^LAB(69.9,1,0),U,11),LRFMT=$S(LRFMT="":"I",1:LRFMT)
- S LRAA=LRAAD D AUTO^LRCAPV I $G(LREND) K LREND G CLEAN
- F LRAN=0:0 S LRAN=$O(^LAH(LRLL,1,"C",LRAN)) Q:LRAN<1 D LRANX I LREND Q
- I '$D(^LAH(LRLL,1,"C")) W !!?10,"End of Data",!!,$C(7)
- CLEAN ;
- LOCK
- K LRRB,LRSB,LRTREA,VA,XX,LAMIAUTO,LRCAPWA
- D KVAR^VADPT
- K A,DD,GLB,LAYGO,LACAPMS,LRCDEF,LRCDEF0,LRCNT,LRCODE,LRCODEN,LRCSQ,LRCY,LRP,LRPN,LRQC,LRSSC,LRSSCX,LRSTD,LRSTR,LRT,LRTIME,LRTS,NODE,NODE0,ZTSK
- K %,LRTEC,%DT,%X,%Y,A,AGE,B,B1,B2,B3,DA,DFN,DIC,DIE,DOB,DR,I,II,J,K,LR1PASS,LR2ORMOR,LRAA,LRAAD,LRAADF,LRABVNT,LRACC,LRACCN,LRACNT,LRAD,LRADDF,LRAN,LRAO,LRBN,LRBUG,LRTEC
- K IR,IX,IXI,LRABCNT,LRLL,LRCNODE,LRD,LRDR,LRDRDX,LRINST,LRNAME,LRNTN,LRNX,LRODT,LRORGD,LRSUB,LRTEST,N,T1,X9,AA,LRDRD,LRCARD,LRDRNAME,LRALL,LRPHYN,LRCAPMS
- K LRCDT,LRCODE,LRCOMTAB,LRDCOM,LRDFN,LRDPF,LRDTR,LREAL,LREDIT,LREND,LRFLAG,LRFMT,LRI,LRIDT,LRIFN,LRINI,LRLL,LRLLOC,LRLLOC,LRMOVE,LRMICOM,LRMICOMS,LRMIDEF,LRMIOTH,LRODT
- K LRPTP,LRY,LRVT,LRTS,LRSCOM,LRSAME,LRCAPOK,LRFIFO,LRNB,LRTPT,LRBDUP
- K LRORG,LRORGCOM,LRORGN,LRPHY,LRRES,LRSAMP,LRSN,LRSPEC,LRSS,LRTCUP,LRTRAN,LRUNDO,LRWRD,LRWRDVEW,PNM,Q9,SEX,SSN,TAB1,TAB2,TAB3,X,X1,X2,Y
- Q
- LRANX ;
- W !!," Enter number Part of Accession "_LRAN_" // " R X:DTIME S:'$T!($E(X)="^") LREND=1 Q:LREND S:X="" X=LRAN I $L(X),'$D(^LAH(LRLL,1,"C",X)) D LST S LREND=0 G LRANX
- K LRAA S:$L(X) LRAN=X S LRIFN=+$O(^LAH(LRLL,1,"C",LRAN,0)) I 'LRIFN W !?7,"RETRANSMIT THE FILE",! Q
- I '$D(^LAH(LRLL,1,LRIFN,0))#2 W !?7,"NO DATA FOR THIS NUMBER",! K ^LAH(LRLL,1,"C",LRAN,LRIFN) Q
- S LRAA=+$S($P(^LAH(LRLL,1,LRIFN,0),U,3):$P(^(0),U,3),1:LRAAD) I '$D(^LRO(68,LRAA,0)) D ACC Q:Y<1
- DATE ;
- Q:'$D(^LRO(68,LRAA,0))#2 S Y(0)=^(0),LRADDF=$P(Y(0),U,2)
- S LRAD=+$S($P(^LAH(LRLL,1,LRIFN,0),U,4):$P(^(0),U,4),1:LRADDF) I $D(^LRO(68,LRAA,1,LRAD,1,LRAN)) G OK
- S LRTRAN=$P(Y(0),U,3)
- S DT=$$DT^XLFDT
- S %DT="AEP",%DT("A")="Select "_$S(LRTRAN=""!("WMQD"]LRTRAN):"Accession Date: ",1:"Accession Year: ")
- S %DT("B")=$$FMTE^XLFDT($$CADT^LA7UTIL(LRAA),"1") ; Calculate default date based on accession transform.
- D DATE^LRWU
- I '$D(^LRO(68,LRAA,1,Y)) W !!,$C(7)," THERE ARE NO ACCESSIONS FOR THIS DATE " S LRAN=0 Q
- S LRAD=Y
- OK I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W !?7,"Not accessioned -- Would you like a list " S %=2 D YN^DICN G:%=1 SHOW Q
- S LRTCUP=$P(^LAH(LRLL,1,LRIFN,0),U)_";"_$P(^(0),U,2) D ^LAMIAUT1 LOCK ;Lock is set in BB+4^LAMIAUT1
- Q
- LST ;
- W !!,$S(+X>0:" ( "_X_" ) DOES NOT EXIST ",1:"")," WOULD YOU LIKE A LIST " S %=1,LREND=0 D YN^DICN S:%<0 LREND=1 Q:%'=1
- SHOW ;
- S LREND=0 F A=0:0 S A=$O(^LAH(LRLL,1,"C",A)) Q:LREND!(A<1) D:$Y>(IOSL-4) WAIT Q:$D(X)&($E(X)="^") W !?10,A," " I '$D(^LRO(68,LRAAD,1,LRADDF,1,A)) W " NOT ACCESSIONED "
- Q
- WAIT R !!," PRESS RETURN FOR MORE ",X:DTIME S:'$T LREND=1 Q:LREND W @IOF Q
- ACC ;
- K DIC,Y S DIC("B")=$S($D(LRAADF):LRAADF,1:""),DIC=68,DIC(0)="AQEZM",DIC("S")="I $P(^(0),U,2)=""MI""" D ^DIC Q:Y<1 S LRAA=+Y,LRAADF=$P(Y,U,2)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLAMIAUT0 4341 printed Feb 18, 2025@23:09:27 Page 2
- LAMIAUT0 ;SLC/FHS - MICRO AUTO INSTRUMENT PROGRAM VITEK ;7/20/90 09:31 ;
- +1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**42,91**;Sep 27, 1994;Build 4
- EN ;
- +1 DO CLEAN
- DO ^LRPARAM
- SET LRMIDEF=$PIECE(^LAB(69.9,1,1),U,10)
- SET LRMIOTH=$PIECE(^(1),U,11)
- SET LRINI=$PIECE(^VA(200,DUZ,0),U,2)
- SET LRMICOM=$SELECT($DATA(^DD(63.31,.01,0)):$PIECE(^(0),U,5,99),1:"S Q9=""1,68,KM"" D COM^LRNUM")
- SET LRMICOMS=$PIECE($PIECE(LRMICOM,",",3),"""",1)
- +2 SET LRTEC=LRINI
- KILL DIC
- SET DIC=68
- SET DIC(0)="ZMAQE"
- SET DIC("S")="I $P(^(0),U,2)=""MI"""
- DO ^DIC
- if Y<1
- GOTO CLEAN
- SET (LRCAPMS,LRAAD,LRCAPWA)=+Y
- SET LAMIAUTO=1
- ACCESS IF $PIECE(Y(0),U,14)
- IF '$DATA(^XUSEC($PIECE(^DIC(19.1,$PIECE(Y(0),U,14),0),U),DUZ))
- WRITE !!?10,"ACCESS IS DENIED ",$CHAR(7)
- GOTO CLEAN
- +1 SET TAB1="?20"
- SET TAB2="?30"
- SET TAB3="?35"
- SET LREND=0
- SET LRFIFO=0
- +2 SET LRTRAN=$PIECE(^LRO(68,LRAAD,0),U,3)
- +3 SET DT=$$DT^XLFDT
- +4 SET %DT="AEP"
- SET %DT("A")="Select "_$SELECT(LRTRAN=""!("WMQD"]LRTRAN):"Accession Date: ",1:"Accession Year: ")
- +5 ; Calculate default date based on accession transform.
- SET %DT("B")=$$FMTE^XLFDT($$CADT^LA7UTIL(LRAAD),"1")
- +6 DO DATE^LRWU
- SET LRADDF=+Y
- IF LRADDF<1
- GOTO CLEAN
- +7 KILL DIC
- SET LREND=0
- SET LRACC=""
- SET LRSS="MI"
- SET DIC=62.4
- SET DIC("S")="I +Y<1000"
- SET DIC(0)="AQEZ"
- SET DIC("A")="Select Auto Instrument: "
- DO ^DIC
- if Y<1
- GOTO CLEAN
- SET LRLL=$PIECE(Y(0),U,4)
- SET LRINST=+Y
- IF '$LENGTH(LRLL)
- WRITE $CHAR(7),!!!,?10,"No Load List For "_$PIECE(Y,U,2),!
- GOTO CLEAN
- +8 IF '$ORDER(^LAH(LRLL,1,"C",0))
- WRITE !!,$CHAR(7),$PIECE(Y(0),U)," Has no data TRY LATER "
- DO CLEAN
- QUIT
- +9 SET LRVT="VS"
- IF $LENGTH($PIECE(Y(0),U,15))
- SET LRVT=$PIECE(Y(0),U,15)
- +10 SET LRFMT=$PIECE(^LAB(69.9,1,0),U,11)
- SET LRFMT=$SELECT(LRFMT="":"I",1:LRFMT)
- +11 SET LRAA=LRAAD
- DO AUTO^LRCAPV
- IF $GET(LREND)
- KILL LREND
- GOTO CLEAN
- +12 FOR LRAN=0:0
- SET LRAN=$ORDER(^LAH(LRLL,1,"C",LRAN))
- if LRAN<1
- QUIT
- DO LRANX
- IF LREND
- QUIT
- +13 IF '$DATA(^LAH(LRLL,1,"C"))
- WRITE !!?10,"End of Data",!!,$CHAR(7)
- CLEAN ;
- +1 LOCK
- +2 KILL LRRB,LRSB,LRTREA,VA,XX,LAMIAUTO,LRCAPWA
- +3 DO KVAR^VADPT
- +4 KILL A,DD,GLB,LAYGO,LACAPMS,LRCDEF,LRCDEF0,LRCNT,LRCODE,LRCODEN,LRCSQ,LRCY,LRP,LRPN,LRQC,LRSSC,LRSSCX,LRSTD,LRSTR,LRT,LRTIME,LRTS,NODE,NODE0,ZTSK
- +5 KILL %,LRTEC,%DT,%X,%Y,A,AGE,B,B1,B2,B3,DA,DFN,DIC,DIE,DOB,DR,I,II,J,K,LR1PASS,LR2ORMOR,LRAA,LRAAD,LRAADF,LRABVNT,LRACC,LRACCN,LRACNT,LRAD,LRADDF,LRAN,LRAO,LRBN,LRBUG,LRTEC
- +6 KILL IR,IX,IXI,LRABCNT,LRLL,LRCNODE,LRD,LRDR,LRDRDX,LRINST,LRNAME,LRNTN,LRNX,LRODT,LRORGD,LRSUB,LRTEST,N,T1,X9,AA,LRDRD,LRCARD,LRDRNAME,LRALL,LRPHYN,LRCAPMS
- +7 KILL LRCDT,LRCODE,LRCOMTAB,LRDCOM,LRDFN,LRDPF,LRDTR,LREAL,LREDIT,LREND,LRFLAG,LRFMT,LRI,LRIDT,LRIFN,LRINI,LRLL,LRLLOC,LRLLOC,LRMOVE,LRMICOM,LRMICOMS,LRMIDEF,LRMIOTH,LRODT
- +8 KILL LRPTP,LRY,LRVT,LRTS,LRSCOM,LRSAME,LRCAPOK,LRFIFO,LRNB,LRTPT,LRBDUP
- +9 KILL LRORG,LRORGCOM,LRORGN,LRPHY,LRRES,LRSAMP,LRSN,LRSPEC,LRSS,LRTCUP,LRTRAN,LRUNDO,LRWRD,LRWRDVEW,PNM,Q9,SEX,SSN,TAB1,TAB2,TAB3,X,X1,X2,Y
- +10 QUIT
- LRANX ;
- +1 WRITE !!," Enter number Part of Accession "_LRAN_" // "
- READ X:DTIME
- if '$TEST!($EXTRACT(X)="^")
- SET LREND=1
- if LREND
- QUIT
- if X=""
- SET X=LRAN
- IF $LENGTH(X)
- IF '$DATA(^LAH(LRLL,1,"C",X))
- DO LST
- SET LREND=0
- GOTO LRANX
- +2 KILL LRAA
- if $LENGTH(X)
- SET LRAN=X
- SET LRIFN=+$ORDER(^LAH(LRLL,1,"C",LRAN,0))
- IF 'LRIFN
- WRITE !?7,"RETRANSMIT THE FILE",!
- QUIT
- +3 IF '$DATA(^LAH(LRLL,1,LRIFN,0))#2
- WRITE !?7,"NO DATA FOR THIS NUMBER",!
- KILL ^LAH(LRLL,1,"C",LRAN,LRIFN)
- QUIT
- +4 SET LRAA=+$SELECT($PIECE(^LAH(LRLL,1,LRIFN,0),U,3):$PIECE(^(0),U,3),1:LRAAD)
- IF '$DATA(^LRO(68,LRAA,0))
- DO ACC
- if Y<1
- QUIT
- DATE ;
- +1 if '$DATA(^LRO(68,LRAA,0))#2
- QUIT
- SET Y(0)=^(0)
- SET LRADDF=$PIECE(Y(0),U,2)
- +2 SET LRAD=+$SELECT($PIECE(^LAH(LRLL,1,LRIFN,0),U,4):$PIECE(^(0),U,4),1:LRADDF)
- IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN))
- GOTO OK
- +3 SET LRTRAN=$PIECE(Y(0),U,3)
- +4 SET DT=$$DT^XLFDT
- +5 SET %DT="AEP"
- SET %DT("A")="Select "_$SELECT(LRTRAN=""!("WMQD"]LRTRAN):"Accession Date: ",1:"Accession Year: ")
- +6 ; Calculate default date based on accession transform.
- SET %DT("B")=$$FMTE^XLFDT($$CADT^LA7UTIL(LRAA),"1")
- +7 DO DATE^LRWU
- +8 IF '$DATA(^LRO(68,LRAA,1,Y))
- WRITE !!,$CHAR(7)," THERE ARE NO ACCESSIONS FOR THIS DATE "
- SET LRAN=0
- QUIT
- +9 SET LRAD=Y
- OK IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
- WRITE !?7,"Not accessioned -- Would you like a list "
- SET %=2
- DO YN^DICN
- if %=1
- GOTO SHOW
- QUIT
- +1 ;Lock is set in BB+4^LAMIAUT1
- SET LRTCUP=$PIECE(^LAH(LRLL,1,LRIFN,0),U)_";"_$PIECE(^(0),U,2)
- DO ^LAMIAUT1
- LOCK
- +2 QUIT
- LST ;
- +1 WRITE !!,$SELECT(+X>0:" ( "_X_" ) DOES NOT EXIST ",1:"")," WOULD YOU LIKE A LIST "
- SET %=1
- SET LREND=0
- DO YN^DICN
- if %<0
- SET LREND=1
- if %'=1
- QUIT
- SHOW ;
- +1 SET LREND=0
- FOR A=0:0
- SET A=$ORDER(^LAH(LRLL,1,"C",A))
- if LREND!(A<1)
- QUIT
- if $Y>(IOSL-4)
- DO WAIT
- if $DATA(X)&($EXTRACT(X)="^")
- QUIT
- WRITE !?10,A," "
- IF '$DATA(^LRO(68,LRAAD,1,LRADDF,1,A))
- WRITE " NOT ACCESSIONED "
- +2 QUIT
- WAIT READ !!," PRESS RETURN FOR MORE ",X:DTIME
- if '$TEST
- SET LREND=1
- if LREND
- QUIT
- WRITE @IOF
- QUIT
- ACC ;
- +1 KILL DIC,Y
- SET DIC("B")=$SELECT($DATA(LRAADF):LRAADF,1:"")
- SET DIC=68
- SET DIC(0)="AQEZM"
- SET DIC("S")="I $P(^(0),U,2)=""MI"""
- DO ^DIC
- if Y<1
- QUIT
- SET LRAA=+Y
- SET LRAADF=$PIECE(Y,U,2)
- +2 QUIT
