LRORDB ;DALOI/STAFF - ORDER LEDI TEST USING BARCODE FROM 69.6 ;06/22/11 12:38
;;5.2;LAB SERVICE;**153,222,286,350**;Sep 27, 1994;Build 230
;
EN(LRRUID,LRSSMP) ;
;
N I,LRDIR,LRSTATUS,LRX,X
;
K LROT
;
S (LROT,LRSTATUS)=""
;
Q:($G(LRRUID)="")!($G(LRSSMP)="")
S LR696=$O(^LRO(69.6,"AD",LRSSMP,LRRUID,0)) Q:'LR696
Q:'($D(^LRO(69.6,LR696,0))#2)
;
S LRDIR("A",2)=" "
S LRDIR("A",2.001)="Collecting Site UID: "_LRRUID
;S LRDIR("A",2.002)="Current Tests on Order:"
S LRDIR("A",2.003)="Collecting Site Test Host UID Host Site Test"
S LRDIR("A",2.004)="-------------------- -------- --------------"
S I=0
F S I=$O(^LRO(69.6,LR696,2,I)) Q:'I D
. S I(0)=$G(^LRO(69.6,LR696,2,I,0))
. S X=$P(I(0),"^",3)
. I X="" S X=$P(I(0),"^",1) ; If no remote test name then display NLT Test field value.
. S LRDIR("A","2."_I)=$$LJ^XLFSTR($E(X,1,30),31)_$$LJ^XLFSTR($P(I(0),"^",9),15)_" "_$E($P($G(^LAB(60,+$P(I(0),"^",11),0)),"^"),1,30)
K I
;
S LRX=+$P(^LRO(69.6,LR696,0),U,10)
I LRX S LRSTATUS=$$GET1^DIQ(64.061,LRX_",",.01)
I LRSTATUS'="",LRSTATUS'="In-Transit" D
. S I=0
. F S I=$O(^LRO(69.6,LR696,2,I)) Q:'I D Q:LRSTATUS="In-Transit"
. . S X=$P(^LRO(69.6,LR696,2,I,0),"^",6) Q:'X
. . I $$GET1^DIQ(64.061,X_",",.01)="In-Transit" S LRSTATUS="In-Transit"
;
I LRSTATUS'="",LRSTATUS'="In-Transit" D Q
. S LRDIR("A",1)="This order has a status of ["_LRSTATUS_"]"
. S LRDIR("A",1.1)="No test selected."
. D DISPLO(.LRDIR)
;
; Display any comments that accompanied order
I $D(^LRO(69.6,LR696,99)) D
. N LRWP
. S LRWP=$$GET1^DIQ(69.6,LR696_",",99,"","LRWP")
. S LRWP(.5)="Collecting site order comments:",LRWP(.5,"F")="!!"
. D EN^DDIOL(.LRWP)
;
D LROT(LR696)
;
;I $O(LROT(0)) D LL3^LROW3
I '$O(LROT(0)) D Q
. S LRDIR("A",2)="NO tests found on Shipping Manifest "_$G(LRRSITE("SMID"))
. S LRDIR("A",2.1)="For UID "_$G(LRRUID)
. D DISPLO(.LRDIR)
;
S $P(^LRO(69.6,LR696,0),U,11)=$G(LRSD("RIEN"))
Q
;
;
LROT(LR696) ;
;
N LR60,LR6205,LR6964,LRATG,LRMICHK,LRNLT,LRX,LRY,X
;
K LROT
;
S LR696(0)=$G(^LRO(69.6,LR696,0))
S LRSPEC=+$P(LR696(0),U,7),LRSAMP=+$P(LR696(0),U,8)
;Q:'LRSPEC!('$D(^LAB(61,LRSPEC,0)))
S (LR6964,LRMICHK)=0
F S LR6964=+$O(^LRO(69.6,LR696,2,LR6964)) Q:LR6964<1 D
. S LR6964(0)=$G(^LRO(69.6,LR696,2,LR6964,0))
. I LR6964(0)="" Q
. I $P(LR6964(0),"^",6),$$GET1^DIQ(64.061,$P(LR6964(0),"^",6)_",",.01)'="In-Transit" Q
. S LR60=$P(LR6964(0),U,11) ; Lab test to order
. S LR6205=$P(LR6964(0),U,12) ; Urgency
. I 'LRMICHK,LR60>0,"MISPCYEM"[$P(^LAB(60,LR60,0),U,4) D MICHECK
. S LRATG=0
. ; If have everything, then don't check accession test group.
. I LR60,LRSPEC,LRSAMP,LR6205 D Q:LRATG
. . S LR64=+$G(^LAB(60,LR60,64))
. . I 'LR64 Q
. . S LRNLT=$P($G(^LAM(LR64,0)),U,2),LRNLT(2)=$P($G(^LAM(LR64,0)),U)
. . ; Find available spot.
. . F LRATG=LRWPC+1:1 I '$D(LROT(LRSAMP,LRSPEC,LRATG)) S LRWPC=LRATG Q
. . D CHKURG,SETLROT
. S LRNLT=$P(LR6964(0),U,2) Q:'LRNLT
. S LRNLT(1)=+$O(^LAM("C",LRNLT_" ",0))
. I 'LRNLT(1)!('$D(^LAM(LRNLT(1),0))) Q
. S LRNLT(2)=$P(^LAM(LRNLT(1),0),U),LR60=0
. F S LR60=+$O(^LAB(60,"AC",LRNLT(1),LR60)) Q:'LR60 D
. . S LRATG=+$O(^TMP("LRSTIK",$J,"C",LR60,0)) Q:LRATG<1
. . S LRATG(1)=$G(^TMP("LRSTIK",$J,LRATG)) Q:'LRATG(1)!('$P(LRATG(1),U,3))
. . S:'$G(LRSAMP) LRSAMP=$P(LRATG(1),U,3)
. . D CHKURG
. . I LR60,LRSPEC,LRSAMP,LR6205 D SETLROT
Q
;
;
SETLROT ; Setup LROT array
;
S LROT(LRSAMP,LRSPEC,LRATG)=LR60
S LROT(LRSAMP,LRSPEC,LRATG,1)=LR6205
S LROT(LRSAMP,LRSPEC,LRATG,"B",LR60)=LR6964_U_LRNLT_U_LRNLT(2)
;
; Required comment
S:$P($G(^LAB(60,LR60,0)),U,19) LROT(LRSAMP,LRSPEC,LRATG,2)=$P(^(0),U,19)
;
Q
;
;
CHKURG ; Check for forced, highest allowed and missing urgency on this test
;
N X
;
; Forced urgency
I +$P(^LAB(60,LR60,0),U,18) S LR6205=+$P(^LAB(60,LR60,0),U,18)
;
; If missing urgency then look above workload urgencies for last urgency
; that matches on HL7 urgency otherwise use site's default for routine.
I 'LR6205 D
. S X=$P(LR6964(0),U,5)
. I X'="" S LR6205=+$O(^LAB(62.05,"HL7",X,50),-1)
. S LR6205=$S(LR6205>0:LR6205,1:LROUTINE)
;
; Highest urgency allowed, reset if higher than highest allowed.
S X=+$P(^LAB(60,LR60,0),U,16)
I LR6205<X S LR6205=X
;
Q
;
;
MICHECK ; Check "MI" subscript test for missing topography and collection sample
;
N DA,DIE,DR,X,Y
S DA=LR696,DIE=69.6,DR="",LRMICHK=1
I LRSPEC'>0 S DR=4_";"
I LRSAMP'>0 S DR=DR_5
I LRSPEC D
. I $P(^LAB(60,LR60,0),U,4)'="MI" Q
. S LRX=$$GET1^DIQ(61,LRSPEC_",",".09:2")
. I LRX="XXX"!(LRX="ORH") S DR="4;5"
I DR="" Q
D EN^DDIOL("Update missing order information for:",,"!!")
D EN^DDIOL("",,"!")
D ^DIE
S LR696(0)=$G(^LRO(69.6,LR696,0))
S LRSPEC=+$P(LR696(0),U,7),LRSAMP=+$P(LR696(0),U,8)
;
Q
;
;
SMID ; Call to get shipping manifest ID (manual selection)
N CNT,DA,DIR,LRSMID,LRY,X,Y
S LREND=0,LRSMID=""
S DIR(0)="69.6,18" D ^DIR
I $D(DTOUT)!($D(DUOUT)) S LREND=1 Q
I $D(DIRUT) Q
S LRY=Y
I LRY'="",$D(^LRO(69.6,"D",LRY)) D
. N LR696
. S LR696=$O(^LRO(69.6,"D",LRY,0))
. I $P($G(^LRO(69.6,+LR696,0)),"^",5)=+$G(LRRSITE("RSITE")) S LRSMID=LRY
I LRSMID="" D
. D SHOW
. K ^TMP("LR",$J,"SMID")
;
I LRSMID="" D Q
. N DIR
. S DIR(0)="YO",DIR("A")="Use manifest '"_LRY_"' anyway",DIR("B")="NO"
. W ! D ^DIR
. I Y S LRRSITE("SMID")=LRY
;
S LRRSITE("SMID")=LRSMID
S LRY=$O(^LRO(69.6,"D",LRSMID,0))
I LRY S LRRSITE("SDT")=$$GET1^DIQ(69.6,LRY_",",14,"I")
K DIR
;
; Flag to determine if this shipping manifest should be used to
; look up orders when manually accessioning.
S DIR(0)="YO",DIR("A")="Lookup orders using this manifest",DIR("B")="YES"
D ^DIR
I $D(DIRUT) S LREND=1 Q
S LRRSITE("SMID-OK")=Y
Q
;
;
SHOW ; Gather a list of possible SMID to select from
N CNT,DIR,IEN,LEN,SMID,VAL
K ^TMP("LR",$J,"SMID")
S SMID=LRY,LEN=$L(LRY),CNT=0
I SMID?1.N S SMID=SMID_" "
F S SMID=$O(^LRO(69.6,"D",SMID)) Q:$E(SMID,1,LEN)'=LRY D
. S IEN=+$O(^LRO(69.6,"D",SMID,0))
. I $P($G(^LRO(69.6,IEN,0)),"^",5)'=+$G(LRRSITE("RSITE")) Q
. S CNT=CNT+1
. S ^TMP("LR",$J,"SMID",CNT)=SMID
I 'CNT W !,"No manifest '",LRY,"' found on file." Q
I CNT=1 S LRSMID=^TMP("LR",$J,"SMID",CNT) Q
;
; Select SMID from List
D DISPL
S DIR(0)="NO^1:"_CNT,DIR("A")="Select Manifest Number"
D ^DIR
I $D(DIRUT) W !,"No manifest selected." Q
S LRSMID=$G(^TMP("LR",$J,"SMID",Y))
Q
;
;
DISPL ;
N CNT,DIR,DIRUT
W @IOF
S CNT=0
F S CNT=$O(^TMP("LR",$J,"SMID",CNT)) Q:'CNT D Q:$D(DIRUT)
. I CNT#3=1 D Q:$D(DIRUT)
. . I '(CNT#(IOSL-3)) S DIR(0)="E" D ^DIR Q:$D(DIRUT)
. . W !
. W $$LJ^XLFSTR(CNT_". "_^TMP("LR",$J,"SMID",CNT),26)
Q
;
;
DISPLO(LRDIR) ; Display the order from #69.6
; Call with LRDIR = array of additonal prompts to display, pass by reference
;
N DA,DIC,DIR,DIRUT,DTOUT,DUOUT,DX,S,X,Y
;
M DIR=LRDIR
S DIR("A")="Would you like a display of the Order",DIR("B")="NO"
S DIR(0)="Y" D ^DIR K DIR
I $D(DIRUT)!(Y'=1) W ! Q
S DA=LR696,DIC="^LRO(69.6,",S=0 W @IOF D EN^DIQ W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRORDB 7203 printed Apr 09, 2024@21:22 Page 2
LRORDB ;DALOI/STAFF - ORDER LEDI TEST USING BARCODE FROM 69.6 ;06/22/11 12:38
+1 ;;5.2;LAB SERVICE;**153,222,286,350**;Sep 27, 1994;Build 230
+2 ;
EN(LRRUID,LRSSMP) ;
+1 ;
+2 NEW I,LRDIR,LRSTATUS,LRX,X
+3 ;
+4 KILL LROT
+5 ;
+6 SET (LROT,LRSTATUS)=""
+7 ;
+8 if ($GET(LRRUID)="")!($GET(LRSSMP)="")
QUIT
+9 SET LR696=$ORDER(^LRO(69.6,"AD",LRSSMP,LRRUID,0))
if 'LR696
QUIT
+10 if '($DATA(^LRO(69.6,LR696,0))#2)
QUIT
+11 ;
+12 SET LRDIR("A",2)=" "
+13 SET LRDIR("A",2.001)="Collecting Site UID: "_LRRUID
+14 ;S LRDIR("A",2.002)="Current Tests on Order:"
+15 SET LRDIR("A",2.003)="Collecting Site Test Host UID Host Site Test"
+16 SET LRDIR("A",2.004)="-------------------- -------- --------------"
+17 SET I=0
+18 FOR
SET I=$ORDER(^LRO(69.6,LR696,2,I))
if 'I
QUIT
Begin DoDot:1
+19 SET I(0)=$GET(^LRO(69.6,LR696,2,I,0))
+20 SET X=$PIECE(I(0),"^",3)
+21 ; If no remote test name then display NLT Test field value.
IF X=""
SET X=$PIECE(I(0),"^",1)
+22 SET LRDIR("A","2."_I)=$$LJ^XLFSTR($EXTRACT(X,1,30),31)_$$LJ^XLFSTR($PIECE(I(0),"^",9),15)_" "_$EXTRACT($PIECE($GET(^LAB(60,+$PIECE(I(0),"^",11),0)),"^"),1,30)
End DoDot:1
+23 KILL I
+24 ;
+25 SET LRX=+$PIECE(^LRO(69.6,LR696,0),U,10)
+26 IF LRX
SET LRSTATUS=$$GET1^DIQ(64.061,LRX_",",.01)
+27 IF LRSTATUS'=""
IF LRSTATUS'="In-Transit"
Begin DoDot:1
+28 SET I=0
+29 FOR
SET I=$ORDER(^LRO(69.6,LR696,2,I))
if 'I
QUIT
Begin DoDot:2
+30 SET X=$PIECE(^LRO(69.6,LR696,2,I,0),"^",6)
if 'X
QUIT
+31 IF $$GET1^DIQ(64.061,X_",",.01)="In-Transit"
SET LRSTATUS="In-Transit"
End DoDot:2
if LRSTATUS="In-Transit"
QUIT
End DoDot:1
+32 ;
+33 IF LRSTATUS'=""
IF LRSTATUS'="In-Transit"
Begin DoDot:1
+34 SET LRDIR("A",1)="This order has a status of ["_LRSTATUS_"]"
+35 SET LRDIR("A",1.1)="No test selected."
+36 DO DISPLO(.LRDIR)
End DoDot:1
QUIT
+37 ;
+38 ; Display any comments that accompanied order
+39 IF $DATA(^LRO(69.6,LR696,99))
Begin DoDot:1
+40 NEW LRWP
+41 SET LRWP=$$GET1^DIQ(69.6,LR696_",",99,"","LRWP")
+42 SET LRWP(.5)="Collecting site order comments:"
SET LRWP(.5,"F")="!!"
+43 DO EN^DDIOL(.LRWP)
End DoDot:1
+44 ;
+45 DO LROT(LR696)
+46 ;
+47 ;I $O(LROT(0)) D LL3^LROW3
+48 IF '$ORDER(LROT(0))
Begin DoDot:1
+49 SET LRDIR("A",2)="NO tests found on Shipping Manifest "_$GET(LRRSITE("SMID"))
+50 SET LRDIR("A",2.1)="For UID "_$GET(LRRUID)
+51 DO DISPLO(.LRDIR)
End DoDot:1
QUIT
+52 ;
+53 SET $PIECE(^LRO(69.6,LR696,0),U,11)=$GET(LRSD("RIEN"))
+54 QUIT
+55 ;
+56 ;
LROT(LR696) ;
+1 ;
+2 NEW LR60,LR6205,LR6964,LRATG,LRMICHK,LRNLT,LRX,LRY,X
+3 ;
+4 KILL LROT
+5 ;
+6 SET LR696(0)=$GET(^LRO(69.6,LR696,0))
+7 SET LRSPEC=+$PIECE(LR696(0),U,7)
SET LRSAMP=+$PIECE(LR696(0),U,8)
+8 ;Q:'LRSPEC!('$D(^LAB(61,LRSPEC,0)))
+9 SET (LR6964,LRMICHK)=0
+10 FOR
SET LR6964=+$ORDER(^LRO(69.6,LR696,2,LR6964))
if LR6964<1
QUIT
Begin DoDot:1
+11 SET LR6964(0)=$GET(^LRO(69.6,LR696,2,LR6964,0))
+12 IF LR6964(0)=""
QUIT
+13 IF $PIECE(LR6964(0),"^",6)
IF $$GET1^DIQ(64.061,$PIECE(LR6964(0),"^",6)_",",.01)'="In-Transit"
QUIT
+14 ; Lab test to order
SET LR60=$PIECE(LR6964(0),U,11)
+15 ; Urgency
SET LR6205=$PIECE(LR6964(0),U,12)
+16 IF 'LRMICHK
IF LR60>0
IF "MISPCYEM"[$PIECE(^LAB(60,LR60,0),U,4)
DO MICHECK
+17 SET LRATG=0
+18 ; If have everything, then don't check accession test group.
+19 IF LR60
IF LRSPEC
IF LRSAMP
IF LR6205
Begin DoDot:2
+20 SET LR64=+$GET(^LAB(60,LR60,64))
+21 IF 'LR64
QUIT
+22 SET LRNLT=$PIECE($GET(^LAM(LR64,0)),U,2)
SET LRNLT(2)=$PIECE($GET(^LAM(LR64,0)),U)
+23 ; Find available spot.
+24 FOR LRATG=LRWPC+1:1
IF '$DATA(LROT(LRSAMP,LRSPEC,LRATG))
SET LRWPC=LRATG
QUIT
+25 DO CHKURG
DO SETLROT
End DoDot:2
if LRATG
QUIT
+26 SET LRNLT=$PIECE(LR6964(0),U,2)
if 'LRNLT
QUIT
+27 SET LRNLT(1)=+$ORDER(^LAM("C",LRNLT_" ",0))
+28 IF 'LRNLT(1)!('$DATA(^LAM(LRNLT(1),0)))
QUIT
+29 SET LRNLT(2)=$PIECE(^LAM(LRNLT(1),0),U)
SET LR60=0
+30 FOR
SET LR60=+$ORDER(^LAB(60,"AC",LRNLT(1),LR60))
if 'LR60
QUIT
Begin DoDot:2
+31 SET LRATG=+$ORDER(^TMP("LRSTIK",$JOB,"C",LR60,0))
if LRATG<1
QUIT
+32 SET LRATG(1)=$GET(^TMP("LRSTIK",$JOB,LRATG))
if 'LRATG(1)!('$PIECE(LRATG(1),U,3))
QUIT
+33 if '$GET(LRSAMP)
SET LRSAMP=$PIECE(LRATG(1),U,3)
+34 DO CHKURG
+35 IF LR60
IF LRSPEC
IF LRSAMP
IF LR6205
DO SETLROT
End DoDot:2
End DoDot:1
+36 QUIT
+37 ;
+38 ;
SETLROT ; Setup LROT array
+1 ;
+2 SET LROT(LRSAMP,LRSPEC,LRATG)=LR60
+3 SET LROT(LRSAMP,LRSPEC,LRATG,1)=LR6205
+4 SET LROT(LRSAMP,LRSPEC,LRATG,"B",LR60)=LR6964_U_LRNLT_U_LRNLT(2)
+5 ;
+6 ; Required comment
+7 if $PIECE($GET(^LAB(60,LR60,0)),U,19)
SET LROT(LRSAMP,LRSPEC,LRATG,2)=$PIECE(^(0),U,19)
+8 ;
+9 QUIT
+10 ;
+11 ;
CHKURG ; Check for forced, highest allowed and missing urgency on this test
+1 ;
+2 NEW X
+3 ;
+4 ; Forced urgency
+5 IF +$PIECE(^LAB(60,LR60,0),U,18)
SET LR6205=+$PIECE(^LAB(60,LR60,0),U,18)
+6 ;
+7 ; If missing urgency then look above workload urgencies for last urgency
+8 ; that matches on HL7 urgency otherwise use site's default for routine.
+9 IF 'LR6205
Begin DoDot:1
+10 SET X=$PIECE(LR6964(0),U,5)
+11 IF X'=""
SET LR6205=+$ORDER(^LAB(62.05,"HL7",X,50),-1)
+12 SET LR6205=$SELECT(LR6205>0:LR6205,1:LROUTINE)
End DoDot:1
+13 ;
+14 ; Highest urgency allowed, reset if higher than highest allowed.
+15 SET X=+$PIECE(^LAB(60,LR60,0),U,16)
+16 IF LR6205<X
SET LR6205=X
+17 ;
+18 QUIT
+19 ;
+20 ;
MICHECK ; Check "MI" subscript test for missing topography and collection sample
+1 ;
+2 NEW DA,DIE,DR,X,Y
+3 SET DA=LR696
SET DIE=69.6
SET DR=""
SET LRMICHK=1
+4 IF LRSPEC'>0
SET DR=4_";"
+5 IF LRSAMP'>0
SET DR=DR_5
+6 IF LRSPEC
Begin DoDot:1
+7 IF $PIECE(^LAB(60,LR60,0),U,4)'="MI"
QUIT
+8 SET LRX=$$GET1^DIQ(61,LRSPEC_",",".09:2")
+9 IF LRX="XXX"!(LRX="ORH")
SET DR="4;5"
End DoDot:1
+10 IF DR=""
QUIT
+11 DO EN^DDIOL("Update missing order information for:",,"!!")
+12 DO EN^DDIOL("",,"!")
+13 DO ^DIE
+14 SET LR696(0)=$GET(^LRO(69.6,LR696,0))
+15 SET LRSPEC=+$PIECE(LR696(0),U,7)
SET LRSAMP=+$PIECE(LR696(0),U,8)
+16 ;
+17 QUIT
+18 ;
+19 ;
SMID ; Call to get shipping manifest ID (manual selection)
+1 NEW CNT,DA,DIR,LRSMID,LRY,X,Y
+2 SET LREND=0
SET LRSMID=""
+3 SET DIR(0)="69.6,18"
DO ^DIR
+4 IF $DATA(DTOUT)!($DATA(DUOUT))
SET LREND=1
QUIT
+5 IF $DATA(DIRUT)
QUIT
+6 SET LRY=Y
+7 IF LRY'=""
IF $DATA(^LRO(69.6,"D",LRY))
Begin DoDot:1
+8 NEW LR696
+9 SET LR696=$ORDER(^LRO(69.6,"D",LRY,0))
+10 IF $PIECE($GET(^LRO(69.6,+LR696,0)),"^",5)=+$GET(LRRSITE("RSITE"))
SET LRSMID=LRY
End DoDot:1
+11 IF LRSMID=""
Begin DoDot:1
+12 DO SHOW
+13 KILL ^TMP("LR",$JOB,"SMID")
End DoDot:1
+14 ;
+15 IF LRSMID=""
Begin DoDot:1
+16 NEW DIR
+17 SET DIR(0)="YO"
SET DIR("A")="Use manifest '"_LRY_"' anyway"
SET DIR("B")="NO"
+18 WRITE !
DO ^DIR
+19 IF Y
SET LRRSITE("SMID")=LRY
End DoDot:1
QUIT
+20 ;
+21 SET LRRSITE("SMID")=LRSMID
+22 SET LRY=$ORDER(^LRO(69.6,"D",LRSMID,0))
+23 IF LRY
SET LRRSITE("SDT")=$$GET1^DIQ(69.6,LRY_",",14,"I")
+24 KILL DIR
+25 ;
+26 ; Flag to determine if this shipping manifest should be used to
+27 ; look up orders when manually accessioning.
+28 SET DIR(0)="YO"
SET DIR("A")="Lookup orders using this manifest"
SET DIR("B")="YES"
+29 DO ^DIR
+30 IF $DATA(DIRUT)
SET LREND=1
QUIT
+31 SET LRRSITE("SMID-OK")=Y
+32 QUIT
+33 ;
+34 ;
SHOW ; Gather a list of possible SMID to select from
+1 NEW CNT,DIR,IEN,LEN,SMID,VAL
+2 KILL ^TMP("LR",$JOB,"SMID")
+3 SET SMID=LRY
SET LEN=$LENGTH(LRY)
SET CNT=0
+4 IF SMID?1.N
SET SMID=SMID_" "
+5 FOR
SET SMID=$ORDER(^LRO(69.6,"D",SMID))
if $EXTRACT(SMID,1,LEN)'=LRY
QUIT
Begin DoDot:1
+6 SET IEN=+$ORDER(^LRO(69.6,"D",SMID,0))
+7 IF $PIECE($GET(^LRO(69.6,IEN,0)),"^",5)'=+$GET(LRRSITE("RSITE"))
QUIT
+8 SET CNT=CNT+1
+9 SET ^TMP("LR",$JOB,"SMID",CNT)=SMID
End DoDot:1
+10 IF 'CNT
WRITE !,"No manifest '",LRY,"' found on file."
QUIT
+11 IF CNT=1
SET LRSMID=^TMP("LR",$JOB,"SMID",CNT)
QUIT
+12 ;
+13 ; Select SMID from List
+14 DO DISPL
+15 SET DIR(0)="NO^1:"_CNT
SET DIR("A")="Select Manifest Number"
+16 DO ^DIR
+17 IF $DATA(DIRUT)
WRITE !,"No manifest selected."
QUIT
+18 SET LRSMID=$GET(^TMP("LR",$JOB,"SMID",Y))
+19 QUIT
+20 ;
+21 ;
DISPL ;
+1 NEW CNT,DIR,DIRUT
+2 WRITE @IOF
+3 SET CNT=0
+4 FOR
SET CNT=$ORDER(^TMP("LR",$JOB,"SMID",CNT))
if 'CNT
QUIT
Begin DoDot:1
+5 IF CNT#3=1
Begin DoDot:2
+6 IF '(CNT#(IOSL-3))
SET DIR(0)="E"
DO ^DIR
if $DATA(DIRUT)
QUIT
+7 WRITE !
End DoDot:2
if $DATA(DIRUT)
QUIT
+8 WRITE $$LJ^XLFSTR(CNT_". "_^TMP("LR",$JOB,"SMID",CNT),26)
End DoDot:1
if $DATA(DIRUT)
QUIT
+9 QUIT
+10 ;
+11 ;
DISPLO(LRDIR) ; Display the order from #69.6
+1 ; Call with LRDIR = array of additonal prompts to display, pass by reference
+2 ;
+3 NEW DA,DIC,DIR,DIRUT,DTOUT,DUOUT,DX,S,X,Y
+4 ;
+5 MERGE DIR=LRDIR
+6 SET DIR("A")="Would you like a display of the Order"
SET DIR("B")="NO"
+7 SET DIR(0)="Y"
DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)!(Y'=1)
WRITE !
QUIT
+9 SET DA=LR696
SET DIC="^LRO(69.6,"
SET S=0
WRITE @IOF
DO EN^DIQ
WRITE !
+10 QUIT
