LRWRKLST ;DALOI/STAFF - LONG ACCESSION LIST ;Mar 22, 2021@17:48
;;5.2;LAB SERVICE;**1,17,38,153,185,221,268,362,350,536,543,555,565**;Sep 27, 1994;Build 7
;
N LRDICS
;
; Save and restore DIC("S") if micro long form accession option (LRMIACC1).
I $D(DIC("S")) S LRDICS=DIC("S")
D LREND
I $D(LRDICS) S DIC("S")=LRDICS
;
S LRDT=$$FMTE^XLFDT($$NOW^XLFDT,"5MZ")
;
S LREND=0
S DIC="^LRO(68,",DIC(0)="AEMOQ"
D ^DIC S LRAA=+Y,LRNAME=$P(Y,U,2)
I LRAA<1 D LREND Q
;
; Ask if list by date rather than accession number
I $P(^LRO(68,LRAA,0),U,3)="Y" D STAR^LRWU3 S LRLAST=$G(LAST)
I LREND D LREND Q
; List by accession number
I '$D(LRSTAR) D PHD
I LREND D LREND Q
;
W ; from LRVER, LRVR
; Added to protect "%*" variables from %ZTLOAD corruption
N %,%A,%A0,%B,%B1,%B2,%B3,%BA,%BU,%C,%D1,%D2,%DT,%E,%G,%H,%I,%J
N %J1,%K,%M,%N,%P,%S,%T,%W,%W0,%X,%Y
N A0,C,D,DD,DDH,DDQ,DDSV,DG,DH,DIC,DIFLD,DIR,DIRO,DIROUT,DIRUT
N DIX,DIY,DISYS,DO,DP,DQ,DTOUT,DU,DZ,X1,XQH
;
I '$D(^LRO(68,LRAA,1,LRAD,1,0)),'$D(LRSTAR) D LREND Q
;
S (LRUNC,LRTSE)=0
S:'$D(LRNAME) LRNAME=$P(^LRO(68,LRAA,0),U,1)
;
S DIR(0)="YO",DIR("A")="Do you want a specific test",DIR("B")="NO"
D ^DIR
I $D(DIRUT) D LREND Q
I Y=1 D
. N DIC,X,Y
. S DIC="^LAB(60,",DIC(0)="AEZOQ"
. D ^DIC
. I Y>0 S LRTSE=+Y
;
K DIR
S DIR(0)="YO",DIR("A")="Do you want only incomplete entries",DIR("B")="YES"
D ^DIR
I $D(DIRUT) D LREND Q
S LRUNC=Y
;
S %ZIS="Q" D ^%ZIS
I POP D ^%ZISC,LREND Q
;
; Queue report via Taskman
I $D(IO("Q")) D Q
. N ZTDESC,ZTSK,ZTRTN,ZTIO,ZTSAVE,%T
. S ZTRTN="ENT^LRWRKLST",ZTDESC="Long form accession list",ZTSAVE("LR*")=""
. D ^%ZTLOAD,^%ZISC
. W !,"Task ",$S($G(ZTSK):ZTSK,1:"NOT")," Queued"
. D LREND K IO("Q")
;
ENT ;
;
N LRTST,LRMIPND
;
I $D(ZTQUEUED) S ZTREQ="@"
S (LREND,LRSTOP)=0
;
;
U IO
D HED,URG^LRX
;
; Process by accession date
I '$D(LRSTAR) D
. S LRAN=LRFAN-1
. F S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN)) Q:'LRAN!(LRAN>LRLAN) D Q:LRSTOP
. . S LREND=0 D TD
. . I LREND Q
. . D LST,TESTS
;
; Process by date received in lab - yearly accession area
I $D(LRSTAR) D
. F S LRAD=$O(^LRO(68,LRAA,1,LRAD)) Q:LRAD<1!(LRAD>LRWDTL) D AC Q:LRSTOP
;
D ^%ZISC,LREND
Q
;
;
TD ; Check tests on accession to determine if meets criteria to display.
; If incomplete only (LRUNC=1) and complete date then skip
; If not specific test selected (LRTSE=file #60 ien) then skip
; Otherwise set LRTST array with file #60 ien.
;
K LRTST,LRMIPND
;
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S LREND=1 Q
S LRSN=+$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,5),LRDAT=+$P(^(0),U,4)
S LRI=0
F S LRI=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI)) Q:LRI<.5 D
. I LRTSE,LRTSE'=+^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0) Q
. ;LR*5.2*536 added line below
. I $P(^LRO(68,LRAA,0),U,2)="MI",$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0),"^",5) D MICRO
. I LRUNC,$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0),"^",5) Q
. S LRTST(LRI)=""
;
I '$D(LRTST) S LREND=1
Q
;
MICRO ;further evaluation for Microbiology test
N LRDFNX,LRIDTX,LREXCODE,LRMIAREA
S LRDFNX=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U)
S LRIDTX=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
S LREXCODE=$P($G(^LAB(60,LRI,0)),"^",14)
Q:'LREXCODE
S LREXCODE=$G(^LAB(62.07,LREXCODE,.1))
;Logic below is the same as the logic in result verification
;routine LRMIEDZ2 which determines which Microbiology area is
;defined for a Microbiology test
S LRMIAREA=$S(LREXCODE["11.5":1,LREXCODE["23":11,LREXCODE["19":8,LREXCODE["15":5,LREXCODE["34":16,1:"")
;If the [area] RPT DATE APPROVED field is null, display this test as "pending"
;LR*5.2*543: Add check at 6th piece as to whether has been marked "not performed" or "merged".
I $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0),"^",6)']"",$D(^LR(LRDFNX,"MI",LRIDTX,LRMIAREA)),$P(^(LRMIAREA),U)="" D
. ;Include on report as a pending test if user specific only incompletes
. I LRUNC S LRTST(LRI)=""
. ;flag as a pending test for section TS2
. S LRMIPND(LRI)=""
Q
;
TESTS ;
N S1,S2
;
D CHKPAGE^LRWRKLS1
Q:LRSTOP!LREND
;
Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
;
S LRSPEC=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)),LRSAMP=$S(LRSPEC:$P(^(0),U,2),1:"")
S S1=$P($G(^LAB(61,+LRSPEC,0)),U,1)
S S2=$P($G(^LAB(62,+LRSAMP,0)),U,1)
;
W !," SAMPLE: ",S1_$S(S1'=S2:" "_S2,1:"")
S LN=LN+1
;
S LRLO69=$G(^LRO(69,LRDAT,1,LRSN,0))
I LRLO69'="",$D(^LRO(69,LRDAT,1,LRSN,1)),$L($P(^(1),U,6)) W !,$P(^(1),U,6) S LN=LN+1
;
K LRNAC
S LRI=0
F S LRI=$O(LRTST(LRI)) Q:'LRI D TS2
;
I '$D(LRNAC),$L($P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,4)) D
. W !,"ALL COMPLETED",!!
. S LN=LN+3
E I $$CHKAC() W !,"ALL COMPLETED",!! S LN=LN+3
Q
;
;
CHKAC() ;Are all tests complete?
N LRT,LRP,LRC
Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4))
S LRT=0 F S LRT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT)) Q:LRT<1 D
. I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0)),U,5)'="" S LRC(LRT)=$P(^(0),U,4)
. E S LRP(LRT)=$P(^(0),U,5)_U_$P(^(0),U,9)
Q '$D(LRP)
TS2 ;
;
D CHKPAGE^LRWRKLS1
Q:LRSTOP!LREND
;
S LRXXX=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0)),LRURG=+$P(LRXXX,U,2)
W !," TEST: ",$P($G(^LAB(60,+LRXXX,0),"deleted test"),"^")
S LN=LN+1
;
W ?40,$S($D(LRURG(LRURG)):LRURG(LRURG),1:"")
I $P(LRXXX,U,3)'="" W ?55," LIST: ",$P($G(^LRO(68.2,+$P(LRXXX,U,3),0)),U,1)," ",$P($P(LRXXX,U,3),";",2,3)
;
I $D(^LRO(69,LRDAT,1,LRSN,2,"B",LRI)) D
. N I,X
. S X=$O(^LRO(69,LRDAT,1,LRSN,2,"B",LRI,0))
. I X,$O(^LRO(69,LRDAT,1,LRSN,2,X,1,0)) D
. . S I=0
. . F S I=$O(^LRO(69,LRDAT,1,LRSN,2,X,1,I)) Q:I<1 W !?3,": "_^(I,0)
;
D REF
;
;LR*5.2*536 - add check of LRMIPND for pending Microbiology test
I $P(LRXXX,U,5),'$D(LRMIPND(LRI)) W !," COMPLETED: ",$$FMTE^XLFDT($P(LRXXX,U,5),"MZ") S LN=LN+1
E S LRNAC=""
Q
;
;
REF ; if referred test, display status and manifest
;
N LRDFN,LRDN,LREVNT,LRIDT,LRIENS,LRMAN,LRSCFG,LRSS,LRUID,LRY
;
S LRUID=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^") Q:LRUID=""
S LRMAN=$P(LRXXX,"^",10),LRSCFG=""
I LRMAN D
. S LRSCFG=$P($G(^LAHM(62.8,LRMAN,0)),"^",2)
. I LRSCFG S LRSCFG(0)=$G(^LAHM(62.9,LRSCFG,0),"Unknown/deleted")
. S LRMAN=$P($G(^LAHM(62.8,LRMAN,0)),"^")
S LREVNT=$$STATUS^LREVENT(LRUID,+LRXXX,LRMAN)
I LREVNT'="" D
. W !,?4,"REFERRAL STATUS..: "_$P(LREVNT,"^")_" ("_$P(LREVNT,"^",2)_")"
. W !,?4,"SHIPPING MANIFEST: "_$P(LREVNT,"^",3)
. S LN=LN+2
. I LRSCFG D
. . W " using shipping config "_$P(LRSCFG(0),"^")
. . W !,?4,"SHIPPED TO.......: "_$P($$NS^XUAF4($P(LRSCFG(0),"^",3)),"^")
. . S LN=LN+1
;
; Display external order info (placer/filler) if any.
S LRDFN=+LRDX
S LRY=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
S LRIDT=$P(LRY,"^",5),LRSS=$P($G(^LRO(68,LRAA,0)),"^",2)
S LRDN=0,LRTEST=+LRXXX
I LRSS="CH" D LR60DN(.LRDN,LRTEST,.LRTST)
;
S LRDN=0
F S LRDN=$O(LRDN(LRDN)) Q:LRDN<1 D
. S LRIENS=LRDFN_","_LRSS_","_LRIDT_","_LRDN
. F LRTYPE=3,4 I $D(^LR(LRDFN,"EPR","AD",LRIENS,LRTYPE)) D
. . N LRDATA,LRON,LRREF,LRJ
. . S LRJ=$O(^LR(LRDFN,"EPR","AD",LRIENS,LRTYPE,0)),LRREF=LRJ_","_LRDFN_","
. . D GETDATA^LRUEPR(.LRDATA,LRREF)
. . S LRON=$G(LRDATA(63.00013,LRREF,1,"I")),LRON(0)="Unknown"
. . I LRON="" Q
. . I $P($G(LRDATA(63.00013,LRREF,.03,"I")),";",2)="DIC(4," S LRON(0)=$P($$NS^XUAF4(+LRDATA(63.00013,LRREF,.03,"I")),"^")
. . W !,?4,LRON(0)_$S(LRTYPE=3:" placer",1:" filler")_" order # "_LRON
;
Q
;
;
PHD ;
Q:LREND
S LREND=0,U="^"
D ADATE^LRWU Q:LREND
D LRAN^LRWU3
Q
;
LST ;
D HED:($E(IOST)="P"&($Y+11>IOSL)),LST1^LRWRKLS1
Q
;
HED ;
W @IOF,!,"LONG FORM",?30,"NOT FOR WARD USE",!
W "Accession Area: ",LRNAME,?40,LRDT,!!
S LN=4
Q
;
AC ;
I LRSTOP!LREND Q
;
S LRTK=LRSTAR-.00001
F S LRTK=$O(^LRO(68,LRAA,1,LRAD,1,"E",LRTK)) Q:LRTK<1!(LRTK\1>LRLAST) D Q:LRSTOP
. S LRAN=0
. F S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,"E",LRTK,LRAN)) Q:LRAN<1!(LRSTOP) D
. . I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) Q
. . S LREND=0 D TD
. . I LREND Q
. . D LST,TESTS
Q
;
;
LREND ;
D KVAR^VADPT
K %,%DT,%ZIS
K LN,LRA,AGE,DFN,DIC,DIR,DIRUT,DOB,DTOUT,DUOUT,K,LAST
K LRACC,LRDLA,LRDLC,LRDX,LRI,LRLO69,LRSAMP,LRSPEC
K LRURG,LRWRD,LRACO,DIC,LRUNC,LRDAT,LRAA,LRAD
K LRNAC,LRAN,LRCE,LRDPF,LRSN,LRDTO,LRLAST,LRPRAC,LRSTAR,LRXXX
K LRB,LRLAN,LRDT,LREND,LRFAN,LRIX,LRNAME,LRTSE,LRTST
K LRDFN,LREDT,LRLLOC,LRSDT,LRTK,LRWDTL,POP,LRSTOP
K PNM,SEX,SSN,X,X1,X2,Y,Z,ZTSK
Q
;
;
EN ;
SINGLE ;
;
N LRAA,LRACC,LRAD,LRAN,LREND,LRSTOP,LRTSE,LRUNC,LRURG
;
D URG^LRX
;
F D Q:LREND!LRSTOP
. S (LREND,LRUNC,LRSTOP,LRTSE)=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
. ;LR*5.2*565: Reset date subscript if accession rolled over.
. N LRROLL
. S LRROLL=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,9))
. I LRROLL S LRAD=LRROLL
. D TD,LST1^LRWRKLS1,TESTS
. W !
;
D LREND
Q
;
;
LR60DN(LRDN,LR60,LRTST) ; Retreive CH subscript dataname for a test
N LRX,LRY
;
S LRX=$P($G(^LAB(60,LR60,.2)),"^")
I LRX>0 S LRDN(LRX)="" Q
;
; Expand and check panel tests
S LRY=0
F S LRY=$O(^LAB(60,LR60,2,LRY)) Q:LRY<1 D
. S LRY(0)=$P($G(^LAB(60,LR60,2,LRY,0)),"^")
. I LRY(0)<1 Q
. I $D(LRTST(LRY(0))) Q ; test on panel also on accession as individual test
. D LR60DN(.LRDN,LRY(0))
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRWRKLST 9389 printed Sep 23, 2025@19:58:51 Page 2
LRWRKLST ;DALOI/STAFF - LONG ACCESSION LIST ;Mar 22, 2021@17:48
+1 ;;5.2;LAB SERVICE;**1,17,38,153,185,221,268,362,350,536,543,555,565**;Sep 27, 1994;Build 7
+2 ;
+3 NEW LRDICS
+4 ;
+5 ; Save and restore DIC("S") if micro long form accession option (LRMIACC1).
+6 IF $DATA(DIC("S"))
SET LRDICS=DIC("S")
+7 DO LREND
+8 IF $DATA(LRDICS)
SET DIC("S")=LRDICS
+9 ;
+10 SET LRDT=$$FMTE^XLFDT($$NOW^XLFDT,"5MZ")
+11 ;
+12 SET LREND=0
+13 SET DIC="^LRO(68,"
SET DIC(0)="AEMOQ"
+14 DO ^DIC
SET LRAA=+Y
SET LRNAME=$PIECE(Y,U,2)
+15 IF LRAA<1
DO LREND
QUIT
+16 ;
+17 ; Ask if list by date rather than accession number
+18 IF $PIECE(^LRO(68,LRAA,0),U,3)="Y"
DO STAR^LRWU3
SET LRLAST=$GET(LAST)
+19 IF LREND
DO LREND
QUIT
+20 ; List by accession number
+21 IF '$DATA(LRSTAR)
DO PHD
+22 IF LREND
DO LREND
QUIT
+23 ;
W ; from LRVER, LRVR
+1 ; Added to protect "%*" variables from %ZTLOAD corruption
+2 NEW %,%A,%A0,%B,%B1,%B2,%B3,%BA,%BU,%C,%D1,%D2,%DT,%E,%G,%H,%I,%J
+3 NEW %J1,%K,%M,%N,%P,%S,%T,%W,%W0,%X,%Y
+4 NEW A0,C,D,DD,DDH,DDQ,DDSV,DG,DH,DIC,DIFLD,DIR,DIRO,DIROUT,DIRUT
+5 NEW DIX,DIY,DISYS,DO,DP,DQ,DTOUT,DU,DZ,X1,XQH
+6 ;
+7 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,0))
IF '$DATA(LRSTAR)
DO LREND
QUIT
+8 ;
+9 SET (LRUNC,LRTSE)=0
+10 if '$DATA(LRNAME)
SET LRNAME=$PIECE(^LRO(68,LRAA,0),U,1)
+11 ;
+12 SET DIR(0)="YO"
SET DIR("A")="Do you want a specific test"
SET DIR("B")="NO"
+13 DO ^DIR
+14 IF $DATA(DIRUT)
DO LREND
QUIT
+15 IF Y=1
Begin DoDot:1
+16 NEW DIC,X,Y
+17 SET DIC="^LAB(60,"
SET DIC(0)="AEZOQ"
+18 DO ^DIC
+19 IF Y>0
SET LRTSE=+Y
End DoDot:1
+20 ;
+21 KILL DIR
+22 SET DIR(0)="YO"
SET DIR("A")="Do you want only incomplete entries"
SET DIR("B")="YES"
+23 DO ^DIR
+24 IF $DATA(DIRUT)
DO LREND
QUIT
+25 SET LRUNC=Y
+26 ;
+27 SET %ZIS="Q"
DO ^%ZIS
+28 IF POP
DO ^%ZISC
DO LREND
QUIT
+29 ;
+30 ; Queue report via Taskman
+31 IF $DATA(IO("Q"))
Begin DoDot:1
+32 NEW ZTDESC,ZTSK,ZTRTN,ZTIO,ZTSAVE,%T
+33 SET ZTRTN="ENT^LRWRKLST"
SET ZTDESC="Long form accession list"
SET ZTSAVE("LR*")=""
+34 DO ^%ZTLOAD
DO ^%ZISC
+35 WRITE !,"Task ",$SELECT($GET(ZTSK):ZTSK,1:"NOT")," Queued"
+36 DO LREND
KILL IO("Q")
End DoDot:1
QUIT
+37 ;
ENT ;
+1 ;
+2 NEW LRTST,LRMIPND
+3 ;
+4 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 SET (LREND,LRSTOP)=0
+6 ;
+7 ;
+8 USE IO
+9 DO HED
DO URG^LRX
+10 ;
+11 ; Process by accession date
+12 IF '$DATA(LRSTAR)
Begin DoDot:1
+13 SET LRAN=LRFAN-1
+14 FOR
SET LRAN=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN))
if 'LRAN!(LRAN>LRLAN)
QUIT
Begin DoDot:2
+15 SET LREND=0
DO TD
+16 IF LREND
QUIT
+17 DO LST
DO TESTS
End DoDot:2
if LRSTOP
QUIT
End DoDot:1
+18 ;
+19 ; Process by date received in lab - yearly accession area
+20 IF $DATA(LRSTAR)
Begin DoDot:1
+21 FOR
SET LRAD=$ORDER(^LRO(68,LRAA,1,LRAD))
if LRAD<1!(LRAD>LRWDTL)
QUIT
DO AC
if LRSTOP
QUIT
End DoDot:1
+22 ;
+23 DO ^%ZISC
DO LREND
+24 QUIT
+25 ;
+26 ;
TD ; Check tests on accession to determine if meets criteria to display.
+1 ; If incomplete only (LRUNC=1) and complete date then skip
+2 ; If not specific test selected (LRTSE=file #60 ien) then skip
+3 ; Otherwise set LRTST array with file #60 ien.
+4 ;
+5 KILL LRTST,LRMIPND
+6 ;
+7 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
SET LREND=1
QUIT
+8 SET LRSN=+$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,5)
SET LRDAT=+$PIECE(^(0),U,4)
+9 SET LRI=0
+10 FOR
SET LRI=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI))
if LRI<.5
QUIT
Begin DoDot:1
+11 IF LRTSE
IF LRTSE'=+^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0)
QUIT
+12 ;LR*5.2*536 added line below
+13 IF $PIECE(^LRO(68,LRAA,0),U,2)="MI"
IF $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0),"^",5)
DO MICRO
+14 IF LRUNC
IF $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0),"^",5)
QUIT
+15 SET LRTST(LRI)=""
End DoDot:1
+16 ;
+17 IF '$DATA(LRTST)
SET LREND=1
+18 QUIT
+19 ;
MICRO ;further evaluation for Microbiology test
+1 NEW LRDFNX,LRIDTX,LREXCODE,LRMIAREA
+2 SET LRDFNX=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U)
+3 SET LRIDTX=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
+4 SET LREXCODE=$PIECE($GET(^LAB(60,LRI,0)),"^",14)
+5 if 'LREXCODE
QUIT
+6 SET LREXCODE=$GET(^LAB(62.07,LREXCODE,.1))
+7 ;Logic below is the same as the logic in result verification
+8 ;routine LRMIEDZ2 which determines which Microbiology area is
+9 ;defined for a Microbiology test
+10 SET LRMIAREA=$SELECT(LREXCODE["11.5":1,LREXCODE["23":11,LREXCODE["19":8,LREXCODE["15":5,LREXCODE["34":16,1:"")
+11 ;If the [area] RPT DATE APPROVED field is null, display this test as "pending"
+12 ;LR*5.2*543: Add check at 6th piece as to whether has been marked "not performed" or "merged".
+13 IF $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0),"^",6)']""
IF $DATA(^LR(LRDFNX,"MI",LRIDTX,LRMIAREA))
IF $PIECE(^(LRMIAREA),U)=""
Begin DoDot:1
+14 ;Include on report as a pending test if user specific only incompletes
+15 IF LRUNC
SET LRTST(LRI)=""
+16 ;flag as a pending test for section TS2
+17 SET LRMIPND(LRI)=""
End DoDot:1
+18 QUIT
+19 ;
TESTS ;
+1 NEW S1,S2
+2 ;
+3 DO CHKPAGE^LRWRKLS1
+4 if LRSTOP!LREND
QUIT
+5 ;
+6 if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
QUIT
+7 ;
+8 SET LRSPEC=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0))
SET LRSAMP=$SELECT(LRSPEC:$PIECE(^(0),U,2),1:"")
+9 SET S1=$PIECE($GET(^LAB(61,+LRSPEC,0)),U,1)
+10 SET S2=$PIECE($GET(^LAB(62,+LRSAMP,0)),U,1)
+11 ;
+12 WRITE !," SAMPLE: ",S1_$SELECT(S1'=S2:" "_S2,1:"")
+13 SET LN=LN+1
+14 ;
+15 SET LRLO69=$GET(^LRO(69,LRDAT,1,LRSN,0))
+16 IF LRLO69'=""
IF $DATA(^LRO(69,LRDAT,1,LRSN,1))
IF $LENGTH($PIECE(^(1),U,6))
WRITE !,$PIECE(^(1),U,6)
SET LN=LN+1
+17 ;
+18 KILL LRNAC
+19 SET LRI=0
+20 FOR
SET LRI=$ORDER(LRTST(LRI))
if 'LRI
QUIT
DO TS2
+21 ;
+22 IF '$DATA(LRNAC)
IF $LENGTH($PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,4))
Begin DoDot:1
+23 WRITE !,"ALL COMPLETED",!!
+24 SET LN=LN+3
End DoDot:1
+25 IF '$TEST
IF $$CHKAC()
WRITE !,"ALL COMPLETED",!!
SET LN=LN+3
+26 QUIT
+27 ;
+28 ;
CHKAC() ;Are all tests complete?
+1 NEW LRT,LRP,LRC
+2 if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4))
QUIT
+3 SET LRT=0
FOR
SET LRT=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT))
if LRT<1
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0)),U,5)'=""
SET LRC(LRT)=$PIECE(^(0),U,4)
+5 IF '$TEST
SET LRP(LRT)=$PIECE(^(0),U,5)_U_$PIECE(^(0),U,9)
End DoDot:1
+6 QUIT '$DATA(LRP)
TS2 ;
+1 ;
+2 DO CHKPAGE^LRWRKLS1
+3 if LRSTOP!LREND
QUIT
+4 ;
+5 SET LRXXX=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0))
SET LRURG=+$PIECE(LRXXX,U,2)
+6 WRITE !," TEST: ",$PIECE($GET(^LAB(60,+LRXXX,0),"deleted test"),"^")
+7 SET LN=LN+1
+8 ;
+9 WRITE ?40,$SELECT($DATA(LRURG(LRURG)):LRURG(LRURG),1:"")
+10 IF $PIECE(LRXXX,U,3)'=""
WRITE ?55," LIST: ",$PIECE($GET(^LRO(68.2,+$PIECE(LRXXX,U,3),0)),U,1)," ",$PIECE($PIECE(LRXXX,U,3),";",2,3)
+11 ;
+12 IF $DATA(^LRO(69,LRDAT,1,LRSN,2,"B",LRI))
Begin DoDot:1
+13 NEW I,X
+14 SET X=$ORDER(^LRO(69,LRDAT,1,LRSN,2,"B",LRI,0))
+15 IF X
IF $ORDER(^LRO(69,LRDAT,1,LRSN,2,X,1,0))
Begin DoDot:2
+16 SET I=0
+17 FOR
SET I=$ORDER(^LRO(69,LRDAT,1,LRSN,2,X,1,I))
if I<1
QUIT
WRITE !?3,": "_^(I,0)
End DoDot:2
End DoDot:1
+18 ;
+19 DO REF
+20 ;
+21 ;LR*5.2*536 - add check of LRMIPND for pending Microbiology test
+22 IF $PIECE(LRXXX,U,5)
IF '$DATA(LRMIPND(LRI))
WRITE !," COMPLETED: ",$$FMTE^XLFDT($PIECE(LRXXX,U,5),"MZ")
SET LN=LN+1
+23 IF '$TEST
SET LRNAC=""
+24 QUIT
+25 ;
+26 ;
REF ; if referred test, display status and manifest
+1 ;
+2 NEW LRDFN,LRDN,LREVNT,LRIDT,LRIENS,LRMAN,LRSCFG,LRSS,LRUID,LRY
+3 ;
+4 SET LRUID=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
if LRUID=""
QUIT
+5 SET LRMAN=$PIECE(LRXXX,"^",10)
SET LRSCFG=""
+6 IF LRMAN
Begin DoDot:1
+7 SET LRSCFG=$PIECE($GET(^LAHM(62.8,LRMAN,0)),"^",2)
+8 IF LRSCFG
SET LRSCFG(0)=$GET(^LAHM(62.9,LRSCFG,0),"Unknown/deleted")
+9 SET LRMAN=$PIECE($GET(^LAHM(62.8,LRMAN,0)),"^")
End DoDot:1
+10 SET LREVNT=$$STATUS^LREVENT(LRUID,+LRXXX,LRMAN)
+11 IF LREVNT'=""
Begin DoDot:1
+12 WRITE !,?4,"REFERRAL STATUS..: "_$PIECE(LREVNT,"^")_" ("_$PIECE(LREVNT,"^",2)_")"
+13 WRITE !,?4,"SHIPPING MANIFEST: "_$PIECE(LREVNT,"^",3)
+14 SET LN=LN+2
+15 IF LRSCFG
Begin DoDot:2
+16 WRITE " using shipping config "_$PIECE(LRSCFG(0),"^")
+17 WRITE !,?4,"SHIPPED TO.......: "_$PIECE($$NS^XUAF4($PIECE(LRSCFG(0),"^",3)),"^")
+18 SET LN=LN+1
End DoDot:2
End DoDot:1
+19 ;
+20 ; Display external order info (placer/filler) if any.
+21 SET LRDFN=+LRDX
+22 SET LRY=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
+23 SET LRIDT=$PIECE(LRY,"^",5)
SET LRSS=$PIECE($GET(^LRO(68,LRAA,0)),"^",2)
+24 SET LRDN=0
SET LRTEST=+LRXXX
+25 IF LRSS="CH"
DO LR60DN(.LRDN,LRTEST,.LRTST)
+26 ;
+27 SET LRDN=0
+28 FOR
SET LRDN=$ORDER(LRDN(LRDN))
if LRDN<1
QUIT
Begin DoDot:1
+29 SET LRIENS=LRDFN_","_LRSS_","_LRIDT_","_LRDN
+30 FOR LRTYPE=3,4
IF $DATA(^LR(LRDFN,"EPR","AD",LRIENS,LRTYPE))
Begin DoDot:2
+31 NEW LRDATA,LRON,LRREF,LRJ
+32 SET LRJ=$ORDER(^LR(LRDFN,"EPR","AD",LRIENS,LRTYPE,0))
SET LRREF=LRJ_","_LRDFN_","
+33 DO GETDATA^LRUEPR(.LRDATA,LRREF)
+34 SET LRON=$GET(LRDATA(63.00013,LRREF,1,"I"))
SET LRON(0)="Unknown"
+35 IF LRON=""
QUIT
+36 IF $PIECE($GET(LRDATA(63.00013,LRREF,.03,"I")),";",2)="DIC(4,"
SET LRON(0)=$PIECE($$NS^XUAF4(+LRDATA(63.00013,LRREF,.03,"I")),"^")
+37 WRITE !,?4,LRON(0)_$SELECT(LRTYPE=3:" placer",1:" filler")_" order # "_LRON
End DoDot:2
End DoDot:1
+38 ;
+39 QUIT
+40 ;
+41 ;
PHD ;
+1 if LREND
QUIT
+2 SET LREND=0
SET U="^"
+3 DO ADATE^LRWU
if LREND
QUIT
+4 DO LRAN^LRWU3
+5 QUIT
+6 ;
LST ;
+1 if ($EXTRACT(IOST)="P"&($Y+11>IOSL))
DO HED
DO LST1^LRWRKLS1
+2 QUIT
+3 ;
HED ;
+1 WRITE @IOF,!,"LONG FORM",?30,"NOT FOR WARD USE",!
+2 WRITE "Accession Area: ",LRNAME,?40,LRDT,!!
+3 SET LN=4
+4 QUIT
+5 ;
AC ;
+1 IF LRSTOP!LREND
QUIT
+2 ;
+3 SET LRTK=LRSTAR-.00001
+4 FOR
SET LRTK=$ORDER(^LRO(68,LRAA,1,LRAD,1,"E",LRTK))
if LRTK<1!(LRTK\1>LRLAST)
QUIT
Begin DoDot:1
+5 SET LRAN=0
+6 FOR
SET LRAN=$ORDER(^LRO(68,LRAA,1,LRAD,1,"E",LRTK,LRAN))
if LRAN<1!(LRSTOP)
QUIT
Begin DoDot:2
+7 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
QUIT
+8 SET LREND=0
DO TD
+9 IF LREND
QUIT
+10 DO LST
DO TESTS
End DoDot:2
End DoDot:1
if LRSTOP
QUIT
+11 QUIT
+12 ;
+13 ;
LREND ;
+1 DO KVAR^VADPT
+2 KILL %,%DT,%ZIS
+3 KILL LN,LRA,AGE,DFN,DIC,DIR,DIRUT,DOB,DTOUT,DUOUT,K,LAST
+4 KILL LRACC,LRDLA,LRDLC,LRDX,LRI,LRLO69,LRSAMP,LRSPEC
+5 KILL LRURG,LRWRD,LRACO,DIC,LRUNC,LRDAT,LRAA,LRAD
+6 KILL LRNAC,LRAN,LRCE,LRDPF,LRSN,LRDTO,LRLAST,LRPRAC,LRSTAR,LRXXX
+7 KILL LRB,LRLAN,LRDT,LREND,LRFAN,LRIX,LRNAME,LRTSE,LRTST
+8 KILL LRDFN,LREDT,LRLLOC,LRSDT,LRTK,LRWDTL,POP,LRSTOP
+9 KILL PNM,SEX,SSN,X,X1,X2,Y,Z,ZTSK
+10 QUIT
+11 ;
+12 ;
EN ;
SINGLE ;
+1 ;
+2 NEW LRAA,LRACC,LRAD,LRAN,LREND,LRSTOP,LRTSE,LRUNC,LRURG
+3 ;
+4 DO URG^LRX
+5 ;
+6 FOR
Begin DoDot:1
+7 SET (LREND,LRUNC,LRSTOP,LRTSE)=0
+8 SET LRACC=""
DO ^LRWU4
+9 IF LRAN<1
SET LREND=1
QUIT
+10 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
WRITE !,"Doesn't exist."
QUIT
+11 ;LR*5.2*565: Reset date subscript if accession rolled over.
+12 NEW LRROLL
+13 SET LRROLL=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,9))
+14 IF LRROLL
SET LRAD=LRROLL
+15 DO TD
DO LST1^LRWRKLS1
DO TESTS
+16 WRITE !
End DoDot:1
if LREND!LRSTOP
QUIT
+17 ;
+18 DO LREND
+19 QUIT
+20 ;
+21 ;
LR60DN(LRDN,LR60,LRTST) ; Retreive CH subscript dataname for a test
+1 NEW LRX,LRY
+2 ;
+3 SET LRX=$PIECE($GET(^LAB(60,LR60,.2)),"^")
+4 IF LRX>0
SET LRDN(LRX)=""
QUIT
+5 ;
+6 ; Expand and check panel tests
+7 SET LRY=0
+8 FOR
SET LRY=$ORDER(^LAB(60,LR60,2,LRY))
if LRY<1
QUIT
Begin DoDot:1
+9 SET LRY(0)=$PIECE($GET(^LAB(60,LR60,2,LRY,0)),"^")
+10 IF LRY(0)<1
QUIT
+11 ; test on panel also on accession as individual test
IF $DATA(LRTST(LRY(0)))
QUIT
+12 DO LR60DN(.LRDN,LRY(0))
End DoDot:1
+13 ;
+14 QUIT
