- 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 Jan 18, 2025@03:23 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