LAMIAUT0 ; IHS/DIR/FJE - MICRO AUTO INSTRUMENT PROGRAM VITEK ; 18-NOV-2013 10:40 ; MKK
;;5.2;LR;**1008,42,1018,1033**;Nov 1, 1997
;;
EN ;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
W !!
D ^XBFMK
S DIR(0)="YO"
S DIR("A")="VITEK Verification (Y/N)"
D ^DIR
I +$G(DIRUT) D Q
. W !!,?4,"Invalid/No/Quit Entry. Routine Ends."
. D PRESSKEY^BLRGMENU(9)
;
I +$G(Y)<1 D EP^BLRMIAUT Q
; ----- END IHS/MSC/MKK - LR*5.2*1033
;
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 %DT="AE",%DT("A")=" Accession Date : ",%DT("B")=$E(DT,2,3) 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<99",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^BLRDPT
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
D @$S($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")
;----- END IHS MODIFICATIONS
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,HRCN,TAB1,TAB2,TAB3,X,X1,X2,Y ;IHS/ANMC/CLS 11/1/95
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
; begin Y2K fix block
;S LRTRAN=$P(Y(0),U,3),%DT="AE",%DT("A")=$S(LRTRAN=""!("WMQD"]LRTRAN):" Accession Date : ",1:" Accession Year "),%DT("B")=$S("Y"[LRTRAN:$E(DT,2,3),"M"[LRTRAN:+$E(DT,4,5)_" 19"_$E(DT,2,3),1:LRDT0) D DATE^LRWU
S LRTRAN=$P(Y(0),U,3),%DT="AE",%DT("A")=$S(LRTRAN=""!("WMQD"]LRTRAN):" Accession Date : ",1:" Accession Year "),%DT("B")=$S("Y"[LRTRAN:$E(DT,2,3),"M"[LRTRAN:+$E(DT,4,5)_($E(DT,1,3)+1700),1:LRDT0) D DATE^LRWU ;Y2000
; end Y2K fix block
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
LAMIAUT0 ; IHS/DIR/FJE - MICRO AUTO INSTRUMENT PROGRAM VITEK ; 18-NOV-2013 10:40 ; MKK
+1 ;;5.2;LR;**1008,42,1018,1033**;Nov 1, 1997
+2 ;;
EN ;
+1 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
+2 WRITE !!
+3 DO ^XBFMK
+4 SET DIR(0)="YO"
+5 SET DIR("A")="VITEK Verification (Y/N)"
+6 DO ^DIR
+7 IF +$GET(DIRUT)
Begin DoDot:1
+8 WRITE !!,?4,"Invalid/No/Quit Entry. Routine Ends."
+9 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+10 ;
+11 IF +$GET(Y)<1
DO EP^BLRMIAUT
QUIT
+12 ; ----- END IHS/MSC/MKK - LR*5.2*1033
+13 ;
+14 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)
+15 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 %DT="AE"
SET %DT("A")=" Accession Date : "
SET %DT("B")=$EXTRACT(DT,2,3)
DO DATE^LRWU
SET LRADDF=+Y
IF LRADDF<1
GOTO CLEAN
+3 KILL DIC
SET LREND=0
SET LRACC=""
SET LRSS="MI"
SET DIC=62.4
SET DIC("S")="I +Y<99"
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
+4 IF '$ORDER(^LAH(LRLL,1,"C",0))
WRITE !!,$CHAR(7),$PIECE(Y(0),U)," Has no data TRY LATER "
DO CLEAN
QUIT
+5 SET LRVT="VS"
IF $LENGTH($PIECE(Y(0),U,15))
SET LRVT=$PIECE(Y(0),U,15)
+6 SET LRFMT=$PIECE(^LAB(69.9,1,0),U,11)
SET LRFMT=$SELECT(LRFMT="":"I",1:LRFMT)
+7 SET LRAA=LRAAD
DO AUTO^LRCAPV
IF $GET(LREND)
KILL LREND
GOTO CLEAN
+8 FOR LRAN=0:0
SET LRAN=$ORDER(^LAH(LRLL,1,"C",LRAN))
IF LRAN<1
QUIT
DO LRANX
IF LREND
QUIT
+9 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 ;D KVAR^BLRDPT
+4 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+5 DO @$SELECT($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")
+6 ;----- END IHS MODIFICATIONS
+7 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
+8 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
+9 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
+10 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
+11 KILL LRPTP,LRY,LRVT,LRTS,LRSCOM,LRSAME,LRCAPOK,LRFIFO,LRNB,LRTPT,LRBDUP
+12 ;IHS/ANMC/CLS 11/1/95
KILL LRORG,LRORGCOM,LRORGN,LRPHY,LRRES,LRSAMP,LRSN,LRSPEC,LRSS,LRTCUP,LRTRAN,LRUNDO,LRWRD,LRWRDVEW,PNM,Q9,SEX,SSN,HRCN,TAB1,TAB2,TAB3,X,X1,X2,Y
+13 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 ; begin Y2K fix block
+4 ;S LRTRAN=$P(Y(0),U,3),%DT="AE",%DT("A")=$S(LRTRAN=""!("WMQD"]LRTRAN):" Accession Date : ",1:" Accession Year "),%DT("B")=$S("Y"[LRTRAN:$E(DT,2,3),"M"[LRTRAN:+$E(DT,4,5)_" 19"_$E(DT,2,3),1:LRDT0) D DATE^LRWU
+5 ;Y2000
SET LRTRAN=$PIECE(Y(0),U,3)
SET %DT="AE"
SET %DT("A")=$SELECT(LRTRAN=""!("WMQD"]LRTRAN):" Accession Date : ",1:" Accession Year ")
SET %DT("B")=$SELECT("Y"[LRTRAN:$EXTRACT(DT,2,3),"M"[LRTRAN:+$EXTRACT(DT,4,5)_($EXTRACT(DT,1,3)+1700),1:LRDT0)
DO DATE^LRWU
+6 ; end Y2K fix block
+7 IF '$DATA(^LRO(68,LRAA,1,Y))
WRITE !!,$CHAR(7)," THERE ARE NO ACCESSIONS FOR THIS DATE "
SET LRAN=0
QUIT
+8 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
