LRWU ;SLC/RWF/MILW/J - UTILITY FUNTIONS ; 12/28/88 11:04 ; 9/27/19 3:32pm
;;5.2;LAB SERVICE;**42,138,153,432,531**;Sep 27, 1994;Build 7
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"
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"
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"
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
;LR*5.2*531 DD code for DD 64.52 TYPE OF DISPLAY
TODIT ; Input transform for DD 64.52 TYPE OF DISPLAY
N LRIEN
I X="V" D Q
. S LRIEN=0 F S LRIEN=$O(^LAB(64.5,1,1,DA(1),1,LRIEN)) Q:'LRIEN D Q:$G(X)=""
. . I DA'=LRIEN W !,"Only one minor header allowed if vertical." K X Q
I X="H" D
. S LRIEN=0 F S LRIEN=$O(^LAB(64.5,1,1,DA(1),1,LRIEN)) Q:'LRIEN D Q:$G(X)=""
. . I $P(^LAB(64.5,1,1,DA(1),1,LRIEN,0),U,3)="V"&(DA'=LRIEN) D
. . . W !,"No other minor headers may be defined after a vertical format minor header",!,"is defined." K X Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRWU 4458 printed Oct 16, 2024@18:23:58 Page 2
LRWU ;SLC/RWF/MILW/J - UTILITY FUNTIONS ; 12/28/88 11:04 ; 9/27/19 3:32pm
+1 ;;5.2;LAB SERVICE;**42,138,153,432,531**;Sep 27, 1994;Build 7
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 IF $DATA(^LR(LRDFN,.1))
SET LRLLOC=^(.1)
GOTO ASK
+8 SET LRLLOC="UNKNOWN"
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 if '$LENGTH(LRLLOC)
SET LRLLOC="NO ABRV"
+6 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 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 COLLECT"
+4 if $PIECE($GET(^LAB(69.9,1,7,DUZ(2),0)),U,6)
SET DIR(0)=DIR(0)_";I:Immed COLLECT"
+5 DO ^DIR
if X="^"!($DATA(DIRUT))!($DATA(DTOUT))
SET LREND=1
if LREND
QUIT
SET LRLWC=Y
+6 QUIT
+7 ;LR*5.2*531 DD code for DD 64.52 TYPE OF DISPLAY
TODIT ; Input transform for DD 64.52 TYPE OF DISPLAY
+1 NEW LRIEN
+2 IF X="V"
Begin DoDot:1
+3 SET LRIEN=0
FOR
SET LRIEN=$ORDER(^LAB(64.5,1,1,DA(1),1,LRIEN))
if 'LRIEN
QUIT
Begin DoDot:2
+4 IF DA'=LRIEN
WRITE !,"Only one minor header allowed if vertical."
KILL X
QUIT
End DoDot:2
if $GET(X)=""
QUIT
End DoDot:1
QUIT
+5 IF X="H"
Begin DoDot:1
+6 SET LRIEN=0
FOR
SET LRIEN=$ORDER(^LAB(64.5,1,1,DA(1),1,LRIEN))
if 'LRIEN
QUIT
Begin DoDot:2
+7 IF $PIECE(^LAB(64.5,1,1,DA(1),1,LRIEN,0),U,3)="V"&(DA'=LRIEN)
Begin DoDot:3
+8 WRITE !,"No other minor headers may be defined after a vertical format minor header",!,"is defined."
KILL X
QUIT
End DoDot:3
End DoDot:2
if $GET(X)=""
QUIT
End DoDot:1
+9 QUIT
