- 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