Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRORDB

LRORDB.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. EN(LRRUID,LRSSMP) ;
  1. ;
  1. N I,LRSTATUS,LRX
  1. ;
  1. K LROT
  1. ;
  1. S (LROT,LRSTATUS)=""
  1. ;
  1. Q:'$L($G(LRRUID))!('$L($G(LRSSMP)))
  1. S LR696=$O(^LRO(69.6,"AD",LRSSMP,LRRUID,0)) Q:'LR696
  1. Q:'$D(^LRO(69.6,LR696,0))#2
  1. ;
  1. S LRX=+$P(^LRO(69.6,LR696,0),U,10)
  1. I LRX S LRSTATUS=$$GET1^DIQ(64.061,LRX_",",.01)
  1. I LRSTATUS'="",LRSTATUS'="In-Transit" D
  1. . S I=0
  1. . F S I=$O(^LRO(69.6,LR696,2,I)) Q:'I D Q:LRSTATUS="In-Transit"
  1. . . S X=$P(^LRO(69.6,LR696,2,I,0),"^",6) Q:'X
  1. . . I $$GET1^DIQ(64.061,X_",",.01)="In-Transit" S LRSTATUS="In-Transit"
  1. ;
  1. I LRSTATUS'="",LRSTATUS'="In-Transit" D Q
  1. . N DIR
  1. . S DIR("A",1)="This order has a status of [ "_LRSTATUS_" ]"
  1. . S DIR("A",2)="No test selected."
  1. . D DISPLO
  1. ;
  1. ; Display any comments that accompanied order
  1. I $D(^LRO(69.6,LR696,99)) D
  1. . N LRWP
  1. . S LRWP=$$GET1^DIQ(69.6,LR696_",",99,"","LRWP")
  1. . S LRWP(.5)="Collecting site order comments:",LRWP(.5,"F")="!!"
  1. . D EN^DDIOL(.LRWP)
  1. ;
  1. D LROT(LR696)
  1. ;
  1. I $O(LROT(0)) D LL3^LROW3
  1. I '$O(LROT(0)) D Q
  1. . N DIR
  1. . S DIR("A",1)="NO tests found on Shipping Manifest "_$G(LRRSITE("SMID"))
  1. . S DIR("A",2)="For UID "_$G(LRRUID)
  1. . D DISPLO
  1. ;
  1. S $P(^LRO(69.6,LR696,0),U,11)=$G(LRSD("RIEN"))
  1. Q
  1. ;
  1. ;
  1. LROT(LR696) ;
  1. ;
  1. N LR60,LR6205,LR6964,LRATG,LRMICHK,LRNLT,LRX,LRY,X
  1. ;
  1. K LROT
  1. ;
  1. S LR696(0)=$G(^LRO(69.6,LR696,0))
  1. S LRSPEC=+$P(LR696(0),U,7),LRSAMP=+$P(LR696(0),U,8)
  1. ;Q:'LRSPEC!('$D(^LAB(61,LRSPEC,0)))
  1. S (LR6964,LRMICHK)=0
  1. F S LR6964=+$O(^LRO(69.6,LR696,2,LR6964)) Q:LR6964<1 D
  1. . S LR6964(0)=$G(^LRO(69.6,LR696,2,LR6964,0))
  1. . I LR6964(0)="" Q
  1. . I $P(LR6964(0),"^",6),$$GET1^DIQ(64.061,$P(LR6964(0),"^",6)_",",.01)'="In-Transit" Q
  1. . S LR60=$P(LR6964(0),U,11) ; Lab test to order
  1. . S LR6205=$P(LR6964(0),U,12) ; Urgency
  1. . I 'LRMICHK,LR60>0,$P(^LAB(60,LR60,0),U,4)="MI" D MICHECK
  1. . S LRATG=0
  1. . ; If have everything, then don't check accession test group.
  1. . I LR60,LRSPEC,LRSAMP,LR6205 D Q:LRATG
  1. . . S LR64=+$G(^LAB(60,LR60,64))
  1. . . I 'LR64 Q
  1. . . S LRNLT=$P($G(^LAM(LR64,0)),U,2),LRNLT(2)=$P($G(^LAM(LR64,0)),U)
  1. . . ; Find available spot.
  1. . . F LRATG=LRWPC+1:1 I '$D(LROT(LRSAMP,LRSPEC,LRATG)) S LRWPC=LRATG Q
  1. . . D CHKURG,SETLROT
  1. . S LRNLT=$P(LR6964(0),U,2) Q:'LRNLT
  1. . S LRNLT(1)=+$O(^LAM("C",LRNLT_" ",0))
  1. . I 'LRNLT(1)!('$D(^LAM(LRNLT(1),0))) Q
  1. . S LRNLT(2)=$P(^LAM(LRNLT(1),0),U),LR60=0
  1. . F S LR60=+$O(^LAB(60,"AC",LRNLT(1),LR60)) Q:'LR60 D
  1. . . S LRATG=+$O(^TMP("LRSTIK",$J,"C",LR60,0)) Q:LRATG<1
  1. . . S LRATG(1)=$G(^TMP("LRSTIK",$J,LRATG)) Q:'LRATG(1)!('$P(LRATG(1),U,3))
  1. . . S:'$G(LRSAMP) LRSAMP=$P(LRATG(1),U,3)
  1. . . D CHKURG
  1. . . I LR60,LRSPEC,LRSAMP,LR6205 D SETLROT
  1. Q
  1. ;
  1. ;
  1. SETLROT ; Setup LROT array
  1. ;
  1. S LROT(LRSAMP,LRSPEC,LRATG)=LR60
  1. S LROT(LRSAMP,LRSPEC,LRATG,1)=LR6205
  1. S LROT(LRSAMP,LRSPEC,LRATG,"B",LR60)=LR6964_U_LRNLT_U_LRNLT(2)
  1. ;
  1. ; Required comment
  1. S:$P($G(^LAB(60,LR60,0)),U,19) LROT(LRSAMP,LRSPEC,LRATG,2)=$P(^(0),U,19)
  1. ;
  1. Q
  1. ;
  1. ;
  1. CHKURG ; Check for forced, highest allowed and missing urgency on this test
  1. ;
  1. N X
  1. ;
  1. ; Forced urgency
  1. I +$P(^LAB(60,LR60,0),U,18) S LR6205=+$P(^LAB(60,LR60,0),U,18)
  1. ;
  1. ; If missing urgency then look above workload urgencies for last urgency
  1. ; that matches on HL7 urgency othewise use site's default for routine.
  1. I 'LR6205 D
  1. . S X=$P(LR6964(0),U,5)
  1. . I $L(X) S LR6205=+$O(^LAB(62.05,"HL7",X,50),-1)
  1. . S LR6205=$S(LR6205>0:LR6205,1:LROUTINE)
  1. ;
  1. ; Highest urgency allowed, reset if higher than highest allowed.
  1. S X=+$P(^LAB(60,LR60,0),U,16)
  1. I LR6205<X S LR6205=X
  1. ;
  1. Q
  1. ;
  1. ;
  1. MICHECK ; Check "MI" subscript test for missing topography and collection sample
  1. ;
  1. N DA,DIE,DR,X,Y
  1. S DA=LR696,DIE=69.6,DR="",LRMICHK=1
  1. I LRSPEC'>0 S DR=4_";"
  1. I LRSAMP'>0 S DR=DR_5
  1. I LRSPEC D
  1. . S LRX=$$GET1^DIQ(61,LRSPEC_",",".09:2")
  1. . I LRX="XXX"!(LRX="ORH") S DR="4;5"
  1. I DR="" Q
  1. D EN^DDIOL("Update missing order information for:",,"!!")
  1. D EN^DDIOL("",,"!")
  1. D ^DIE
  1. S LR696(0)=$G(^LRO(69.6,LR696,0))
  1. S LRSPEC=+$P(LR696(0),U,7),LRSAMP=+$P(LR696(0),U,8)
  1. ;
  1. Q
  1. ;
  1. ;
  1. SMID ; Call to get shipping manifest ID (manual selection)
  1. N CNT,DA,DIR,LRSMID,LRY,X,Y
  1. S LREND=0,LRSMID=""
  1. S DIR(0)="69.6,18" D ^DIR
  1. I $D(DTOUT)!($D(DUOUT)) S LREND=1 Q
  1. I $D(DIRUT) Q
  1. S LRY=Y
  1. I LRY'="",$D(^LRO(69.6,"D",LRY)) S LRSMID=LRY
  1. I LRSMID="" D
  1. . D SHOW
  1. . K ^TMP("LR",$J,"SMID")
  1. ;
  1. I LRSMID="" D Q
  1. . N DIR
  1. . S DIR(0)="YO",DIR("A")="Use manifest '"_LRY_"' anyway",DIR("B")="NO"
  1. . W ! D ^DIR
  1. . I Y S LRRSITE("SMID")=LRY
  1. ;
  1. S LRRSITE("SMID")=LRSMID
  1. S LRY=$O(^LRO(69.6,"D",LRSMID,0))
  1. I LRY S LRRSITE("SDT")=$$GET1^DIQ(69.6,LRY_",",14,"I")
  1. K DIR
  1. ;
  1. ; Flag to determine if this shipping manfiest should be used to
  1. ; look up orders when manually accessioning.
  1. S DIR(0)="YO",DIR("A")="Lookup orders using this manifest",DIR("B")="YES"
  1. D ^DIR
  1. I $D(DIRUT) S LREND=1 Q
  1. S LRRSITE("SMID-OK")=Y
  1. Q
  1. ;
  1. ;
  1. SHOW ; Gather a list of possible SMID to select from
  1. N CNT,DIR,IEN,LEN,SMID,VAL
  1. K ^TMP("LR",$J,"SMID")
  1. S SMID=LRY,LEN=$L(LRY),CNT=0
  1. I SMID?1.N S SMID=SMID_" "
  1. F S SMID=$O(^LRO(69.6,"D",SMID)) Q:$E(SMID,1,LEN)'=LRY D
  1. . S IEN=+$O(^LRO(69.6,"D",SMID,0))
  1. . I $P($G(^LRO(69.6,IEN,0)),"^",5)'=+$G(LRRSITE("RSITE")) Q
  1. . S CNT=CNT+1
  1. . S ^TMP("LR",$J,"SMID",CNT)=SMID
  1. I 'CNT W !,"No manifest '",LRY,"' found on file." Q
  1. I CNT=1 S LRSMID=^TMP("LR",$J,"SMID",CNT) Q
  1. ;
  1. ; Select SMID from List
  1. D DISPL
  1. S DIR(0)="NO^1:"_CNT,DIR("A")="Select Manifest Number"
  1. D ^DIR
  1. I $D(DIRUT) W !,"No manifest selected." Q
  1. S LRSMID=$G(^TMP("LR",$J,"SMID",Y))
  1. Q
  1. ;
  1. ;
  1. DISPL ;
  1. N CNT,DIR,DIRUT
  1. W @IOF
  1. S CNT=0
  1. F S CNT=$O(^TMP("LR",$J,"SMID",CNT)) Q:'CNT D Q:$D(DIRUT)
  1. . I CNT#3=1 D Q:$D(DIRUT)
  1. . . I '(CNT#(IOSL-3)) S DIR(0)="E" D ^DIR Q:$D(DIRUT)
  1. . . W !
  1. . W $$LJ^XLFSTR(CNT_". "_^TMP("LR",$J,"SMID",CNT),26)
  1. Q
  1. ;
  1. ;
  1. DISPLO ; Display the order from #69.6
  1. N DA,DIC,DIRUT,DTOUT,DUOUT,DX,S,X,Y
  1. S DIR("A")="Would you like a display of the Order"
  1. S DIR(0)="Y" D ^DIR K DIR
  1. I $D(DIROUT)!(Y'=1) W ! Q
  1. S DA=LR696,DIC="^LRO(69.6,",S=0 W @IOF D EN^DIQ W !
  1. Q