LRAC2 ;SLC/DCM - CUMULATIVE CONT. ; 12/12/88 10:16 ;
;;5.2;LAB SERVICE;**225**;Sep 27, 1994
TST1 Q:LRSPM'=LRSPM1
I $L(LX1),LX2,$D(^LAC(LRXLR,LRDFN,1,LX1,1,LX2,1,LRIIDT,1,LRTSTS)),LRMH_":"_LRSH=(LX1_":"_LX2) S LRNON=1 Q
SBSET S LRMHN=$P(^LAB(64.5,1,1,LRMH,0),U,1),LRTF=^(1,LRSH,0),$P(LRTF,U,4)=$P(LRTF,U,3),$P(LRTF,U,3)=$P(^(1,0),U,4),LRNON=1,LRIIDT=LRVIDT
I '$D(^LAC(LRXLR,LRDFN,1,LRMH,0)) S ^(0)=LRMHN,LRZO="^LAC("""_LRXLR_""","_LRDFN_",1,",LRZ1=64.701,LRZ3=LRMH D Z^LRWU
I '$D(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,0))!($D(^(0))=10) S ^(0)=LRTF_U,LRZO="^LAC("""_LRXLR_""","_LRDFN_",1,"_LRMH_",1,",LRZ1=64.703,LRZ3=LRSH D Z^LRWU
I '$D(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRIIDT,0)) S ^(0)=LRVIDT_U_LRTLOC_U_LRVDT_U_LRAN_U_LRIDT,LRZO="^LAC("""_LRXLR_""","_LRDFN_",1,"_LRMH_",1,"_LRSH_",1,",LRZ1="64.704D",LRZ3=LRIIDT D Z^LRWU
LRTSTVAL S ^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRIIDT,1,LRTSTS,0)=LRTSTVAL_U_X1_U_LRSUB,LRZO="^LAC("""_LRXLR_""","_LRDFN_",1,"_LRMH_",1,"_LRSH_",1,"_LRIIDT_",1,",LRZ1=64.705,LRZ3=LRTSTS D Z^LRWU
I $D(^LR(LRDFN,"CH",LRIDT,1,0)) D TEXT
I '$L(LX1)!(LX2&(LX1_":"_LX2'=(LRMH_":"_LRSH))),'$D(^LAC("LGOT",LRDFN,LRMH)) S ^(LRMH)="",^LAC("LRAC",LRDFN,1,LRMH,.5)=1
S:'LRRE ^LRO(68,"AC",LRDFN,LRIDT,LRSUB)=LRMH_"^"_LRSH
Q
SUB1 I '$D(^LR(LRDFN,"CH",LRIDT,LRSUB)) K ^LRO(68,"AC",LRDFN,LRIDT,LRSUB) Q
S LRTST=$O(^LAB(60,"C","CH;"_LRSUB_";1",0)) I LRTST="" K ^LRO(68,"AC",LRDFN,LRIDT,LRSUB) Q
S LX2=$P(LX1,"^",2),LX1=$P(LX1,"^")
SUB2 ;from LRACM2
S LRTSTVAL=$P(^LR(LRDFN,"CH",LRIDT,LRSUB),U,1),X1=$P(^(LRSUB),U,2)
I "IN"[$P(^LAB(60,LRTST,0),U,3) K ^LRO(68,"AC",LRDFN,LRIDT,LRSUB) Q
G S LRNOFL=""
I '$D(^LAB(64.5,"AC",LRSUB)),LX1'="MISC" D MISC^LRAC2A Q
K LRNON
S LRMH=0 F S LRMH=$O(^LAB(64.5,"AC",LRSUB,1,LRMH)) Q:'LRMH S LRSH=0 F S LRSH=$O(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH)) Q:'LRSH S LRTSTS=0 F S LRTSTS=$O(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH,LRTSTS)) Q:'LRTSTS S LRSPM1=^(LRTSTS) D TST1
I '$D(LRNON),LX1'="MISC" D MISC^LRAC2A
K LX1,LX2 Q
LRIDT ;from LRAC1
I $D(^LR(LRDFN,"CH",LRIDT,0))[0 K ^LRO(68,"AC",LRDFN,LRIDT) Q
LRSPM S X=^LR(LRDFN,"CH",LRIDT,0),LRIIDT=$P(X,U,1),LRTNN=1,LRVIDT=LRIIDT
OD S LRSPM=$P(X,U,5),LRIPG=$P(X,U,9),LRTLOC=$E($P(X,U,11),1,7),LRVDT=$P(X,U,3),LRAN=$P(X,U,6)
Q:'$L(LRVDT) S LRSUB=1 F S LRSUB=$O(^LRO(68,"AC",LRDFN,LRIDT,LRSUB)) Q:LRSUB<1 S LX1=^(LRSUB) D SUB1
Q
TEXT S LRYESCOM=0 K ^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRIIDT,"TX")
S M=0 F S M=$O(^LR(LRDFN,"CH",LRIDT,1,M)) Q:'M!(LRYESCOM) F N=1:1:$L(^LR(LRDFN,"CH",LRIDT,1,M,0)) Q:LRYESCOM S:$E(^(0),N)'[$C(32) LRYESCOM=1
Q:'LRYESCOM
S ^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRIIDT,"TX",0)="^^1^1^"_LRIIDT
S L=0 F S L=$O(^LR(LRDFN,"CH",LRIDT,1,L)) Q:'L S ^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRIIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
I +LRIPG<0 S ^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRIIDT,"TX",.1,0)="ATTENTION: This data has been modified from previously reported results!!! "
Q
LRCALE ;from LRAC1, LRACM2, LRACM3
S A7=0 F S A7=$O(^LAB(64.5,1,1,A7)) Q:A7<1 S B3=0 F S B3=$O(^LAB(64.5,1,1,A7,1,B3)) Q:B3<1 S:$P(^LAB(64.5,1,1,A7,1,B3,0),U,4) LRCALE(A7,B3)=1
K A7,B3 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAC2 3118 printed Jan 18, 2025@03:06:49 Page 2
LRAC2 ;SLC/DCM - CUMULATIVE CONT. ; 12/12/88 10:16 ;
+1 ;;5.2;LAB SERVICE;**225**;Sep 27, 1994
TST1 if LRSPM'=LRSPM1
QUIT
+1 IF $LENGTH(LX1)
IF LX2
IF $DATA(^LAC(LRXLR,LRDFN,1,LX1,1,LX2,1,LRIIDT,1,LRTSTS))
IF LRMH_":"_LRSH=(LX1_":"_LX2)
SET LRNON=1
QUIT
SBSET SET LRMHN=$PIECE(^LAB(64.5,1,1,LRMH,0),U,1)
SET LRTF=^(1,LRSH,0)
SET $PIECE(LRTF,U,4)=$PIECE(LRTF,U,3)
SET $PIECE(LRTF,U,3)=$PIECE(^(1,0),U,4)
SET LRNON=1
SET LRIIDT=LRVIDT
+1 IF '$DATA(^LAC(LRXLR,LRDFN,1,LRMH,0))
SET ^(0)=LRMHN
SET LRZO="^LAC("""_LRXLR_""","_LRDFN_",1,"
SET LRZ1=64.701
SET LRZ3=LRMH
DO Z^LRWU
+2 IF '$DATA(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,0))!($DATA(^(0))=10)
SET ^(0)=LRTF_U
SET LRZO="^LAC("""_LRXLR_""","_LRDFN_",1,"_LRMH_",1,"
SET LRZ1=64.703
SET LRZ3=LRSH
DO Z^LRWU
+3 IF '$DATA(^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRIIDT,0))
SET ^(0)=LRVIDT_U_LRTLOC_U_LRVDT_U_LRAN_U_LRIDT
SET LRZO="^LAC("""_LRXLR_""","_LRDFN_",1,"_LRMH_",1,"_LRSH_",1,"
SET LRZ1="64.704D"
SET LRZ3=LRIIDT
DO Z^LRWU
LRTSTVAL SET ^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRIIDT,1,LRTSTS,0)=LRTSTVAL_U_X1_U_LRSUB
SET LRZO="^LAC("""_LRXLR_""","_LRDFN_",1,"_LRMH_",1,"_LRSH_",1,"_LRIIDT_",1,"
SET LRZ1=64.705
SET LRZ3=LRTSTS
DO Z^LRWU
+1 IF $DATA(^LR(LRDFN,"CH",LRIDT,1,0))
DO TEXT
+2 IF '$LENGTH(LX1)!(LX2&(LX1_":"_LX2'=(LRMH_":"_LRSH)))
IF '$DATA(^LAC("LGOT",LRDFN,LRMH))
SET ^(LRMH)=""
SET ^LAC("LRAC",LRDFN,1,LRMH,.5)=1
+3 if 'LRRE
SET ^LRO(68,"AC",LRDFN,LRIDT,LRSUB)=LRMH_"^"_LRSH
+4 QUIT
SUB1 IF '$DATA(^LR(LRDFN,"CH",LRIDT,LRSUB))
KILL ^LRO(68,"AC",LRDFN,LRIDT,LRSUB)
QUIT
+1 SET LRTST=$ORDER(^LAB(60,"C","CH;"_LRSUB_";1",0))
IF LRTST=""
KILL ^LRO(68,"AC",LRDFN,LRIDT,LRSUB)
QUIT
+2 SET LX2=$PIECE(LX1,"^",2)
SET LX1=$PIECE(LX1,"^")
SUB2 ;from LRACM2
+1 SET LRTSTVAL=$PIECE(^LR(LRDFN,"CH",LRIDT,LRSUB),U,1)
SET X1=$PIECE(^(LRSUB),U,2)
+2 IF "IN"[$PIECE(^LAB(60,LRTST,0),U,3)
KILL ^LRO(68,"AC",LRDFN,LRIDT,LRSUB)
QUIT
G SET LRNOFL=""
+1 IF '$DATA(^LAB(64.5,"AC",LRSUB))
IF LX1'="MISC"
DO MISC^LRAC2A
QUIT
+2 KILL LRNON
+3 SET LRMH=0
FOR
SET LRMH=$ORDER(^LAB(64.5,"AC",LRSUB,1,LRMH))
if 'LRMH
QUIT
SET LRSH=0
FOR
SET LRSH=$ORDER(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH))
if 'LRSH
QUIT
SET LRTSTS=0
FOR
SET LRTSTS=$ORDER(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH,LRTSTS))
if 'LRTSTS
QUIT
SET LRSPM1=^(LRTSTS)
DO TST1
+4 IF '$DATA(LRNON)
IF LX1'="MISC"
DO MISC^LRAC2A
+5 KILL LX1,LX2
QUIT
LRIDT ;from LRAC1
+1 IF $DATA(^LR(LRDFN,"CH",LRIDT,0))[0
KILL ^LRO(68,"AC",LRDFN,LRIDT)
QUIT
LRSPM SET X=^LR(LRDFN,"CH",LRIDT,0)
SET LRIIDT=$PIECE(X,U,1)
SET LRTNN=1
SET LRVIDT=LRIIDT
OD SET LRSPM=$PIECE(X,U,5)
SET LRIPG=$PIECE(X,U,9)
SET LRTLOC=$EXTRACT($PIECE(X,U,11),1,7)
SET LRVDT=$PIECE(X,U,3)
SET LRAN=$PIECE(X,U,6)
+1 if '$LENGTH(LRVDT)
QUIT
SET LRSUB=1
FOR
SET LRSUB=$ORDER(^LRO(68,"AC",LRDFN,LRIDT,LRSUB))
if LRSUB<1
QUIT
SET LX1=^(LRSUB)
DO SUB1
+2 QUIT
TEXT SET LRYESCOM=0
KILL ^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRIIDT,"TX")
+1 SET M=0
FOR
SET M=$ORDER(^LR(LRDFN,"CH",LRIDT,1,M))
if 'M!(LRYESCOM)
QUIT
FOR N=1:1:$LENGTH(^LR(LRDFN,"CH",LRIDT,1,M,0))
if LRYESCOM
QUIT
if $EXTRACT(^(0),N)'[$CHAR(32)
SET LRYESCOM=1
+2 if 'LRYESCOM
QUIT
+3 SET ^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRIIDT,"TX",0)="^^1^1^"_LRIIDT
+4 SET L=0
FOR
SET L=$ORDER(^LR(LRDFN,"CH",LRIDT,1,L))
if 'L
QUIT
SET ^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRIIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
+5 IF +LRIPG<0
SET ^LAC(LRXLR,LRDFN,1,LRMH,1,LRSH,1,LRIIDT,"TX",.1,0)="ATTENTION: This data has been modified from previously reported results!!! "
+6 QUIT
LRCALE ;from LRAC1, LRACM2, LRACM3
+1 SET A7=0
FOR
SET A7=$ORDER(^LAB(64.5,1,1,A7))
if A7<1
QUIT
SET B3=0
FOR
SET B3=$ORDER(^LAB(64.5,1,1,A7,1,B3))
if B3<1
QUIT
if $PIECE(^LAB(64.5,1,1,A7,1,B3,0),U,4)
SET LRCALE(A7,B3)=1
+2 KILL A7,B3
QUIT
