LRVER3A ;SLC/CJS/DALOI/FHS - DATA VERIFICATION ; 17-Oct-2014 09:22 ; MKK
;;5.2;LAB SERVICE;**1,5,42,100,121,153,190,221,254,263,266,274,1018,295,1030,373,1031,1033,1034**;NOV 1, 1997;Build 88
;
;Also contains LRORFLG to restrict multiple OERR alerts (VER+2)
; Reference to ^DIC(42 supported by IA #10039
; Reference to ^%ZTLOAD supported by DBIA #10063
; Reference to IN5^VADPT supported by DBIA #10061
; Reference to $$NOW^XLFDT supported by DBIA #10103
;
; NOTE: LR*5.2*1031 restores LR*5.2*1018 & LR*5.2*1030 modifications
;
VER ;Call with L ^LR(LRDFN,LRSS,LRIDT) from LRGV2, LRGVG1, LRSTUF1, LRSTUF2, LRVR3
D ENTRYAUD^BLRUTIL("VER^LRVER3A 0.0") ; IHS/MSC/MKK - LR*5.2*1033
;
Q:'$O(LRSB(0))
;
Q:+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))<1 ; IHS/OIT/MKK - LR*5.2*1030
;
D:LRSS="CH" LABSTOR^BLRRLMUC(LRDFN,LRSS,LRIDT) ; Put MU2 Data in Lab Data File - IHS/MSC/MKK - LR*5.2*1033
;
N LRVCHK,LRORTST,LRORFLG,LRT
S LRORU3=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),(LRAOD,LRACD)=$P(^(0),U,3)
S LRACD=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,9)):^(9),1:LRACD)
S:'($D(^LRO(68,LRAA,1,LRACD,1,LRAN,0))#2) LRACD=LRAD
S LRAOD=$S($D(^LRO(68,LRAA,1,LRAOD,1,LRAN,0))#2:LRAOD,1:LRAD)
I '$G(LRFIX) S LRNOW=$$NOW^XLFDT,$P(^LR(LRDFN,LRSS,LRIDT,0),U,3,4)=LRNOW_U_$S($G(LRDUZ):LRDUZ,1:DUZ)
K A2 I '$D(PNM) S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX S:PNM="" PNM="NONAME"
N LRT S LRT=0 F S LRT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT)) Q:LRT<.5 S:$P(^(LRT,0),U,5)="" A2(LRT)=1 I $D(^TMP("LR",$J,"VTO",LRT)) S LRVCHK=+^(LRT) D
. I $S(LRVCHK<1:1,$D(LRSB(LRVCHK))#2:1,1:0) D
. . I $D(LRSB(LRVCHK)) Q:$P(LRSB(LRVCHK),U)=""
. . I LRVCHK<1,$L($P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),U,6)) Q
. . D
. . . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"")
. . . S:'$P(^(0),U,5) $P(^(0),U,5)=LRNOW
. . . S $P(^(0),U,6)="",$P(^(0),U,8)=$G(LRCDEF)
. . S LRORTST(LRT)=""
. . I LRACD'=LRAD D
. . . Q:'$D(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0)) D
. . . . S $P(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0),U,4)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"")
. . . . S:'$P(^(0),U,5) $P(^(0),U,5)=LRNOW
. . . . S $P(^(0),U,6)="",$P(^(0),U,8)=$G(LRCDEF)
. . I $P($G(LRPARAM),U,14),$P($G(^LRO(68,+LRAA,0)),U,16) S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
. . K A2(LRT)
. . I +$G(LRDPF)=2,$$VER^LR7OU1<3 D
. . . N I,Y
. . . S Y=LRNOW,I=LRT D V^LROR ;OE/RR 2.5
;-K ZZCARE,ZRECORD I $D(^LR(LRDFN,.3)),^LR(LRDFN,.3)'="" D FCS ; CJS/MPLS 12-4-91 LINK TO CIS ; CJS/MPLS 3-16-92 KILL LOCAL VARIABLES
;-I $P(^LR(LRDFN,0),U,2)=2 I '$D(ZZCARE) S ZRECORD=0,ZRECORD=$O(^SC("C",LRLLOC,ZRECORD)) I ZRECORD'="",$D(^LRTXFCS(5000024,1,618001,"B",ZRECORD)) D FCS ; CJS/MPLS 3-16-92 LINE ADDED TO CHECK IF REQUESTING LOCATION IS CAREVUE SUPPORTED ++RG
S D1=1,X=0 F S X=$O(^TMP("LR",$J,"TMP",X)) Q:X<1 S LRT=+^(X) I $D(LRM(X)) D REQ
I $D(^LRO(69,LRODT,1,LRSN,0)) S ^(3)=$S($D(^(3)):+^(3),1:LRNOW) S:'$P(^(3),U,2) $P(^(3),U,2)=LRNOW
I D1,'$D(A2) S:'$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4) $P(^(3),U,4)=LRNOW,^LRO(68,LRAA,1,LRAD,1,"AC",LRNOW,LRAN)=""
; Class I CareVue routine TASKED if CareVue ward - pwc/10-2000
D
. N I,LR7DLOC D IN5^VADPT S LR7DLOC=$G(^DIC(42,+$P($G(VAIP(5)),"^"),44))
. Q:'LR7DLOC D:$D(^LAB(62.487,"C",LR7DLOC)) ;good ward location
. . S ZTRTN="^LA7DLOC",ZTDESC="LAB AUTOMATION CAREVUE SUPPORTED WARDS"
. . S ZTIO="",ZTDTH=$H,ZTSAVE("L*")="" D ^%ZTLOAD
. . K ZTSAVE,ZTSK,ZTRTN,ZTIO,ZTDTH,ZTDESC,ZTREQ,ZTQUEUED
;D ^VEICVLOC ;* PLS 6/3/99 -For HL7 interface
I D1,'$D(A2),LRAD'=LRACD S:'$P(^LRO(68,LRAA,1,LRACD,1,LRAN,3),U,4) $P(^(3),U,4)=LRNOW,^LRO(68,LRAA,1,LRACD,1,"AC",LRNOW,LRAN)=""
D XREF I $D(^LRO(68,LRAA,.2))'[0 X ^(.2)
N CORRECT S:$G(LRCORECT) CORRECT=1 D NEW^LR7OB1(LRODT,LRSN,"RE",,.LRORTST)
L -^LR(LRDFN,LRSS,LRIDT) ;unlock
D ENTRYAUD^BLRUTIL("VER^LRVER3A 9.0") ; IHS/MSC/MKK - LR*5.2*1033
Q
XREF ;from COM1^LRVER4 and VER^LRVER3A
I +$G(LRDPF)=2,$$VER^LR7OU1<3 D EN^LROR(LRAA,LRAD,LRAN) ;OE/RR 2.5
I LRDPF=62.3 S ^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)="" Q
S LRPRAC=$$PRAC^LRX($P(^LR(LRDFN,LRSS,LRIDT,0),U,10)) ;get doc name
S ^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)=""
S ^LRO(69,9999999-LRIDT\1,1,"AL",$E(LRLLOC,1,15),$E(PNM,1,20),LRDFN)=""
S ^LRO(69,9999999-LRIDT\1,1,"AP",LRPRAC,$E(PNM,1,20),LRDFN)=""
S ^LRO(69,DT,1,"AN",$E(LRLLOC,1,15),LRDFN,LRIDT)=""
S ^LRO(69,DT,1,"AR",$E(LRLLOC,1,15),$E(PNM,1,20),LRDFN)=""
S ^LRO(69,"AN",$E(LRLLOC,1,20),LRDFN,LRIDT)=""
;
;----- BEGIN IHS/MSC/MKK - LR*5.2*1031 - Restore LR*5.2*1018 modifications
;Next line added per appendix A of RMPS Lab E-Sig enhancement v 5.2 Technical Manual - IHS/HQW/SCR - 8/23/01
I $$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",DUZ(2)) D ^BLRALAF ;IHS/HQW/SCR - 8/23/01
;
IHS ; EP
D:BLRLOG ^BLREVTQ("M","R",$G(BLROPT),,$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)))
;----- END IHS MODIFICATION -- IHS/MSC/MKK - LR*5.2*1031
;
I $D(LRPARAM)<1 D LRPARAM ; IHS/MSC/MKK - LR*5.2*1034
;
D CHSET^LRPX(LRDFN,LRIDT)
Q:'$P(LRPARAM,U,3)
;
TSKM F KK="LRDFN","LRAA","LRAOD","LRAD","LRAN","LRIDT","LRSS","LRLLOC","LRSN","LRODT" S ZTSAVE(KK)=""
N %X S ZTRTN="DQ^LRTP",ZTIO="",ZTDTH=$H,ZTDESC="LAB INTERIM REPORTS" D ^%ZTLOAD
K KK,ZTSK,ZTRTN,ZTDTH,ZTSAVE,ZTIO Q
REQ ;
Q:$P($G(LRSB(X)),U)="comment"
I $D(LRSB(X)),$P(LRSB(X),U)="canc" Q
I $D(LRSB(X)),$P(LRSB(X),U)'["pending" Q
I $L($P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0)),U,6)) Q
S:'$G(LRALERT) LRALERT=$S($G(LROUTINE):LROUTINE,1:9)
;
;----- BEGIN IHS/MSC/MKK - LR*5.2*1031 - Restore LR*5.2*1018 modifications
; Original Comments:
; IHS/ITSC/TPF 10/2/01 FIX FOR SOME TESTS NOT SHOWING AS PENDING; REPORTED BY MITRETEK
; DURING E-SIG DEVELOPMENT THIS OCCURRED WHEN USING FAST BYPASS
; THIS ALONG WITH ADDITION IN CRSFLDS^BLRTN FIXES DUPLICATE ENTRIES IN LOG FILE
I $D(LRSB(X)),LRSB(X)'["pending",LRSB(X)'="" Q
;----- END IHS MODIFICATION -- IHS/MSC/MKK -LR*5.2*1031
;
S D1=0 N A,LRPPURG
I $D(LRSB(X)),LRSB(X)["pending",$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 D G REQ1
. S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,4)="",$P(^(0),U,5,6)="^",$P(^(0),U,9)=+$G(LRM(X,"P"))
I '$D(LRSB(X)),'$L($P($G(^LR(LRDFN,"CH",LRIDT,X)),U)) S $P(^(X),U)="pending"
I '$D(LRSB(X)),$P($G(^LR(LRDFN,"CH",LRIDT,X)),U)'="pending" Q
I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 S $P(^(0),U,4,5)="^",A=$P(^(0),U,2) I A>49 S $P(^(0),U,2)=$S(A=50:9,1:A-50)
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2 D
. S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",+LRT,+LRT)=""
. S LRPPURG=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+$G(LRM(X,"P")),0)),U,2)
. S:'LRPPURG LRPPURG=$S($G(LRALERT):+LRALERT,1:9)
. S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0)=+LRT_U_LRPPURG,$P(^(0),U,9)=+$G(LRM(X,"P"))
. S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),U,3)=+LRT,$P(^(0),U,4)=$P(^(0),U,4)+1 Q
REQ1 ;
Q:LRACD=LRAD I $D(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0))#2,'$L($P(^(0),U,6)) S ^(0)=$P(^(0),U,1,2),$P(^(0),U,7)=1,$P(^(0),U,9)=+$G(LRM(X,"P"))
K CNT,LRAMC Q
FCS ; SET UP FOR FOREIGN COMPUTER SYSTEM ; CJS/MPLS 12-4-91 LINK TO CIS
;-S:'$D(ZRECORD) ZZCARE=1 S:$D(ZRECORD) ZTSAVE("LRLLOC")="" ; CJS/MPLS 3-18-92 SET ZZCARE IF PATIENT IN ICU'S, SET ZTSAVE IF TEST REQUESTED FROM PAR/OR
;-F KK="LRDFN","LRIDT","DFN" S ZTSAVE(KK)=""
;-S ZTRTN="EN^LAFCCVX2",ZTIO="",ZTDTH=$H D ^%ZTLOAD
;-Q
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
Q ; Make sure QUIT is there for FCS subroutine above
;
; Randomly, the LRPARAM variable appears to be set to null. This subroutine
; will reset it, if and only if it's null.
LRPARAM ; EP - Reset the LRPARAM Array without calling the LRPARAM routine
; Done because the LRPARAM routine resets numerous variables
NEW REDUZZR2
S LRPARAM=1_"^"_$P(^LAB(69.9,1,0),"^",2,255)
S LRPARAM("VR")=$G(^DD(63,0,"VR"))_U_$G(^DD(100,0,"VR"))_U_$G(^DG(43,1,"VERSION"))
S REDUZZR2=$S($G(DUZ(2)):DUZ(2),1:$$GET1^DIQ(69.9,1,"DEFAULT INSTITUTION","I"))
S LRPARAM("ASITE",REDUZZR2)=""
Q
; ----- END IHS/MSC/MKK - LR*5.2*1034
LRVER3A ;SLC/CJS/DALOI/FHS - DATA VERIFICATION ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**1,5,42,100,121,153,190,221,254,263,266,274,1018,295,1030,373,1031,1033,1034**;NOV 1, 1997;Build 88
+2 ;
+3 ;Also contains LRORFLG to restrict multiple OERR alerts (VER+2)
+4 ; Reference to ^DIC(42 supported by IA #10039
+5 ; Reference to ^%ZTLOAD supported by DBIA #10063
+6 ; Reference to IN5^VADPT supported by DBIA #10061
+7 ; Reference to $$NOW^XLFDT supported by DBIA #10103
+8 ;
+9 ; NOTE: LR*5.2*1031 restores LR*5.2*1018 & LR*5.2*1030 modifications
+10 ;
VER ;Call with L ^LR(LRDFN,LRSS,LRIDT) from LRGV2, LRGVG1, LRSTUF1, LRSTUF2, LRVR3
+1 ; IHS/MSC/MKK - LR*5.2*1033
DO ENTRYAUD^BLRUTIL("VER^LRVER3A 0.0")
+2 ;
+3 IF '$ORDER(LRSB(0))
QUIT
+4 ;
+5 ; IHS/OIT/MKK - LR*5.2*1030
IF +$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))<1
QUIT
+6 ;
+7 ; Put MU2 Data in Lab Data File - IHS/MSC/MKK - LR*5.2*1033
IF LRSS="CH"
DO LABSTOR^BLRRLMUC(LRDFN,LRSS,LRIDT)
+8 ;
+9 NEW LRVCHK,LRORTST,LRORFLG,LRT
+10 SET LRORU3=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
SET (LRAOD,LRACD)=$PIECE(^(0),U,3)
+11 SET LRACD=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,9)):^(9),1:LRACD)
+12 IF '($DATA(^LRO(68,LRAA,1,LRACD,1,LRAN,0))#2)
SET LRACD=LRAD
+13 SET LRAOD=$SELECT($DATA(^LRO(68,LRAA,1,LRAOD,1,LRAN,0))#2:LRAOD,1:LRAD)
+14 IF '$GET(LRFIX)
SET LRNOW=$$NOW^XLFDT
SET $PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,3,4)=LRNOW_U_$SELECT($GET(LRDUZ):LRDUZ,1:DUZ)
+15 KILL A2
IF '$DATA(PNM)
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
IF PNM=""
SET PNM="NONAME"
+16 NEW LRT
SET LRT=0
FOR
SET LRT=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT))
IF LRT<.5
QUIT
IF $PIECE(^(LRT,0),U,5)=""
SET A2(LRT)=1
IF $DATA(^TMP("LR",$JOB,"VTO",LRT))
SET LRVCHK=+^(LRT)
Begin DoDot:1
+17 IF $SELECT(LRVCHK<1:1,$DATA(LRSB(LRVCHK))#2:1,1:0)
Begin DoDot:2
+18 IF $DATA(LRSB(LRVCHK))
IF $PIECE(LRSB(LRVCHK),U)=""
QUIT
+19 IF LRVCHK<1
IF $LENGTH($PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),U,6))
QUIT
+20 Begin DoDot:3
+21 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,4)=$SELECT($GET(LRDUZ):LRDUZ,$GET(DUZ):DUZ,1:"")
+22 IF '$PIECE(^(0),U,5)
SET $PIECE(^(0),U,5)=LRNOW
+23 SET $PIECE(^(0),U,6)=""
SET $PIECE(^(0),U,8)=$GET(LRCDEF)
End DoDot:3
+24 SET LRORTST(LRT)=""
+25 IF LRACD'=LRAD
Begin DoDot:3
+26 IF '$DATA(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0))
QUIT
Begin DoDot:4
+27 SET $PIECE(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0),U,4)=$SELECT($GET(LRDUZ):LRDUZ,$GET(DUZ):DUZ,1:"")
+28 IF '$PIECE(^(0),U,5)
SET $PIECE(^(0),U,5)=LRNOW
+29 SET $PIECE(^(0),U,6)=""
SET $PIECE(^(0),U,8)=$GET(LRCDEF)
End DoDot:4
End DoDot:3
+30 IF $PIECE($GET(LRPARAM),U,14)
IF $PIECE($GET(^LRO(68,+LRAA,0)),U,16)
SET ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
+31 KILL A2(LRT)
+32 IF +$GET(LRDPF)=2
IF $$VER^LR7OU1<3
Begin DoDot:3
+33 NEW I,Y
+34 ;OE/RR 2.5
SET Y=LRNOW
SET I=LRT
DO V^LROR
End DoDot:3
End DoDot:2
End DoDot:1
+35 ;-K ZZCARE,ZRECORD I $D(^LR(LRDFN,.3)),^LR(LRDFN,.3)'="" D FCS ; CJS/MPLS 12-4-91 LINK TO CIS ; CJS/MPLS 3-16-92 KILL LOCAL VARIABLES
+36 ;-I $P(^LR(LRDFN,0),U,2)=2 I '$D(ZZCARE) S ZRECORD=0,ZRECORD=$O(^SC("C",LRLLOC,ZRECORD)) I ZRECORD'="",$D(^LRTXFCS(5000024,1,618001,"B",ZRECORD)) D FCS ; CJS/MPLS 3-16-92 LINE ADDED TO CHECK IF REQUESTING LOCATION IS CAREVUE SUPPORTED ++RG
+37 SET D1=1
SET X=0
FOR
SET X=$ORDER(^TMP("LR",$JOB,"TMP",X))
IF X<1
QUIT
SET LRT=+^(X)
IF $DATA(LRM(X))
DO REQ
+38 IF $DATA(^LRO(69,LRODT,1,LRSN,0))
SET ^(3)=$SELECT($DATA(^(3)):+^(3),1:LRNOW)
IF '$PIECE(^(3),U,2)
SET $PIECE(^(3),U,2)=LRNOW
+39 IF D1
IF '$DATA(A2)
IF '$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4)
SET $PIECE(^(3),U,4)=LRNOW
SET ^LRO(68,LRAA,1,LRAD,1,"AC",LRNOW,LRAN)=""
+40 ; Class I CareVue routine TASKED if CareVue ward - pwc/10-2000
+41 Begin DoDot:1
+42 NEW I,LR7DLOC
DO IN5^VADPT
SET LR7DLOC=$GET(^DIC(42,+$PIECE($GET(VAIP(5)),"^"),44))
+43 ;good ward location
IF 'LR7DLOC
QUIT
IF $DATA(^LAB(62.487,"C",LR7DLOC))
Begin DoDot:2
+44 SET ZTRTN="^LA7DLOC"
SET ZTDESC="LAB AUTOMATION CAREVUE SUPPORTED WARDS"
+45 SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTSAVE("L*")=""
DO ^%ZTLOAD
+46 KILL ZTSAVE,ZTSK,ZTRTN,ZTIO,ZTDTH,ZTDESC,ZTREQ,ZTQUEUED
End DoDot:2
End DoDot:1
+47 ;D ^VEICVLOC ;* PLS 6/3/99 -For HL7 interface
+48 IF D1
IF '$DATA(A2)
IF LRAD'=LRACD
IF '$PIECE(^LRO(68,LRAA,1,LRACD,1,LRAN,3),U,4)
SET $PIECE(^(3),U,4)=LRNOW
SET ^LRO(68,LRAA,1,LRACD,1,"AC",LRNOW,LRAN)=""
+49 DO XREF
IF $DATA(^LRO(68,LRAA,.2))'[0
XECUTE ^(.2)
+50 NEW CORRECT
IF $GET(LRCORECT)
SET CORRECT=1
DO NEW^LR7OB1(LRODT,LRSN,"RE",,.LRORTST)
+51 ;unlock
LOCK -^LR(LRDFN,LRSS,LRIDT)
+52 ; IHS/MSC/MKK - LR*5.2*1033
DO ENTRYAUD^BLRUTIL("VER^LRVER3A 9.0")
+53 QUIT
XREF ;from COM1^LRVER4 and VER^LRVER3A
+1 ;OE/RR 2.5
IF +$GET(LRDPF)=2
IF $$VER^LR7OU1<3
DO EN^LROR(LRAA,LRAD,LRAN)
+2 IF LRDPF=62.3
SET ^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)=""
QUIT
+3 ;get doc name
SET LRPRAC=$$PRAC^LRX($PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,10))
+4 SET ^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)=""
+5 SET ^LRO(69,9999999-LRIDT\1,1,"AL",$EXTRACT(LRLLOC,1,15),$EXTRACT(PNM,1,20),LRDFN)=""
+6 SET ^LRO(69,9999999-LRIDT\1,1,"AP",LRPRAC,$EXTRACT(PNM,1,20),LRDFN)=""
+7 SET ^LRO(69,DT,1,"AN",$EXTRACT(LRLLOC,1,15),LRDFN,LRIDT)=""
+8 SET ^LRO(69,DT,1,"AR",$EXTRACT(LRLLOC,1,15),$EXTRACT(PNM,1,20),LRDFN)=""
+9 SET ^LRO(69,"AN",$EXTRACT(LRLLOC,1,20),LRDFN,LRIDT)=""
+10 ;
+11 ;----- BEGIN IHS/MSC/MKK - LR*5.2*1031 - Restore LR*5.2*1018 modifications
+12 ;Next line added per appendix A of RMPS Lab E-Sig enhancement v 5.2 Technical Manual - IHS/HQW/SCR - 8/23/01
+13 ;IHS/HQW/SCR - 8/23/01
IF $$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",DUZ(2))
DO ^BLRALAF
+14 ;
IHS ; EP
+1 IF BLRLOG
DO ^BLREVTQ("M","R",$GET(BLROPT),,$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)))
+2 ;----- END IHS MODIFICATION -- IHS/MSC/MKK - LR*5.2*1031
+3 ;
+4 ; IHS/MSC/MKK - LR*5.2*1034
IF $DATA(LRPARAM)<1
DO LRPARAM
+5 ;
+6 DO CHSET^LRPX(LRDFN,LRIDT)
+7 IF '$PIECE(LRPARAM,U,3)
QUIT
+8 ;
TSKM FOR KK="LRDFN","LRAA","LRAOD","LRAD","LRAN","LRIDT","LRSS","LRLLOC","LRSN","LRODT"
SET ZTSAVE(KK)=""
+1 NEW %X
SET ZTRTN="DQ^LRTP"
SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTDESC="LAB INTERIM REPORTS"
DO ^%ZTLOAD
+2 KILL KK,ZTSK,ZTRTN,ZTDTH,ZTSAVE,ZTIO
QUIT
REQ ;
+1 IF $PIECE($GET(LRSB(X)),U)="comment"
QUIT
+2 IF $DATA(LRSB(X))
IF $PIECE(LRSB(X),U)="canc"
QUIT
+3 IF $DATA(LRSB(X))
IF $PIECE(LRSB(X),U)'["pending"
QUIT
+4 IF $LENGTH($PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0)),U,6))
QUIT
+5 IF '$GET(LRALERT)
SET LRALERT=$SELECT($GET(LROUTINE):LROUTINE,1:9)
+6 ;
+7 ;----- BEGIN IHS/MSC/MKK - LR*5.2*1031 - Restore LR*5.2*1018 modifications
+8 ; Original Comments:
+9 ; IHS/ITSC/TPF 10/2/01 FIX FOR SOME TESTS NOT SHOWING AS PENDING; REPORTED BY MITRETEK
+10 ; DURING E-SIG DEVELOPMENT THIS OCCURRED WHEN USING FAST BYPASS
+11 ; THIS ALONG WITH ADDITION IN CRSFLDS^BLRTN FIXES DUPLICATE ENTRIES IN LOG FILE
+12 IF $DATA(LRSB(X))
IF LRSB(X)'["pending"
IF LRSB(X)'=""
QUIT
+13 ;----- END IHS MODIFICATION -- IHS/MSC/MKK -LR*5.2*1031
+14 ;
+15 SET D1=0
NEW A,LRPPURG
+16 IF $DATA(LRSB(X))
IF LRSB(X)["pending"
IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2
Begin DoDot:1
+17 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0),U,4)=""
SET $PIECE(^(0),U,5,6)="^"
SET $PIECE(^(0),U,9)=+$GET(LRM(X,"P"))
End DoDot:1
GOTO REQ1
+18 IF '$DATA(LRSB(X))
IF '$LENGTH($PIECE($GET(^LR(LRDFN,"CH",LRIDT,X)),U))
SET $PIECE(^(X),U)="pending"
+19 IF '$DATA(LRSB(X))
IF $PIECE($GET(^LR(LRDFN,"CH",LRIDT,X)),U)'="pending"
QUIT
+20 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2
SET $PIECE(^(0),U,4,5)="^"
SET A=$PIECE(^(0),U,2)
IF A>49
SET $PIECE(^(0),U,2)=$SELECT(A=50:9,1:A-50)
+21 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0))#2
Begin DoDot:1
+22 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",+LRT,+LRT)=""
+23 SET LRPPURG=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,+$GET(LRM(X,"P")),0)),U,2)
+24 IF 'LRPPURG
SET LRPPURG=$SELECT($GET(LRALERT):+LRALERT,1:9)
+25 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,+LRT,0)=+LRT_U_LRPPURG
SET $PIECE(^(0),U,9)=+$GET(LRM(X,"P"))
+26 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),U,3)=+LRT
SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
QUIT
End DoDot:1
REQ1 ;
+1 IF LRACD=LRAD
QUIT
IF $DATA(^LRO(68,LRAA,1,LRACD,1,LRAN,4,+LRT,0))#2
IF '$LENGTH($PIECE(^(0),U,6))
SET ^(0)=$PIECE(^(0),U,1,2)
SET $PIECE(^(0),U,7)=1
SET $PIECE(^(0),U,9)=+$GET(LRM(X,"P"))
+2 KILL CNT,LRAMC
QUIT
FCS ; SET UP FOR FOREIGN COMPUTER SYSTEM ; CJS/MPLS 12-4-91 LINK TO CIS
+1 ;-S:'$D(ZRECORD) ZZCARE=1 S:$D(ZRECORD) ZTSAVE("LRLLOC")="" ; CJS/MPLS 3-18-92 SET ZZCARE IF PATIENT IN ICU'S, SET ZTSAVE IF TEST REQUESTED FROM PAR/OR
+2 ;-F KK="LRDFN","LRIDT","DFN" S ZTSAVE(KK)=""
+3 ;-S ZTRTN="EN^LAFCCVX2",ZTIO="",ZTDTH=$H D ^%ZTLOAD
+4 ;-Q
+5 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
+6 ; Make sure QUIT is there for FCS subroutine above
QUIT
+7 ;
+8 ; Randomly, the LRPARAM variable appears to be set to null. This subroutine
+9 ; will reset it, if and only if it's null.
LRPARAM ; EP - Reset the LRPARAM Array without calling the LRPARAM routine
+1 ; Done because the LRPARAM routine resets numerous variables
+2 NEW REDUZZR2
+3 SET LRPARAM=1_"^"_$PIECE(^LAB(69.9,1,0),"^",2,255)
+4 SET LRPARAM("VR")=$GET(^DD(63,0,"VR"))_U_$GET(^DD(100,0,"VR"))_U_$GET(^DG(43,1,"VERSION"))
+5 SET REDUZZR2=$SELECT($GET(DUZ(2)):DUZ(2),1:$$GET1^DIQ(69.9,1,"DEFAULT INSTITUTION","I"))
+6 SET LRPARAM("ASITE",REDUZZR2)=""
+7 QUIT
+8 ; ----- END IHS/MSC/MKK - LR*5.2*1034
