LRRP ;DALOI/STAFF - PROCESS DATA FOR INTERIM REPORTS; Oct 28, 2024@13:58
;;5.2;LAB SERVICE;**195,221,283,286,350,577**;Sep 27, 1994;Build 1
;
SET ;from LRRSP, LRRS, LRRD - call with LRORDER=ORDERS, LRODT=DATE, LRDFN
K ^TMP("LR",$J,"TP"),LRORD
S:'$D(LRTSCRN) LRTSCRN=0
S LRLAB=$S($D(LRLABKY):1,1:0),LRHF=1,LRFOOT=0,LRCW=8 Q:'$D(LRODT)
F LROP=1:1 S LRORD(1)=$P(LRORDER,U,LROP) D TEST Q:LRSTOP!LREND!(LRORD(1)="")
I 'LREND,'LRSTOP,LRFOOT D FOOT^LRRP1
K ^TMP("LR",$J,"TP"),LRORD
Q
;
;
TEST ;
I LRORD(1)="" K ^TMP("LR",$J,"TP") Q
S LRFOUND=1,LRORD=$S($D(^LRO(69,LRODT,1,LRORD(1),0))#2:^(0),1:"") Q:LRORD=""!(+LRORD'=LRDFN)
K S,LRAAO
S LRTEST=0
F S LRTEST=+$O(^LRO(69,LRODT,1,LRORD(1),2,LRTEST)) Q:LRTEST<1 S X=^(LRTEST,0) I LRTSCRN=0!(LRTSCRN=+X) D DATA K S
K S Q:'$D(LRAAO) Q:LRAAO<.1
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX
S LROC=$S($D(^LR(LRDFN,.1)):^(.1),LRDPF=2&$D(^DPT(DFN,.1)):^(.1),1:"FILE ROOM")
D ^LRRP1
Q
;
;
DATA ;
S LRTSTS=+X,LRAD=$P(X,U,3),LRAA=+$P(X,U,4),LRAN=$P(X,U,5)
S LRAAO=$S($D(^LRO(68,LRAA,0)):$P(^(0),U,8),1:0)
I LRAAO<.1 Q:'LRAA D Q
. W !?2,$C(7),$P(^LRO(68,LRAA,0),"^")_" accession area is missing a print order!"
. W !?2,$P(^LAB(60,LRTSTS,0),"^")_" results will not be displayed until this is corrected."
. W !?2,"Please contact IRM or the Lab ADPAC."
S LRSS=$P(^LRO(68,LRAA,0),U,2)
Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) Q:'$D(^(3))
S ^TMP("LR",$J,"TP",LRAAO)=LRAA_U_LRSS
S LRCDT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U)
S LRIDT=+$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5)
I 'LRIDT S LRIDT=9999999-LRCDT
S ^TMP("LR",$J,"TP",LRAAO,LRCDT,-1)=$S($D(^TMP("LR",$J,"TP",LRAAO,-1)):^(-1),1:"")_LRTSTS_U
S ^TMP("LR",$J,"TP",LRAAO,LRCDT,-2)=LRIDT
Q:LRSS="MI"
S (S,J)=0
F S J=+$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,J)) Q:J<1 S:^(J,0)>0 S=S+1,S(S)=+^(0)
S LR0=$S($D(^LR(LRDFN,LRSS,LRIDT,0)):^(0),1:""),LRSPEC=+$P(LR0,U,5),(LRTC,LRLLT)=0
F S LRLLT=+$O(S(LRLLT)) Q:LRLLT<1 S LRTSTS=+S(LRLLT) D XPND
D CMNT
Q
;
;
XPND ;
Q:'$D(^LAB(60,LRTSTS,.1)) S LRDN=$P($P(^(0),U,5),";",2)
I LRDN="" S LRJJ=0 F S LRJJ=+$O(^LAB(60,LRTSTS,2,LRJJ)) Q:LRJJ<1 S S=S+1,S(S)=+^(LRJJ,0)
D:$L(LRDN) SETUP
Q
;
;
SETUP Q:'LRTSTS
S X=$G(^LAB(60,LRTSTS,.1))
I 'LRLAB,"BO"'[$P(^LAB(60,LRTSTS,0),U,3) Q
Q:'$D(^LR(LRDFN,LRSS,LRIDT,LRDN)) Q:'$L($P(^(LRDN),U))
S LRPO=$P(X,U,6),LRPO=$S(LRPO:LRPO,1:LRDN/1000000)
F Q:'$D(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO)) Q:LRTSTS=+^(LRPO) S LRPO=LRPO+1
Q:$D(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO))
S ^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO)=LRTSTS_U_$P(^LAB(60,LRTSTS,0),U)_U_$P(X,U)_U_$P(X,U,2)_U_$P(X,U,3)_U_$P(^(0),U,5)_U_$P(^LR(LRDFN,LRSS,LRIDT,LRDN),U)_U_$P(^(LRDN),U,2)_U_$P(^(LRDN),U,9)_U_LRDN,LRTC=LRTC+1
;
I $D(^LAB(60,LRTSTS,1,LRSPEC,1,0)) D
. S LRINTP=0
. F S LRINTP=+$O(^LAB(60,LRTSTS,1,LRSPEC,1,LRINTP)) Q:LRINTP<1 S ^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO,LRINTP)=^(LRINTP,0) S LRTC=LRTC+1
Q
;
;
CMNT ;
S ^TMP("LR",$J,"TP",LRAAO)=LRAA_U_LRSS,^(LRAAO,LRCDT)=LR0,^(LRCDT,-1)=""
S ^TMP("LR",$J,"TP",LRAAO,LRCDT,-2)=LRIDT
;
S LRCMNT=0 F I=0:0 S LRCMNT=+$O(^LR(LRDFN,LRSS,LRIDT,1,LRCMNT)) Q:LRCMNT<1 S ^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)=^(LRCMNT,0) S LRTC=LRTC+1
S $P(^TMP("LR",$J,"TP",LRAAO,LRCDT),U,12)=LRTC
Q
;
;
CH ;from LRRP2
S LRDN=1
F S LRDN=$O(^LR(LRDFN,"CH",LRIDT,LRDN)) Q:LRDN<1 S LRTSTS=$O(^LAB(60,"C","CH;"_LRDN_";1",0)) D SETUP
D CMNT,^LRRP1
Q
;
;
GO ;from LRRP3
S LRLAB=$S($D(LRLABKY):1,1:0),LRDN=1
F S LRDN=$O(^TMP("LR",$J,"TMP",LRDN)) Q:LRDN<1 S LRTSTS=+^(LRDN) D SETUP
D CMNT,^LRRP1
Q
;
;
LOOKUP ; Lookup results by accession
;
N %ZIS,DIR,DIROUT,DIRUT,LRAA,LRACC,LRAD,LRAN,LRDFN,LRDPF,LREND,LRIDT,LRLAB,LRPRTPG,LRSS,LRSTOP,LRVBY,X,Y,ZTDESC,ZTRTN,ZTSAVE,LRADDRESS
;
;ZEXCEPT: CH,MI
;
; Ask if printing address page
S DIR(0)="Y",DIR("A")="Print address page",DIR("B")="NO",LRADDRESS=0
D ^DIR K DIR
I $D(DIRUT) Q
I Y S LRADDRESS=1
;
F D Q:LREND!LRSTOP
. S (LREND,LRSTOP,LRVBY)=0
. S LRACC="" D ^LRWU4
. I LRAN<1 S LREND=1 Q
. I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W !,"Doesn't exist." Q
. K LRDFN,LRDPF,LRIDT,LRSS
. S LRSS=$P(^LRO(68,LRAA,0),"^",2),LRDFN=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^"),LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
. I LRSS=""!(LRIDT<1)!(LRDFN<1) W !,"Incomplete accession - unable to identify results." Q
. I LRSS'?1(1"CH",1"MI") W !,"This option only supports CH and MI subscripted accessions." Q
. S LRPRTPG=LRADDRESS
. S %ZIS="Q",ZTSAVE("DFN")="",ZTSAVE("LR*")="",ZTRTN="ADQ^LRRP",ZTDESC="Interim Report for an Accession"
. D IO^LRWU
. W !!
;
Q
;
;
ADQ ; Tasked entry point to print interim report for an accession
;
;
U IO
N LREND,LRLAB,LRSTOP
D INIT^LRRP2,PT^LRX
S LRLAB=$S($D(LRLABKY):1,1:0)
I LRSS="CH" D CH^LRRP2
I LRSS="MI" D MI^LRRP2
D FOOT^LRRP1
I $G(LRPRTPG),$D(LRPLS) D PLSPG^LRRP2
D QUIT^LRRP2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRRP 4954 printed Sep 23, 2025@19:55:29 Page 2
LRRP ;DALOI/STAFF - PROCESS DATA FOR INTERIM REPORTS; Oct 28, 2024@13:58
+1 ;;5.2;LAB SERVICE;**195,221,283,286,350,577**;Sep 27, 1994;Build 1
+2 ;
SET ;from LRRSP, LRRS, LRRD - call with LRORDER=ORDERS, LRODT=DATE, LRDFN
+1 KILL ^TMP("LR",$JOB,"TP"),LRORD
+2 if '$DATA(LRTSCRN)
SET LRTSCRN=0
+3 SET LRLAB=$SELECT($DATA(LRLABKY):1,1:0)
SET LRHF=1
SET LRFOOT=0
SET LRCW=8
if '$DATA(LRODT)
QUIT
+4 FOR LROP=1:1
SET LRORD(1)=$PIECE(LRORDER,U,LROP)
DO TEST
if LRSTOP!LREND!(LRORD(1)="")
QUIT
+5 IF 'LREND
IF 'LRSTOP
IF LRFOOT
DO FOOT^LRRP1
+6 KILL ^TMP("LR",$JOB,"TP"),LRORD
+7 QUIT
+8 ;
+9 ;
TEST ;
+1 IF LRORD(1)=""
KILL ^TMP("LR",$JOB,"TP")
QUIT
+2 SET LRFOUND=1
SET LRORD=$SELECT($DATA(^LRO(69,LRODT,1,LRORD(1),0))#2:^(0),1:"")
if LRORD=""!(+LRORD'=LRDFN)
QUIT
+3 KILL S,LRAAO
+4 SET LRTEST=0
+5 FOR
SET LRTEST=+$ORDER(^LRO(69,LRODT,1,LRORD(1),2,LRTEST))
if LRTEST<1
QUIT
SET X=^(LRTEST,0)
IF LRTSCRN=0!(LRTSCRN=+X)
DO DATA
KILL S
+6 KILL S
if '$DATA(LRAAO)
QUIT
if LRAAO<.1
QUIT
+7 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
+8 SET LROC=$SELECT($DATA(^LR(LRDFN,.1)):^(.1),LRDPF=2&$DATA(^DPT(DFN,.1)):^(.1),1:"FILE ROOM")
+9 DO ^LRRP1
+10 QUIT
+11 ;
+12 ;
DATA ;
+1 SET LRTSTS=+X
SET LRAD=$PIECE(X,U,3)
SET LRAA=+$PIECE(X,U,4)
SET LRAN=$PIECE(X,U,5)
+2 SET LRAAO=$SELECT($DATA(^LRO(68,LRAA,0)):$PIECE(^(0),U,8),1:0)
+3 IF LRAAO<.1
if 'LRAA
QUIT
Begin DoDot:1
+4 WRITE !?2,$CHAR(7),$PIECE(^LRO(68,LRAA,0),"^")_" accession area is missing a print order!"
+5 WRITE !?2,$PIECE(^LAB(60,LRTSTS,0),"^")_" results will not be displayed until this is corrected."
+6 WRITE !?2,"Please contact IRM or the Lab ADPAC."
End DoDot:1
QUIT
+7 SET LRSS=$PIECE(^LRO(68,LRAA,0),U,2)
+8 if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
QUIT
if '$DATA(^(3))
QUIT
+9 SET ^TMP("LR",$JOB,"TP",LRAAO)=LRAA_U_LRSS
+10 SET LRCDT=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U)
+11 SET LRIDT=+$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5)
+12 IF 'LRIDT
SET LRIDT=9999999-LRCDT
+13 SET ^TMP("LR",$JOB,"TP",LRAAO,LRCDT,-1)=$SELECT($DATA(^TMP("LR",$JOB,"TP",LRAAO,-1)):^(-1),1:"")_LRTSTS_U
+14 SET ^TMP("LR",$JOB,"TP",LRAAO,LRCDT,-2)=LRIDT
+15 if LRSS="MI"
QUIT
+16 SET (S,J)=0
+17 FOR
SET J=+$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,J))
if J<1
QUIT
if ^(J,0)>0
SET S=S+1
SET S(S)=+^(0)
+18 SET LR0=$SELECT($DATA(^LR(LRDFN,LRSS,LRIDT,0)):^(0),1:"")
SET LRSPEC=+$PIECE(LR0,U,5)
SET (LRTC,LRLLT)=0
+19 FOR
SET LRLLT=+$ORDER(S(LRLLT))
if LRLLT<1
QUIT
SET LRTSTS=+S(LRLLT)
DO XPND
+20 DO CMNT
+21 QUIT
+22 ;
+23 ;
XPND ;
+1 if '$DATA(^LAB(60,LRTSTS,.1))
QUIT
SET LRDN=$PIECE($PIECE(^(0),U,5),";",2)
+2 IF LRDN=""
SET LRJJ=0
FOR
SET LRJJ=+$ORDER(^LAB(60,LRTSTS,2,LRJJ))
if LRJJ<1
QUIT
SET S=S+1
SET S(S)=+^(LRJJ,0)
+3 if $LENGTH(LRDN)
DO SETUP
+4 QUIT
+5 ;
+6 ;
SETUP if 'LRTSTS
QUIT
+1 SET X=$GET(^LAB(60,LRTSTS,.1))
+2 IF 'LRLAB
IF "BO"'[$PIECE(^LAB(60,LRTSTS,0),U,3)
QUIT
+3 if '$DATA(^LR(LRDFN,LRSS,LRIDT,LRDN))
QUIT
if '$LENGTH($PIECE(^(LRDN),U))
QUIT
+4 SET LRPO=$PIECE(X,U,6)
SET LRPO=$SELECT(LRPO:LRPO,1:LRDN/1000000)
+5 FOR
if '$DATA(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO))
QUIT
if LRTSTS=+^(LRPO)
QUIT
SET LRPO=LRPO+1
+6 if $DATA(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO))
QUIT
+7 SET ^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO)=LRTSTS_U_$PIECE(^LAB(60,LRTSTS,0),U)_U_$PIECE(X,U)_U_$PIECE(X,U,2)_U_$PIECE(X,U,3)_U_$PIECE(^(0),U,5)_U_$PIECE(^LR(LRDFN,LRSS,LRIDT,LRDN),U)_U_$PIECE(^(LRDN),U,2)_U_$PIECE(^(LRDN),U,9)_U_LRDN
SET LRTC=LRTC+1
+8 ;
+9 IF $DATA(^LAB(60,LRTSTS,1,LRSPEC,1,0))
Begin DoDot:1
+10 SET LRINTP=0
+11 FOR
SET LRINTP=+$ORDER(^LAB(60,LRTSTS,1,LRSPEC,1,LRINTP))
if LRINTP<1
QUIT
SET ^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO,LRINTP)=^(LRINTP,0)
SET LRTC=LRTC+1
End DoDot:1
+12 QUIT
+13 ;
+14 ;
CMNT ;
+1 SET ^TMP("LR",$JOB,"TP",LRAAO)=LRAA_U_LRSS
SET ^(LRAAO,LRCDT)=LR0
SET ^(LRCDT,-1)=""
+2 SET ^TMP("LR",$JOB,"TP",LRAAO,LRCDT,-2)=LRIDT
+3 ;
+4 SET LRCMNT=0
FOR I=0:0
SET LRCMNT=+$ORDER(^LR(LRDFN,LRSS,LRIDT,1,LRCMNT))
if LRCMNT<1
QUIT
SET ^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT)=^(LRCMNT,0)
SET LRTC=LRTC+1
+5 SET $PIECE(^TMP("LR",$JOB,"TP",LRAAO,LRCDT),U,12)=LRTC
+6 QUIT
+7 ;
+8 ;
CH ;from LRRP2
+1 SET LRDN=1
+2 FOR
SET LRDN=$ORDER(^LR(LRDFN,"CH",LRIDT,LRDN))
if LRDN<1
QUIT
SET LRTSTS=$ORDER(^LAB(60,"C","CH;"_LRDN_";1",0))
DO SETUP
+3 DO CMNT
DO ^LRRP1
+4 QUIT
+5 ;
+6 ;
GO ;from LRRP3
+1 SET LRLAB=$SELECT($DATA(LRLABKY):1,1:0)
SET LRDN=1
+2 FOR
SET LRDN=$ORDER(^TMP("LR",$JOB,"TMP",LRDN))
if LRDN<1
QUIT
SET LRTSTS=+^(LRDN)
DO SETUP
+3 DO CMNT
DO ^LRRP1
+4 QUIT
+5 ;
+6 ;
LOOKUP ; Lookup results by accession
+1 ;
+2 NEW %ZIS,DIR,DIROUT,DIRUT,LRAA,LRACC,LRAD,LRAN,LRDFN,LRDPF,LREND,LRIDT,LRLAB,LRPRTPG,LRSS,LRSTOP,LRVBY,X,Y,ZTDESC,ZTRTN,ZTSAVE,LRADDRESS
+3 ;
+4 ;ZEXCEPT: CH,MI
+5 ;
+6 ; Ask if printing address page
+7 SET DIR(0)="Y"
SET DIR("A")="Print address page"
SET DIR("B")="NO"
SET LRADDRESS=0
+8 DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)
QUIT
+10 IF Y
SET LRADDRESS=1
+11 ;
+12 FOR
Begin DoDot:1
+13 SET (LREND,LRSTOP,LRVBY)=0
+14 SET LRACC=""
DO ^LRWU4
+15 IF LRAN<1
SET LREND=1
QUIT
+16 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
WRITE !,"Doesn't exist."
QUIT
+17 KILL LRDFN,LRDPF,LRIDT,LRSS
+18 SET LRSS=$PIECE(^LRO(68,LRAA,0),"^",2)
SET LRDFN=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^")
SET LRIDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
+19 IF LRSS=""!(LRIDT<1)!(LRDFN<1)
WRITE !,"Incomplete accession - unable to identify results."
QUIT
+20 IF LRSS'?1(1"CH",1"MI")
WRITE !,"This option only supports CH and MI subscripted accessions."
QUIT
+21 SET LRPRTPG=LRADDRESS
+22 SET %ZIS="Q"
SET ZTSAVE("DFN")=""
SET ZTSAVE("LR*")=""
SET ZTRTN="ADQ^LRRP"
SET ZTDESC="Interim Report for an Accession"
+23 DO IO^LRWU
+24 WRITE !!
End DoDot:1
if LREND!LRSTOP
QUIT
+25 ;
+26 QUIT
+27 ;
+28 ;
ADQ ; Tasked entry point to print interim report for an accession
+1 ;
+2 ;
+3 USE IO
+4 NEW LREND,LRLAB,LRSTOP
+5 DO INIT^LRRP2
DO PT^LRX
+6 SET LRLAB=$SELECT($DATA(LRLABKY):1,1:0)
+7 IF LRSS="CH"
DO CH^LRRP2
+8 IF LRSS="MI"
DO MI^LRRP2
+9 DO FOOT^LRRP1
+10 IF $GET(LRPRTPG)
IF $DATA(LRPLS)
DO PLSPG^LRRP2
+11 DO QUIT^LRRP2
+12 QUIT
