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

LROR1.m

Go to the documentation of this file.
LROR1 ;SLC/DCM - LAB MODULE FOR OR (CONT.) ;8/11/97 [ 04/14/2003  10:59 AM ]
 ;;5.2T9;LR;**1002,1003,1018**;Nov 17, 2004
 ;;5.2;LAB SERVICE;**100,121,128,230**;Sep 27, 1994
STAT ;;Entry point for OR lab status
 I $$VER^LR7OU1>2.5 Q  ;Not valid with OE/RR 3.0
 Q:'ORPK
 S LREND=0,LRODT=+ORPK,LRSN=$P(ORPK,"^",2),LRTN=$P(ORPK,"^",3)
 I 'LRODT!('LRSN)!('LRTN) G END
 S LRDFN=$$LRDFN^LR7OR1(+ORVP,$P(ORVP,";",2))
 G:'LRDFN END
 S LRLAB=$S($D(^XUSEC("LRLAB",DUZ)):1,1:0)
 K D,LRTT
 G:'$D(^LRO(69,LRODT,1,LRSN,0)) END
 S LROD0=^LRO(69,LRODT,1,LRSN,0),LROD1=$S($D(^(1)):^(1),1:""),LROD3=$S($D(^(3)):^(3),1:""),LRORD=^(.1)
 S I=0 F  S I=$O(^LRO(69,LRODT,1,LRSN,6,I)) Q:I<1  W !?5,": "_^(I,0)
 I $D(^LRO(69,LRODT,1,LRSN,2,LRTN,0))#2 S LRZ=0 F  S LRZ=$O(^LRO(69,LRODT,1,LRSN,2,LRZ)) Q:LRZ<1  S X=^(LRZ,0) I $P(X,"^",7)=ORIFN D COMB
 G:'$D(LRAAO) END G:LRAAO<.1 END
 S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
 D PT^LRX,^LROR2
END K LRO,LRAA,LRAAO,LRACC,LRACN,LRACN0,LRAD,LRAN,LRBLOOD,LRC,LRCDT,LRCMNT,LRCW,LRDATA,LRDFN,LRDN,LRDOC,LRDPF,LRDTO,LREND,LRFFLG,LRFOOT,LRHF,LRHI,LRIDT,LRJJ,LRLL,LRLLT,LRLLO,LROC,LROD0,LROD1,LROD3,LROOS,LROP,LRORDER,LRORD,LRODT,LRSN
 K LRECUR,LRINTP,LRLO,LROS,LRSAV,LRSX,LROSD,LROT,LRPANEL,LRPARAM,LRPC,LRPLASMA,LRPO,LRROD,LRSERUM,LRSORD,LRSPEC,LRSS,LRSTOP,LRSUB,LRTC,LRTEST,LRTHER,LRTM60,LRTSCRN,LRTSTS,LRTT,LRUNKNOW,LRWRD,LR0,LRACD,LRDT0,LRLAB,LRPG,LRSB,LRTN,LRURG,LRZ
 K LRCAPLOC,LRCOM,LRJ,LRMX,LRNOW,LRODTSV,LRORN,LRSNSV,LRTNSV,LRURINE,LRXST,LRMA,KK,N,X1,X2,X3,Z1,X2,Z
 Q
RES K ^TMP("LR",$J,"TP") S LRHF=1,LRFOOT=0,LRCW=8,LRORD(1)=LRSN,LRSORD=LRORD
 Q:+LROD0'=LRDFN
 K S,LRAAO
 S X=LRACN0
 D DATA^LRRP
 K S
 S LRORD=LRSORD
 Q
COMB ;
 N LRACN
 S LRSAV=LRODT_"^"_LRSN_"^"_LRZ
 I $P(X,"^",6) S J=0 F  Q:LREND  S J=$O(^LRO(69,"C",$P(X,"^",6),J)) Q:'J  S K=0 F  S K=$O(^LRO(69,"C",$P(X,"^",6),J,K)) Q:'K  D C1 Q:LREND
 S LREND=0,LRSS=$P(^LAB(60,+X,0),"^",4),LRACN0=X,LRACN=LRTN
 D TEST^LROS:LRSS'="MI",RES
 S LRODT=+LRSAV,LRSN=$P(LRSAV,"^",2),LRZ=$P(LRSAV,"^",3)
 Q
C1 Q:'$D(^LRO(69,J,1,K,2))
 S L=0 F  S L=$O(^LRO(69,J,1,K,2,L)) Q:L<1  I +^(L,0)=+X,$P(^(0),"^",7)=$P(X,"^",7) S X=^(0),LRODT=J,LRSN=K,LRZ=L,LREND=1 Q
 Q
FAST ;Go directly to results
 I $$VER^LR7OU1>2.5 Q  ;Not valid with OE/RR 3.0
 Q:'$G(XQADATA)
 S ORVP=$P(XQA1,",",2)_";DPT(",DFN=$P(ORVP,";",1),LRDFN=$$LRDFN^LR7OR1(DFN)
 Q:'LRDFN
 D PT^LRX,READ^ORUTL
 W @IOF,PNM_"   "_SSN
 S ORPK=$P(XQADATA,"^",1,3),ORIFN=$P(XQADATA,"^",4)
 Q:'ORIFN
 D STAT,READ^ORUTL
 I $D(^OR(100,"AN",ORVP,+$P(XQAID,",",3))) S ORNOTIF=+$P(XQAID,",",3) D CLEAN K XQAKILL
 Q
ORN(ON) ;Check if OE/RR-Lab is on
 N ON,X
 S ON=0,X=$O(^DIC(9.4,"C","LR",0))
 S:'X X=$O(^DIC(9.4,"C","LRX",0))
 I X,$P($G(^ORD(100.99,1,20,X,0)),"^",2)!($P($G(^ORD(100.99,1,5,X,0)),"^",3)) S ON=1
 Q ON
CLEAN ;
 N CHK
 S CHK=0
 I $D(ORNOTIF) S N=+ORNOTIF Q:N<1  S D=0 F  S D=$O(^OR(100,"AN",ORVP,N,D)) Q:D<1  S I=0 F  S I=$O(^OR(100,"AN",ORVP,N,D,I)) Q:I<1  I I=ORIFN D
 . ;BEGIN IHS MODIFICATIONS LR*5.2*1018
 . N X,Y S X=I,Y=N,CHK=1 N N,D,I D NOTIF^ORX8(X,Y)
 . ;END IHS MODIFICATIONS
 .;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
 .;REMOVE OLD IHS LINE
 . ;N X,Y S X=I,Y=N,CHK=1 N N,D,I  ;IHS/DIR TUC/AAB 06/15/98
 .;----- END IHS MODIFICATIONS
 K ORTIT
 Q:CHK
 I $D(XQAID) D DELETE^XQALERT Q
 I '$D(XQAID) S XQAID=$P(^ORD(100.9,N,0),"^",2)_","_$P(ORVP,";")_","_N D DELETEA^XQALERT Q
 Q