LRHYLS1 ;DALOI/HOAK - DISPLAY ORDERS 9/27/2005 ;10/15/10 11:25am
;;5.2;LAB SERVICE;**405,417**;Sep 27, 1994;Build 1
;
LST1 ;
Q:$G(LRKUNKE)=1
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)) S Y=^(3),LRDLA=$P(Y,U,3),LRACO=$P(Y,U,6),Y=$P(Y,U) D
. D:Y DD^LRX S LRDLC=Y,Y=LRDLA D:Y DD^LRX S LRDLA=Y
S Y=$P(LRDX,U,4) D:Y DD^LRX S LRDTO=Y
; Patient:_______________ SSN:_________ DOB:________ PROVIDER:
S LN=$G(LN)+4
D CHKPAGE
Q:$G(LRSTOP)
W !,"UID: ",?11,$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
W !,"ACCESSION: ",$E(^LRO(68,LRAA,0),1,4)," ",$E(LRAD,4,7)," ",LRAN
W !,"ORDER #: ",?11,LRCE
S LRUID=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),U)
D DASH^LRX
D BUILD^LRHYT2
W "Patient: ",$E(PNM,1,12)
W ?22,"SSN: ",$P(SSN,"-",3)
W ?33,"DOB: ",$$DTF^LRAFUNC1(DOB)
S LRPRAC=+$P(LRDX,"^",8)
W ?50,"PROVIDER: ",$S($D(^VA(200,LRPRAC,0)):$P(^(0),"^"),1:LRPRAC)
D DASH^LRX
QUIT
S LN=$G(LN)+6
D CHKPAGE
Q:$G(LRSTOP)=1
N PRAC,PR D PRAC^LR7OMERG(LRAA,LRAD,LRAN,.PRAC) I $O(PRAC(0)) S PR=0 F S PR=$O(PRAC(PR)) Q:PR<1 I $D(^VA(200,PR,0)) W !?16,$P(^(0),"^")
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 LRHYI=0
. S LRNX0=$G(^LRO(69,X1,1,X2,0))
. F S LRHYI=$O(^LRO(69,X1,1,X2,6,LRHYI)) Q:LRHYI<1 I LRHYI>1 W !?11,^(LRHYI,0) S LN=LN+1 D CHKPAGE Q:$G(LRSTOP)
TSTCOM ;
Q:$G(LRSTOP)
S LRHYI=0
F S LRHYI=$O(^LRO(69,X1,1,X2,2,LRHYI)) Q:LRHYI<1 S X=^(LRHYI,0) I $P(X,"^",11) D
. W !," CANCELLED TEST: ",$S($D(^LAB(60,+X,0)):$P(^(0),"^"),1:"UNKNOWN")
. N LRURG S LRURG=+$P(X,U,2)
. I LRURG=1!(LRURG=51) D FLASH
. I LRURG=51 D FLASH
. E W " "_$E($S($D(^LAB(62.05,LRURG,0)):$P(^(0),U),1:"ROUTINE"),1,15)
. W " by: "_$P(^VA(200,$P(X,"^",11),0),"^")
. S LRHYI(2)=0 F S LRHYI(2)=$O(^LRO(69,X1,1,X2,2,LRHYI,1.1,LRHYI(2))) Q:LRHYI(2)<1 I $D(^(LRHYI(2),0)) W !?3,": "_^(0) D CHKPAGE Q:$G(LRSTOP)
I $L(LRACO) W !," Accession Comment: ",LRACO S LN=LN+1
W:$L($P(LRDX,U,6,7))>1 !
Q
FLASH ;
I $G(LRURG)=1!(LRURG=51) D SCRNON^LRHYUTL W IOBON
;
W ?20,$S($D(^LAB(62.05,+LRURG,0)):$P(^(0),U),1:"")," "
;
I $G(LRURG)=1 W IOBOFF D SCRNOFF^LRHYUTL
;
QUIT
CHKPAGE ;
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(DUOUT)!($D(DIRUT)) S LRSTOP=1 Q
S LREND=$G(LRSTOP)
S LN=1
W !
Q
LEDI ; print LEDI information
D LEDI^LRWRKLS1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRHYLS1 2639 printed Nov 22, 2024@17:25:27 Page 2
LRHYLS1 ;DALOI/HOAK - DISPLAY ORDERS 9/27/2005 ;10/15/10 11:25am
+1 ;;5.2;LAB SERVICE;**405,417**;Sep 27, 1994;Build 1
+2 ;
LST1 ;
+1 if $GET(LRKUNKE)=1
QUIT
+2 DO CHKPAGE
+3 if $GET(LRSTOP)=1
QUIT
+4 SET LRDX=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRCE=$SELECT($DATA(^(.1)):^(.1),1:"")
SET LRACC=$SELECT($DATA(^(.2)):^(.2),1:"")
+5 if '$DATA(^LR(+LRDX,0))#2
QUIT
+6 SET LRDPF=$PIECE(^LR(+LRDX,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+7 DO PT^LRX
+8 SET (LRDLA,LRDLC,LRACO)=""
+9 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
SET Y=^(3)
SET LRDLA=$PIECE(Y,U,3)
SET LRACO=$PIECE(Y,U,6)
SET Y=$PIECE(Y,U)
Begin DoDot:1
+10 if Y
DO DD^LRX
SET LRDLC=Y
SET Y=LRDLA
if Y
DO DD^LRX
SET LRDLA=Y
End DoDot:1
+11 SET Y=$PIECE(LRDX,U,4)
if Y
DO DD^LRX
SET LRDTO=Y
+12 ; Patient:_______________ SSN:_________ DOB:________ PROVIDER:
+13 SET LN=$GET(LN)+4
+14 DO CHKPAGE
+15 if $GET(LRSTOP)
QUIT
+16 WRITE !,"UID: ",?11,$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
+17 WRITE !,"ACCESSION: ",$EXTRACT(^LRO(68,LRAA,0),1,4)," ",$EXTRACT(LRAD,4,7)," ",LRAN
+18 WRITE !,"ORDER #: ",?11,LRCE
+19 SET LRUID=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),U)
+20 DO DASH^LRX
+21 DO BUILD^LRHYT2
+22 WRITE "Patient: ",$EXTRACT(PNM,1,12)
+23 WRITE ?22,"SSN: ",$PIECE(SSN,"-",3)
+24 WRITE ?33,"DOB: ",$$DTF^LRAFUNC1(DOB)
+25 SET LRPRAC=+$PIECE(LRDX,"^",8)
+26 WRITE ?50,"PROVIDER: ",$SELECT($DATA(^VA(200,LRPRAC,0)):$PIECE(^(0),"^"),1:LRPRAC)
+27 DO DASH^LRX
+28 QUIT
+29 SET LN=$GET(LN)+6
+30 DO CHKPAGE
+31 if $GET(LRSTOP)=1
QUIT
+32 NEW PRAC,PR
DO PRAC^LR7OMERG(LRAA,LRAD,LRAN,.PRAC)
IF $ORDER(PRAC(0))
SET PR=0
FOR
SET PR=$ORDER(PRAC(PR))
if PR<1
QUIT
IF $DATA(^VA(200,PR,0))
WRITE !?16,$PIECE(^(0),"^")
+33 SET X1=+$PIECE(LRDX,U,4)
SET X2=+$PIECE(LRDX,U,5)
+34 IF $DATA(^LRO(69,X1,1,X2,6))
Begin DoDot:1
+35 WRITE !," Order Comment:"
SET LN=LN+1
+36 SET LRHYI=0
+37 SET LRNX0=$GET(^LRO(69,X1,1,X2,0))
+38 FOR
SET LRHYI=$ORDER(^LRO(69,X1,1,X2,6,LRHYI))
if LRHYI<1
QUIT
IF LRHYI>1
WRITE !?11,^(LRHYI,0)
SET LN=LN+1
DO CHKPAGE
if $GET(LRSTOP)
QUIT
End DoDot:1
TSTCOM ;
+1 if $GET(LRSTOP)
QUIT
+2 SET LRHYI=0
+3 FOR
SET LRHYI=$ORDER(^LRO(69,X1,1,X2,2,LRHYI))
if LRHYI<1
QUIT
SET X=^(LRHYI,0)
IF $PIECE(X,"^",11)
Begin DoDot:1
+4 WRITE !," CANCELLED TEST: ",$SELECT($DATA(^LAB(60,+X,0)):$PIECE(^(0),"^"),1:"UNKNOWN")
+5 NEW LRURG
SET LRURG=+$PIECE(X,U,2)
+6 IF LRURG=1!(LRURG=51)
DO FLASH
+7 IF LRURG=51
DO FLASH
+8 IF '$TEST
WRITE " "_$EXTRACT($SELECT($DATA(^LAB(62.05,LRURG,0)):$PIECE(^(0),U),1:"ROUTINE"),1,15)
+9 WRITE " by: "_$PIECE(^VA(200,$PIECE(X,"^",11),0),"^")
+10 SET LRHYI(2)=0
FOR
SET LRHYI(2)=$ORDER(^LRO(69,X1,1,X2,2,LRHYI,1.1,LRHYI(2)))
if LRHYI(2)<1
QUIT
IF $DATA(^(LRHYI(2),0))
WRITE !?3,": "_^(0)
DO CHKPAGE
if $GET(LRSTOP)
QUIT
End DoDot:1
+11 IF $LENGTH(LRACO)
WRITE !," Accession Comment: ",LRACO
SET LN=LN+1
+12 if $LENGTH($PIECE(LRDX,U,6,7))>1
WRITE !
+13 QUIT
FLASH ;
+1 IF $GET(LRURG)=1!(LRURG=51)
DO SCRNON^LRHYUTL
WRITE IOBON
+2 ;
+3 WRITE ?20,$SELECT($DATA(^LAB(62.05,+LRURG,0)):$PIECE(^(0),U),1:"")," "
+4 ;
+5 IF $GET(LRURG)=1
WRITE IOBOFF
DO SCRNOFF^LRHYUTL
+6 ;
+7 QUIT
CHKPAGE ;
+1 if $GET(LRSTOP)!($DATA(ZTQUEUED))!($EXTRACT(IOST,1,2)'="C-")
QUIT
+2 if $GET(LN)<(IOSL-2)
QUIT
+3 KILL DIR
+4 SET DIR(0)="E"
+5 DO ^DIR
+6 IF $DATA(DUOUT)!($DATA(DIRUT))
SET LRSTOP=1
QUIT
+7 SET LREND=$GET(LRSTOP)
+8 SET LN=1
+9 WRITE !
+10 QUIT
LEDI ; print LEDI information
+1 DO LEDI^LRWRKLS1
+2 QUIT
