- LRMIBL ;VA/AVAMC/REG - BATCH ORDERING/ACCESSION LOGING ;JUL 06, 2010 3:14 PM;
- ;;5.2;LAB SERVICE;**1003,1004,1018,1027**;NOV 01, 1997
- ;;5.2;LAB SERVICE;**121,153**;Sep 27, 1994
- ;from option LRMIBL
- BEGIN S LRBLEND=0 D BLOG
- END K %,A,DFN,DIC,DQ,DX,H8,J,K,L,LRAA,LRACC,LRAC,LRAN,LRBLEND,LRCCOM,LRCDT,LRCOM,LRCSN,LRDFN,LRDPF,LREAL,LREND,LREXP,LRIDT,LRIN,LRIX,LRLBLBP,LRLLOC,LRM,LRNT,LRORD,LROU,LROUTINE,LRPR,LRPRAC,LRRB,LRSN,LRSSP,LRSSX,LRST,LRSUM,LRSXN,LRTS,LRTSTNM
- ;K LRUNQ,LRWLC,LRWP,LRYR,PNM,S,SSN,X,X1,Y,Z,LRFIRST,DIC,LRSAME,LRSAMP,LRSPEC,LRORDR,LRECT,LRODT,LRURG,LRFLOG,LRCS,LROT,LRTN,LRTOP,LRTP,LRTSTN,LRTY,LRUR,LRUSNM,LRWL0,LRWPC,LRXL,S5
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- K LRUNQ,LRWLC,LRWP,LRYR,PNM,S,SSN,HRCN,X,X1,Y,Z,LRFIRST,DIC,LRSAME,LRSAMP,LRSPEC,LRORDR,LRECT,LRODT,LRURG,LRFLOG,LRCS,LROT,LRTN,LRTOP,LRTP,LRTSTN,LRTY,LRUR,LRUSNM,LRWL0,LRWPC,LRXL,S5 ;IHS/ANMC/CLS 08/18/96
- ;----- END IHS MODIFICATIONS
- K LRTCOM,%H,%X,%Y,DIWL,DIWR,DO,DPF,I1,I2,I5,LABEL,LRADDTST,LRBED,LRCE,LRCSS,LRDAT,LRDTO,LRECOM,LRINFW,LRLWC,LRMAX,LRNCWL,LRNIDT,LROCN,LROID,LROLRDFN,LRORDER,LRORDTIM,LROSN,LRPHSET,LRPREF,LRSLIP,LRSNO,LRSPCDSC,LRSVSN,LRTEST,LRTJ
- K ^TMP("LRSTIK",$J)
- Q
- BLOG K ^TMP("LRSTIK",$J),DIC,LRURG,LRSAME,LRCOM,LRTCOM S LRORDR="" D DT^LRX W !!," BATCH LOG-IN",!
- S LRODT=DT,U="^",LRECT=0,LROUTINE=$P(^LAB(69.9,1,3),U,2)
- F W !!,"WANT TO ENTER COLLECTION TIMES" S %=1 D YN^DICN S LRECT=$S(%=2:0,1:1) S:%<0 LRBLEND=1 Q:% W !,"Yes or No"
- Q:LRBLEND
- G1 S LRWP=0 F D GET Q:LRBLEND
- Q
- GET S DIC="^LAB(60,",DIC(0)="AEMOQ",DIC("S")="I ""AUSP""'[$P(^(0),U,4)!($P(^(0),U,4)="""")"_$S('$D(^XUSEC("LRLAB",DUZ)):"&(""NO""'[$P(^(0),U,3))",1:"")
- D ^DIC K DIC("S") S:Y<1 LRBLEND=1 Q:LRBLEND S LRWP=LRWP+1,^TMP("LRSTIK",$J,LRWP)=$P(Y,U,1,2),^TMP("LRSTIK",$J,"B",LRWP)=LRWP
- S LRTSTS=+^TMP("LRSTIK",$J,LRWP) D GS^LRORD3 S:+LRSAMP=-1&(LRSPEC=-1) LRBLEND=1 Q:LRBLEND S ^TMP("LRSTIK",$J,LRWP)=^TMP("LRSTIK",$J,LRWP)_U_LRSAMP_U_U_LRSPEC
- G5 S:'$D(^LRO(69,LRODT,0)) ^(0)=$P(^LRO(69,0),U,1,2)_U_LRODT_U_(1+$P(^(0),U,4)),^LRO(69,LRODT,0)=LRODT,^LRO(69,"B",LRODT,LRODT)=""
- S LRSSX=LRWP,LRST=0,LRSAMP=$P(^TMP("LRSTIK",$J,LRSSX),U,3),LRSPEC=$P(^TMP("LRSTIK",$J,LRSSX),U,5),LRTSTS=+^TMP("LRSTIK",$J,LRSSX) D Q20,URGG
- ;S LRM=0,PNM="",SSN="" D ENSTIK^LROW3 Q:'$D(LROT) S:'$D(%) LRWP=0 Q:'$D(%) S:%["N" LRBLEND=1 Q:LRBLEND S %X="LROT(",%Y="LROU(" D %XY^%RCR
- ;----- BEGIN IHS MODIFICATION LR*5.2*1018
- S LRM=0,PNM="",SSN="",HRCN="" D ENSTIK^LROW3 Q:'$D(LROT) S:'$D(%) LRWP=0 Q:'$D(%) S:%["N" LRBLEND=1 Q:LRBLEND S %X="LROT(",%Y="LROU(" D %XY^%RCR ;IHS/ANMC/CLS 08/18/96
- ;----- END IHS MODIFICATIONS
- F D L2 Q:LRBLEND
- Q
- L2 ; K LRSAME,LRGCOM,DFN,DIC S PNM="",DIC(0)="EMQ"_$S($P(LRPARAM,U,6)&$D(^XUSEC("LRLAB",DUZ)):"L",1:"") W ! D ^LRDPA I (LRDFN=-1)!$D(DUOUT)!$D(DTOUT) S LRBLEND=1 Q
- ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
- K LRSAME,LRGCOM,DFN,DIC
- S PNM=""
- S DIC(0)="EMQ"_$S($P($G(LRPARAM),U,6)&$D(^XUSEC("LRLAB",DUZ)):"L",1:"")
- W !
- D ^LRDPA
- I (LRDFN=-1)!$D(DUOUT)!$D(DTOUT) S LRBLEND=1 Q
- ; ----- END IHS/OIT/MKK - LR*5.2*1027
- S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
- D LOC^LRWU D:LREND DROP Q:LREND D PRAC^LRWU1 I LREND D DROP Q
- D ORDER^LROW2
- S II=0
- F S II=$O(LROT(II)) Q:II<1 D
- . S J=0
- . F S J=$O(LROT(II,J)) Q:J<1 D
- . . S K=0
- . . F S K=$O(LROT(II,J,K)) Q:K<1 S ^LRO(69,LRODT,1,"AB",$S($D(^TMP("LRSTIK",$J,K)):+^TMP("LRSTIK",$J,K),1:+LROT(II,J,K)),J,LRDFN)=""
- I LRECT D TIME^LRWU1 I LRCDT<1 D DROP Q
- S LRORDTIM=$P($H,",",2)\3600*100+($P($H,",",2)\60#60)/10000,LRNT=LRORDTIM+DT,LRORDTIM=$P(LRORDTIM,".",2) S:'LRECT LRCDT=LRNT_"^1"
- S LRIDT=9999999-LRCDT
- S %X="LROU(",%Y="LROT(" D %XY^%RCR D ^LRORDST
- Q
- Q20 D:LRSAMP="" GSS^LRORD3 I (LRSAMP<1)!(LRSPEC<1) W !,"Sample and source incompletely defined, test skipped." K LRSAME Q
- S LROT(LRSAMP,LRSPEC,LRSSX)=LRTSTS D:LRST URGG
- S LREXP=$S($D(^LAB(60,LRTSTS,3,+LRSAMP,0)):$P(^(0),U,6),$P(^LAB(60,LRTSTS,0),U,19):$P(^(0),U,19),1:0) S:LREXP LROT(LRSAMP,LRSPEC,LRSSX,2)=LREXP
- Q
- URGG W !,"For ",$P(^TMP("LRSTIK",$J,LRWP),U,2) D URG^LRORD2
- Q
- DROP W !!,"ORDER CANCELED",$C(7),!!
- Q
- ;LRORDR =TYPE OF ORDER, LRECT =ASK COLECTION TIME
- ;LRFLOG =ACCESSION TEST GROUP, IF DEFINED ON ENTRY, PRESELECTS GROUP
- LRMIBL ;VA/AVAMC/REG - BATCH ORDERING/ACCESSION LOGING ;JUL 06, 2010 3:14 PM;
- +1 ;;5.2;LAB SERVICE;**1003,1004,1018,1027**;NOV 01, 1997
- +2 ;;5.2;LAB SERVICE;**121,153**;Sep 27, 1994
- +3 ;from option LRMIBL
- BEGIN SET LRBLEND=0
- DO BLOG
- END KILL %,A,DFN,DIC,DQ,DX,H8,J,K,L,LRAA,LRACC,LRAC,LRAN,LRBLEND,LRCCOM,LRCDT,LRCOM,LRCSN,LRDFN,LRDPF,LREAL,LREND,LREXP,LRIDT,LRIN,LRIX,LRLBLBP,LRLLOC,LRM,LRNT,LRORD,LROU,LROUTINE,LRPR,LRPRAC,LRRB,LRSN,LRSSP,LRSSX,LRST,LRSUM,LRSXN,LRTS,LRTSTNM
- +1 ;K LRUNQ,LRWLC,LRWP,LRYR,PNM,S,SSN,X,X1,Y,Z,LRFIRST,DIC,LRSAME,LRSAMP,LRSPEC,LRORDR,LRECT,LRODT,LRURG,LRFLOG,LRCS,LROT,LRTN,LRTOP,LRTP,LRTSTN,LRTY,LRUR,LRUSNM,LRWL0,LRWPC,LRXL,S5
- +2 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +3 ;IHS/ANMC/CLS 08/18/96
- KILL LRUNQ,LRWLC,LRWP,LRYR,PNM,S,SSN,HRCN,X,X1,Y,Z,LRFIRST,DIC,LRSAME,LRSAMP,LRSPEC,LRORDR,LRECT,LRODT,LRURG,LRFLOG,LRCS,LROT,LRTN,LRTOP,LRTP,LRTSTN,LRTY,LRUR,LRUSNM,LRWL0,LRWPC,LRXL,S5
- +4 ;----- END IHS MODIFICATIONS
- +5 KILL LRTCOM,%H,%X,%Y,DIWL,DIWR,DO,DPF,I1,I2,I5,LABEL,LRADDTST,LRBED,LRCE,LRCSS,LRDAT,LRDTO,LRECOM,LRINFW,LRLWC,LRMAX,LRNCWL,LRNIDT,LROCN,LROID,LROLRDFN,LRORDER,LRORDTIM,LROSN,LRPHSET,LRPREF,LRSLIP,LRSNO,LRSPCDSC,LRSVSN,LRTEST,LRTJ
- +6 KILL ^TMP("LRSTIK",$JOB)
- +7 QUIT
- BLOG KILL ^TMP("LRSTIK",$JOB),DIC,LRURG,LRSAME,LRCOM,LRTCOM
- SET LRORDR=""
- DO DT^LRX
- WRITE !!," BATCH LOG-IN",!
- +1 SET LRODT=DT
- SET U="^"
- SET LRECT=0
- SET LROUTINE=$PIECE(^LAB(69.9,1,3),U,2)
- +2 FOR
- WRITE !!,"WANT TO ENTER COLLECTION TIMES"
- SET %=1
- DO YN^DICN
- SET LRECT=$SELECT(%=2:0,1:1)
- IF %<0
- SET LRBLEND=1
- IF %
- QUIT
- WRITE !,"Yes or No"
- +3 IF LRBLEND
- QUIT
- G1 SET LRWP=0
- FOR
- DO GET
- IF LRBLEND
- QUIT
- +1 QUIT
- GET SET DIC="^LAB(60,"
- SET DIC(0)="AEMOQ"
- SET DIC("S")="I ""AUSP""'[$P(^(0),U,4)!($P(^(0),U,4)="""")"_$SELECT('$DATA(^XUSEC("LRLAB",DUZ)):"&(""NO""'[$P(^(0),U,3))",1:"")
- +1 DO ^DIC
- KILL DIC("S")
- IF Y<1
- SET LRBLEND=1
- IF LRBLEND
- QUIT
- SET LRWP=LRWP+1
- SET ^TMP("LRSTIK",$JOB,LRWP)=$PIECE(Y,U,1,2)
- SET ^TMP("LRSTIK",$JOB,"B",LRWP)=LRWP
- +2 SET LRTSTS=+^TMP("LRSTIK",$JOB,LRWP)
- DO GS^LRORD3
- IF +LRSAMP=-1&(LRSPEC=-1)
- SET LRBLEND=1
- IF LRBLEND
- QUIT
- SET ^TMP("LRSTIK",$JOB,LRWP)=^TMP("LRSTIK",$JOB,LRWP)_U_LRSAMP_U_U_LRSPEC
- G5 IF '$DATA(^LRO(69,LRODT,0))
- SET ^(0)=$PIECE(^LRO(69,0),U,1,2)_U_LRODT_U_(1+$PIECE(^(0),U,4))
- SET ^LRO(69,LRODT,0)=LRODT
- SET ^LRO(69,"B",LRODT,LRODT)=""
- +1 SET LRSSX=LRWP
- SET LRST=0
- SET LRSAMP=$PIECE(^TMP("LRSTIK",$JOB,LRSSX),U,3)
- SET LRSPEC=$PIECE(^TMP("LRSTIK",$JOB,LRSSX),U,5)
- SET LRTSTS=+^TMP("LRSTIK",$JOB,LRSSX)
- DO Q20
- DO URGG
- +2 ;S LRM=0,PNM="",SSN="" D ENSTIK^LROW3 Q:'$D(LROT) S:'$D(%) LRWP=0 Q:'$D(%) S:%["N" LRBLEND=1 Q:LRBLEND S %X="LROT(",%Y="LROU(" D %XY^%RCR
- +3 ;----- BEGIN IHS MODIFICATION LR*5.2*1018
- +4 ;IHS/ANMC/CLS 08/18/96
- SET LRM=0
- SET PNM=""
- SET SSN=""
- SET HRCN=""
- DO ENSTIK^LROW3
- IF '$DATA(LROT)
- QUIT
- IF '$DATA(%)
- SET LRWP=0
- IF '$DATA(%)
- QUIT
- IF %["N"
- SET LRBLEND=1
- IF LRBLEND
- QUIT
- SET %X="LROT("
- SET %Y="LROU("
- DO %XY^%RCR
- +5 ;----- END IHS MODIFICATIONS
- +6 FOR
- DO L2
- IF LRBLEND
- QUIT
- +7 QUIT
- L2 ; K LRSAME,LRGCOM,DFN,DIC S PNM="",DIC(0)="EMQ"_$S($P(LRPARAM,U,6)&$D(^XUSEC("LRLAB",DUZ)):"L",1:"") W ! D ^LRDPA I (LRDFN=-1)!$D(DUOUT)!$D(DTOUT) S LRBLEND=1 Q
- +1 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
- +2 KILL LRSAME,LRGCOM,DFN,DIC
- +3 SET PNM=""
- +4 SET DIC(0)="EMQ"_$SELECT($PIECE($GET(LRPARAM),U,6)&$DATA(^XUSEC("LRLAB",DUZ)):"L",1:"")
- +5 WRITE !
- +6 DO ^LRDPA
- +7 IF (LRDFN=-1)!$DATA(DUOUT)!$DATA(DTOUT)
- SET LRBLEND=1
- QUIT
- +8 ; ----- END IHS/OIT/MKK - LR*5.2*1027
- +9 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- +10 DO LOC^LRWU
- IF LREND
- DO DROP
- IF LREND
- QUIT
- DO PRAC^LRWU1
- IF LREND
- DO DROP
- QUIT
- +11 DO ORDER^LROW2
- +12 SET II=0
- +13 FOR
- SET II=$ORDER(LROT(II))
- IF II<1
- QUIT
- Begin DoDot:1
- +14 SET J=0
- +15 FOR
- SET J=$ORDER(LROT(II,J))
- IF J<1
- QUIT
- Begin DoDot:2
- +16 SET K=0
- +17 FOR
- SET K=$ORDER(LROT(II,J,K))
- IF K<1
- QUIT
- SET ^LRO(69,LRODT,1,"AB",$SELECT($DATA(^TMP("LRSTIK",$JOB,K)):+^TMP("LRSTIK",$JOB,K),1:+LROT(II,J,K)),J,LRDFN)=""
- End DoDot:2
- End DoDot:1
- +18 IF LRECT
- DO TIME^LRWU1
- IF LRCDT<1
- DO DROP
- QUIT
- +19 SET LRORDTIM=$PIECE($HOROLOG,",",2)\3600*100+($PIECE($HOROLOG,",",2)\60#60)/10000
- SET LRNT=LRORDTIM+DT
- SET LRORDTIM=$PIECE(LRORDTIM,".",2)
- IF 'LRECT
- SET LRCDT=LRNT_"^1"
- +20 SET LRIDT=9999999-LRCDT
- +21 SET %X="LROU("
- SET %Y="LROT("
- DO %XY^%RCR
- DO ^LRORDST
- +22 QUIT
- Q20 IF LRSAMP=""
- DO GSS^LRORD3
- IF (LRSAMP<1)!(LRSPEC<1)
- WRITE !,"Sample and source incompletely defined, test skipped."
- KILL LRSAME
- QUIT
- +1 SET LROT(LRSAMP,LRSPEC,LRSSX)=LRTSTS
- IF LRST
- DO URGG
- +2 SET LREXP=$SELECT($DATA(^LAB(60,LRTSTS,3,+LRSAMP,0)):$PIECE(^(0),U,6),$PIECE(^LAB(60,LRTSTS,0),U,19):$PIECE(^(0),U,19),1:0)
- IF LREXP
- SET LROT(LRSAMP,LRSPEC,LRSSX,2)=LREXP
- +3 QUIT
- URGG WRITE !,"For ",$PIECE(^TMP("LRSTIK",$JOB,LRWP),U,2)
- DO URG^LRORD2
- +1 QUIT
- DROP WRITE !!,"ORDER CANCELED",$CHAR(7),!!
- +1 QUIT
- +2 ;LRORDR =TYPE OF ORDER, LRECT =ASK COLECTION TIME
- +3 ;LRFLOG =ACCESSION TEST GROUP, IF DEFINED ON ENTRY, PRESELECTS GROUP
