LRWU.m

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