LRU ;AVAMC/REG/WTY - LAB UTILITY; 9/25/00 [ 04/10/2003 10:10 AM ]
;;5.2T9;LR;**1002,1006,1009,1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**1,72,201,248**;Sep 27, 1994
;
;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):1
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
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
;POSSIBLY NOT NEEDED WITH NEW VA CODE ABOVE???
;W @IOF,!,Y,?22,LRQ(1),?(IOM-10),"Pg: ",LRQ Q ;IHS/DIR/FJE ADD THE IOF BACK IN
;----- END IHS MODIFICATIONS
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
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
S (HRCN,VA("BID"),VA("PID"))="" G:'$G(LRDPF)!(+$G(LRDPF)'=2) SSNFM ;IHS/ANMC/CLS 11/1/95
;----- END IHS MODIFICATIONS
N I,X,Y,N
;I $D(DFN) D PID^VADPT6
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
;I $D(DFN) D PID^BLRDPT6 ;IHS/OIRM TUC/MJL
I $D(DFN) D @$S($$ISPIMS^BLRUTIL:"PID^VADPT6",1:"PID^BLRDPT6")
;----- END IHS MODIFICATIONS
SSNFM S SSN(2)=SSN
I $L(DUZ("AG")),"NAFARMY"[DUZ("AG") 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)) Q
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="?" 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)
;----- BEGIN IHS MODIFICATIONS LR*5.2*!018
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) ;IHS/ANMC/CLS 11/1/95
;----- END IHS MODIFICATIONS
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)
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
S %DT="AEX",%DT("A")="Go back to Date TODAY// " D ^%DT K %DT I X="" S Y=DT W H(10) ;IHS/ANMC/CLS 11/1/95
;----- END IHS MODIFICATIONS
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 D K
K %,ZTRTN,LRWHO,AGE,DIC,DLAYGO,DIE,DR,DFN,LRSDT,LRLDT,LRSTR,LRLST,LRXR
K LRXREF,LRADM,LRADX,LRABV,LRAWRD,LRAX,LRAD,LRDPAF,LRFNAM,LRMD,LRPF
K LRPFN,LRSVC,LRID,LRAP,LRSAV,LREP,LRDTI,LRODT,LRSN,LRBL,LRCPT,%Y,%X
K LRFND,LRPPT,LRIDT,LRPMD,LR,LRA,LRB,LRC,LRD,LRE,LRF,LRG,LRH,LRI,LRJ
K LRK,LRL,LRM,LRN,LRO,LRP,LRQ,LRR,LRS,LRT,LRU,LRV,LRW,LRX,LRY,LRZ,ZTSK
K ZTRTN,ZTSAVE,ZTDESC,LRAU,LRFLN,LRLIDT,LRND,LRNO,LRST,LRTK,LRWW,LRAC
K DIWL,DIWR,DIWF,LRCAP,LRCAPA,LRCAPLOC,LRPRAC,LRRMD,^UTILITY($J)
K ^TMP($J),^TMP("LRBL",$J),DIWF,D0,LRDFN,LRSF,DQ,LR,LRAN,DA,DX,DOB,SEX
K LRAA,LRSOP,LROPT,LRRH,SSN,LRLLOC,LRDPF,LREND,LREXP,LRTOD,LRABO
K LRPABO,LRPRH,LRSS,PNM,DE,DG,DA,LRCS,LRRC,LRSIT,LRWHN,POP,LRSA,LRIFN
K LRBLT,LRQA,DIR,DIRUT,LRSD,LRPTF,LRADM,LRWARD,LRTS,LRDATE,LROLLOC,VA
K VAIN,VADM,D1,DI,LRWD,LRRB,LRTREA,LRWRD,LRLOKVAR,LRAPX,LRSET,LRNOP
K ^TMP("LR",$J),ZTREQ
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
K HCRN ;IHS/ANMC/CLS 11/1/95 HRCN
;----- END IHS MODIFICATIONS
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 $P(LR("%"),"-",IOM-1)="-" Q
L1 D:'$D(IOM) I K LR("%1") S $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 Y,X,DIC,I
I '$D(^VA(200,+$G(DUZ),0))#2 W !,"You are not a valid user.",!!,$C(7) Q
I $S('$G(DUZ(2)):1,'$D(^DIC(4,DUZ(2),0))#2:1,1:0) D Q
. W !?5,"You do not currently have a valid Division assigned.",!,"Log off the system and try again.",!!,$C(7)
S X=0 F S X=$O(^VA(200,DUZ,2,X)) Q:X<1 S I=$G(I)+1
I $G(I)'>1 W !,"You have only one Division Defined in the New Person file, change not possible.",!! Q
K DIC S DIC="^VA(200,DUZ,2,",DIC(0)="AEMNQ"
S DIC("S")="I $G(^DIC(4,+Y,99))"
D ^DIC K DIC,DIC("S")
I Y'>0 D Q
.W !,$C(7),"Division Unchanged - Currently you are assigned to "
.W $P($G(^DIC(4,DUZ(2),99)),U)_" "_$P($G(^DIC(4,DUZ(2),0)),U),!
S DUZ(2)=+Y W !?5,"Division is now set to [ ",$P($G(^DIC(4,DUZ(2),99)),U)_" "_$P($G(^DIC(4,DUZ(2),0)),U)," ]",! Q
LRU ;AVAMC/REG/WTY - LAB UTILITY; 9/25/00 [ 04/10/2003 10:10 AM ]
+1 ;;5.2T9;LR;**1002,1006,1009,1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**1,72,201,248**;Sep 27, 1994
+3 ;
+4 ;Reference to ^DIC(4 supported by IA #10090
+5 ;Reference to ^XMB(1 supported by IA #10091
+6 ;Reference to ^VA(200 supported by IA #10060
+7 ;Reference to ^%DT supported by IA #10003
+8 ;Reference to ^%ZIS supported by IA #10086
+9 ;Reference to ^DIC supported by IA #10006
+10 ;Reference to ^DIE supported by IA #10018
+11 ;Reference to PID^VADPT6 supported by IA #10062
+12 ;Reference to $$FMTE^XLFDT supported by IA #10103
+13 ;
+14 SET X="T"
SET %DT=""
DO ^%DT
DO D
SET H(10)=Y
QUIT
+15 ;
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
CK IF $DATA(LRLOKVAR)#2
DO FRE
SET LRLOKVAR=DIE_DA_")"
LOCK +@(LRLOKVAR):1
+1 IF '$TEST
Begin DoDot:1
+2 WRITE !,$CHAR(7),"ANOTHER TERMINAL IS EDITING THIS ENTRY!"
SET LR("CK")=1
+3 KILL LRLOKVAR
End DoDot:1
+4 QUIT
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 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+7 ;POSSIBLY NOT NEEDED WITH NEW VA CODE ABOVE???
+8 ;W @IOF,!,Y,?22,LRQ(1),?(IOM-10),"Pg: ",LRQ Q ;IHS/DIR/FJE ADD THE IOF BACK IN
+9 ;----- END IHS MODIFICATIONS
+10 QUIT
M READ !,"'^' TO STOP: ",X:DTIME
IF '$TEST!(X["^")
SET LR("Q")=1
WRITE $CHAR(13),$JUSTIFY("",15),$CHAR(13)
QUIT
+1 ;
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
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 ;
D ; Returns date in eye-readable month format
+1 SET Y=$TRANSLATE($$FMTE^XLFDT(Y,"M"),"@"," ")
+2 QUIT
DA ; Returns date in eye-readable month format
+1 SET Y=$$FMTE^XLFDT(Y,"M")
+2 QUIT
+3 ;
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
QUIT
+3 ;
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 ;S (VA("BID"),VA("PID"))="" G:'$G(LRDPF)!(+$G(LRDPF)'=2) SSNFM
+4 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+5 ;IHS/ANMC/CLS 11/1/95
SET (HRCN,VA("BID"),VA("PID"))=""
IF '$GET(LRDPF)!(+$GET(LRDPF)'=2)
GOTO SSNFM
+6 ;----- END IHS MODIFICATIONS
+7 NEW I,X,Y,N
+8 ;I $D(DFN) D PID^VADPT6
+9 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+10 ;I $D(DFN) D PID^BLRDPT6 ;IHS/OIRM TUC/MJL
+11 IF $DATA(DFN)
DO @$SELECT($$ISPIMS^BLRUTIL:"PID^VADPT6",1:"PID^BLRDPT6")
+12 ;----- END IHS MODIFICATIONS
SSNFM SET SSN(2)=SSN
+1 IF $LENGTH(DUZ("AG"))
IF "NAFARMY"[DUZ("AG")
SET SSN=$SELECT($LENGTH(SSN)<11:$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,10),1:$EXTRACT(SSN,10,11)_"/"_$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9))
SET SSN(1)=$SELECT($PIECE(SSN,"-",3):$PIECE(SSN,"-",3),1:$EXTRACT(SSN,9,12))
QUIT
+2 IF $LENGTH(SSN)>8
SET SSN=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,99)
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:"????")
IF '$LENGTH(SSN)
SET SSN="?"
QUIT
+3 ;
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)
+1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*!018
+2 ;IHS/ANMC/CLS 11/1/95
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)
+3 ;----- END IHS MODIFICATIONS
+4 IF Y<1
QUIT
SET LRSDT=Y
+5 ;S %DT="AEX",%DT("A")="Go to Date TODAY// " D ^%DT K %DT I X="" S Y=DT W H(10)
+6 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+7 ;IHS/ANMC/CLS 11/1/95
SET %DT="AEX"
SET %DT("A")="Go back to Date TODAY// "
DO ^%DT
KILL %DT
IF X=""
SET Y=DT
WRITE H(10)
+8 ;----- END IHS MODIFICATIONS
+9 IF Y<1
QUIT
SET LRLDT=Y
IF LRSDT>LRLDT
SET X=LRSDT
SET LRSDT=LRLDT
SET LRLDT=X
+10 SET Y=LRSDT
DO D^LRU
SET LRSTR=Y
SET Y=LRLDT
DO D^LRU
SET LRLST=Y
QUIT
+11 ;
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")
QUIT
+5 ;
XR IF '$DATA(LRSS)
QUIT
SET LRXR="A"_LRSS
SET LRXREF=LRXR_"A"
QUIT
+1 ;
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
QUIT
+3 ;
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
QUIT
+1 ;
V DO K
+1 KILL %,ZTRTN,LRWHO,AGE,DIC,DLAYGO,DIE,DR,DFN,LRSDT,LRLDT,LRSTR,LRLST,LRXR
+2 KILL LRXREF,LRADM,LRADX,LRABV,LRAWRD,LRAX,LRAD,LRDPAF,LRFNAM,LRMD,LRPF
+3 KILL LRPFN,LRSVC,LRID,LRAP,LRSAV,LREP,LRDTI,LRODT,LRSN,LRBL,LRCPT,%Y,%X
+4 KILL LRFND,LRPPT,LRIDT,LRPMD,LR,LRA,LRB,LRC,LRD,LRE,LRF,LRG,LRH,LRI,LRJ
+5 KILL LRK,LRL,LRM,LRN,LRO,LRP,LRQ,LRR,LRS,LRT,LRU,LRV,LRW,LRX,LRY,LRZ,ZTSK
+6 KILL ZTRTN,ZTSAVE,ZTDESC,LRAU,LRFLN,LRLIDT,LRND,LRNO,LRST,LRTK,LRWW,LRAC
+7 KILL DIWL,DIWR,DIWF,LRCAP,LRCAPA,LRCAPLOC,LRPRAC,LRRMD,^UTILITY($JOB)
+8 KILL ^TMP($JOB),^TMP("LRBL",$JOB),DIWF,D0,LRDFN,LRSF,DQ,LR,LRAN,DA,DX,DOB,SEX
+9 KILL LRAA,LRSOP,LROPT,LRRH,SSN,LRLLOC,LRDPF,LREND,LREXP,LRTOD,LRABO
+10 KILL LRPABO,LRPRH,LRSS,PNM,DE,DG,DA,LRCS,LRRC,LRSIT,LRWHN,POP,LRSA,LRIFN
+11 KILL LRBLT,LRQA,DIR,DIRUT,LRSD,LRPTF,LRADM,LRWARD,LRTS,LRDATE,LROLLOC,VA
+12 KILL VAIN,VADM,D1,DI,LRWD,LRRB,LRTREA,LRWRD,LRLOKVAR,LRAPX,LRSET,LRNOP
+13 KILL ^TMP("LR",$JOB),ZTREQ
+14 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+15 ;IHS/ANMC/CLS 11/1/95 HRCN
KILL HCRN
+16 ;----- END IHS MODIFICATIONS
+17 QUIT
+18 ;
LRAD 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)
DO D^LRU
SET LRH(0)=Y
QUIT
+1 ;
H WRITE !,$CHAR(7),"TO SORT IN SEQUENCE, STARTING FROM A CERTAIN NAME,",!?7,"TYPE THAT NAME"
QUIT
+1 ;
H1 WRITE !,$CHAR(7),"TO SORT ONLY UP TO A CERTAIN NAME,",!?7,"TYPE THAT NAME"
QUIT
L IF '$DATA(IOM)
DO I
KILL LR("%")
SET $PIECE(LR("%"),"-",IOM-1)="-"
QUIT
L1 IF '$DATA(IOM)
DO I
KILL LR("%1")
SET $PIECE(LR("%1"),"=",IOM-1)="="
QUIT
I SET IOP="HOME"
DO ^%ZIS
QUIT
S SET (LR("Q"),LRQ)=0
SET LRQ(1)=$$INS
QUIT
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
INSN() ;Set primary institution number from ^XMB
+1 NEW Y
+2 SET Y=+$PIECE($GET(^XMB(1,1,"XUS")),U,17)
+3 QUIT Y
DUZ2 ;Allow user to change Division [DUZ(2)] value
+1 NEW Y,X,DIC,I
+2 IF '$DATA(^VA(200,+$GET(DUZ),0))#2
WRITE !,"You are not a valid user.",!!,$CHAR(7)
QUIT
+3 IF $SELECT('$GET(DUZ(2)):1,'$DATA(^DIC(4,DUZ(2),0))#2:1,1:0)
Begin DoDot:1
+4 WRITE !?5,"You do not currently have a valid Division assigned.",!,"Log off the system and try again.",!!,$CHAR(7)
End DoDot:1
QUIT
+5 SET X=0
FOR
SET X=$ORDER(^VA(200,DUZ,2,X))
IF X<1
QUIT
SET I=$GET(I)+1
+6 IF $GET(I)'>1
WRITE !,"You have only one Division Defined in the New Person file, change not possible.",!!
QUIT
+7 KILL DIC
SET DIC="^VA(200,DUZ,2,"
SET DIC(0)="AEMNQ"
+8 SET DIC("S")="I $G(^DIC(4,+Y,99))"
+9 DO ^DIC
KILL DIC,DIC("S")
+10 IF Y'>0
Begin DoDot:1
+11 WRITE !,$CHAR(7),"Division Unchanged - Currently you are assigned to "
+12 WRITE $PIECE($GET(^DIC(4,DUZ(2),99)),U)_" "_$PIECE($GET(^DIC(4,DUZ(2),0)),U),!
End DoDot:1
QUIT
+13 SET DUZ(2)=+Y
WRITE !?5,"Division is now set to [ ",$PIECE($GET(^DIC(4,DUZ(2),99)),U)_" "_$PIECE($GET(^DIC(4,DUZ(2),0)),U)," ]",!
QUIT
