BLRMIAUT.m

BLRMIAUT ; IHS/MSC/MKK - INCOMING HL7 MICRO AUTO INSTRUMENT PROGRAM  ; 22-Oct-2013 09:22 ; MKK

 ;;5.2;LA;**1033**;NOV 01, 1997

 ;

 ; Cloned from LAMIAUT0

 ;

EP ; EP

 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,LAMIAUTO=1

 S ^TMP("BLRMIAUT",$J,"HL7")=""

 ;

ACCESS ; EP

 S TAB1="?20",TAB2="?30",TAB3="?35",LREND=0,LRFIFO=0

 ;

 NEW HEADER

 D ACCFILEL^BLRLAHGU    ; Get Date Range, AUTO INSTRUMENT, and LOAD/WORK LIST

 G:LRLL<1 CLEAN

 ;

 S LRFMT=$P(^LAB(69.9,1,0),U,11),LRFMT=$S(LRFMT="":"I",1:LRFMT)

 S LRVT="VS"

 S LRSS="MI"

 ;

 S (NOGO,LREND)=0

 F  Q:NOGO!(+$G(LREND))  D

 . D GETUID^BLRLAHGU(LRSDT,LRLDT)

 . Q:+$G(LREND)

 . ;

 . S (LRCAPMS,LRAAD,LRCAPWA)=LRAA

 . D AUTO^LRCAPV  Q:$G(LREND)

 . S LRADDF=LRAD

 . D LRANX

 . D:+$G(LREND)<1 ONGO^BLRLAHGU(.NOGO),PUTCOMPD

 ;

CLEAN ;

 LOCK

 K LRRB,LRSB,LRTREA,VA,XX,LAMIAUTO,LRCAPWA

 D @$S($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")

 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

 K ^TMP("BLRMIAUT",$J)

 Q

LRANX ;

 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

 I '$D(^LRO(68,LRAA,1,Y)) W !!,$C(7)," THERE ARE NO ACCESSIONS FOR THIS DATE " S LRAN=0 Q

 ;

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

 ;

 D LABIHSMS^BLRRLMUM(LRAA,LRAD,LRAN)

 ;

 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 ; EP

 D ^XBFMK

 S DIR(0)="FO"

 S DIR("A")=$J("",5)_"PRESS RETURN FOR MORE "

 D ^DIR

 I +$G(DIRUT) S LREND=1 Q

 W @IOF

 Q

 ;

ACC ; EP

 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

 ;

 ; Put Complete Date on Accession

PUTCOMPD ; EP

 NEW ERRS,FDA,LRDFN,LRIDT,ORG,RELDATE,ORGDATE

 S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),LRIDT=$P($G(^(3)),"^",5)

 S (ORG,RELDATE)=0

 F  S ORG=$O(^LR(LRDFN,"MI",LRIDT,3,ORG))  Q:ORG<1  D

 . S ORGDATE=+$P($G(^LR(LRDFN,"MI",LRIDT,3,ORG,"IHSOBX")),"^",5)

 . S:ORGDATE>RELDATE RELDATE=ORGDATE

 ;

 Q:RELDATE<1

 ;

 S ^TMP("BLRMIAUT",$J,"PUTCOMPD",$H,LRAA,LRAD,LRAN)=RELDATE

 ;

 S FDA(68.02,LRAN_","_LRAD_","_LRAA_",",13)=RELDATE

 D UPDATE^DIE("S","FDA","ERRS")

 Q

BLRMIAUT  ; IHS/MSC/MKK - INCOMING HL7 MICRO AUTO INSTRUMENT PROGRAM  ; 22-Oct-2013 09:22 ; MKK

 +1       ;;5.2;LA;**1033**;NOV 01, 1997

 +2       ;

 +3       ; Cloned from LAMIAUT0

 +4       ;

EP        ; EP

 +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       ;

 +3        SET LRTEC=LRINI

           SET LAMIAUTO=1

 +4        SET ^TMP("BLRMIAUT",$JOB,"HL7")=""

 +5       ;

