LRWRKLST ;DALOI/CJS/DRH-LONG ACCESSION LIST ; 13-Oct-2017 14:04 ; MKK
;;5.2;LAB SERVICE;**1,17,38,1004,1013,153,185,221,268,1018,362,1031,1037,1041**;NOV 1, 1997;Build 23
;
; NOTE: LR*5.2*1031 restores LR*5.2*1018 modifications
;
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 acccession number
I '$D(LRSTAR) D PHD
I LREND D LREND Q
;
W ;from LRVER, LRVR
;
N DIR,DTOUT,DIRUT,DIROUT
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
;
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
;
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
. 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
;
;
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=1+$G(LN)
;
S LRLO69=$G(^LRO(69,LRDAT,1,LRSN,0))
I $L(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=3+$G(LN)
Q
;
;
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:"")
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
W ?40," ",$S($D(LRURG(LRURG)):LRURG(LRURG),1:"")
I $L($P(LRXXX,U,4)) D
. NEW TECH,TECHLEN,TAB
. S TECH=$$GET1^DIQ(200,$P(LRXXX,U,4),.01)
. S TECHLEN=$L(TECH)
. S TAB=(IOM-TECHLEN)-8
. I TAB>$X W ?TAB,"TECH: ",TECH
. E W !,?8,"TECH: ",TECH S LN=LN+1
. S LN=LN+1
; ----- END IHS/MSC/MKK - LR*5.2*1041
;
W:$L($P(LRXXX,U,3)) ?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
;
I $P(LRXXX,U,5) W !," COMPLETED: ",$$FMTE^XLFDT($P(LRXXX,U,5),"5MZ") S LN=LN+1
E S LRNAC=""
Q
;
;
REF ; if referred test, display status and manifest
;
N LREVNT,LRUID,LRMAN
;
S LRUID=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^") Q:LRUID=""
S LRMAN=$P(LRXXX,"^",10)
I LRMAN S LRMAN=$P($G(^LAHM(62.8,LRMAN,0)),"^")
S LREVNT=$$STATUS^LREVENT(LRUID,+LRXXX,LRMAN)
I LREVNT'="" D
. W !,?5,"REFERRAL STATUS: "_$P(LREVNT,"^")_" ("_$P(LREVNT,"^",2)_")"
. W !,?8,"SHIPPING MANIFEST: "_$P(LREVNT,"^",3)
. S LN=LN+2
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
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
;D KVAR^BLRDPT ;IHS/DIR TUC/AAB 06/23/98
D @$S($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")
;----- END IHS MODIFICATIONS
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
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
K HRCN
;----- END IHS MODIFICATIONS
Q
;
EN ;
SINGLE ;
;
N LRACC,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
. D TD,LST1^LRWRKLS1,TESTS
. W !
;
D LREND
Q
LRWRKLST ;DALOI/CJS/DRH-LONG ACCESSION LIST ; 13-Oct-2017 14:04 ; MKK
+1 ;;5.2;LAB SERVICE;**1,17,38,1004,1013,153,185,221,268,1018,362,1031,1037,1041**;NOV 1, 1997;Build 23
+2 ;
+3 ; NOTE: LR*5.2*1031 restores LR*5.2*1018 modifications
+4 ;
+5 NEW LRDICS
+6 ;
+7 ; Save and restore DIC("S") if micro long form accession option (LRMIACC1).
+8 IF $DATA(DIC("S"))
SET LRDICS=DIC("S")
+9 DO LREND
+10 IF $DATA(LRDICS)
SET DIC("S")=LRDICS
+11 ;
+12 SET LRDT=$$FMTE^XLFDT($$NOW^XLFDT,"5MZ")
+13 ;
+14 SET LREND=0
+15 SET DIC="^LRO(68,"
SET DIC(0)="AEMOQ"
+16 DO ^DIC
SET LRAA=+Y
SET LRNAME=$PIECE(Y,U,2)
+17 IF LRAA<1
DO LREND
QUIT
+18 ;
+19 ; Ask if list by date rather than accession number
+20 IF $PIECE(^LRO(68,LRAA,0),U,3)="Y"
DO STAR^LRWU3
SET LRLAST=$GET(LAST)
+21 IF LREND
DO LREND
QUIT
+22 ; List by acccession number
+23 IF '$DATA(LRSTAR)
DO PHD
+24 IF LREND
DO LREND
QUIT
+25 ;
W ;from LRVER, LRVR
+1 ;
+2 NEW DIR,DTOUT,DIRUT,DIROUT
+3 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,0))
IF '$DATA(LRSTAR)
DO LREND
QUIT
+4 ;
+5 SET (LRUNC,LRTSE)=0
+6 IF '$DATA(LRNAME)
SET LRNAME=$PIECE(^LRO(68,LRAA,0),U,1)
+7 ;
+8 SET DIR(0)="YO"
SET DIR("A")="Do you want a specific test"
SET DIR("B")="NO"
+9 DO ^DIR
+10 IF $DATA(DIRUT)
DO LREND
QUIT
+11 IF Y=1
Begin DoDot:1
+12 NEW DIC,X,Y
+13 SET DIC="^LAB(60,"
SET DIC(0)="AEZOQ"
+14 DO ^DIC
+15 IF Y>0
SET LRTSE=+Y
End DoDot:1
+16 ;
+17 KILL DIR
+18 SET DIR(0)="YO"
SET DIR("A")="Do you want only incomplete entries"
SET DIR("B")="YES"
+19 DO ^DIR
+20 IF $DATA(DIRUT)
DO LREND
QUIT
+21 SET LRUNC=Y
+22 ;
+23 SET %ZIS="Q"
DO ^%ZIS
+24 IF POP
DO ^%ZISC
DO LREND
QUIT
+25 ;
+26 ; Queue report via Taskman
+27 IF $DATA(IO("Q"))
Begin DoDot:1
+28 NEW ZTDESC,ZTSK,ZTRTN,ZTIO,ZTSAVE,%T
+29 SET ZTRTN="ENT^LRWRKLST"
SET ZTDESC="Long form accession list"
SET ZTSAVE("LR*")=""
+30 DO ^%ZTLOAD
DO ^%ZISC
+31 WRITE !,"Task ",$SELECT($GET(ZTSK):ZTSK,1:"NOT")," Queued"
+32 DO LREND
KILL IO("Q")
End DoDot:1
QUIT
+33 ;
ENT ;
+1 ;
+2 NEW LRTST
+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
+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 IF LRUNC
IF $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0),"^",5)
QUIT
+13 SET LRTST(LRI)=""
End DoDot:1
+14 ;
+15 IF '$DATA(LRTST)
SET LREND=1
+16 QUIT
+17 ;
+18 ;
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=1+$GET(LN)
+14 ;
+15 SET LRLO69=$GET(^LRO(69,LRDAT,1,LRSN,0))
+16 IF $LENGTH(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=3+$GET(LN)
End DoDot:1
+25 QUIT
+26 ;
+27 ;
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 ; W ?40,$S($D(LRURG(LRURG)):LRURG(LRURG),1:"")
+10 ;
+11 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
+12 WRITE ?40," ",$SELECT($DATA(LRURG(LRURG)):LRURG(LRURG),1:"")
+13 IF $LENGTH($PIECE(LRXXX,U,4))
Begin DoDot:1
+14 NEW TECH,TECHLEN,TAB
+15 SET TECH=$$GET1^DIQ(200,$PIECE(LRXXX,U,4),.01)
+16 SET TECHLEN=$LENGTH(TECH)
+17 SET TAB=(IOM-TECHLEN)-8
+18 IF TAB>$X
WRITE ?TAB,"TECH: ",TECH
+19 IF '$TEST
WRITE !,?8,"TECH: ",TECH
SET LN=LN+1
+20 SET LN=LN+1
End DoDot:1
+21 ; ----- END IHS/MSC/MKK - LR*5.2*1041
+22 ;
+23 IF $LENGTH($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)
+24 ;
+25 IF $DATA(^LRO(69,LRDAT,1,LRSN,2,"B",LRI))
Begin DoDot:1
+26 NEW I,X
+27 SET X=$ORDER(^LRO(69,LRDAT,1,LRSN,2,"B",LRI,0))
+28 IF X
IF $ORDER(^LRO(69,LRDAT,1,LRSN,2,X,1,0))
Begin DoDot:2
+29 SET I=0
+30 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
+31 ;
+32 DO REF
+33 ;
+34 IF $PIECE(LRXXX,U,5)
WRITE !," COMPLETED: ",$$FMTE^XLFDT($PIECE(LRXXX,U,5),"5MZ")
SET LN=LN+1
+35 IF '$TEST
SET LRNAC=""
+36 QUIT
+37 ;
+38 ;
REF ; if referred test, display status and manifest
+1 ;
+2 NEW LREVNT,LRUID,LRMAN
+3 ;
+4 SET LRUID=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
IF LRUID=""
QUIT
+5 SET LRMAN=$PIECE(LRXXX,"^",10)
+6 IF LRMAN
SET LRMAN=$PIECE($GET(^LAHM(62.8,LRMAN,0)),"^")
+7 SET LREVNT=$$STATUS^LREVENT(LRUID,+LRXXX,LRMAN)
+8 IF LREVNT'=""
Begin DoDot:1
+9 WRITE !,?5,"REFERRAL STATUS: "_$PIECE(LREVNT,"^")_" ("_$PIECE(LREVNT,"^",2)_")"
+10 WRITE !,?8,"SHIPPING MANIFEST: "_$PIECE(LREVNT,"^",3)
+11 SET LN=LN+2
End DoDot:1
+12 QUIT
+13 ;
+14 ;
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 ; D KVAR^VADPT
+2 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+3 ;D KVAR^BLRDPT ;IHS/DIR TUC/AAB 06/23/98
+4 DO @$SELECT($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")
+5 ;----- END IHS MODIFICATIONS
+6 KILL %,%DT,%ZIS
+7 KILL LN,LRA,AGE,DFN,DIC,DIR,DIRUT,DOB,DTOUT,DUOUT,K,LAST
+8 KILL LRACC,LRDLA,LRDLC,LRDX,LRI,LRLO69,LRSAMP,LRSPEC
+9 KILL LRURG,LRWRD,LRACO,DIC,LRUNC,LRDAT,LRAA,LRAD
+10 KILL LRNAC,LRAN,LRCE,LRDPF,LRSN,LRDTO,LRLAST,LRPRAC,LRSTAR,LRXXX
+11 KILL LRB,LRLAN,LRDT,LREND,LRFAN,LRIX,LRNAME,LRTSE,LRTST
+12 KILL LRDFN,LREDT,LRLLOC,LRSDT,LRTK,LRWDTL,POP,LRSTOP
+13 KILL PNM,SEX,SSN,X,X1,X2,Y,Z,ZTSK
+14 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+15 KILL HRCN
+16 ;----- END IHS MODIFICATIONS
+17 QUIT
+18 ;
EN ;
SINGLE ;
+1 ;
+2 NEW LRACC,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 DO TD
DO LST1^LRWRKLS1
DO TESTS
+12 WRITE !
End DoDot:1
IF LREND!LRSTOP
QUIT
+13 ;
+14 DO LREND
+15 QUIT
