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 ;SLC/CJS/JAH - JAM TESTS ONTO (OR OFF) ACCESSIONS ; 04-Feb-2014 15:40 ; MKK
  1.  ;;5.2;LAB SERVICE;**65,100,121,153,201,202,263,1018,291,1031,1033**;NOV 1, 1997
  1.  ;
  1.  ;Formerly apart of LRTSTJAM
  1. EN ;
  1.  I '($D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2) W !?10,"Sorry  This accession "_LRAN_" No longer exist",!?10," Accession may have been deleted.",!,$C(7) G ADDTST^LRTSTJAM
  1.  S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTS,0)=LRTS_"^"_LRURG,$P(^(0),U,9)=$G(LRTSP),^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 I $P(LRPARAM,U,14),$P(^LRO(68,LRAA,0),U,16) D CAP^LRWLST12
  1.  S LRACD=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^",3),LRTSAD(1,LRTS)=""
  1.  D EN^LA7ADL($P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),0),"^")) ;Check for automatic downloading
  1.  I LRACD,LRACD'=LRAD S ^LRO(68,LRAA,1,LRACD,1,LRAN,4,LRTS,0)=LRTS_"^"_LRURG,$P(^(0),U,9)=+LRTS D
  1.  .S ^LRO(68,LRAA,1,LRACD,1,LRAN,4,"B",LRTS,LRTS)="",$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",4)="" I $P(LRPARAM,U,14),$P(^LRO(68,LRAA,0),U,16) D CAP^LRWLST12
  1.  F  L +^LRO(69,LRODT,1,LRSN):1 Q:$T  W !?7,"Someone else is editing this order",!,$C(7) H 20
  1.  K LRXDA,DA,DIC,DIE,DR
  1.  S DIC="^LRO(69,"_LRODT_",1,"_LRSN_",2,",DA(2)=LRODT,DA(1)=LRSN
  1.  S DIC(0)="LOX",DLAYGO=69,X=$P(^LAB(60,LRTS,0),"^") D ^DIC
  1.  ;
  1.  D:Y<1 TRYAGAIN    ; IHS/MSC/MKK - LR*5.2*1033
  1.  ;
  1. 69 I Y>0 D
  1.  . S LRXDA(3)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
  1.  . S (LRXDA,DA)=+Y,DIE=DIC,DR="1///^S X=LRURG;2///^S X=LRAODT;3///^S X=LRAA;4///^S X=LRAN;8///^S X=""IP"";9///^S X=""L"""
  1.  . I $L($P(LRXDA(3),U)) D
  1.  . . S DR=DR_";13///^S X=$P(LRXDA(3),U)"
  1.  . . S:$P(LRXDA(3),U,2) DR=DR_";14////^S X=$P(LRXDA(3),U,2);15////^S X=$P(LRXDA(3),U,3);16///^S X=$P(LRXDA(3),U,4);17///^S X=$P(LRXDA(3),U,5)"
  1.  . D ^DIE
  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.  I $G(LRXDA) D
  1.  . N X,Y
  1.  . S Y=$P($$FMTE^XLFDT($$NOW^XLFDT,"5Z"),":",1,2)
  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 "_Y
  1.  . S ^LRO(69,"AA",+$G(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
  1.  . ;
  1.  . D ADDTST^BLRDIAG(LRODT,LRSN,LRTS)   ; IHS/ITSC/TPF **1015** 'SIGN OR SYMPTOM' LAB POV
  1.  . ;
  1.  I '$D(LRFLG) K DLAYGO,DA,DIC,DIE,DR,LRXDA L -^LRO(69,LRODT,1,LRSN) Q
  1.  ;
  1. SETOR ; EP
  1.  I $G(LRXDA),$$VER^LR7OU1<3 D  ;OE/RR 2.5
  1.  . I '$D(ORNATR) S ORNATR=$S($D(LRNATURE):LRNATURE,1:"") I '$D(LRNATURE) D:$P($G(^ORD(100.99,1,2)),"^",2) OT^LROR6 S LRNATURE=ORNATR
  1.  . S X=^LRO(69,LRODT,1,LRSN,0),LRLB=$P(^(.1),"^"),X1=$S($D(^(1)):^(1),1:$P(X,"^",8)),ORVP=$P(^LR(+X,0),"^",3)_";"_$P(^DIC($P(^LR(+X,0),"^",2),0,"GL"),"^",2)
  1.  . I ORNATR="C" S OREPDUZ=$P(X,"^",2),ORLOG=$P(X,"^",5),ORNATR=""
  1.  . S LRORSAMP=$P(X,"^",3),LRORTYPE=$P(X,"^",4),ORNP=$P(X,"^",6),ORL=$S($L($P(X,"^",7)):$P(X,"^",7),1:"UNKNOWN")
  1.  . S ORL=$S($O(^SC("C",ORL,0))'="":$O(^(0))_";SC(",1:""),ORSTRT=$P(X1,"^"),X=^LRO(69,LRODT,1,LRSN,2,LRXDA,0),ORIT=+X_";LAB(60,",LRORSPEC=$O(^LRO(69,LRODT,1,LRSN,4,0)),LRORSPEC=$S(LRORSPEC>0:$P(^(LRORSPEC,0),"^"),1:"")
  1.  . S X=$S($D(LRORSAMP):$S($D(^LAB(62,+LRORSAMP,0)):$P(^(0),"^"),1:""),1:""),Y=$S($D(LRORSPEC):$S($D(^LAB(61,+LRORSPEC,0)):$P(^(0),"^"),1:""),1:"")
  1.  . S ORTX(1)=$P(^LAB(60,+LRTS,0),"^")_$S(Y'[X!(X=Y):" "_X,1:"")_$S(X'[Y:" "_Y,1:"")
  1.  . S ORTX(1)=ORTX(1)_" LB #"_LRLB_"    "_$S($D(LRORTYPE):LRORTYPE,1:"")_$S(LRURG=9!('LRURG):"",1:"   "_$P(^LAB(62.05,LRURG,0),"^"))
  1.  . S ORPCL=$P(^LAB(69.9,1,1),"^",6),ORSTS=6,ORTO=$P(^LAB(60,+ORIT,0),"^",6) S:$P(^LAB(69.9,1,0),"^",9) ORPURG=$P(^(0),"^",9)
  1.  . S ORPCL=$P(^LAB(69.9,1,1),"^",6)_";ORD(101,",ORPK=LRODT_"^"_LRSN_"^"_DA,DA=LRXDA
  1.  . D FILE^ORX
  1.  . S:$D(ORIFN) $P(^LRO(69,LRODT,1,LRSN,2,LRXDA,0),"^",7)=ORIFN
  1.  . K LRLB,LRXDA,LRFLG,LRORSPEC,LRORSAMP,LRORTYPE
  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 L -^LRO(69,LRODT,1,LRSN)
  1. B ; Q:$D(LRPHSET)  W !?5,$P(^LAB(60,LRTS,0),U,1)," ADDED" K DIC("B") Q:$D(LRTSAD(2))  G ADDTST^LRTSTJAM
  1.  ;
  1.  ;----- BEGIN IHS MODIFICATION LR*5.2*1018
  1.  Q:$D(LRPHSET)
  1.  S:$G(BLROPT)=""!($G(BLROPT(0))'=$P(XQY0,U)) BLROPT="ADDACC",BLROPT(0)=$P(XQY0,U)  ;IHS/OIRM TUC/AAB 3/4/97
  1.  I $$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",DUZ(2)) S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5),LRSS=$P($G(^LRO(68,LRAA,0)),U,2) D ^BLRALAF  ;IHS/ITSC/TPF 12/04/01 ADDITIONAL CHANGE FOR E-SIG 
  1.  ; 
  1.  W !?5,$P(^LAB(60,LRTS,0),U,1)," ADDED" D:BLRLOG ^BLREVTQ("C","A",BLROPT,,LRODT_","_LRSN_","_LRAA_","_LRAD_","_LRAN) K DIC("B") Q:$D(LRTSAD(2))  G ADDTST^LRTSTJAM  ;IHS/OIRM TUC/AAB 11/14/96
  1.  ;----- END IHS MODIFICATION LR*5.2*1018
  1.  Q
  1.  ;
  1.  ; ----- IHS/MSC/MKK - LR*5.2*1033
  1.  ; If D ^DIC fails with Y=-1, try using UDPATE^DIE call
  1. TRYAGAIN ; EP
  1.  NEW ERRS,FDA,IENS,IENARRAY
  1.  S IENS="?+1,"_LRSN_","_LRODT_","
  1.  S FDA(69.03,IENS,.01)=LRTS
  1.  D UPDATE^DIE("EKS","FDA","IENARRAY","ERRS")
  1.  I $D(ERRS) S Y=-1  Q
  1.  ;
  1.  S Y=$G(IENARRAY(1))_"^"_LRTS_"^1"
  1.  ;
  1.  Q
  1.  ;
  1.  S NOW=$H
  1.  S ^XTMP("LRTSTSET",NOW,LRODT,LRSN,LRTS)=""
  1.  M ^XTMP("LRTSTSET",NOW,LRODT,LRSN,LRTS,"FDA")=FDA
  1.  M ^XTMP("LRTSTSET",NOW,LRODT,LRSN,LRTS,"IENARRAY")=IENARRAY
  1.  S ^XTMP("LRTSTSET",NOW,LRODT,LRSN,LRTS,"Y")=Y
  1.  S ^XTMP("LRTSTSET",0)=$$HTFM^XLFDT(+$H+365)_"^"_$$DT^XLFDT_"^LRTSTSET TRYAGAIN Call"
  1.  ;
  1.  Q
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1033