Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BLRMANPU

BLRMANPU.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. EEP ; Ersatz EP
  1. D EEP^BLRGMENU
  1. Q
  1. ;
  1. EP ; EP
  1. PEP ; EP
  1. NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1. ;
  1. D SETBLRVS
  1. ;
  1. S HEADER(1)="Multiple Accessions"
  1. S HEADER(2)="Not Performed Utility"
  1. ;
  1. S ONGO="YES"
  1. F Q:ONGO="NO" D
  1. . D HEADERDT^BLRGMENU
  1. . I $D(REMOVEA) D
  1. .. W "The following Accessions have been selected:",!,?4
  1. .. S LRAS=""
  1. .. F S LRAS=$O(REMOVEA(LRAS)) Q:LRAS="" D
  1. ... W $$LJ^XLFSTR(LRAS,22)
  1. ... I $X>69 W !,?4
  1. . W !!
  1. . D LRWU4
  1. . I LRAA<1!(LRAD<1)!(LRAN<1) S ONGO="NO" Q
  1. . ;
  1. . I $D(^LRO(68,LRAA,1,LRAD,1,LRAN))<1 D Q
  1. .. D PROMPTO^BLRUTIL7("Accession "_BLRLRAS_" does not exist.")
  1. . ;
  1. . S (COMPLTED,LRAT)=0
  1. . F S LRAT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRAT)) Q:LRAT<1!(COMPLTED) D
  1. .. I $$GET1^DIQ(68.04,LRAT_","_LRAN_","_LRAD_","_LRAA,4,"I") S COMPLTED=COMPLTED+1
  1. . ;
  1. . I COMPLTED D Q
  1. .. D PROMPTO^BLRUTIL7("Accession "_BLRLRAS_" has completed data. Cannot be selected.")
  1. . ;
  1. . S REMOVEA(BLRLRAS)=LRAA_U_LRAD_U_LRAN
  1. ;
  1. I $D(REMOVEA)<1 D BADSTUFF^BLRUTIL7("No Accessions selected.") Q
  1. ;
  1. D HEADERDT^BLRGMENU
  1. W "The following Accessions have been selected to be marked as NOT PERFORMED:",!,?4
  1. S LRAS=""
  1. F S LRAS=$O(REMOVEA(LRAS)) Q:LRAS="" D
  1. . W $$LJ^XLFSTR(LRAS,22)
  1. . I $X>69 W !,?4
  1. W !!
  1. ;
  1. D ^XBFMK
  1. S DIR(0)="YO"
  1. S DIR("A")="Do you want to continue"
  1. S DIR("B")="NO"
  1. D ^DIR
  1. I +$G(DIRUT)!(+Y<1) D PROMPTO^BLRUTIL7("Per response, routine ends.") Q
  1. ;
  1. S CANCLRSN=""
  1. F Q:$L(CANCLRSN) D
  1. . D HEADERDT^BLRGMENU
  1. . D ^XBFMK
  1. . S DIR(0)="FO"
  1. . S DIR("A")="Not Performed Reason"
  1. . D ^DIR
  1. . I +$G(DIRUT) D Q
  1. .. D BADSTUFF^BLRUTIL7("No/Quit/Invalid Input.")
  1. .. S CANCLRSN="BLRMANPU NO GOOD"
  1. . ;
  1. . S CANCLRSN="Cancel Reason:*"_$G(X)
  1. ;
  1. Q:CANCLRSN="BLRMANPU NO GOOD"
  1. ;
  1. S LRAS=""
  1. F S LRAS=$O(REMOVEA(LRAS)) Q:LRAS="" D
  1. . S STR=$G(REMOVEA(LRAS))
  1. . S LRAA=$P(STR,U),LRAD=$P(STR,U,2),LRAN=$P(STR,U,3)
  1. . S UID=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA,16,"I")
  1. . S OKAY=$$NOTPERF(LRAA,LRAD,LRAN,UID,CANCLRSN)
  1. . S:OKAY<1 NOTOKAY(LRAS)=""
  1. . S:OKAY NPOKAY(LRAS)=""
  1. ;
  1. D HEADERDT^BLRGMENU
  1. I $D(NPOKAY) D
  1. . S LRAS=""
  1. . F S LRAS=$O(NPOKAY(LRAS)) Q:LRAS="" W ?4,LRAS,?29,"*NP Marked",!
  1. ;
  1. ; Now, mark them discontinued in the Order (#100) file
  1. S DISCPTR=$$FIND1^DIC(100.01,,,"DISCONTINUED")
  1. K WHOCANCL
  1. S LRAS=""
  1. F S LRAS=$O(NPOKAY(LRAS)) Q:LRAS="" D
  1. . S STR=$G(REMOVEA(LRAS))
  1. . S LRAA=$P(STR,U),LRAD=$P(STR,U,2),LRAN=$P(STR,U,3)
  1. . S LRODNUM=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA,14,"I")
  1. . S LRODT=0
  1. . F S LRODT=$O(^LRO(69,"C",LRODNUM,LRODT)) Q:LRODT<1 D
  1. .. S LRSP=0
  1. .. F S LRSP=$O(^LRO(69,"C",LRODNUM,LRODT,LRSP)) Q:LRSP<1 D
  1. ... K TESTS,NAT
  1. ... S LROT=0
  1. ... F S LROT=$O(^LRO(69,LRODT,1,LRSP,2,LROT)) Q:LROT<1 D
  1. .... S LROTIEN=LROT_","_LRSP_","_LRODT
  1. .... S LROLRAD=$$GET1^DIQ(69.03,LROTIEN,2,"I")
  1. .... Q:LROLRAD'=LRAD
  1. .... S LROLRAA=$$GET1^DIQ(69.03,LROTIEN,3,"I")
  1. .... Q:LROLRAA'=LRAA
  1. .... S LROLRAN=$$GET1^DIQ(69.03,LROTIEN,4,"I")
  1. .... Q:LROLRAN'=LRAN
  1. .... ;
  1. .... S F60PTR=$$GET1^DIQ(69.03,LROTIEN,.01,"I")
  1. .... S TESTS(F60PTR)=""
  1. .... S WHOCANCL(LRODT,LRSP,LROT)=$$GET1^DIQ(69.03,LROTIEN,10,"I")
  1. .... S $P(^LRO(69,LRODT,1,LRSP,2,LROT,0),U,11)="" ; Have to make null for NEW^LR7OB1 to work
  1. ... Q:$D(TESTS)<1
  1. ... ;
  1. ... S NAT="^^^5^OTHER CANCEL REASON^99ORR"
  1. ... D NEW^LR7OB1(LRODT,LRSP,"OC",NAT,.TESTS)
  1. ;
  1. ; Now, set or restore the WHO CANCELLED field
  1. S LRODT=0
  1. F S LRODT=$O(WHOCANCL(LRODT)) Q:LRODT<1 D
  1. . S LRSP=0
  1. . F S LRSP=$O(WHOCANCL(LRODT,LRSP)) Q:LRSP<1 D
  1. .. S LROT=0
  1. .. F S LROT=$O(WHOCANCL(LRODT,LRSP,LROT)) Q:LROT<1 D
  1. ... S WHOCANCL=$G(WHOCANCL(LRODT,LRSP,LROT))
  1. ... S WHOCANCL=$S(WHOCANCL:WHOCANCL,1:DUZ)
  1. ... S $P(^LRO(69,LRODT,1,LRSP,2,LROT,0),U,11)=WHOCANCL
  1. ;
  1. I $D(NOTOKAY) D
  1. . W !!,"The following accessions were NOT marked as *NP Complete:",!,?4
  1. . S LRAS=""
  1. . F S LRAS=$O(NOTOKAY(LRAS)) Q:LRAS="" D
  1. .. W $$LJ^XLFSTR(LRAS,22)
  1. .. I $X>69 W !,?4
  1. ;
  1. D PRESSKEY^BLRGMENU(9)
  1. Q
  1. ;
  1. 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)
  1. ;
  1. D ^LRPARAM
  1. S BLRLOG=1
  1. ;
  1. S SAVLRAA=LRAA,SAVLRAD=LRAD,SAVLRAN=LRAN
  1. ;
  1. S LRSS=$$GET1^DIQ(68,LRAA,"LR SUBSCRIPT","I")
  1. S IEN=LRAN_","_LRAD_","_LRAA_","
  1. S LRDFN=$$GET1^DIQ(68.02,IEN,"LRDFN","I")
  1. S LRIDT=$$GET1^DIQ(68.02,IEN,"INVERSE DATE","I")
  1. ;
  1. S BLROPT="DELACC"
  1. ;
  1. K LRXX,LRSCNXB
  1. S (LREND,LRNOP)=0
  1. D FIX^BLRMANP2
  1. I $G(LREND) S LREND=1 Q 0
  1. ;
  1. Q 1
  1. ;
  1. GETRID(LRAA,LRAD,LRAN,LRAS,LRNOP) ; EP - Mark Accession as NOT Performed.
  1. ; Following code cloned from LRTSTJAN & LRTSTOUT
  1. NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRAA,LRAD,LRAN,LRAS,LRNOP,U,XPARSYS,XQXFLG)
  1. ;
  1. S UID=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA,16,"I")
  1. D NOTPERF^BLRRLTDR(UID)
  1. ;
  1. 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
  1. L +^LRO(68,LRAA,1,LRAD,1,LRAN):1 I '$T W !,"Someone else is working on this accession",! S LRNOP=1 Q
  1. S LRX=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRACN=$P(^(.2),U),LRUID=$P(^(.3),U)
  1. S LRDFN=+LRX,LRSN=+$P(LRX,U,5),LRODT=+$P(LRX,U,4)
  1. S LRSS=$$GET1^DIQ(68,LRAA,.02,"I")
  1. S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
  1. D PT^LRX
  1. ;
  1. 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
  1. I '$G(^LR(LRDFN,LRSS,LRIDT,0)) W !?5," Can't find Lab Data for this accession",! D UNLOCK S LRNOP=1 Q
  1. ;
  1. S LRTOTL=1,LRIFN=0
  1. I LRTOTL>0 D
  1. .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)=""
  1. I LRTOTL=0 D CHG^LRTSTOUT Q
  1. D FX2^LRTSTOUT I $G(LREND) Q
  1. D
  1. . N LRTSTS
  1. . 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
  1. . . I $D(^LAB(60,LRTSTS,0)) S LRTNM=$P(^(0),U) D SET^LRTSTOUT
  1. L -^LRO(68,LRAA,1,LRAD,1,LRAN)
  1. I $L($G(LRSS)) L -^LR(+$G(LRDFN),LRSS,+$G(LRIDT))
  1. D:BLRLOG ^BLREVTQ("M","D",$G(BLROPT),,LRACN)
  1. Q
  1. ;
  1. ;
  1. UNLOCK ; EP
  1. L -(^LR($G(LRDFN),$G(LRSS),$G(LRIDT)),^LRO(68,$G(LRAA),1,$G(LRAD),1,$G(LRAN)))
  1. Q
  1. ;
  1. ;
  1. SETBLRVS(TWO) ; EP - Set the BLRVERN variable(s)
  1. K BLRVERN,BLRVERN2
  1. ;
  1. S BLRVERN=$P($P($T(+1),";")," ")
  1. S:$L($G(TWO)) BLRVERN2=$G(TWO)
  1. Q
  1. ;
  1. SLABDATA ; EP - Setup the Lab Data file variables
  1. D ^LRWU4
  1. ;
  1. S LRAIEN=LRAN_","_LRAD_","_LRAA
  1. S LRDFN=$$GET1^DIQ(68.02,LRAIEN,"LRDFN","I")
  1. S LRIDT=$$GET1^DIQ(68.02,LRAIEN,"INVERSE DATE","I")
  1. ;
  1. W !!,"LRDFN:",LRDFN,"; LRIDT:",LRIDT,!!
  1. Q
  1. ;
  1. LRWU4 ; EP - Code cloned from LRWU4 routine
  1. N %,DIC,DIR,DIRUT,DUOUT,DTOUT,LRQUIT,LRX
  1. ;
  1. K LRNATURE
  1. S U="^",DT=$$DT^XLFDT,LRQUIT=0
  1. F D LRWU4AA Q:LRQUIT
  1. Q
  1. ;
  1. LRWU4AA ;
  1. S DIR(0)="FO^1:30",DIR("A")="Select Accession"_$S($G(LRVBY)=1:"",1:" or UID")
  1. S DIR("?")="^D QUES^LRWU4"
  1. D ^DIR
  1. I Y=""!$D(DIRUT) D QUIT^LRWU4 Q
  1. S LRX=Y
  1. S BLRLRAS=$G(X)
  1. ;
  1. S:$L(LRX)>2 ^DISV(DUZ,"LRACC")=LRX
  1. S:LRX=" " LRX=$S($D(^DISV(DUZ,"LRACC")):^("LRACC"),1:"?")
  1. S (LRAA,LRAD,LRAN)=0
  1. ;
  1. ; see if entry is UID
  1. I $G(LRVBY)<1,$D(^LRO(68,"C",LRX)) D UNIV^LRWU4 Q
  1. ;
  1. ; Parse and process user input.
  1. S (X1,X2,X3)="",X1=$P(LRX," ",1),X2=$P(LRX," ",2),X3=$P(LRX," ",3)
  1. S:X3=""&(+X2=X2) X3=X2,X2=""
  1. I X1'?1A.AN D QUES^LRWU4 Q
  1. S LRAA=$O(^LRO(68,"B",X1,0))
  1. I LRAA<1 D WLQUES^LRWU4 Q:LRAA<1
  1. S %=$P(^LRO(68,LRAA,0),U,14)
  1. S %=$$LKUP^XPDKEY(%)
  1. I $L(%),'$D(^XUSEC(%,DUZ)) D WLQUES^LRWU4 Q:LRAA<1
  1. ;
  1. S LRX=$G(^LRO(68,LRAA,0)),LRIDIV=$S($L($P(LRX,U,19)):$P(LRX,U,19),1:"CP")
  1. ; W !,$P(LRX,U)
  1. ;
  1. ; User entered only accession area identifier, no date or number. Not allowed.
  1. I X2="",X3="" D QUIT^LRWU4 Q
  1. ;
  1. ; Convert middle value to FileMan date
  1. ; Adjust for monthly and quarterly formats (MM00) if user enters 4 digit
  1. ; number as middle part of accession then convert to appropriate date.
  1. I LRAD<1 D
  1. . N %DT
  1. . I X2="" S X2=DT
  1. . I X2?4N D
  1. . . S X2=$E(DT,1,3)_X2
  1. . . I X2>DT S X2=X2-10000
  1. . S %DT="EP",X=X2
  1. . D ^%DT
  1. . I Y>0 S LRAD=Y Q
  1. . D QUES^LRWU4
  1. I LRAD<1 Q
  1. ;
  1. ; Convert date entered to apropriate date for accession area transform
  1. S X=$P(^LRO(68,LRAA,0),U,3)
  1. 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)
  1. W:X3>0 " ",+X3
  1. ;
  1. I X3="",$D(LRACC) D
  1. . N DIR,DIRUT,DUOUT,DTOUT,X,Y
  1. . S DIR(0)="NO^1:999999",DIR("A")=" Number part of Accession"
  1. . D ^DIR
  1. . I Y=""!$D(DIRUT) Q
  1. . S X3=Y
  1. ;
  1. I X3="",$D(LRACC) D QUIT^LRWU4 Q
  1. S LRAN=+X3
  1. I LRAN<1,$D(LRACC) D QUES^LRWU4 Q
  1. I $D(LRACC),'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q
  1. . W !,"ACCESSION: ",$P(^LRO(68,LRAA,0),U,11)," ",$$FMTE^XLFDT(LRAD,"5D")," ",LRAN," DOES NOT EXIST!"
  1. ;
  1. S LRQUIT=1
  1. Q
  1. ;
  1. NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1. ;
  1. D SETBLRVS
  1. ;
  1. D ADDTMENU^BLRGMENU("PEP^BLRMANPU","Mark Multiple Accessions NP")
  1. D ADDTMENU^BLRGMENU("XTMPRPT^BLRMANP3","Report on Errors For Mult Accs NP")
  1. D ADDTMENU^BLRGMENU("XTMPKILL^BLRMANP3","Purge Error Report Global")
  1. D ADDTMENU^BLRGMENU("DETAIL68^BLRMANP3","Accession Detail")
  1. D ADDTMENU^BLRGMENU("F6869100^BLRMANPU","Report on Files 68, 69, & 100")
  1. ;
  1. D MENUDRVR^BLRGMENU("RPMS Lab","Mark Multiple Accessions NP Utilities")
  1. Q
  1. ;
  1. ; The following cloned from BLRRLTDU
  1. XTMPISET(MSG,RTN) ; EP - Set data in ^XTMP when there are issues
  1. NEW UID,STR
  1. ;
  1. S STR=$G(^XTMP("BLRMANPU",0))
  1. I $L(STR)<1 D ; Set ^XTMP Node Zero
  1. . S STR=$$HTFM^XLFDT(+$H)_"^^Multiple Accessions as Not Performed Errors"
  1. S $P(STR,"^",2)=$$HTFM^XLFDT(+$H+30)
  1. S ^XTMP("BLRMANPU",0)=STR
  1. ;
  1. S UID=$G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),.3),"<UNKNOWN>")
  1. S ^XTMP("BLRMANPU","UID",UID,"DUZ",DUZ,$H)=RTN_"^"_MSG
  1. S ^XTMP("BLRMANPU","UID")=1+$G(^XTMP("BLRMANPU","UID"))
  1. S LREND=1
  1. ;
  1. Q
  1. ;
  1. ;
  1. 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)
  1. ;
  1. D SETBLRVS
  1. ;
  1. S HEADER(1)="Accession Data"
  1. S HEADER(2)="File 68, 69 & 100 Status"
  1. D HEADERDT^BLRGMENU
  1. ;
  1. D ^LRWU4
  1. ;
  1. I LRAA<1!(LRAD<1)!(LRAN<1) S ONGO="NO" Q
  1. ;
  1. I $D(^LRO(68,LRAA,1,LRAD,1,LRAN))<1 D Q
  1. . D PROMPTO^BLRUTIL7("Accession "_BLRLRAS_" does not exist.")
  1. ;
  1. D HEADERDT^BLRGMENU
  1. D HEADONE^BLRGMENU(.HDRONE)
  1. D HEADERDT^BLRGMENU
  1. ;
  1. S LRAAIEN=LRAN_","_LRAD_","_LRAA
  1. S ORDNUM=$$GET1^DIQ(68.02,LRAAIEN,14)
  1. S LRAS=$$GET1^DIQ(68.02,LRAAIEN,15)
  1. S LRAUID=$$GET1^DIQ(68.02,LRAAIEN,16)
  1. ;
  1. K HEADER(1)
  1. S HEADER(1)="Accession "_LRAS_" ["_LRAUID_"] Data"
  1. ;
  1. S HEADER(3)=" "
  1. S HEADER(4)="File 60"
  1. S $E(HEADER(4),10)=$$COLHEAD^BLRGMENU("File 68",31)
  1. S $E(HEADER(4),43)=$$COLHEAD^BLRGMENU("File 69",18)
  1. S $E(HEADER(4),63)=$$COLHEAD^BLRGMENU("File 100",18)
  1. S HEADER(5)="IEN"
  1. S $E(HEADER(5),10)="LRAS"
  1. S $E(HEADER(5),28)="Disposition"
  1. S $E(HEADER(5),43)="Order #"
  1. S $E(HEADER(5),53)="CancelBy"
  1. S $E(HEADER(5),63)="OERR #"
  1. S $E(HEADER(5),75)="Status"
  1. ;
  1. S MAXLINES=IOSL-4,LINES=MAXLINES+10
  1. S (CNT,PG)=0
  1. S QFLG="NO"
  1. ;
  1. ; Create File 69 Array by File 60 IEN
  1. S LRODT=0
  1. F S LRODT=$O(^LRO(69,"C",ORDNUM,LRODT)) Q:LRODT<1 D
  1. . S LRSP=0
  1. . F S LRSP=$O(^LRO(69,"C",ORDNUM,LRODT,LRSP)) Q:LRSP<1 D
  1. .. S LROT=0
  1. .. F S LROT=$O(^LRO(69,LRODT,1,LRSP,2,LROT)) Q:LROT<1 D
  1. ... S LROTIEN=LROT_","_LRSP_","_LRODT
  1. ... S LROF60=$$GET1^DIQ(69.03,LROTIEN,.01,"I")
  1. ... S OERRIEN=$$GET1^DIQ(69.03,LROTIEN,6,"I")
  1. ... S LROSTS=$$GET1^DIQ(69.03,LROTIEN,9)
  1. ... S LROCANBY=$$GET1^DIQ(69.03,LROTIEN,10,"I")
  1. ... S LROTARRY(LROF60)=LRODT_U_LRSP_U_OERRIEN_U_LROCANBY_U_LROSTS
  1. ;
  1. ; Go through File 68's File 60 IENs
  1. S LRAT=0
  1. F S LRAT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRAT)) Q:LRAT<1!(QFLG="Q") D
  1. . S DISPTION=$$GET1^DIQ(68.04,LRAT_","_LRAAIEN,5)
  1. . S STR=$G(LROTARRY(LRAT))
  1. . S OERRIEN=$P(STR,U,3)
  1. . S OERRSTS=$$GET1^DIQ(100,OERRIEN,"STATUS")
  1. . S CANCBY=$P(STR,U,4)
  1. . I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE) Q:QFLG="Q"
  1. . ;
  1. . W LRAT
  1. . W ?9,LRAS
  1. . W ?27,$E(DISPTION,1,13)
  1. . W ?42,ORDNUM
  1. . W ?52,CANCBY
  1. . W ?62,OERRIEN
  1. . W ?74,$E(OERRSTS,1,6)
  1. . W !
  1. . S LINES=LINES+1
  1. ;
  1. D PRESSKEY^BLRGMENU(9)
  1. Q