LRORD ;DALOI/CJS - LAZY ACCESSION LOGGING ;05/29/12 10:25
;;5.2;LAB SERVICE;**100,121,153,286,350**;Sep 27, 1994;Build 230
;
EN ;;
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 !,"If you continue to accession, you may block accessions from yesterday from",!,"rolling over." G LRORD:%=0 I %'=1 W !,"OK, try later." Q
EN1 ;;from LROR4
D EN^LRPARAM
K ^TMP("LRSTIK",$J),DIC,LRURG,LRSAME,LRCOM,LRNATURE,LRTCOM
S LRORDTIM="" S:'$D(LRORDR) LRORDR="" D DT^LRX
I $D(LRADDTST) Q:LRADDTST=""
S LRFIRST=1,LRODT=DT,U="^",LRECT=0,LROUTINE=$P(^LAB(69.9,1,3),U,2)
S:$G(LRORDRR)="R" LRECT=1,LRFIRST=0
I '$G(LRECT),LRORDR="" W !!,"WANT TO ENTER COLLECTION TIMES? Y//" D % S LRECT='(%["N") G KILL:$E(%)="^"
I LRORDR="LC" W !!," Ordering for ROUTINE LAB COLLECT ONLY",$C(7),! S LRLWC="LC",LRLLOC=".",LREND=0 D NEXTCOL^LROW5 G KILL:LREND
I LRORDR="SP" W !!," Ordering for SEND PATIENT ONLY",$C(7),! S LRLWC="SP"
I LRORDR="WC" W !!,"Ordering for WARD COLLECT & DELIVER ONLY",$C(7),! S LRLWC="WC"
I LRORDR="I" D ^LRORDIM G KILL:'$D(LRCDT)
L5 I LRORDR]"",LRORDR'="LC",LRORDR'="I" S %DT="AET",%DT("A")=$S(LRORDR="WC":"COLLECTION",LRORDR="SP":"PATIENT VISIT",1:"")_" DATE: "
I $T D DATE^LRWU G KILL:Y<1 S LRORDTIM=$P(Y,".",2),LRODT=$P(Y,".",1),X1=Y,X2=DT D ^%DTC IF X>370 W !,"Can't order more than 12 months ahead!!" G L5
I $D(LRODT),$P(LRODT,".")?7N,'+$E($P(LRODT,"."),6,7) W !!?7,$C(7),"Please enter a date, ie. 4/1/90",!! G L5
I $D(LRODT),$P(LRODT,".")<DT W !,$C(7),"Cannot order in the Past.",! G L5
I $D(LRFLOG) S Y=LRFLOG G G0:LRFLOG>0
S DIC="^LAB(62.6,",DIC(0)="AEQMZ"
S DIC("S")=$S($D(LRLABKY):"I '(LRORDR=""LC""&'$P(^(0),U,4))",1:"I '(LRORDR=""LC""&'$P(^(0),U,4))&'$P(^(0),U,3)")
D ^DIC K DIC G KILL:$D(DUOUT)!$D(DTOUT),G1:Y<1 S LRFLOG=Y
G0 S $P(LRFLOG,U,3)=$P(^LAB(62.2,+$P(^LAB(62.6,+LRFLOG,0),U,2),0),U,2)
S LRFLOG(0)=^LAB(62.6,+LRFLOG,0)
S (LRWP,I)=0
F S I=$O(^LAB(62.6,+Y,1,I)) Q:I<1 D
. S Y(0)=$G(^LAB(62.6,+Y,1,I,0)),LRWP=LRWP+1
. S ^TMP("LRSTIK",$J,$S($P(LRFLOG(0),"^",5):I,1:LRWP))=Y(0)
. ; Lookup by number user enters.
. S ^TMP("LRSTIK",$J,"B",LRWP)=$S($P(LRFLOG(0),"^",5):I,1:LRWP)
. ; Lookup by test - used by LEDI (LRORDB) when user creates list "on-the-fly"
. S ^TMP("LRSTIK",$J,"C",+Y(0),$S($P(LRFLOG(0),"^",5):I,1:LRWP))=""
I LRWP>40 S LRFIRST=0 ; Don't automatically display "long" test lists.
G G5
G1 S LRWP=0 W !,"Select one or more tests from which you will be generating your entries."
GET D Q15^LRORD2
D ^DIC K DIC("S") G:Y<1 G5
S LRWP=LRWP+1,LRY=Y
S ^TMP("LRSTIK",$J,LRWP)=$P(LRY,U,1,2)
; "B" Used to lookup by number user enters.
S ^TMP("LRSTIK",$J,"B",LRWP)=LRWP
; "C" Used by LEDI (LRORDB)
S ^TMP("LRSTIK",$J,"C",+LRY,LRWP)=""
S LRTSTS=+^TMP("LRSTIK",$J,LRWP) D GS^LRORD3
S:+LRSAMP=-1&(LRSPEC=-1) LRWP=LRWP-1
G GET:+LRSAMP=-1&(LRSPEC=-1)
S ^TMP("LRSTIK",$J,LRWP)=^TMP("LRSTIK",$J,LRWP)_U_LRSAMP_U_U_LRSPEC
G GET
;
G5 G KILL:LRWP<1
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 LRURG="",LRAD=DT,LRWPD=LRWP\2+(LRWP#2) D ^LRORD1
KILL D ^LRORDK,HOME^%ZIS Q
% R %:DTIME Q:%=""!(%["N")!(%["Y")!($E(%)="^") W !,"Answer 'Y' or 'N': " G %
EN01 ;LAB COLLECT ORDER ENTRY
ORDER S %=2 W !,"Do you want copies of the orders" D YN^DICN Q:%=-1 S:%=1 LRSLIP="" I %=0 D QUIZ G ORDER
S LRORDR="LC",LRLWCURG=$S($P(^LAB(69.9,1,3),U,2)'="":$P(^(3),U,2),1:9) G LRORD
EN02 ;SEND PATIENT ORDER ENTRY
SENDPAT S %=2 W !,"Do you want copies of the orders" D YN^DICN Q:%=-1 S:%=1 LRSLIP="" I %=0 D QUIZ G SENDPAT
S LRORDR="SP" G LRORD
IMMCOL ;IMMEDIATE LAB COLLECTION
I '$P($G(^LAB(69.9,1,7,DUZ(2),0)),U,6) W !!?5," This option is not available at the time ",!!,$C(7) Q
S LRORDR="I" K LRODT G LRORD
;
EN03 ;WARD COLLECT ORDER ENTRY
WARDCOL ;
S %=2
W !,"Do you want copies of the orders" D YN^DICN Q:%=-1 S:%=1 LRSLIP="" I %=0 D QUIZ G WARDCOL
S LRORDR="WC" D LRORD
Q
;
;
LEDI ; Laboratory Electronic Data Exchange
; This entry point is used to select patients from ^LRT(67, file
; Routine LRDPAREF controls patient selection, patients must already
; exist in ^DPT in order to be selected.
D ^LRPARAM
I $G(LREND) D ^LRORDK Q
N CONTROL,LA7,LA7SCFG,LA7X,LA7Y,LR64,LR696,LRLABLIO,LRRSTAT,LRRSITE,LRSD,LRTSN
S LRREFBAR=$$BAR^LA7SBCR
I LRREFBAR<0 D ^LRORDK Q
S LRRSTAT="I"
S LRRSTAT(0)=$$FIND1^DIC(64.061,"","OMX","Specimen in process","","I $P(^LAB(64.061,Y,0),U,7)=""U""")
D SITE^LA7SBCR2(.LRRSITE,"Scan Remote Site Barcode (SM)",LRREFBAR)
I LRRSITE("ERROR") D Q
. W !!,$C(7),"ERROR -- ",$P(LRRSITE("ERROR"),"^",2),!
. D ^LRORDK
;
; Handle inter-divisional manifests
I DUZ(2)=$P(LRRSITE("HSITE"),"^"),$$KSP^XUPARAM("INST")=$P(LRRSITE("RPSITE"),"^") D INTERDIV^LA7SMA(.LRRSITE),^LRORDK Q
;
; Get shipping manifest ID manual input
I $G(LRRSITE("SMID"))="" D
. F D SMID^LRORDB Q:LREND!($G(LRRSITE("SMID"))'="")
I $G(LREND) D ^LRORDK Q
;
; LRORDRR="R" variable indicates host accessioning of remote orders
S LRORDRR="R",LRORDR="" K LRODT
D LRORD,^LRORDK
Q
;
;
; LRORDRR =TYPE OF ORDER, LRECT =ASK COLECTION TIME
; LRFLOG =ACCESSION TEST GROUP, IF DEFINED ON ENTRY, PRESELECTS GROUP
;
QUIZ W !,"The order copy is automatically sent to the CLOSEST PRINTER,"
W !,"if a closest printer is defined for the device you are using."
W !,"Otherwise, you will be prompted with ORDER COPY DEVICE.",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRORD 5641 printed Oct 16, 2024@18:19:34 Page 2
LRORD ;DALOI/CJS - LAZY ACCESSION LOGGING ;05/29/12 10:25
+1 ;;5.2;LAB SERVICE;**100,121,153,286,350**;Sep 27, 1994;Build 230
+2 ;
EN ;;
+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 !,"If you continue to accession, you may block accessions from yesterday from",!,"rolling over."
if %=0
GOTO LRORD
IF %'=1
WRITE !,"OK, try later."
QUIT
EN1 ;;from LROR4
+1 DO EN^LRPARAM
+2 KILL ^TMP("LRSTIK",$JOB),DIC,LRURG,LRSAME,LRCOM,LRNATURE,LRTCOM
+3 SET LRORDTIM=""
if '$DATA(LRORDR)
SET LRORDR=""
DO DT^LRX
+4 IF $DATA(LRADDTST)
if LRADDTST=""
QUIT
+5 SET LRFIRST=1
SET LRODT=DT
SET U="^"
SET LRECT=0
SET LROUTINE=$PIECE(^LAB(69.9,1,3),U,2)
+6 if $GET(LRORDRR)="R"
SET LRECT=1
SET LRFIRST=0
+7 IF '$GET(LRECT)
IF LRORDR=""
WRITE !!,"WANT TO ENTER COLLECTION TIMES? Y//"
DO %
SET LRECT='(%["N")
if $EXTRACT(%)="^"
GOTO KILL
+8 IF LRORDR="LC"
WRITE !!," Ordering for ROUTINE LAB COLLECT ONLY",$CHAR(7),!
SET LRLWC="LC"
SET LRLLOC="."
SET LREND=0
DO NEXTCOL^LROW5
if LREND
GOTO KILL
+9 IF LRORDR="SP"
WRITE !!," Ordering for SEND PATIENT ONLY",$CHAR(7),!
SET LRLWC="SP"
+10 IF LRORDR="WC"
WRITE !!,"Ordering for WARD COLLECT & DELIVER ONLY",$CHAR(7),!
SET LRLWC="WC"
+11 IF LRORDR="I"
DO ^LRORDIM
if '$DATA(LRCDT)
GOTO KILL
L5 IF LRORDR]""
IF LRORDR'="LC"
IF LRORDR'="I"
SET %DT="AET"
SET %DT("A")=$SELECT(LRORDR="WC":"COLLECTION",LRORDR="SP":"PATIENT VISIT",1:"")_" DATE: "
+1 IF $TEST
DO DATE^LRWU
if Y<1
GOTO KILL
SET LRORDTIM=$PIECE(Y,".",2)
SET LRODT=$PIECE(Y,".",1)
SET X1=Y
SET X2=DT
DO ^%DTC
IF X>370
WRITE !,"Can't order more than 12 months ahead!!"
GOTO L5
+2 IF $DATA(LRODT)
IF $PIECE(LRODT,".")?7N
IF '+$EXTRACT($PIECE(LRODT,"."),6,7)
WRITE !!?7,$CHAR(7),"Please enter a date, ie. 4/1/90",!!
GOTO L5
+3 IF $DATA(LRODT)
IF $PIECE(LRODT,".")<DT
WRITE !,$CHAR(7),"Cannot order in the Past.",!
GOTO L5
+4 IF $DATA(LRFLOG)
SET Y=LRFLOG
if LRFLOG>0
GOTO G0
+5 SET DIC="^LAB(62.6,"
SET DIC(0)="AEQMZ"
+6 SET DIC("S")=$SELECT($DATA(LRLABKY):"I '(LRORDR=""LC""&'$P(^(0),U,4))",1:"I '(LRORDR=""LC""&'$P(^(0),U,4))&'$P(^(0),U,3)")
+7 DO ^DIC
KILL DIC
if $DATA(DUOUT)!$DATA(DTOUT)
GOTO KILL
if Y<1
GOTO G1
SET LRFLOG=Y
G0 SET $PIECE(LRFLOG,U,3)=$PIECE(^LAB(62.2,+$PIECE(^LAB(62.6,+LRFLOG,0),U,2),0),U,2)
+1 SET LRFLOG(0)=^LAB(62.6,+LRFLOG,0)
+2 SET (LRWP,I)=0
+3 FOR
SET I=$ORDER(^LAB(62.6,+Y,1,I))
if I<1
QUIT
Begin DoDot:1
+4 SET Y(0)=$GET(^LAB(62.6,+Y,1,I,0))
SET LRWP=LRWP+1
+5 SET ^TMP("LRSTIK",$JOB,$SELECT($PIECE(LRFLOG(0),"^",5):I,1:LRWP))=Y(0)
+6 ; Lookup by number user enters.
+7 SET ^TMP("LRSTIK",$JOB,"B",LRWP)=$SELECT($PIECE(LRFLOG(0),"^",5):I,1:LRWP)
+8 ; Lookup by test - used by LEDI (LRORDB) when user creates list "on-the-fly"
+9 SET ^TMP("LRSTIK",$JOB,"C",+Y(0),$SELECT($PIECE(LRFLOG(0),"^",5):I,1:LRWP))=""
End DoDot:1
+10 ; Don't automatically display "long" test lists.
IF LRWP>40
SET LRFIRST=0
+11 GOTO G5
G1 SET LRWP=0
WRITE !,"Select one or more tests from which you will be generating your entries."
GET DO Q15^LRORD2
+1 DO ^DIC
KILL DIC("S")
if Y<1
GOTO G5
+2 SET LRWP=LRWP+1
SET LRY=Y
+3 SET ^TMP("LRSTIK",$JOB,LRWP)=$PIECE(LRY,U,1,2)
+4 ; "B" Used to lookup by number user enters.
+5 SET ^TMP("LRSTIK",$JOB,"B",LRWP)=LRWP
+6 ; "C" Used by LEDI (LRORDB)
+7 SET ^TMP("LRSTIK",$JOB,"C",+LRY,LRWP)=""
+8 SET LRTSTS=+^TMP("LRSTIK",$JOB,LRWP)
DO GS^LRORD3
+9 if +LRSAMP=-1&(LRSPEC=-1)
SET LRWP=LRWP-1
+10 if +LRSAMP=-1&(LRSPEC=-1)
GOTO GET
+11 SET ^TMP("LRSTIK",$JOB,LRWP)=^TMP("LRSTIK",$JOB,LRWP)_U_LRSAMP_U_U_LRSPEC
+12 GOTO GET
+13 ;
G5 if LRWP<1
GOTO KILL
+1 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)=""
+2 SET LRURG=""
SET LRAD=DT
SET LRWPD=LRWP\2+(LRWP#2)
DO ^LRORD1
KILL DO ^LRORDK
DO HOME^%ZIS
QUIT
% READ %:DTIME
if %=""!(%["N")!(%["Y")!($EXTRACT(%)="^")
QUIT
WRITE !,"Answer 'Y' or 'N': "
GOTO %
EN01 ;LAB COLLECT ORDER ENTRY
ORDER SET %=2
WRITE !,"Do you want copies of the orders"
DO YN^DICN
if %=-1
QUIT
if %=1
SET LRSLIP=""
IF %=0
DO QUIZ
GOTO ORDER
+1 SET LRORDR="LC"
SET LRLWCURG=$SELECT($PIECE(^LAB(69.9,1,3),U,2)'="":$PIECE(^(3),U,2),1:9)
GOTO LRORD
EN02 ;SEND PATIENT ORDER ENTRY
SENDPAT SET %=2
WRITE !,"Do you want copies of the orders"
DO YN^DICN
if %=-1
QUIT
if %=1
SET LRSLIP=""
IF %=0
DO QUIZ
GOTO SENDPAT
+1 SET LRORDR="SP"
GOTO LRORD
IMMCOL ;IMMEDIATE LAB COLLECTION
+1 IF '$PIECE($GET(^LAB(69.9,1,7,DUZ(2),0)),U,6)
WRITE !!?5," This option is not available at the time ",!!,$CHAR(7)
QUIT
+2 SET LRORDR="I"
KILL LRODT
GOTO LRORD
+3 ;
EN03 ;WARD COLLECT ORDER ENTRY
WARDCOL ;
+1 SET %=2
+2 WRITE !,"Do you want copies of the orders"
DO YN^DICN
if %=-1
QUIT
if %=1
SET LRSLIP=""
IF %=0
DO QUIZ
GOTO WARDCOL
+3 SET LRORDR="WC"
DO LRORD
+4 QUIT
+5 ;
+6 ;
LEDI ; Laboratory Electronic Data Exchange
+1 ; This entry point is used to select patients from ^LRT(67, file
+2 ; Routine LRDPAREF controls patient selection, patients must already
+3 ; exist in ^DPT in order to be selected.
+4 DO ^LRPARAM
+5 IF $GET(LREND)
DO ^LRORDK
QUIT
+6 NEW CONTROL,LA7,LA7SCFG,LA7X,LA7Y,LR64,LR696,LRLABLIO,LRRSTAT,LRRSITE,LRSD,LRTSN
+7 SET LRREFBAR=$$BAR^LA7SBCR
+8 IF LRREFBAR<0
DO ^LRORDK
QUIT
+9 SET LRRSTAT="I"
+10 SET LRRSTAT(0)=$$FIND1^DIC(64.061,"","OMX","Specimen in process","","I $P(^LAB(64.061,Y,0),U,7)=""U""")
+11 DO SITE^LA7SBCR2(.LRRSITE,"Scan Remote Site Barcode (SM)",LRREFBAR)
+12 IF LRRSITE("ERROR")
Begin DoDot:1
+13 WRITE !!,$CHAR(7),"ERROR -- ",$PIECE(LRRSITE("ERROR"),"^",2),!
+14 DO ^LRORDK
End DoDot:1
QUIT
+15 ;
+16 ; Handle inter-divisional manifests
+17 IF DUZ(2)=$PIECE(LRRSITE("HSITE"),"^")
IF $$KSP^XUPARAM("INST")=$PIECE(LRRSITE("RPSITE"),"^")
DO INTERDIV^LA7SMA(.LRRSITE)
DO ^LRORDK
QUIT
+18 ;
+19 ; Get shipping manifest ID manual input
+20 IF $GET(LRRSITE("SMID"))=""
Begin DoDot:1
+21 FOR
DO SMID^LRORDB
if LREND!($GET(LRRSITE("SMID"))'="")
QUIT
End DoDot:1
+22 IF $GET(LREND)
DO ^LRORDK
QUIT
+23 ;
+24 ; LRORDRR="R" variable indicates host accessioning of remote orders
+25 SET LRORDRR="R"
SET LRORDR=""
KILL LRODT
+26 DO LRORD
DO ^LRORDK
+27 QUIT
+28 ;
+29 ;
+30 ; LRORDRR =TYPE OF ORDER, LRECT =ASK COLECTION TIME
+31 ; LRFLOG =ACCESSION TEST GROUP, IF DEFINED ON ENTRY, PRESELECTS GROUP
+32 ;
QUIZ WRITE !,"The order copy is automatically sent to the CLOSEST PRINTER,"
+1 WRITE !,"if a closest printer is defined for the device you are using."
+2 WRITE !,"Otherwise, you will be prompted with ORDER COPY DEVICE.",!
+3 QUIT
