LRWRKIN1.m

LRWRKIN1 ;SLC/DCM/CJS-LRWRKINC, CONT ;2/22/87  11:39 AM [ 04/23/2003  9:02 AM ]

 ;;5.2;LR;**1004,1006,1018,1022**;September 20, 2007

 ;;5.2;LAB SERVICE;**153,201,221**;Sep 27, 1994

LST1 ;EP - 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 ;EP - 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)

 . . . .;----- BEGIN IHS MODIFICATION LR*5.2*1018

 . . . . S W=^TMP($J,LRTSTN,LRUR,LRACCN,LRAN),LRST=$P(W,U,1),HRCN=$P(W,U,2),PNM=$P(W,U,3),LRLLOC=$P(W,U,4),LRCOLL=$P(W,U,5),LRMAN=$P(W,U,6)  ;IHS/ANMC/CLS 08/18/96

 . . . .;----- END IHS MODIFICATIONS

 . . . . ;W !,$E($S(LRSORTBY=1:$P(LRTSTN,"^",2),1:LRTSTN),1,20),?23,$E(LRU,1,9),?34,LRACCN,?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

 . . . .;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 . . . .;W !,$E($S(LRSORTBY=1:$P(LRTSTN,"^",2),1:LRTSTN),1,20),?23,$E(LRU,1,9),?34,LRACCN_" "_LRAN,?47,"  ",LRCOLL,?65,$E(LRLLOC,1,15)

 . . . .;----- BEGIN IHS/OIT/MKK - MOD LR*5.2*1022

 . . . .W !,$E($S(LRSORTBY=1:$P(LRTSTN,"^",2),1:LRTSTN),1,20)

 . . . .W ?23,$E(LRU,1,9)

 . . . .W ?34,LRACCN_" "_LRAN

 . . . .W ?47,"  ",LRCOLL

 . . . .W ?67,$E(LRLLOC,1,15)     ; "Move" Location 2 to the right (from 65 to 67)

 . . . .;----- END IHS MODIFICATIONS LR*5.2*1018

 . . . .S LRCL=$S(IOM<120:5,1:82) W:IOM<120 ! I IOM<120!('LREXD) W ?LRCL,HRCN  ;IHS/ANMC/CLS 08/18/96 

 . . . .;----- END IHS MODIFICATIONS

 . . . . 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

 . . . . . ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 . . . . . ; W !,?23,$P(A,"^"),?48,$E(Y,1,16),?65,$P(A,"^",5) I IOM'<120 W ?82,HRCN  ;IHS/DIR TUC/AAB 06/23/98

 . . . . . ;----- END IHS MODIFICATIONS

 . . . . . ;----- BEGIN IHS/OIT/MKK - MOD LR*5.2*1022

 . . . . . W !,?23,$P(A,"^")

 . . . . . W ?48,$E(Y,1,16)

 . . . . . W ?67,$P(A,"^",5)      ; "Move" Location 2 to the right (from 65 to 67)

 . . . . . I IOM'<120 W ?82,HRCN  ;IHS/DIR TUC/AAB 06/23/98

 . . . . . ;----- END IHS/OIT/MKK - MOD LR*5.2*1022

 . . . . . W:IOM<120 ! S LRCL=$S(IOM<120:20,1:102) W ?LRCL,LRMAN

 . W:'LREND !,?7,"------",!,$J(J,13)

 Q

 ;

HED ; EP - 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"

 ;----- BEGIN IHS/OIT/MKK - MOD LR*5.2*1022

 W !!,"Test"

 W ?23,"Urgency"

 W ?34,"Accession"

 W ?48,"Date/time"

 W ?67,"Location"       ; "Move" Location 2 to the right (from 65 to 67)

 ;----- END IHS/OIT/MKK - MOD LR*5.2*1022

 ;

 S LRCL=$S(IOM<120:5,1:82)

 W:IOM<120 !

 ;I IOM<120!('LREXD) W ?LRCL,"SSN"

 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 I IOM<120!('LREXD) W ?LRCL,"HCRN"  ;IHS/ANMC/CLS 08/18/96

 ;----- END IHS MODIFICATIONS

 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"

 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 I LREXD,IOM'<120 W ?82,"HCRN"  ;IHS/ANMC/CLS 08/18/96

 ;----- END IHS MODIFICATIONS

 I LREXD W:IOM<120 ! S LRCL=$S(IOM<120:20,1:102) W ?LRCL,"Shipping Manifest"

 D DASH^LRX

 W !

 Q

 ;

WAIT ;EP - 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 ; EP

 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 ; EP - 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

LRWRKIN1  ;SLC/DCM/CJS-LRWRKINC, CONT ;2/22/87  11:39 AM [ 04/23/2003  9:02 AM ]

 +1       ;;5.2;LR;**1004,1006,1018,1022**;September 20, 2007

 +2       ;;5.2;LAB SERVICE;**153,201,221**;Sep 27, 1994

LST1      ;EP - 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         ;EP - 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      ;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)

 +16      ;----- BEGIN IHS MODIFICATION LR*5.2*1018

 +17      ;IHS/ANMC/CLS 08/18/96

                                           SET W=^TMP($JOB,LRTSTN,LRUR,LRACCN,LRAN)

                                           SET LRST=$PIECE(W,U,1)

                                           SET HRCN=$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)

 +18      ;----- END IHS MODIFICATIONS

 +19      ;W !,$E($S(LRSORTBY=1:$P(LRTSTN,"^",2),1:LRTSTN),1,20),?23,$E(LRU,1,9),?34,LRACCN,?47," ",LRCOLL,?65,$E(LRLLOC,1,15)

 +20      ;S LRCL=$S(IOM<120:5,1:82) W:IOM<120 ! I IOM<120!('LREXD) W ?LRCL,SSN

 +21      ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 +22      ;W !,$E($S(LRSORTBY=1:$P(LRTSTN,"^",2),1:LRTSTN),1,20),?23,$E(LRU,1,9),?34,LRACCN_" "_LRAN,?47,"  ",LRCOLL,?65,$E(LRLLOC,1,15)

 +23      ;----- BEGIN IHS/OIT/MKK - MOD LR*5.2*1022

 +24                                       WRITE !,$EXTRACT($SELECT(LRSORTBY=1:$PIECE(LRTSTN,"^",2),1:LRTSTN),1,20)

 +25                                       WRITE ?23,$EXTRACT(LRU,1,9)

 +26                                       WRITE ?34,LRACCN_" "_LRAN

 +27                                       WRITE ?47,"  ",LRCOLL

 +28      ; "Move" Location 2 to the right (from 65 to 67)

                                           WRITE ?67,$EXTRACT(LRLLOC,1,15)

 +29      ;----- END IHS MODIFICATIONS LR*5.2*1018

 +30      ;IHS/ANMC/CLS 08/18/96 

                                           SET LRCL=$SELECT(IOM<120:5,1:82)

                                           IF IOM<120

                                               WRITE !

                                           IF IOM<120!('LREXD)

                                               WRITE ?LRCL,HRCN

 +31      ;----- END IHS MODIFICATIONS

 +32                                       SET LRCL=$SELECT(IOM<120:20,LREXD:82,1:97)

                                           WRITE ?LRCL,$EXTRACT(PNM,1,19)

 +33                                       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))

 +34                                       IF LREXD

                                               Begin DoDot:5

 +35                                               NEW A

 +36                                               SET A=$GET(^TMP($JOB,LRTSTN,LRUR,LRACCN,LRAN,.3))

 +37                                               SET Y=$PIECE(A,"^",2)

                                                   IF Y

                                                       SET C=$PIECE(^DD(68.02,16.1,0),"^",2)

                                                       DO Y^DIQ

 +38      ;W !,?23,$P(A,"^"),?48,$E(Y,1,16),?65,$P(A,"^",5) I IOM'<120 W ?82,SSN

 +39      ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 +40      ; W !,?23,$P(A,"^"),?48,$E(Y,1,16),?65,$P(A,"^",5) I IOM'<120 W ?82,HRCN  ;IHS/DIR TUC/AAB 06/23/98

 +41      ;----- END IHS MODIFICATIONS

 +42      ;----- BEGIN IHS/OIT/MKK - MOD LR*5.2*1022

 +43                                               WRITE !,?23,$PIECE(A,"^")

 +44                                               WRITE ?48,$EXTRACT(Y,1,16)

 +45      ; "Move" Location 2 to the right (from 65 to 67)

                                                   WRITE ?67,$PIECE(A,"^",5)

 +46      ;IHS/DIR TUC/AAB 06/23/98

                                                   IF IOM'<120

                                                       WRITE ?82,HRCN

 +47      ;----- END IHS/OIT/MKK - MOD LR*5.2*1022

 +48                                               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 

 +49               IF 'LREND

                       WRITE !,?7,"------",!,$JUSTIFY(J,13)

               End DoDot:1

               IF LREND

                   QUIT 

 +50       QUIT 

 +51      ;

HED       ; EP - 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       ; W !!,"Test",?23,"Urgency",?34,"Accession",?48,"Date/time",?65,"Location"

 +8       ;----- BEGIN IHS/OIT/MKK - MOD LR*5.2*1022

 +9        WRITE !!,"Test"

 +10       WRITE ?23,"Urgency"

 +11       WRITE ?34,"Accession"

 +12       WRITE ?48,"Date/time"

 +13      ; "Move" Location 2 to the right (from 65 to 67)

           WRITE ?67,"Location"

 +14      ;----- END IHS/OIT/MKK - MOD LR*5.2*1022

 +15      ;

 +16       SET LRCL=$SELECT(IOM<120:5,1:82)

 +17       IF IOM<120

               WRITE !

 +18      ;I IOM<120!('LREXD) W ?LRCL,"SSN"

 +19      ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 +20      ;IHS/ANMC/CLS 08/18/96

           IF IOM<120!('LREXD)

               WRITE ?LRCL,"HCRN"

 +21      ;----- END IHS MODIFICATIONS

 +22       SET LRCL=$SELECT(IOM<120:20,LREXD:82,1:97)

           WRITE ?LRCL,"Patient"

 +23       SET LRCL=$SELECT(IOM<120:40,LREXD:102,1:117)

           WRITE ?LRCL,"Status"

 +24       IF $GET(LREXD)

               WRITE !,?23,"UID",?48,"Sending Site",?65,"Sender's UID"

 +25      ;I LREXD,IOM'<120 W ?82,"SSN"

 +26      ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 +27      ;IHS/ANMC/CLS 08/18/96

           IF LREXD

               IF IOM'<120

                   WRITE ?82,"HCRN"

 +28      ;----- END IHS MODIFICATIONS

 +29       IF LREXD

               IF IOM<120

                   WRITE !

               SET LRCL=$SELECT(IOM<120:20,1:102)

               WRITE ?LRCL,"Shipping Manifest"

 +30       DO DASH^LRX

 +31       WRITE !

 +32       QUIT 

 +33      ;

WAIT      ;EP - 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     ; EP

 +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     ; EP - 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