- LRORD ;VA/DALOI/CJS - LAZY ACCESSION LOGGING ; 22-Oct-2013 09:22 ; MKK
- ;;5.2;LAB SERVICE;**1010,1011,1012,100,1013,1014,121,153,1015,286,1027,291,1030,1033**;NOV 01, 1997
- ;
- ; IHS Patch 1033:
- ; (1) Restores IHS/DIR/MJL PATCH 1008 line that comments out line G0+12
- ; (2) Repaced code in % subroutine so that it uses FileMan DIR call
- ;
- D ENTRYAUD^BLRUTIL("^LRORD 0.0")
- ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
- S:XQY0["LRFASTS" BLROPT="FASTORD",BLROPT(0)=$P(XQY0,U)
- S XWBWRAP=1 ;IHS/ITSC/TPF 10/10/02 REQUESTED BY PATIENT CHART DEV. F.J.EVANS **1014**
- S:$G(BLROPT)=""!($G(BLROPT(0))'=$P(XQY0,U)) BLROPT="MULTI",BLROPT(0)=$P(XQY0,U) ;IHS/OIRM TUC/AAB 2/1/97
- ; ----- END IHS/OIT/MKK - LR*5.2*1027
- ;
- EN ;; EP
- D ENTRYAUD^BLRUTIL("EN^LRORD 0.0")
- ; 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
- ;-----BEGIN IHS MODIFICATION LR*5.2*1018
- I $D(^LAB(69.9,1,"RO")),+$H'=+^("RO") D Q:$G(BLRGUI) G LRORD:%=0 Q:%'=1
- . I $G(BLRGUI) S RESULT(1)=-1,RESULT(2)="ROLLOVER HAS NOT RUN. CHECK WITH SITE MANAGER" Q
- . ;
- . ; W $C(7),!,"ROLLOVER ",$S($P(^("RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")
- . W $C(7),!,"ROLLOVER ",$S($P(^LAB(69.9,1,"RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")
- . W " ACCESSIONING SHOULDN'T BE DONE NOW.",$C(7),!
- . W " Are you sure you want to continue"
- . S %=1 I $T S %=2 D YN^DICN W:%=0 !,"If you continue to accession, you may block accessions from yesterday from",!,"rolling over." Q:%=0 I %'=1 W !,"OK, try later."
- ;----- END IHS MODIFICATION
- ;
- EN1 ;;EP - from LROR4
- D ENTRYAUD^BLRUTIL("EN1^LRORD 0.0")
- D ^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 '$G(LRECT),LRORDR="" D %("WANT TO ENTER COLLECTION TIMES","YES") S LRECT='(%["N") G KILL:$E(%)="^" ; IHS/MSC/MKK - LR*5.2*1033
- 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 ; EP
- D ENTRYAUD^BLRUTIL("L5^LRORD 0.0")
- 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 ; EP
- D ENTRYAUD^BLRUTIL("G0^LRORD 0.0")
- 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))=""
- ;
- ; Following commented out for IHS. Originally done for LR*5.2*1008. Comment accidently left off
- ; in LR*5.2*1030, but restored with LR*5.2*1033
- ; I LRWP>40 S LRFIRST=0 ; Don't automatically display "long" test lists. ; IHS/DIR/MJL PATCH 1008
- G G5
- ;
- G1 ; EP
- S LRWP=0 W !,"Select one or more tests from which you will be generating your entries."
- ;
- GET ; EP
- D ENTRYAUD^BLRUTIL("GET^LRORD 0.0")
- 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
- D ENTRYAUD^BLRUTIL("GET^LRORD 9.0")
- G GET
- ;
- G5 ; EP
- D ENTRYAUD^BLRUTIL("G5^LRORD 0.0")
- 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 ; EP
- D ^LRORDK,HOME^%ZIS Q
- ;
- ; % ; EP
- ; R %:DTIME Q:%=""!(%["N")!(%["Y")!($E(%)="^") W !,"Answer 'Y' or 'N': " G %
- ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
- %(MSG,DEF) ; EP
- K DIR,X,Y,%
- S DIR(0)="YO"
- S:$L($G(MSG)) DIR("A")=MSG
- S:$L($G(DEF)) DIR("B")=DEF
- D ^DIR
- S %=$E(X)
- Q
- ; ----- END IHS/MSC/MKK - LR*5.2*1033
- ;
- EN01 ;EP - LAB COLLECT ORDER ENTRY
- D ENTRYAUD^BLRUTIL("EN01^LRORD 0.0")
- ;
- ORDER ; EP
- D ENTRYAUD^BLRUTIL("ORDER^LRORD 0.0")
- 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)
- S:$G(BLROPT)=""!($G(BLROPT(0))'=$P(XQY0,U)) BLROPT="FASTORD",BLROPT(0)=$P(XQY0,U) ;IHS/OIRM TUC/AAB 2/13/97
- G LRORD
- ;
- EN02 ; EP SEND PATIENT ORDER ENTRY
- SENDPAT ; EP - S %=2 W !,"Do you want copies of the orders" D YN^DICN Q:%=-1 S:%=1 LRSLIP="" I %=0 D QUIZ G SENDPAT
- D ENTRYAUD^BLRUTIL("SENDPAT^LRORD 0.0")
- S %=2 W !,"Do you want copies of the orders" D YN^DICN Q:%=-1 S:%=1 LRSLIP="" I %=0 D QUIZ G SENDPAT ; IHS/OIT/MKK -- LR*5.2*1027 -- Restored line
- S LRORDR="SP"
- S:$G(BLROPT)=""!($G(BLROPT(0))'=$P(XQY0,U)) BLROPT="FASTORD",BLROPT(0)=$P(XQY0,U) ;IHS/OIRM TUC/AAB 2/13/97
- G LRORD
- ;
- IMMCOL ;EP - IMMEDIATE LAB COLLECTION
- D ENTRYAUD^BLRUTIL("IMMCOL^LRORD 0.0")
- 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"
- S:$G(BLROPT)=""!($G(BLROPT(0))'=$P(XQY0,U)) BLROPT="FASTORD",BLROPT(0)=$P(XQY0,U) ;IHS/OIRM TUC/AAB 2/13/97 -- IHS/OIT/MKK -- LR*5.2*1027 -- Restored line
- K LRODT G LRORD
- ;
- EN03 ; EP - WARD COLLECT ORDER ENTRY
- WARDCOL ; EP
- D ENTRYAUD^BLRUTIL("WARDCOL^LRORD 0.0")
- 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 ENTRYAUD^BLRUTIL("ENTER WARDCOL^LRORD","BLROPT") ; <<<<<<< DEBUG
- S:$G(BLROPT)=""!($G(BLROPT(0))'=$P(XQY0,U)) BLROPT="FASTORD",BLROPT(0)=$P(XQY0,U) ;IHS/OIRM TUC/AAB 2/13/97 -- IHS/OIT/MKK -- LR*5.2*1027 -- Restored line
- D LRORD
- D ENTRYAUD^BLRUTIL("WARDCOL^LRORD 9.0")
- Q
- ;
- LEDI ; EP - Laboratory Electronic Data Exchange
- D ENTRYAUD^BLRUTIL("LEDI^LRORD 0.0")
- ; 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
- ;
- ; 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
- D ENTRYAUD^BLRUTIL("LEDI^LRORD 9.0")
- Q
- ;
- ; LRORDRR =TYPE OF ORDER, LRECT =ASK COLECTION TIME
- ; LRFLOG =ACCESSION TEST GROUP, IF DEFINED ON ENTRY, PRESELECTS GROUP
- ;
- QUIZ ; EP
- D ENTRYAUD^BLRUTIL("QUIZ^LRORD 0.0")
- 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
- ;
- ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
- START(RESULT,BPCPARAM) ;EP
- D ENTRYAUD^BLRUTIL("START^LRORD 0.0")
- I $$VERSION^XPDUTL("LAB SERVICE")'="5.2" D Q
- . S RESULT(1)=-1
- . S RESULT(2)="LAB ORDERING NOT ALLOWED. Wrong LAB version or LAB not installed."
- ;
- S BLRGUI=1
- S DFN=$P(BPCPARAM,";",1)
- S BPCTL=$P(BPCPARAM,";",2)
- S LRORDR=$P(BPCPARAM,";",3) I LRORDR="" I '$D(^XUSEC("LRLAB",DUZ)) S RESULT(1)=-1,RESULT(2)="User not authorized for LAB ACCESSIONING." Q
- S BPCURG=$P(BPCPARAM,";",4) I '$D(^LAB(62.05,"B",BPCURG)) S RESULT(1)=-1,RESULT(2)="No URGENCY "_BPCURG_" defined in Lab file 62.05." Q
- S BPCURG=$O(^LAB(62.05,"B",BPCURG,0))
- S BPCODT=$P(BPCPARAM,";",6)
- S BPCCOM=$P(BPCPARAM,";",7) ; MJL I $L(BPCCOM)
- S BPCOORDS=$P(BPCPARAM,";",8) ; FHL 8/7/98 - OTHER ORDERS
- S BLRPRAC=$P(BPCPARAM,";",9) ; MJL - PROVIDER
- S LRFLOG=$P(BPCPARAM,";",10) ; MJL - PICKLIST
- S BPCACC=""
- D ^LRORDGUI ; Patient Chart version of LRORD
- D ENTRYAUD^BLRUTIL("START^LRORD 9.0")
- Q
- ; ----- END IHS/OIT/MKK - LR*5.2*1027
- LRORD ;VA/DALOI/CJS - LAZY ACCESSION LOGGING ; 22-Oct-2013 09:22 ; MKK
- +1 ;;5.2;LAB SERVICE;**1010,1011,1012,100,1013,1014,121,153,1015,286,1027,291,1030,1033**;NOV 01, 1997
- +2 ;
- +3 ; IHS Patch 1033:
- +4 ; (1) Restores IHS/DIR/MJL PATCH 1008 line that comments out line G0+12
- +5 ; (2) Repaced code in % subroutine so that it uses FileMan DIR call
- +6 ;
- +7 DO ENTRYAUD^BLRUTIL("^LRORD 0.0")
- +8 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
- +9 IF XQY0["LRFASTS"
- SET BLROPT="FASTORD"
- SET BLROPT(0)=$PIECE(XQY0,U)
- +10 ;IHS/ITSC/TPF 10/10/02 REQUESTED BY PATIENT CHART DEV. F.J.EVANS **1014**
- SET XWBWRAP=1
- +11 ;IHS/OIRM TUC/AAB 2/1/97
- IF $GET">GET(BLROPT)=""!($GET">GET(BLROPT(0))'=$PIECE(XQY0,U))
- SET BLROPT="MULTI"
- SET BLROPT(0)=$PIECE(XQY0,U)
- +12 ; ----- END IHS/OIT/MKK - LR*5.2*1027
- +13 ;
- EN ;; EP
- +1 DO ENTRYAUD^BLRUTIL("EN^LRORD 0.0")
- +2 ; 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"
- +3 ; 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
- +4 ;-----BEGIN IHS MODIFICATION LR*5.2*1018
- +5 IF $DATA(^LAB(69.9,1,"RO"))
- IF +$HOROLOG'=+^("RO")
- Begin DoDot:1
- +6 IF $GET(BLRGUI)
- SET RESULT(1)=-1
- SET RESULT(2)="ROLLOVER HAS NOT RUN. CHECK WITH SITE MANAGER"
- QUIT
- +7 ;
- +8 ; W $C(7),!,"ROLLOVER ",$S($P(^("RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")
- +9 WRITE $CHAR(7),!,"ROLLOVER ",$SELECT($PIECE(^LAB(69.9,1,"RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")
- +10 WRITE " ACCESSIONING SHOULDN'T BE DONE NOW.",$CHAR(7),!
- +11 WRITE " Are you sure you want to continue"
- +12 SET %=1
- 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
- QUIT
- IF %'=1
- WRITE !,"OK, try later."
- End DoDot:1
- IF $GET(BLRGUI)
- QUIT
- IF %=0
- GOTO LRORD
- IF %'=1
- QUIT
- +13 ;----- END IHS MODIFICATION
- +14 ;
- EN1 ;;EP - from LROR4
- +1 DO ENTRYAUD^BLRUTIL("EN1^LRORD 0.0")
- +2 DO ^LRPARAM
- +3 KILL ^TMP("LRSTIK",$JOB),DIC,LRURG,LRSAME,LRCOM,LRNATURE,LRTCOM
- +4 SET LRORDTIM=""
- IF '$DATA(LRORDR)
- SET LRORDR=""
- DO DT^LRX
- +5 IF $DATA(LRADDTST)
- IF LRADDTST=""
- QUIT
- +6 SET LRFIRST=1
- SET LRODT=DT
- SET U="^"
- SET LRECT=0
- SET LROUTINE=$PIECE(^LAB(69.9,1,3),U,2)
- +7 IF $GET(LRORDRR)="R"
- SET LRECT=1
- SET LRFIRST=0
- +8 ; I '$G(LRECT),LRORDR="" W !!,"WANT TO ENTER COLLECTION TIMES? Y//" D % S LRECT='(%["N") G KILL:$E(%)="^"
- +9 ; IHS/MSC/MKK - LR*5.2*1033
- IF '$GET(LRECT)
- IF LRORDR=""
- DO %("WANT TO ENTER COLLECTION TIMES","YES")
- SET LRECT='(%["N")
- IF $EXTRACT(%)="^"
- GOTO KILL
- +10 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
- +11 IF LRORDR="SP"
- WRITE !!," Ordering for SEND PATIENT ONLY",$CHAR(7),!
- SET LRLWC="SP"
- +12 IF LRORDR="WC"
- WRITE !!,"Ordering for WARD COLLECT & DELIVER ONLY",$CHAR(7),!
- SET LRLWC="WC"
- +13 IF LRORDR="I"
- DO ^LRORDIM
- IF '$DATA(LRCDT)
- GOTO KILL
- +14 ;
- L5 ; EP
- +1 DO ENTRYAUD^BLRUTIL("L5^LRORD 0.0")
- +2 IF LRORDR]""
- IF LRORDR'="LC"
- IF LRORDR'="I"
- SET %DT="AET"
- SET %DT("A")=$SELECT(LRORDR="WC":"COLLECTION",LRORDR="SP":"PATIENT VISIT",1:"")_" DATE: "
- +3 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
- +4 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
- +5 IF $DATA(LRODT)
- IF $PIECE(LRODT,".")<DT
- WRITE !,$CHAR(7),"Cannot order in the Past.",!
- GOTO L5
- +6 IF $DATA(LRFLOG)
- SET Y=LRFLOG
- IF LRFLOG>0
- GOTO G0
- +7 SET DIC="^LAB(62.6,"
- SET DIC(0)="AEQMZ"
- +8 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)")
- +9 DO ^DIC
- KILL DIC
- IF $DATA(DUOUT)!$DATA(DTOUT)
- GOTO KILL
- IF Y<1
- GOTO G1
- SET LRFLOG=Y
- +10 ;
- G0 ; EP
- +1 DO ENTRYAUD^BLRUTIL("G0^LRORD 0.0")
- +2 SET $PIECE(LRFLOG,U,3)=$PIECE(^LAB(62.2,+$PIECE(^LAB(62.6,+LRFLOG,0),U,2),0),U,2)
- +3 SET LRFLOG(0)=^LAB(62.6,+LRFLOG,0)
- +4 SET (LRWP,I)=0
- +5 FOR
- SET I=$ORDER(^LAB(62.6,+Y,1,I))
- IF I<1
- QUIT
- Begin DoDot:1
- +6 SET Y(0)=$GET(^LAB(62.6,+Y,1,I,0))
- SET LRWP=LRWP+1
- +7 SET ^TMP("LRSTIK",$JOB,$SELECT($PIECE(LRFLOG(0),"^",5):I,1:LRWP))=Y(0)
- +8 ; Lookup by number user enters.
- +9 SET ^TMP("LRSTIK",$JOB,"B",LRWP)=$SELECT($PIECE(LRFLOG(0),"^",5):I,1:LRWP)
- +10 ; Lookup by test - used by LEDI (LRORDB) when user creates list "on-the-fly"
- +11 SET ^TMP("LRSTIK",$JOB,"C",+Y(0),$SELECT($PIECE(LRFLOG(0),"^",5):I,1:LRWP))=""
- End DoDot:1
- +12 ;
- +13 ; Following commented out for IHS. Originally done for LR*5.2*1008. Comment accidently left off
- +14 ; in LR*5.2*1030, but restored with LR*5.2*1033
- +15 ; I LRWP>40 S LRFIRST=0 ; Don't automatically display "long" test lists. ; IHS/DIR/MJL PATCH 1008
- +16 GOTO G5
- +17 ;
- G1 ; EP
- +1 SET LRWP=0
- WRITE !,"Select one or more tests from which you will be generating your entries."
- +2 ;
- GET ; EP
- +1 DO ENTRYAUD^BLRUTIL("GET^LRORD 0.0")
- +2 DO Q15^LRORD2
- +3 DO ^DIC
- KILL DIC("S")
- IF Y<1
- GOTO G5
- +4 SET LRWP=LRWP+1
- SET LRY=Y
- +5 SET ^TMP("LRSTIK",$JOB,LRWP)=$PIECE(LRY,U,1,2)
- +6 ; "B" Used to lookup by number user enters.
- +7 SET ^TMP("LRSTIK",$JOB,"B",LRWP)=LRWP
- +8 ; "C" Used by LEDI (LRORDB)
- +9 SET ^TMP("LRSTIK",$JOB,"C",+LRY,LRWP)=""
- +10 SET LRTSTS=+^TMP("LRSTIK",$JOB,LRWP)
- DO GS^LRORD3
- +11 IF +LRSAMP=-1&(LRSPEC=-1)
- SET LRWP=LRWP-1
- +12 IF +LRSAMP=-1&(LRSPEC=-1)
- GOTO GET
- +13 SET ^TMP("LRSTIK",$JOB,LRWP)=^TMP("LRSTIK",$JOB,LRWP)_U_LRSAMP_U_U_LRSPEC
- +14 DO ENTRYAUD^BLRUTIL("GET^LRORD 9.0")
- +15 GOTO GET
- +16 ;
- G5 ; EP
- +1 DO ENTRYAUD^BLRUTIL("G5^LRORD 0.0")
- +2 IF LRWP<1
- GOTO KILL
- +3 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)=""
- +4 SET LRURG=""
- SET LRAD=DT
- SET LRWPD=LRWP\2+(LRWP#2)
- DO ^LRORD1
- +5 ;
- KILL ; EP
- +1 DO ^LRORDK
- DO HOME^%ZIS
- QUIT
- +2 ;
- +3 ; % ; EP
- +4 ; R %:DTIME Q:%=""!(%["N")!(%["Y")!($E(%)="^") W !,"Answer 'Y' or 'N': " G %
- +5 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
- %(MSG,DEF) ; EP
- +1 KILL DIR,X,Y,%
- +2 SET DIR(0)="YO"
- +3 IF $LENGTH($GET(MSG))
- SET DIR("A")=MSG
- +4 IF $LENGTH($GET(DEF))
- SET DIR("B")=DEF
- +5 DO ^DIR
- +6 SET %=$EXTRACT(X)
- +7 QUIT
- +8 ; ----- END IHS/MSC/MKK - LR*5.2*1033
- +9 ;
- EN01 ;EP - LAB COLLECT ORDER ENTRY
- +1 DO ENTRYAUD^BLRUTIL("EN01^LRORD 0.0")
- +2 ;
- ORDER ; EP
- +1 DO ENTRYAUD^BLRUTIL("ORDER^LRORD 0.0")
- +2 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
- +3 SET LRORDR="LC"
- SET LRLWCURG=$SELECT($PIECE(^LAB(69.9,1,3),U,2)'="":$PIECE(^(3),U,2),1:9)
- +4 ;IHS/OIRM TUC/AAB 2/13/97
- IF $GET">GET(BLROPT)=""!($GET">GET(BLROPT(0))'=$PIECE(XQY0,U))
- SET BLROPT="FASTORD"
- SET BLROPT(0)=$PIECE(XQY0,U)
- +5 GOTO LRORD
- +6 ;
- EN02 ; EP SEND PATIENT ORDER ENTRY
- SENDPAT ; EP - S %=2 W !,"Do you want copies of the orders" D YN^DICN Q:%=-1 S:%=1 LRSLIP="" I %=0 D QUIZ G SENDPAT
- +1 DO ENTRYAUD^BLRUTIL("SENDPAT^LRORD 0.0")
- +2 ; IHS/OIT/MKK -- LR*5.2*1027 -- Restored line
- 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
- +3 SET LRORDR="SP"
- +4 ;IHS/OIRM TUC/AAB 2/13/97
- IF $GET">GET(BLROPT)=""!($GET">GET(BLROPT(0))'=$PIECE(XQY0,U))
- SET BLROPT="FASTORD"
- SET BLROPT(0)=$PIECE(XQY0,U)
- +5 GOTO LRORD
- +6 ;
- IMMCOL ;EP - IMMEDIATE LAB COLLECTION
- +1 DO ENTRYAUD^BLRUTIL("IMMCOL^LRORD 0.0")
- +2 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
- +3 SET LRORDR="I"
- +4 ;IHS/OIRM TUC/AAB 2/13/97 -- IHS/OIT/MKK -- LR*5.2*1027 -- Restored line
- IF $GET">GET(BLROPT)=""!($GET">GET(BLROPT(0))'=$PIECE(XQY0,U))
- SET BLROPT="FASTORD"
- SET BLROPT(0)=$PIECE(XQY0,U)
- +5 KILL LRODT
- GOTO LRORD
- +6 ;
- EN03 ; EP - WARD COLLECT ORDER ENTRY
- WARDCOL ; EP
- +1 DO ENTRYAUD^BLRUTIL("WARDCOL^LRORD 0.0")
- +2 SET %=2
- +3 WRITE !,"Do you want copies of the orders"
- DO YN^DICN
- IF %=-1
- QUIT
- IF %=1
- SET LRSLIP=""
- IF %=0
- DO QUIZ
- GOTO WARDCOL
- +4 SET LRORDR="WC"
- +5 ; <<<<<<< DEBUG
- DO ENTRYAUD^BLRUTIL("ENTER WARDCOL^LRORD","BLROPT")
- +6 ;IHS/OIRM TUC/AAB 2/13/97 -- IHS/OIT/MKK -- LR*5.2*1027 -- Restored line
- IF $GET">GET(BLROPT)=""!($GET">GET(BLROPT(0))'=$PIECE(XQY0,U))
- SET BLROPT="FASTORD"
- SET BLROPT(0)=$PIECE(XQY0,U)
- +7 DO LRORD
- +8 DO ENTRYAUD^BLRUTIL("WARDCOL^LRORD 9.0")
- +9 QUIT
- +10 ;
- LEDI ; EP - Laboratory Electronic Data Exchange
- +1 DO ENTRYAUD^BLRUTIL("LEDI^LRORD 0.0")
- +2 ; This entry point is used to select patients from ^LRT(67, file
- +3 ; Routine LRDPAREF controls patient selection, patients must already
- +4 ; exist in ^DPT in order to be selected.
- +5 DO ^LRPARAM
- +6 IF $GET(LREND)
- DO ^LRORDK
- QUIT
- +7 NEW CONTROL,LA7,LA7SCFG,LA7X,LA7Y,LR64,LR696,LRLABLIO,LRRSTAT,LRRSITE,LRSD,LRTSN
- +8 SET LRREFBAR=$$BAR^LA7SBCR
- +9 IF LRREFBAR<0
- DO ^LRORDK
- QUIT
- +10 SET LRRSTAT="I"
- +11 SET LRRSTAT(0)=$$FIND1^DIC(64.061,"","OMX","Specimen in process","","I $P(^LAB(64.061,Y,0),U,7)=""U""")
- +12 DO SITE^LA7SBCR2(.LRRSITE,"Scan Remote Site Barcode (SM)",LRREFBAR)
- +13 IF LRRSITE("ERROR")
- Begin DoDot:1
- +14 WRITE !!,$CHAR(7),"ERROR -- ",$PIECE(LRRSITE("ERROR"),"^",2),!
- +15 DO ^LRORDK
- End DoDot:1
- QUIT
- +16 ;
- +17 ; Get shipping manifest ID manual input
- +18 IF $GET(LRRSITE("SMID"))=""
- Begin DoDot:1
- +19 FOR
- DO SMID^LRORDB
- IF LREND!($GET(LRRSITE("SMID"))'="")
- QUIT
- End DoDot:1
- +20 IF $GET(LREND)
- DO ^LRORDK
- QUIT
- +21 ;
- +22 ; LRORDRR="R" variable indicates host accessioning of remote orders
- +23 SET LRORDRR="R"
- SET LRORDR=""
- KILL LRODT
- +24 DO LRORD
- DO ^LRORDK
- +25 DO ENTRYAUD^BLRUTIL("LEDI^LRORD 9.0")
- +26 QUIT
- +27 ;
- +28 ; LRORDRR =TYPE OF ORDER, LRECT =ASK COLECTION TIME
- +29 ; LRFLOG =ACCESSION TEST GROUP, IF DEFINED ON ENTRY, PRESELECTS GROUP
- +30 ;
- QUIZ ; EP
- +1 DO ENTRYAUD^BLRUTIL("QUIZ^LRORD 0.0")
- +2 WRITE !,"The order copy is automatically sent to the CLOSEST PRINTER,"
- +3 WRITE !,"if a closest printer is defined for the device you are using."
- +4 WRITE !,"Otherwise, you will be prompted with ORDER COPY DEVICE.",!
- +5 QUIT
- +6 ;
- +7 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
- START(RESULT,BPCPARAM) ;EP
- +1 DO ENTRYAUD^BLRUTIL("START^LRORD 0.0")
- +2 IF $$VERSION^XPDUTL("LAB SERVICE")'="5.2"
- Begin DoDot:1
- +3 SET RESULT(1)=-1
- +4 SET RESULT(2)="LAB ORDERING NOT ALLOWED. Wrong LAB version or LAB not installed."
- End DoDot:1
- QUIT
- +5 ;
- +6 SET BLRGUI=1
- +7 SET DFN=$PIECE(BPCPARAM,";",1)
- +8 SET BPCTL=$PIECE(BPCPARAM,";",2)
- +9 SET LRORDR=$PIECE(BPCPARAM,";",3)
- IF LRORDR=""
- IF '$DATA(^XUSEC("LRLAB",DUZ))
- SET RESULT(1)=-1
- SET RESULT(2)="User not authorized for LAB ACCESSIONING."
- QUIT
- +10 SET BPCURG=$PIECE(BPCPARAM,";",4)
- IF '$DATA(^LAB(62.05,"B",BPCURG))
- SET RESULT(1)=-1
- SET RESULT(2)="No URGENCY "_BPCURG_" defined in Lab file 62.05."
- QUIT
- +11 SET BPCURG=$ORDER(^LAB(62.05,"B",BPCURG,0))
- +12 SET BPCODT=$PIECE(BPCPARAM,";",6)
- +13 ; MJL I $L(BPCCOM)
- SET BPCCOM=$PIECE(BPCPARAM,";",7)
- +14 ; FHL 8/7/98 - OTHER ORDERS
- SET BPCOORDS=$PIECE(BPCPARAM,";",8)
- +15 ; MJL - PROVIDER
- SET BLRPRAC=$PIECE(BPCPARAM,";",9)
- +16 ; MJL - PICKLIST
- SET LRFLOG=$PIECE(BPCPARAM,";",10)
- +17 SET BPCACC=""
- +18 ; Patient Chart version of LRORD
- DO ^LRORDGUI
- +19 DO ENTRYAUD^BLRUTIL("START^LRORD 9.0")
- +20 QUIT
- +21 ; ----- END IHS/OIT/MKK - LR*5.2*1027
