- 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