ACCESS    ; EP

 +1        SET TAB1="?20"

           SET TAB2="?30"

           SET TAB3="?35"

           SET LREND=0

           SET LRFIFO=0

 +2       ;

 +3        NEW HEADER

 +4       ; Get Date Range, AUTO INSTRUMENT, and LOAD/WORK LIST

           DO ACCFILEL^BLRLAHGU

 +5        IF LRLL<1

               GOTO CLEAN

 +6       ;

 +7        SET LRFMT=$PIECE(^LAB(69.9,1,0),U,11)

           SET LRFMT=$SELECT(LRFMT="":"I",1:LRFMT)

 +8        SET LRVT="VS"

 +9        SET LRSS="MI"

 +10      ;

 +11       SET (NOGO,LREND)=0

 +12       FOR 

               IF NOGO!(+$GET(LREND))

                   QUIT 

               Begin DoDot:1

 +13               DO GETUID^BLRLAHGU(LRSDT,LRLDT)

 +14               IF +$GET(LREND)

                       QUIT 

 +15      ;

 +16               SET (LRCAPMS,LRAAD,LRCAPWA)=LRAA

 +17               DO AUTO^LRCAPV

                   IF $GET(LREND)

                       QUIT 

 +18               SET LRADDF=LRAD

 +19               DO LRANX

 +20               IF +$GET(LREND)<1

                       DO ONGO^BLRLAHGU(.NOGO)

                       DO PUTCOMPD

               End DoDot:1

 +21      ;

CLEAN     ;

 +1        LOCK 

 +2        KILL LRRB,LRSB,LRTREA,VA,XX,LAMIAUTO,LRCAPWA

 +3        DO @$SELECT($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")

 +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,HRCN,TAB1,TAB2,TAB3,X,X1,X2,Y

 +10       KILL ^TMP("BLRMIAUT",$JOB)

 +11       QUIT 

LRANX     ;

 +1        IF '$DATA(^LAH(LRLL,1,LRIFN,0))#2

               WRITE !?7,"NO DATA FOR THIS NUMBER",!

               KILL ^LAH(LRLL,1,"C",LRAN,LRIFN)

               QUIT 

 +2        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 

 +3       ;

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        IF '$DATA(^LRO(68,LRAA,1,Y))

               WRITE !!,$CHAR(7)," THERE ARE NO ACCESSIONS FOR THIS DATE "

               SET LRAN=0

               QUIT 

 +4       ;

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       ;

 +3        DO LABIHSMS^BLRRLMUM(LRAA,LRAD,LRAN)

 +4       ;

 +5        QUIT 

 +6       ;

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 

 +2       ;

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 

 +3       ;

WAIT      ; EP

 +1        DO ^XBFMK

 +2        SET DIR(0)="FO"

 +3        SET DIR("A")=$JUSTIFY("",5)_"PRESS RETURN FOR MORE "

 +4        DO ^DIR

 +5        IF +$GET(DIRUT)

               SET LREND=1

               QUIT 

 +6        WRITE @IOF

 +7        QUIT 

 +8       ;

ACC       ; EP

 +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 

 +3       ;

 +4       ; Put Complete Date on Accession

PUTCOMPD  ; EP

 +1        NEW ERRS,FDA,LRDFN,LRIDT,ORG,RELDATE,ORGDATE

 +2        SET LRDFN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))

           SET LRIDT=$PIECE($GET(^(3)),"^",5)

 +3        SET (ORG,RELDATE)=0

 +4        FOR 

               SET ORG=$ORDER(^LR(LRDFN,"MI",LRIDT,3,ORG))

               IF ORG<1

                   QUIT 

               Begin DoDot:1

 +5                SET ORGDATE=+$PIECE($GET(^LR(LRDFN,"MI",LRIDT,3,ORG,"IHSOBX")),"^",5)

 +6                IF ORGDATE>RELDATE

                       SET RELDATE=ORGDATE

               End DoDot:1

 +7       ;

 +8        IF RELDATE<1

               QUIT 

 +9       ;

 +10       SET ^TMP("BLRMIAUT",$JOB,"PUTCOMPD",$HOROLOG,LRAA,LRAD,LRAN)=RELDATE

 +11      ;

 +12       SET FDA(68.02,LRAN_","_LRAD_","_LRAA_",",13)=RELDATE

 +13       DO UPDATE^DIE("S","FDA","ERRS")

 +14       QUIT