LRLABLD0 ;DALOI/FHS/DRH/JMC - LABELS ON DEMAND FOR FUTURE LAB COLLECT ;8/29/94 12:36
;;5.2;LAB SERVICE;**1,65,121,161,218,445**;Sep 27, 1994;Build 6
EN ;
W !?5,"Future Lab, Immediate, Ward Collect and Send Patient Orders"
W !?5,"Enter each date to print separately",!!
N %DT,%ZIS,DIR,DIRUT,DTOUT,DUOUT,LRBATCH,LRCHLOC,LRCT0,LRDTC,X,Y,ZTSK,LRAA,LRAD,LRAN,LRUID
S (LN,LRSTOP,CNT,LREND)=0,(LRLOCF,LRCHLOC)="",LRBATCH=1
S DT=$$DT^XLFDT
S %DT("A")="Print for what date(s): ",%DT="AEFX"
S %DT(0)=DT ; Only allow future dates( >=DT)
F D ^%DT Q:Y<1 S LRCT0(Y)="" I '$O(^LRO(69,+Y,1,0)) W !?10,"No Orders For "_$$FMTE^XLFDT(Y) K LRCT0(Y)
I '$O(LRCT0(0)) W !!?10,"Nothing selected ",!,$C(7) G END
D LRPICK G:$G(LREND) END
K DIR
S DIR(0)="S^1:Selected Locations;2:All Locations"
S DIR("A")="Choose one of the following",DIR("?")="Enter 1 or 2."
D ^DIR
I $D(DIRUT) D END Q
S LRCHLOC=Y
SELLOC I LRCHLOC=1 D
. N DIC,DTOUT,DUOUT,X,Y
. S DIC="^SC(",DIC(0)="AEMQZ"
. F D Q:Y<0
. . D ^DIC
. . I $D(DUOUT)!($D(DTOUT)) S LREND=1
. . I Y>0 S LRLOCF(+Y)=$P(Y(0),U)
. I '$O(LRLOCF(0)) W !!?10,"No Locations Selected ",$C(7) S LREND=1
I LREND D END Q
D SELCOLTY
I LREND D END Q
S %ZIS="Q" D ^%ZIS G END:POP
I $D(IO("Q")) D Q
. N LRION
. S LRION=ION
. S ZTSAVE("LR*")="",ZTRTN="QUE^LRLABLD0",ZTDESC="Print future collection labels"
. D ^%ZTLOAD,^%ZISC
. W !?10,$S($G(ZTSK):"Queued to "_LRION,1:"Task NOT queued"),!
. D END
;
QUE ; Tasked entry and interactive point.
K ^TMP($J),LRDTC
S ^TMP($J)=$$NOW^XLFDT_"^"_$$FMADD^XLFDT(DT,1,0,0,0)
S (LN,LRSTOP,CNT,LRRB)=0
S LRODT=0
F S LRODT=$O(LRCT0(LRODT)) Q:LRODT="" D
. S LRSN=0
. F S LRSN=$O(^LRO(69,LRODT,1,LRSN)) Q:LRSN<1 D
. . N LREND
. . S LRSN(0)=$G(^LRO(69,LRODT,1,LRSN,0)),LRSN(1)=$G(^LRO(69,LRODT,1,LRSN,1))
. . ; Skip lab controls
. . I $P($G(^LR(+LRSN(0),0)),"^",2)=62.3 Q
. . ; Not selected location
. . I $O(LRLOCF(0)),'$D(LRLOCF(+$P(LRSN(0),U,9))) Q
. . ; No collection type
. . I $P(LRSN(0),U,4)="" Q
. . ; Not selected collection type.
. . I '$D(LRCOLTY($P(LRSN(0),U,4))) Q
. . S LREND=0 D CHK^LRLABLDS Q:LREND
. . S LRDFN=+LRSN(0) D BLDTMP
D ^LRLABELF
D END^LRLABELF
Q
;
SETUP ; Called by LRLABELF
S Y2=1,LRRB=0,N=1
S (Y1,Y)=LRCT
S LRDAT=$TR($$FMTE^XLFDT(LRCT,"2M"),"@"," ") ; Date/time with "@" --> " "
S NODE=$G(^LRO(69,LRODT,1,LRSN,0)) Q:'$L(NODE) S LRCE=$G(^(.1))
S LRCLTY=$P(NODE,U,4)
S LRDFN=+NODE,DFN=$P($G(^LR(LRDFN,0)),U,3) Q:'DFN S LRDPF=$P(^(0),U,2),LRINFW=$G(^(.091))
D PT^LRX
S LRLLOC=$P(NODE,U,7),LRTVOL=0
S LRTJ=$P(NODE,U,3)
I '$G(LRSING),$G(LRNEWL)'=LRLLOC D SEP
S LRTJDATA=$S($D(^LAB(62,+LRTJ,0)):^(0),1:"")
S LRTOP=$P(LRTJDATA,U,3),S1=$P(LRTJDATA,U,4)
S S2=$P(LRTJDATA,U,5) D:LRTOP="" LRTOP
D T
S LRN=$S(+S1=0:1,1:LRTVOL\S1+$S(LRTVOL#S1:1,LRTVOL=0:1,1:0))+LRXL
D P
Q
T ;
Q:LRODT'>0
K LRTS,LRURG
S LRURG0=9,(LRXL,T)=0
F S T=$O(^LRO(69,LRODT,1,LRSN,2,T)) Q:T<.5 D
. Q:'$G(^LRO(69,LRODT,1,LRSN,2,T,0)) S LRTV=^(0)
. I $P(LRTV,"^",11) Q
. D T1
. S LRTS(T)=$S($D(^LAB(60,+LRTV,.1)):$P(^(.1),U,1),1:"")
. S LRXL=LRXL+$P(^LAB(60,+LRTV,0),U,15) ;Extra labels
Q
T1 ;
N X
S LRVOL="" S:$P(LRTV,U,2)<3 LRURG=1
I $P(LRTV,U,2),$P(LRTV,U,2)<LRURG0 S LRURG0=$P(LRTV,U,2)
S X=0 F S X=$O(^LAB(60,+LRTV,3,X)) Q:X<1 I +$G(^(X,0))=$P(NODE,U,3) S LRVOL=$P(^(0),U,4),LRTVOL=LRTVOL+LRVOL
Q
LRTOP ;
S LRTOP=$G(^LRO(69,LRODT,1,LRSN,4,1,0)) ; Specimen from file #69
S T=$P($G(^LAB(62,+$P($G(NODE),U,3),0)),U,1) ; Collection sample from file #69
S LRTOP=$P($G(^LAB(61,+LRTOP,0)),U)
S LRTOP=T_$S(LRTOP'=T:" "_LRTOP,1:"")
Q
P ;
I '$G(LRSING) D:$S('$D(LRNEWL):1,(LRNEWL'=LRLLOC):1,1:0) SEP
Q:LRN<1
N LRAA,LRBAR
S LRAA=0
D LBLTYP^LRLABLD
D LRBAR^LRLABLD
S LRACC=$P($P($$FMTE^XLFDT(LRCT,2),"@",2),":",1,2)_" "_LRCLTY
D UID^LRLABLD,BARID^LRLABLD ; Setup UID and barcode ID.
S LRURGA=$$URGA^LRLABLD(LRURG0) ; Setup urgency abbreviation
U IO
F LRI=1:1:LRN D
. S I=LRI,N=LRN ; Label routines use "I" and "N"
. N LRI,LRN
. S LRPREF=$S(S2="":"",LRTVOL>S2:"LARGE ",1:"SMALL "),LRTVOL=LRTVOL-S1
. D @LRLABEL
Q
QUIT ;
END ;
D END^LRLABELF
Q
SEP ;
N LRAA,LRAN,LRACC,LRBAR,LRCE,LRURG0,LRXL
N PNM,LRDAT,LRRB,SSN,LRTOP,LRINFW,LRTS,LRPREF,LRUID,I,N
S:'$D(LRLLOC) LRLLOC="" S LRNEWL=LRLLOC
S PNM="*** "_LRLLOC_" ***"
N LRLLOC S LRLLOC="LAB"
S LRDAT="XX/XX/XX",LRAN="0000"
S SSN="000-00-0000",LRACC="*NEW LOC*",LRCE="000"
S LRRB=1,LRPREF="SMALL ",LRURG0=9
S LRTOP="TEST TUBE",LRTS(1)="DON'T USE",LRTS(2)="This label"
D LBLTYP^LRLABLD
D LRBAR^LRLABLD
D UID^LRLABLD,BARID^LRLABLD ; Setup UID and barcode ID.
S LRURGA=$$URGA^LRLABLD(LRURG0) ; Setup urgency abbreviation
S LRINFW=" ",I=1,N=2,LRXL=0
U IO
D @LRLABEL
Q
;
LRPICK ; Choose type of output
K LRPICK
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="SO^1:List;2:Labels",DIR("?")="Enter 1 or 2."
S DIR("A")="Print a list or labels"
D ^DIR
I $D(DIRUT) S LREND=1
E S LRPICK=Y
Q
;
SELCOLTY ; Select collection Type(s) to Print
N DIR,DIRUT,DTOUT,DUOUT,LRCNT,X,Y
W !
K LRCOLTY
S LRCOLTY="I:IMM. LAB COLLECT;LC:LAB COLLECT;SP:SEND PATIENT;WC:WARD COLLECT"
F I=1:1 Q:$P(LRCOLTY,";",I)="" D
. S LRCNT=I ; number of items
. S DIR("A",I)=$J(I,5)_" "_$P($P(LRCOLTY,";",I),":",2)_" ("_$P($P(LRCOLTY,";",I),":",1)_")"
S DIR("A",LRCNT+1)=" "
S DIR("A")="Select Collection Type(s)"
S DIR(0)="LO^1:"_LRCNT_":0"
D ^DIR
I $D(DIRUT) S LREND=1 Q
F I=1:1 Q:'$P(Y,",",I) S LRCOLTY($P($P(LRCOLTY,";",$P(Y,",",I)),":"))=$P($P(LRCOLTY,";",$P(Y,",",I)),":",2)
Q
;
BLDTMP ; Build TMP global with order info.
; Called from above, LRLABLDS
N LRORDLOC
S DFN=+$P($G(^LR(LRDFN,0)),U,3),LRDPF=+$P(^(0),U,2)
I 'DFN!('LRDPF) Q
D PT^LRX
S LRORDLOC=$$GET1^DIQ(44,+$P(LRSN(0),U,9)_",",.01) ; Ordering location
I LRORDLOC="" S LRORDLOC="Unknown"
S ^TMP($J,"LR",LRODT,+$P(LRSN(0),U,8),$S($L(LRWRD):LRWRD_"/",1:"")_LRORDLOC,PNM,"*"_LRSN)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLABLD0 6016 printed Oct 16, 2024@18:16:49 Page 2
LRLABLD0 ;DALOI/FHS/DRH/JMC - LABELS ON DEMAND FOR FUTURE LAB COLLECT ;8/29/94 12:36
+1 ;;5.2;LAB SERVICE;**1,65,121,161,218,445**;Sep 27, 1994;Build 6
EN ;
+1 WRITE !?5,"Future Lab, Immediate, Ward Collect and Send Patient Orders"
+2 WRITE !?5,"Enter each date to print separately",!!
+3 NEW %DT,%ZIS,DIR,DIRUT,DTOUT,DUOUT,LRBATCH,LRCHLOC,LRCT0,LRDTC,X,Y,ZTSK,LRAA,LRAD,LRAN,LRUID
+4 SET (LN,LRSTOP,CNT,LREND)=0
SET (LRLOCF,LRCHLOC)=""
SET LRBATCH=1
+5 SET DT=$$DT^XLFDT
+6 SET %DT("A")="Print for what date(s): "
SET %DT="AEFX"
+7 ; Only allow future dates( >=DT)
SET %DT(0)=DT
+8 FOR
DO ^%DT
if Y<1
QUIT
SET LRCT0(Y)=""
IF '$ORDER(^LRO(69,+Y,1,0))
WRITE !?10,"No Orders For "_$$FMTE^XLFDT(Y)
KILL LRCT0(Y)
+9 IF '$ORDER(LRCT0(0))
WRITE !!?10,"Nothing selected ",!,$CHAR(7)
GOTO END
+10 DO LRPICK
if $GET(LREND)
GOTO END
+11 KILL DIR
+12 SET DIR(0)="S^1:Selected Locations;2:All Locations"
+13 SET DIR("A")="Choose one of the following"
SET DIR("?")="Enter 1 or 2."
+14 DO ^DIR
+15 IF $DATA(DIRUT)
DO END
QUIT
+16 SET LRCHLOC=Y
SELLOC IF LRCHLOC=1
Begin DoDot:1
+1 NEW DIC,DTOUT,DUOUT,X,Y
+2 SET DIC="^SC("
SET DIC(0)="AEMQZ"
+3 FOR
Begin DoDot:2
+4 DO ^DIC
+5 IF $DATA(DUOUT)!($DATA(DTOUT))
SET LREND=1
+6 IF Y>0
SET LRLOCF(+Y)=$PIECE(Y(0),U)
End DoDot:2
if Y<0
QUIT
+7 IF '$ORDER(LRLOCF(0))
WRITE !!?10,"No Locations Selected ",$CHAR(7)
SET LREND=1
End DoDot:1
+8 IF LREND
DO END
QUIT
+9 DO SELCOLTY
+10 IF LREND
DO END
QUIT
+11 SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO END
+12 IF $DATA(IO("Q"))
Begin DoDot:1
+13 NEW LRION
+14 SET LRION=ION
+15 SET ZTSAVE("LR*")=""
SET ZTRTN="QUE^LRLABLD0"
SET ZTDESC="Print future collection labels"
+16 DO ^%ZTLOAD
DO ^%ZISC
+17 WRITE !?10,$SELECT($GET(ZTSK):"Queued to "_LRION,1:"Task NOT queued"),!
+18 DO END
End DoDot:1
QUIT
+19 ;
QUE ; Tasked entry and interactive point.
+1 KILL ^TMP($JOB),LRDTC
+2 SET ^TMP($JOB)=$$NOW^XLFDT_"^"_$$FMADD^XLFDT(DT,1,0,0,0)
+3 SET (LN,LRSTOP,CNT,LRRB)=0
+4 SET LRODT=0
+5 FOR
SET LRODT=$ORDER(LRCT0(LRODT))
if LRODT=""
QUIT
Begin DoDot:1
+6 SET LRSN=0
+7 FOR
SET LRSN=$ORDER(^LRO(69,LRODT,1,LRSN))
if LRSN<1
QUIT
Begin DoDot:2
+8 NEW LREND
+9 SET LRSN(0)=$GET(^LRO(69,LRODT,1,LRSN,0))
SET LRSN(1)=$GET(^LRO(69,LRODT,1,LRSN,1))
+10 ; Skip lab controls
+11 IF $PIECE($GET(^LR(+LRSN(0),0)),"^",2)=62.3
QUIT
+12 ; Not selected location
+13 IF $ORDER(LRLOCF(0))
IF '$DATA(LRLOCF(+$PIECE(LRSN(0),U,9)))
QUIT
+14 ; No collection type
+15 IF $PIECE(LRSN(0),U,4)=""
QUIT
+16 ; Not selected collection type.
+17 IF '$DATA(LRCOLTY($PIECE(LRSN(0),U,4)))
QUIT
+18 SET LREND=0
DO CHK^LRLABLDS
if LREND
QUIT
+19 SET LRDFN=+LRSN(0)
DO BLDTMP
End DoDot:2
End DoDot:1
+20 DO ^LRLABELF
+21 DO END^LRLABELF
+22 QUIT
+23 ;
SETUP ; Called by LRLABELF
+1 SET Y2=1
SET LRRB=0
SET N=1
+2 SET (Y1,Y)=LRCT
+3 ; Date/time with "@" --> " "
SET LRDAT=$TRANSLATE($$FMTE^XLFDT(LRCT,"2M"),"@"," ")
+4 SET NODE=$GET(^LRO(69,LRODT,1,LRSN,0))
if '$LENGTH(NODE)
QUIT
SET LRCE=$GET(^(.1))
+5 SET LRCLTY=$PIECE(NODE,U,4)
+6 SET LRDFN=+NODE
SET DFN=$PIECE($GET(^LR(LRDFN,0)),U,3)
if 'DFN
QUIT
SET LRDPF=$PIECE(^(0),U,2)
SET LRINFW=$GET(^(.091))
+7 DO PT^LRX
+8 SET LRLLOC=$PIECE(NODE,U,7)
SET LRTVOL=0
+9 SET LRTJ=$PIECE(NODE,U,3)
+10 IF '$GET(LRSING)
IF $GET(LRNEWL)'=LRLLOC
DO SEP
+11 SET LRTJDATA=$SELECT($DATA(^LAB(62,+LRTJ,0)):^(0),1:"")
+12 SET LRTOP=$PIECE(LRTJDATA,U,3)
SET S1=$PIECE(LRTJDATA,U,4)
+13 SET S2=$PIECE(LRTJDATA,U,5)
if LRTOP=""
DO LRTOP
+14 DO T
+15 SET LRN=$SELECT(+S1=0:1,1:LRTVOL\S1+$SELECT(LRTVOL#S1:1,LRTVOL=0:1,1:0))+LRXL
+16 DO P
+17 QUIT
T ;
+1 if LRODT'>0
QUIT
+2 KILL LRTS,LRURG
+3 SET LRURG0=9
SET (LRXL,T)=0
+4 FOR
SET T=$ORDER(^LRO(69,LRODT,1,LRSN,2,T))
if T<.5
QUIT
Begin DoDot:1
+5 if '$GET(^LRO(69,LRODT,1,LRSN,2,T,0))
QUIT
SET LRTV=^(0)
+6 IF $PIECE(LRTV,"^",11)
QUIT
+7 DO T1
+8 SET LRTS(T)=$SELECT($DATA(^LAB(60,+LRTV,.1)):$PIECE(^(.1),U,1),1:"")
+9 ;Extra labels
SET LRXL=LRXL+$PIECE(^LAB(60,+LRTV,0),U,15)
End DoDot:1
+10 QUIT
T1 ;
+1 NEW X
+2 SET LRVOL=""
if $PIECE(LRTV,U,2)<3
SET LRURG=1
+3 IF $PIECE(LRTV,U,2)
IF $PIECE(LRTV,U,2)<LRURG0
SET LRURG0=$PIECE(LRTV,U,2)
+4 SET X=0
FOR
SET X=$ORDER(^LAB(60,+LRTV,3,X))
if X<1
QUIT
IF +$GET(^(X,0))=$PIECE(NODE,U,3)
SET LRVOL=$PIECE(^(0),U,4)
SET LRTVOL=LRTVOL+LRVOL
+5 QUIT
LRTOP ;
+1 ; Specimen from file #69
SET LRTOP=$GET(^LRO(69,LRODT,1,LRSN,4,1,0))
+2 ; Collection sample from file #69
SET T=$PIECE($GET(^LAB(62,+$PIECE($GET(NODE),U,3),0)),U,1)
+3 SET LRTOP=$PIECE($GET(^LAB(61,+LRTOP,0)),U)
+4 SET LRTOP=T_$SELECT(LRTOP'=T:" "_LRTOP,1:"")
+5 QUIT
P ;
+1 IF '$GET(LRSING)
if $SELECT('$DATA(LRNEWL)
DO SEP
+2 if LRN<1
QUIT
+3 NEW LRAA,LRBAR
+4 SET LRAA=0
+5 DO LBLTYP^LRLABLD
+6 DO LRBAR^LRLABLD
+7 SET LRACC=$PIECE($PIECE($$FMTE^XLFDT(LRCT,2),"@",2),":",1,2)_" "_LRCLTY
+8 ; Setup UID and barcode ID.
DO UID^LRLABLD
DO BARID^LRLABLD
+9 ; Setup urgency abbreviation
SET LRURGA=$$URGA^LRLABLD(LRURG0)
+10 USE IO
+11 FOR LRI=1:1:LRN
Begin DoDot:1
+12 ; Label routines use "I" and "N"
SET I=LRI
SET N=LRN
+13 NEW LRI,LRN
+14 SET LRPREF=$SELECT(S2="":"",LRTVOL>S2:"LARGE ",1:"SMALL ")
SET LRTVOL=LRTVOL-S1
+15 DO @LRLABEL
End DoDot:1
+16 QUIT
QUIT ;
END ;
+1 DO END^LRLABELF
+2 QUIT
SEP ;
+1 NEW LRAA,LRAN,LRACC,LRBAR,LRCE,LRURG0,LRXL
+2 NEW PNM,LRDAT,LRRB,SSN,LRTOP,LRINFW,LRTS,LRPREF,LRUID,I,N
+3 if '$DATA(LRLLOC)
SET LRLLOC=""
SET LRNEWL=LRLLOC
+4 SET PNM="*** "_LRLLOC_" ***"
+5 NEW LRLLOC
SET LRLLOC="LAB"
+6 SET LRDAT="XX/XX/XX"
SET LRAN="0000"
+7 SET SSN="000-00-0000"
SET LRACC="*NEW LOC*"
SET LRCE="000"
+8 SET LRRB=1
SET LRPREF="SMALL "
SET LRURG0=9
+9 SET LRTOP="TEST TUBE"
SET LRTS(1)="DON'T USE"
SET LRTS(2)="This label"
+10 DO LBLTYP^LRLABLD
+11 DO LRBAR^LRLABLD
+12 ; Setup UID and barcode ID.
DO UID^LRLABLD
DO BARID^LRLABLD
+13 ; Setup urgency abbreviation
SET LRURGA=$$URGA^LRLABLD(LRURG0)
+14 SET LRINFW=" "
SET I=1
SET N=2
SET LRXL=0
+15 USE IO
+16 DO @LRLABEL
+17 QUIT
+18 ;
LRPICK ; Choose type of output
+1 KILL LRPICK
+2 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+3 SET DIR(0)="SO^1:List;2:Labels"
SET DIR("?")="Enter 1 or 2."
+4 SET DIR("A")="Print a list or labels"
+5 DO ^DIR
+6 IF $DATA(DIRUT)
SET LREND=1
+7 IF '$TEST
SET LRPICK=Y
+8 QUIT
+9 ;
SELCOLTY ; Select collection Type(s) to Print
+1 NEW DIR,DIRUT,DTOUT,DUOUT,LRCNT,X,Y
+2 WRITE !
+3 KILL LRCOLTY
+4 SET LRCOLTY="I:IMM. LAB COLLECT;LC:LAB COLLECT;SP:SEND PATIENT;WC:WARD COLLECT"
+5 FOR I=1:1
if $PIECE(LRCOLTY,";",I)=""
QUIT
Begin DoDot:1
+6 ; number of items
SET LRCNT=I
+7 SET DIR("A",I)=$JUSTIFY(I,5)_" "_$PIECE($PIECE(LRCOLTY,";",I),":",2)_" ("_$PIECE($PIECE(LRCOLTY,";",I),":",1)_")"
End DoDot:1
+8 SET DIR("A",LRCNT+1)=" "
+9 SET DIR("A")="Select Collection Type(s)"
+10 SET DIR(0)="LO^1:"_LRCNT_":0"
+11 DO ^DIR
+12 IF $DATA(DIRUT)
SET LREND=1
QUIT
+13 FOR I=1:1
if '$PIECE(Y,",",I)
QUIT
SET LRCOLTY($PIECE($PIECE(LRCOLTY,";",$PIECE(Y,",",I)),":"))=$PIECE($PIECE(LRCOLTY,";",$PIECE(Y,",",I)),":",2)
+14 QUIT
+15 ;
BLDTMP ; Build TMP global with order info.
+1 ; Called from above, LRLABLDS
+2 NEW LRORDLOC
+3 SET DFN=+$PIECE($GET(^LR(LRDFN,0)),U,3)
SET LRDPF=+$PIECE(^(0),U,2)
+4 IF 'DFN!('LRDPF)
QUIT
+5 DO PT^LRX
+6 ; Ordering location
SET LRORDLOC=$$GET1^DIQ(44,+$PIECE(LRSN(0),U,9)_",",.01)
+7 IF LRORDLOC=""
SET LRORDLOC="Unknown"
+8 SET ^TMP($JOB,"LR",LRODT,+$PIECE(LRSN(0),U,8),$SELECT($LENGTH(LRWRD):LRWRD_"/",1:"")_LRORDLOC,PNM,"*"_LRSN)=""
+9 QUIT
