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
