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