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

LRTSTSET.m

Go to the documentation of this file. 
  1. LRTSTSET ;DALOI/STAFF - JAM TESTS ONTO (OR OFF) ACCESSIONS ; 19 Jun 2017  12:20 PM
  1.  ;;5.2;LAB SERVICE;**65,100,121,153,201,202,263,291,350,492**;Sep 27, 1994;Build 3
  1.  ;
  1.  ;Formerly apart of LRTSTJAM
  1.  ;
  1. EN ;
  1.  ; Called from LRTSTJAM, LRPHSET2
  1.  I '($D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2) D  Q
  1.  . W !?10,"Sorry  This accession "_LRAN_" No longer exist"
  1.  . W !?10," Accession may have been deleted.",!,$C(7)
  1.  ;
  1.  S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTS,0)=LRTS_"^"_LRURG,$P(^(0),U,9)=+LRTS
  1.  S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",LRTS,LRTS)="",$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4)=""
  1.  S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),U,3)=LRTS,$P(^(0),U,4)=$P(^(0),U,4)+1
  1.  ;
  1.  I $P(LRPARAM,U,14),$P(^LRO(68,LRAA,0),U,16) D CAP^LRWLST12
  1.  ;
  1.  S LRACD=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^",3),LRTSAD(1,LRTS)=""
  1.  I LRACD,LRACD'=LRAD D
  1.  . S ^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRTS,0)=LRTS_"^"_LRURG,$P(^(0),U,9)=+LRTS
  1.  . S ^LRO(68,LRAA,1,LRACD,1,LRAN,4,"B",LRTS,LRTS)="",$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",4)=""
  1.  . I $P(LRPARAM,U,14),$P(^LRO(68,LRAA,0),U,16) D CAP^LRWLST12
  1.  ;
  1.  ;In certain cases, the order number in file 68 may need to be updated.
  1.  ;MFLG = set by LRPHSET2 for those cases
  1.  ;
  1.  I $G(MFLG) D
  1.  . I LRODT=""!(LRSN="") Q
  1.  . S ^LRO(68,LRAA,1,LRAD,1,LRAN,.1)=$G(^LRO(69,LRODT,1,LRSN,.1))
  1.  ;
  1.  D ORUT^LRTSTJM1(LRDFN,LRAA,LRAD,LRAN,LRTS,LRORDTYP,LRURG,LRODT,LRSN)
  1.  ;
  1.  S LRADL=1
  1.  ;
  1.  F  L +^LRO(69,LRODT,1,LRSN):DILOCKTM Q:$T  W !?7,"Someone else is editing this order",!,$C(7) H 20
  1.  ;
  1.  ; Add stub entry for new test.
  1.  K DA,DIC,DIE,DINUM,DO,DR
  1.  ;
  1.  ;The stub may already exist.
  1.  ;
  1.  I $D(^LRO(69,LRODT,1,LRSN,2,"B",+LRTS)) S Y=$O(^LRO(69,LRODT,1,LRSN,2,"B",+LRTS,0))_"^"_+LRTS_"^1"
  1.  ;
  1.  I '$D(^LRO(69,LRODT,1,LRSN,2,"B",+LRTS)) D
  1.  . S DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2,",DA(2)=LRODT,DA(1)=LRSN
  1.  . S DIC(0)="F",X=+LRTS
  1.  . D FILE^DICN
  1.  ;
  1. 69 ; Called by LR7OMERG
  1.  I Y>0 D
  1.  . N LRDIE,LRFDA,LRIENS,I
  1.  . S LRXDA=+Y,LRIENS=LRXDA_","_LRSN_","_LRODT_","
  1.  . S LRXDA(3)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
  1.  . S LRFDA(1,69.03,LRIENS,1)=LRURG
  1.  . S LRFDA(1,69.03,LRIENS,2)=LRAODT
  1.  . S LRFDA(1,69.03,LRIENS,3)=LRAA
  1.  . S LRFDA(1,69.03,LRIENS,4)=LRAN
  1.  . S LRFDA(1,69.03,LRIENS,8)="IP"
  1.  . S LRFDA(1,69.03,LRIENS,9)="L"
  1.  . I $P(LRXDA(3),"^")'="" D
  1.  . . S LRFDA(1,69.03,LRIENS,13)=$P(LRXDA(3),"^")
  1.  . . I $P(LRXDA(3),"^",2) F I=2:1:5 S LRFDA(1,69.03,LRIENS,I+12)=$P(LRXDA(3),"^",I)
  1.  . D FILE^DIE("","LRFDA(1)","LRDIE(1)")
  1.  . D:$G(LRTSP)
  1.  . . S LRBETN=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRTSP,""))
  1.  . . I LRBETN D DADD^LRBEBA31(LRODT,LRSN,LRBETN,LRXDA,LRTS,$G(LRBERF))
  1.  . K LRBETN,LRBERF
  1.  ;
  1.  I $G(LRXDA),'$G(MFLG) D
  1.  . ;MFLG = comments are added in LRPHSET2 instead
  1.  . N X
  1.  . S X=1+$S($D(^LRO(69,LRODT,1,LRSN,2,LRXDA,1,0)):$P(^(0),"^",3),1:0),^(0)="^^"_X_"^"_DT,^(X,0)=" Added by "_$G(DUZ)_" on "_$$HTE^XLFDT($H,"M")
  1.  . S ^LRO(69,"AA",+$G(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
  1.  ;
  1.  I '$D(LRFLG) K DLAYGO,DA,DIC,DIE,DR,LRXDA L -^LRO(69,LRODT,1,LRSN) Q
  1.  ;
  1. SETOR ;
  1.  N LTS S LTS(LRTS)=""
  1.  D NEW^LR7OB1(LRODT,LRSN,"SN",$G(LRNATURE),.LTS,6)
  1.  K DLAYGO,DA,DIC,DIE,DR,LRBERF,LRBEFN,LRBEX
  1.  L -^LRO(69,LRODT,1,LRSN)
  1.  ;
  1. B Q:$D(LRPHSET)
  1.  W !?5,$P(^LAB(60,LRTS,0),U,1)," ADDED" ;K DIC("B") Q:$D(LRTSAD(2))  G ADDTST^LRTSTJAM
  1.  Q