source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRU.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.9 KB
Line 
1LRU ;AVAMC/REG/WTY - LAB UTILITY; 9/25/00
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 S X="T",%DT="" D ^%DT,D S H(10)=Y Q
15 ;
16LOCK ;Set and kill lock for ^DIE call. If lock fails LR("CK")=1 is set.
17 N LRLOKVAR
18 I '$D(DIE) S LR("CK")=1 Q
19 D CK I '$G(LR("CK")) D ^DIE K LR("CK") D FRE
20 Q
21CK D:$D(LRLOKVAR)#2 FRE S LRLOKVAR=DIE_DA_")" L +@(LRLOKVAR):1
22 I '$T D
23 . W !,$C(7),"ANOTHER TERMINAL IS EDITING THIS ENTRY!" S LR("CK")=1
24 . K LRLOKVAR
25 Q
26FRE I $D(LRLOKVAR) L -@(LRLOKVAR) K LRLOKVAR
27 Q
28 ;
29F ;
30 S LRQ=LRQ+1,X="N",%DT="T" D ^%DT,D^LRU
31 ;Suppress unnecessary form feeds
32 I $G(LRSS)'="BB" W:IOST?1"C".E!($D(LR("F"))) @IOF
33 W:$G(LRSS)="BB" @IOF
34 W !,Y,?22,LRQ(1),?(IOM-10),"Pg: ",LRQ
35 Q
36M R !,"'^' TO STOP: ",X:DTIME S:'$T!(X["^") LR("Q")=1 W $C(13),$J("",15),$C(13) Q
37 ;
38T ; Returns the Month/Day
39 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:"")
40 Q
41A ; Returns Date in format mm/dd/yyyy with time if a time is passed.
42 Q:'Y S Y=$$FMTE^XLFDT(Y,"5M")
43 I $L($P(Y,"/"))=1 S $P(Y,"/")="0"_$P(Y,"/") ;--> pad for 2 digit day
44 I $L($P(Y,"/",2))=1 S $P(Y,"/",2)="0"_$P(Y,"/",2) ;--> pad for 2 digit month
45 Q
46 ;
47D ; Returns date in eye-readable month format
48 S Y=$TR($$FMTE^XLFDT(Y,"M"),"@"," ")
49 Q
50DA ; Returns date in eye-readable month format
51 S Y=$$FMTE^XLFDT(Y,"M")
52 Q
53 ;
54DT ; If Blood Bank maintain existing display, else display 4 digit year.
55 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
56 D A Q
57 ;
58SSN ;
59 S (SSN,SSN(1),SSN(2))=$G(SSN)
60 I '$G(LRDPF),$G(LRDFN) S:$P($G(^LR(+LRDFN,0)),U,2) LRDPF=+$P(^(0),U,2)
61 S (VA("BID"),VA("PID"))="" G:'$G(LRDPF)!(+$G(LRDPF)'=2) SSNFM
62 N I,X,Y,N
63 I $D(DFN) D PID^VADPT6
64SSNFM S SSN(2)=SSN
65 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
66 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
67 ;
68B 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)
69 Q:Y<1 S LRSDT=Y
70 S %DT="AEX",%DT("A")="Go to Date TODAY// " D ^%DT K %DT I X="" S Y=DT W H(10)
71 Q:Y<1 S LRLDT=Y I LRSDT>LRLDT S X=LRSDT,LRSDT=LRLDT,LRLDT=X
72 S Y=LRSDT D D^LRU S LRSTR=Y,Y=LRLDT D D^LRU S LRLST=Y Q
73 ;
74YN W "? ",$P("YES// ^NO// ","^",%) S LR("%1")=%
75RX R %Y:$S($D(DTIME):DTIME,1:99999) E S DTOUT=1,%Y="^" W $C(7)
76 S:%Y]""!'% %=$A(%Y),%=$S(%=89:1,%=121:1,%=78:2,%=110:2,%=94:-1,1:0)
77 I %Y="@"!(%Y="S") S %=-1 Q
78 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
79 W:$X>73 ! W $P(" (YES)^ (NO)","^",%) K LR("%1") Q
80 ;
81XR Q:'$D(LRSS) S LRXR="A"_LRSS,LRXREF=LRXR_"A" Q
82 ;
83WAIT W !!,"..."
84 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)_"..."
85 H 1 Q
86 ;
87K 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
88 ;
89V D K
90 K %,ZTRTN,LRWHO,AGE,DIC,DLAYGO,DIE,DR,DFN,LRSDT,LRLDT,LRSTR,LRLST,LRXR
91 K LRXREF,LRADM,LRADX,LRABV,LRAWRD,LRAX,LRAD,LRDPAF,LRFNAM,LRMD,LRPF
92 K LRPFN,LRSVC,LRID,LRAP,LRSAV,LREP,LRDTI,LRODT,LRSN,LRBL,LRCPT,%Y,%X
93 K LRFND,LRPPT,LRIDT,LRPMD,LR,LRA,LRB,LRC,LRD,LRE,LRF,LRG,LRH,LRI,LRJ
94 K LRK,LRL,LRM,LRN,LRO,LRP,LRQ,LRR,LRS,LRT,LRU,LRV,LRW,LRX,LRY,LRZ,ZTSK
95 K ZTRTN,ZTSAVE,ZTDESC,LRAU,LRFLN,LRLIDT,LRND,LRNO,LRST,LRTK,LRWW,LRAC
96 K DIWL,DIWR,DIWF,LRCAP,LRCAPA,LRCAPLOC,LRPRAC,LRRMD,^UTILITY($J)
97 K ^TMP($J),^TMP("LRBL",$J),DIWF,D0,LRDFN,LRSF,DQ,LR,LRAN,DA,DX,DOB,SEX
98 K LRAA,LRSOP,LROPT,LRRH,SSN,LRLLOC,LRDPF,LREND,LREXP,LRTOD,LRABO
99 K LRPABO,LRPRH,LRSS,PNM,DE,DG,DA,LRCS,LRRC,LRSIT,LRWHN,POP,LRSA,LRIFN
100 K LRBLT,LRQA,DIR,DIRUT,LRSD,LRPTF,LRADM,LRWARD,LRTS,LRDATE,LROLLOC,VA
101 K VAIN,VADM,D1,DI,LRWD,LRRB,LRTREA,LRWRD,LRLOKVAR,LRAPX,LRSET,LRNOP
102 K ^TMP("LR",$J),ZTREQ
103 Q
104 ;
105LRAD 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
106 ;
107H W !,$C(7),"TO SORT IN SEQUENCE, STARTING FROM A CERTAIN NAME,",!?7,"TYPE THAT NAME" Q
108 ;
109H1 W !,$C(7),"TO SORT ONLY UP TO A CERTAIN NAME,",!?7,"TYPE THAT NAME" Q
110L D:'$D(IOM) I K LR("%") S $P(LR("%"),"-",IOM-1)="-" Q
111L1 D:'$D(IOM) I K LR("%1") S $P(LR("%1"),"=",IOM-1)="=" Q
112I S IOP="HOME" D ^%ZIS Q
113S S (LR("Q"),LRQ)=0,LRQ(1)=$$INS Q
114INS() ;Set institution Name from ^XMB
115 N Y
116 S Y=$P($G(^DIC(4,+$P($G(^XMB(1,1,"XUS")),U,17),0)),U)
117 Q Y
118INSN() ;Set primary institution number from ^XMB
119 N Y
120 S Y=+$P($G(^XMB(1,1,"XUS")),U,17)
121 Q Y
122DUZ2 ;Allow user to change Division [DUZ(2)] value
123 N Y,X,DIC,I
124 I '$D(^VA(200,+$G(DUZ),0))#2 W !,"You are not a valid user.",!!,$C(7) Q
125 I $S('$G(DUZ(2)):1,'$D(^DIC(4,DUZ(2),0))#2:1,1:0) D Q
126 . W !?5,"You do not currently have a valid Division assigned.",!,"Log off the system and try again.",!!,$C(7)
127 S X=0 F S X=$O(^VA(200,DUZ,2,X)) Q:X<1 S I=$G(I)+1
128 I $G(I)'>1 W !,"You have only one Division Defined in the New Person file, change not possible.",!! Q
129 K DIC S DIC="^VA(200,DUZ,2,",DIC(0)="AEMNQ"
130 S DIC("S")="I $G(^DIC(4,+Y,99))"
131 D ^DIC K DIC,DIC("S")
132 I Y'>0 D Q
133 .W !,$C(7),"Division Unchanged - Currently you are assigned to "
134 .W $P($G(^DIC(4,DUZ(2),99)),U)_" "_$P($G(^DIC(4,DUZ(2),0)),U),!
135 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
Note: See TracBrowser for help on using the repository browser.