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

LRORDST.m

Go to the documentation of this file. 
  1. LRORDST ;SLC/CJS/WTY - SET THE ORDER AND ACCESSION ; 13-Oct-2017 14:04 ;  MKK
  1.  ;;5.2;LAB SERVICE;**1002,1003,1004,1009,100,107,121,1010,1011,1013,1015,153,202,1018,1019,290,291,359,362,1031,1032,1035,1041**;NOV 1, 1997;Build 23
  1.  ;
  1.  ;Called to create orders and accessions from local LROT array
  1.  ;
  1. EP ; EP 
  1.  D DT
  1.  K ZTSK
  1.  ; I $P(LRPARAM,U,4),'$D(LRNOLABL),'$D(LRTJ),LRORDR="" D ^LRLABLIO
  1.  ;-----BEGIN IHS MODIFICATION LR*5.2*1018
  1.  I $P(LRPARAM,U,4),'$D(LRNOLABL),'$D(LRTJ),LRORDR="" D:'$G(BLRGUI) ^LRLABLIO
  1.  ;-----END IHS MODIFICATION
  1.  ;
  1.  F LRSAMP=-1:0 S LRSAMP=$O(LROT(LRSAMP)) Q:LRSAMP=""  F LRSPEC=-1:0 S LRSPEC=$O(LROT(LRSAMP,LRSPEC)) Q:LRSPEC=""  D ZX
  1.  ;
  1.  M ^TMP("LRORDST",$J,"LROT")=LROT      ; IHS/MSC/MKK - LR*5.2*1032
  1.  ;
  1.  D COMPORD^BLRDIAG(LRODT,LRORD)  ;IHS/ITSC/TPF 11/07/02 **1015** DIAGNSOSI/SYMPTOM LAB POV
  1.  ;
  1.  D BUG1034F(LRORD)   ; IHS/MSC/MKK - LR*5.2*1035 - Fix for Major Bug in LR*5.2*1034
  1.  ;
  1.  K ^TMP("LRORDST",$J)                  ; IHS/MSC/MKK - LR*5.2*1032
  1.  ;
  1.  I $D(LRLABLIO),$D(LRLBL) D
  1.  . S ZTRTN="ENT^LRLABLD",ZTDESC="LAB LABELS",ZTDTH=$H
  1.  . S ZTIO=LRLABLIO,ZTSAVE("LRLBL(")=""
  1.  . D ^%ZTLOAD K LRLBL
  1.  ;
  1.  I $D(LRSLIP) F I1=0:0 S I1=$O(LROT(I1)) Q:I1<1  F I2=-1:0 S I2=$O(LROT(I1,I2)) Q:I2=""  S LRSN=LROT(I1,I2,"SN") D WCP
  1.  ;
  1.  K LRLBL,ZTSK
  1.  ;Clean-up CIDC variables
  1.  K LRBEX,LRBEY,LRBEAR,LRBERF
  1.  Q
  1.  ;
  1.  ;
  1. ZX ; EP
  1.  K:$G(LRORDR)'="P" LRCOM,LRTCOM
  1.  N I,COMB,LRCPRS
  1.  I $D(LRGCOM) S LRCCOM=LRGCOM D RCS^LRORD2
  1.  S LRSXN=0,I=0
  1.  F  S I=$O(LROT(LRSAMP,LRSPEC,I)) Q:I<1  S LRSXN=LRSXN+1
  1.  ; L +^LRO(69,LRODT,1)
  1.  L +^LRO(69,LRODT,1):5  ; IHS/MSC/MKK - LR*5.2*1032
  1.  S LRSN=1+$P($G(^LRO(69,LRODT,1,0)),U,3)
  1.  S LRSUM=1+$P($G(^LRO(69,LRODT,1,0)),U,4)
  1.  ;
  1.  ;
  1. ZSN ; EP
  1.  N I
  1.  F  Q:'$D(^LRO(69,LRODT,1,LRSN,0))  S LRSN=LRSN+1
  1.  S ^LRO(69,LRODT,1,LRSN,0)=LRDFN_"^"_DUZ_"^"_(+LRSAMP)_"^"_$S($L($G(LRLWC)):LRLWC,$L(LRORDR):LRORDR,1:"SP")_"^"_LRNT_"^"_LRPRAC_"^"_LRLLOC_"^"_LRODT_$S(+LRORDTIM:"."_LRORDTIM,1:"")_"^"_LROLLOC_"^^"_$G(LRORIFN)
  1.  S ^LRO(69,LRODT,1,LRSN,2,0)="^69.03PA^"_LRSXN_U_LRSXN
  1.  S ^LRO(69,LRODT,1,0)="^69.01PA^"_LRSN_U_LRSUM
  1.  L -^LRO(69,LRODT,1)
  1.  ;
  1.  S:LRLLOC="" LRLLOC="."                          ; IHS/ANMC/CLS 08/18/96
  1.  S ^LRO(69,LRODT,1,"AA",LRDFN,LRSN)=""
  1.  S ^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=""
  1.  S LROT(LRSAMP,LRSPEC,"SN")=LRSN
  1.  S ^LRO(69,"D",LRDFN,LRODT,LRSN)=""
  1.  S COMB=$P($G(^LRO(69,LRODT,1,LRSN,1)),"^",7)
  1.  I $S($G(LRORDR)="":1,$G(LRORDR)="P":1,1:0) D
  1.  . S $P(^LRO(69,LRODT,1,LRSN,1),"^")=$P(LRCDT,"^")
  1.  . S $P(^LRO(69,LRODT,1,LRSN,1),"^",2)=$P(LRCDT,"^",2)
  1.  . S $P(^LRO(69,LRODT,1,LRSN,1),"^",4)="C"
  1.  . S $P(^LRO(69,LRODT,1,LRSN,1),"^",8)=DUZ(2)
  1.  . ;S ^LRO(69,LRODT,1,LRSN,1)=LRCDT_"^^C^^^"_COMB_"^"_DUZ(2)
  1.  . I $G(LRORDR)'="P" S ^LRO(69,"AA",+$G(LRORD),LRODT_"|"_LRSN)=""
  1.  . ; PIECE 4 INDICATED COLLECTED (NOTE: LRCDT HAS 2 PIECES)
  1.  ;
  1.  I LRSPEC'="" S ^LRO(69,LRODT,1,LRSN,4,0)="^69.02PA^1^1",^(1,0)=LRSPEC
  1.  S ^LRO(69,LRODT,1,LRSN,.1)=LRORD,^LRO(69,"C",+LRORD,LRODT,LRSN)="",LRJ=0
  1.  F LRTN=1:1 S LRJ=$O(LROT(LRSAMP,LRSPEC,LRJ)) Q:LRJ<1  D ZSN1
  1.  ;
  1.  I $D(LRCOM(LRSAMP,LRSPEC)),LRCOM(LRSAMP,LRSPEC) D
  1.  . N I
  1.  . S X=LRCOM(LRSAMP,LRSPEC)
  1.  . S ^LRO(69,LRODT,1,LRSN,6,0)="^69.04W^"_X_U_X
  1.  . F I=1:1:X S ^LRO(69,LRODT,1,LRSN,6,I,0)=LRCOM(LRSAMP,LRSPEC,I)
  1.  ;
  1.  ; D:BLRLOG ^BLREVTQ("C","O",$G(BLROPT),,LRODT_","_LRSN)     ; IHS/DIR/MJL 09/20/99
  1.  D:+$G(BLRLOG) ^BLREVTQ("C","O",$G(BLROPT),,LRODT_","_LRSN)     ; MSC/MKK - LR*5.2*1041
  1.  ;
  1.  D NEW^LR7OB1(LRODT,LRSN,"SN",$G(LRNATURE),.LRCPRS)
  1.  I LRORDR="LC"!(LRORDR="I") D
  1.  . S ION=$P($G(^LAB(69.9,1,3.5,+DUZ(2),0)),U,2)
  1.  . S:ION="" ION=$P($G(^LAB(69.9,1,3)),U,4)
  1.  . I ION'="",(LRORDR="LC"!(LRORDR="I")) D ^LROW2P
  1.  I LRORDR="I" S ION=$P($G(^LAB(69.9,1,7,DUZ(2),0)),U,3) I ION'="" D ^LROW2P
  1.  ; I $S(LRORDR="":1,LRORDR="P":1,1:0) D ^LRWLST
  1.  ; ----- BEGIN IHS/ITSC/TPF **1015** 'SIGN OR SYMPTOM' LAB POV
  1.  ; ABOVE COMMENTED OUT.
  1.  ; THIS IS TO ACCOMODATE THE EDITING OF THE DIAGNOSIS ENTRY AFTER THE ENTIRE
  1.  ; ORDER IS COMPLETE. THE CALL TO LRWLST IS DONE WITHIN BLRDIAG
  1.  ; ----- END IHS/ITSC/TPF **1015** 'SIGN OR SYMPTOM' LAB POV
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. ZSN1 ;
  1.  N LRORIFN
  1.  S LRTSTS=LROT(LRSAMP,LRSPEC,LRJ),LRCPRS(LRTSTS)=""
  1.  ; S ^LRO(69,LRODT,1,LRSN,2,LRTN,0)=LRTSTS_"^"_$S($D(LROT(LRSAMP,LRSPEC,LRJ,1)):LROT(LRSAMP,LRSPEC,LRJ,1),1:LROUTINE)
  1.  ;----- BEGIN IHS MODIFICATION LR*5.2*1018
  1.  S ^LRO(69,LRODT,1,LRSN,2,LRTN,0)=LRTSTS_"^"_$S($D(LROT(LRSAMP,LRSPEC,LRJ,1)):LROT(LRSAMP,LRSPEC,LRJ,1),$G(BLRGUI):LRURG,1:LROUTINE)
  1.  ;----- END IHS MODIFICATION 
  1.  D:+LRDPF=2&($G(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT))  ;CIDC
  1.  .D SACC^LRBEBA2(LRODT,LRSN,LRTN,LRSAMP,LRSPEC,LRTSTS,.LRBEX)
  1.  I $G(LRORIFN) S $P(^LRO(69,LRODT,1,LRSN,2,LRTN,0),"^",7)=LRORIFN ;OE/RR 2.5
  1.  S $P(^LRO(69,LRODT,1,LRSN,2,LRTN,0),"^",9,10)="IP^L"
  1.  S ^LRO(69,LRODT,1,LRSN,2,"B",LRTSTS,LRTN)=""
  1.  S ^LRO(69,"AT",LRDFN,LRTSTS,LRSPEC,LRODT)="",^(-LRODT)=""
  1.  D RCOM:$D(LROT(LRSAMP,LRSPEC,LRJ,2))
  1.  D:$O(LRTCOM(LRTSTS,0)) TCOM^LROW2A(LRTSTS)
  1.  Q
  1.  ;
  1.  ;
  1. RCOM ; Required comment
  1.  N LRTSTN,LRTEST
  1.  S LRTSTN=1,LRTEST(LRTSTN)=LRTSTS
  1.  ; S LRCCOM="~For Test: "_$P(^LAB(60,LRTSTS,0),U)_"   "_$P(^LAB(62,LRSAMP,0),U) S:$P(^(0),U)'=$P(^LAB(61,LRSPEC,0),U) LRCCOM=LRCCOM_"   "_$P(^LAB(61,LRSPEC,0),U) I $S('$D(DUZ("AG")):1,"ARMYAFN"'[DUZ("AG"):1,1:0) W !,LRCCOM
  1.  ;----- BEGIN IHS MODIFICATION LR*5.2*1018
  1.  S LRCCOM="~For Test: "_$P(^LAB(60,LRTSTS,0),U)_"   "_$P(^LAB(62,LRSAMP,0),U) S:$P(^(0),U)'=$P(^LAB(61,LRSPEC,0),U) LRCCOM=LRCCOM_"   "_$P(^LAB(61,LRSPEC,0),U) I $S('$D(DUZ("AG")):1,"ARMYAFN"'[DUZ("AG"):1,1:0) W:'$G(BLRGUI) !,LRCCOM
  1.  ;----- END IHS MODIFICATION
  1.  S LREXP=LROT(LRSAMP,LRSPEC,LRJ,2)
  1.  D RCS^LRORD2,RCOM^LRORD2
  1.  I $G(LRKIL) S DA(1)=LRODT,DA=LRSN,DIK="^LRO(69,"_DA(1)_",1," D ^DIK Q
  1.  I LRCCOM="",$D(LRCOM(LRSAMP,LRSPEC)) S X=+LRCOM(LRSAMP,LRSPEC) I $D(LRCOM(LRSAMP,LRSPEC,X)),LRCOM(LRSAMP,LRSPEC,X)["~For Test:" K LRCOM(LRSAMP,LRSPEC,X) S LRCOM(LRSAMP,LRSPEC)=X-1
  1.  Q
  1.  ;
  1.  ;
  1. OLD ; to allow unchanged routines to still work, from LROE1, LRPHSET1
  1.  N LRNT
  1.  D DT,NOW^%DTC
  1.  S LRNT=%
  1.  I $P(LRPARAM,U,4),'$D(LRNOLABL),'$D(LRTJ) D ^LRLABLIO
  1.  D ^LRWLST
  1.  Q
  1.  ;
  1.  ;
  1. WCP Q:$D(LRNCWL)
  1.  S:$D(LRORDER) ION=LRORDER
  1.  ; I '$D(LRORDER) K %ZIS S IOP="HOME",%ZIS="NQ" D ^%ZIS G:POP WCP1 S X=ION,DIC(0)="EQ",DIC=3.5 D ^DIC G:Y<1 WCP1 G:'$D(^%ZIS(1,+Y,99)) WCP1 G:'$L($P(^(99),U)) WCP1 S IOP=$P(^%ZIS(1,$P(^(99),U),0),U),%ZIS="NQ" D ^%ZIS G:POP WCP1 K %ZIS,IOP
  1.  ;----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1019 -- DIC(0)="EQX" fix
  1.  I '$D(LRORDER) K %ZIS S IOP="HOME",%ZIS="NQ" D ^%ZIS G:POP WCP1 S X=ION,DIC(0)="EQX",DIC=3.5 D ^DIC G:Y<1 WCP1 G:'$D(^%ZIS(1,+Y,99)) WCP1 G:'$L($P(^(99),U)) WCP1 S IOP=$P(^%ZIS(1,$P(^(99),U),0),U),%ZIS="NQ" D ^%ZIS G:POP WCP1 K %ZIS,IOP
  1.  ;----- END IHS MODIFICATION LR*5.2*1019
  1. WCP2 S LRORDER=ION
  1.  I IO(0)=IO R !!,"Press RETURN to continue...",X:DTIME S IOP=LRORDER,%ZIS="" D ^%ZIS D ENT2^LROW2P Q
  1.  I IO'=IO(0) D ^LROW2P Q
  1.  Q
  1.  ;
  1.  ;
  1. DT S DT=$$DT^XLFDT()
  1.  Q
  1.  ;
  1.  ;
  1. WCP1 S %ZIS="NQ",%ZIS("A")="ORDER COPY DEVICE:"
  1.  D ^%ZIS
  1.  Q:POP
  1.  G WCP2
  1.  ;
  1.  ;
  1. OR ;OE/RR 2.5
  1.  ; Q  ;Following logic not required - 2.5 is obsolete version
  1.  I $$VER^LR7OU1>2.5 Q   ; OE/RR 2.5 Logic put back in -- IHS/MSC/MKK - LR*5.2*1031
  1.  N LRORDR
  1.  Q:$G(LRORDRR)="R"
  1.  S LRY=$S($D(LROT(LRSAMP,LRSPEC,LRJ,1)):LROT(LRSAMP,LRSPEC,LRJ,1),1:LROUTINE),LRI=1,LRTEST(LRI)=LRTSTS_"^"_LRY,LRORDR=$S($L($G(LRLWC)):LRLWC,1:"")
  1.  D SET^LROR
  1.  Q
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
  1.  ; There was a major bug regarding Multipurpose accessioning in LR*5.2*1034.
  1.  ; This code is the fix, but it's not known, at this time, what change caused the problem.
  1.  ; It deals with the improper SPECIMEN TYPE being stored into the Lab Data file during
  1.  ; accessioning, even though the Accession file has the correct SPECIMEN.
  1. BUG1034F(LRORD) ; EP
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRORD,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S LRODT=0
  1.  F  S LRODT=$O(^LRO(69,"C",LRORD,LRODT))  Q:LRODT<1  D
  1.  . S LRSP=0
  1.  . F  S LRSP=$O(^LRO(69,"C",LRORD,LRODT,LRSP))  Q:LRSP<1  D
  1.  .. S LROT=0
  1.  .. F  S LROT=$O(^LRO(69,LRODT,1,LRSP,2,LROT))  Q:LROT<1  D
  1.  ... S STR=$G(^LRO(69,LRODT,1,LRSP,2,LROT,0))
  1.  ... S LRAD=+$P(STR,U,3),LRAA=+$P(STR,U,4),LRAN=+$P(STR,U,5)
  1.  ... S LRSS=$P($G(^LRO(68,LRAA,0)),U,2)
  1.  ... S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),LRIDT=+$P($G(^(3)),U,5)
  1.  ... S LRSPEC=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0))
  1.  ... S COLLSAMP=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)),U,2)
  1.  ... Q:LRSS'="BB"&(LRSS'="CH")&(LRSS'="MI")
  1.  ... I LRSPEC,LRDFN,LRIDT,$L(LRSS) D
  1.  .... S $P(^LR(LRDFN,LRSS,LRIDT,0),U,5)=LRSPEC
  1.  .... S:LRSS="MI"!(LRSS="BB") $P(^LR(LRDFN,LRSS,LRIDT,0),U,11)=$S(COLLSAMP:COLLSAMP,1:"")
  1.  Q