LRWU ;SLC/RWF/MILW/J - UTILITY FUNTIONS ; 12/28/88 11:04 ;
;;5.2;LR;**42,1002,138,1004,153,1018,432,1039**;NOV 01, 1997;Build 32
;;5.2;LAB SERVICE;**42,138,153,432**;Sep 27, 1994;Build 2
Z ;;set up 0th nodes for globals
I '$D(@(LRZO_"0)")) S ^(0)="^"_LRZ1_"^^"
S LRZI1=$S($P(@(LRZO_"0)"),"^",3)>LRZ3:$P(^(0),"^",3),1:LRZ3),LRZI2=$P(^(0),"^",4)+1,$P(^(0),"^",3,4)=LRZI1_"^"_LRZI2
I $D(LRZB) S B="B",@(LRZO_"B,LRZB,LRZ3)")=""
K LRZO,LRZ1,LRZ3,LRZI1,LRZI2 Q
LOC ;get pt. location, called by LRPDA1
I $G(LRORDRR)="R" D Q
. S LRCAPLOC="Z",LRLLOC=$P(LRRSITE("RSITE"),U,2),(LROLLOC,LRTREA)=""
N %
I +LRDPF=LRDPF S LRDPF=LRDPF_^DIC(LRDPF,0,"GL")
S LREND=0,LRCAPLOC="Z"
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
; I $D(^LR(LRDFN,.1)) S LRLLOC=^(.1) G ASK
; S LRLLOC="UNKNOWN"
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
S LRLLOC="" ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
ASK 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
K DIC S DIC("S")="I '$G(^(""OOS""))&(""FI""'[$P($G(^(0)),""^"",3))"
S LROLLOC="",DIC=44,DIC(0)="EMOQZ" S:X="" X=LRLLOC D ^DIC K DIC G LOC:X["?"
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)
I $L(LRLLOC) S ^LR(LRDFN,.1)=LRLLOC
; S:'$L(LRLLOC) LRLLOC="NO ABRV"
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
S:'$L(LRLLOC) LRLLOC="" ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
S ^LR(LRDFN,.092)=LRCAPLOC
INACT K LRIA,LRRA I $D(^SC(+Y,"I")) S LRIA=+^("I"),LRRA=$P(^("I"),U,2)
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
I Y<0,('$D(LRLABKY)!($P(^LAB(69.9,1,1),"^",8))) W " You must select a standard location." G LOC
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"
K DIC,LRIA,LRRA,% Q
QUIT S LREND=1 K DIC,LRIA,LRRE,% Q
DATE ;
K DTOUT,DUOUT S LREND=0
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
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)
K %DT Q
ADATE ;
K %DT S %DT("A")="Accession Date: ",%DT="EP" D DATE
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)
S LRAD=Y,LREND=(Y<1) Q
Q
LOCA ;
K DIC
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""))"
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))
G LOCHELP:X["?"!(X="")
I Y<0 W !,?7,"THAT MATCHES NO STANDARD LOCATION,",!,?12,"ARE YOU SURE" S %=2 D YN^DICN G LOCA:%'=1
LOCE K DIC Q
LOCHELP W !,"Enter a location of 1 to 20 characters." G LOCA
DPT ;
Q:'$D(LRLLOC) K DIC S X=LRLLOC,DIC(0)="XM",DIC=42 D ^DIC K DIC I Y<1 Q
I $D(^DIC(42,+Y,44)) S X=$P(^(44),U) I X,$D(^SC(X,0))#2,'$G(^("OOS")) D
. 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)
Q
IO ;outputs ZTRTN
D IOX K ZTRTN,ZTSAVE,IO("Q") D ^%ZISC
Q
IOX S:'$D(%ZIS) %ZIS="Q" D ^%ZIS I POP S LREND=1 Q
I $D(IO("Q")) K IO("Q") S ZTSAVE("L*")="" D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED" K ZTSK,ZTIO Q
D @ZTRTN
Q
A ;
S X1=$A(X)_"." F I1=2:1:$L(X) S X1=X1_$A(X,I1)
S X1=+X1
Q
COLTY ;N DIR("A"),DIR(0)
I $G(LRORDRR)="R" S LRLWC="R"
I $G(LRLWC)="R" Q
; 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"
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
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/CLINIC COLLECT" ;IHS/OIRM TUC/AAB 3/20/97
;----- END IHS MODIFICATIONS
S:$P($G(^LAB(69.9,1,7,DUZ(2),0)),U,6) DIR(0)=DIR(0)_";I:Immed COLLECT"
D ^DIR S:X="^"!($D(DIRUT))!($D(DTOUT)) LREND=1 Q:LREND S LRLWC=Y
Q
LRWU ;SLC/RWF/MILW/J - UTILITY FUNTIONS ; 12/28/88 11:04 ;
+1 ;;5.2;LR;**42,1002,138,1004,153,1018,432,1039**;NOV 01, 1997;Build 32
+2 ;;5.2;LAB SERVICE;**42,138,153,432**;Sep 27, 1994;Build 2
Z ;;set up 0th nodes for globals
+1 IF '$DATA(@(LRZO_"0)"))
SET ^(0)="^"_LRZ1_"^^"
+2 SET LRZI1=$SELECT($PIECE(@(LRZO_"0)"),"^",3)>LRZ3:$PIECE(^(0),"^",3),1:LRZ3)
SET LRZI2=$PIECE(^(0),"^",4)+1
SET $PIECE(^(0),"^",3,4)=LRZI1_"^"_LRZI2
+3 IF $DATA(LRZB)
SET B="B"
SET @(LRZO_"B,LRZB,LRZ3)")=""
+4 KILL LRZO,LRZ1,LRZ3,LRZI1,LRZI2
QUIT
LOC ;get pt. location, called by LRPDA1
+1 IF $GET(LRORDRR)="R"
Begin DoDot:1
+2 SET LRCAPLOC="Z"
SET LRLLOC=$PIECE(LRRSITE("RSITE"),U,2)
SET (LROLLOC,LRTREA)=""
End DoDot:1
QUIT
+3 NEW %
+4 IF +LRDPF=LRDPF
SET LRDPF=LRDPF_^DIC(LRDPF,0,"GL")
+5 SET LREND=0
SET LRCAPLOC="Z"
+6 IF $DATA(LRDPF)
IF +$GET(LRDPF)=2
IF $GET(DFN)
IF $DATA(@("^"_$SELECT(LRDPF["^":$PIECE(LRDPF,"^",2),1:"DPT(")_DFN_",.1)"))
SET LRLLOC=^(.1)
DO DPT
GOTO ASK
+7 ; I $D(^LR(LRDFN,.1)) S LRLLOC=^(.1) G ASK
+8 ; S LRLLOC="UNKNOWN"
+9 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+10 ;IHS/ANMC/CLS 08/18/96
SET LRLLOC=""
+11 ;----- END IHS MODIFICATIONS
ASK WRITE !,"PATIENT LOCATION: ",LRLLOC,$SELECT(LRLLOC]"":"// ",1:"")
READ X:DTIME
IF '$TEST
GOTO QUIT
IF X[U
GOTO QUIT
IF $LENGTH(X)>30!(X'?.ANP)
WRITE " Enter 2 - 30 alpha-numeric name"
GOTO LOC
+1 KILL DIC
SET DIC("S")="I '$G(^(""OOS""))&(""FI""'[$P($G(^(0)),""^"",3))"
+2 SET LROLLOC=""
SET DIC=44
SET DIC(0)="EMOQZ"
IF X=""
SET X=LRLLOC
DO ^DIC
KILL DIC
IF X["?"
GOTO LOC
+3 IF Y>0
SET LROLLOC=+Y
SET LRLLOC=$PIECE(Y(0),U,2)
SET LRCAPLOC=$SELECT($LENGTH($PIECE(Y(0),U,3)):$PIECE(Y(0),U,3),1:LRCAPLOC)
+4 IF $LENGTH(LRLLOC)
SET ^LR(LRDFN,.1)=LRLLOC
+5 ; S:'$L(LRLLOC) LRLLOC="NO ABRV"
+6 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+7 ;IHS/ANMC/CLS 08/18/96
IF '$LENGTH(LRLLOC)
SET LRLLOC=""
+8 ;----- END IHS MODIFICATIONS
+9 SET ^LR(LRDFN,.092)=LRCAPLOC
INACT KILL LRIA,LRRA
IF $DATA(^SC(+Y,"I"))
SET LRIA=+^("I")
SET LRRA=$PIECE(^("I"),U,2)
+1 IF $SELECT('$DATA(LRIA):0,'LRIA:0,LRIA>DT:0,LRRA'>DT&(LRRA):0,1:1)
WRITE $CHAR(7)," Location is inactive, Not allowed."
GOTO LOC
+2 IF Y<0
IF ('$DATA(LRLABKY)!($PIECE(^LAB(69.9,1,1),"^",8)))
WRITE " You must select a standard location."
GOTO LOC
+3 IF Y<0
WRITE !,?7,"THAT MATCHES NO STANDARD LOCATION,",!,?12,"ARE YOU SURE"
SET %=2
DO YN^DICN
IF %'=1
GOTO LOC
SET LRLLOC=X
SET ^LR(LRDFN,.1)=LRLLOC
SET ^(.092)="Z"
+4 KILL DIC,LRIA,LRRA,%
QUIT
QUIT SET LREND=1
KILL DIC,LRIA,LRRE,%
QUIT
DATE ;
+1 KILL DTOUT,DUOUT
SET LREND=0
+2 WRITE !,$SELECT($DATA(%DT("A")):%DT("A"),1:"DATE: "),$SELECT($DATA(%DT("B")):%DT("B"),1:"TODAY"),"//"
READ X:DTIME
IF X="^"
SET DUOUT=1
IF '$TEST
SET X="^"
SET DTOUT=1
IF $DATA(DUOUT)!($DATA(DTOUT))
SET LREND=1
SET Y=-1
QUIT
+3 IF X=""
SET X=$SELECT($DATA(%DT("B")):%DT("B"),1:"T")
IF $DATA(%DT)[0
SET %DT="E"
IF %DT["A"
SET %DT=$PIECE(%DT,"A",1)_$PIECE(%DT,"A",2)
IF %DT'["E"
SET %DT="E"_%DT
DO ^%DT
IF X="?"!(Y<1)
GOTO DATE
+4 KILL %DT
QUIT
ADATE ;
+1 KILL %DT
SET %DT("A")="Accession Date: "
SET %DT="EP"
DO DATE
+2 IF $DATA(LRAA)#2
IF $DATA(^LRO(68,LRAA,0))
SET %=$PIECE(^LRO(68,LRAA,0),U,3)
SET Y=$SELECT("D"[%:Y,%="Y":$EXTRACT(Y,1,3)_"0000","M"[%:$EXTRACT(Y,1,5)_"00","Q"[%:$EXTRACT(Y,1,3)_"0000"+(($EXTRACT(Y,4,5)-1)\3*300+100),1:Y)
+3 SET LRAD=Y
SET LREND=(Y<1)
QUIT
+4 QUIT
LOCA ;
+1 KILL DIC
+2 SET LRLLOC=""
READ !,"Select HOSPITAL LOCATION NAME: ",X:DTIME
IF '$LENGTH(X)
SET X=U
IF '$TEST!(X[U)
GOTO LOCE
IF ($LENGTH(X)>20)!(X'?.ANP)!(X="")
GOTO LOCHELP
SET LRLLOC=X
SET DIC=44
SET DIC(0)="EMOQ"
SET DIC("S")="I '$G(^(""OOS""))"
+3 DO ^DIC
KILL DIC
IF Y'<1
SET LROLLOC=+Y
SET LRLLOC=$SELECT($LENGTH($PIECE(^SC(+Y,0),U,2)):$PIECE(^(0),U,2),1:$PIECE(^(0),U))
+4 IF X["?"!(X="")
GOTO LOCHELP
+5 IF Y<0
WRITE !,?7,"THAT MATCHES NO STANDARD LOCATION,",!,?12,"ARE YOU SURE"
SET %=2
DO YN^DICN
IF %'=1
GOTO LOCA
LOCE KILL DIC
QUIT
LOCHELP WRITE !,"Enter a location of 1 to 20 characters."
GOTO LOCA
DPT ;
+1 IF '$DATA(LRLLOC)
QUIT
KILL DIC
SET X=LRLLOC
SET DIC(0)="XM"
SET DIC=42
DO ^DIC
KILL DIC
IF Y<1
QUIT
+2 IF $DATA(^DIC(42,+Y,44))
SET X=$PIECE(^(44),U)
IF X
IF $DATA(^SC(X,0))#2
IF '$GET(^("OOS"))
Begin DoDot:1
+3 SET LRLLOC=$SELECT($LENGTH($PIECE(^SC(X,0),U,2)):$PIECE(^(0),U,2),1:$PIECE(^(0),U))
SET LROLLOC=X
IF '$GET(LRTREA)
SET LRTREA=$PIECE(^(0),U,20)
End DoDot:1
+4 QUIT
IO ;outputs ZTRTN
+1 DO IOX
KILL ZTRTN,ZTSAVE,IO("Q")
DO ^%ZISC
+2 QUIT
IOX IF '$DATA(%ZIS)
SET %ZIS="Q"
DO ^%ZIS
IF POP
SET LREND=1
QUIT
+1 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTSAVE("L*")=""
DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !,"REQUEST QUEUED"
KILL ZTSK,ZTIO
QUIT
+2 DO @ZTRTN
+3 QUIT
A ;
+1 SET X1=$ASCII(X)_"."
FOR I1=2:1:$LENGTH(X)
SET X1=X1_$ASCII(X,I1)
+2 SET X1=+X1
+3 QUIT
COLTY ;N DIR("A"),DIR(0)
+1 IF $GET(LRORDRR)="R"
SET LRLWC="R"
+2 IF $GET(LRLWC)="R"
QUIT
+3 ; 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"
+4 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+5 ;IHS/OIRM TUC/AAB 3/20/97
SET DIR("B")=$SELECT($DATA(LRLWC)=1:LRLWC,1:"SP")
SET LREND=0
SET DIR("A")="Specimen collected how ? "
SET DIR(0)="S^LC:LAB COLLECT(INPATIENTS-MORN. DRAW);SP:SEND PATIENT;WC:WARD/CLINIC COLLECT"
+6 ;----- END IHS MODIFICATIONS
+7 IF $PIECE($GET(^LAB(69.9,1,7,DUZ(2),0)),U,6)
SET DIR(0)=DIR(0)_";I:Immed COLLECT"
+8 DO ^DIR
IF X="^"!($DATA(DIRUT))!($DATA(DTOUT))
SET LREND=1
IF LREND
QUIT
SET LRLWC=Y
+9 QUIT
