LRORDB ;VA/DALOI/FHS - ORDER LEDI TEST USING BARCODE FROM 69.6 ;JUL 06, 2010 3:14 PM
;;5.2;LAB SERVICE;**153,222,286,1027**;NOV 01, 1997
;
EN(LRRUID,LRSSMP) ;
;
N I,LRSTATUS,LRX
;
K LROT
;
S (LROT,LRSTATUS)=""
;
Q:'$L($G(LRRUID))!('$L($G(LRSSMP)))
S LR696=$O(^LRO(69.6,"AD",LRSSMP,LRRUID,0)) Q:'LR696
Q:'$D(^LRO(69.6,LR696,0))#2
;
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
. N DIR
. S DIR("A",1)="This order has a status of [ "_LRSTATUS_" ]"
. S DIR("A",2)="No test selected."
. D DISPLO
;
; 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
. N DIR
. S DIR("A",1)="NO tests found on Shipping Manifest "_$G(LRRSITE("SMID"))
. S DIR("A",2)="For UID "_$G(LRRUID)
. D DISPLO
;
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,$P(^LAB(60,LR60,0),U,4)="MI" 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 othewise use site's default for routine.
I 'LR6205 D
. S X=$P(LR6964(0),U,5)
. I $L(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
. 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)) 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 manfiest 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 ; Display the order from #69.6
N DA,DIC,DIRUT,DTOUT,DUOUT,DX,S,X,Y
S DIR("A")="Would you like a display of the Order"
S DIR(0)="Y" D ^DIR K DIR
I $D(DIROUT)!(Y'=1) W ! Q
S DA=LR696,DIC="^LRO(69.6,",S=0 W @IOF D EN^DIQ W !
Q
LRORDB ;VA/DALOI/FHS - ORDER LEDI TEST USING BARCODE FROM 69.6 ;JUL 06, 2010 3:14 PM
+1 ;;5.2;LAB SERVICE;**153,222,286,1027**;NOV 01, 1997
+2 ;
EN(LRRUID,LRSSMP) ;
+1 ;
+2 NEW I,LRSTATUS,LRX
+3 ;
+4 KILL LROT
+5 ;
+6 SET (LROT,LRSTATUS)=""
+7 ;
+8 IF '$LENGTH($GET(LRRUID))!('$LENGTH($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 LRX=+$PIECE(^LRO(69.6,LR696,0),U,10)
+13 IF LRX
SET LRSTATUS=$$GET1^DIQ(64.061,LRX_",",.01)
+14 IF LRSTATUS'=""
IF LRSTATUS'="In-Transit"
Begin DoDot:1
+15 SET I=0
+16 FOR
SET I=$ORDER(^LRO(69.6,LR696,2,I))
IF 'I
QUIT
Begin DoDot:2
+17 SET X=$PIECE(^LRO(69.6,LR696,2,I,0),"^",6)
IF 'X
QUIT
+18 IF $$GET1^DIQ(64.061,X_",",.01)="In-Transit"
SET LRSTATUS="In-Transit"
End DoDot:2
IF LRSTATUS="In-Transit"
QUIT
End DoDot:1
+19 ;
+20 IF LRSTATUS'=""
IF LRSTATUS'="In-Transit"
Begin DoDot:1
+21 NEW DIR
+22 SET DIR("A",1)="This order has a status of [ "_LRSTATUS_" ]"
+23 SET DIR("A",2)="No test selected."
+24 DO DISPLO
End DoDot:1
QUIT
+25 ;
+26 ; Display any comments that accompanied order
+27 IF $DATA(^LRO(69.6,LR696,99))
Begin DoDot:1
+28 NEW LRWP
+29 SET LRWP=$$GET1^DIQ(69.6,LR696_",",99,"","LRWP")
+30 SET LRWP(.5)="Collecting site order comments:"
SET LRWP(.5,"F")="!!"
+31 DO EN^DDIOL(.LRWP)
End DoDot:1
+32 ;
+33 DO LROT(LR696)
+34 ;
+35 IF $ORDER(LROT(0))
DO LL3^LROW3
+36 IF '$ORDER(LROT(0))
Begin DoDot:1
+37 NEW DIR
+38 SET DIR("A",1)="NO tests found on Shipping Manifest "_$GET(LRRSITE("SMID"))
+39 SET DIR("A",2)="For UID "_$GET(LRRUID)
+40 DO DISPLO
End DoDot:1
QUIT
+41 ;
+42 SET $PIECE(^LRO(69.6,LR696,0),U,11)=$GET(LRSD("RIEN"))
+43 QUIT
+44 ;
+45 ;
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 $PIECE(^LAB(60,LR60,0),U,4)="MI"
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 othewise use site's default for routine.
+9 IF 'LR6205
Begin DoDot:1
+10 SET X=$PIECE(LR6964(0),U,5)
+11 IF $LENGTH(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 SET LRX=$$GET1^DIQ(61,LRSPEC_",",".09:2")
+8 IF LRX="XXX"!(LRX="ORH")
SET DR="4;5"
End DoDot:1
+9 IF DR=""
QUIT
+10 DO EN^DDIOL("Update missing order information for:",,"!!")
+11 DO EN^DDIOL("",,"!")
+12 DO ^DIE
+13 SET LR696(0)=$GET(^LRO(69.6,LR696,0))
+14 SET LRSPEC=+$PIECE(LR696(0),U,7)
SET LRSAMP=+$PIECE(LR696(0),U,8)
+15 ;
+16 QUIT
+17 ;
+18 ;
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))
SET LRSMID=LRY
+8 IF LRSMID=""
Begin DoDot:1
+9 DO SHOW
+10 KILL ^TMP("LR",$JOB,"SMID")
End DoDot:1
+11 ;
+12 IF LRSMID=""
Begin DoDot:1
+13 NEW DIR
+14 SET DIR(0)="YO"
SET DIR("A")="Use manifest '"_LRY_"' anyway"
SET DIR("B")="NO"
+15 WRITE !
DO ^DIR
+16 IF Y
SET LRRSITE("SMID")=LRY
End DoDot:1
QUIT
+17 ;
+18 SET LRRSITE("SMID")=LRSMID
+19 SET LRY=$ORDER(^LRO(69.6,"D",LRSMID,0))
+20 IF LRY
SET LRRSITE("SDT")=$$GET1^DIQ(69.6,LRY_",",14,"I")
+21 KILL DIR
+22 ;
+23 ; Flag to determine if this shipping manfiest should be used to
+24 ; look up orders when manually accessioning.
+25 SET DIR(0)="YO"
SET DIR("A")="Lookup orders using this manifest"
SET DIR("B")="YES"
+26 DO ^DIR
+27 IF $DATA(DIRUT)
SET LREND=1
QUIT
+28 SET LRRSITE("SMID-OK")=Y
+29 QUIT
+30 ;
+31 ;
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 ; Display the order from #69.6
+1 NEW DA,DIC,DIRUT,DTOUT,DUOUT,DX,S,X,Y
+2 SET DIR("A")="Would you like a display of the Order"
+3 SET DIR(0)="Y"
DO ^DIR
KILL DIR
+4 IF $DATA(DIROUT)!(Y'=1)
WRITE !
QUIT
+5 SET DA=LR696
SET DIC="^LRO(69.6,"
SET S=0
WRITE @IOF
DO EN^DIQ
WRITE !
+6 QUIT
