LRUTL ;AVAMC/REG/CYM - GENERAL LAB UTILITY ;3/12/98 07:53
;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994
I $D(DUZ)'=11 S Y=-1 Q
D ^LRPARAM Q:$G(LREND)
I X="BLOOD BANK" S LRAA(2)="BB" D BB Q:Y=-1
S DIC=68,DIC(0)="MOXZ" I X="" S DIC(0)="AEMQZ"
A D ^DIC K DIC Q:$D(DUOUT)!$D(DTOUT)!(X="") I Y<1 W $C(7),!!,X," Not in Accession Area file (#68)",!,"Tell responsible person to enter ",X," in file." Q
S LR("K")=$P(Y(0),U,14) I LR("K"),$D(^DIC(19.1,LR("K"),0)) S LR("K")=$P(^(0),U) I LR("K")]"",'$D(^XUSEC(LR("K"),DUZ)) W $C(7),!!,"You do not have the appropriate security key to select this section.",! S Y=-1 Q
S LRAA=+Y,(LRO(68),LRAA(1))=$P(Y,U,2),LRAA(2)=$P(Y(0),U,2),LRABV=$P(Y(0),U,11),LRSS=$P(Y(0),U,2) Q:'$L(LRSS)
I LRSS="BB" S LRAA(1)="BLOOD BANK",LR(69.981)=LRAA
I "SPCYEMAU"[LRSS S LRAA(1)=$S(LRSS="SP":"SURGICAL PATHOLOGY",LRSS="CY":"CYTOPATHOLOGY",LRSS="AU":"AUTOPSY",1:"EM")
S X=^DIC(4,DUZ(2),0),LRAA(4)=$P(X,"^"),LRAA(5)=$E($P($G(^(1)),"^",3),1,30),X=+$P(X,"^",2),LRAA(6)=$P($G(^DIC(5,X,0)),"^",2) ;LRAA(4)=institution name, LRAA(5)=city, LRAA(6)=state
S LRAX=$O(^DD(63,"B",LRAA(1),0)) S:LRAX'>0 LRAX=+$O(^DD(63,"B",LRAA(2),0)) S LRSF=$S($D(^DD(63,LRAX,0)):+$P(^(0),"^",2),1:"")
S LRCAPA=$P(^LAB(69.9,1,0),"^",14)&$P(^LRO(68,LRAA,0),"^",16),LRT="" ;workload flag
I 'LRSF,"BBCYEMSP"[LRSS W $C(7),!!,"LAB DATA FILE(#63) is missing one of the following:",!?3,"BLOOD BANK (63.01)",!?3,"EM (63.02)",!?3,"SURGICAL PATHOLOGY (63.08)",!?3,"CYTOPATHOLOGY (63.09)",!!?29,"Please tell IRM STAFF" D V^LRU S Y=-1 Q
I '$D(^LRO(69.2,LRAA,0)) S ^(0)=LRAA_"^"_$P(Y(0),"^",11),^LRO(69.2,"B",LRAA,LRAA)="",^LRO(69.2,"C",$P(Y(0),"^",11),LRAA)="",X=^LRO(69.2,0),^(0)=$P(X,"^",1,2)_"^^"_($P(X,"^",4)+1)
S:'$D(^LRO(69.2,LRAA,1,0)) ^(0)="^69.21A^0^0" S:'$D(^LRO(69.2,LRAA,3,0)) ^(0)="^69.29A^0^0" S:'$D(^LRO(69.2,LRAA,2,0)) ^(0)="^69.23A^0^0"
S X=$S($D(^VA(200,DUZ,0)):$P(^(0),U,2),1:"") D C^LRUA S LRWHO=X,LRDPAF=1,Y=DT K DR,DIE,DIC
D LRAD^LRU
EN ;
S LRU=$O(^LAB(61,"C","00001",0)) I 'LRU Q:'$D(^LAB(61,0)) S X="UNKNOWN",(DIC,DIE)=61,DIC(0)="LMO",DR="2///00001",DLAYGO=61 D ^DIC S (LRU,DA)=+Y D ^DIE K DIC,DIE,DR,DLAYGO
Q
BEG ;
K IOP,ZTSK,%ZIS S %ZIS="Q" D ^%ZIS Q:POP!(IO(0)=IO)&('$D(IOCPU)) I '$D(IO("Q")) G W
G QUE
END ;
W:'$D(LR("LINE")) ! W:$E(IOST,1,2)="P-"&('$D(LR("FORM"))) @IOF S:$D(ZTQUEUED) ZTREQ="@" D:'$D(ZTQUEUED) ^%ZISC Q
;
BB S (A,B)=0 F S A=$O(^LRO(68,A)) Q:'A I $P($G(^LRO(68,A,0)),"^",2)=LRAA(2),$G(^(3,DUZ(2),0)) S B=B+1,B(B)=A
I B=0 W $C(7),!!,"There are no accession areas for blood bank.",!,"Please have responsible person enter one in Accession File (#68)." S Y=-1 Q
I B=1!($D(LR("M"))) S X=$P(^LRO(68,B(B),0),U),Y=1 K A,B Q
S DIC=68,DIC(0)="AEQM",DIC("S")="I $P(^(0),U,2)=""BB""&(+$G(^(3,+DUZ(2),0)))" D ^DIC K DIC S X=$P(Y,U,2) Q
;
QUE K IO("Q") I '$D(ZTRTN)!(IOF="") S POP=1 Q
S:'$D(ZTDESC) ZTDESC=""
S ZTIO=ION S:'$D(ZTSAVE) ZTSAVE("*")="" D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued to device ",ION K ZTIO S:'$D(ZTSK) POP=1 D ^%ZISC Q
;
W W !?13,"Do you want to queue this report " S %=2 D YN^LRU I %<1 S POP=1 Q
G:%=1 QUE S IOP=ION D ^%ZIS I POP W $C(7),!,"PRINTER BUSY, TRY LATER"
Q
STF(LRAA,LRAD,LRAN,LRT,TIME) ;Set ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0) entries into
W !,LRAA,!,LRAD,!,LRAN,!,LRT,!,TIME
;accession file. Used with workload data collection functions. LRRC=yyymmdd.mmss
;A default of 50 (Wkld) urgency is stuffed for each entry.
; LRT=internal pointer to ^LAB(60,
S LRERR=$S('$G(LRAA):1,'$G(LRAD):1,'$G(LRAN):1,'$G(LRT):1,$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))[0:1,1:0) Q:LRERR
N X,LRRC
S LRRC=$S($P(TIME,".",2):TIME,1:$$NOW^XLFDT)
S:$D(^LRO(68,LRAN,1,LRAD,1,LRAN,4,0))[0 ^(0)="^68.04PA^"
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0)) S ^(0)=LRT_"^50^^"_DUZ_"^"_LRRC D
.S X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),^(0)=$P(X,"^",1,2)_"^"_LRT_"^"_($P(X,"^",4)+1),^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",LRT,LRT)=""
S:$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0))[0 ^(0)="^68.14P^^" Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUTL 3979 printed Dec 13, 2024@02:22:18 Page 2
LRUTL ;AVAMC/REG/CYM - GENERAL LAB UTILITY ;3/12/98 07:53
+1 ;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994
+2 IF $DATA(DUZ)'=11
SET Y=-1
QUIT
+3 DO ^LRPARAM
if $GET(LREND)
QUIT
+4 IF X="BLOOD BANK"
SET LRAA(2)="BB"
DO BB
if Y=-1
QUIT
+5 SET DIC=68
SET DIC(0)="MOXZ"
IF X=""
SET DIC(0)="AEMQZ"
A DO ^DIC
KILL DIC
if $DATA(DUOUT)!$DATA(DTOUT)!(X="")
QUIT
IF Y<1
WRITE $CHAR(7),!!,X," Not in Accession Area file (#68)",!,"Tell responsible person to enter ",X," in file."
QUIT
+1 SET LR("K")=$PIECE(Y(0),U,14)
IF LR("K")
IF $DATA(^DIC(19.1,LR("K"),0))
SET LR("K")=$PIECE(^(0),U)
IF LR("K")]""
IF '$DATA(^XUSEC(LR("K"),DUZ))
WRITE $CHAR(7),!!,"You do not have the appropriate security key to select this section.",!
SET Y=-1
QUIT
+2 SET LRAA=+Y
SET (LRO(68),LRAA(1))=$PIECE(Y,U,2)
SET LRAA(2)=$PIECE(Y(0),U,2)
SET LRABV=$PIECE(Y(0),U,11)
SET LRSS=$PIECE(Y(0),U,2)
if '$LENGTH(LRSS)
QUIT
+3 IF LRSS="BB"
SET LRAA(1)="BLOOD BANK"
SET LR(69.981)=LRAA
+4 IF "SPCYEMAU"[LRSS
SET LRAA(1)=$SELECT(LRSS="SP":"SURGICAL PATHOLOGY",LRSS="CY":"CYTOPATHOLOGY",LRSS="AU":"AUTOPSY",1:"EM")
+5 ;LRAA(4)=institution name, LRAA(5)=city, LRAA(6)=state
SET X=^DIC(4,DUZ(2),0)
SET LRAA(4)=$PIECE(X,"^")
SET LRAA(5)=$EXTRACT($PIECE($GET(^(1)),"^",3),1,30)
SET X=+$PIECE(X,"^",2)
SET LRAA(6)=$PIECE($GET(^DIC(5,X,0)),"^",2)
+6 SET LRAX=$ORDER(^DD(63,"B",LRAA(1),0))
if LRAX'>0
SET LRAX=+$ORDER(^DD(63,"B",LRAA(2),0))
SET LRSF=$SELECT($DATA(^DD(63,LRAX,0)):+$PIECE(^(0),"^",2),1:"")
+7 ;workload flag
SET LRCAPA=$PIECE(^LAB(69.9,1,0),"^",14)&$PIECE(^LRO(68,LRAA,0),"^",16)
SET LRT=""
+8 IF 'LRSF
IF "BBCYEMSP"[LRSS
WRITE $CHAR(7),!!,"LAB DATA FILE(#63) is missing one of the following:",!?3,"BLOOD BANK (63.01)",!?3,"EM (63.02)",!?3,"SURGICAL PATHOLOGY (63.08)",!?3,"CYTOPATHOLOGY (63.09)",!!?29,"Please tell IRM STAFF"
DO V^LRU
SET Y=-1
QUIT
+9 IF '$DATA(^LRO(69.2,LRAA,0))
SET ^(0)=LRAA_"^"_$PIECE(Y(0),"^",11)
SET ^LRO(69.2,"B",LRAA,LRAA)=""
SET ^LRO(69.2,"C",$PIECE(Y(0),"^",11),LRAA)=""
SET X=^LRO(69.2,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^^"_($PIECE(X,"^",4)+1)
+10 if '$DATA(^LRO(69.2,LRAA,1,0))
SET ^(0)="^69.21A^0^0"
if '$DATA(^LRO(69.2,LRAA,3,0))
SET ^(0)="^69.29A^0^0"
if '$DATA(^LRO(69.2,LRAA,2,0))
SET ^(0)="^69.23A^0^0"
+11 SET X=$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U,2),1:"")
DO C^LRUA
SET LRWHO=X
SET LRDPAF=1
SET Y=DT
KILL DR,DIE,DIC
+12 DO LRAD^LRU
EN ;
+1 SET LRU=$ORDER(^LAB(61,"C","00001",0))
IF 'LRU
if '$DATA(^LAB(61,0))
QUIT
SET X="UNKNOWN"
SET (DIC,DIE)=61
SET DIC(0)="LMO"
SET DR="2///00001"
SET DLAYGO=61
DO ^DIC
SET (LRU,DA)=+Y
DO ^DIE
KILL DIC,DIE,DR,DLAYGO
+2 QUIT
BEG ;
+1 KILL IOP,ZTSK,%ZIS
SET %ZIS="Q"
DO ^%ZIS
if POP!(IO(0)=IO)&('$DATA(IOCPU))
QUIT
IF '$DATA(IO("Q"))
GOTO W
+2 GOTO QUE
END ;
+1 if '$DATA(LR("LINE"))
WRITE !
if $EXTRACT(IOST,1,2)="P-"&('$DATA(LR("FORM")))
WRITE @IOF
if $DATA(ZTQUEUED)
SET ZTREQ="@"
if '$DATA(ZTQUEUED)
DO ^%ZISC
QUIT
+2 ;
BB SET (A,B)=0
FOR
SET A=$ORDER(^LRO(68,A))
if 'A
QUIT
IF $PIECE($GET(^LRO(68,A,0)),"^",2)=LRAA(2)
IF $GET(^(3,DUZ(2),0))
SET B=B+1
SET B(B)=A
+1 IF B=0
WRITE $CHAR(7),!!,"There are no accession areas for blood bank.",!,"Please have responsible person enter one in Accession File (#68)."
SET Y=-1
QUIT
+2 IF B=1!($DATA(LR("M")))
SET X=$PIECE(^LRO(68,B(B),0),U)
SET Y=1
KILL A,B
QUIT
+3 SET DIC=68
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,2)=""BB""&(+$G(^(3,+DUZ(2),0)))"
DO ^DIC
KILL DIC
SET X=$PIECE(Y,U,2)
QUIT
+4 ;
QUE KILL IO("Q")
IF '$DATA(ZTRTN)!(IOF="")
SET POP=1
QUIT
+1 if '$DATA(ZTDESC)
SET ZTDESC=""
+2 SET ZTIO=ION
if '$DATA(ZTSAVE)
SET ZTSAVE("*")=""
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Report Queued to device ",ION
KILL ZTIO
if '$DATA(ZTSK)
SET POP=1
DO ^%ZISC
QUIT
+3 ;
W WRITE !?13,"Do you want to queue this report "
SET %=2
DO YN^LRU
IF %<1
SET POP=1
QUIT
+1 if %=1
GOTO QUE
SET IOP=ION
DO ^%ZIS
IF POP
WRITE $CHAR(7),!,"PRINTER BUSY, TRY LATER"
+2 QUIT
STF(LRAA,LRAD,LRAN,LRT,TIME) ;Set ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0) entries into
+1 WRITE !,LRAA,!,LRAD,!,LRAN,!,LRT,!,TIME
+2 ;accession file. Used with workload data collection functions. LRRC=yyymmdd.mmss
+3 ;A default of 50 (Wkld) urgency is stuffed for each entry.
+4 ; LRT=internal pointer to ^LAB(60,
+5 SET LRERR=$SELECT('$GET(LRAA):1,'$GET(LRAD):1,'$GET(LRAN):1,'$GET(LRT):1,$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))[0:1,1:0)
if LRERR
QUIT
+6 NEW X,LRRC
+7 SET LRRC=$SELECT($PIECE(TIME,".",2):TIME,1:$$NOW^XLFDT)
+8 if $DATA(^LRO(68,LRAN,1,LRAD,1,LRAN,4,0))[0
SET ^(0)="^68.04PA^"
+9 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0))
SET ^(0)=LRT_"^50^^"_DUZ_"^"_LRRC
Begin DoDot:1
+10 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRT_"^"_($PIECE(X,"^",4)+1)
SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",LRT,LRT)=""
End DoDot:1
+11 if $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0))[0
SET ^(0)="^68.14P^^"
QUIT
+12 QUIT
