source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRWU.m@ 1582

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

initial load of FOIAVistA 6/30/08 version

File size: 3.7 KB
Line 
1LRWU ;SLC/RWF/MILW/J - UTILITY FUNTIONS ; 12/28/88 11:04 ;
2 ;;5.2;LAB SERVICE;**42,138,153**;Sep 27, 1994
3Z ;;set up 0th nodes for globals
4 I '$D(@(LRZO_"0)")) S ^(0)="^"_LRZ1_"^^"
5 S LRZI1=$S($P(@(LRZO_"0)"),"^",3)>LRZ3:$P(^(0),"^",3),1:LRZ3),LRZI2=$P(^(0),"^",4)+1,$P(^(0),"^",3,4)=LRZI1_"^"_LRZI2
6 I $D(LRZB) S B="B",@(LRZO_"B,LRZB,LRZ3)")=""
7 K LRZO,LRZ1,LRZ3,LRZI1,LRZI2 Q
8LOC ;get pt. location, called by LRPDA1
9 I $G(LRORDRR)="R" D Q
10 . S LRCAPLOC="Z",LRLLOC=$P(LRRSITE("RSITE"),U,2),(LROLLOC,LRTREA)=""
11 N %
12 I +LRDPF=LRDPF S LRDPF=LRDPF_^DIC(LRDPF,0,"GL")
13 S LREND=0,LRCAPLOC="Z"
14 I $D(LRDPF),+$G(LRDPF)=2,$G(DFN),$D(@("^"_$S(LRDPF["^":$P(LRDPF,"^",2),1:"DPT(")_DFN_",.1)")) S LRLLOC=^(.1) D DPT G ASK
15 I $D(^LR(LRDFN,.1)) S LRLLOC=^(.1) G ASK
16 S LRLLOC="UNKNOWN"
17ASK W !,"PATIENT LOCATION: ",LRLLOC,$S(LRLLOC]"":"// ",1:"") R X:DTIME G QUIT:'$T,QUIT:X[U I $L(X)>30!(X'?.ANP) W " Enter 2 - 30 alpha-numeric name" G LOC
18 K DIC S DIC("S")="I '$G(^(""OOS""))"
19 S LROLLOC="",DIC=44,DIC(0)="EMOQZ" S:X="" X=LRLLOC D ^DIC K DIC G LOC:X["?"
20 S:Y>0 LROLLOC=+Y,LRLLOC=$P(Y(0),U,2),LRCAPLOC=$S($L($P(Y(0),U,3)):$P(Y(0),U,3),1:LRCAPLOC)
21 I $L(LRLLOC) S ^LR(LRDFN,.1)=LRLLOC
22 S:'$L(LRLLOC) LRLLOC="NO ABRV"
23 S ^LR(LRDFN,.092)=LRCAPLOC
24INACT K LRIA,LRRA I $D(^SC(+Y,"I")) S LRIA=+^("I"),LRRA=$P(^("I"),U,2)
25 I $S('$D(LRIA):0,'LRIA:0,LRIA>DT:0,LRRA'>DT&(LRRA):0,1:1) W $C(7)," Location is inactive, Not allowed." G LOC
26 I Y<0,('$D(LRLABKY)!($P(^LAB(69.9,1,1),"^",8))) W " You must select a standard location." G LOC
27 I Y<0 W !,?7,"THAT MATCHES NO STANDARD LOCATION,",!,?12,"ARE YOU SURE" S %=2 D YN^DICN G LOC:%'=1 S LRLLOC=X,^LR(LRDFN,.1)=LRLLOC,^(.092)="Z"
28 K DIC,LRIA,LRRA,% Q
29QUIT S LREND=1 K DIC,LRIA,LRRE,% Q
30DATE ;
31 K DTOUT,DUOUT S LREND=0
32 W !,$S($D(%DT("A")):%DT("A"),1:"DATE: "),$S($D(%DT("B")):%DT("B"),1:"TODAY"),"//" R X:DTIME S:X="^" DUOUT=1 S:'$T X="^",DTOUT=1 I $D(DUOUT)!($D(DTOUT)) S LREND=1,Y=-1 Q
33 S:X="" X=$S($D(%DT("B")):%DT("B"),1:"T") S:$D(%DT)[0 %DT="E" S:%DT["A" %DT=$P(%DT,"A",1)_$P(%DT,"A",2) S:%DT'["E" %DT="E"_%DT D ^%DT G DATE:X="?"!(Y<1)
34 K %DT Q
35ADATE ;
36 K %DT S %DT("A")="Accession Date: ",%DT="EP" D DATE
37 I $D(LRAA)#2,$D(^LRO(68,LRAA,0)) S %=$P(^LRO(68,LRAA,0),U,3),Y=$S("D"[%:Y,%="Y":$E(Y,1,3)_"0000","M"[%:$E(Y,1,5)_"00","Q"[%:$E(Y,1,3)_"0000"+(($E(Y,4,5)-1)\3*300+100),1:Y)
38 S LRAD=Y,LREND=(Y<1) Q
39 Q
40LOCA ;
41 K DIC
42 S LRLLOC="" R !,"Select HOSPITAL LOCATION NAME: ",X:DTIME S:'$L(X) X=U G LOCE:'$T!(X[U),LOCHELP:($L(X)>20)!(X'?.ANP)!(X="") S LRLLOC=X,DIC=44,DIC(0)="EMOQ",DIC("S")="I '$G(^(""OOS""))"
43 D ^DIC K DIC I Y'<1 S LROLLOC=+Y,LRLLOC=$S($L($P(^SC(+Y,0),U,2)):$P(^(0),U,2),1:$P(^(0),U))
44 G LOCHELP:X["?"!(X="")
45 I Y<0 W !,?7,"THAT MATCHES NO STANDARD LOCATION,",!,?12,"ARE YOU SURE" S %=2 D YN^DICN G LOCA:%'=1
46LOCE K DIC Q
47LOCHELP W !,"Enter a location of 1 to 20 characters." G LOCA
48DPT ;
49 Q:'$D(LRLLOC) K DIC S X=LRLLOC,DIC(0)="XM",DIC=42 D ^DIC K DIC I Y<1 Q
50 I $D(^DIC(42,+Y,44)) S X=$P(^(44),U) I X,$D(^SC(X,0))#2,'$G(^("OOS")) D
51 . S LRLLOC=$S($L($P(^SC(X,0),U,2)):$P(^(0),U,2),1:$P(^(0),U)),LROLLOC=X S:'$G(LRTREA) LRTREA=$P(^(0),U,20)
52 Q
53IO ;outputs ZTRTN
54 D IOX K ZTRTN,ZTSAVE,IO("Q") D ^%ZISC
55 Q
56IOX S:'$D(%ZIS) %ZIS="Q" D ^%ZIS I POP S LREND=1 Q
57 I $D(IO("Q")) K IO("Q") S ZTSAVE("L*")="" D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED" K ZTSK,ZTIO Q
58 D @ZTRTN
59 Q
60A ;
61 S X1=$A(X)_"." F I1=2:1:$L(X) S X1=X1_$A(X,I1)
62 S X1=+X1
63 Q
64COLTY ;N DIR("A"),DIR(0)
65 I $G(LRORDRR)="R" S LRLWC="R"
66 I $G(LRLWC)="R" Q
67 S DIR("B")=$S($D(LRLWC)=1:LRLWC,1:"SP") S LREND=0,DIR("A")="Specimen collected how ? ",DIR(0)="S^LC:LAB COLLECT(INPATIENTS-MORN. DRAW);SP:SEND PATIENT;WC:WARD COLLECT"
68 S:$P($G(^LAB(69.9,1,7,DUZ(2),0)),U,6) DIR(0)=DIR(0)_";I:Immed COLLECT"
69 D ^DIR S:X="^"!($D(DIRUT))!($D(DTOUT)) LREND=1 Q:LREND S LRLWC=Y
70 Q
Note: See TracBrowser for help on using the repository browser.