LRWRKLS1 ;DALOI/CJS/DRH - LRWRKLST, CONT. ; 13-Oct-2017 14:04 ; MKK
;;5.2;LAB SERVICE;**1003,1004,121,153,185,268,1018,1025,1027,1041**;NOV 01, 1997;Build 23
;
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,"^"),"5MZ")
. S LRDLA=$$FMTE^XLFDT($P(LRY,"^",3),"5MZ")
S LRDTO=$$FMTE^XLFDT($P(LRDX,"^",4),"5MZ")
;
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,!
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
W !," ORDER #: ",LRCE,?43,"HRCN: ",HRCN,!
;----- END IHS MODIFICATIONS - NOTE- COULD NOT COPY DIRECT FROM IHS RTN
S X=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
W:X'="" ?6,"UID: ",X
W ?44,"DOB: ",$$FMTE^XLFDT(DOB,"5MZ")
W !," LOCATION: ",$E($P(LRDX,"^",7),1,19)
; W:$L(LRDTO) ?35,"DATE ORDERED: ",LRDTO,!
; ----- BEGIN IHS LR*5.2*1025 MODIFICATION
; I $D(LRCE)>0 D ; Does Order exist
I +$G(LRCE)>0 D ; Does Order exist -- LR*5.2*1027
. NEW DTTORD,FMDTORD,LRORDIEN
. S FMDTORD=+$O(^LRO(69,"C",LRCE,"")) ; Date Ordred
. I FMDTORD<1 Q ; If null, skip
. S LRORDIEN=+$O(^LRO(69,"C",LRCE,FMDTORD,"")) ; LRAN of Order
. I LRORDIEN<1 Q ; If null, skip
. S DTTORD=+$P($G(^LRO(69,FMDTORD,1,LRORDIEN,0)),"^",5) ; Date/Time of Order
. I $D(DTTORD)<1 Q ; If null, skip
. ;
. W ?40,"ORDERED: ",$$FMTE^XLFDT(DTTORD,"5MZ"),!
; ----- END IHS LR*5.2*1025 MODIFICATION
W:$P(LRDX,U,6) " IDENTITY: ",$P(LRDX,U,6)
W:$L(LRDLC) ?38,"COLLECTED: ",LRDLC
;
S (LRPRAC,LRX)=$P(LRDX,"^",8)
I LRPRAC S LRX=$$GET1^DIQ(200,LRPRAC_",",.01)
I LRX="" S LRX=$S($L(LRPRAC):LRPRAC,1:"UNKNOWN")
W !," PROVIDER: ",LRX
W:$L(LRDLA) ?36,"LAB ARRIVAL: ",LRDLA
S LN=$G(LN)+6
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
W !," ACCESSION PERSON: ",$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA,"LOG-IN PERSON")
S LN=$G(LN)+1
; ----- END IHS/MSC/MKK - LR*5.2*1041
;
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 $L(LRACO) W !," Accession Comment: ",LRACO S LN=LN+1
;
I $L($P(LRDX,U,6,7))>1 W ! S LN=LN+1
Q
;
;
CHKPAGE ;
; 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)
K DIR
S DIR(0)="E"
D ^DIR
I $D(DIRUT) S (LREND,LRSTOP)=1
S LN=1
W !
Q
;
;
LEDI ; print LEDI information
;
N LRIENS,LRUID,LRX,LRY
;
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 $L(LRX)!($L(LRUID)) D
. W !!
. I $L(LRX) W $J($$GET1^DID(68.02,16.2,"","LABEL")_": ",17),$E(LRX,1,20)
. I $L(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 $L(LRX) D
. W !,$J($$GET1^DID(68.02,16.1,"","LABEL")_": ",17),$E(LRX,1,20)
. S LN=LN+1
;
Q
LRWRKLS1 ;DALOI/CJS/DRH - LRWRKLST, CONT. ; 13-Oct-2017 14:04 ; MKK
+1 ;;5.2;LAB SERVICE;**1003,1004,121,153,185,268,1018,1025,1027,1041**;NOV 01, 1997;Build 23
+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,"^"),"5MZ")
+14 SET LRDLA=$$FMTE^XLFDT($PIECE(LRY,"^",3),"5MZ")
End DoDot:1
+15 SET LRDTO=$$FMTE^XLFDT($PIECE(LRDX,"^",4),"5MZ")
+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 ;W !," ORDER #: ",LRCE,?41,"SSN/ID: ",SSN,!
+25 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+26 WRITE !," ORDER #: ",LRCE,?43,"HRCN: ",HRCN,!
+27 ;----- END IHS MODIFICATIONS - NOTE- COULD NOT COPY DIRECT FROM IHS RTN
+28 SET X=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
+29 IF X'=""
WRITE ?6,"UID: ",X
+30 WRITE ?44,"DOB: ",$$FMTE^XLFDT(DOB,"5MZ")
+31 WRITE !," LOCATION: ",$EXTRACT($PIECE(LRDX,"^",7),1,19)
+32 ; W:$L(LRDTO) ?35,"DATE ORDERED: ",LRDTO,!
+33 ; ----- BEGIN IHS LR*5.2*1025 MODIFICATION
+34 ; I $D(LRCE)>0 D ; Does Order exist
+35 ; Does Order exist -- LR*5.2*1027
IF +$GET(LRCE)>0
Begin DoDot:1
+36 NEW DTTORD,FMDTORD,LRORDIEN
+37 ; Date Ordred
SET FMDTORD=+$ORDER(^LRO(69,"C",LRCE,""))
+38 ; If null, skip
IF FMDTORD<1
QUIT
+39 ; LRAN of Order
SET LRORDIEN=+$ORDER(^LRO(69,"C",LRCE,FMDTORD,""))
+40 ; If null, skip
IF LRORDIEN<1
QUIT
+41 ; Date/Time of Order
SET DTTORD=+$PIECE($GET(^LRO(69,FMDTORD,1,LRORDIEN,0)),"^",5)
+42 ; If null, skip
IF $DATA(DTTORD)<1
QUIT
+43 ;
+44 WRITE ?40,"ORDERED: ",$$FMTE^XLFDT(DTTORD,"5MZ"),!
End DoDot:1
+45 ; ----- END IHS LR*5.2*1025 MODIFICATION
+46 IF $PIECE(LRDX,U,6)
WRITE " IDENTITY: ",$PIECE(LRDX,U,6)
+47 IF $LENGTH(LRDLC)
WRITE ?38,"COLLECTED: ",LRDLC
+48 ;
+49 SET (LRPRAC,LRX)=$PIECE(LRDX,"^",8)
+50 IF LRPRAC
SET LRX=$$GET1^DIQ(200,LRPRAC_",",.01)
+51 IF LRX=""
SET LRX=$SELECT($LENGTH(LRPRAC):LRPRAC,1:"UNKNOWN")
+52 WRITE !," PROVIDER: ",LRX
+53 IF $LENGTH(LRDLA)
WRITE ?36,"LAB ARRIVAL: ",LRDLA
+54 SET LN=$GET(LN)+6
+55 ;
+56 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
+57 WRITE !," ACCESSION PERSON: ",$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA,"LOG-IN PERSON")
+58 SET LN=$GET(LN)+1
+59 ; ----- END IHS/MSC/MKK - LR*5.2*1041
+60 ;
+61 NEW PRAC,PR
+62 DO PRAC^LR7OMERG(LRAA,LRAD,LRAN,.PRAC)
+63 SET PR=0
+64 FOR
SET PR=$ORDER(PRAC(PR))
IF PR<1
QUIT
WRITE !?11,$$GET1^DIQ(200,PR_",",.01)
SET LN=LN+1
+65 ;
+66 DO CHKPAGE
+67 IF $GET(LRSTOP)=1
QUIT
+68 ;
+69 ;
+70 DO LEDI
+71 ;
+72 ; Find and print order comments from file #69
+73 SET X1=+$PIECE(LRDX,U,4)
SET X2=+$PIECE(LRDX,U,5)
+74 IF $DATA(^LRO(69,X1,1,X2,6))
Begin DoDot:1
+75 WRITE !," Order Comment:"
SET LN=LN+1
+76 SET I=0
+77 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
+78 ;
+79 ;
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 $LENGTH(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 ; Check if task and user wants to stop task.
+2 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
Begin DoDot:1
+3 SET (LRSTOP,ZTSTOP)=1
+4 WRITE !!,"*** Report requested to stop by TaskMan ***"
+5 WRITE !,"*** Task #",$GET(ZTQUEUED,"UNKNOWN")," stopped at ",$$HTE^XLFDT($HOROLOG)," ***"
End DoDot:1
QUIT
+6 ;
+7 IF $GET(LRSTOP)!($DATA(ZTQUEUED))!($EXTRACT(IOST,1,2)'="C-")
QUIT
+8 IF $GET(LN)<(IOSL-2)
QUIT
+9 KILL DIR
+10 SET DIR(0)="E"
+11 DO ^DIR
+12 IF $DATA(DIRUT)
SET (LREND,LRSTOP)=1
+13 SET LN=1
+14 WRITE !
+15 QUIT
+16 ;
+17 ;
LEDI ; print LEDI information
+1 ;
+2 NEW LRIENS,LRUID,LRX,LRY
+3 ;
+4 SET LRY=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
SET LRIENS=LRAN_","_LRAD_","_LRAA_","
+5 ;
+6 SET LRX=$$GET1^DIQ(68.02,LRIENS,16.1)
SET LRUID=$PIECE(LRY,"^",5)
+7 IF $LENGTH(LRX)!($LENGTH(LRUID))
Begin DoDot:1
+8 WRITE !!
+9 IF $LENGTH(LRX)
WRITE $JUSTIFY($$GET1^DID(68.02,16.2,"","LABEL")_": ",17),$EXTRACT(LRX,1,20)
+10 IF $LENGTH(LRUID)
WRITE ?40,$$GET1^DID(68.02,16.4,"","LABEL"),": ",LRUID
+11 SET LN=LN+2
End DoDot:1
+12 ;
+13 SET LRX=$$GET1^DIQ(68.02,LRIENS,16.2)
+14 IF $LENGTH(LRX)
Begin DoDot:1
+15 WRITE !,$JUSTIFY($$GET1^DID(68.02,16.1,"","LABEL")_": ",17),$EXTRACT(LRX,1,20)
+16 SET LN=LN+1
End DoDot:1
+17 ;
+18 QUIT
