LRFAST ;VA/DALOI/JMC - FAST ENTRY ;May 23, 2006
;;5.2;LAB SERVICE;**1003,1006,1013,1018,1027,1031**;NOV 1, 1997
;
;;VA LR Patche(s): 100,121,201,286,291,328
;
N LRBEQT,LRBEVT,LRBETS,LRBEX,LRBEY,LRBEZ,LRBETYP
K LRLONG,LRNATURE
S LRLONG=""
D ^LRPARAM
SHORT S LRPANEL=0,LROUTINE=$P(^LAB(69.9,1,3),U,2),LRPTP=-1 I '$D(LRLONG) W !,"BYPASSING ORDER ENTRY!!",$C(7)
I $D(^LAB(69.9,1,"RO")),+$H'=^("RO") W $C(7),!,"ROLLOVER ",$S($P(^("RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")," ACCESSIONING SHOULDN'T BE DONE NOW.",$C(7),!," Are you sure you want to continue"
I $T S %=2 D YN^DICN W:%=0 !,"Not sure?" I %'=1 W !,"OK, try later." Q
S X=$$SELPL^LRVERA(DUZ(2))
I X<1 D QUIT Q
I X'=DUZ(2) N LRPL S LRPL=X
;
SH ; W !,"Do you want to enter draw times" S %=2 D YN^DICN S LRADT=(%=1) Q:%=-1
W !,"Do you want to enter draw times" S %=1 D YN^DICN S LRADT=(%=1) Q:%=-1 ;IHS/ANMC/CLS 08/18/96
I %=0 W !,"If you answer 'yes', you will be asked for the approximate time the specimen",!,"was taken from the patient. Otherwise, the current time will be assumed." G SH
AMIS ;
S U="^",(Y,LRNT)=$$NOW^XLFDT,LRODT=DT,LRAD=DT,LRIDT=9999999-Y,LRCDT=Y_"^1",LRSAMP="" K DFN,DIC S DIC(0)="EMQ"_$S($P(LRPARAM,U,6):"L",1:"") D ^LRDPA G:(LRDFN=-1)!$D(DUOUT)!$D(DTOUT) QUIT
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 %H=$H-60 D YMD^LRX S LRTM60=9999999-X
QSN1 D PT^LRX G:$G(LREND) QUIT K DR S LRLLOC=$S($L(LRWRD):LRWRD,$D(^LR(LRDFN,.1)):^(.1),1:"UNKNOWN") D:$L(LRWRD) DPT^LRWU
Q12 I $D(LRLONG) D LOC^LRWU G QUIT:LREND
Q11 D COLTY^LRWU G QUIT:LREND S LRPRAC="" I $D(LRLONG) D PRAC^LRWU1 I LREND W !!,$C(7),"ORDER CANCELED",!! G QUIT
URG ;
S DIC="^LAB(62.05,",DIC(0)="AQE",DIC("S")="I '$P(^(0),U,3)",DIC("B")=$P($G(^LAB(62.05,LROUTINE,0)),U) D ^DIC S LRURG=$S(+Y<1:LROUTINE,1:+Y)
S LRNN=1 D ^LROW1 G QUIT:'$D(X3) S S9=LRSPEC
QSN2 IF LRADT S %DT("A")="DRAW DATE/TIME: ",%DT(0)="-N",%DT="EATPX" D ^%DT K %DT G:Y<0 QUIT S LRCDT=Y_U,LRIDT=9999999-Y G QSN2:Y<1
D NEW^LROR6() I $G(LRNATURE)=-1 W !!,$C(7),"...process aborted" S %="^" K LRNATURE Q
S LRSNO=LRDFN_U_DUZ_U_LRSAMP_U_LRLWC_U_+LRCDT_U_LRPRAC_U_LRLLOC
S LRBEY=1 I +LRDPF=2&($G(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT)) D G QUIT:'LRBEY
.D SLROT^LRBEBA2(.LRXST,.LRTEST,.LROT) ;Define LROT array
.D AQ1^LRBEBA3 ; CIDC
I ($D(LRBEY)<1)!$D(DUOUT)!$D(DTOUT) Q
S LRNCWL=1 D REST^LROW2 K LRNCWL S ^LRO(69,LRODT,1,LRSN,1)=+LRCDT_"^^"_DUZ_"^C^^^^"_DUZ(2),^LRO(69,"AA",+$G(^(.1)),LRODT_"|"_LRSN)=""
S LRSPEC=S9,LRTSTS=0,LRNOLABL=1 D ^LRWLST K LRNOLABL Q:'$D(LRAN)
LROE ;from LROE1
S LRLLOC=$P(^LRO(69,LRODT,1,LRSN,0),U,7) S:'$L(LRLLOC) LRLLOC=0 K LROE
; S I1=0 F S I1=$O(^LRO(69,LRODT,1,LRSN,2,I1)) Q:I1<1!($G(LREND)) S X=^(I1,0) I $P(X,U,4) S LRAA=$P(X,U,4),LRAN=$P(X,U,5),LRAD=$P(X,U,3) I '$D(LROE(LRAD_LRAA_LRAN)) S LROE(LRAD_LRAA_LRAN)="" D LROE1
; ----- BEGIN IHS/OIT - LR*5.2*1027 - I1 variable getting Killed somewhere.
NEW I111
S I111=0 F S I111=$O(^LRO(69,LRODT,1,LRSN,2,I111)) Q:I111<1!($G(LREND)) S X=^(I111,0) I $P(X,U,4) S LRAA=$P(X,U,4),LRAN=$P(X,U,5),LRAD=$P(X,U,3) I '$D(LROE(LRAD_LRAA_LRAN)) S LROE(LRAD_LRAA_LRAN)="" D LROE1
; ----- END IHS/OIT - LR*5.2*1027 - I1 variable getting Killed somewhere.
G QUIT
;
;
LROE1 S LRX=$G(^LRO(68,LRAA,0))
S LRIDIV=$S($L($P(LRX,U,19)):$P(LRX,U,19),1:"CP")
D:$P(LRPARAM,U,14)&($P($G(^LRO(68,LRAA,0)),U,16)) ^LRCAPV
I $G(LREND) Q
; Check for different performing lab.
I $G(LRPL) N LRDUZ S LRDUZ(2)=LRPL
;
S LRUID=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),"^")
I $P(LRX,U,2)="CH" D DEM^LRX,^LRVER1
I $P(LRX,U,2)="MI" D
. S LRPTP=-1,LRMIDEF=$P(^LAB(69.9,1,1),U,10),LRMIOTH=$P(^(0),U,11)
. D PAT1^LRMIEDZ2
. K LRMIDEF,LRMIOTH
K LRX
Q
;
;
QUIT K ^TMP("LR",$J,"TMP"),%,A,AGE,D1,D2,DFN,DIE,DL,DLAYGO,DOB,DQ,DR,DX,H8,I,J,K,LRAA,LRACC,LRAD,LRADT,LRAN,LRAP,LRCDT,LRCW,LRNATURE,I1
K LRCWDT,LRD,LRDAT,LRDEL,LRDFN,LRDPF,LRDV,LRDVF,LREAL,LREDIT,LREND,LRFFLG,LRFP,LRIDT,LRIN,LRINI,LRIX,DIC,LRORD,LRSB
K LRLBLBP,LRLCT,LRLDT,LRLLOC,LRLONG,LRMETH,LRNAME,LRNG,LRNG2,LRNG3,LRNG4,LRNG5,LRNP,LRNT,LRNTN,LRNX,LRODT,LROUT,LROUTINE,LROWDT,LROWLE,LRPR,LRPRAC,LRRB,LRPTP,LRSAMP,LRSN,LRSPEC,LRSS,LRSSP,LRST,LRSUB,LRSUM,LRTB,LRTD,LRTEST
K LRTN,LRTS,LRTX,LRUNQ,LRURG,LRUSI,LRUSNM,^TMP("LR",$J,"VTO"),LRWL0,LRWLC,LRWRD,LRXD,LRXDH,LRXDP,LRYR,PNM,S,S9,SEX,SSN,T,X,X1,Y,Z,LRACD,LRADDTST,LRAOD,LRBED,LRCSS,LRDTO,LREXEC,LRFLOG,LRGCOM,LRGVP,LRIOZERO,LRNIDT,LROCN,LROID,LROLRDFN
K LRCCOM,LRCFL,LRCS,LRCSN,LRCSP,LRCSX,LREXP,LRLWC,LRM,LRMAX,LRNN,LRSNO,LRTSTN,LRTY,LRVF,LRVRM,LRXS,I5,S2,S5,T1,POP,X2,X3,X9,LRORDER,LRORDR,LRORDTIM,LRORIFN,LROSN,LRPER,LRPHSET,LRPLOC,LRSPCDSC,LRSSQ,LRSSX,LRSVSN,LRTEC,LRTJ,LRTP,LRTSTNM
K LRTCOM,LRALERT,LROE,LRUR,LRVOL,LRWPC,PNM,LROLLOC,LRTREA,LRMAX2,LRMX,LRCAPLOC,LRCOM,LRXST,LRY,LRJ,LRMA,LRMAX1,LRNOW,LRODTSV,LRPANEL,LRSNSV,LRTNSV,LRCDEF0X,LRDAX,LRNOCODE
K LRSUF0,LRBEQT,LRBEVT,LRBETS,LRBEX,LRBEY,LRBEZ,LRBETYP
K HRCN ;IHS/ANMC/CLS 08/18/96
D END^LRMIEDZ,^LRORDK ;LROEND^LRORDK
D ^LRPARAM Q
EN ; D QUIT,^LRORDK,LROEND^LRORDK D ^LRPARAM S LRLONG="" G SHORT
D QUIT,^LRORDK,LROEND^LRORDK D ^LRPARAM S LRLONG="" S:$G(BLROPT)=""!($G(BLROPT(0))'=$P(XQY0,U)) BLROPT="BYPASS",BLROPT(0)=$P(XQY0,U) G SHORT ;IHS/OIRM TUC/AAB 2/1/97
% R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G %
LRFAST ;VA/DALOI/JMC - FAST ENTRY ;May 23, 2006
+1 ;;5.2;LAB SERVICE;**1003,1006,1013,1018,1027,1031**;NOV 1, 1997
+2 ;
+3 ;;VA LR Patche(s): 100,121,201,286,291,328
+4 ;
+5 NEW LRBEQT,LRBEVT,LRBETS,LRBEX,LRBEY,LRBEZ,LRBETYP
+6 KILL LRLONG,LRNATURE
+7 SET LRLONG=""
+8 DO ^LRPARAM
SHORT SET LRPANEL=0
SET LROUTINE=$PIECE(^LAB(69.9,1,3),U,2)
SET LRPTP=-1
IF '$DATA(LRLONG)
WRITE !,"BYPASSING ORDER ENTRY!!",$CHAR(7)
+1 IF $DATA(^LAB(69.9,1,"RO"))
IF +$HOROLOG'=^("RO")
WRITE $CHAR(7),!,"ROLLOVER ",$SELECT($PIECE(^("RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")," ACCESSIONING SHOULDN'T BE DONE NOW.",$CHAR(7),!," Are you sure you want to continue"
+2 IF $TEST
SET %=2
DO YN^DICN
IF %=0
WRITE !,"Not sure?"
IF %'=1
WRITE !,"OK, try later."
QUIT
+3 SET X=$$SELPL^LRVERA(DUZ(2))
+4 IF X<1
DO QUIT
QUIT
+5 IF X'=DUZ(2)
NEW LRPL
SET LRPL=X
+6 ;
SH ; W !,"Do you want to enter draw times" S %=2 D YN^DICN S LRADT=(%=1) Q:%=-1
+1 ;IHS/ANMC/CLS 08/18/96
WRITE !,"Do you want to enter draw times"
SET %=1
DO YN^DICN
SET LRADT=(%=1)
IF %=-1
QUIT
+2 IF %=0
WRITE !,"If you answer 'yes', you will be asked for the approximate time the specimen",!,"was taken from the patient. Otherwise, the current time will be assumed."
GOTO SH
AMIS ;
+1 SET U="^"
SET (Y,LRNT)=$$NOW^XLFDT
SET LRODT=DT
SET LRAD=DT
SET LRIDT=9999999-Y
SET LRCDT=Y_"^1"
SET LRSAMP=""
KILL DFN,DIC
SET DIC(0)="EMQ"_$SELECT($PIECE(LRPARAM,U,6):"L",1:"")
DO ^LRDPA
IF (LRDFN=-1)!$DATA(DUOUT)!$DATA(DTOUT)
GOTO QUIT
+2 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)=""
SET %H=$HOROLOG-60
DO YMD^LRX
SET LRTM60=9999999-X
QSN1 DO PT^LRX
IF $GET(LREND)
GOTO QUIT
KILL DR
SET LRLLOC=$SELECT($LENGTH(LRWRD):LRWRD,$DATA(^LR(LRDFN,.1)):^(.1),1:"UNKNOWN")
IF $LENGTH(LRWRD)
DO DPT^LRWU
Q12 IF $DATA(LRLONG)
DO LOC^LRWU
IF LREND
GOTO QUIT
Q11 DO COLTY^LRWU
IF LREND
GOTO QUIT
SET LRPRAC=""
IF $DATA(LRLONG)
DO PRAC^LRWU1
IF LREND
WRITE !!,$CHAR(7),"ORDER CANCELED",!!
GOTO QUIT
URG ;
+1 SET DIC="^LAB(62.05,"
SET DIC(0)="AQE"
SET DIC("S")="I '$P(^(0),U,3)"
SET DIC("B")=$PIECE($GET(^LAB(62.05,LROUTINE,0)),U)
DO ^DIC
SET LRURG=$SELECT(+Y<1:LROUTINE,1:+Y)
+2 SET LRNN=1
DO ^LROW1
IF '$DATA(X3)
GOTO QUIT
SET S9=LRSPEC
QSN2 IF LRADT
SET %DT("A")="DRAW DATE/TIME: "
SET %DT(0)="-N"
SET %DT="EATPX"
DO ^%DT
KILL %DT
IF Y<0
GOTO QUIT
SET LRCDT=Y_U
SET LRIDT=9999999-Y
IF Y<1
GOTO QSN2
+1 DO NEW^LROR6()
IF $GET(LRNATURE)=-1
WRITE !!,$CHAR(7),"...process aborted"
SET %="^"
KILL LRNATURE
QUIT
+2 SET LRSNO=LRDFN_U_DUZ_U_LRSAMP_U_LRLWC_U_+LRCDT_U_LRPRAC_U_LRLLOC
+3 SET LRBEY=1
IF +LRDPF=2&($GET(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT))
Begin DoDot:1
+4 ;Define LROT array
DO SLROT^LRBEBA2(.LRXST,.LRTEST,.LROT)
+5 ; CIDC
DO AQ1^LRBEBA3
End DoDot:1
IF 'LRBEY
GOTO QUIT
+6 IF ($DATA(LRBEY)<1)!$DATA(DUOUT)!$DATA(DTOUT)
QUIT
+7 SET LRNCWL=1
DO REST^LROW2
KILL LRNCWL
SET ^LRO(69,LRODT,1,LRSN,1)=+LRCDT_"^^"_DUZ_"^C^^^^"_DUZ(2)
SET ^LRO(69,"AA",+$GET(^(.1)),LRODT_"|"_LRSN)=""
+8 SET LRSPEC=S9
SET LRTSTS=0
SET LRNOLABL=1
DO ^LRWLST
KILL LRNOLABL
IF '$DATA(LRAN)
QUIT
LROE ;from LROE1
+1 SET LRLLOC=$PIECE(^LRO(69,LRODT,1,LRSN,0),U,7)
IF '$LENGTH(LRLLOC)
SET LRLLOC=0
KILL LROE
+2 ; S I1=0 F S I1=$O(^LRO(69,LRODT,1,LRSN,2,I1)) Q:I1<1!($G(LREND)) S X=^(I1,0) I $P(X,U,4) S LRAA=$P(X,U,4),LRAN=$P(X,U,5),LRAD=$P(X,U,3) I '$D(LROE(LRAD_LRAA_LRAN)) S LROE(LRAD_LRAA_LRAN)="" D LROE1
+3 ; ----- BEGIN IHS/OIT - LR*5.2*1027 - I1 variable getting Killed somewhere.
+4 NEW I111
+5 SET I111=0
FOR
SET I111=$ORDER(^LRO(69,LRODT,1,LRSN,2,I111))
IF I111<1!($GET(LREND))
QUIT
SET X=^(I111,0)
IF $PIECE(X,U,4)
SET LRAA=$PIECE(X,U,4)
SET LRAN=$PIECE(X,U,5)
SET LRAD=$PIECE(X,U,3)
IF '$DATA(LROE(LRAD_LRAA_LRAN))
SET LROE(LRAD_LRAA_LRAN)=""
DO LROE1
+6 ; ----- END IHS/OIT - LR*5.2*1027 - I1 variable getting Killed somewhere.
+7 GOTO QUIT
+8 ;
+9 ;
LROE1 SET LRX=$GET(^LRO(68,LRAA,0))
+1 SET LRIDIV=$SELECT($LENGTH($PIECE(LRX,U,19)):$PIECE(LRX,U,19),1:"CP")
+2 IF $PIECE(LRPARAM,U,14)&($PIECE($GET(^LRO(68,LRAA,0)),U,16))
DO ^LRCAPV
+3 IF $GET(LREND)
QUIT
+4 ; Check for different performing lab.
+5 IF $GET(LRPL)
NEW LRDUZ
SET LRDUZ(2)=LRPL
+6 ;
+7 SET LRUID=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),"^")
+8 IF $PIECE(LRX,U,2)="CH"
DO DEM^LRX
DO ^LRVER1
+9 IF $PIECE(LRX,U,2)="MI"
Begin DoDot:1
+10 SET LRPTP=-1
SET LRMIDEF=$PIECE(^LAB(69.9,1,1),U,10)
SET LRMIOTH=$PIECE(^(0),U,11)
+11 DO PAT1^LRMIEDZ2
+12 KILL LRMIDEF,LRMIOTH
End DoDot:1
+13 KILL LRX
+14 QUIT
+15 ;
+16 ;
QUIT KILL ^TMP("LR",$JOB,"TMP"),%,A,AGE,D1,D2,DFN,DIE,DL,DLAYGO,DOB,DQ,DR,DX,H8,I,J,K,LRAA,LRACC,LRAD,LRADT,LRAN,LRAP,LRCDT,LRCW,LRNATURE,I1
+1 KILL LRCWDT,LRD,LRDAT,LRDEL,LRDFN,LRDPF,LRDV,LRDVF,LREAL,LREDIT,LREND,LRFFLG,LRFP,LRIDT,LRIN,LRINI,LRIX,DIC,LRORD,LRSB
+2 KILL LRLBLBP,LRLCT,LRLDT,LRLLOC,LRLONG,LRMETH,LRNAME,LRNG,LRNG2,LRNG3,LRNG4,LRNG5,LRNP,LRNT,LRNTN,LRNX,LRODT,LROUT,LROUTINE,LROWDT,LROWLE,LRPR,LRPRAC,LRRB,LRPTP,LRSAMP,LRSN,LRSPEC,LRSS,LRSSP,LRST,LRSUB,LRSUM,LRTB,LRTD,LRTEST
+3 KILL LRTN,LRTS,LRTX,LRUNQ,LRURG,LRUSI,LRUSNM,^TMP("LR",$JOB,"VTO"),LRWL0,LRWLC,LRWRD,LRXD,LRXDH,LRXDP,LRYR,PNM,S,S9,SEX,SSN,T,X,X1,Y,Z,LRACD,LRADDTST,LRAOD,LRBED,LRCSS,LRDTO,LREXEC,LRFLOG,LRGCOM,LRGVP,LRIOZERO,LRNIDT,LROCN,LROID,LROLRDFN
+4 KILL LRCCOM,LRCFL,LRCS,LRCSN,LRCSP,LRCSX,LREXP,LRLWC,LRM,LRMAX,LRNN,LRSNO,LRTSTN,LRTY,LRVF,LRVRM,LRXS,I5,S2,S5,T1,POP,X2,X3,X9,LRORDER,LRORDR,LRORDTIM,LRORIFN,LROSN,LRPER,LRPHSET,LRPLOC,LRSPCDSC,LRSSQ,LRSSX,LRSVSN,LRTEC,LRTJ,LRTP,LRTSTNM
+5 KILL LRTCOM,LRALERT,LROE,LRUR,LRVOL,LRWPC,PNM,LROLLOC,LRTREA,LRMAX2,LRMX,LRCAPLOC,LRCOM,LRXST,LRY,LRJ,LRMA,LRMAX1,LRNOW,LRODTSV,LRPANEL,LRSNSV,LRTNSV,LRCDEF0X,LRDAX,LRNOCODE
+6 KILL LRSUF0,LRBEQT,LRBEVT,LRBETS,LRBEX,LRBEY,LRBEZ,LRBETYP
+7 ;IHS/ANMC/CLS 08/18/96
KILL HRCN
+8 ;LROEND^LRORDK
DO END^LRMIEDZ
DO ^LRORDK
+9 DO ^LRPARAM
QUIT
EN ; D QUIT,^LRORDK,LROEND^LRORDK D ^LRPARAM S LRLONG="" G SHORT
+1 ;IHS/OIRM TUC/AAB 2/1/97
DO QUIT
DO ^LRORDK
DO LROEND^LRORDK
DO ^LRPARAM
SET LRLONG=""
IF $GET(BLROPT)=""!($GET(BLROPT(0))'=$PIECE(XQY0,U))
SET BLROPT="BYPASS"
SET BLROPT(0)=$PIECE(XQY0,U)
GOTO SHORT
% READ %:DTIME
IF %=""!(%["N")!(%["Y")
QUIT
WRITE !,"Answer 'Y' or 'N': "
GOTO %
