LRWRKLS1 ;DALOI/STAFF - LRWRKLST, CONT. ;12/06/10 17:05
;;5.2;LAB SERVICE;**121,153,185,268,350**;Sep 27, 1994;Build 230
;
LST1 ;from LRWRKLST
D CHKPAGE
Q:$G(LRSTOP)=1
S LRDX=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRCE=$S($D(^(.1)):^(.1),1:""),LRACC=$S($D(^(.2)):^(.2),1:"")
Q:'$D(^LR(+LRDX,0))#2
;
S LRDPF=$P(^LR(+LRDX,0),U,2),DFN=$P(^(0),U,3)
D PT^LRX
;
S (LRDLA,LRDLC,LRACO)=""
I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) D
. N LRY
. S LRY=^LRO(68,LRAA,1,LRAD,1,LRAN,3),LRACO=$P(LRY,U,6)
. S LRDLC=$$FMTE^XLFDT($P(LRY,"^"),"MZ")
. S LRDLA=$$FMTE^XLFDT($P(LRY,"^",3),"MZ")
S LRDTO=$$FMTE^XLFDT($P(LRDX,"^",4),"MZ")
;
W ! D DASH^LRX
;
S LN=$G(LN)+1
D CHKPAGE
Q:$G(LRSTOP)
;
W !,"ACCESSION: ",LRACC,?40,"PATIENT: ",PNM
W !," ORDER #: ",LRCE,?41,"SSN/ID: ",SSN,!
S X=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
W:X'="" ?6,"UID: ",X
W ?44,"DOB: ",$$FMTE^XLFDT(DOB,"MZ")
W !," LOCATION: ",$E($P(LRDX,"^",7),1,19)
W:LRDTO'="" ?35,"DATE ORDERED: ",LRDTO,!
W:$P(LRDX,U,6) " IDENTITY: ",$P(LRDX,U,6)
W:LRDLC'="" ?38,"COLLECTED: ",LRDLC
;
S (LRPRAC,LRX)=$P(LRDX,"^",8)
I LRPRAC S LRX=$$GET1^DIQ(200,LRPRAC_",",.01)
I LRX="" S LRX=$S(LRPRAC'="":LRPRAC,1:"UNKNOWN")
W !," PROVIDER: ",LRX
W:LRDLA'="" ?36,"LAB ARRIVAL: ",LRDLA
S LN=$G(LN)+6
;
N PRAC,PR
D PRAC^LR7OMERG(LRAA,LRAD,LRAN,.PRAC)
S PR=0
F S PR=$O(PRAC(PR)) Q:PR<1 W !?11,$$GET1^DIQ(200,PR_",",.01) S LN=LN+1
;
D CHKPAGE
Q:$G(LRSTOP)=1
;
;
D LEDI
;
; Find and print order comments from file #69
S X1=+$P(LRDX,U,4),X2=+$P(LRDX,U,5)
I $D(^LRO(69,X1,1,X2,6)) D
. W !," Order Comment:" S LN=LN+1
. S I=0
. F S I=$O(^LRO(69,X1,1,X2,6,I)) Q:I<1 W !?11,^(I,0) S LN=LN+1 D CHKPAGE Q:$G(LRSTOP)
;
;
TSTCOM ; Display test comments
;
N LRI,LRX,LRY
;
Q:$G(LRSTOP)
;
; Check for canceled test and print test and cancel reason
S LRI=0
F S LRI=$O(^LRO(69,X1,1,X2,2,LRI)) Q:LRI<1 D
. S LRX=$G(^LRO(69,X1,1,X2,2,LRI,0))
. I '$P(LRX,"^",11) Q
. W !," CANCELED TEST: ",$P($G(^LAB(60,+LRX,0),"UNKNOWN"),"^")
. W " "_$E($P($G(^LAB(62.05,+$P(LRX,"^",2),0),"ROUTINE"),"^"),1,15)
. W " by: "_$$GET1^DIQ(200,+$P(LRX,"^",11)_",",.01)
. S LN=LN+1,LRI(2)=0
. F S LRI(2)=$O(^LRO(69,X1,1,X2,2,LRI,1.1,LRI(2))) Q:LRI(2)<1 D Q:$G(LRSTOP)
. . S LRY=$G(^LRO(69,X1,1,X2,2,LRI,1.1,LRI(2),0))
. . W !?3,": "_LRY
. . S LN=LN+1 D CHKPAGE
;
I LRACO'="" W !," Accession Comment: ",LRACO S LN=LN+1
;
I $L($P(LRDX,U,6,7))>1 W ! S LN=LN+1
Q
;
;
CHKPAGE ;
;
;ZEXCEPT: LN,LREND,LRSTOP,ZTQUEUED,ZTSTOP
;
; Check if task and user wants to stop task.
I $D(ZTQUEUED),$$S^%ZTLOAD D Q
. S (LRSTOP,ZTSTOP)=1
. W !!,"*** Report requested to stop by TaskMan ***"
. W !,"*** Task #",$G(ZTQUEUED,"UNKNOWN")," stopped at ",$$HTE^XLFDT($H)," ***"
;
Q:$G(LRSTOP)!($D(ZTQUEUED))!($E(IOST,1,2)'="C-")
Q:$G(LN)<(IOSL-2)
;
N DIR,DIRUT,DIROUT,DUOUT,X,Y
S DIR(0)="E"
D ^DIR
I $D(DIRUT) S (LREND,LRSTOP)=1
S LN=1
W !
Q
;
;
LEDI ; print LEDI information
;
;ZEXCEPT: LRDX,LN,LRAA,LRAD,LRAN,LRDFN
;
N LRDFN,LRIDT,LRIENS,LRSS,LRTYPE,LRUID,LRX,LRY
;
S LRDFN=+LRDX
S LRY=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),LRIENS=LRAN_","_LRAD_","_LRAA_","
;
S LRX=$$GET1^DIQ(68.02,LRIENS,16.1),LRUID=$P(LRY,"^",5)
I LRX'=""!(LRUID'="") D
. W !!
. I LRX'="" W $J($$GET1^DID(68.02,16.2,"","LABEL")_": ",17),$E(LRX,1,20)
. I LRUID'="" W ?40,$$GET1^DID(68.02,16.4,"","LABEL"),": ",LRUID
. S LN=LN+2
;
S LRX=$$GET1^DIQ(68.02,LRIENS,16.2)
I LRX'="" D
. W !,$J($$GET1^DID(68.02,16.1,"","LABEL")_": ",17),$E(LRX,1,20)
. S LN=LN+1
;
S LRY=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
S LRIDT=$P(LRY,"^",5),LRSS=$P($G(^LRO(68,LRAA,0)),"^",2)
I LRIDT<1 Q
S LRIENS=LRDFN_","_LRSS_","_LRIDT_",0"
;
; Display external order info (placer/filler) if any.
F LRTYPE=3,4 I $D(^LR(LRDFN,"EPR","AD",LRIENS,LRTYPE)) D
. N LRDATA,LRON,LRREF,LRJ
. S LRJ=$O(^LR(LRDFN,"EPR","AD",LRIENS,LRTYPE,0)),LRREF=LRJ_","_LRDFN_","
. D GETDATA^LRUEPR(.LRDATA,LRREF)
. S LRON=$G(LRDATA(63.00013,LRREF,1,"I")),LRON(0)="Unknown"
. I LRON="" Q
. I $P($G(LRDATA(63.00013,LRREF,.03,"I")),";",2)="DIC(4," S LRON(0)=$P($$NS^XUAF4(+LRDATA(63.00013,LRREF,.03,"I")),"^")
. W !,?4,LRON(0)_$S(LRTYPE=3:" placer",1:" filler")_" order # "_LRON
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRWRKLS1 4335 printed Apr 09, 2024@21:18:44 Page 2
LRWRKLS1 ;DALOI/STAFF - LRWRKLST, CONT. ;12/06/10 17:05
+1 ;;5.2;LAB SERVICE;**121,153,185,268,350**;Sep 27, 1994;Build 230
+2 ;
LST1 ;from LRWRKLST
+1 DO CHKPAGE
+2 if $GET(LRSTOP)=1
QUIT
+3 SET LRDX=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRCE=$SELECT($DATA(^(.1)):^(.1),1:"")
SET LRACC=$SELECT($DATA(^(.2)):^(.2),1:"")
+4 if '$DATA(^LR(+LRDX,0))#2
QUIT
+5 ;
+6 SET LRDPF=$PIECE(^LR(+LRDX,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+7 DO PT^LRX
+8 ;
+9 SET (LRDLA,LRDLC,LRACO)=""
+10 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
Begin DoDot:1
+11 NEW LRY
+12 SET LRY=^LRO(68,LRAA,1,LRAD,1,LRAN,3)
SET LRACO=$PIECE(LRY,U,6)
+13 SET LRDLC=$$FMTE^XLFDT($PIECE(LRY,"^"),"MZ")
+14 SET LRDLA=$$FMTE^XLFDT($PIECE(LRY,"^",3),"MZ")
End DoDot:1
+15 SET LRDTO=$$FMTE^XLFDT($PIECE(LRDX,"^",4),"MZ")
+16 ;
+17 WRITE !
DO DASH^LRX
+18 ;
+19 SET LN=$GET(LN)+1
+20 DO CHKPAGE
+21 if $GET(LRSTOP)
QUIT
+22 ;
+23 WRITE !,"ACCESSION: ",LRACC,?40,"PATIENT: ",PNM
+24 WRITE !," ORDER #: ",LRCE,?41,"SSN/ID: ",SSN,!
+25 SET X=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
+26 if X'=""
WRITE ?6,"UID: ",X
+27 WRITE ?44,"DOB: ",$$FMTE^XLFDT(DOB,"MZ")
+28 WRITE !," LOCATION: ",$EXTRACT($PIECE(LRDX,"^",7),1,19)
+29 if LRDTO'=""
WRITE ?35,"DATE ORDERED: ",LRDTO,!
+30 if $PIECE(LRDX,U,6)
WRITE " IDENTITY: ",$PIECE(LRDX,U,6)
+31 if LRDLC'=""
WRITE ?38,"COLLECTED: ",LRDLC
+32 ;
+33 SET (LRPRAC,LRX)=$PIECE(LRDX,"^",8)
+34 IF LRPRAC
SET LRX=$$GET1^DIQ(200,LRPRAC_",",.01)
+35 IF LRX=""
SET LRX=$SELECT(LRPRAC'="":LRPRAC,1:"UNKNOWN")
+36 WRITE !," PROVIDER: ",LRX
+37 if LRDLA'=""
WRITE ?36,"LAB ARRIVAL: ",LRDLA
+38 SET LN=$GET(LN)+6
+39 ;
+40 NEW PRAC,PR
+41 DO PRAC^LR7OMERG(LRAA,LRAD,LRAN,.PRAC)
+42 SET PR=0
+43 FOR
SET PR=$ORDER(PRAC(PR))
if PR<1
QUIT
WRITE !?11,$$GET1^DIQ(200,PR_",",.01)
SET LN=LN+1
+44 ;
+45 DO CHKPAGE
+46 if $GET(LRSTOP)=1
QUIT
+47 ;
+48 ;
+49 DO LEDI
+50 ;
+51 ; Find and print order comments from file #69
+52 SET X1=+$PIECE(LRDX,U,4)
SET X2=+$PIECE(LRDX,U,5)
+53 IF $DATA(^LRO(69,X1,1,X2,6))
Begin DoDot:1
+54 WRITE !," Order Comment:"
SET LN=LN+1
+55 SET I=0
+56 FOR
SET I=$ORDER(^LRO(69,X1,1,X2,6,I))
if I<1
QUIT
WRITE !?11,^(I,0)
SET LN=LN+1
DO CHKPAGE
if $GET(LRSTOP)
QUIT
End DoDot:1
+57 ;
+58 ;
TSTCOM ; Display test comments
+1 ;
+2 NEW LRI,LRX,LRY
+3 ;
+4 if $GET(LRSTOP)
QUIT
+5 ;
+6 ; Check for canceled test and print test and cancel reason
+7 SET LRI=0
+8 FOR
SET LRI=$ORDER(^LRO(69,X1,1,X2,2,LRI))
if LRI<1
QUIT
Begin DoDot:1
+9 SET LRX=$GET(^LRO(69,X1,1,X2,2,LRI,0))
+10 IF '$PIECE(LRX,"^",11)
QUIT
+11 WRITE !," CANCELED TEST: ",$PIECE($GET(^LAB(60,+LRX,0),"UNKNOWN"),"^")
+12 WRITE " "_$EXTRACT($PIECE($GET(^LAB(62.05,+$PIECE(LRX,"^",2),0),"ROUTINE"),"^"),1,15)
+13 WRITE " by: "_$$GET1^DIQ(200,+$PIECE(LRX,"^",11)_",",.01)
+14 SET LN=LN+1
SET LRI(2)=0
+15 FOR
SET LRI(2)=$ORDER(^LRO(69,X1,1,X2,2,LRI,1.1,LRI(2)))
if LRI(2)<1
QUIT
Begin DoDot:2
+16 SET LRY=$GET(^LRO(69,X1,1,X2,2,LRI,1.1,LRI(2),0))
+17 WRITE !?3,": "_LRY
+18 SET LN=LN+1
DO CHKPAGE
End DoDot:2
if $GET(LRSTOP)
QUIT
End DoDot:1
+19 ;
+20 IF LRACO'=""
WRITE !," Accession Comment: ",LRACO
SET LN=LN+1
+21 ;
+22 IF $LENGTH($PIECE(LRDX,U,6,7))>1
WRITE !
SET LN=LN+1
+23 QUIT
+24 ;
+25 ;
CHKPAGE ;
+1 ;
+2 ;ZEXCEPT: LN,LREND,LRSTOP,ZTQUEUED,ZTSTOP
+3 ;
+4 ; Check if task and user wants to stop task.
+5 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
Begin DoDot:1
+6 SET (LRSTOP,ZTSTOP)=1
+7 WRITE !!,"*** Report requested to stop by TaskMan ***"
+8 WRITE !,"*** Task #",$GET(ZTQUEUED,"UNKNOWN")," stopped at ",$$HTE^XLFDT($HOROLOG)," ***"
End DoDot:1
QUIT
+9 ;
+10 if $GET(LRSTOP)!($DATA(ZTQUEUED))!($EXTRACT(IOST,1,2)'="C-")
QUIT
+11 if $GET(LN)<(IOSL-2)
QUIT
+12 ;
+13 NEW DIR,DIRUT,DIROUT,DUOUT,X,Y
+14 SET DIR(0)="E"
+15 DO ^DIR
+16 IF $DATA(DIRUT)
SET (LREND,LRSTOP)=1
+17 SET LN=1
+18 WRITE !
+19 QUIT
+20 ;
+21 ;
LEDI ; print LEDI information
+1 ;
+2 ;ZEXCEPT: LRDX,LN,LRAA,LRAD,LRAN,LRDFN
+3 ;
+4 NEW LRDFN,LRIDT,LRIENS,LRSS,LRTYPE,LRUID,LRX,LRY
+5 ;
+6 SET LRDFN=+LRDX
+7 SET LRY=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
SET LRIENS=LRAN_","_LRAD_","_LRAA_","
+8 ;
+9 SET LRX=$$GET1^DIQ(68.02,LRIENS,16.1)
SET LRUID=$PIECE(LRY,"^",5)
+10 IF LRX'=""!(LRUID'="")
Begin DoDot:1
+11 WRITE !!
+12 IF LRX'=""
WRITE $JUSTIFY($$GET1^DID(68.02,16.2,"","LABEL")_": ",17),$EXTRACT(LRX,1,20)
+13 IF LRUID'=""
WRITE ?40,$$GET1^DID(68.02,16.4,"","LABEL"),": ",LRUID
+14 SET LN=LN+2
End DoDot:1
+15 ;
+16 SET LRX=$$GET1^DIQ(68.02,LRIENS,16.2)
+17 IF LRX'=""
Begin DoDot:1
+18 WRITE !,$JUSTIFY($$GET1^DID(68.02,16.1,"","LABEL")_": ",17),$EXTRACT(LRX,1,20)
+19 SET LN=LN+1
End DoDot:1
+20 ;
+21 SET LRY=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
+22 SET LRIDT=$PIECE(LRY,"^",5)
SET LRSS=$PIECE($GET(^LRO(68,LRAA,0)),"^",2)
+23 IF LRIDT<1
QUIT
+24 SET LRIENS=LRDFN_","_LRSS_","_LRIDT_",0"
+25 ;
+26 ; Display external order info (placer/filler) if any.
+27 FOR LRTYPE=3,4
IF $DATA(^LR(LRDFN,"EPR","AD",LRIENS,LRTYPE))
Begin DoDot:1
+28 NEW LRDATA,LRON,LRREF,LRJ
+29 SET LRJ=$ORDER(^LR(LRDFN,"EPR","AD",LRIENS,LRTYPE,0))
SET LRREF=LRJ_","_LRDFN_","
+30 DO GETDATA^LRUEPR(.LRDATA,LRREF)
+31 SET LRON=$GET(LRDATA(63.00013,LRREF,1,"I"))
SET LRON(0)="Unknown"
+32 IF LRON=""
QUIT
+33 IF $PIECE($GET(LRDATA(63.00013,LRREF,.03,"I")),";",2)="DIC(4,"
SET LRON(0)=$PIECE($$NS^XUAF4(+LRDATA(63.00013,LRREF,.03,"I")),"^")
+34 WRITE !,?4,LRON(0)_$SELECT(LRTYPE=3:" placer",1:" filler")_" order # "_LRON
End DoDot:1
+35 ;
+36 QUIT
