LRMIPSZ1 ;DALOI/STAFF - MICRO PATIENT REPORT ;Aug 14, 2019@10:00
;;5.2;LAB SERVICE;**283,350,520,536**;Sep 27, 1994;Build 18
;
;
DQ ;tasked from LRTASK from IMMEDIATE INTERIM REPORTING thru LRTP
;
S LRPATLOC=$G(LRLLOC),LRIDT=$G(LRIDT,0),LRSS="MI",LRONETST="",LRONESPC="",LREND=0
D EN^LRPARAM
S LRLLT=^LR(LRDFN,"MI",LRIDT,0),LRACC=$P(LRLLT,U,6),LRAD=$E(LRLLT)_$P(LRACC," ",2)_"0000"
S X=$P(LRACC," "),DIC=68,DIC(0)="M"
I X'="" D ^DIC S LRAA=+Y,LRAN=+$P(LRACC," ",3)
;
; ^TMP("LRMI",$J,LRDFN,"MI",LRIDT) will already exist if this is a LEDI result being processed (rtn LRVRMI1)
I '$D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT)) D
. M ^TMP("LRMI",$J,LRDFN,"MI",LRIDT)=^LR(LRDFN,"MI",LRIDT)
. K ^TMP("LRMI",$J,LRDFN,"MI",LRIDT,32)
;
S LRCMNT=$G(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,99))
S LRPG=0
D EN
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
;
EN ;
; from LRMINEW2, LRMIPC, LRMIPLOG, LRMIPSZ, LRMIVER1
; ^TMP("LRMI",$J,LRDFN,"MI",LRIDT) will already exist if this is a LEDI result being processed (rtn LRVRMI1)
I '$D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT)) D ;
. M ^TMP("LRMI",$J,LRDFN,"MI",LRIDT)=^LR(LRDFN,"MI",LRIDT)
. K ^TMP("LRMI",$J,LRDFN,"MI",LRIDT,32)
;
S LRUID=$P($G(^LR(LRDFN,"MI",LRIDT,"ORU")),U)
I '$D(LRONESPC) S LRONESPC="",DIC="^LAB(61,",DIC("A")="Select SPECIMEN/SOURCE: ANY//",DIC(0)="AEMOQ" D ^DIC S:Y>0 LRONESPC=+Y K DIC("A")
I '$D(LRONETST) S LRONETST="",DIC="^LAB(60,",DIC(0)="AEOQ",DIC("S")="I $P(^(0),U,4)=""MI"")"_$S('$D(LRLABKY):",""BO""[$P(^(0),U,3)",1:""),D="E" D IX^DIC Q:Y<1 I Y>0 S LRONETST=+Y
S LRSPEC=$P(LRLLT,U,5) I LRONESPC'="",LRSPEC'=LRONESPC Q
D RPT
I '$G(EAMODE) K ^TMP("LRMI",$J,LRDFN,"MI",LRIDT)
K %,A8,A,AB,B,B1,B2,B3,C,IA,LR1PASS,LR2ORMOR,LRABCNT,LRACNT,LRADM,LRADX,LRAFS,LRAMT,LRAX,LRBN,LRBRR,LRBUG,LRCOMTAB,LRCS,LRDCOM,LRDOC,LRDRTM1,LRDRTM2,LREF,LRFLIP,LRFMT,LRGRM,LRHC,LRIFN,LRINT,LRPATLOC,LRMYC,LRNS,LRNUM
K LRORG,LRPAR,LRPC,LRPRE,LRPRINT,LRQU,LRRC,LRRES,LRSBC1,LRSBC2,LRSET,LRSIC1,LRSIC2,LRSPEC,LRSSD,LRST,LRTA,LRTB,LRTBA,LRTBC,LRTBS,LRTK,LRTS,LRTSTS,LRTUS,LRUS,LRWRD,N
Q
;
;
RPT ;
;
N LRABORT,LRPGDATA,LRPRNTED,LRDISP
;
; If called by another process, i.e. interim reports, then don't reset current page number
S LRPG=$G(LRPG,0)
;
S LRPGDATA("HDR")="D HDR2^LRMIPSU(.LRPRNTED,.LRABORT,.LRPGDATA)"
S LRPGDATA("BM")=8
S LRPGDATA("FTR")="D FOOT2^LRMIPSU"
; Dont print the footer when console device
I $E($G(IOST),1,2)="C-" D ;
. S LRPGDATA("BM")=0
. S LRPGDATA("FTR")=""
S LRPGDATA("PROMPTX")="S X=$$PROMPT^LRMIPSU()"
S LRPGDATA("ERASE")=1
S LRPGDATA("PGNUM")=0
S LRABORT=0
;
S:'$D(LRSB) LRSB=0
S LRPRINT=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,4)):"",1:1),LRHC=$S($E(IOST,1,2)'="C-":1,1:0),LRFLIP=$S(LRHC:11,1:6)
;
K DIC
D DT^LRX
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
D PT^LRX
S:$G(VAIN(3)) DOB=$P(VADM(3),U) S LRPATLOC=$P(LRLLT,U,8)
S (LRADM,LRADX)=""
I +$G(LRDPF)=2,'$G(VAERR) S LRADM=$P(VAIN(7),U,2),LRADX=VAIN(9)
S LRCS=$S($D(^LAB(62,+$P(LRLLT,U,11),0)):$P(^(0),U),1:"")
S LRTK=$P(LRLLT,U),LRRC=$P(LRLLT,U,10),LRST=$S(LRSPEC:$P(^LAB(61,LRSPEC,0),U),1:"")
S Y=LRTK D D^LRU S LRTK=Y
S Y=LRRC D D^LRU S LRRC=Y
S X=$P(LRLLT,U,7) D DOC^LRX
;
K ^TMP("LR",$J,"T"),LRTSTS
;
S (LRBRR,LRTESTCOMPLE)=0
F S LRBRR=+$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR)) Q:LRBRR<1 D EN1
I 'LRPRINT,LRONETST Q
;
;
D HDR2^LRMIPSU(.LRPRNTED,.LRABORT,.LRPGDATA)
S LREND=LRABORT
Q:LRABORT
; display audit log
D BANNER^LRMIAU2(.LRABORT,.LRPGDATA)
S LREND=LRABORT
Q:LRABORT
;
I $D(^TMP("LR",$J,"T")) D Q:LRABORT
. N J,LRX,LRY,X,Y
. W !?2,"Test(s) ordered:"
. S J=0
. F S J=$O(^TMP("LR",$J,"T",J)) Q:J="" D Q:LRABORT
. . S X=^TMP("LR",$J,"T",J)
. . S LRX=$P(X,"^")
. . I LRTESTCOMPLE S LRX=$$LJ^XLFSTR(LRX,30,".")
. . W ?19,LRX
. . I '$P(X,U,2) W ! D NP Q
. . S Y=$P(X,U,2)
. . ; LR*5.2*520 and LR*5.2*536
. . S LRDISP=$P(X,U,3)
. . D D^LRU S LRY=$S(LRDISP["Not Performed":"canceled: ",1:"completed: ")_Y
. . I (19+$L(LRX)+$L(LRY))>IOM W !
. . W ?50,LRY,! D NP
;
K ^TMP("LR",$J,"T"),LRTSTS W:LRHC !
I $D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,14)) D Q:LRABORT ;
. D NP Q:LRABORT
. D ANTI^LRMIPSZ2
. D NP Q:LRABORT
;
I $D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,1)) D Q:LRABORT ;
. D NP Q:LRABORT
. D BACT^LRMIPSZ2 Q:LREND
. D NP Q:LRABORT
. D REFS^LRMIPSU Q:LREND
. D NP Q:LRABORT
;
I $D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,31)) D Q:LRABORT ;
. D NP Q:LRABORT
. D STER^LRMIPSZ3
. D NP Q:LRABORT
;
I $D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,5)) D Q:LRABORT Q:LREND ;
. D NP Q:LRABORT
. D PARA^LRMIPSZ3
. D NP Q:LRABORT
. D REFS^LRMIPSU
. Q:LREND
. D NP Q:LRABORT
;
I $D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,16)) D Q:LREND Q:LRABORT ;
. D NP Q:LRABORT
. D VIR^LRMIPSZ3
. D REFS^LRMIPSU Q:LREND Q:LRABORT ;
;
I $D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,11)) D Q:LREND Q:LRABORT ;
. D NP Q:LRABORT
. D TB^LRMIPSZ4
. D NP Q:LRABORT
. D REFS^LRMIPSU
. D NP Q:LRABORT
;
I $D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,8)) D Q:LREND Q:LRABORT ;
. D NP Q:LRABORT
. D FUNG^LRMIPSZ4
. D NP Q:LRABORT
. D REFS^LRMIPSU
. Q:LREND Q:LRABORT
;
Q:LRABORT
;
; Print any performing labs listing
I $G(LRMODE)'="LDSI" D PPL
;
; Write last footer if needed
I 'LRABORT,'$G(LRPGDATA("WFTR")) D ;
. I $G(LRPGDATA("FTR"))="" Q
. I $E($G(IOST),1,2)'="C-" D ;
. . N I,BM
. . S BM=$G(LRPGDATA("BM"))
. . F I=$Y+1:1:($G(IOSL,60)-BM-1) W !
. X LRPGDATA("FTR")
;
I 'LRABORT D ;
. N PAD,STR,I,II
. S X=" End of Report ",PAD="+ ",STR=""
. S I=IOM-($L(X)*3),I=I/4/$L(PAD)
. F II=1:1:3 S STR=STR_$$REPEAT^XLFSTR(PAD,I)_X
. S STR=STR_$$REPEAT^XLFSTR(PAD,I)
. W !,$$CJ^XLFSTR(STR,IOM)
. F I=$Y+1:1:($G(IOSL,60)-$G(LRPGDATA("BM"))-1) W !
. S (LRABORT,LREND)=$$MORE^LRUTIL($$PROMPT^LRMIPSU(),0)
. ; LRMLTRPT indicates multi report (set in SENDUP^LRMIPLOG)
. I $G(LRMLTRPT),$E($G(IOST),1,2)="P-",$G(IOF)'="" W @IOF
;
Q
;
;
EN1 ;
; LR*5.2*520 Set disposition to LRDISP
S LRTS=+^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR,0),LRTS(1)=$P(^(0),U,5),LRDISP=$P(^(0),U,6)
Q:'$L($P($G(^LAB(60,LRTS,0)),U,3))
I '$D(LRLABKY),"BO"'[$P($G(^LAB(60,LRTS,0)),U,3) Q
;
; Set flag that at least one test is completed
I LRTS(1) S LRTESTCOMPLE=1
;
S:LRTS=LRONETST LRPRINT=1
S LRTSTS=$S($D(^LAB(60,LRTS,0)):$P(^(0),U),1:"deleted test"),^TMP("LR",$J,"T",$S($D(^LAB(60,LRTS,.1)):$P(^(.1),U,6),1:"")_","_LRBRR)=LRTSTS_U_LRTS(1)_U_LRDISP
Q
;
;
NP ;
; Convenience method
; Some methods in these report routines may be called by a different parent so need to handle this if needed.
I '$D(LRABORT) S LRABORT=0
Q:'$D(LRPGDATA)
D NP^LRUTIL(.LRABORT,.LRPGDATA)
S LRPG=$G(LRPGDATA("PGNUM"),1)
;
; backward compatability (for SENDUP^LRMIPLOG)
S LREND=LRABORT
Q
;
;
PPL ; Print any performing laboratories
;
N LRPL,LRI,LRX,LRY
;
D RETLST^LRRPL(.LRPL,LRDFN,"MI",LRIDT,0)
I $G(LRPL)<1 Q
;
; Start new page if space on existing page too small to display a significant portion of labs
S LRY=IOSL-$Y S:LRY<1 LRY=1
I (LRPL/LRY)>1 D
. F LRI=$Y+1:1:($G(IOSL,60)-$G(LRPGDATA("BM"))-1) W !
. D NP
E S LRX="=--" W !!,$$REPEAT^XLFSTR(LRX,IOM/$L(LRX))
;
W !,"Performing Laboratory:",!
S LRI=0
F S LRI=$O(LRPL(LRI)) Q:'LRI D Q:LRABORT
. W !,LRPL(LRI)
. D NP
. I 'LRABORT,LRPGDATA("NP") W !,"Performing Laboratory (cont'd):",!
;
I 'LRABORT W !
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMIPSZ1 7479 printed Sep 23, 2025@19:52:52 Page 2
LRMIPSZ1 ;DALOI/STAFF - MICRO PATIENT REPORT ;Aug 14, 2019@10:00
+1 ;;5.2;LAB SERVICE;**283,350,520,536**;Sep 27, 1994;Build 18
+2 ;
+3 ;
DQ ;tasked from LRTASK from IMMEDIATE INTERIM REPORTING thru LRTP
+1 ;
+2 SET LRPATLOC=$GET(LRLLOC)
SET LRIDT=$GET(LRIDT,0)
SET LRSS="MI"
SET LRONETST=""
SET LRONESPC=""
SET LREND=0
+3 DO EN^LRPARAM
+4 SET LRLLT=^LR(LRDFN,"MI",LRIDT,0)
SET LRACC=$PIECE(LRLLT,U,6)
SET LRAD=$EXTRACT(LRLLT)_$PIECE(LRACC," ",2)_"0000"
+5 SET X=$PIECE(LRACC," ")
SET DIC=68
SET DIC(0)="M"
+6 IF X'=""
DO ^DIC
SET LRAA=+Y
SET LRAN=+$PIECE(LRACC," ",3)
+7 ;
+8 ; ^TMP("LRMI",$J,LRDFN,"MI",LRIDT) will already exist if this is a LEDI result being processed (rtn LRVRMI1)
+9 IF '$DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT))
Begin DoDot:1
+10 MERGE ^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT)=^LR(LRDFN,"MI",LRIDT)
+11 KILL ^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,32)
End DoDot:1
+12 ;
+13 SET LRCMNT=$GET(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,99))
+14 SET LRPG=0
+15 DO EN
+16 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+17 QUIT
+18 ;
+19 ;
EN ;
+1 ; from LRMINEW2, LRMIPC, LRMIPLOG, LRMIPSZ, LRMIVER1
+2 ; ^TMP("LRMI",$J,LRDFN,"MI",LRIDT) will already exist if this is a LEDI result being processed (rtn LRVRMI1)
+3 ;
IF '$DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT))
Begin DoDot:1
+4 MERGE ^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT)=^LR(LRDFN,"MI",LRIDT)
+5 KILL ^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,32)
End DoDot:1
+6 ;
+7 SET LRUID=$PIECE($GET(^LR(LRDFN,"MI",LRIDT,"ORU")),U)
+8 IF '$DATA(LRONESPC)
SET LRONESPC=""
SET DIC="^LAB(61,"
SET DIC("A")="Select SPECIMEN/SOURCE: ANY//"
SET DIC(0)="AEMOQ"
DO ^DIC
if Y>0
SET LRONESPC=+Y
KILL DIC("A")
+9 IF '$DATA(LRONETST)
SET LRONETST=""
SET DIC="^LAB(60,"
SET DIC(0)="AEOQ"
SET DIC("S")="I $P(^(0),U,4)=""MI"")"_$SELECT('$DATA(LRLABKY):",""BO""[$P(^(0),U,3)",1:"")
SET D="E"
DO IX^DIC
if Y<1
QUIT
IF Y>0
SET LRONETST=+Y
+10 SET LRSPEC=$PIECE(LRLLT,U,5)
IF LRONESPC'=""
IF LRSPEC'=LRONESPC
QUIT
+11 DO RPT
+12 IF '$GET(EAMODE)
KILL ^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT)
+13 KILL %,A8,A,AB,B,B1,B2,B3,C,IA,LR1PASS,LR2ORMOR,LRABCNT,LRACNT,LRADM,LRADX,LRAFS,LRAMT,LRAX,LRBN,LRBRR,LRBUG,LRCOMTAB,LRCS,LRDCOM,LRDOC,LRDRTM1,LRDRTM2,LREF,LRFLIP,LRFMT,LRGRM,LRHC,LRIFN,LRINT,LRPATLOC,LRMYC,LRNS,LRNUM
+14 KILL LRORG,LRPAR,LRPC,LRPRE,LRPRINT,LRQU,LRRC,LRRES,LRSBC1,LRSBC2,LRSET,LRSIC1,LRSIC2,LRSPEC,LRSSD,LRST,LRTA,LRTB,LRTBA,LRTBC,LRTBS,LRTK,LRTS,LRTSTS,LRTUS,LRUS,LRWRD,N
+15 QUIT
+16 ;
+17 ;
RPT ;
+1 ;
+2 NEW LRABORT,LRPGDATA,LRPRNTED,LRDISP
+3 ;
+4 ; If called by another process, i.e. interim reports, then don't reset current page number
+5 SET LRPG=$GET(LRPG,0)
+6 ;
+7 SET LRPGDATA("HDR")="D HDR2^LRMIPSU(.LRPRNTED,.LRABORT,.LRPGDATA)"
+8 SET LRPGDATA("BM")=8
+9 SET LRPGDATA("FTR")="D FOOT2^LRMIPSU"
+10 ; Dont print the footer when console device
+11 ;
IF $EXTRACT($GET(IOST),1,2)="C-"
Begin DoDot:1
+12 SET LRPGDATA("BM")=0
+13 SET LRPGDATA("FTR")=""
End DoDot:1
+14 SET LRPGDATA("PROMPTX")="S X=$$PROMPT^LRMIPSU()"
+15 SET LRPGDATA("ERASE")=1
+16 SET LRPGDATA("PGNUM")=0
+17 SET LRABORT=0
+18 ;
+19 if '$DATA(LRSB)
SET LRSB=0
+20 SET LRPRINT=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4)):"",1:1)
SET LRHC=$SELECT($EXTRACT(IOST,1,2)'="C-":1,1:0)
SET LRFLIP=$SELECT(LRHC:11,1:6)
+21 ;
+22 KILL DIC
+23 DO DT^LRX
+24 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+25 DO PT^LRX
+26 if $GET(VAIN(3))
SET DOB=$PIECE(VADM(3),U)
SET LRPATLOC=$PIECE(LRLLT,U,8)
+27 SET (LRADM,LRADX)=""
+28 IF +$GET(LRDPF)=2
IF '$GET(VAERR)
SET LRADM=$PIECE(VAIN(7),U,2)
SET LRADX=VAIN(9)
+29 SET LRCS=$SELECT($DATA(^LAB(62,+$PIECE(LRLLT,U,11),0)):$PIECE(^(0),U),1:"")
+30 SET LRTK=$PIECE(LRLLT,U)
SET LRRC=$PIECE(LRLLT,U,10)
SET LRST=$SELECT(LRSPEC:$PIECE(^LAB(61,LRSPEC,0),U),1:"")
+31 SET Y=LRTK
DO D^LRU
SET LRTK=Y
+32 SET Y=LRRC
DO D^LRU
SET LRRC=Y
+33 SET X=$PIECE(LRLLT,U,7)
DO DOC^LRX
+34 ;
+35 KILL ^TMP("LR",$JOB,"T"),LRTSTS
+36 ;
+37 SET (LRBRR,LRTESTCOMPLE)=0
+38 FOR
SET LRBRR=+$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR))
if LRBRR<1
QUIT
DO EN1
+39 IF 'LRPRINT
IF LRONETST
QUIT
+40 ;
+41 ;
+42 DO HDR2^LRMIPSU(.LRPRNTED,.LRABORT,.LRPGDATA)
+43 SET LREND=LRABORT
+44 if LRABORT
QUIT
+45 ; display audit log
+46 DO BANNER^LRMIAU2(.LRABORT,.LRPGDATA)
+47 SET LREND=LRABORT
+48 if LRABORT
QUIT
+49 ;
+50 IF $DATA(^TMP("LR",$JOB,"T"))
Begin DoDot:1
+51 NEW J,LRX,LRY,X,Y
+52 WRITE !?2,"Test(s) ordered:"
+53 SET J=0
+54 FOR
SET J=$ORDER(^TMP("LR",$JOB,"T",J))
if J=""
QUIT
Begin DoDot:2
+55 SET X=^TMP("LR",$JOB,"T",J)
+56 SET LRX=$PIECE(X,"^")
+57 IF LRTESTCOMPLE
SET LRX=$$LJ^XLFSTR(LRX,30,".")
+58 WRITE ?19,LRX
+59 IF '$PIECE(X,U,2)
WRITE !
DO NP
QUIT
+60 SET Y=$PIECE(X,U,2)
+61 ; LR*5.2*520 and LR*5.2*536
+62 SET LRDISP=$PIECE(X,U,3)
+63 DO D^LRU
SET LRY=$SELECT(LRDISP["Not Performed":"canceled: ",1:"completed: ")_Y
+64 IF (19+$LENGTH(LRX)+$LENGTH(LRY))>IOM
WRITE !
+65 WRITE ?50,LRY,!
DO NP
End DoDot:2
if LRABORT
QUIT
End DoDot:1
if LRABORT
QUIT
+66 ;
+67 KILL ^TMP("LR",$JOB,"T"),LRTSTS
if LRHC
WRITE !
+68 ;
IF $DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,14))
Begin DoDot:1
+69 DO NP
if LRABORT
QUIT
+70 DO ANTI^LRMIPSZ2
+71 DO NP
if LRABORT
QUIT
End DoDot:1
if LRABORT
QUIT
+72 ;
+73 ;
IF $DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,1))
Begin DoDot:1
+74 DO NP
if LRABORT
QUIT
+75 DO BACT^LRMIPSZ2
if LREND
QUIT
+76 DO NP
if LRABORT
QUIT
+77 DO REFS^LRMIPSU
if LREND
QUIT
+78 DO NP
if LRABORT
QUIT
End DoDot:1
if LRABORT
QUIT
+79 ;
+80 ;
IF $DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,31))
Begin DoDot:1
+81 DO NP
if LRABORT
QUIT
+82 DO STER^LRMIPSZ3
+83 DO NP
if LRABORT
QUIT
End DoDot:1
if LRABORT
QUIT
+84 ;
+85 ;
IF $DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,5))
Begin DoDot:1
+86 DO NP
if LRABORT
QUIT
+87 DO PARA^LRMIPSZ3
+88 DO NP
if LRABORT
QUIT
+89 DO REFS^LRMIPSU
+90 if LREND
QUIT
+91 DO NP
if LRABORT
QUIT
End DoDot:1
if LRABORT
QUIT
if LREND
QUIT
+92 ;
+93 ;
IF $DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,16))
Begin DoDot:1
+94 DO NP
if LRABORT
QUIT
+95 DO VIR^LRMIPSZ3
+96 ;
DO REFS^LRMIPSU
if LREND
QUIT
if LRABORT
QUIT
End DoDot:1
if LREND
QUIT
if LRABORT
QUIT
+97 ;
+98 ;
IF $DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,11))
Begin DoDot:1
+99 DO NP
if LRABORT
QUIT
+100 DO TB^LRMIPSZ4
+101 DO NP
if LRABORT
QUIT
+102 DO REFS^LRMIPSU
+103 DO NP
if LRABORT
QUIT
End DoDot:1
if LREND
QUIT
if LRABORT
QUIT
+104 ;
+105 ;
IF $DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,8))
Begin DoDot:1
+106 DO NP
if LRABORT
QUIT
+107 DO FUNG^LRMIPSZ4
+108 DO NP
if LRABORT
QUIT
+109 DO REFS^LRMIPSU
+110 if LREND
QUIT
if LRABORT
QUIT
End DoDot:1
if LREND
QUIT
if LRABORT
QUIT
+111 ;
+112 if LRABORT
QUIT
+113 ;
+114 ; Print any performing labs listing
+115 IF $GET(LRMODE)'="LDSI"
DO PPL
+116 ;
+117 ; Write last footer if needed
+118 ;
IF 'LRABORT
IF '$GET(LRPGDATA("WFTR"))
Begin DoDot:1
+119 IF $GET(LRPGDATA("FTR"))=""
QUIT
+120 ;
IF $EXTRACT($GET(IOST),1,2)'="C-"
Begin DoDot:2
+121 NEW I,BM
+122 SET BM=$GET(LRPGDATA("BM"))
+123 FOR I=$Y+1:1:($GET(IOSL,60)-BM-1)
WRITE !
End DoDot:2
+124 XECUTE LRPGDATA("FTR")
End DoDot:1
+125 ;
+126 ;
IF 'LRABORT
Begin DoDot:1
+127 NEW PAD,STR,I,II
+128 SET X=" End of Report "
SET PAD="+ "
SET STR=""
+129 SET I=IOM-($LENGTH(X)*3)
SET I=I/4/$LENGTH(PAD)
+130 FOR II=1:1:3
SET STR=STR_$$REPEAT^XLFSTR(PAD,I)_X
+131 SET STR=STR_$$REPEAT^XLFSTR(PAD,I)
+132 WRITE !,$$CJ^XLFSTR(STR,IOM)
+133 FOR I=$Y+1:1:($GET(IOSL,60)-$GET(LRPGDATA("BM"))-1)
WRITE !
+134 SET (LRABORT,LREND)=$$MORE^LRUTIL($$PROMPT^LRMIPSU(),0)
+135 ; LRMLTRPT indicates multi report (set in SENDUP^LRMIPLOG)
+136 IF $GET(LRMLTRPT)
IF $EXTRACT($GET(IOST),1,2)="P-"
IF $GET(IOF)'=""
WRITE @IOF
End DoDot:1
+137 ;
+138 QUIT
+139 ;
+140 ;
EN1 ;
+1 ; LR*5.2*520 Set disposition to LRDISP
+2 SET LRTS=+^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR,0)
SET LRTS(1)=$PIECE(^(0),U,5)
SET LRDISP=$PIECE(^(0),U,6)
+3 if '$LENGTH($PIECE($GET(^LAB(60,LRTS,0)),U,3))
QUIT
+4 IF '$DATA(LRLABKY)
IF "BO"'[$PIECE($GET(^LAB(60,LRTS,0)),U,3)
QUIT
+5 ;
+6 ; Set flag that at least one test is completed
+7 IF LRTS(1)
SET LRTESTCOMPLE=1
+8 ;
+9 if LRTS=LRONETST
SET LRPRINT=1
+10 SET LRTSTS=$SELECT($DATA(^LAB(60,LRTS,0)):$PIECE(^(0),U),1:"deleted test")
SET ^TMP("LR",$JOB,"T",$SELECT($DATA(^LAB(60,LRTS,.1)):$PIECE(^(.1),U,6),1:"")_","_LRBRR)=LRTSTS_U_LRTS(1)_U_LRDISP
+11 QUIT
+12 ;
+13 ;
NP ;
+1 ; Convenience method
+2 ; Some methods in these report routines may be called by a different parent so need to handle this if needed.
+3 IF '$DATA(LRABORT)
SET LRABORT=0
+4 if '$DATA(LRPGDATA)
QUIT
+5 DO NP^LRUTIL(.LRABORT,.LRPGDATA)
+6 SET LRPG=$GET(LRPGDATA("PGNUM"),1)
+7 ;
+8 ; backward compatability (for SENDUP^LRMIPLOG)
+9 SET LREND=LRABORT
+10 QUIT
+11 ;
+12 ;
PPL ; Print any performing laboratories
+1 ;
+2 NEW LRPL,LRI,LRX,LRY
+3 ;
+4 DO RETLST^LRRPL(.LRPL,LRDFN,"MI",LRIDT,0)
+5 IF $GET(LRPL)<1
QUIT
+6 ;
+7 ; Start new page if space on existing page too small to display a significant portion of labs
+8 SET LRY=IOSL-$Y
if LRY<1
SET LRY=1
+9 IF (LRPL/LRY)>1
Begin DoDot:1
+10 FOR LRI=$Y+1:1:($GET(IOSL,60)-$GET(LRPGDATA("BM"))-1)
WRITE !
+11 DO NP
End DoDot:1
+12 IF '$TEST
SET LRX="=--"
WRITE !!,$$REPEAT^XLFSTR(LRX,IOM/$LENGTH(LRX))
+13 ;
+14 WRITE !,"Performing Laboratory:",!
+15 SET LRI=0
+16 FOR
SET LRI=$ORDER(LRPL(LRI))
if 'LRI
QUIT
Begin DoDot:1
+17 WRITE !,LRPL(LRI)
+18 DO NP
+19 IF 'LRABORT
IF LRPGDATA("NP")
WRITE !,"Performing Laboratory (cont'd):",!
End DoDot:1
if LRABORT
QUIT
+20 ;
+21 IF 'LRABORT
WRITE !
+22 ;
+23 QUIT
