Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRLABLD0

LRLABLD0.m

Go to the documentation of this file.
  1. 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
  1. EN ;
  1. W !?5,"Future Lab, Immediate, Ward Collect and Send Patient Orders"
  1. W !?5,"Enter each date to print separately",!!
  1. N %DT,%ZIS,DIR,DIRUT,DTOUT,DUOUT,LRBATCH,LRCHLOC,LRCT0,LRDTC,X,Y,ZTSK,LRAA,LRAD,LRAN,LRUID
  1. S (LN,LRSTOP,CNT,LREND)=0,(LRLOCF,LRCHLOC)="",LRBATCH=1
  1. S DT=$$DT^XLFDT
  1. S %DT("A")="Print for what date(s): ",%DT="AEFX"
  1. S %DT(0)=DT ; Only allow future dates( >=DT)
  1. 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)
  1. I '$O(LRCT0(0)) W !!?10,"Nothing selected ",!,$C(7) G END
  1. D LRPICK G:$G(LREND) END
  1. K DIR
  1. S DIR(0)="S^1:Selected Locations;2:All Locations"
  1. S DIR("A")="Choose one of the following",DIR("?")="Enter 1 or 2."
  1. D ^DIR
  1. I $D(DIRUT) D END Q
  1. S LRCHLOC=Y
  1. SELLOC I LRCHLOC=1 D
  1. . N DIC,DTOUT,DUOUT,X,Y
  1. . S DIC="^SC(",DIC(0)="AEMQZ"
  1. . F D Q:Y<0
  1. . . D ^DIC
  1. . . I $D(DUOUT)!($D(DTOUT)) S LREND=1
  1. . . I Y>0 S LRLOCF(+Y)=$P(Y(0),U)
  1. . I '$O(LRLOCF(0)) W !!?10,"No Locations Selected ",$C(7) S LREND=1
  1. I LREND D END Q
  1. D SELCOLTY
  1. I LREND D END Q
  1. S %ZIS="Q" D ^%ZIS G END:POP
  1. I $D(IO("Q")) D Q
  1. . N LRION
  1. . S LRION=ION
  1. . S ZTSAVE("LR*")="",ZTRTN="QUE^LRLABLD0",ZTDESC="Print future collection labels"
  1. . D ^%ZTLOAD,^%ZISC
  1. . W !?10,$S($G(ZTSK):"Queued to "_LRION,1:"Task NOT queued"),!
  1. . D END
  1. ;
  1. QUE ; Tasked entry and interactive point.
  1. K ^TMP($J),LRDTC
  1. S ^TMP($J)=$$NOW^XLFDT_"^"_$$FMADD^XLFDT(DT,1,0,0,0)
  1. S (LN,LRSTOP,CNT,LRRB)=0
  1. S LRODT=0
  1. F S LRODT=$O(LRCT0(LRODT)) Q:LRODT="" D
  1. . S LRSN=0
  1. . F S LRSN=$O(^LRO(69,LRODT,1,LRSN)) Q:LRSN<1 D
  1. . . N LREND
  1. . . S LRSN(0)=$G(^LRO(69,LRODT,1,LRSN,0)),LRSN(1)=$G(^LRO(69,LRODT,1,LRSN,1))
  1. . . ; Skip lab controls
  1. . . I $P($G(^LR(+LRSN(0),0)),"^",2)=62.3 Q
  1. . . ; Not selected location
  1. . . I $O(LRLOCF(0)),'$D(LRLOCF(+$P(LRSN(0),U,9))) Q
  1. . . ; No collection type
  1. . . I $P(LRSN(0),U,4)="" Q
  1. . . ; Not selected collection type.
  1. . . I '$D(LRCOLTY($P(LRSN(0),U,4))) Q
  1. . . S LREND=0 D CHK^LRLABLDS Q:LREND
  1. . . S LRDFN=+LRSN(0) D BLDTMP
  1. D ^LRLABELF
  1. D END^LRLABELF
  1. Q
  1. ;
  1. SETUP ; Called by LRLABELF
  1. S Y2=1,LRRB=0,N=1
  1. S (Y1,Y)=LRCT
  1. S LRDAT=$TR($$FMTE^XLFDT(LRCT,"2M"),"@"," ") ; Date/time with "@" --> " "
  1. S NODE=$G(^LRO(69,LRODT,1,LRSN,0)) Q:'$L(NODE) S LRCE=$G(^(.1))
  1. S LRCLTY=$P(NODE,U,4)
  1. S LRDFN=+NODE,DFN=$P($G(^LR(LRDFN,0)),U,3) Q:'DFN S LRDPF=$P(^(0),U,2),LRINFW=$G(^(.091))
  1. D PT^LRX
  1. S LRLLOC=$P(NODE,U,7),LRTVOL=0
  1. S LRTJ=$P(NODE,U,3)
  1. I '$G(LRSING),$G(LRNEWL)'=LRLLOC D SEP
  1. S LRTJDATA=$S($D(^LAB(62,+LRTJ,0)):^(0),1:"")
  1. S LRTOP=$P(LRTJDATA,U,3),S1=$P(LRTJDATA,U,4)
  1. S S2=$P(LRTJDATA,U,5) D:LRTOP="" LRTOP
  1. D T
  1. S LRN=$S(+S1=0:1,1:LRTVOL\S1+$S(LRTVOL#S1:1,LRTVOL=0:1,1:0))+LRXL
  1. D P
  1. Q
  1. T ;
  1. Q:LRODT'>0
  1. K LRTS,LRURG
  1. S LRURG0=9,(LRXL,T)=0
  1. F S T=$O(^LRO(69,LRODT,1,LRSN,2,T)) Q:T<.5 D
  1. . Q:'$G(^LRO(69,LRODT,1,LRSN,2,T,0)) S LRTV=^(0)
  1. . I $P(LRTV,"^",11) Q
  1. . D T1
  1. . S LRTS(T)=$S($D(^LAB(60,+LRTV,.1)):$P(^(.1),U,1),1:"")
  1. . S LRXL=LRXL+$P(^LAB(60,+LRTV,0),U,15) ;Extra labels
  1. Q
  1. T1 ;
  1. N X
  1. S LRVOL="" S:$P(LRTV,U,2)<3 LRURG=1
  1. I $P(LRTV,U,2),$P(LRTV,U,2)<LRURG0 S LRURG0=$P(LRTV,U,2)
  1. 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
  1. Q
  1. LRTOP ;
  1. S LRTOP=$G(^LRO(69,LRODT,1,LRSN,4,1,0)) ; Specimen from file #69
  1. S T=$P($G(^LAB(62,+$P($G(NODE),U,3),0)),U,1) ; Collection sample from file #69
  1. S LRTOP=$P($G(^LAB(61,+LRTOP,0)),U)
  1. S LRTOP=T_$S(LRTOP'=T:" "_LRTOP,1:"")
  1. Q
  1. P ;
  1. I '$G(LRSING) D:$S('$D(LRNEWL):1,(LRNEWL'=LRLLOC):1,1:0) SEP
  1. Q:LRN<1
  1. N LRAA,LRBAR
  1. S LRAA=0
  1. D LBLTYP^LRLABLD
  1. D LRBAR^LRLABLD
  1. S LRACC=$P($P($$FMTE^XLFDT(LRCT,2),"@",2),":",1,2)_" "_LRCLTY
  1. D UID^LRLABLD,BARID^LRLABLD ; Setup UID and barcode ID.
  1. S LRURGA=$$URGA^LRLABLD(LRURG0) ; Setup urgency abbreviation
  1. U IO
  1. F LRI=1:1:LRN D
  1. . S I=LRI,N=LRN ; Label routines use "I" and "N"
  1. . N LRI,LRN
  1. . S LRPREF=$S(S2="":"",LRTVOL>S2:"LARGE ",1:"SMALL "),LRTVOL=LRTVOL-S1
  1. . D @LRLABEL
  1. Q
  1. QUIT ;
  1. END ;
  1. D END^LRLABELF
  1. Q
  1. SEP ;
  1. N LRAA,LRAN,LRACC,LRBAR,LRCE,LRURG0,LRXL
  1. N PNM,LRDAT,LRRB,SSN,LRTOP,LRINFW,LRTS,LRPREF,LRUID,I,N
  1. S:'$D(LRLLOC) LRLLOC="" S LRNEWL=LRLLOC
  1. S PNM="*** "_LRLLOC_" ***"
  1. N LRLLOC S LRLLOC="LAB"
  1. S LRDAT="XX/XX/XX",LRAN="0000"
  1. S SSN="000-00-0000",LRACC="*NEW LOC*",LRCE="000"
  1. S LRRB=1,LRPREF="SMALL ",LRURG0=9
  1. S LRTOP="TEST TUBE",LRTS(1)="DON'T USE",LRTS(2)="This label"
  1. D LBLTYP^LRLABLD
  1. D LRBAR^LRLABLD
  1. D UID^LRLABLD,BARID^LRLABLD ; Setup UID and barcode ID.
  1. S LRURGA=$$URGA^LRLABLD(LRURG0) ; Setup urgency abbreviation
  1. S LRINFW=" ",I=1,N=2,LRXL=0
  1. U IO
  1. D @LRLABEL
  1. Q
  1. ;
  1. LRPICK ; Choose type of output
  1. K LRPICK
  1. N DIR,DIRUT,DTOUT,DUOUT,X,Y
  1. S DIR(0)="SO^1:List;2:Labels",DIR("?")="Enter 1 or 2."
  1. S DIR("A")="Print a list or labels"
  1. D ^DIR
  1. I $D(DIRUT) S LREND=1
  1. E S LRPICK=Y
  1. Q
  1. ;
  1. SELCOLTY ; Select collection Type(s) to Print
  1. N DIR,DIRUT,DTOUT,DUOUT,LRCNT,X,Y
  1. W !
  1. K LRCOLTY
  1. S LRCOLTY="I:IMM. LAB COLLECT;LC:LAB COLLECT;SP:SEND PATIENT;WC:WARD COLLECT"
  1. F I=1:1 Q:$P(LRCOLTY,";",I)="" D
  1. . S LRCNT=I ; number of items
  1. . S DIR("A",I)=$J(I,5)_" "_$P($P(LRCOLTY,";",I),":",2)_" ("_$P($P(LRCOLTY,";",I),":",1)_")"
  1. S DIR("A",LRCNT+1)=" "
  1. S DIR("A")="Select Collection Type(s)"
  1. S DIR(0)="LO^1:"_LRCNT_":0"
  1. D ^DIR
  1. I $D(DIRUT) S LREND=1 Q
  1. F I=1:1 Q:'$P(Y,",",I) S LRCOLTY($P($P(LRCOLTY,";",$P(Y,",",I)),":"))=$P($P(LRCOLTY,";",$P(Y,",",I)),":",2)
  1. Q
  1. ;
  1. BLDTMP ; Build TMP global with order info.
  1. ; Called from above, LRLABLDS
  1. N LRORDLOC
  1. S DFN=+$P($G(^LR(LRDFN,0)),U,3),LRDPF=+$P(^(0),U,2)
  1. I 'DFN!('LRDPF) Q
  1. D PT^LRX
  1. S LRORDLOC=$$GET1^DIQ(44,+$P(LRSN(0),U,9)_",",.01) ; Ordering location
  1. I LRORDLOC="" S LRORDLOC="Unknown"
  1. S ^TMP($J,"LR",LRODT,+$P(LRSN(0),U,8),$S($L(LRWRD):LRWRD_"/",1:"")_LRORDLOC,PNM,"*"_LRSN)=""
  1. Q