Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRPHITEM

LRPHITEM.m

Go to the documentation of this file. 
  1. LRPHITEM ;SLC/CJS/RWF-ITEMIZED LOGIN ;6/24/91  10:49 [ 04/08/2003  9:05 AM ]
  1.  ;;5.2T9;LR;**1010,1018**;Nov 17, 2004
  1.  ;;5.2;LAB SERVICE;**121,198,208,202,221,262**;Sep 27, 1994
  1.  ;
  1.  ;----- BEGIN IHS MODIFICATION LR*5.2*1018
  1.  S:$G(BLROPT)=""!($G(BLROPT(0))'=$P(XQY0,U)) BLROPT="ITMCOL",BLROPT(0)=$P(XQY0,U)  ;IHS/DIR TUC/AAB 5/5/98
  1.  ;----- END IHS MODIFICATION
  1.  S LRODT=DT,LRNT=$$NOW^XLFDT
  1.  ;
  1. V1 D FNDLOC^LRDRAW G END^LRPHITE1:LRLLOC["^"
  1.  I LRLLOC="" W !,"All locations" S %=2 D YN^DICN G V1:%=2!(%=0),END^LRPHITE1:%=-1
  1.  I $L(LRLLOC) I '$D(^LRO(69.1,"LRPH",1,LRLLOC)) W !,"Location ",LRLLOC," not found on collection list.",$C(7) G V1
  1.  ;
  1. V2 ;
  1.  K LRSN,LROR,LRCOM,LRTCOM,LRNOCOM
  1.  W !!,$C(7),"Enter Order Numbers NOT collected: " S LROR=0,LRFIRST=1 D LP1 G:X="^" END^LRPHITE1
  1.  ; -->Fix for 208
  1.  I $O(LROR(0))>0 W !,"Exceptions first." S LROR=0 D
  1.  . N LRLLOC,LRODT
  1.  . F  S LROR=$O(LROR(LROR)) Q:LROR<1  D EXCEPT^LRPHITE3
  1.  ;
  1.  K LRSN,LROR,LRCOM,LRTCOM
  1.  W !!,"Enter Order Numbers COLLECTED: " S LRNOCOM=1,LROR="" D LP1 G:X="^" END^LRPHITE1
  1.  G:LRLLOC'="" E1 S LRLLOC="" F  S LRLLOC=$O(^LRO(69,LRODT,1,"AC",LRLLOC)) Q:LRLLOC=""  D E2
  1.  D LEFT G END^LRPHITE1
  1.  ;
  1. E1 ;
  1.  D E2,LEFT G END^LRPHITE1
  1.  ;
  1. LEFT Q:$O(LROR(0))=""  W !!,"DID NOT FIND THESE ORDERS:" S I=0 F  S I=$O(LROR(I)) Q:I=""  W $J(LROR(I),10) W:$X>69 !
  1.  Q
  1.  ;
  1. E2 ;
  1.  N LRSTORE
  1.  S LROR=0
  1.  F  S LROR=$O(LROR(LROR)) Q:LROR<1  D
  1.  . S LRSTORE(1)=LROR(LROR)
  1.  . S LRSN=0
  1.  . F  S LRSN=$O(^LRO(69,"C",LRSTORE(1),LRODT,LRSN)) Q:LRSN=""  D
  1.  . . I $G(^LRO(69,LRODT,1,"AC",LRLLOC,LRSN))'=1 Q
  1.  . . S LRSTORE=0
  1.  . . D P15
  1.  . . W !,LRLLOC,"  ",LRSTORE(1)
  1.  . . W:'$G(LRSTORE) "  Not Accepted !! ",$C(7)
  1.  . . K LROR(LROR)
  1.  Q
  1.  ;
  1.  ;
  1. P15 ;from LROE1, LRPHEXPT
  1.  N LRORIFN,LRX712,LRUIDA
  1.  ;
  1.  Q:'$D(^LRO(69,LRODT,1,LRSN,1))  Q:$L($P(^(1),U,4))  S J1=^(1),LRX712=^(0)
  1.  S LRDFN=+LRX712 K LRDPF
  1.  D
  1.  . N LRRB
  1.  . D PT^LRX
  1.  S LROLLOC=$P(LRX712,U,9)
  1.  S LRTREA=+$G(VAIN(3))
  1.  S LRORIFN=$P(LRX712,U,11)
  1.  S LRNT=$$NOW^XLFDT
  1.  ;
  1.  ;S ^LRO(69,LRODT,1,LRSN,1)=$P(J1,U,1,2)_"^"_DUZ_"^"_$P(J1,U,4)_"^^"_$P(J1,U,6)_"^"_$P(J1,U,7)
  1.  S $P(^LRO(69,LRODT,1,LRSN,1),U,3)=DUZ
  1.  ;
  1.  S $P(^LRO(69,LRODT,1,LRSN,3),U)=LRNT,^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=""
  1.  S (LRAA,LRAD,LRAN,LRTN)=0
  1.  F  S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:LRTN<1  D
  1.  . I '$D(^LRO(69,LRODT,1,LRSN,2,LRTN,0)) Q
  1.  . S X=^LRO(69,LRODT,1,LRSN,2,LRTN,0),LRAA=+$P(X,U,4),LRAD=+$P(X,U,3),LRAN=+$P(X,U,5),LRORIFN=$P(X,U,7)
  1.  . D P15A
  1.  . I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) D
  1.  . . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)=LRNT
  1.  . . S ^LRO(68,LRAA,1,LRAD,1,"E",LRNT,LRAN)=""
  1.  ;
  1.  I +$G(LRDPF)=2 D
  1.  . N CONTROL
  1.  . S CONTROL=$S($L(LRORIFN):"SC",1:"SN")
  1.  . D NEW^LR7OB1(LRODT,LRSN,CONTROL,,,6)
  1.  ;
  1.  N LRX
  1.  S LRX=""
  1.  F  S LRX=$O(LRUIDA(LRX)) Q:LRX=""  D EN^LA7ADL(LRX)
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. P15A ;
  1.  I $G(LRDPF)=2,$$VER^LR7OU1<3 D:LRAA OR^LRWLST S $P(^LRO(69,LRODT,1,LRSN,2,LRTN,0),U,7)=LRORIFN
  1.  Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
  1.  S $P(^LRO(69,LRODT,1,LRSN,1),U,4)="C",$P(^(1),U,8)=DUZ(2),LRRB="",$P(^LRO(69,LRODT,1,LRSN,1),U)=LRNT,^LRO(69,"AA",+$G(^(.1)),LRODT_"|"_LRSN)=""
  1.  ;----- BEGIN IHS MODIFICATION LR*5.2*1018
  1.  I ($G(BLROPT)="RECCOL"!($G(BLROPT)="ITMCOL")),BLRLOG D ^BLREVTQ("M","A",$G(BLROPT),,LRODT_","_LRSN_","_LRAA_","_LRAD_","_LRAN)  ;IHS/DIR/TUC/AAB 04/17/98
  1.  ;----- END IHS MODIFICATION
  1.  S LRSTORE=1
  1.  ;
  1.  ; Save list of uid's on this order, used above to download to Lab UI.
  1.  N X
  1.  S X=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),U)
  1.  I $L(X) S LRUIDA(X)=""
  1.  Q
  1.  ;
  1. P16 ;from LRPHITE1
  1.  N X
  1.  Q:'$D(^LRO(69,LRODT,1,LRSN,1))#2
  1.  S LRSS=$P(^LRO(68,LRAA,0),"^",2)
  1.  Q:'$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))  S LRDFN=+^(0),LRDPF=$P(^(0),U,2)
  1.  S LRDTM=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U),LRIDT=+$P(^(3),U,5)
  1.  I $S('LRIDT:1,'$D(^LR(LRDFN,LRSS,LRIDT,0))#2:1,1:0) S LRNOP=1 W !?5,"Accession Information Corrupt for this Order",!! Q
  1.  I $P(^LR(LRDFN,LRSS,LRIDT,0),U,3) W !,$C(7),"CAN'T DO IT.  The data has been verified for accession  ",$P(^(0),U,6) S LRNOP=1 Q
  1. SKP S $P(^LRO(69,LRODT,1,LRSN,1),U,3)=DUZ,$P(^(1),U,4)="U" G P17:'LRBATCH
  1.  S X=$O(LRCOM(999-LROR)),LRRND=$S($L(LRRND):LRRND,X>0:LRCOM(X,1,1),1:"")
  1. P17 G P18:$L(LRRND) W !,"REASON FOR NON-DRAW ON ORDER ",LROR(LROR)
  1.  W " ",$G(LRCCOM)
  1.  I $G(LREPISOD) K LREPISOD
  1.  S LRSAMP=1,LRSPEC=1,LREND=0 I '$L(LRRND) F  D  Q:$L(LRRND)!($G(LREND))  W !?5,"You must enter a reason.",!
  1.  . N LRCCOM,LRCCOM1,LRCCOMX D FX2^LRTSTOUT S LRRND=LRCCOM
  1.  Q:$G(LREND)
  1. P18 S $P(^LRO(69,LRODT,1,LRSN,1),U,6)=LRRND
  1.  D:$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) OUT^LRPHITE2
  1.  Q
  1. LP1 ;from LRPHEXPT
  1.  N Y1
  1.  S LRFORD=LROR K LRCCOM,LRCOM0
  1.  W !,"Enter Order #(s) :",! R X:DTIME Q:(X="^"!(X="")!('$T))  W ! I (X="?"!($L(X)>80)) W !,"Enter a string of numbers separated with A ',' UP TO 80 CHARACTERS LONG ",! G LP1
  1.  W ! F I=1:1 S LRSN=+$P(X,",",I) Q:LRSN=0  D
  1.  .  S Y1=$O(^LRO(69,"C",+LRSN,LRODT,0))
  1.  .  S Y=Y1 D:Y1<1 TEXT S LRSN0=Y1 ;----->LR*5.2*182
  1.  .  I Y1'="" S LRWD=$P(^LRO(69,LRODT,1,Y1,0),U,7) S:LRLLOC'="" Y=$S(LRWD=LRLLOC:$D(^LRO(69,LRODT,1,Y,1)),1:"") S:Y LROR=LROR+1,LROR(LROR)=+LRSN D TEXT
  1. 198 ;
  1.  S LRSAMP=999-LRFORD,LRSPEC=1,LRCOM(LRSAMP,1,1)="",LRCOM(LRSAMP,1)=0
  1.  G LP1
  1. TEXT S:Y<1 Y="" W:$X>70 ! W +LRSN,$S(Y:" OK, ",1:" NOT ON LIST, ")
  1.  QUIT
  1.  ;--> LR*5.2*182
  1. SINGLE ;
  1.  N X
  1.  Q:$G(LREPISOD)=1
  1.  S LREPISOD=1
  1.  I '$G(LRSN) S LRSN=$G(LRSN0)
  1.  S LRITN=$G(LRITN,LRIX)
  1.  S LRRND=LRCCOM
  1.  Q:'$G(LRSN)
  1.  S $P(^LRO(69,LRODT,1,LRSN,1),U,6)=LRRND
  1.  S X=1+$O(^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,"A"),-1),X(1)=$P($G(^(0)),U,4)
  1.  S ^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,X,0)="*"_$G(LRCCOM1)_":"_LRCCOM,X=X+1,X(1)=X(1)+1
  1.  S ^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,0)="^^"_X_U_X(1)_U_DT
  1.  K LRSAMP,LRSPEC,LRCOM,LRCCOM
  1.  QUIT
  1. POLY ;
  1.  N LRTIC
  1.  S LRTIC=0
  1.  F  S LRTIC=$O(^LRO(69,LRODT,1,LRSN,2,LRTIC)) Q:+LRTIC'>0  S LRITN=LRTIC D
  1.  .  S X=1+$O(^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,"A"),-1),X(1)=$P($G(^(0)),U,4)
  1.  .  S ^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,X,0)="*"_$G(LRCCOM1)_":"_LRCCOM,X=X+1,X(1)=X(1)+1
  1.  .  S ^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,0)="^^"_X_U_X(1)_U_DT
  1.  K DIE,LREPISOD
  1.  S LRCOM0=LRCCOM
  1.  K LRSAMP,LRSPEC,LRCOM
  1.  QUIT
  1.  ;
  1. MULT ;
  1.  S LRSN0=0 ;-->  specimen number
  1.  F  S LRSN0=$O(^LRO(69,"C",LRSN,LRODT,LRSN0)) Q:+LRSN0'>0  D LRSN
  1.  QUIT
  1. LRSN ;
  1.  ;--> From LRPHITE1 when multiple tests have been cancelled
  1.  ;    LRCCOM is still valid since only one comment per order
  1.  ;
  1.  N LRTT3
  1.  S LRTT3=0
  1.  F  S LRTT3=$O(^LRO(69,LRODT,1,LRSN0,2,LRTT3)) Q:+LRTT3'>0  D
  1.  .  Q:$P(^LRO(69,LRODT,1,LRSN0,2,LRTT3,0),U,9)'="CA"
  1.  .  S LRTIC=0
  1.  .  F  S LRTIC=$O(^LRO(69,LRODT,1,LRSN0,2,LRTT3,1,LRTIC)) Q:+LRTIC'>0  D
  1.  ..  Q:$D(^LRO(69,LRODT,1,LRSN0,2,LRTT3,1,LRTIC,0))
  1.  ..  N LRITN S LRITN=LRTT3
  1.  ..  D SINGLE
  1.  QUIT