BLRSHPM1 ;cmi/anch/maw - BLR Reference Lab Shipping Manifest (con't) ; 11-Apr-2016 10:30 ; MAW
;;5.2;IHS LABORATORY;**1027,1030,1031,1039**;NOV 01, 1997;Build 38
;
;;5.2;LAB SERVICE;**121,153**;Sep 27, 1994
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)) 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
W !
D DASH^LRX
S LN=$G(LN)+4
D CHKPAGE
Q:$G(LRSTOP)
W !,"ACCESSION: ",LRACC,?25,$S(LRCE]"":"ORDER #: "_LRCE,1:"")
;W ?40,"PATIENT: ",PNM," ",SSN,! S X=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^") W:X'="" ?6,"UID: "_X,?41," DOB: ",$$DTF^LRAFUNC1(DOB)
;W ?40,"PATIENT: ",PNM," ",HRCN,! S X=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^") W:X'="" ?6,"UID: "_X,?41," DOB: ",$$DTF^LRAFUNC1(DOB) ;IHS/ANMC/CLS 08/18/96
; W ?40,"PATIENT: ",PNM," ",HRCN,! S X=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^") W:X'="" ?6,"UID: "_X,?40,"SEX: "_$G(SEX)_" DOB: ",DOB
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
; DOB must be in human-readable format
W ?40,"PATIENT: ",PNM," ",HRCN,!
S X=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^") W:X'="" ?6,"UID: "_X,?40,"SEX: "_$G(SEX)_" DOB: ",$S(+$G(DOB)>1950101:$$FMTE^XLFDT(DOB),1:$G(DOB))
; ----- END IHS/MSC/MKK - LR*5.2*1031
W:$P(LRDX,U,6) !,"IDENTITY: ",$P(LRDX,U,6)
W !," LOCATION:",$P(LRDX,"^",7)
W:$L(LRDTO) ?40,"DATE ORDERED: ",LRDTO
W:$L(LRDLC) !?40,"COLLECTED: ",LRDLC
W !
S LN=$G(LN)+6
D CHKPAGE
Q:$G(LRSTOP)=1
S LRPRAC=+$P(LRDX,"^",8)
I LRPRAC W " PRACTITIONER: ",$S($D(^VA(200,LRPRAC,0)):$P(^(0),"^"),1:LRPRAC) S LN=LN+1
W:$L(LRDLA) ?40,"LAB ARRIVAL: ",LRDLA D LEDI
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 I=0
. F S I=$O(^LRO(69,X1,1,X2,6,I)) Q:I<1 I I>1 W ! W ?11,^(I,0) S LN=LN+1 D CHKPAGE Q:$G(LRSTOP)
TSTCOM ;
Q:$G(LRSTOP)
S LRTS=0 F S LRTS=$O(^LRO(69,X1,1,X2,2,LRTS)) Q:LRTS<1 S LRTST=$G(^(LRTS,0)) I LRTST D
. Q:'$O(^LRO(69,X1,1,X2,2,LRTS,1,0))
. Q:'$D(^LAB(60,+LRTST,0))#2 W !,"Test [ ",$P(^(0),U)_" ] Comment "
. S X3=0 F S X3=$O(^LRO(69,X1,1,X2,2,LRTS,1,X3)) Q:X3<1 I $D(^(X3,0)) W !,?5,^(0) S LN=LN+1 D CHKPAGE Q:$G(LRSTOP)
Q:$G(LRSTOP)
I $L(LRACO) W !," Accession Comment: ",LRACO S LN=LN+1
W:$L($P(LRDX,U,6,7))>1 !
Q
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
N LRUIDX S LRUIDX=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
S Y=$P(LRUIDX,"^",2) I Y!($P(LRUIDX,"^",5)'="") W ! S C=$P(^DD(68.02,16.1,0),"^",2) D Y^DIQ W:Y'="" " ORDERING SITE: "_$E(Y,1,20) W:$P(LRUIDX,"^",5)'="" ?40,"ORDERING SITE UID: "_$P(LRUIDX,"^",5) S LN=LN+1
S Y=$P(LRUIDX,"^",3) I Y!($P(LRUIDX,"^",4)'="") W ! S C=$P(^DD(68.02,16.2,0),"^",2) D Y^DIQ W:Y'="" " COLLECTING SITE: "_$E(Y,1,20) W:$P(LRUIDX,"^",4)'="" ?40,"HOST UID: "_$P(LRUIDX,"^",4) S LN=LN+1
Q
BLRSHPM1 ;cmi/anch/maw - BLR Reference Lab Shipping Manifest (con't) ; 11-Apr-2016 10:30 ; MAW
+1 ;;5.2;IHS LABORATORY;**1027,1030,1031,1039**;NOV 01, 1997;Build 38
+2 ;
+3 ;;5.2;LAB SERVICE;**121,153**;Sep 27, 1994
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 SET LRDPF=$PIECE(^LR(+LRDX,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+6 DO PT^LRX
+7 SET (LRDLA,LRDLC,LRACO)=""
+8 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
+9 IF Y
DO DD^LRX
SET LRDLC=Y
SET Y=LRDLA
IF Y
DO DD^LRX
SET LRDLA=Y
End DoDot:1
+10 SET Y=$PIECE(LRDX,U,4)
IF Y
DO DD^LRX
SET LRDTO=Y
+11 WRITE !
+12 DO DASH^LRX
+13 SET LN=$GET(LN)+4
+14 DO CHKPAGE
+15 IF $GET(LRSTOP)
QUIT
+16 WRITE !,"ACCESSION: ",LRACC,?25,$SELECT(LRCE]"":"ORDER #: "_LRCE,1:"")
+17 ;W ?40,"PATIENT: ",PNM," ",SSN,! S X=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^") W:X'="" ?6,"UID: "_X,?41," DOB: ",$$DTF^LRAFUNC1(DOB)
+18 ;W ?40,"PATIENT: ",PNM," ",HRCN,! S X=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^") W:X'="" ?6,"UID: "_X,?41," DOB: ",$$DTF^LRAFUNC1(DOB) ;IHS/ANMC/CLS 08/18/96
+19 ; W ?40,"PATIENT: ",PNM," ",HRCN,! S X=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^") W:X'="" ?6,"UID: "_X,?40,"SEX: "_$G(SEX)_" DOB: ",DOB
+20 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+21 ; DOB must be in human-readable format
+22 WRITE ?40,"PATIENT: ",PNM," ",HRCN,!
+23 SET X=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
IF X'=""
WRITE ?6,"UID: "_X,?40,"SEX: "_$GET(SEX)_" DOB: ",$SELECT(+$GET(DOB)>1950101:$$FMTE^XLFDT(DOB),1:$GET(DOB))
+24 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+25 IF $PIECE(LRDX,U,6)
WRITE !,"IDENTITY: ",$PIECE(LRDX,U,6)
+26 WRITE !," LOCATION:",$PIECE(LRDX,"^",7)
+27 IF $LENGTH(LRDTO)
WRITE ?40,"DATE ORDERED: ",LRDTO
+28 IF $LENGTH(LRDLC)
WRITE !?40,"COLLECTED: ",LRDLC
+29 WRITE !
+30 SET LN=$GET(LN)+6
+31 DO CHKPAGE
+32 IF $GET(LRSTOP)=1
QUIT
+33 SET LRPRAC=+$PIECE(LRDX,"^",8)
+34 IF LRPRAC
WRITE " PRACTITIONER: ",$SELECT($DATA(^VA(200,LRPRAC,0)):$PIECE(^(0),"^"),1:LRPRAC)
SET LN=LN+1
+35 IF $LENGTH(LRDLA)
WRITE ?40,"LAB ARRIVAL: ",LRDLA
DO LEDI
+36 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),"^")
+37 SET X1=+$PIECE(LRDX,U,4)
SET X2=+$PIECE(LRDX,U,5)
+38 IF $DATA(^LRO(69,X1,1,X2,6))
Begin DoDot:1
+39 WRITE !," Order Comment:"
SET LN=LN+1
+40 SET I=0
+41 FOR
SET I=$ORDER(^LRO(69,X1,1,X2,6,I))
IF I<1
QUIT
IF I>1
WRITE !
WRITE ?11,^(I,0)
SET LN=LN+1
DO CHKPAGE
IF $GET(LRSTOP)
QUIT
End DoDot:1
TSTCOM ;
+1 IF $GET(LRSTOP)
QUIT
+2 SET LRTS=0
FOR
SET LRTS=$ORDER(^LRO(69,X1,1,X2,2,LRTS))
IF LRTS<1
QUIT
SET LRTST=$GET(^(LRTS,0))
IF LRTST
Begin DoDot:1
+3 IF '$ORDER(^LRO(69,X1,1,X2,2,LRTS,1,0))
QUIT
+4 IF '$DATA(^LAB(60,+LRTST,0))#2
QUIT
WRITE !,"Test [ ",$PIECE(^(0),U)_" ] Comment "
+5 SET X3=0
FOR
SET X3=$ORDER(^LRO(69,X1,1,X2,2,LRTS,1,X3))
IF X3<1
QUIT
IF $DATA(^(X3,0))
WRITE !,?5,^(0)
SET LN=LN+1
DO CHKPAGE
IF $GET(LRSTOP)
QUIT
End DoDot:1
+6 IF $GET(LRSTOP)
QUIT
+7 IF $LENGTH(LRACO)
WRITE !," Accession Comment: ",LRACO
SET LN=LN+1
+8 IF $LENGTH($PIECE(LRDX,U,6,7))>1
WRITE !
+9 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 NEW LRUIDX
SET LRUIDX=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
+2 SET Y=$PIECE(LRUIDX,"^",2)
IF Y!($PIECE(LRUIDX,"^",5)'="")
WRITE !
SET C=$PIECE(^DD(68.02,16.1,0),"^",2)
DO Y^DIQ
IF Y'=""
WRITE " ORDERING SITE: "_$EXTRACT(Y,1,20)
IF $PIECE(LRUIDX,"^",5)'=""
WRITE ?40,"ORDERING SITE UID: "_$PIECE(LRUIDX,"^",5)
SET LN=LN+1
+3 SET Y=$PIECE(LRUIDX,"^",3)
IF Y!($PIECE(LRUIDX,"^",4)'="")
WRITE !
SET C=$PIECE(^DD(68.02,16.2,0),"^",2)
DO Y^DIQ
IF Y'=""
WRITE " COLLECTING SITE: "_$EXTRACT(Y,1,20)
IF $PIECE(LRUIDX,"^",4)'=""
WRITE ?40,"HOST UID: "_$PIECE(LRUIDX,"^",4)
SET LN=LN+1
+4 QUIT
