- 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