Routine: LAMIAUT0

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

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

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 "

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)

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

LAMIAUT0.m