LRSORA3 ;SLC/KCM - SEARCH LAB DATA AND PRINT REPORT ;8/28/89 12:07 ;
;;5.2;LAB SERVICE;**1,344,449**;Sep 27, 1994;Build 4
BUILD ;
S LRLOG="I "
F %=1:1:$L(LRTST(0)) D
. S LRLOG=LRLOG_$S($E(LRTST(0),%)?1A:"T("_($A(LRTST(0),%)-64)_")",1:$E(LRTST(0),%))
S LRDFN=0,LRLDFN=0,LREND=0
D SHORT:'LRLONG,LONG:LRLONG
Q
SHORT ;
S LRVDT=$P(LREDT,".",1)-.01
F S LRVDT=$O(^LRO(69,LRVDT)) Q:LRVDT=""!(LRVDT>LRSDT) D
. S LRLLOC=""
. F S LRLLOC=$O(^LRO(69,LRVDT,1,"AN",LRLLOC)) Q:LRLLOC="" D
.. S LRDFN=0
.. F S LRDFN=$O(^LRO(69,LRVDT,1,"AN",LRLLOC,LRDFN)) Q:LRDFN<1 D GIDT
Q
GIDT ;
S LRIDT=0
F S LRIDT=$O(^LRO(69,LRVDT,1,"AN",LRLLOC,LRDFN,LRIDT)) Q:LRIDT<1 D EVTW
Q
LONG ;
S LRSDT=$S($L(LRSDT,".")=2:LRSDT+.000001,1:LRSDT+1)
S LRSDT=9999999-LRSDT,LREDT=9999999-LREDT
S LRDFN=0 F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D GDATA
Q
GDATA ;
S LRIDT=LRSDT
F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT=""!(LRIDT>LREDT) D
. D:$L($P(^LR(LRDFN,"CH",LRIDT,0),U,3)) EVTW
Q
EVTW ;
S %=$G(^LR(LRDFN,"CH",LRIDT,0)) Q:'$L(%)
I LRAA S LRAAA=$P($P(%,U,6)," ") Q:'$D(LRAA(LRAAA))#2
K V F J=1:1:LRTST S T(J)=0
D EVAL Q:$G(LRNOP) X LRLOG
I $T S LRIDT1=0 F S LRIDT1=$O(V(LRIDT1)) Q:LRIDT1<1 D
. S LRSUB=0 F S LRSUB=$O(V(LRIDT1,LRSUB)) Q:LRSUB<1 D SET
Q
EVAL ;
F J=1:1:LRTST X LRTST(J,1) D
. I $T S T(J)=1
. I S X=$P(LRTST(J,3),U,1)
. I S $P(V(LRIDT,X),U,1)=$P(^LR(LRDFN,"CH",LRIDT,X),U,1)
. I S $P(V(LRIDT,X),U,2)=$P(^LR(LRDFN,"CH",LRIDT,X),U,2)
. I S $P(V(LRIDT,X),U,3)=$P(LRTST(J,2),U,1)
Q
SET ;
K LRWRD
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) Q:LRDPF<1!(LRDPF=62.3) D PT^LRX
I LRPTS Q:'$D(LRPTS(DFN))
S %=^LR(LRDFN,"CH",LRIDT1,0),LRAN=$P(^(0),U,6),LRLOC=$P(^(0),U,11)
Q:LRLOC="" I LRLCS Q:'$D(LRLCS(LRLOC))
;S LRWRD="" S:LRDPF=2 LRWRD=$S($D(^DPT(DFN,.1)):^(.1),1:"")
S LRWRD=$G(^DPT(DFN,.1))
S (Y1,LRDAT)=$P(^LR(LRDFN,"CH",LRIDT1,0),U,1),Y2=1
S LRCDT=$$DDDATE^LRAFUNC1(Y1,Y2) K Y1,Y2
S LRSUB1=$S(LRSRT="P":PNM_SSN,1:LRLOC)
S LRSUB2=$S(LRSRT="P":LRDAT,1:PNM_SSN)
S LRSUB3=$S(LRSRT="P":LRLOC,1:LRDAT)
S LRSPEC=$P(^LR(LRDFN,"CH",LRIDT1,0),U,5) D RRNG
S LRSPEC=$P($G(^LAB(61,LRSPEC,0)),U)
S LRTEST=LRTSTX
S LRVAL=$P(V(LRIDT1,LRSUB),U)
S LRMRK=$P(V(LRIDT1,LRSUB),U,2)
I LRSRT="P" S ^TMP("LR",$J,LRSUB1,LRSPEC,LRTEST,LRIDT)=PNM_U_SSN_U_LRLOC_U_U_LRSPEC_U_U_LRLO_U_LRHI_U_LRVAL_U_LRMRK_U_LRTHER_U_LRWRD_U_LRAN_U_LRDAT_U_LRTEST_U_LRUNITS
I LRSRT'="P" S ^TMP("LR",$J,LRLOC,LRSUB2,LRSPEC,LRTEST,LRIDT)=PNM_U_SSN_U_LRLOC_U_U_LRSPEC_U_U_LRLO_U_LRHI_U_LRVAL_U_LRMRK_U_LRTHER_U_LRWRD_U_LRAN_U_LRDAT_U_LRTEST_U_LRUNITS
S C=0
F S C=$O(^LR(LRDFN,"CH",LRIDT,1,C)) Q:'C D
. I LRSRT="P" S ^TMP("LR",$J,LRSUB1,LRSPEC,LRTEST,LRIDT,"COM",C)=^LR(LRDFN,"CH",LRIDT,1,C,0)
. I LRSRT'="P" S ^TMP("LR",$J,LRLOC,LRSUB2,LRSPEC,LRTEST,LRIDT,"COM",C)=^LR(LRDFN,"CH",LRIDT,1,C,0)
Q
RRNG ;
N LRFLAG
S (LRHI,LRLO,LRTHER,LRFLAG)="",X="CH;"_LRSUB_";1",X=$O(^LAB(60,"C",X,0))
S LRTSTX=$P(^LAB(60,X,.1),U)
S LRUNITS=$P($G(^LAB(60,X,1,LRSPEC,0)),"^",7)
S:$L(X)&$L(LRSPEC) X=$S($D(^LAB(60,X,1,LRSPEC,0)):^(0),1:"") Q:X=""
;
; check for ranges in file 63
D CHK63
;check for units stored with results and update LRUNITS
I $P(X,"^",7)'="" S LRUNITS=$P(X,"^",7)
;
S LRTHER=$P(X,U,11)'=""&($P(X,U,12)'="")
S LRLO=$S('LRTHER:$P(X,U,2),1:$P(X,U,11))
S LRHI=$S('LRTHER:$P(X,U,3),1:$P(X,U,12))
I 'LRFLAG D
. S @("LRLO="_$S($L(LRLO):LRLO,1:""""""))
. S @("LRHI="_$S($L(LRHI):LRHI,1:""""""))
Q
;
CHK63 ;
N LR63DAT,PC5
S LR63DAT=$G(^LR(LRDFN,"CH",LRIDT,LRSUB))
I $G(^LR(LRDFN,"CH",LRIDT,"NPC"))>1,$P(LR63DAT,U,5,12)'="" S LRFLAG=1
I LRFLAG D
.S PC5=$P(LR63DAT,U,5)
.S PC5=$TR(PC5,"!","^")
.S X=PC5
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSORA3 3725 printed Oct 16, 2024@18:21:13 Page 2
LRSORA3 ;SLC/KCM - SEARCH LAB DATA AND PRINT REPORT ;8/28/89 12:07 ;
+1 ;;5.2;LAB SERVICE;**1,344,449**;Sep 27, 1994;Build 4
BUILD ;
+1 SET LRLOG="I "
+2 FOR %=1:1:$LENGTH(LRTST(0))
Begin DoDot:1
+3 SET LRLOG=LRLOG_$SELECT($EXTRACT(LRTST(0),%)?1A:"T("_($ASCII(LRTST(0),%)-64)_")",1:$EXTRACT(LRTST(0),%))
End DoDot:1
+4 SET LRDFN=0
SET LRLDFN=0
SET LREND=0
+5 if 'LRLONG
DO SHORT
if LRLONG
DO LONG
+6 QUIT
SHORT ;
+1 SET LRVDT=$PIECE(LREDT,".",1)-.01
+2 FOR
SET LRVDT=$ORDER(^LRO(69,LRVDT))
if LRVDT=""!(LRVDT>LRSDT)
QUIT
Begin DoDot:1
+3 SET LRLLOC=""
+4 FOR
SET LRLLOC=$ORDER(^LRO(69,LRVDT,1,"AN",LRLLOC))
if LRLLOC=""
QUIT
Begin DoDot:2
+5 SET LRDFN=0
+6 FOR
SET LRDFN=$ORDER(^LRO(69,LRVDT,1,"AN",LRLLOC,LRDFN))
if LRDFN<1
QUIT
DO GIDT
End DoDot:2
End DoDot:1
+7 QUIT
GIDT ;
+1 SET LRIDT=0
+2 FOR
SET LRIDT=$ORDER(^LRO(69,LRVDT,1,"AN",LRLLOC,LRDFN,LRIDT))
if LRIDT<1
QUIT
DO EVTW
+3 QUIT
LONG ;
+1 SET LRSDT=$SELECT($LENGTH(LRSDT,".")=2:LRSDT+.000001,1:LRSDT+1)
+2 SET LRSDT=9999999-LRSDT
SET LREDT=9999999-LREDT
+3 SET LRDFN=0
FOR
SET LRDFN=$ORDER(^LR(LRDFN))
if LRDFN<1
QUIT
DO GDATA
+4 QUIT
GDATA ;
+1 SET LRIDT=LRSDT
+2 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
if LRIDT=""!(LRIDT>LREDT)
QUIT
Begin DoDot:1
+3 if $LENGTH($PIECE(^LR(LRDFN,"CH",LRIDT,0),U,3))
DO EVTW
End DoDot:1
+4 QUIT
EVTW ;
+1 SET %=$GET(^LR(LRDFN,"CH",LRIDT,0))
if '$LENGTH(%)
QUIT
+2 IF LRAA
SET LRAAA=$PIECE($PIECE(%,U,6)," ")
if '$DATA(LRAA(LRAAA))#2
QUIT
+3 KILL V
FOR J=1:1:LRTST
SET T(J)=0
+4 DO EVAL
if $GET(LRNOP)
QUIT
XECUTE LRLOG
+5 IF $TEST
SET LRIDT1=0
FOR
SET LRIDT1=$ORDER(V(LRIDT1))
if LRIDT1<1
QUIT
Begin DoDot:1
+6 SET LRSUB=0
FOR
SET LRSUB=$ORDER(V(LRIDT1,LRSUB))
if LRSUB<1
QUIT
DO SET
End DoDot:1
+7 QUIT
EVAL ;
+1 FOR J=1:1:LRTST
XECUTE LRTST(J,1)
Begin DoDot:1
+2 IF $TEST
SET T(J)=1
+3 IF $TEST
SET X=$PIECE(LRTST(J,3),U,1)
+4 IF $TEST
SET $PIECE(V(LRIDT,X),U,1)=$PIECE(^LR(LRDFN,"CH",LRIDT,X),U,1)
+5 IF $TEST
SET $PIECE(V(LRIDT,X),U,2)=$PIECE(^LR(LRDFN,"CH",LRIDT,X),U,2)
+6 IF $TEST
SET $PIECE(V(LRIDT,X),U,3)=$PIECE(LRTST(J,2),U,1)
End DoDot:1
+7 QUIT
SET ;
+1 KILL LRWRD
+2 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
if LRDPF<1!(LRDPF=62.3)
QUIT
DO PT^LRX
+3 IF LRPTS
if '$DATA(LRPTS(DFN))
QUIT
+4 SET %=^LR(LRDFN,"CH",LRIDT1,0)
SET LRAN=$PIECE(^(0),U,6)
SET LRLOC=$PIECE(^(0),U,11)
+5 if LRLOC=""
QUIT
IF LRLCS
if '$DATA(LRLCS(LRLOC))
QUIT
+6 ;S LRWRD="" S:LRDPF=2 LRWRD=$S($D(^DPT(DFN,.1)):^(.1),1:"")
+7 SET LRWRD=$GET(^DPT(DFN,.1))
+8 SET (Y1,LRDAT)=$PIECE(^LR(LRDFN,"CH",LRIDT1,0),U,1)
SET Y2=1
+9 SET LRCDT=$$DDDATE^LRAFUNC1(Y1,Y2)
KILL Y1,Y2
+10 SET LRSUB1=$SELECT(LRSRT="P":PNM_SSN,1:LRLOC)
+11 SET LRSUB2=$SELECT(LRSRT="P":LRDAT,1:PNM_SSN)
+12 SET LRSUB3=$SELECT(LRSRT="P":LRLOC,1:LRDAT)
+13 SET LRSPEC=$PIECE(^LR(LRDFN,"CH",LRIDT1,0),U,5)
DO RRNG
+14 SET LRSPEC=$PIECE($GET(^LAB(61,LRSPEC,0)),U)
+15 SET LRTEST=LRTSTX
+16 SET LRVAL=$PIECE(V(LRIDT1,LRSUB),U)
+17 SET LRMRK=$PIECE(V(LRIDT1,LRSUB),U,2)
+18 IF LRSRT="P"
SET ^TMP("LR",$JOB,LRSUB1,LRSPEC,LRTEST,LRIDT)=PNM_U_SSN_U_LRLOC_U_U_LRSPEC_U_U_LRLO_U_LRHI_U_LRVAL_U_LRMRK_U_LRTHER_U_LRWRD_U_LRAN_U_LRDAT_U_LRTEST_U_LRUNITS
+19 IF LRSRT'="P"
SET ^TMP("LR",$JOB,LRLOC,LRSUB2,LRSPEC,LRTEST,LRIDT)=PNM_U_SSN_U_LRLOC_U_U_LRSPEC_U_U_LRLO_U_LRHI_U_LRVAL_U_LRMRK_U_LRTHER_U_LRWRD_U_LRAN_U_LRDAT_U_LRTEST_U_LRUNITS
+20 SET C=0
+21 FOR
SET C=$ORDER(^LR(LRDFN,"CH",LRIDT,1,C))
if 'C
QUIT
Begin DoDot:1
+22 IF LRSRT="P"
SET ^TMP("LR",$JOB,LRSUB1,LRSPEC,LRTEST,LRIDT,"COM",C)=^LR(LRDFN,"CH",LRIDT,1,C,0)
+23 IF LRSRT'="P"
SET ^TMP("LR",$JOB,LRLOC,LRSUB2,LRSPEC,LRTEST,LRIDT,"COM",C)=^LR(LRDFN,"CH",LRIDT,1,C,0)
End DoDot:1
+24 QUIT
RRNG ;
+1 NEW LRFLAG
+2 SET (LRHI,LRLO,LRTHER,LRFLAG)=""
SET X="CH;"_LRSUB_";1"
SET X=$ORDER(^LAB(60,"C",X,0))
+3 SET LRTSTX=$PIECE(^LAB(60,X,.1),U)
+4 SET LRUNITS=$PIECE($GET(^LAB(60,X,1,LRSPEC,0)),"^",7)
+5 if $LENGTH(X)&$LENGTH(LRSPEC)
SET X=$SELECT($DATA(^LAB(60,X,1,LRSPEC,0)):^(0),1:"")
if X=""
QUIT
+6 ;
+7 ; check for ranges in file 63
+8 DO CHK63
+9 ;check for units stored with results and update LRUNITS
+10 IF $PIECE(X,"^",7)'=""
SET LRUNITS=$PIECE(X,"^",7)
+11 ;
+12 SET LRTHER=$PIECE(X,U,11)'=""&($PIECE(X,U,12)'="")
+13 SET LRLO=$SELECT('LRTHER:$PIECE(X,U,2),1:$PIECE(X,U,11))
+14 SET LRHI=$SELECT('LRTHER:$PIECE(X,U,3),1:$PIECE(X,U,12))
+15 IF 'LRFLAG
Begin DoDot:1
+16 SET @("LRLO="_$SELECT($LENGTH(LRLO):LRLO,1:""""""))
+17 SET @("LRHI="_$SELECT($LENGTH(LRHI):LRHI,1:""""""))
End DoDot:1
+18 QUIT
+19 ;
CHK63 ;
+1 NEW LR63DAT,PC5
+2 SET LR63DAT=$GET(^LR(LRDFN,"CH",LRIDT,LRSUB))
+3 IF $GET(^LR(LRDFN,"CH",LRIDT,"NPC"))>1
IF $PIECE(LR63DAT,U,5,12)'=""
SET LRFLAG=1
+4 IF LRFLAG
Begin DoDot:1
+5 SET PC5=$PIECE(LR63DAT,U,5)
+6 SET PC5=$TRANSLATE(PC5,"!","^")
+7 SET X=PC5
End DoDot:1
+8 QUIT
