LRRP2 ;DALOI/STAFF - INTERIM REPORT ;02/28/12 20:08
;;5.2;LAB SERVICE;**106,121,221,283,300,350**;Sep 27, 1994;Build 230
;
; from option LRRP2
BEGIN ;
D INIT K DIC S LRPRTPG=0
D ^LRDPA D:LRDFN>0 START G:LRDFN<0 END G BEGIN
END ;
D ^LRRK
Q
;
;
CUM ;ENTRY POINT FOR CUMULATIVE OPTIONS- LRAC PT,LRAC 1 PAGE, LRAC MANUAL
S LRPRTPG=1
;
SUM ;ENTRY POINT FROM SUM^LRACM2- PRINT A FULL PATIENT SUMMARY
D INIT K DIC D ^LRDPA D:LRDFN>0 START G:LRDFN<0 END
Q
;
;
START ;
I $O(^LR(LRDFN,0))="" W !,"NO LAB DATA ON THIS PATIENT!",$C(7) Q
S LRLAB=$S($D(LRLABKY):1,1:0)
I $D(LRCUM) S LRIDT=0,LREDT=9999999
E D
. S LREDT="T-7" D ^LRWU3 Q:LREND
. S LRIDT=9999999-LRSDT,LREDT=9999999-LREDT
I LREND Q
;
;
ASKPG ;
I '$G(LRPRTPG) D
. N DIR,DIROUT,DIRUT,X,Y
. S DIR(0)="Y",DIR("A")="Print address page",DIR("B")="NO",LRPRTPG=0
. D ^DIR K DIR
. I Y S LRPRTPG=1
S %ZIS="Q",ZTSAVE("DFN")="",ZTSAVE("LR*")="",ZTRTN="SDQ^LRRP2"
D IO^LRWU
Q
;
;
SDQ ; dequeued
S:$D(ZTQUEUED) ZTREQ="@" U IO D PT^LRX
F S LRCNIDT=+$O(^LR(LRDFN,"CH",LRIDT)),LRMNIDT=+$O(^LR(LRDFN,"MI",LRIDT)) Q:'LRCNIDT&'LRMNIDT D SWITCH Q:LREND!LRSTOP!(LRIDT>LREDT)
D FOOT^LRRP1
D:$G(LRPRTPG) PLSPG
Q
;
;
SWITCH I LRCNIDT=LRMNIDT S LRIDT=LRCNIDT Q:LRIDT>LREDT D CH,MI Q
I 'LRMNIDT S LRIDT=LRCNIDT Q:LRIDT>LREDT D CH Q
I 'LRCNIDT S LRIDT=LRMNIDT Q:LRIDT>LREDT D MI Q
I LRCNIDT<LRMNIDT S LRIDT=LRCNIDT Q:LRIDT>LREDT D CH Q
S LRIDT=LRMNIDT Q:LRIDT>LREDT D MI
Q
;
GENP ;
W !!,"Too many tests! Will use alternate format. May show extra tests.",!
S LREDT="T-7" D ^LRWU3 Q:LREND
S LRSDT=9999999-LRSDT,LREDT=9999999-LREDT
K ^TMP("LR",$J,"T"),LRORD,LRTSTS
S ZTSAVE("^TMP(""LR"",$J,")="",ZTSAVE("DFN")="",ZTRTN="GDQ^LRRP2" D IO^LRWU
Q
;
;
GDQ ;dequeued
S:$D(ZTQUEUED) ZTREQ="@" U IO D PT^LRX
S LRSUB="" F S LRSUB=$O(^TMP("LR",$J,"TMP",LRSUB)) Q:LRSUB="" S X=+$P(LRSUB,";",2),^TMP("LR",$J,"T",X)=""
S LRIDT=LRSDT F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1!(LRIDT>LREDT) D GEN2 Q:LREND!LRSTOP
K ^TMP("LR",$J,"T"),^TMP("LR",$J,"TMP"),LRSDT,LREDT,LRTSTS,LRSUB,LRIDT
Q
;
;
GEN2 ;
S LRTN=0 F S LRTN=$O(^LR(LRDFN,"CH",LRIDT,LRTN)) Q:LRTN<1 I $D(^TMP("LR",$J,"T",LRTN)) D CH Q
I '$P($G(^LR(LRDFN,"CH",LRIDT,0)),U,3),$O(^LR(LRDFN,"CH",LRIDT,1,0)) D Q:'$G(LRCAN) D CH
. S LRCAN=0 F S LRCAN=+$O(^LR(LRDFN,"CH",LRIDT,1,LRCAN)) Q:LRCAN<1 Q:$E($G(^(LRCAN,0)))="*"
Q
;
;
AIDQUE ;
D INIT
S LRLAB=$S($D(LRLABKY):1,1:0)
K ^TMP($J)
S LROCE=$S($D(LROC):LROC,1:""),LROC=$S(LROCE="":$O(^LAB(64.6,"AI","")),1:LROC)
D:LROC'="" AI2
F S LROC=$O(^LAB(64.6,"AI",LROC)) Q:LROC=""!($L(LROCE)&(LROC'=LROCE)) D AI2
S LROC="UNKNOWN" D AI2
;
;
PRT ; Print sorted data
U IO K VA D KVAR^VADPT S LREND=0
I $O(^TMP($J,0))="" D Q
. W !!?10,"No Interim report Patients to Print "
. W !?20,$$HTE^XLFDT($H),!!
. D QUIT
S LROC=""
F S LROC=$O(^TMP($J,LROC)) Q:LROC=""!($G(LREND)) D
. S LRPHY=""
. F S LRPHY=$O(^TMP($J,LROC,LRPHY)) Q:LRPHY=""!($G(LREND)) D
. . S LRSSN=""
. . F S LRSSN=$O(^TMP($J,LROC,LRPHY,LRSSN)) Q:LRSSN=""!($G(LREND)) D
. . . S LRDFN=0
. . . F S LRHF=1,LRDFN=$O(^TMP($J,LROC,LRPHY,LRSSN,LRDFN)) Q:LRDFN<1!($G(LREND)) D
. . . . S LRIDT=0
. . . . F S LRIDT=$O(^TMP($J,LROC,LRPHY,LRSSN,LRDFN,LRIDT)) Q:LRIDT<1!($G(LREND)) D
. . . . . S LRSS="",PNM=^(LRIDT),SSN=$P(PNM,U,2),AGE=$P(PNM,U,3),SEX=$P(PNM,U,4),PNM=$P(PNM,U),LRFOOT=0
. . . . . D:$D(^LR(LRDFN,"CH",LRIDT,0))#2 CH
. . . . . S LRFOOT=0
. . . . . I $D(^LR(LRDFN,"MI",LRIDT,0))#2 D
. . . . . . I $G(LRSS)="CH" D FOOT^LRRP1 D:$G(LRPRTPG) PLSPG
. . . . . . D MI
. . . . . I $G(LRSS)="CH" D FOOT^LRRP1 D:$G(LRPRTPG) PLSPG
D QUIT
Q
;
;
QUIT ;
K LR0
S:$D(ZTQUEUED) ZTREQ="@"
D ^%ZISC,^LRRK
Q
;
;
AI2 ;
Q:'$L($G(LROC))
F LRDFN=0:0 S LRDFN=$O(^LRO(69,"AN",LROC,LRDFN)) Q:LRDFN<1 I $D(^LR(LRDFN,0))#2 D
. S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX Q:LREND
. I '$G(VAERR) D AI3
Q
;
;
AI3 ;
Q:$G(LREND) N LRCAN
S LRSSN=$P(PNM,",")_SSN(1)
F LRIDT=0:0 S LRIDT=$O(^LRO(69,"AN",LROC,LRDFN,LRIDT)) Q:LRIDT<1 D
. S LRND=$S($G(^LR(LRDFN,"CH",LRIDT,0)):^(0),$G(^LR(LRDFN,"MI",LRIDT,0)):^(0),1:"") D
. . I $G(^LR(LRDFN,"CH",LRIDT,0)) D
. . . I $O(^LR(LRDFN,"CH",LRIDT,1)),$P(LRND,U,3) D AI3SET Q ; Print verified results.
. . . I $O(^LR(LRDFN,"CH",LRIDT,1)) Q ; Don't print unverified results.
. . . S LRCAN=0 F S LRCAN=+$O(^LR(LRDFN,"CH",LRIDT,1,LRCAN)) Q:LRCAN<1 Q:($E(^(LRCAN,0))="*")
. . . I $G(LRCAN) D AI3SET ; Print if cancel comment and no unverified results.
. . I $P($G(^LR(LRDFN,"MI",LRIDT,0)),U,3) D
. . . S I=$O(^LR(LRDFN,"MI",LRIDT,0)) Q:I'=99 D AI3SET
Q
;
;
AI3SET ;
S LRPHY=$P($G(^VA(200,+$P(LRND,U,10),0)),U) S:LRPHY="" LRPHY="UNKNOWN"
S ^TMP($J,LROC,LRPHY,LRSSN,LRDFN,LRIDT)=PNM_U_SSN_U_AGE_U_SEX
Q
;
;
CH ;Also used by DVBC Package
Q:'$G(^LR(LRDFN,"CH",LRIDT,0))
N LROC,LRCAN
K ^TMP("LR",$J,"TP"),LRTP S LR0=^LR(LRDFN,"CH",LRIDT,0)
Q:$O(^LR(LRDFN,"CH",LRIDT,1))&('$P(LR0,U,3))
I '$P(LR0,U,3),$O(^LR(LRDFN,"CH",LRIDT,1,0)) D Q:'$G(LRCAN)
. S LRCAN=0 F S LRCAN=+$O(^LR(LRDFN,"CH",LRIDT,1,LRCAN)) Q:LRCAN<1 Q:$E($G(^(LRCAN,0)))="*"
S LRCDT=+LR0,LRSS="CH",LROC=$P(LR0,U,11),LRAA="",LRAAO=1,LRTC=0,LRSPEC=$P(LR0,U,5)
D CH^LRRP
Q
;
;
MI ;Also used by DVBC package
S LRCDT=9999999-LRIDT,^TMP("LR",$J,"TP",1)="^MI",^(1,LRCDT)="",^(LRCDT,-1)="",LRSS="MI",LRH=1
I LRFOOT D FOOT^LRRP1 Q:LRSTOP
D EN1^LRMIPC
S LRHF=1,LRFOOT=0
K A,Z,LRH
S:LREND LREND=0,LRSTOP=1
Q
;
;
INIT ;
D EN^LRPARAM
S (LREND,LRSTOP,LRPG,LRFOOT)=0,LRCW=8,LRHF=1,(LRONESPC,LRONETST)=""
K LREPR,LRPLS
Q
;
;
EN69 ;entry point for surgery pkg
D START,^LRRK
Q
;
;
GEN ;from LRGEN test overflow
S LRLAB=$S($D(LRLABKY):1,1:0) D INIT,GENP,^LRRK
Q
;
DS ;from LRRD, LRRS
D INIT S DFN=$P(^LR(LRDFN,0),U,3),LRDPF=$P(^(0),U,2) D SDQ
Q
;
;
AIDQ ;tasked from LRTASK DAILY INTERIM,LRTASK CUM
N LRLAB,LRH,LRWRDVEW,LRPRTPG
S (LRH,LRWRDVEW)="",LRPRTPG=1
D AIDQUE
K ^TMP($J)
Q
;
;
DQ ;tasked from LRVER3 thru LRTP for IMMEDIATE INTERIM REPORTING
;
D INIT
S LRLAB=0,LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
D PT^LRX
D CH,FOOT^LRRP1,^%ZISC
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
;
OR ;OE/RR entry point
Q:'$D(ORVP) S KILL=1 I '$D(LRPARAM) D EN^LRPARAM S KILL=0
S (LREND,LRSTOP)=0,LRCW=8,LRHF=1,LRFOOT=0,(LRONESPC,LRONETST)=""
D DT^LRX K DIC,LRTP S LRTP=0,DFN=+ORVP,LRDPF=+$P(@("^"_$P(ORVP,";",2)_"0)"),"^",2)_"^"_$P(ORVP,";",2) D END^LRDPA Q:LRDFN<1
D START,^LRRK
I 'KILL K LRBLOOD,LRDT0,LRPARAM,LRPLASMA,LRSERUM,LRSB,LRTP,LRUNKNOW,LRURINE
K KILL
Q
;
;
PLSPG ;Print last page with performing lab site names and addresses
;
N A,CLIA,LR4,LRJ,LRX,LRY
W @IOF
I $D(LRPG) S LRPG=LRPG+1,A(1)="page "_LRPG,A(1,"F")="!?65"
S A(2)=$$LJ^XLFSTR(PNM,30)_$$LJ^XLFSTR(SSN,20)_$$HTE^XLFDT($H,"M")
S A(3)="Performing Lab Sites:",A(3,"F")="!!"
S LR4=0,LRJ=$O(A(""),-1)+1
F S LR4=$O(LRPLS(LR4)) Q:LR4="" D
. S LRX=$$NAME^XUAF4(LR4),CLIA=$$ID^XUAF4("CLIA",LR4),LRY="["_LR4_"] "
. S A(LRJ)=LRY_LRX,A(LRJ,"F")="!!"
. I CLIA'="" D
. . I $L(A(LRJ))<60 S A(LRJ)=A(LRJ)_" [CLIA# "_CLIA_"]"
. . E S A(LRJ+.5)="CLIA# "_CLIA,A(LRJ+.5,"F")="!?"_$L(LRY)
. S LRX=$$PADD^XUAF4(LR4)
. S A(LRJ+1)=$P(LRX,U)_" "_$P(LRX,U,2)_", "_$P(LRX,U,3)_" "_$P(LRX,U,4)
. S A(LRJ+1,"F")="!?"_$L(LRY),LRJ=LRJ+2
D EN^DDIOL(.A)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRRP2 7488 printed Jan 18, 2025@03:20:34 Page 2
LRRP2 ;DALOI/STAFF - INTERIM REPORT ;02/28/12 20:08
+1 ;;5.2;LAB SERVICE;**106,121,221,283,300,350**;Sep 27, 1994;Build 230
+2 ;
+3 ; from option LRRP2
BEGIN ;
+1 DO INIT
KILL DIC
SET LRPRTPG=0
+2 DO ^LRDPA
if LRDFN>0
DO START
if LRDFN<0
GOTO END
GOTO BEGIN
END ;
+1 DO ^LRRK
+2 QUIT
+3 ;
+4 ;
CUM ;ENTRY POINT FOR CUMULATIVE OPTIONS- LRAC PT,LRAC 1 PAGE, LRAC MANUAL
+1 SET LRPRTPG=1
+2 ;
SUM ;ENTRY POINT FROM SUM^LRACM2- PRINT A FULL PATIENT SUMMARY
+1 DO INIT
KILL DIC
DO ^LRDPA
if LRDFN>0
DO START
if LRDFN<0
GOTO END
+2 QUIT
+3 ;
+4 ;
START ;
+1 IF $ORDER(^LR(LRDFN,0))=""
WRITE !,"NO LAB DATA ON THIS PATIENT!",$CHAR(7)
QUIT
+2 SET LRLAB=$SELECT($DATA(LRLABKY):1,1:0)
+3 IF $DATA(LRCUM)
SET LRIDT=0
SET LREDT=9999999
+4 IF '$TEST
Begin DoDot:1
+5 SET LREDT="T-7"
DO ^LRWU3
if LREND
QUIT
+6 SET LRIDT=9999999-LRSDT
SET LREDT=9999999-LREDT
End DoDot:1
+7 IF LREND
QUIT
+8 ;
+9 ;
ASKPG ;
+1 IF '$GET(LRPRTPG)
Begin DoDot:1
+2 NEW DIR,DIROUT,DIRUT,X,Y
+3 SET DIR(0)="Y"
SET DIR("A")="Print address page"
SET DIR("B")="NO"
SET LRPRTPG=0
+4 DO ^DIR
KILL DIR
+5 IF Y
SET LRPRTPG=1
End DoDot:1
+6 SET %ZIS="Q"
SET ZTSAVE("DFN")=""
SET ZTSAVE("LR*")=""
SET ZTRTN="SDQ^LRRP2"
+7 DO IO^LRWU
+8 QUIT
+9 ;
+10 ;
SDQ ; dequeued
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
USE IO
DO PT^LRX
+2 FOR
SET LRCNIDT=+$ORDER(^LR(LRDFN,"CH",LRIDT))
SET LRMNIDT=+$ORDER(^LR(LRDFN,"MI",LRIDT))
if 'LRCNIDT&'LRMNIDT
QUIT
DO SWITCH
if LREND!LRSTOP!(LRIDT>LREDT)
QUIT
+3 DO FOOT^LRRP1
+4 if $GET(LRPRTPG)
DO PLSPG
+5 QUIT
+6 ;
+7 ;
SWITCH IF LRCNIDT=LRMNIDT
SET LRIDT=LRCNIDT
if LRIDT>LREDT
QUIT
DO CH
DO MI
QUIT
+1 IF 'LRMNIDT
SET LRIDT=LRCNIDT
if LRIDT>LREDT
QUIT
DO CH
QUIT
+2 IF 'LRCNIDT
SET LRIDT=LRMNIDT
if LRIDT>LREDT
QUIT
DO MI
QUIT
+3 IF LRCNIDT<LRMNIDT
SET LRIDT=LRCNIDT
if LRIDT>LREDT
QUIT
DO CH
QUIT
+4 SET LRIDT=LRMNIDT
if LRIDT>LREDT
QUIT
DO MI
+5 QUIT
+6 ;
GENP ;
+1 WRITE !!,"Too many tests! Will use alternate format. May show extra tests.",!
+2 SET LREDT="T-7"
DO ^LRWU3
if LREND
QUIT
+3 SET LRSDT=9999999-LRSDT
SET LREDT=9999999-LREDT
+4 KILL ^TMP("LR",$JOB,"T"),LRORD,LRTSTS
+5 SET ZTSAVE("^TMP(""LR"",$J,")=""
SET ZTSAVE("DFN")=""
SET ZTRTN="GDQ^LRRP2"
DO IO^LRWU
+6 QUIT
+7 ;
+8 ;
GDQ ;dequeued
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
USE IO
DO PT^LRX
+2 SET LRSUB=""
FOR
SET LRSUB=$ORDER(^TMP("LR",$JOB,"TMP",LRSUB))
if LRSUB=""
QUIT
SET X=+$PIECE(LRSUB,";",2)
SET ^TMP("LR",$JOB,"T",X)=""
+3 SET LRIDT=LRSDT
FOR
SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
if LRIDT<1!(LRIDT>LREDT)
QUIT
DO GEN2
if LREND!LRSTOP
QUIT
+4 KILL ^TMP("LR",$JOB,"T"),^TMP("LR",$JOB,"TMP"),LRSDT,LREDT,LRTSTS,LRSUB,LRIDT
+5 QUIT
+6 ;
+7 ;
GEN2 ;
+1 SET LRTN=0
FOR
SET LRTN=$ORDER(^LR(LRDFN,"CH",LRIDT,LRTN))
if LRTN<1
QUIT
IF $DATA(^TMP("LR",$JOB,"T",LRTN))
DO CH
QUIT
+2 IF '$PIECE($GET(^LR(LRDFN,"CH",LRIDT,0)),U,3)
IF $ORDER(^LR(LRDFN,"CH",LRIDT,1,0))
Begin DoDot:1
+3 SET LRCAN=0
FOR
SET LRCAN=+$ORDER(^LR(LRDFN,"CH",LRIDT,1,LRCAN))
if LRCAN<1
QUIT
if $EXTRACT($GET(^(LRCAN,0)))="*"
QUIT
End DoDot:1
if '$GET(LRCAN)
QUIT
DO CH
+4 QUIT
+5 ;
+6 ;
AIDQUE ;
+1 DO INIT
+2 SET LRLAB=$SELECT($DATA(LRLABKY):1,1:0)
+3 KILL ^TMP($JOB)
+4 SET LROCE=$SELECT($DATA(LROC):LROC,1:"")
SET LROC=$SELECT(LROCE="":$ORDER(^LAB(64.6,"AI","")),1:LROC)
+5 if LROC'=""
DO AI2
+6 FOR
SET LROC=$ORDER(^LAB(64.6,"AI",LROC))
if LROC=""!($LENGTH(LROCE)&(LROC'=LROCE))
QUIT
DO AI2
+7 SET LROC="UNKNOWN"
DO AI2
+8 ;
+9 ;
PRT ; Print sorted data
+1 USE IO
KILL VA
DO KVAR^VADPT
SET LREND=0
+2 IF $ORDER(^TMP($JOB,0))=""
Begin DoDot:1
+3 WRITE !!?10,"No Interim report Patients to Print "
+4 WRITE !?20,$$HTE^XLFDT($HOROLOG),!!
+5 DO QUIT
End DoDot:1
QUIT
+6 SET LROC=""
+7 FOR
SET LROC=$ORDER(^TMP($JOB,LROC))
if LROC=""!($GET(LREND))
QUIT
Begin DoDot:1
+8 SET LRPHY=""
+9 FOR
SET LRPHY=$ORDER(^TMP($JOB,LROC,LRPHY))
if LRPHY=""!($GET(LREND))
QUIT
Begin DoDot:2
+10 SET LRSSN=""
+11 FOR
SET LRSSN=$ORDER(^TMP($JOB,LROC,LRPHY,LRSSN))
if LRSSN=""!($GET(LREND))
QUIT
Begin DoDot:3
+12 SET LRDFN=0
+13 FOR
SET LRHF=1
SET LRDFN=$ORDER(^TMP($JOB,LROC,LRPHY,LRSSN,LRDFN))
if LRDFN<1!($GET(LREND))
QUIT
Begin DoDot:4
+14 SET LRIDT=0
+15 FOR
SET LRIDT=$ORDER(^TMP($JOB,LROC,LRPHY,LRSSN,LRDFN,LRIDT))
if LRIDT<1!($GET(LREND))
QUIT
Begin DoDot:5
+16 SET LRSS=""
SET PNM=^(LRIDT)
SET SSN=$PIECE(PNM,U,2)
SET AGE=$PIECE(PNM,U,3)
SET SEX=$PIECE(PNM,U,4)
SET PNM=$PIECE(PNM,U)
SET LRFOOT=0
+17 if $DATA(^LR(LRDFN,"CH",LRIDT,0))#2
DO CH
+18 SET LRFOOT=0
+19 IF $DATA(^LR(LRDFN,"MI",LRIDT,0))#2
Begin DoDot:6
+20 IF $GET(LRSS)="CH"
DO FOOT^LRRP1
if $GET(LRPRTPG)
DO PLSPG
+21 DO MI
End DoDot:6
+22 IF $GET(LRSS)="CH"
DO FOOT^LRRP1
if $GET(LRPRTPG)
DO PLSPG
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+23 DO QUIT
+24 QUIT
+25 ;
+26 ;
QUIT ;
+1 KILL LR0
+2 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 DO ^%ZISC
DO ^LRRK
+4 QUIT
+5 ;
+6 ;
AI2 ;
+1 if '$LENGTH($GET(LROC))
QUIT
+2 FOR LRDFN=0:0
SET LRDFN=$ORDER(^LRO(69,"AN",LROC,LRDFN))
if LRDFN<1
QUIT
IF $DATA(^LR(LRDFN,0))#2
Begin DoDot:1
+3 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
if LREND
QUIT
+4 IF '$GET(VAERR)
DO AI3
End DoDot:1
+5 QUIT
+6 ;
+7 ;
AI3 ;
+1 if $GET(LREND)
QUIT
NEW LRCAN
+2 SET LRSSN=$PIECE(PNM,",")_SSN(1)
+3 FOR LRIDT=0:0
SET LRIDT=$ORDER(^LRO(69,"AN",LROC,LRDFN,LRIDT))
if LRIDT<1
QUIT
Begin DoDot:1
+4 SET LRND=$SELECT($GET(^LR(LRDFN,"CH",LRIDT,0)):^(0),$GET(^LR(LRDFN,"MI",LRIDT,0)):^(0),1:"")
Begin DoDot:2
+5 IF $GET(^LR(LRDFN,"CH",LRIDT,0))
Begin DoDot:3
+6 ; Print verified results.
IF $ORDER(^LR(LRDFN,"CH",LRIDT,1))
IF $PIECE(LRND,U,3)
DO AI3SET
QUIT
+7 ; Don't print unverified results.
IF $ORDER(^LR(LRDFN,"CH",LRIDT,1))
QUIT
+8 SET LRCAN=0
FOR
SET LRCAN=+$ORDER(^LR(LRDFN,"CH",LRIDT,1,LRCAN))
if LRCAN<1
QUIT
if ($EXTRACT(^(LRCAN,0))="*")
QUIT
+9 ; Print if cancel comment and no unverified results.
IF $GET(LRCAN)
DO AI3SET
End DoDot:3
+10 IF $PIECE($GET(^LR(LRDFN,"MI",LRIDT,0)),U,3)
Begin DoDot:3
+11 SET I=$ORDER(^LR(LRDFN,"MI",LRIDT,0))
if I'=99
QUIT
DO AI3SET
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
+14 ;
AI3SET ;
+1 SET LRPHY=$PIECE($GET(^VA(200,+$PIECE(LRND,U,10),0)),U)
if LRPHY=""
SET LRPHY="UNKNOWN"
+2 SET ^TMP($JOB,LROC,LRPHY,LRSSN,LRDFN,LRIDT)=PNM_U_SSN_U_AGE_U_SEX
+3 QUIT
+4 ;
+5 ;
CH ;Also used by DVBC Package
+1 if '$GET(^LR(LRDFN,"CH",LRIDT,0))
QUIT
+2 NEW LROC,LRCAN
+3 KILL ^TMP("LR",$JOB,"TP"),LRTP
SET LR0=^LR(LRDFN,"CH",LRIDT,0)
+4 if $ORDER(^LR(LRDFN,"CH",LRIDT,1))&('$PIECE(LR0,U,3))
QUIT
+5 IF '$PIECE(LR0,U,3)
IF $ORDER(^LR(LRDFN,"CH",LRIDT,1,0))
Begin DoDot:1
+6 SET LRCAN=0
FOR
SET LRCAN=+$ORDER(^LR(LRDFN,"CH",LRIDT,1,LRCAN))
if LRCAN<1
QUIT
if $EXTRACT($GET(^(LRCAN,0)))="*"
QUIT
End DoDot:1
if '$GET(LRCAN)
QUIT
+7 SET LRCDT=+LR0
SET LRSS="CH"
SET LROC=$PIECE(LR0,U,11)
SET LRAA=""
SET LRAAO=1
SET LRTC=0
SET LRSPEC=$PIECE(LR0,U,5)
+8 DO CH^LRRP
+9 QUIT
+10 ;
+11 ;
MI ;Also used by DVBC package
+1 SET LRCDT=9999999-LRIDT
SET ^TMP("LR",$JOB,"TP",1)="^MI"
SET ^(1,LRCDT)=""
SET ^(LRCDT,-1)=""
SET LRSS="MI"
SET LRH=1
+2 IF LRFOOT
DO FOOT^LRRP1
if LRSTOP
QUIT
+3 DO EN1^LRMIPC
+4 SET LRHF=1
SET LRFOOT=0
+5 KILL A,Z,LRH
+6 if LREND
SET LREND=0
SET LRSTOP=1
+7 QUIT
+8 ;
+9 ;
INIT ;
+1 DO EN^LRPARAM
+2 SET (LREND,LRSTOP,LRPG,LRFOOT)=0
SET LRCW=8
SET LRHF=1
SET (LRONESPC,LRONETST)=""
+3 KILL LREPR,LRPLS
+4 QUIT
+5 ;
+6 ;
EN69 ;entry point for surgery pkg
+1 DO START
DO ^LRRK
+2 QUIT
+3 ;
+4 ;
GEN ;from LRGEN test overflow
+1 SET LRLAB=$SELECT($DATA(LRLABKY):1,1:0)
DO INIT
DO GENP
DO ^LRRK
+2 QUIT
+3 ;
DS ;from LRRD, LRRS
+1 DO INIT
SET DFN=$PIECE(^LR(LRDFN,0),U,3)
SET LRDPF=$PIECE(^(0),U,2)
DO SDQ
+2 QUIT
+3 ;
+4 ;
AIDQ ;tasked from LRTASK DAILY INTERIM,LRTASK CUM
+1 NEW LRLAB,LRH,LRWRDVEW,LRPRTPG
+2 SET (LRH,LRWRDVEW)=""
SET LRPRTPG=1
+3 DO AIDQUE
+4 KILL ^TMP($JOB)
+5 QUIT
+6 ;
+7 ;
DQ ;tasked from LRVER3 thru LRTP for IMMEDIATE INTERIM REPORTING
+1 ;
+2 DO INIT
+3 SET LRLAB=0
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+4 DO PT^LRX
+5 DO CH
DO FOOT^LRRP1
DO ^%ZISC
+6 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+7 QUIT
+8 ;
+9 ;
OR ;OE/RR entry point
+1 if '$DATA(ORVP)
QUIT
SET KILL=1
IF '$DATA(LRPARAM)
DO EN^LRPARAM
SET KILL=0
+2 SET (LREND,LRSTOP)=0
SET LRCW=8
SET LRHF=1
SET LRFOOT=0
SET (LRONESPC,LRONETST)=""
+3 DO DT^LRX
KILL DIC,LRTP
SET LRTP=0
SET DFN=+ORVP
SET LRDPF=+$PIECE(@("^"_$PIECE(ORVP,";",2)_"0)"),"^",2)_"^"_$PIECE(ORVP,";",2)
DO END^LRDPA
if LRDFN<1
QUIT
+4 DO START
DO ^LRRK
+5 IF 'KILL
KILL LRBLOOD,LRDT0,LRPARAM,LRPLASMA,LRSERUM,LRSB,LRTP,LRUNKNOW,LRURINE
+6 KILL KILL
+7 QUIT
+8 ;
+9 ;
PLSPG ;Print last page with performing lab site names and addresses
+1 ;
+2 NEW A,CLIA,LR4,LRJ,LRX,LRY
+3 WRITE @IOF
+4 IF $DATA(LRPG)
SET LRPG=LRPG+1
SET A(1)="page "_LRPG
SET A(1,"F")="!?65"
+5 SET A(2)=$$LJ^XLFSTR(PNM,30)_$$LJ^XLFSTR(SSN,20)_$$HTE^XLFDT($HOROLOG,"M")
+6 SET A(3)="Performing Lab Sites:"
SET A(3,"F")="!!"
+7 SET LR4=0
SET LRJ=$ORDER(A(""),-1)+1
+8 FOR
SET LR4=$ORDER(LRPLS(LR4))
if LR4=""
QUIT
Begin DoDot:1
+9 SET LRX=$$NAME^XUAF4(LR4)
SET CLIA=$$ID^XUAF4("CLIA",LR4)
SET LRY="["_LR4_"] "
+10 SET A(LRJ)=LRY_LRX
SET A(LRJ,"F")="!!"
+11 IF CLIA'=""
Begin DoDot:2
+12 IF $LENGTH(A(LRJ))<60
SET A(LRJ)=A(LRJ)_" [CLIA# "_CLIA_"]"
+13 IF '$TEST
SET A(LRJ+.5)="CLIA# "_CLIA
SET A(LRJ+.5,"F")="!?"_$LENGTH(LRY)
End DoDot:2
+14 SET LRX=$$PADD^XUAF4(LR4)
+15 SET A(LRJ+1)=$PIECE(LRX,U)_" "_$PIECE(LRX,U,2)_", "_$PIECE(LRX,U,3)_" "_$PIECE(LRX,U,4)
+16 SET A(LRJ+1,"F")="!?"_$LENGTH(LRY)
SET LRJ=LRJ+2
End DoDot:1
+17 DO EN^DDIOL(.A)
+18 QUIT
