BLRMANPU ; IHS/MSC/MKK - Multiple Accession Not Performed Utility ;10-Jan-2017 09:29;MKK
;;5.2;IHS LABORATORY;**1039**;NOV 01, 1997;Build 38
;
EEP ; Ersatz EP
D EEP^BLRGMENU
Q
;
EP ; EP
PEP ; EP
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
D SETBLRVS
;
S HEADER(1)="Multiple Accessions"
S HEADER(2)="Not Performed Utility"
;
S ONGO="YES"
F Q:ONGO="NO" D
. D HEADERDT^BLRGMENU
. I $D(REMOVEA) D
.. W "The following Accessions have been selected:",!,?4
.. S LRAS=""
.. F S LRAS=$O(REMOVEA(LRAS)) Q:LRAS="" D
... W $$LJ^XLFSTR(LRAS,22)
... I $X>69 W !,?4
. W !!
. D LRWU4
. I LRAA<1!(LRAD<1)!(LRAN<1) S ONGO="NO" Q
. ;
. I $D(^LRO(68,LRAA,1,LRAD,1,LRAN))<1 D Q
.. D PROMPTO^BLRUTIL7("Accession "_BLRLRAS_" does not exist.")
. ;
. S (COMPLTED,LRAT)=0
. F S LRAT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRAT)) Q:LRAT<1!(COMPLTED) D
.. I $$GET1^DIQ(68.04,LRAT_","_LRAN_","_LRAD_","_LRAA,4,"I") S COMPLTED=COMPLTED+1
. ;
. I COMPLTED D Q
.. D PROMPTO^BLRUTIL7("Accession "_BLRLRAS_" has completed data. Cannot be selected.")
. ;
. S REMOVEA(BLRLRAS)=LRAA_U_LRAD_U_LRAN
;
I $D(REMOVEA)<1 D BADSTUFF^BLRUTIL7("No Accessions selected.") Q
;
D HEADERDT^BLRGMENU
W "The following Accessions have been selected to be marked as NOT PERFORMED:",!,?4
S LRAS=""
F S LRAS=$O(REMOVEA(LRAS)) Q:LRAS="" D
. W $$LJ^XLFSTR(LRAS,22)
. I $X>69 W !,?4
W !!
;
D ^XBFMK
S DIR(0)="YO"
S DIR("A")="Do you want to continue"
S DIR("B")="NO"
D ^DIR
I +$G(DIRUT)!(+Y<1) D PROMPTO^BLRUTIL7("Per response, routine ends.") Q
;
S CANCLRSN=""
F Q:$L(CANCLRSN) D
. D HEADERDT^BLRGMENU
. D ^XBFMK
. S DIR(0)="FO"
. S DIR("A")="Not Performed Reason"
. D ^DIR
. I +$G(DIRUT) D Q
.. D BADSTUFF^BLRUTIL7("No/Quit/Invalid Input.")
.. S CANCLRSN="BLRMANPU NO GOOD"
. ;
. S CANCLRSN="Cancel Reason:*"_$G(X)
;
Q:CANCLRSN="BLRMANPU NO GOOD"
;
S LRAS=""
F S LRAS=$O(REMOVEA(LRAS)) Q:LRAS="" D
. S STR=$G(REMOVEA(LRAS))
. S LRAA=$P(STR,U),LRAD=$P(STR,U,2),LRAN=$P(STR,U,3)
. S UID=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA,16,"I")
. S OKAY=$$NOTPERF(LRAA,LRAD,LRAN,UID,CANCLRSN)
. S:OKAY<1 NOTOKAY(LRAS)=""
. S:OKAY NPOKAY(LRAS)=""
;
D HEADERDT^BLRGMENU
I $D(NPOKAY) D
. S LRAS=""
. F S LRAS=$O(NPOKAY(LRAS)) Q:LRAS="" W ?4,LRAS,?29,"*NP Marked",!
;
; Now, mark them discontinued in the Order (#100) file
S DISCPTR=$$FIND1^DIC(100.01,,,"DISCONTINUED")
K WHOCANCL
S LRAS=""
F S LRAS=$O(NPOKAY(LRAS)) Q:LRAS="" D
. S STR=$G(REMOVEA(LRAS))
. S LRAA=$P(STR,U),LRAD=$P(STR,U,2),LRAN=$P(STR,U,3)
. S LRODNUM=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA,14,"I")
. S LRODT=0
. F S LRODT=$O(^LRO(69,"C",LRODNUM,LRODT)) Q:LRODT<1 D
.. S LRSP=0
.. F S LRSP=$O(^LRO(69,"C",LRODNUM,LRODT,LRSP)) Q:LRSP<1 D
... K TESTS,NAT
... S LROT=0
... F S LROT=$O(^LRO(69,LRODT,1,LRSP,2,LROT)) Q:LROT<1 D
.... S LROTIEN=LROT_","_LRSP_","_LRODT
.... S LROLRAD=$$GET1^DIQ(69.03,LROTIEN,2,"I")
.... Q:LROLRAD'=LRAD
.... S LROLRAA=$$GET1^DIQ(69.03,LROTIEN,3,"I")
.... Q:LROLRAA'=LRAA
.... S LROLRAN=$$GET1^DIQ(69.03,LROTIEN,4,"I")
.... Q:LROLRAN'=LRAN
.... ;
.... S F60PTR=$$GET1^DIQ(69.03,LROTIEN,.01,"I")
.... S TESTS(F60PTR)=""
.... S WHOCANCL(LRODT,LRSP,LROT)=$$GET1^DIQ(69.03,LROTIEN,10,"I")
.... S $P(^LRO(69,LRODT,1,LRSP,2,LROT,0),U,11)="" ; Have to make null for NEW^LR7OB1 to work
... Q:$D(TESTS)<1
... ;
... S NAT="^^^5^OTHER CANCEL REASON^99ORR"
... D NEW^LR7OB1(LRODT,LRSP,"OC",NAT,.TESTS)
;
; Now, set or restore the WHO CANCELLED field
S LRODT=0
F S LRODT=$O(WHOCANCL(LRODT)) Q:LRODT<1 D
. S LRSP=0
. F S LRSP=$O(WHOCANCL(LRODT,LRSP)) Q:LRSP<1 D
.. S LROT=0
.. F S LROT=$O(WHOCANCL(LRODT,LRSP,LROT)) Q:LROT<1 D
... S WHOCANCL=$G(WHOCANCL(LRODT,LRSP,LROT))
... S WHOCANCL=$S(WHOCANCL:WHOCANCL,1:DUZ)
... S $P(^LRO(69,LRODT,1,LRSP,2,LROT,0),U,11)=WHOCANCL
;
I $D(NOTOKAY) D
. W !!,"The following accessions were NOT marked as *NP Complete:",!,?4
. S LRAS=""
. F S LRAS=$O(NOTOKAY(LRAS)) Q:LRAS="" D
.. W $$LJ^XLFSTR(LRAS,22)
.. I $X>69 W !,?4
;
D PRESSKEY^BLRGMENU(9)
Q
;
NOTPERF(LRAA,LRAD,LRAN,UID,CANCLRSN) ; EP - Not Performed
NEW (CANCLRSN,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRAA,LRAD,LRAN,U,UID,XPARSYS,XQXFLG)
;
D ^LRPARAM
S BLRLOG=1
;
S SAVLRAA=LRAA,SAVLRAD=LRAD,SAVLRAN=LRAN
;
S LRSS=$$GET1^DIQ(68,LRAA,"LR SUBSCRIPT","I")
S IEN=LRAN_","_LRAD_","_LRAA_","
S LRDFN=$$GET1^DIQ(68.02,IEN,"LRDFN","I")
S LRIDT=$$GET1^DIQ(68.02,IEN,"INVERSE DATE","I")
;
S BLROPT="DELACC"
;
K LRXX,LRSCNXB
S (LREND,LRNOP)=0
D FIX^BLRMANP2
I $G(LREND) S LREND=1 Q 0
;
Q 1
;
GETRID(LRAA,LRAD,LRAN,LRAS,LRNOP) ; EP - Mark Accession as NOT Performed.
; Following code cloned from LRTSTJAN & LRTSTOUT
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRAA,LRAD,LRAN,LRAS,LRNOP,U,XPARSYS,XQXFLG)
;
S UID=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA,16,"I")
D NOTPERF^BLRRLTDR(UID)
;
I '$P($G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),0)),U,2) W !?5,"Accession has no Test ",! S LRNOP=1 Q
L +^LRO(68,LRAA,1,LRAD,1,LRAN):1 I '$T W !,"Someone else is working on this accession",! S LRNOP=1 Q
S LRX=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRACN=$P(^(.2),U),LRUID=$P(^(.3),U)
S LRDFN=+LRX,LRSN=+$P(LRX,U,5),LRODT=+$P(LRX,U,4)
S LRSS=$$GET1^DIQ(68,LRAA,.02,"I")
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
D PT^LRX
;
S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5) L +^LR(LRDFN,LRSS,LRIDT):1 I '$T W !,"Someone else is working on this data." L -^LRO(68,LRAA,1,LRAD,1,LRAN) S LRNOP=1 Q
I '$G(^LR(LRDFN,LRSS,LRIDT,0)) W !?5," Can't find Lab Data for this accession",! D UNLOCK S LRNOP=1 Q
;
S LRTOTL=1,LRIFN=0
I LRTOTL>0 D
.F S LRIFN=$O(^LR(LRDFN,LRSS,LRIDT,LRIFN)) Q:LRIFN="" S:$P($G(^LR(LRDFN,LRSS,LRIDT,LRIFN)),U)="pending" $P(^LR(LRDFN,LRSS,LRIDT,LRIFN),U)=""
I LRTOTL=0 D CHG^LRTSTOUT Q
D FX2^LRTSTOUT I $G(LREND) Q
D
. N LRTSTS
. S LRTSTS=0,LRNOW=$$NOW^XLFDT F S LRTSTS=+$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS)) Q:LRTSTS<1 I $D(^(LRTSTS,0))#2,'$P(^(0),U,5) D
. . I $D(^LAB(60,LRTSTS,0)) S LRTNM=$P(^(0),U) D SET^LRTSTOUT
L -^LRO(68,LRAA,1,LRAD,1,LRAN)
I $L($G(LRSS)) L -^LR(+$G(LRDFN),LRSS,+$G(LRIDT))
D:BLRLOG ^BLREVTQ("M","D",$G(BLROPT),,LRACN)
Q
;
;
UNLOCK ; EP
L -(^LR($G(LRDFN),$G(LRSS),$G(LRIDT)),^LRO(68,$G(LRAA),1,$G(LRAD),1,$G(LRAN)))
Q
;
;
SETBLRVS(TWO) ; EP - Set the BLRVERN variable(s)
K BLRVERN,BLRVERN2
;
S BLRVERN=$P($P($T(+1),";")," ")
S:$L($G(TWO)) BLRVERN2=$G(TWO)
Q
;
SLABDATA ; EP - Setup the Lab Data file variables
D ^LRWU4
;
S LRAIEN=LRAN_","_LRAD_","_LRAA
S LRDFN=$$GET1^DIQ(68.02,LRAIEN,"LRDFN","I")
S LRIDT=$$GET1^DIQ(68.02,LRAIEN,"INVERSE DATE","I")
;
W !!,"LRDFN:",LRDFN,"; LRIDT:",LRIDT,!!
Q
;
LRWU4 ; EP - Code cloned from LRWU4 routine
N %,DIC,DIR,DIRUT,DUOUT,DTOUT,LRQUIT,LRX
;
K LRNATURE
S U="^",DT=$$DT^XLFDT,LRQUIT=0
F D LRWU4AA Q:LRQUIT
Q
;
LRWU4AA ;
S DIR(0)="FO^1:30",DIR("A")="Select Accession"_$S($G(LRVBY)=1:"",1:" or UID")
S DIR("?")="^D QUES^LRWU4"
D ^DIR
I Y=""!$D(DIRUT) D QUIT^LRWU4 Q
S LRX=Y
S BLRLRAS=$G(X)
;
S:$L(LRX)>2 ^DISV(DUZ,"LRACC")=LRX
S:LRX=" " LRX=$S($D(^DISV(DUZ,"LRACC")):^("LRACC"),1:"?")
S (LRAA,LRAD,LRAN)=0
;
; see if entry is UID
I $G(LRVBY)<1,$D(^LRO(68,"C",LRX)) D UNIV^LRWU4 Q
;
; Parse and process user input.
S (X1,X2,X3)="",X1=$P(LRX," ",1),X2=$P(LRX," ",2),X3=$P(LRX," ",3)
S:X3=""&(+X2=X2) X3=X2,X2=""
I X1'?1A.AN D QUES^LRWU4 Q
S LRAA=$O(^LRO(68,"B",X1,0))
I LRAA<1 D WLQUES^LRWU4 Q:LRAA<1
S %=$P(^LRO(68,LRAA,0),U,14)
S %=$$LKUP^XPDKEY(%)
I $L(%),'$D(^XUSEC(%,DUZ)) D WLQUES^LRWU4 Q:LRAA<1
;
S LRX=$G(^LRO(68,LRAA,0)),LRIDIV=$S($L($P(LRX,U,19)):$P(LRX,U,19),1:"CP")
; W !,$P(LRX,U)
;
; User entered only accession area identifier, no date or number. Not allowed.
I X2="",X3="" D QUIT^LRWU4 Q
;
; Convert middle value to FileMan date
; Adjust for monthly and quarterly formats (MM00) if user enters 4 digit
; number as middle part of accession then convert to appropriate date.
I LRAD<1 D
. N %DT
. I X2="" S X2=DT
. I X2?4N D
. . S X2=$E(DT,1,3)_X2
. . I X2>DT S X2=X2-10000
. S %DT="EP",X=X2
. D ^%DT
. I Y>0 S LRAD=Y Q
. D QUES^LRWU4
I LRAD<1 Q
;
; Convert date entered to apropriate date for accession area transform
S X=$P(^LRO(68,LRAA,0),U,3)
S LRAD=$S("D"[X:LRAD,X="Y":$E(LRAD,1,3)_"0000","M"[X:$E(LRAD,1,5)_"00","Q"[X:$E(LRAD,1,3)_"0000"+(($E(LRAD,4,5)-1)\3*300+100),1:LRAD)
W:X3>0 " ",+X3
;
I X3="",$D(LRACC) D
. N DIR,DIRUT,DUOUT,DTOUT,X,Y
. S DIR(0)="NO^1:999999",DIR("A")=" Number part of Accession"
. D ^DIR
. I Y=""!$D(DIRUT) Q
. S X3=Y
;
I X3="",$D(LRACC) D QUIT^LRWU4 Q
S LRAN=+X3
I LRAN<1,$D(LRACC) D QUES^LRWU4 Q
I $D(LRACC),'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q
. W !,"ACCESSION: ",$P(^LRO(68,LRAA,0),U,11)," ",$$FMTE^XLFDT(LRAD,"5D")," ",LRAN," DOES NOT EXIST!"
;
S LRQUIT=1
Q
;
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
D SETBLRVS
;
D ADDTMENU^BLRGMENU("PEP^BLRMANPU","Mark Multiple Accessions NP")
D ADDTMENU^BLRGMENU("XTMPRPT^BLRMANP3","Report on Errors For Mult Accs NP")
D ADDTMENU^BLRGMENU("XTMPKILL^BLRMANP3","Purge Error Report Global")
D ADDTMENU^BLRGMENU("DETAIL68^BLRMANP3","Accession Detail")
D ADDTMENU^BLRGMENU("F6869100^BLRMANPU","Report on Files 68, 69, & 100")
;
D MENUDRVR^BLRGMENU("RPMS Lab","Mark Multiple Accessions NP Utilities")
Q
;
; The following cloned from BLRRLTDU
XTMPISET(MSG,RTN) ; EP - Set data in ^XTMP when there are issues
NEW UID,STR
;
S STR=$G(^XTMP("BLRMANPU",0))
I $L(STR)<1 D ; Set ^XTMP Node Zero
. S STR=$$HTFM^XLFDT(+$H)_"^^Multiple Accessions as Not Performed Errors"
S $P(STR,"^",2)=$$HTFM^XLFDT(+$H+30)
S ^XTMP("BLRMANPU",0)=STR
;
S UID=$G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),.3),"<UNKNOWN>")
S ^XTMP("BLRMANPU","UID",UID,"DUZ",DUZ,$H)=RTN_"^"_MSG
S ^XTMP("BLRMANPU","UID")=1+$G(^XTMP("BLRMANPU","UID"))
S LREND=1
;
Q
;
;
F6869100 ; EP - Given an Accession, display data from 68, 69 & 100
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
D SETBLRVS
;
S HEADER(1)="Accession Data"
S HEADER(2)="File 68, 69 & 100 Status"
D HEADERDT^BLRGMENU
;
D ^LRWU4
;
I LRAA<1!(LRAD<1)!(LRAN<1) S ONGO="NO" Q
;
I $D(^LRO(68,LRAA,1,LRAD,1,LRAN))<1 D Q
. D PROMPTO^BLRUTIL7("Accession "_BLRLRAS_" does not exist.")
;
D HEADERDT^BLRGMENU
D HEADONE^BLRGMENU(.HDRONE)
D HEADERDT^BLRGMENU
;
S LRAAIEN=LRAN_","_LRAD_","_LRAA
S ORDNUM=$$GET1^DIQ(68.02,LRAAIEN,14)
S LRAS=$$GET1^DIQ(68.02,LRAAIEN,15)
S LRAUID=$$GET1^DIQ(68.02,LRAAIEN,16)
;
K HEADER(1)
S HEADER(1)="Accession "_LRAS_" ["_LRAUID_"] Data"
;
S HEADER(3)=" "
S HEADER(4)="File 60"
S $E(HEADER(4),10)=$$COLHEAD^BLRGMENU("File 68",31)
S $E(HEADER(4),43)=$$COLHEAD^BLRGMENU("File 69",18)
S $E(HEADER(4),63)=$$COLHEAD^BLRGMENU("File 100",18)
S HEADER(5)="IEN"
S $E(HEADER(5),10)="LRAS"
S $E(HEADER(5),28)="Disposition"
S $E(HEADER(5),43)="Order #"
S $E(HEADER(5),53)="CancelBy"
S $E(HEADER(5),63)="OERR #"
S $E(HEADER(5),75)="Status"
;
S MAXLINES=IOSL-4,LINES=MAXLINES+10
S (CNT,PG)=0
S QFLG="NO"
;
; Create File 69 Array by File 60 IEN
S LRODT=0
F S LRODT=$O(^LRO(69,"C",ORDNUM,LRODT)) Q:LRODT<1 D
. S LRSP=0
. F S LRSP=$O(^LRO(69,"C",ORDNUM,LRODT,LRSP)) Q:LRSP<1 D
.. S LROT=0
.. F S LROT=$O(^LRO(69,LRODT,1,LRSP,2,LROT)) Q:LROT<1 D
... S LROTIEN=LROT_","_LRSP_","_LRODT
... S LROF60=$$GET1^DIQ(69.03,LROTIEN,.01,"I")
... S OERRIEN=$$GET1^DIQ(69.03,LROTIEN,6,"I")
... S LROSTS=$$GET1^DIQ(69.03,LROTIEN,9)
... S LROCANBY=$$GET1^DIQ(69.03,LROTIEN,10,"I")
... S LROTARRY(LROF60)=LRODT_U_LRSP_U_OERRIEN_U_LROCANBY_U_LROSTS
;
; Go through File 68's File 60 IENs
S LRAT=0
F S LRAT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRAT)) Q:LRAT<1!(QFLG="Q") D
. S DISPTION=$$GET1^DIQ(68.04,LRAT_","_LRAAIEN,5)
. S STR=$G(LROTARRY(LRAT))
. S OERRIEN=$P(STR,U,3)
. S OERRSTS=$$GET1^DIQ(100,OERRIEN,"STATUS")
. S CANCBY=$P(STR,U,4)
. I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE) Q:QFLG="Q"
. ;
. W LRAT
. W ?9,LRAS
. W ?27,$E(DISPTION,1,13)
. W ?42,ORDNUM
. W ?52,CANCBY
. W ?62,OERRIEN
. W ?74,$E(OERRSTS,1,6)
. W !
. S LINES=LINES+1
;
D PRESSKEY^BLRGMENU(9)
Q
BLRMANPU ; IHS/MSC/MKK - Multiple Accession Not Performed Utility ;10-Jan-2017 09:29;MKK
+1 ;;5.2;IHS LABORATORY;**1039**;NOV 01, 1997;Build 38
+2 ;
EEP ; Ersatz EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
EP ; EP
PEP ; EP
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 DO SETBLRVS
+4 ;
+5 SET HEADER(1)="Multiple Accessions"
+6 SET HEADER(2)="Not Performed Utility"
+7 ;
+8 SET ONGO="YES"
+9 FOR
IF ONGO="NO"
QUIT
Begin DoDot:1
+10 DO HEADERDT^BLRGMENU
+11 IF $DATA(REMOVEA)
Begin DoDot:2
+12 WRITE "The following Accessions have been selected:",!,?4
+13 SET LRAS=""
+14 FOR
SET LRAS=$ORDER(REMOVEA(LRAS))
IF LRAS=""
QUIT
Begin DoDot:3
+15 WRITE $$LJ^XLFSTR(LRAS,22)
+16 IF $X>69
WRITE !,?4
End DoDot:3
End DoDot:2
+17 WRITE !!
+18 DO LRWU4
+19 IF LRAA<1!(LRAD<1)!(LRAN<1)
SET ONGO="NO"
QUIT
+20 ;
+21 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN))<1
Begin DoDot:2
+22 DO PROMPTO^BLRUTIL7("Accession "_BLRLRAS_" does not exist.")
End DoDot:2
QUIT
+23 ;
+24 SET (COMPLTED,LRAT)=0
+25 FOR
SET LRAT=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRAT))
IF LRAT<1!(COMPLTED)
QUIT
Begin DoDot:2
+26 IF $$GET1^DIQ(68.04,LRAT_","_LRAN_","_LRAD_","_LRAA,4,"I")
SET COMPLTED=COMPLTED+1
End DoDot:2
+27 ;
+28 IF COMPLTED
Begin DoDot:2
+29 DO PROMPTO^BLRUTIL7("Accession "_BLRLRAS_" has completed data. Cannot be selected.")
End DoDot:2
QUIT
+30 ;
+31 SET REMOVEA(BLRLRAS)=LRAA_U_LRAD_U_LRAN
End DoDot:1
+32 ;
+33 IF $DATA(REMOVEA)<1
DO BADSTUFF^BLRUTIL7("No Accessions selected.")
QUIT
+34 ;
+35 DO HEADERDT^BLRGMENU
+36 WRITE "The following Accessions have been selected to be marked as NOT PERFORMED:",!,?4
+37 SET LRAS=""
+38 FOR
SET LRAS=$ORDER(REMOVEA(LRAS))
IF LRAS=""
QUIT
Begin DoDot:1
+39 WRITE $$LJ^XLFSTR(LRAS,22)
+40 IF $X>69
WRITE !,?4
End DoDot:1
+41 WRITE !!
+42 ;
+43 DO ^XBFMK
+44 SET DIR(0)="YO"
+45 SET DIR("A")="Do you want to continue"
+46 SET DIR("B")="NO"
+47 DO ^DIR
+48 IF +$GET(DIRUT)!(+Y<1)
DO PROMPTO^BLRUTIL7("Per response, routine ends.")
QUIT
+49 ;
+50 SET CANCLRSN=""
+51 FOR
IF $LENGTH(CANCLRSN)
QUIT
Begin DoDot:1
+52 DO HEADERDT^BLRGMENU
+53 DO ^XBFMK
+54 SET DIR(0)="FO"
+55 SET DIR("A")="Not Performed Reason"
+56 DO ^DIR
+57 IF +$GET(DIRUT)
Begin DoDot:2
+58 DO BADSTUFF^BLRUTIL7("No/Quit/Invalid Input.")
+59 SET CANCLRSN="BLRMANPU NO GOOD"
End DoDot:2
QUIT
+60 ;
+61 SET CANCLRSN="Cancel Reason:*"_$GET(X)
End DoDot:1
+62 ;
+63 IF CANCLRSN="BLRMANPU NO GOOD"
QUIT
+64 ;
+65 SET LRAS=""
+66 FOR
SET LRAS=$ORDER(REMOVEA(LRAS))
IF LRAS=""
QUIT
Begin DoDot:1
+67 SET STR=$GET(REMOVEA(LRAS))
+68 SET LRAA=$PIECE(STR,U)
SET LRAD=$PIECE(STR,U,2)
SET LRAN=$PIECE(STR,U,3)
+69 SET UID=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA,16,"I")
+70 SET OKAY=$$NOTPERF(LRAA,LRAD,LRAN,UID,CANCLRSN)
+71 IF OKAY<1
SET NOTOKAY(LRAS)=""
+72 IF OKAY
SET NPOKAY(LRAS)=""
End DoDot:1
+73 ;
+74 DO HEADERDT^BLRGMENU
+75 IF $DATA(NPOKAY)
Begin DoDot:1
+76 SET LRAS=""
+77 FOR
SET LRAS=$ORDER(NPOKAY(LRAS))
IF LRAS=""
QUIT
WRITE ?4,LRAS,?29,"*NP Marked",!
End DoDot:1
+78 ;
+79 ; Now, mark them discontinued in the Order (#100) file
+80 SET DISCPTR=$$FIND1^DIC(100.01,,,"DISCONTINUED")
+81 KILL WHOCANCL
+82 SET LRAS=""
+83 FOR
SET LRAS=$ORDER(NPOKAY(LRAS))
IF LRAS=""
QUIT
Begin DoDot:1
+84 SET STR=$GET(REMOVEA(LRAS))
+85 SET LRAA=$PIECE(STR,U)
SET LRAD=$PIECE(STR,U,2)
SET LRAN=$PIECE(STR,U,3)
+86 SET LRODNUM=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA,14,"I")
+87 SET LRODT=0
+88 FOR
SET LRODT=$ORDER(^LRO(69,"C",LRODNUM,LRODT))
IF LRODT<1
QUIT
Begin DoDot:2
+89 SET LRSP=0
+90 FOR
SET LRSP=$ORDER(^LRO(69,"C",LRODNUM,LRODT,LRSP))
IF LRSP<1
QUIT
Begin DoDot:3
+91 KILL TESTS,NAT
+92 SET LROT=0
+93 FOR
SET LROT=$ORDER(^LRO(69,LRODT,1,LRSP,2,LROT))
IF LROT<1
QUIT
Begin DoDot:4
+94 SET LROTIEN=LROT_","_LRSP_","_LRODT
+95 SET LROLRAD=$$GET1^DIQ(69.03,LROTIEN,2,"I")
+96 IF LROLRAD'=LRAD
QUIT
+97 SET LROLRAA=$$GET1^DIQ(69.03,LROTIEN,3,"I")
+98 IF LROLRAA'=LRAA
QUIT
+99 SET LROLRAN=$$GET1^DIQ(69.03,LROTIEN,4,"I")
+100 IF LROLRAN'=LRAN
QUIT
+101 ;
+102 SET F60PTR=$$GET1^DIQ(69.03,LROTIEN,.01,"I")
+103 SET TESTS(F60PTR)=""
+104 SET WHOCANCL(LRODT,LRSP,LROT)=$$GET1^DIQ(69.03,LROTIEN,10,"I")
+105 ; Have to make null for NEW^LR7OB1 to work
SET $PIECE(^LRO(69,LRODT,1,LRSP,2,LROT,0),U,11)=""
End DoDot:4
+106 IF $DATA(TESTS)<1
QUIT
+107 ;
+108 SET NAT="^^^5^OTHER CANCEL REASON^99ORR"
+109 DO NEW^LR7OB1(LRODT,LRSP,"OC",NAT,.TESTS)
End DoDot:3
End DoDot:2
End DoDot:1
+110 ;
+111 ; Now, set or restore the WHO CANCELLED field
+112 SET LRODT=0
+113 FOR
SET LRODT=$ORDER(WHOCANCL(LRODT))
IF LRODT<1
QUIT
Begin DoDot:1
+114 SET LRSP=0
+115 FOR
SET LRSP=$ORDER(WHOCANCL(LRODT,LRSP))
IF LRSP<1
QUIT
Begin DoDot:2
+116 SET LROT=0
+117 FOR
SET LROT=$ORDER(WHOCANCL(LRODT,LRSP,LROT))
IF LROT<1
QUIT
Begin DoDot:3
+118 SET WHOCANCL=$GET(WHOCANCL(LRODT,LRSP,LROT))
+119 SET WHOCANCL=$SELECT(WHOCANCL:WHOCANCL,1:DUZ)
+120 SET $PIECE(^LRO(69,LRODT,1,LRSP,2,LROT,0),U,11)=WHOCANCL
End DoDot:3
End DoDot:2
End DoDot:1
+121 ;
+122 IF $DATA(NOTOKAY)
Begin DoDot:1
+123 WRITE !!,"The following accessions were NOT marked as *NP Complete:",!,?4
+124 SET LRAS=""
+125 FOR
SET LRAS=$ORDER(NOTOKAY(LRAS))
IF LRAS=""
QUIT
Begin DoDot:2
+126 WRITE $$LJ^XLFSTR(LRAS,22)
+127 IF $X>69
WRITE !,?4
End DoDot:2
End DoDot:1
+128 ;
+129 DO PRESSKEY^BLRGMENU(9)
+130 QUIT
+131 ;
NOTPERF(LRAA,LRAD,LRAN,UID,CANCLRSN) ; EP - Not Performed
+1 NEW (CANCLRSN,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRAA,LRAD,LRAN,U,UID,XPARSYS,XQXFLG)
+2 ;
+3 DO ^LRPARAM
+4 SET BLRLOG=1
+5 ;
+6 SET SAVLRAA=LRAA
SET SAVLRAD=LRAD
SET SAVLRAN=LRAN
+7 ;
+8 SET LRSS=$$GET1^DIQ(68,LRAA,"LR SUBSCRIPT","I")
+9 SET IEN=LRAN_","_LRAD_","_LRAA_","
+10 SET LRDFN=$$GET1^DIQ(68.02,IEN,"LRDFN","I")
+11 SET LRIDT=$$GET1^DIQ(68.02,IEN,"INVERSE DATE","I")
+12 ;
+13 SET BLROPT="DELACC"
+14 ;
+15 KILL LRXX,LRSCNXB
+16 SET (LREND,LRNOP)=0
+17 DO FIX^BLRMANP2
+18 IF $GET(LREND)
SET LREND=1
QUIT 0
+19 ;
+20 QUIT 1
+21 ;
GETRID(LRAA,LRAD,LRAN,LRAS,LRNOP) ; EP - Mark Accession as NOT Performed.
+1 ; Following code cloned from LRTSTJAN & LRTSTOUT
+2 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRAA,LRAD,LRAN,LRAS,LRNOP,U,XPARSYS,XQXFLG)
+3 ;
+4 SET UID=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA,16,"I")
+5 DO NOTPERF^BLRRLTDR(UID)
+6 ;
+7 IF '$PIECE($GET(^LRO(68,+$GET(LRAA),1,+$GET(LRAD),1,+$GET(LRAN),0)),U,2)
WRITE !?5,"Accession has no Test ",!
SET LRNOP=1
QUIT
+8 LOCK +^LRO(68,LRAA,1,LRAD,1,LRAN):1
IF '$TEST
WRITE !,"Someone else is working on this accession",!
SET LRNOP=1
QUIT
+9 SET LRX=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRACN=$PIECE(^(.2),U)
SET LRUID=$PIECE(^(.3),U)
+10 SET LRDFN=+LRX
SET LRSN=+$PIECE(LRX,U,5)
SET LRODT=+$PIECE(LRX,U,4)
+11 SET LRSS=$$GET1^DIQ(68,LRAA,.02,"I")
+12 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+13 DO PT^LRX
+14 ;
+15 SET LRIDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
LOCK +^LR(LRDFN,LRSS,LRIDT):1
IF '$TEST
WRITE !,"Someone else is working on this data."
LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)
SET LRNOP=1
QUIT
+16 IF '$GET(^LR(LRDFN,LRSS,LRIDT,0))
WRITE !?5," Can't find Lab Data for this accession",!
DO UNLOCK
SET LRNOP=1
QUIT
+17 ;
+18 SET LRTOTL=1
SET LRIFN=0
+19 IF LRTOTL>0
Begin DoDot:1
+20 FOR
SET LRIFN=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRIFN))
IF LRIFN=""
QUIT
IF $PIECE($GET(^LR(LRDFN,LRSS,LRIDT,LRIFN)),U)="pending"
SET $PIECE(^LR(LRDFN,LRSS,LRIDT,LRIFN),U)=""
End DoDot:1
+21 IF LRTOTL=0
DO CHG^LRTSTOUT
QUIT
+22 DO FX2^LRTSTOUT
IF $GET(LREND)
QUIT
+23 Begin DoDot:1
+24 NEW LRTSTS
+25 SET LRTSTS=0
SET LRNOW=$$NOW^XLFDT
FOR
SET LRTSTS=+$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS))
IF LRTSTS<1
QUIT
IF $DATA(^(LRTSTS,0))#2
IF '$PIECE(^(0),U,5)
Begin DoDot:2
+26 IF $DATA(^LAB(60,LRTSTS,0))
SET LRTNM=$PIECE(^(0),U)
DO SET^LRTSTOUT
End DoDot:2
End DoDot:1
+27 LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)
+28 IF $LENGTH($GET(LRSS))
LOCK -^LR(+$GET(LRDFN),LRSS,+$GET(LRIDT))
+29 IF BLRLOG
DO ^BLREVTQ("M","D",$GET(BLROPT),,LRACN)
+30 QUIT
+31 ;
+32 ;
UNLOCK ; EP
+1 LOCK -(^LR($GET(LRDFN),$GET(LRSS),$GET(LRIDT)),^LRO(68,$GET(LRAA),1,$GET(LRAD),1,$GET(LRAN)))
+2 QUIT
+3 ;
+4 ;
SETBLRVS(TWO) ; EP - Set the BLRVERN variable(s)
+1 KILL BLRVERN,BLRVERN2
+2 ;
+3 SET BLRVERN=$PIECE($PIECE($TEXT(+1),";")," ")
+4 IF $LENGTH($GET(TWO))
SET BLRVERN2=$GET(TWO)
+5 QUIT
+6 ;
SLABDATA ; EP - Setup the Lab Data file variables
+1 DO ^LRWU4
+2 ;
+3 SET LRAIEN=LRAN_","_LRAD_","_LRAA
+4 SET LRDFN=$$GET1^DIQ(68.02,LRAIEN,"LRDFN","I")
+5 SET LRIDT=$$GET1^DIQ(68.02,LRAIEN,"INVERSE DATE","I")
+6 ;
+7 WRITE !!,"LRDFN:",LRDFN,"; LRIDT:",LRIDT,!!
+8 QUIT
+9 ;
LRWU4 ; EP - Code cloned from LRWU4 routine
+1 NEW %,DIC,DIR,DIRUT,DUOUT,DTOUT,LRQUIT,LRX
+2 ;
+3 KILL LRNATURE
+4 SET U="^"
SET DT=$$DT^XLFDT
SET LRQUIT=0
+5 FOR
DO LRWU4AA
IF LRQUIT
QUIT
+6 QUIT
+7 ;
LRWU4AA ;
+1 SET DIR(0)="FO^1:30"
SET DIR("A")="Select Accession"_$SELECT($GET(LRVBY)=1:"",1:" or UID")
+2 SET DIR("?")="^D QUES^LRWU4"
+3 DO ^DIR
+4 IF Y=""!$DATA(DIRUT)
DO QUIT^LRWU4
QUIT
+5 SET LRX=Y
+6 SET BLRLRAS=$GET(X)
+7 ;
+8 IF $LENGTH(LRX)>2
SET ^DISV(DUZ,"LRACC")=LRX
+9 IF LRX=" "
SET LRX=$SELECT($DATA(^DISV(DUZ,"LRACC")):^("LRACC"),1:"?")
+10 SET (LRAA,LRAD,LRAN)=0
+11 ;
+12 ; see if entry is UID
+13 IF $GET(LRVBY)<1
IF $DATA(^LRO(68,"C",LRX))
DO UNIV^LRWU4
QUIT
+14 ;
+15 ; Parse and process user input.
+16 SET (X1,X2,X3)=""
SET X1=$PIECE(LRX," ",1)
SET X2=$PIECE(LRX," ",2)
SET X3=$PIECE(LRX," ",3)
+17 IF X3=""&(+X2=X2)
SET X3=X2
SET X2=""
+18 IF X1'?1A.AN
DO QUES^LRWU4
QUIT
+19 SET LRAA=$ORDER(^LRO(68,"B",X1,0))
+20 IF LRAA<1
DO WLQUES^LRWU4
IF LRAA<1
QUIT
+21 SET %=$PIECE(^LRO(68,LRAA,0),U,14)
+22 SET %=$$LKUP^XPDKEY(%)
+23 IF $LENGTH(%)
IF '$DATA(^XUSEC(%,DUZ))
DO WLQUES^LRWU4
IF LRAA<1
QUIT
+24 ;
+25 SET LRX=$GET(^LRO(68,LRAA,0))
SET LRIDIV=$SELECT($LENGTH($PIECE(LRX,U,19)):$PIECE(LRX,U,19),1:"CP")
+26 ; W !,$P(LRX,U)
+27 ;
+28 ; User entered only accession area identifier, no date or number. Not allowed.
+29 IF X2=""
IF X3=""
DO QUIT^LRWU4
QUIT
+30 ;
+31 ; Convert middle value to FileMan date
+32 ; Adjust for monthly and quarterly formats (MM00) if user enters 4 digit
+33 ; number as middle part of accession then convert to appropriate date.
+34 IF LRAD<1
Begin DoDot:1
+35 NEW %DT
+36 IF X2=""
SET X2=DT
+37 IF X2?4N
Begin DoDot:2
+38 SET X2=$EXTRACT(DT,1,3)_X2
+39 IF X2>DT
SET X2=X2-10000
End DoDot:2
+40 SET %DT="EP"
SET X=X2
+41 DO ^%DT
+42 IF Y>0
SET LRAD=Y
QUIT
+43 DO QUES^LRWU4
End DoDot:1
+44 IF LRAD<1
QUIT
+45 ;
+46 ; Convert date entered to apropriate date for accession area transform
+47 SET X=$PIECE(^LRO(68,LRAA,0),U,3)
+48 SET LRAD=$SELECT("D"[X:LRAD,X="Y":$EXTRACT(LRAD,1,3)_"0000","M"[X:$EXTRACT(LRAD,1,5)_"00","Q"[X:$EXTRACT(LRAD,1,3)_"0000"+(($EXTRACT(LRAD,4,5)-1)\3*300+100),1:LRAD)
+49 IF X3>0
WRITE " ",+X3
+50 ;
+51 IF X3=""
IF $DATA(LRACC)
Begin DoDot:1
+52 NEW DIR,DIRUT,DUOUT,DTOUT,X,Y
+53 SET DIR(0)="NO^1:999999"
SET DIR("A")=" Number part of Accession"
+54 DO ^DIR
+55 IF Y=""!$DATA(DIRUT)
QUIT
+56 SET X3=Y
End DoDot:1
+57 ;
+58 IF X3=""
IF $DATA(LRACC)
DO QUIT^LRWU4
QUIT
+59 SET LRAN=+X3
+60 IF LRAN<1
IF $DATA(LRACC)
DO QUES^LRWU4
QUIT
+61 IF $DATA(LRACC)
IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
Begin DoDot:1
+62 WRITE !,"ACCESSION: ",$PIECE(^LRO(68,LRAA,0),U,11)," ",$$FMTE^XLFDT(LRAD,"5D")," ",LRAN," DOES NOT EXIST!"
End DoDot:1
QUIT
+63 ;
+64 SET LRQUIT=1
+65 QUIT
+66 ;
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 DO SETBLRVS
+4 ;
+5 DO ADDTMENU^BLRGMENU("PEP^BLRMANPU","Mark Multiple Accessions NP")
+6 DO ADDTMENU^BLRGMENU("XTMPRPT^BLRMANP3","Report on Errors For Mult Accs NP")
+7 DO ADDTMENU^BLRGMENU("XTMPKILL^BLRMANP3","Purge Error Report Global")
+8 DO ADDTMENU^BLRGMENU("DETAIL68^BLRMANP3","Accession Detail")
+9 DO ADDTMENU^BLRGMENU("F6869100^BLRMANPU","Report on Files 68, 69, & 100")
+10 ;
+11 DO MENUDRVR^BLRGMENU("RPMS Lab","Mark Multiple Accessions NP Utilities")
+12 QUIT
+13 ;
+14 ; The following cloned from BLRRLTDU
XTMPISET(MSG,RTN) ; EP - Set data in ^XTMP when there are issues
+1 NEW UID,STR
+2 ;
+3 SET STR=$GET(^XTMP("BLRMANPU",0))
+4 ; Set ^XTMP Node Zero
IF $LENGTH(STR)<1
Begin DoDot:1
+5 SET STR=$$HTFM^XLFDT(+$HOROLOG)_"^^Multiple Accessions as Not Performed Errors"
End DoDot:1
+6 SET $PIECE(STR,"^",2)=$$HTFM^XLFDT(+$HOROLOG+30)
+7 SET ^XTMP("BLRMANPU",0)=STR
+8 ;
+9 SET UID=$GET(^LRO(68,+$GET(LRAA),1,+$GET(LRAD),1,+$GET(LRAN),.3),"<UNKNOWN>")
+10 SET ^XTMP("BLRMANPU","UID",UID,"DUZ",DUZ,$HOROLOG)=RTN_"^"_MSG
+11 SET ^XTMP("BLRMANPU","UID")=1+$GET(^XTMP("BLRMANPU","UID"))
+12 SET LREND=1
+13 ;
+14 QUIT
+15 ;
+16 ;
F6869100 ; EP - Given an Accession, display data from 68, 69 & 100
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 DO SETBLRVS
+4 ;
+5 SET HEADER(1)="Accession Data"
+6 SET HEADER(2)="File 68, 69 & 100 Status"
+7 DO HEADERDT^BLRGMENU
+8 ;
+9 DO ^LRWU4
+10 ;
+11 IF LRAA<1!(LRAD<1)!(LRAN<1)
SET ONGO="NO"
QUIT
+12 ;
+13 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN))<1
Begin DoDot:1
+14 DO PROMPTO^BLRUTIL7("Accession "_BLRLRAS_" does not exist.")
End DoDot:1
QUIT
+15 ;
+16 DO HEADERDT^BLRGMENU
+17 DO HEADONE^BLRGMENU(.HDRONE)
+18 DO HEADERDT^BLRGMENU
+19 ;
+20 SET LRAAIEN=LRAN_","_LRAD_","_LRAA
+21 SET ORDNUM=$$GET1^DIQ(68.02,LRAAIEN,14)
+22 SET LRAS=$$GET1^DIQ(68.02,LRAAIEN,15)
+23 SET LRAUID=$$GET1^DIQ(68.02,LRAAIEN,16)
+24 ;
+25 KILL HEADER(1)
+26 SET HEADER(1)="Accession "_LRAS_" ["_LRAUID_"] Data"
+27 ;
+28 SET HEADER(3)=" "
+29 SET HEADER(4)="File 60"
+30 SET $EXTRACT(HEADER(4),10)=$$COLHEAD^BLRGMENU("File 68",31)
+31 SET $EXTRACT(HEADER(4),43)=$$COLHEAD^BLRGMENU("File 69",18)
+32 SET $EXTRACT(HEADER(4),63)=$$COLHEAD^BLRGMENU("File 100",18)
+33 SET HEADER(5)="IEN"
+34 SET $EXTRACT(HEADER(5),10)="LRAS"
+35 SET $EXTRACT(HEADER(5),28)="Disposition"
+36 SET $EXTRACT(HEADER(5),43)="Order #"
+37 SET $EXTRACT(HEADER(5),53)="CancelBy"
+38 SET $EXTRACT(HEADER(5),63)="OERR #"
+39 SET $EXTRACT(HEADER(5),75)="Status"
+40 ;
+41 SET MAXLINES=IOSL-4
SET LINES=MAXLINES+10
+42 SET (CNT,PG)=0
+43 SET QFLG="NO"
+44 ;
+45 ; Create File 69 Array by File 60 IEN
+46 SET LRODT=0
+47 FOR
SET LRODT=$ORDER(^LRO(69,"C",ORDNUM,LRODT))
IF LRODT<1
QUIT
Begin DoDot:1
+48 SET LRSP=0
+49 FOR
SET LRSP=$ORDER(^LRO(69,"C",ORDNUM,LRODT,LRSP))
IF LRSP<1
QUIT
Begin DoDot:2
+50 SET LROT=0
+51 FOR
SET LROT=$ORDER(^LRO(69,LRODT,1,LRSP,2,LROT))
IF LROT<1
QUIT
Begin DoDot:3
+52 SET LROTIEN=LROT_","_LRSP_","_LRODT
+53 SET LROF60=$$GET1^DIQ(69.03,LROTIEN,.01,"I")
+54 SET OERRIEN=$$GET1^DIQ(69.03,LROTIEN,6,"I")
+55 SET LROSTS=$$GET1^DIQ(69.03,LROTIEN,9)
+56 SET LROCANBY=$$GET1^DIQ(69.03,LROTIEN,10,"I")
+57 SET LROTARRY(LROF60)=LRODT_U_LRSP_U_OERRIEN_U_LROCANBY_U_LROSTS
End DoDot:3
End DoDot:2
End DoDot:1
+58 ;
+59 ; Go through File 68's File 60 IENs
+60 SET LRAT=0
+61 FOR
SET LRAT=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRAT))
IF LRAT<1!(QFLG="Q")
QUIT
Begin DoDot:1
+62 SET DISPTION=$$GET1^DIQ(68.04,LRAT_","_LRAAIEN,5)
+63 SET STR=$GET(LROTARRY(LRAT))
+64 SET OERRIEN=$PIECE(STR,U,3)
+65 SET OERRSTS=$$GET1^DIQ(100,OERRIEN,"STATUS")
+66 SET CANCBY=$PIECE(STR,U,4)
+67 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)
IF QFLG="Q"
QUIT
+68 ;
+69 WRITE LRAT
+70 WRITE ?9,LRAS
+71 WRITE ?27,$EXTRACT(DISPTION,1,13)
+72 WRITE ?42,ORDNUM
+73 WRITE ?52,CANCBY
+74 WRITE ?62,OERRIEN
+75 WRITE ?74,$EXTRACT(OERRSTS,1,6)
+76 WRITE !
+77 SET LINES=LINES+1
End DoDot:1
+78 ;
+79 DO PRESSKEY^BLRGMENU(9)
+80 QUIT
