LRU ;DALOI/STAFF - LAB UTILITY ;05/11/10 15:14
;;5.2;LAB SERVICE;**1,72,201,248,350,422**;Sep 27, 1994;Build 29
;
;Reference to ^DIC(4 supported by IA #10090
;Reference to ^XMB(1 supported by IA #10091
;Reference to ^VA(200 supported by IA #10060
;Reference to ^%DT supported by IA #10003
;Reference to ^%ZIS supported by IA #10086
;Reference to ^DIC supported by IA #10006
;Reference to ^DIE supported by IA #10018
;Reference to PID^VADPT6 supported by IA #10062
;Reference to $$FMTE^XLFDT supported by IA #10103
;
S X="T",%DT="" D ^%DT,D S H(10)=Y
Q
;
;
LOCK ;Set and kill lock for ^DIE call. If lock fails LR("CK")=1 is set.
N LRLOKVAR
I '$D(DIE) S LR("CK")=1 Q
D CK I '$G(LR("CK")) D ^DIE K LR("CK") D FRE
Q
;
;
CK ;
D:$D(LRLOKVAR)#2 FRE
S LRLOKVAR=DIE_DA_")" L +@(LRLOKVAR):DILOCKTM
I '$T D
. W !,$C(7),"ANOTHER TERMINAL IS EDITING THIS ENTRY!" S LR("CK")=1
. K LRLOKVAR
Q
;
;
FRE I $D(LRLOKVAR) L -@(LRLOKVAR) K LRLOKVAR
Q
;
F ;
S LRQ=LRQ+1,X="N",%DT="T" D ^%DT,D^LRU
;Suppress unnecessary form feeds
I $G(LRSS)'="BB" W:IOST?1"C".E!($D(LR("F"))) @IOF
W:$G(LRSS)="BB" @IOF
W !,Y,?22,LRQ(1),?(IOM-10),"Pg: ",LRQ
Q
;
;
M R !,"'^' TO STOP: ",X:DTIME S:'$T!(X["^") LR("Q")=1
W $C(13),$J("",15),$C(13)
Q
;
;
T ; Returns the Month/Day
Q:'Y S Y=Y_"000",Y=$E(Y,4,5)_"/"_$E(Y,6,7)_$S(Y[".":" "_$E(Y,9,10)_":"_$E(Y,11,12),1:"")
Q
;
;
A ; Returns Date in format mm/dd/yyyy with time if a time is passed.
Q:'Y S Y=$$FMTE^XLFDT(Y,"5M")
I $L($P(Y,"/"))=1 S $P(Y,"/")="0"_$P(Y,"/") ;--> pad for 2 digit day
I $L($P(Y,"/",2))=1 S $P(Y,"/",2)="0"_$P(Y,"/",2) ;--> pad for 2 digit month
Q
;
;
D ; Returns date in eye-readable month format
S Y=$TR($$FMTE^XLFDT(Y,"M"),"@"," ")
Q
;
;
DA ; Returns date in eye-readable month format
S Y=$$FMTE^XLFDT(Y,"M")
Q
;
;
DT ; If Blood Bank maintain existing display, else display 4 digit year.
I $G(LRSS)="BB" S Y=Y_"000",Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_" "_$S(Y[".":$E(Y,9,10)_":"_$E(Y,11,12),1:"") Q
D A
Q
;
;
SSN ;
S (SSN,SSN(1),SSN(2))=$G(SSN)
I '$G(LRDPF),$G(LRDFN) S:$P($G(^LR(+LRDFN,0)),U,2) LRDPF=+$P(^(0),U,2)
S (VA("BID"),VA("PID"))="" G:'$G(LRDPF)!(+$G(LRDPF)'=2) SSNFM
N I,X,Y,N
I $D(DFN) D PID^VADPT6 S (SSN,SSN(2))=VA("PID"),SSN(1)=VA("BID")
;
SSNFM ;
S SSN(2)=$TR(SSN,"-","")
;I $G(DUZ("AG"))'="","NAFARMY"[DUZ("AG") D Q
;. S SSN=$S($L(SSN)<11:$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10),1:$E(SSN,10,11)_"/"_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9))
;. S SSN(1)=$S($P(SSN,"-",3):$P(SSN,"-",3),1:$E(SSN,9,12))
;
; Setup identifier for PATIENT (#2) file related entry
I $G(LRDPF)=2,$G(DFN)="" D
. S:$L(SSN)>8 SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,99)
. S SSN(1)=$S($P(SSN,"-",3):$P(SSN,"-",3),$L($E(SSN,($L(SSN)-3),$L(SSN))):$E(SSN,($L(SSN)-3),$L(SSN)),1:"????")
. S:'$L(SSN) SSN="?"
;
; Setup identifier for non-PATIENT (#2) file related entry
I $G(LRDPF)'=2 D
. I SSN?9N.1A S SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,99)
. S SSN(1)=$S($P(SSN,"-",3):$P(SSN,"-",3),$L($E(SSN,($L(SSN)-3),$L(SSN))):$E(SSN,($L(SSN)-3),$L(SSN)),1:"????")
;
I SSN="" S SSN="?"
;
Q
;
;
B D LRU S %DT="AEX",%DT(0)="-N",%DT("A")="Start with Date TODAY// " D ^%DT K %DT I X="" S Y=DT W H(10)
Q:Y<1 S LRSDT=Y
S %DT="AEX",%DT("A")="Go to Date TODAY// " D ^%DT K %DT I X="" S Y=DT W H(10)
Q:Y<1 S LRLDT=Y I LRSDT>LRLDT S X=LRSDT,LRSDT=LRLDT,LRLDT=X
S Y=LRSDT D D^LRU S LRSTR=Y,Y=LRLDT D D^LRU S LRLST=Y
Q
;
;
YN W "? ",$P("YES// ^NO// ","^",%) S LR("%1")=%
RX R %Y:$S($D(DTIME):DTIME,1:99999) E S DTOUT=1,%Y="^" W $C(7)
S:%Y]""!'% %=$A(%Y),%=$S(%=89:1,%=121:1,%=78:2,%=110:2,%=94:-1,1:0)
I %Y="@"!(%Y="S") S %=-1 Q
I '%,%Y]"" W $C(7),!?4,"ANSWER 'YES', 'NO', '^', '@'",!?4,"or press RETURN key to accept default response (if one)" S:$D(LR("%1")) %=LR("%1") W !! G YN
W:$X>73 ! W $P(" (YES)^ (NO)","^",%) K LR("%1")
Q
;
;
XR Q:'$D(LRSS) S LRXR="A"_LRSS,LRXREF=LRXR_"A"
Q
;
;
WAIT W !!,"..."
W $P("HMMM^EXCUSE ME ^SORRY","^",$R(3)+1),", ",$P("THIS MAY TAKE A WHILE^LET ME PUT YOU ON 'HOLD' ^HOLD ON^JUST A MOMENT PLEASE^I'M WORKING AS FAST AS I CAN^LET ME THINK ABOUT THAT ","^",$R(6)+1)_"..."
H 1
Q
;
;
K K A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
Q
;
;
V ; Cleanup variables
;
; Task background job to create messages
I $D(^LAHM(62.49,"AC")) D
. N ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTDESC,ZTSK
. S ZTIO="",ZTRTN="ORU^LA7VMSG",ZTDTH=$H,ZTDESC="Send Lab LEDI HL7 Result Message to collecting site"
. D ^%ZTLOAD
;
D K
K %,%DT,%X,%Y,A,AGE,DO,D1,DA,DE,DFN,DG,DI,DIC,DIE,DIR,DIRUT
K DIWF,DIWL,DLAYGO,DOB,DR,DTOUT,DX,LR,LRA,LRAA,LRABO,LRABV
K LRAC,LRAD,LRADM,LRADX,LRAN,LRAP,LRAPX,LRAU,LRAWRD,LRAX,LRB,LRBL
K LRBLT,LRC,LRCAP,LRCAPA,LRCAPLOC,LRCPT,LRCS,LRD,LRDATA
K LRDATE,LRDFN,LRDPAF,LRDPF,LRDTI,LRE,LREND,LREP,LREXP
K LRF,LRFLN,LRFNAM,LRFND,LRG,LRH,LRI,LRIDT,LRIFN,LRJ
K LRK,LRL,LRLDT,LRLIDT,LRLLOC,LRLOKVAR,LRLST,LRM
K LRMD,LRN,LRND,LRNO,LRNOP,LRO,LRODT,LROLLOC,LROPT,LRORU3
K LRP,LRPABO,LRPF,LRPFN,LRPMOD,LRPNM,LRPPT,LRPRAC
K LRPRH,LRPTF,LRQ,LRQA,LRR,LRRB,LRRC,LRRMD,LRS,LRSA,LRSAV
K LRSD,LRSDT,LRSEL,LRSET,LRSF,LRSIT,LRSN,LRSOP,LRSS,LRST
K LRSTR,LRSVC,LRT,LRTK,LRTOD,LRTREA,LRTS,LRU,LRV,LRW
K LRWARD,LRWD,LRWHN,LRWHO,LRWRD,LRWW,LRX,LRXR,LRXREF
K LRY,LRZ,PNM,POP,SEX,SSN,VA,VADM,VAIN
K ZTDESC,ZTDTH,ZTIO,ZTREQ,ZTRTN,ZTSAVE,ZTSK
K ^UTILITY($J),^TMP($J),^TMP("LRBL",$J),^TMP("LR",$J)
K LRICDT,LRCDSYS,ICDSYS,ICDFMT,LRDXV
Q
;
;
LRAD ;
S X=$P(^LRO(68,LRAA,0),"^",3),(Y,LRAD)=$S(X="Y":$E(Y,1,3)_"0000","M"[X:$E(Y,1,5)_"00","Q"[X:$E(Y,1,3)_"0000"+(($E(Y,4,5)-1)\3*300+100),1:Y)
D D^LRU S LRH(0)=Y
Q
;
;
H W !,$C(7),"TO SORT IN SEQUENCE, STARTING FROM A CERTAIN NAME,",!?7,"TYPE THAT NAME"
Q
;
;
H1 W !,$C(7),"TO SORT ONLY UP TO A CERTAIN NAME,",!?7,"TYPE THAT NAME"
Q
;
;
L ;
D:'$D(IOM) I
K LR("%")
S LR("%")="-",$P(LR("%"),"-",IOM-1)="-"
Q
;
;
L1 ;
D:'$D(IOM) I
K LR("%1")
S LR("%1")="=",$P(LR("%1"),"=",IOM-1)="="
Q
;
;
I ;
S IOP="HOME" D ^%ZIS
Q
;
;
S S (LR("Q"),LRQ)=0,LRQ(1)=$$INS
Q
;
;
INS() ;Set institution Name from ^XMB
N Y
S Y=$P($G(^DIC(4,+$P($G(^XMB(1,1,"XUS")),U,17),0)),U)
Q Y
;
;
INSN() ;Set primary institution number from ^XMB
N Y
S Y=+$P($G(^XMB(1,1,"XUS")),U,17)
Q Y
;
;
DUZ2 ;Allow user to change Division [DUZ(2)] value
N A
S A(1)="*** THIS OPTION IS NO LONGER AVAILABLE ***",A(1,"F")="!?18"
S A(2)="Use Kernel option 'Change my Division' [XUSER DIV CHG]",A(2,"F")="!?18"
D EN^DDIOL(.A)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRU 6663 printed Oct 16, 2024@18:21:57 Page 2
LRU ;DALOI/STAFF - LAB UTILITY ;05/11/10 15:14
+1 ;;5.2;LAB SERVICE;**1,72,201,248,350,422**;Sep 27, 1994;Build 29
+2 ;
+3 ;Reference to ^DIC(4 supported by IA #10090
+4 ;Reference to ^XMB(1 supported by IA #10091
+5 ;Reference to ^VA(200 supported by IA #10060
+6 ;Reference to ^%DT supported by IA #10003
+7 ;Reference to ^%ZIS supported by IA #10086
+8 ;Reference to ^DIC supported by IA #10006
+9 ;Reference to ^DIE supported by IA #10018
+10 ;Reference to PID^VADPT6 supported by IA #10062
+11 ;Reference to $$FMTE^XLFDT supported by IA #10103
+12 ;
+13 SET X="T"
SET %DT=""
DO ^%DT
DO D
SET H(10)=Y
+14 QUIT
+15 ;
+16 ;
LOCK ;Set and kill lock for ^DIE call. If lock fails LR("CK")=1 is set.
+1 NEW LRLOKVAR
+2 IF '$DATA(DIE)
SET LR("CK")=1
QUIT
+3 DO CK
IF '$GET(LR("CK"))
DO ^DIE
KILL LR("CK")
DO FRE
+4 QUIT
+5 ;
+6 ;
CK ;
+1 if $DATA(LRLOKVAR)#2
DO FRE
+2 SET LRLOKVAR=DIE_DA_")"
LOCK +@(LRLOKVAR):DILOCKTM
+3 IF '$TEST
Begin DoDot:1
+4 WRITE !,$CHAR(7),"ANOTHER TERMINAL IS EDITING THIS ENTRY!"
SET LR("CK")=1
+5 KILL LRLOKVAR
End DoDot:1
+6 QUIT
+7 ;
+8 ;
FRE IF $DATA(LRLOKVAR)
LOCK -@(LRLOKVAR)
KILL LRLOKVAR
+1 QUIT
+2 ;
F ;
+1 SET LRQ=LRQ+1
SET X="N"
SET %DT="T"
DO ^%DT
DO D^LRU
+2 ;Suppress unnecessary form feeds
+3 IF $GET(LRSS)'="BB"
if IOST?1"C".E!($DATA(LR("F")))
WRITE @IOF
+4 if $GET(LRSS)="BB"
WRITE @IOF
+5 WRITE !,Y,?22,LRQ(1),?(IOM-10),"Pg: ",LRQ
+6 QUIT
+7 ;
+8 ;
M READ !,"'^' TO STOP: ",X:DTIME
if '$TEST!(X["^")
SET LR("Q")=1
+1 WRITE $CHAR(13),$JUSTIFY("",15),$CHAR(13)
+2 QUIT
+3 ;
+4 ;
T ; Returns the Month/Day
+1 if 'Y
QUIT
SET Y=Y_"000"
SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_$SELECT(Y[".":" "_$EXTRACT(Y,9,10)_":"_$EXTRACT(Y,11,12),1:"")
+2 QUIT
+3 ;
+4 ;
A ; Returns Date in format mm/dd/yyyy with time if a time is passed.
+1 if 'Y
QUIT
SET Y=$$FMTE^XLFDT(Y,"5M")
+2 ;--> pad for 2 digit day
IF $LENGTH($PIECE(Y,"/"))=1
SET $PIECE(Y,"/")="0"_$PIECE(Y,"/")
+3 ;--> pad for 2 digit month
IF $LENGTH($PIECE(Y,"/",2))=1
SET $PIECE(Y,"/",2)="0"_$PIECE(Y,"/",2)
+4 QUIT
+5 ;
+6 ;
D ; Returns date in eye-readable month format
+1 SET Y=$TRANSLATE($$FMTE^XLFDT(Y,"M"),"@"," ")
+2 QUIT
+3 ;
+4 ;
DA ; Returns date in eye-readable month format
+1 SET Y=$$FMTE^XLFDT(Y,"M")
+2 QUIT
+3 ;
+4 ;
DT ; If Blood Bank maintain existing display, else display 4 digit year.
+1 IF $GET(LRSS)="BB"
SET Y=Y_"000"
SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_" "_$SELECT(Y[".":$EXTRACT(Y,9,10)_":"_$EXTRACT(Y,11,12),1:"")
QUIT
+2 DO A
+3 QUIT
+4 ;
+5 ;
SSN ;
+1 SET (SSN,SSN(1),SSN(2))=$GET(SSN)
+2 IF '$GET(LRDPF)
IF $GET(LRDFN)
if $PIECE($GET(^LR(+LRDFN,0)),U,2)
SET LRDPF=+$PIECE(^(0),U,2)
+3 SET (VA("BID"),VA("PID"))=""
if '$GET(LRDPF)!(+$GET(LRDPF)'=2)
GOTO SSNFM
+4 NEW I,X,Y,N
+5 IF $DATA(DFN)
DO PID^VADPT6
SET (SSN,SSN(2))=VA("PID")
SET SSN(1)=VA("BID")
+6 ;
SSNFM ;
+1 SET SSN(2)=$TRANSLATE(SSN,"-","")
+2 ;I $G(DUZ("AG"))'="","NAFARMY"[DUZ("AG") D Q
+3 ;. S SSN=$S($L(SSN)<11:$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10),1:$E(SSN,10,11)_"/"_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9))
+4 ;. S SSN(1)=$S($P(SSN,"-",3):$P(SSN,"-",3),1:$E(SSN,9,12))
+5 ;
+6 ; Setup identifier for PATIENT (#2) file related entry
+7 IF $GET(LRDPF)=2
IF $GET(DFN)=""
Begin DoDot:1
+8 if $LENGTH(SSN)>8
SET SSN=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,99)
+9 SET SSN(1)=$SELECT($PIECE(SSN,"-",3):$PIECE(SSN,"-",3),$LENGTH($EXTRACT(SSN,($LENGTH(SSN)-3),$LENGTH(SSN))):$EXTRACT(SSN,($LENGTH(SSN)-3),$LENGTH(SSN)),1:"????")
+10 if '$LENGTH(SSN)
SET SSN="?"
End DoDot:1
+11 ;
+12 ; Setup identifier for non-PATIENT (#2) file related entry
+13 IF $GET(LRDPF)'=2
Begin DoDot:1
+14 IF SSN?9N.1A
SET SSN=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,99)
+15 SET SSN(1)=$SELECT($PIECE(SSN,"-",3):$PIECE(SSN,"-",3),$LENGTH($EXTRACT(SSN,($LENGTH(SSN)-3),$LENGTH(SSN))):$EXTRACT(SSN,($LENGTH(SSN)-3),$LENGTH(SSN)),1:"????")
End DoDot:1
+16 ;
+17 IF SSN=""
SET SSN="?"
+18 ;
+19 QUIT
+20 ;
+21 ;
B DO LRU
SET %DT="AEX"
SET %DT(0)="-N"
SET %DT("A")="Start with Date TODAY// "
DO ^%DT
KILL %DT
IF X=""
SET Y=DT
WRITE H(10)
+1 if Y<1
QUIT
SET LRSDT=Y
+2 SET %DT="AEX"
SET %DT("A")="Go to Date TODAY// "
DO ^%DT
KILL %DT
IF X=""
SET Y=DT
WRITE H(10)
+3 if Y<1
QUIT
SET LRLDT=Y
IF LRSDT>LRLDT
SET X=LRSDT
SET LRSDT=LRLDT
SET LRLDT=X
+4 SET Y=LRSDT
DO D^LRU
SET LRSTR=Y
SET Y=LRLDT
DO D^LRU
SET LRLST=Y
+5 QUIT
+6 ;
+7 ;
YN WRITE "? ",$PIECE("YES// ^NO// ","^",%)
SET LR("%1")=%
RX READ %Y:$SELECT($DATA(DTIME):DTIME,1:99999)
IF '$TEST
SET DTOUT=1
SET %Y="^"
WRITE $CHAR(7)
+1 if %Y]""!'%
SET %=$ASCII(%Y)
SET %=$SELECT(%=89:1,%=121:1,%=78:2,%=110:2,%=94:-1,1:0)
+2 IF %Y="@"!(%Y="S")
SET %=-1
QUIT
+3 IF '%
IF %Y]""
WRITE $CHAR(7),!?4,"ANSWER 'YES', 'NO', '^', '@'",!?4,"or press RETURN key to accept default response (if one)"
if $DATA(LR("%1"))
SET %=LR("%1")
WRITE !!
GOTO YN
+4 if $X>73
WRITE !
WRITE $PIECE(" (YES)^ (NO)","^",%)
KILL LR("%1")
+5 QUIT
+6 ;
+7 ;
XR if '$DATA(LRSS)
QUIT
SET LRXR="A"_LRSS
SET LRXREF=LRXR_"A"
+1 QUIT
+2 ;
+3 ;
WAIT WRITE !!,"..."
+1 WRITE $PIECE("HMMM^EXCUSE ME ^SORRY","^",$RANDOM(3)+1),", ",$PIECE("THIS MAY TAKE A WHILE^LET ME PUT YOU ON 'HOLD' ^HOLD ON^JUST A MOMENT PLEASE^I'M WORKING AS FAST AS I CAN^LET ME THINK ABOUT THAT ","^",$RANDOM(6)+1)_"..."
+2 HANG 1
+3 QUIT
+4 ;
+5 ;
K KILL A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
+1 QUIT
+2 ;
+3 ;
V ; Cleanup variables
+1 ;
+2 ; Task background job to create messages
+3 IF $DATA(^LAHM(62.49,"AC"))
Begin DoDot:1
+4 NEW ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTDESC,ZTSK
+5 SET ZTIO=""
SET ZTRTN="ORU^LA7VMSG"
SET ZTDTH=$HOROLOG
SET ZTDESC="Send Lab LEDI HL7 Result Message to collecting site"
+6 DO ^%ZTLOAD
End DoDot:1
+7 ;
+8 DO K
+9 KILL %,%DT,%X,%Y,A,AGE,DO,D1,DA,DE,DFN,DG,DI,DIC,DIE,DIR,DIRUT
+10 KILL DIWF,DIWL,DLAYGO,DOB,DR,DTOUT,DX,LR,LRA,LRAA,LRABO,LRABV
+11 KILL LRAC,LRAD,LRADM,LRADX,LRAN,LRAP,LRAPX,LRAU,LRAWRD,LRAX,LRB,LRBL
+12 KILL LRBLT,LRC,LRCAP,LRCAPA,LRCAPLOC,LRCPT,LRCS,LRD,LRDATA
+13 KILL LRDATE,LRDFN,LRDPAF,LRDPF,LRDTI,LRE,LREND,LREP,LREXP
+14 KILL LRF,LRFLN,LRFNAM,LRFND,LRG,LRH,LRI,LRIDT,LRIFN,LRJ
+15 KILL LRK,LRL,LRLDT,LRLIDT,LRLLOC,LRLOKVAR,LRLST,LRM
+16 KILL LRMD,LRN,LRND,LRNO,LRNOP,LRO,LRODT,LROLLOC,LROPT,LRORU3
+17 KILL LRP,LRPABO,LRPF,LRPFN,LRPMOD,LRPNM,LRPPT,LRPRAC
+18 KILL LRPRH,LRPTF,LRQ,LRQA,LRR,LRRB,LRRC,LRRMD,LRS,LRSA,LRSAV
+19 KILL LRSD,LRSDT,LRSEL,LRSET,LRSF,LRSIT,LRSN,LRSOP,LRSS,LRST
+20 KILL LRSTR,LRSVC,LRT,LRTK,LRTOD,LRTREA,LRTS,LRU,LRV,LRW
+21 KILL LRWARD,LRWD,LRWHN,LRWHO,LRWRD,LRWW,LRX,LRXR,LRXREF
+22 KILL LRY,LRZ,PNM,POP,SEX,SSN,VA,VADM,VAIN
+23 KILL ZTDESC,ZTDTH,ZTIO,ZTREQ,ZTRTN,ZTSAVE,ZTSK
+24 KILL ^UTILITY($JOB),^TMP($JOB),^TMP("LRBL",$JOB),^TMP("LR",$JOB)
+25 KILL LRICDT,LRCDSYS,ICDSYS,ICDFMT,LRDXV
+26 QUIT
+27 ;
+28 ;
LRAD ;
+1 SET X=$PIECE(^LRO(68,LRAA,0),"^",3)
SET (Y,LRAD)=$SELECT(X="Y":$EXTRACT(Y,1,3)_"0000","M"[X:$EXTRACT(Y,1,5)_"00","Q"[X:$EXTRACT(Y,1,3)_"0000"+(($EXTRACT(Y,4,5)-1)\3*300+100),1:Y)
+2 DO D^LRU
SET LRH(0)=Y
+3 QUIT
+4 ;
+5 ;
H WRITE !,$CHAR(7),"TO SORT IN SEQUENCE, STARTING FROM A CERTAIN NAME,",!?7,"TYPE THAT NAME"
+1 QUIT
+2 ;
+3 ;
H1 WRITE !,$CHAR(7),"TO SORT ONLY UP TO A CERTAIN NAME,",!?7,"TYPE THAT NAME"
+1 QUIT
+2 ;
+3 ;
L ;
+1 if '$DATA(IOM)
DO I
+2 KILL LR("%")
+3 SET LR("%")="-"
SET $PIECE(LR("%"),"-",IOM-1)="-"
+4 QUIT
+5 ;
+6 ;
L1 ;
+1 if '$DATA(IOM)
DO I
+2 KILL LR("%1")
+3 SET LR("%1")="="
SET $PIECE(LR("%1"),"=",IOM-1)="="
+4 QUIT
+5 ;
+6 ;
I ;
+1 SET IOP="HOME"
DO ^%ZIS
+2 QUIT
+3 ;
+4 ;
S SET (LR("Q"),LRQ)=0
SET LRQ(1)=$$INS
+1 QUIT
+2 ;
+3 ;
INS() ;Set institution Name from ^XMB
+1 NEW Y
+2 SET Y=$PIECE($GET(^DIC(4,+$PIECE($GET(^XMB(1,1,"XUS")),U,17),0)),U)
+3 QUIT Y
+4 ;
+5 ;
INSN() ;Set primary institution number from ^XMB
+1 NEW Y
+2 SET Y=+$PIECE($GET(^XMB(1,1,"XUS")),U,17)
+3 QUIT Y
+4 ;
+5 ;
DUZ2 ;Allow user to change Division [DUZ(2)] value
+1 NEW A
+2 SET A(1)="*** THIS OPTION IS NO LONGER AVAILABLE ***"
SET A(1,"F")="!?18"
+3 SET A(2)="Use Kernel option 'Change my Division' [XUSER DIV CHG]"
SET A(2,"F")="!?18"
+4 DO EN^DDIOL(.A)
+5 QUIT
