LRWRKIN1 ;SLC/DCM/CJS-LRWRKINC, CONT ;2/22/87 11:39 AM
;;5.2;LAB SERVICE;**153,201,221**;Sep 27, 1994
LST1 ;from LRWRKINC
S (LRDLC,LRDTO)=""
S LRDX=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
S LRCE=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.1))
S LRACC=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
S LRDX(0)=$G(^LR(+LRDX,0))
S LRDPF=$P(LRDX(0),U,2),DFN=$P(LRDX(0),U,3) D PT^LRX
I $P(LRDX,U,4) S LRDTO=$$FMTE^XLFDT($P(LRDX,"^",4),"5MZ")
S Y=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),LRDLA=$P(Y,U,3),LRACO=$P(Y,U,6)
I $P(Y,"^") S LRDLC=$$FMTE^XLFDT($P(U,"^"),"5MZ")
I LRDLA S $P(LRDLA,"^",2)=$$FMTE^XLFDT(LRDLA,"5MZ")
Q
;
X ;from LRWRKINC
N LRTSTN,LRACC,LRACCN,LRAN,LRUR
S LRTSTN="",LREND=0
F S LRTSTN=$O(^TMP($J,LRTSTN)) Q:LRTSTN="" D Q:LREND
. S J=0,LRUR=""
. F S LRUR=$O(^TMP($J,LRTSTN,LRUR)) Q:LRUR="" S LRU=$G(LRURG(LRUR)) D Q:LREND
. . S LRACCN=""
. . F S LRACCN=$O(^TMP($J,LRTSTN,LRUR,LRACCN)) Q:LRACCN="" D Q:LREND
. . . S LRAN=""
. . . F S LRAN=$O(^TMP($J,LRTSTN,LRUR,LRACCN,LRAN)) Q:LRAN="" D Q:LREND
. . . . I ($Y+8)>IOSL D Q:LREND
. . . . . D EQUALS^LRX
. . . . . I $E(IOST,1,2)="C-" D WAIT Q:LREND
. . . . . D HED
. . . . S J=J+1
. . . . S W=^TMP($J,LRTSTN,LRUR,LRACCN,LRAN),LRST=$P(W,U,1),SSN=$P(W,U,2),PNM=$P(W,U,3),LRLLOC=$P(W,U,4),LRCOLL=$P(W,U,5),LRMAN=$P(W,U,6),LRACC=$P(W,U,7)
. . . . W !,$E($S(LRSORTBY=1:$P(LRTSTN,"^",2),1:LRTSTN),1,20),?23,$E(LRU,1,9),?34,LRACC,?47," ",LRCOLL,?65,$E(LRLLOC,1,15)
. . . . S LRCL=$S(IOM<120:5,1:82) W:IOM<120 ! I IOM<120!('LREXD) W ?LRCL,SSN
. . . . S LRCL=$S(IOM<120:20,LREXD:82,1:97) W ?LRCL,$E(PNM,1,19)
. . . . S LRCL=$S(IOM<120:40,LREXD:102,1:117) W ?LRCL,$S('LREXD&(IOM'<120):$E(LRST,1,15),1:$E(LRST,1,30))
. . . . I LREXD D
. . . . . N A
. . . . . S A=$G(^TMP($J,LRTSTN,LRUR,LRACCN,LRAN,.3))
. . . . . S Y=$P(A,"^",2) I Y S C=$P(^DD(68.02,16.1,0),"^",2) D Y^DIQ
. . . . . W !,?23,$P(A,"^"),?48,$E(Y,1,16),?65,$P(A,"^",5) I IOM'<120 W ?82,SSN
. . . . . W:IOM<120 ! S LRCL=$S(IOM<120:20,1:102) W ?LRCL,LRMAN
. W:'LREND !,?7,"------",!,$J(J,13)
Q
;
HED ; Print header
I LRPAGE!($E(IOST,1,2)="C-") W @IOF
S LRPAGE=LRPAGE+1
W "INCOMPLETE STATUS REPORT *** NOT FOR WARD USE ***",?(IOM-16),LRDT
W !,"Accession Area(s):",?(IOM-10),"Page: ",LRPAGE
S LRINDEX=0
F S LRINDEX=$O(LRNAME(LRINDEX)) Q:'LRINDEX W !,LRNAME(LRINDEX)
W !!,"Test",?23,"Urgency",?34,"Accession",?48,"Date/time",?65,"Location"
S LRCL=$S(IOM<120:5,1:82)
W:IOM<120 !
I IOM<120!('LREXD) W ?LRCL,"SSN"
S LRCL=$S(IOM<120:20,LREXD:82,1:97) W ?LRCL,"Patient"
S LRCL=$S(IOM<120:40,LREXD:102,1:117) W ?LRCL,"Status"
I $G(LREXD) W !,?23,"UID",?48,"Sending Site",?65,"Sender's UID"
I LREXD,IOM'<120 W ?82,"SSN"
I LREXD W:IOM<120 ! S LRCL=$S(IOM<120:20,1:102) W ?LRCL,"Shipping Manifest"
D DASH^LRX
W !
Q
;
WAIT ;from LRWRKINC
I $E(IOST,1,2)'="C-" Q
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="E" D ^DIR
I $D(DIRUT) S LREND=1
Q
;
LREND ;
I $E(IOST,1,2)="P-" W @IOF
I $D(ZTQUEUED) S ZTREQ="@"
E D ^%ZISC
D KVA^VADPT
K %,%DT,%X,%Y,%ZIS,A,AGE,B,C,DIC,DICS,DFN,DOB,I,K,J,L,LAST,PNM,POP,SEX,SSN,W,X,X1,X2,Y,Z,ZTSK
K LRCNT,LRCUTOFF,LRDLA,LRDLC,LRDX,LRLO69,LRSAMP
K LRRB,LRSPEC,LRTREA,LRURG,LRWRD,LRCOLL,LRACO
K LRAA,LRACC,LRAD,LRAN,LRNAC,LRCE,LRDPF,LRSN,LRDTO,LRINDEX
K LREXNREQ,LRPAGE,LRPRAC,LRSORTBY,LRSTAR,LRX
K LA,LRLAN,LRDAT,LRDT,LREND,LREXD,LREXTST,LRFAN,LRFI,LRIX,LRMAN,LRNAME,LRNOCNTL
K LRTSE,LRVERVER,LRLLOC,LRU,LRST,LRCL,LRDFN,LREDT,LRIOZERO,LRSDT,LRTK,LRTSE,LRWDTL
K LRX,LRY,LRZ
K ^TMP("LRWRKINC",$J),^TMP($J)
Q
;
CHKAA ; Check if user wants to use criteria from another chosen area.
N DIR,DIRUT,DTOUT,DUOUT,LRFAN,LRINDEX,LRLAST,LRSTAR,LRX,LRY,LRZ,X,Y
S (LRINDEX,LRZ)=0,(LRUSEAA,LRX)=""
F S LRX=$O(^TMP("LRWRKINC",$J,LRX)) Q:LRX="" D
. S LRZ=0
. F S LRZ=$O(^TMP("LRWRKINC",$J,LRX,LRZ)) Q:'LRZ D
. . S LRZ(0)=^TMP("LRWRKINC",$J,LRX,LRZ,0)
. . S LRZ(1)=^TMP("LRWRKINC",$J,LRX,LRZ,1)
. . S LRY=""
. . I $P(LRAA(0),"^",3)'=$P(LRZ(0),"^",3) Q ; Not same accession transform.
. . I LRAA=$P(LRX,"^",2) Q ; Don't use criteria from same accession area.
. . S LRFAN=$P(LRZ(1),"^",2),LRLAN=$P(LRZ(1),"^",3),LRSTAR=$P(LRZ(1),"^",4),LRLAST=$P(LRZ(1),"^",5)
. . I LRSTAR,LRLAST S LRY="From Date: "_$$FMTE^XLFDT(LRSTAR,"2DZ")_" To: "_$$FMTE^XLFDT(LRLAST,"2DZ")
. . E S LRY="For Date: "_$$FMTE^XLFDT(LRLAST,"2DZ")_" From: "_LRFAN_" To: "_LRLAN
. . S LRINDEX=LRINDEX+1,LRINDEX(LRINDEX)=LRX_"^"_LRZ
. . S DIR("A",LRINDEX)=$J(LRINDEX,4)_" "_$P(LRZ(0),"^")_" "_LRY
I $D(DIR("A")) D
. S DIR(0)="NO^1:"_LRINDEX_":0"
. S DIR("A",LRINDEX+1)=" "
. S DIR("A")="Use Criteria from Accession Area"
. S DIR("?",1)="Use previously selected accession area's date and number criteria."
. S DIR("?")="Or press <RET> to specify different date/number criteria for "_$P(LRAA(0),"^")_"."
. W ! D ^DIR
. I '$D(DIRUT) S LRUSEAA=LRINDEX(Y) Q
. I $D(DUOUT)!$D(DTOUT) S LREND=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRWRKIN1 4954 printed Sep 23, 2025@19:58:48 Page 2
LRWRKIN1 ;SLC/DCM/CJS-LRWRKINC, CONT ;2/22/87 11:39 AM
+1 ;;5.2;LAB SERVICE;**153,201,221**;Sep 27, 1994
LST1 ;from LRWRKINC
+1 SET (LRDLC,LRDTO)=""
+2 SET LRDX=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
+3 SET LRCE=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.1))
+4 SET LRACC=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
+5 SET LRDX(0)=$GET(^LR(+LRDX,0))
+6 SET LRDPF=$PIECE(LRDX(0),U,2)
SET DFN=$PIECE(LRDX(0),U,3)
DO PT^LRX
+7 IF $PIECE(LRDX,U,4)
SET LRDTO=$$FMTE^XLFDT($PIECE(LRDX,"^",4),"5MZ")
+8 SET Y=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
SET LRDLA=$PIECE(Y,U,3)
SET LRACO=$PIECE(Y,U,6)
+9 IF $PIECE(Y,"^")
SET LRDLC=$$FMTE^XLFDT($PIECE(U,"^"),"5MZ")
+10 IF LRDLA
SET $PIECE(LRDLA,"^",2)=$$FMTE^XLFDT(LRDLA,"5MZ")
+11 QUIT
+12 ;
X ;from LRWRKINC
+1 NEW LRTSTN,LRACC,LRACCN,LRAN,LRUR
+2 SET LRTSTN=""
SET LREND=0
+3 FOR
SET LRTSTN=$ORDER(^TMP($JOB,LRTSTN))
if LRTSTN=""
QUIT
Begin DoDot:1
+4 SET J=0
SET LRUR=""
+5 FOR
SET LRUR=$ORDER(^TMP($JOB,LRTSTN,LRUR))
if LRUR=""
QUIT
SET LRU=$GET(LRURG(LRUR))
Begin DoDot:2
+6 SET LRACCN=""
+7 FOR
SET LRACCN=$ORDER(^TMP($JOB,LRTSTN,LRUR,LRACCN))
if LRACCN=""
QUIT
Begin DoDot:3
+8 SET LRAN=""
+9 FOR
SET LRAN=$ORDER(^TMP($JOB,LRTSTN,LRUR,LRACCN,LRAN))
if LRAN=""
QUIT
Begin DoDot:4
+10 IF ($Y+8)>IOSL
Begin DoDot:5
+11 DO EQUALS^LRX
+12 IF $EXTRACT(IOST,1,2)="C-"
DO WAIT
if LREND
QUIT
+13 DO HED
End DoDot:5
if LREND
QUIT
+14 SET J=J+1
+15 SET W=^TMP($JOB,LRTSTN,LRUR,LRACCN,LRAN)
SET LRST=$PIECE(W,U,1)
SET SSN=$PIECE(W,U,2)
SET PNM=$PIECE(W,U,3)
SET LRLLOC=$PIECE(W,U,4)
SET LRCOLL=$PIECE(W,U,5)
SET LRMAN=$PIECE(W,U,6)
SET LRACC=$PIECE(W,U,7)
+16 WRITE !,$EXTRACT($SELECT(LRSORTBY=1:$PIECE(LRTSTN,"^",2),1:LRTSTN),1,20),?23,$EXTRACT(LRU,1,9),?34,LRACC,?47," ",LRCOLL,?65,$EXTRACT(LRLLOC,1,15)
+17 SET LRCL=$SELECT(IOM<120:5,1:82)
if IOM<120
WRITE !
IF IOM<120!('LREXD)
WRITE ?LRCL,SSN
+18 SET LRCL=$SELECT(IOM<120:20,LREXD:82,1:97)
WRITE ?LRCL,$EXTRACT(PNM,1,19)
+19 SET LRCL=$SELECT(IOM<120:40,LREXD:102,1:117)
WRITE ?LRCL,$SELECT('LREXD&(IOM'<120):$EXTRACT(LRST,1,15),1:$EXTRACT(LRST,1,30))
+20 IF LREXD
Begin DoDot:5
+21 NEW A
+22 SET A=$GET(^TMP($JOB,LRTSTN,LRUR,LRACCN,LRAN,.3))
+23 SET Y=$PIECE(A,"^",2)
IF Y
SET C=$PIECE(^DD(68.02,16.1,0),"^",2)
DO Y^DIQ
+24 WRITE !,?23,$PIECE(A,"^"),?48,$EXTRACT(Y,1,16),?65,$PIECE(A,"^",5)
IF IOM'<120
WRITE ?82,SSN
+25 if IOM<120
WRITE !
SET LRCL=$SELECT(IOM<120:20,1:102)
WRITE ?LRCL,LRMAN
End DoDot:5
End DoDot:4
if LREND
QUIT
End DoDot:3
if LREND
QUIT
End DoDot:2
if LREND
QUIT
+26 if 'LREND
WRITE !,?7,"------",!,$JUSTIFY(J,13)
End DoDot:1
if LREND
QUIT
+27 QUIT
+28 ;
HED ; Print header
+1 IF LRPAGE!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF
+2 SET LRPAGE=LRPAGE+1
+3 WRITE "INCOMPLETE STATUS REPORT *** NOT FOR WARD USE ***",?(IOM-16),LRDT
+4 WRITE !,"Accession Area(s):",?(IOM-10),"Page: ",LRPAGE
+5 SET LRINDEX=0
+6 FOR
SET LRINDEX=$ORDER(LRNAME(LRINDEX))
if 'LRINDEX
QUIT
WRITE !,LRNAME(LRINDEX)
+7 WRITE !!,"Test",?23,"Urgency",?34,"Accession",?48,"Date/time",?65,"Location"
+8 SET LRCL=$SELECT(IOM<120:5,1:82)
+9 if IOM<120
WRITE !
+10 IF IOM<120!('LREXD)
WRITE ?LRCL,"SSN"
+11 SET LRCL=$SELECT(IOM<120:20,LREXD:82,1:97)
WRITE ?LRCL,"Patient"
+12 SET LRCL=$SELECT(IOM<120:40,LREXD:102,1:117)
WRITE ?LRCL,"Status"
+13 IF $GET(LREXD)
WRITE !,?23,"UID",?48,"Sending Site",?65,"Sender's UID"
+14 IF LREXD
IF IOM'<120
WRITE ?82,"SSN"
+15 IF LREXD
if IOM<120
WRITE !
SET LRCL=$SELECT(IOM<120:20,1:102)
WRITE ?LRCL,"Shipping Manifest"
+16 DO DASH^LRX
+17 WRITE !
+18 QUIT
+19 ;
WAIT ;from LRWRKINC
+1 IF $EXTRACT(IOST,1,2)'="C-"
QUIT
+2 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+3 SET DIR(0)="E"
DO ^DIR
+4 IF $DATA(DIRUT)
SET LREND=1
+5 QUIT
+6 ;
LREND ;
+1 IF $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 IF '$TEST
DO ^%ZISC
+4 DO KVA^VADPT
+5 KILL %,%DT,%X,%Y,%ZIS,A,AGE,B,C,DIC,DICS,DFN,DOB,I,K,J,L,LAST,PNM,POP,SEX,SSN,W,X,X1,X2,Y,Z,ZTSK
+6 KILL LRCNT,LRCUTOFF,LRDLA,LRDLC,LRDX,LRLO69,LRSAMP
+7 KILL LRRB,LRSPEC,LRTREA,LRURG,LRWRD,LRCOLL,LRACO
+8 KILL LRAA,LRACC,LRAD,LRAN,LRNAC,LRCE,LRDPF,LRSN,LRDTO,LRINDEX
+9 KILL LREXNREQ,LRPAGE,LRPRAC,LRSORTBY,LRSTAR,LRX
+10 KILL LA,LRLAN,LRDAT,LRDT,LREND,LREXD,LREXTST,LRFAN,LRFI,LRIX,LRMAN,LRNAME,LRNOCNTL
+11 KILL LRTSE,LRVERVER,LRLLOC,LRU,LRST,LRCL,LRDFN,LREDT,LRIOZERO,LRSDT,LRTK,LRTSE,LRWDTL
+12 KILL LRX,LRY,LRZ
+13 KILL ^TMP("LRWRKINC",$JOB),^TMP($JOB)
+14 QUIT
+15 ;
CHKAA ; Check if user wants to use criteria from another chosen area.
+1 NEW DIR,DIRUT,DTOUT,DUOUT,LRFAN,LRINDEX,LRLAST,LRSTAR,LRX,LRY,LRZ,X,Y
+2 SET (LRINDEX,LRZ)=0
SET (LRUSEAA,LRX)=""
+3 FOR
SET LRX=$ORDER(^TMP("LRWRKINC",$JOB,LRX))
if LRX=""
QUIT
Begin DoDot:1
+4 SET LRZ=0
+5 FOR
SET LRZ=$ORDER(^TMP("LRWRKINC",$JOB,LRX,LRZ))
if 'LRZ
QUIT
Begin DoDot:2
+6 SET LRZ(0)=^TMP("LRWRKINC",$JOB,LRX,LRZ,0)
+7 SET LRZ(1)=^TMP("LRWRKINC",$JOB,LRX,LRZ,1)
+8 SET LRY=""
+9 ; Not same accession transform.
IF $PIECE(LRAA(0),"^",3)'=$PIECE(LRZ(0),"^",3)
QUIT
+10 ; Don't use criteria from same accession area.
IF LRAA=$PIECE(LRX,"^",2)
QUIT
+11 SET LRFAN=$PIECE(LRZ(1),"^",2)
SET LRLAN=$PIECE(LRZ(1),"^",3)
SET LRSTAR=$PIECE(LRZ(1),"^",4)
SET LRLAST=$PIECE(LRZ(1),"^",5)
+12 IF LRSTAR
IF LRLAST
SET LRY="From Date: "_$$FMTE^XLFDT(LRSTAR,"2DZ")_" To: "_$$FMTE^XLFDT(LRLAST,"2DZ")
+13 IF '$TEST
SET LRY="For Date: "_$$FMTE^XLFDT(LRLAST,"2DZ")_" From: "_LRFAN_" To: "_LRLAN
+14 SET LRINDEX=LRINDEX+1
SET LRINDEX(LRINDEX)=LRX_"^"_LRZ
+15 SET DIR("A",LRINDEX)=$JUSTIFY(LRINDEX,4)_" "_$PIECE(LRZ(0),"^")_" "_LRY
End DoDot:2
End DoDot:1
+16 IF $DATA(DIR("A"))
Begin DoDot:1
+17 SET DIR(0)="NO^1:"_LRINDEX_":0"
+18 SET DIR("A",LRINDEX+1)=" "
+19 SET DIR("A")="Use Criteria from Accession Area"
+20 SET DIR("?",1)="Use previously selected accession area's date and number criteria."
+21 SET DIR("?")="Or press <RET> to specify different date/number criteria for "_$PIECE(LRAA(0),"^")_"."
+22 WRITE !
DO ^DIR
+23 IF '$DATA(DIRUT)
SET LRUSEAA=LRINDEX(Y)
QUIT
+24 IF $DATA(DUOUT)!$DATA(DTOUT)
SET LREND=1
End DoDot:1
+25 QUIT
