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

BLRSGNSP.m

Go to the documentation of this file. 
  1. BLRSGNSP ; IHS/MSC/MKK - Delete Order even though in SiGN or SYmptom Process ; 31-Jul-2015 06:30 ; MKK
  1.  ;;5.2;LR;**1033,1035,1036**;NOV 1, 1997;Build 10
  1.  ;
  1.  ; Code cloned from LRCENDEL routine.
  1. EEP ; Ersatz EP
  1.  D EEP^BLRGMENU
  1.  Q
  1.  ;
  1. EP ; EP - ORDERN = Order Number
  1. GETRID(ORDERN) ; EP - Cancel ALL Tests on an Order
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,ORDERN,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S LRORT=+$G(^TMP("BLRDIAG",$J,"ORDER","ADDTST"))
  1.  I LRORT  D GETRID1(ORDERN,LRORT)  Q
  1.  ;
  1.  S (DELCNT,LRODT)=0
  1.  F  S LRODT=$O(^LRO(69,"C",ORDERN,LRODT))  Q:LRODT<1  D
  1.  . S LRSP=0
  1.  . F  S LRSP=$O(^LRO(69,"C",ORDERN,LRODT,LRSP))  Q:LRSP<1  D
  1.  .. ;
  1.  .. D OERRSTSC^BLRUTIL7(LRODT,LRSP)  ; IHS/MSC/MKK - LR*5.2*1035 
  1.  .. ;
  1.  .. S LRORT=0
  1.  .. F  S LRORT=$O(^LRO(69,LRODT,1,LRSP,2,LRORT))  Q:LRORT<1  D
  1.  ... S STR=$G(^LRO(69,LRODT,1,LRSP,2,LRORT,0))
  1.  ... ;
  1.  ... ; Skip if already cancelled
  1.  ... Q:$L($P(^LRO(69,LRODT,1,LRSP,2,LRORT,0),"^",11))
  1.  ... ;
  1.  ... S FDAIENS=LRORT_","_LRSP_","_LRODT_","
  1.  ... K FDA
  1.  ... S FDA(69.03,FDAIENS,8)="CA"
  1.  ... S FDA(69.03,FDAIENS,11)=$G(DUZ)
  1.  ... D FILE^DIE("KS","FDA","ERRS")
  1.  ... ; I $D(ERRS) D SHOWERRS^BLRADDCD("Order File")  Q
  1.  ... I $D(ERRS) D ERRMSG^BLRSGNS3("GETRID: FILE^DIE","BLRSGNSP")  Q   ; IHS/MSC/MKK - LR*5.2*1035
  1.  ... D MAKEMESG(LRODT,LRSP,LRORT)
  1.  ... S DELCNT=DELCNT+1
  1.  ... D DELACC(LRODT,LRSP,LRORT)
  1.  ;
  1.  K ^TMP("BLRDAIG",$J,"ORDER")
  1.  K ^TMP("BLR SNOMED GET",$J,"HDR")
  1.  Q:DELCNT<1
  1.  ;
  1.  W !!,"All Tests on Order ",ORDERN,":",!
  1.  S LRODT=0
  1.  F  S LRODT=$O(^LRO(69,"C",ORDERN,LRODT))  Q:LRODT<1  D
  1.  . S LRSP=0
  1.  . F  S LRSP=$O(^LRO(69,"C",ORDERN,LRODT,LRSP))  Q:LRSP<1  D
  1.  .. S LRORT=0
  1.  .. F  S LRORT=$O(^LRO(69,LRODT,1,LRSP,2,LRORT))  Q:LRORT<1  D
  1.  ... S IENS=LRORT_","_LRSP_","_LRODT
  1.  ... W ?4,$$GET1^DIQ(69.03,IENS,.01)," ",$$GET1^DIQ(69.03,IENS,8),!
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. GETRID1(ORDERN,LRORT) ; EP - Cancel One Test on an Order
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRORT,ORDERN,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S LRODT=0
  1.  F  S LRODT=$O(^LRO(69,"C",ORDERN,LRODT))  Q:LRODT<1  D
  1.  . S LRSP=0
  1.  . F  S LRSP=$O(^LRO(69,"C",ORDERN,LRODT,LRSP))  Q:LRSP<1  D
  1.  .. S STR=$G(^LRO(69,LRODT,1,LRSP,2,LRORT,0))
  1.  .. Q:$L(STR)<1
  1.  .. ;
  1.  .. ; Skip if already cancelled
  1.  .. Q:$L($P(^LRO(69,LRODT,1,LRSP,2,LRORT,0),"^",11))
  1.  .. ;
  1.  .. D OERRSTSO^BLRUTIL7(LRODT,LRSP,LRORT)  ; IHS/MSC/MKK - LR*5.2*1035
  1.  .. ;
  1.  .. S FDAIENS=LRORT_","_LRSP_","_LRODT_","
  1.  .. K FDA
  1.  .. S FDA(69.03,FDAIENS,8)="CA"
  1.  .. S FDA(69.03,FDAIENS,11)=$G(DUZ)
  1.  .. D FILE^DIE("KS","FDA","ERRS")
  1.  .. ; I $D(ERRS) D SHOWERRS^BLRADDCD("Order File")  Q
  1.  .. ; I $D(ERRS) D ERRMSG("GETRID1: FILE^DIE")  Q
  1.  .. I $D(ERRS) D ERRMSG^BLRSGNS3("GETRID1: FILE^DIE","BLRSGNSP")  Q   ; IHS/MSC/MKK - LR*5.2*1035
  1.  .. D MAKEMESG(LRODT,LRSP,LRORT)
  1.  .. ;
  1.  .. D DELACC(LRODT,LRSP,LRORT)
  1.  ;
  1.  K ^TMP("BLRDAIG",$J,"ORDER")
  1.  K ^TMP("BLR SNOMED GET",$J,"HDR")
  1.  ;
  1.  W !!,"Test on Order ",ORDERN,":",!
  1.  F  S LRODT=$O(^LRO(69,"C",ORDERN,LRODT))  Q:LRODT<1  D
  1.  . S LRSP=0
  1.  . F  S LRSP=$O(^LRO(69,"C",ORDERN,LRODT,LRSP))  Q:LRSP<1  D
  1.  .. S STR=$G(^LRO(69,LRODT,1,LRSP,2,LRORT,0))
  1.  .. Q:$L(STR)<1
  1.  .. S IENS=LRORT_","_LRSP_","_LRODT
  1.  .. W ?4,$$GET1^DIQ(69.03,IENS,.01)," ",$$GET1^DIQ(69.03,IENS,8),!
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. DELACC(LRODT,LRSP,LRORT) ; EP - Cancel Test on Accession and add note on Lab Data File
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRODT,LRORT,LRSP,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S STR=$G(^LRO(69,LRODT,1,LRSP,2,LRORT,0))
  1.  ;
  1.  S LRAD=+$P(STR,"^",3),LRAA=+$P(STR,"^",4),LRAN=+$P(STR,"^",5)
  1.  Q:LRAD<1!(LRAA<1)!(LRAN<1)    ; Skip if no Accession
  1.  ;
  1.  S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),LRIDT=$P($G(^(3)),"^",5)
  1.  ;
  1.  ; Need to get File 68 variables
  1.  S LROTF60=+$G(STR)  ; File 60 Pointer
  1.  ;
  1.  S (FOUND,LRAT)=0
  1.  F  S LRAT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRAT))  Q:LRAT<1!(FOUND)  D
  1.  . S:+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRAT,0))=LROTF60 FOUND=LRAT
  1.  ;
  1.  Q:FOUND<1      ; Skip if cannot find Test on Accession
  1.  ;
  1.  ; File 68 "NOT PERFORMED"
  1.  D ^XBFMK
  1.  S IENS=FOUND_","_LRAN_","_LRAD_","_LRAA_","
  1.  K FDA,ERRS
  1.  S FDA(68.04,IENS,3)=$G(DUZ)
  1.  S FDA(68.04,IENS,4)=$$NOW^XLFDT
  1.  S FDA(68.04,IENS,5)="*Not Performed"
  1.  D FILE^DIE("KS","FDA","ERRS")
  1.  ; I $D(ERRS) D SHOWERRS^BLRADDCD("Accession File")  Q
  1.  I $D(ERRS) D ERRMSG^BLRSGNS3("File 68 - DELACC: FILE^DIE","BLRSGNSP")  Q  ; IHS/MSC/MKK - LR*5.2*1035
  1.  ;
  1.  ; File 63 "NOT PERFORMED"
  1.  S F60NAME=$$GET1^DIQ(60,LROTF60,"NAME")
  1.  S DEL1="*"_F60NAME_" Not Performed: "_$$HTE^XLFDT($H,"5MPZ")_" by "_$G(DUZ)
  1.  S DEL2="*NP Reason: User Quit During Clinical Indication Selection."
  1.  K IENS,FDA,ERRS
  1.  S IENS(1)=$O(^LR(LRDFN,"CH",LRIDT,1,"B"),-1)+1  ; Get next COMMENT line
  1.  S FDA(63.041,"+1,"_LRIDT_","_LRDFN_",",.01)=DEL1
  1.  D UPDATE^DIE(,"FDA","IENS","ERRS")
  1.  ; I $D(ERRS) D SHOWERRS^BLRADDCD("Lab Data File") Q
  1.  ; I $D(ERRS) D ERRMSG("File 63.041 - DELACC: UPDATE^DIE")  Q
  1.  I $D(ERRS) D ERRMSG^BLRSGNS3("File 63.041 - DELACC: UPDATE^DIE","BLRSGNSP")  Q      ; IHS/MSC/MKK - LR*5.2*1035
  1.  ;
  1.  K IENS,FDA,ERRS
  1.  S IENS(1)=$O(^LR(LRDFN,"CH",LRIDT,1,"B"),-1)+1  ; Get next COMMENT line
  1.  S FDA(63.041,"+1,"_LRIDT_","_LRDFN_",",.01)=DEL2
  1.  D UPDATE^DIE(,"FDA","IENS","ERRS")
  1.  ; I $D(ERRS) D SHOWERRS^BLRADDCD("Lab Data File")
  1.  ; I $D(ERRS) D ERRMSG("File 63.041, Line 2 - DELACC: UPDATE^DIE")  Q
  1.  I $D(ERRS) D ERRMSG^BLRSGNS3("File 63.041, Line 2 - DELACC: UPDATE^DIE","BLRSGNSP")  Q   ; IHS/MSC/MKK - LR*5.2*1035
  1.  Q
  1.  ;
  1.  ; ----- Begin IHS/MSC/MKK - LR*5.2*1036
  1. ERRMSG(MSG,ERRFRTN) ; EP - Left in for other routines to call.
  1.  D ERRMSG^BLRSGNS3(MSG,ERRFRTN)
  1.  Q
  1.  ; ----- End IHS/MSC/MKK - LR*5.2*1036
  1.  ;
  1. MAKEMESG(LRODT,LRSN,LRI) ; EP - Create the cancel reason in 69 - some code cloned from LRHYDEL routine.
  1.  NEW II,ORIFN,LRMSTATI,LRNATURE,LRSTATUS
  1.  ;
  1.  S ORIFN=$P(^LRO(69,LRODT,1,LRSN,2,LRI,0),U,7)
  1.  S X=1+$O(^LRO(69,LRODT,1,LRSN,2,LRI,1.1,"A"),-1),X(1)=$P($G(^(0)),U,4)
  1.  S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,X,0)="OTHER CANCEL REASON: *NP Reason:User Quit During Clinical Indication Selection."
  1.  S X=X+1,X(1)=X(1)+1
  1.  S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,X,0)="*NP Action:"_$$HTE^XLFDT($H,"5MZ")
  1.  S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,0)="^^"_X_"^"_X(1)_"^"_DT
  1.  S $P(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",9)="CA",$P(^(0),U,10)="L",$P(^(0),U,11)=DUZ
  1.  S:$D(^LRO(69,LRODT,1,LRSN,"PCE")) ^LRO(69,"AE",DUZ,LRODT,LRSN,LRI)=""
  1.  Q
  1.  ;
  1.  W @IOF N LRCANK,LRTN
  1.  S BLROPT="DELORD",BLROPT(0)=$P($G(XQY0),U)
  1. FIND ; EP
  1.  S LREND=0 D ^LRPARAM I $G(LREND) G END
  1.  K LRDFN,LRONE,LRNATURE
  1.  W !?3,"If lab has received the sample (i.e. the test has an accession),",!,?3,"you can't change this order.  If so, use the REMOVE AN ACCESSION option",!,?3,"to change the test."  ; IHS/OIT/MKK - LR*5.2*1033
  1.  D
  1.  . N DIR
  1.  . S DIR("A")="ENTER ORDER NUMBER: "
  1.  . S DIR(0)="LO^1:9999999999"
  1.  . S DIR("?")="Enter the number associated with the order. "
  1.  . S DIR("??")="^D ^LROS"
  1.  . S DIR("S")="I $O(^LRO(69,""C"",X,0))"
  1.  . S DIR("T")=1800      ; IHS/MSC/MKK - LR*5.2*1035
  1.  . D ^DIR
  1.  G END:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT))
  1.  S LRORD=X
  1.  W @IOF D LOOK G FIND
  1.  Q
  1.  ;
  1. LOOK ; EP
  1.  S LRCNT=0,LRODT=$O(^LRO(69,"C",LRORD,0)) I LRODT<1 W !,"Not found." Q
  1.  S (LRCANK,LROV,LRSN,LRCOL)=0
  1.  F  S LRSN=$O(^LRO(69,"C",+LRORD,LRODT,LRSN)) Q:LRSN<1!($G(LREND))  D:'$G(LREND) SHOW^LROS S LRCNT=1 S:$S($D(^LRO(69,LRODT,1,LRSN,3)):$P(^(3),U,2),1:0) LROV=1 D
  1.  . L +^LRO(69,"C",+LRORD):1 I '$T W !?5,"Someone Else is Editing this order, try later",! S LREND=1 Q
  1.  . S LRTN=0 F  S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:LRTN<1  S X=^(LRTN,0) I '$P(X,"^",11) S LRCANK=1 Q
  1.  I $G(LREND) D UNL69,END Q
  1.  I LRCNT<1 W !,"No order found with that number." D UNL69,END Q
  1.  I 'LRCANK W !!,"[ * All tests on this order # have already been dispositoned. * ]" D NAME Q
  1.  I $G(LRCOL) D  D UNL69,END Q
  1.  . W !!?5," You CAN NOT change the status of test(s) on this order."
  1.  . W !,"Test sample(s) have already been received into the laboratory."
  1.  . W !,"You must use the REMOVE AN ACCESSION option to have the test(s) status changed.",$C(7)
  1.  D NAME
  1.  S LRNOP=0  S %=1  ; I 'LROV F I=0:0 W !,"Change entire order" S %=2 D YN^DICN Q:%  W "Answer 'Y'es or 'N'o."
  1.  I 'LROV G END:%=-1,OUT:%=1
  1.  S LRT=0,J=0 F  S J=$O(LRT(J)) Q:J<1  S LRT=J
  1.  I LRT<1 W !,$$CJ^XLFSTR(" Can't change status of test(s) on this order.",IOM),! D UNL69 Q
  1. MORE ; EP
  1.  W !,?8,"entry",?15,"test",?40,"sample"
  1.  S LRT=0,J=0 F  S J=$O(LRT(J)) Q:J<1  S LRT=J W !,?10,J,?15,$P(^LAB(60,$P(LRT(J),U,3),0),U),?40,$P(LRT(J),U,4)
  1.  I LRT=0 W !,"All have been dispositioned from that order."
  1.  Q
  1.  ;
  1. ONE ; EP
  1.  R !,"Change status of which entry: ",LRJ:DTIME W:LRJ["?" !,"Pick one of the following entries:" G MORE:LRJ["?" Q:LRJ["^"!(LRJ="")
  1.  I LRJ'=+LRJ!(LRJ<1)!(LRJ>LRT) W !,"Enter a number between 1 and ",LRT,! G ONE
  1.  I '$D(LRT(LRJ)) W !,"You've already dispositioned that one.",! G MORE
  1.  K LRNATURE
  1.  D FX2^LRTSTOUT I $G(LREND) D UNL69,END Q
  1.  K LRTSTI,LRMSTATI D EN1,UNL69 G LOOK
  1.  Q
  1.  ;
  1. EN1 ; EP
  1.  I '$D(^LRO(69,LRODT,1,LRSN,2,LRTSTI,0))#2 W !,"Does not exist ",! Q
  1.  S LRX=^LRO(69,LRODT,1,LRSN,2,LRTSTI,0),LRAD=+$P(LRX,U,3),LRAA=+$P(LRX,U,4),LRAN=+$P(LRX,U,5),LRNOP=0,LRONE="",LRACC=0,ORIFN=$P(LRX,U,7)
  1.  S LRSS=$P($G(^LRO(68,LRAA,0)),U,2)
  1.  S LRTNM=$P($G(^LAB(60,LRTSTS,0)),U)
  1.  I '$L($G(LRNATURE)) D DC^LROR6() I $G(LRNATURE)=-1 W !!,$C(7),"NOTHING CHANGED" Q
  1.  S LRIDT=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
  1.  I LRIDT L +^LR(LRDFN,LRSS,LRIDT):1 I '$T W !?5,"Someone else is editing this entry",! S LREND=1 Q
  1.  D SET^LRTSTOUT I LRIDT L -^LR(LRDFN,LRSS,LRIDT)
  1.  D UNL69
  1.  Q
  1.  ;
  1.  D CEN1^LRCENDE1 K LRONE Q:LRACC&'$D(^XUSEC("LRLAB",DUZ))
  1.  I LRTSTI,'$G(LRNOP) D
  1.  . N LRI S LRI(LRTSN)=""
  1.  . D NEW^LR7OB1(LRODT,LRSN,$S($G(LRMSTATI)=""!($G(LRMSTATI)=1):"OC",1:"SC"),$G(LRNATURE),.LRI,$G(LRMSTATI))
  1.  . S $P(^LRO(69,LRODT,1,LRSN,2,LRTSTI,0),"^",3,6)="^^^",$P(^(0),"^",9,11)="CA^L^"_DUZ K T(LRJ)
  1.  . S DIE="^LRO(69,LRODT,1,LRSN,2,",DA=LRTSTI,DA(1)=LRODT,DR=99 D ^DIE
  1.  K LRI
  1.  S X=DUZ D DUZ^LRX
  1.  W:'LRNOP !!,"Status changed to Not Performed" G FIND:$O(LRT(0))<1,ONE
  1.  ;
  1. OUT ; EP
  1.  Q:$G(LRNOP)  S LRJ=0
  1.  D FX2^LRTSTOUT I $G(LREND) D UNL69,END Q
  1.  S LRCCOMX=LRCCOM
  1.  S LRJ=0 F  S LRJ=$O(LRT(LRJ)) Q:LRJ<1  S LRCCOM=LRCCOMX D
  1.  . S LRSN=0
  1.  . F  S LRSN=$O(^LRO(69,"C",LRORD,LRODT,LRSN))  Q:LRSN<1  D
  1.  .. S LRTSTI=0
  1.  .. F  S LRTSTI=$O(^LRO(69,LRODT,1,LRSN,2,LRTSTI))  Q:LRTSTI<1  D
  1.  ... S IENS=LRTSTI_","_LRSN_","_LRODT_","
  1.  ;
  1.  K LRCCOMX D UNL69
  1.  Q
  1.  ;
  1.  S LRSN=0 F  S LRSN=$O(^LRO(69,"C",+LRORD,LRODT,LRSN)) Q:LRSN<1  D
  1.  . S LRX=^LRO(69,LRODT,1,LRSN,2,LRTSTI,0),LRAD=$P(LRX,U,3),LRAA=+$P(LRX,U,4),LRAN=+$P(LRX,U,5),LRNOP=0,LRONE="",LRACC=0,ORIFN=$P(LRX,U,7)
  1.  ;
  1. ALLDEL ; EP
  1.  K LRNATURE G FIND
  1.  ;
  1. % ; EP
  1.  K DIR,X,Y,%
  1.  S DIR(0)="YO"
  1.  S DIR("T")=1800   ; IHS/MSC/MKK - LR*5.2*1035
  1.  D ^DIR
  1.  S %=$E(X)
  1.  Q
  1.  ;
  1. UNL69 ;
  1.  L -^LRO(69,"C",+LRORD)
  1.  Q
  1.  ;
  1. NAME ; EP 
  1.  S LRDFN=+^LRO(69,LRODT,1,$O(^LRO(69,"C",+LRORD,LRODT,0)),0),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
  1.  D PT^LRX W !,PNM,?30,HRCN
  1.  ;
  1. EN ;from LRPHITE3
  1.  K LRT S (J,LRSN,LRNOP)=0 F  S LRSN=$O(^LRO(69,"C",+LRORD,LRODT,LRSN)) Q:LRSN<1!($G(LRNOP))  D TSET
  1.  Q
  1.  ;
  1. TSET ; EP
  1.  I $D(^LRO(69,LRODT,1,LRSN,3)),$P(^(3),"^",2) D  Q
  1.  . W !,$$CJ^XLFSTR("Test(s) already verified for this order, cannot change ENTIRE order",IOM)
  1.  . W !,$$CJ^XLFSTR(" You must select individual test using the 'Delete Test from Accession' option.",IOM),!!
  1.  . D UNL69 S LRNOP=1
  1.  ;
  1.  S I=0 F  S I=$O(^LRO(69,LRODT,1,LRSN,2,I)) Q:I<1  S X=^(I,0) D
  1.  . Q:$P(X,"^",11)
  1.  . I $P(X,U,3),'$D(LRLABKY) Q
  1.  . S J=J+1,LRSPEC=$S($D(^LRO(69,LRODT,1,LRSN,4,1,0)):+^(0),1:""),LRT(J)=LRSN_U_I_U_+X_U_$S(LRSPEC:$P(^LAB(61,+LRSPEC,0),U),1:"")_U_$P(X,U,2,99)
  1.  Q
  1.  ;
  1. END ; EP
  1.  K %,A,AGE,DFN,DIC,DIE,DOB,DQ,DR,DWLW,HRCN,I,J,K,LRAA,LRACC,LRACN,LRACN0,LRAD,LRAN,LRCL,LRCNT,LRCOL
  1.  K LRDOC,LRDPF,LRDTM,LREND,LRIDT,LRJ,LRNOW,LRLL,LRLLOC,LRNATURE,LRNOP,LROD0,LROD1,LROD3,LRODT
  1.  K LROOS,LRORD,LROS,LROSD,LROT,LROV,LRROD,LRSCNXB,LRSN,LRSPEC,LRSS,LRTC,LRTP,LRTSTI,LRTSTS,LRT,LRTT
  1.  K LRURG,LRUSI,LRUSNM,LRWRD,LRCANK,LRTN,LRCCOM,LRCCOM1
  1.  K PNM,SEX,SSN,T,X,X1,X2,X3,X4,Y,Z,ORIFN
  1.  D END^LRTSTOUT
  1.  Q