LRPHITEM ;SLC/CJS/RWF-ITEMIZED LOGIN ;JUNE 06, 1991@1049
;;5.2;LAB SERVICE;**121,198,208,202,221,262,528**;Sep 27, 1994;Build 3
;
S LRODT=DT,LRNT=$$NOW^XLFDT
;
V1 D FNDLOC^LRDRAW G END^LRPHITE1:LRLLOC["^"
I LRLLOC="" W !,"All locations" S %=2 D YN^DICN G V1:%=2!(%=0),END^LRPHITE1:%=-1
I $L(LRLLOC) I '$D(^LRO(69.1,"LRPH",1,LRLLOC)) W !,"Location ",LRLLOC," not found on collection list.",$C(7) G V1
;
V2 ;
K LRSN,LROR,LRCOM,LRTCOM,LRNOCOM
W !!,$C(7),"Enter Order Numbers NOT collected: " S LROR=0,LRFIRST=1 D LP1 G:X="^" END^LRPHITE1
; -->Fix for 208
I $O(LROR(0))>0 W !,"Exceptions first." S LROR=0 D
. N LRLLOC,LRODT
. F S LROR=$O(LROR(LROR)) Q:LROR<1 D EXCEPT^LRPHITE3
;
K LRSN,LROR,LRCOM,LRTCOM
W !!,"Enter Order Numbers COLLECTED: " S LRNOCOM=1,LROR="" D LP1 G:X="^" END^LRPHITE1
G:LRLLOC'="" E1 S LRLLOC="" F S LRLLOC=$O(^LRO(69,LRODT,1,"AC",LRLLOC)) Q:LRLLOC="" D E2
D LEFT G END^LRPHITE1
;
E1 ;
D E2,LEFT G END^LRPHITE1
;
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 !
Q
;
E2 ;
N LRSTORE
S LROR=0
F S LROR=$O(LROR(LROR)) Q:LROR<1 D
. S LRSTORE(1)=LROR(LROR)
. S LRSN=0
. F S LRSN=$O(^LRO(69,"C",LRSTORE(1),LRODT,LRSN)) Q:LRSN="" D
. . I $G(^LRO(69,LRODT,1,"AC",LRLLOC,LRSN))'=1 Q
. . S LRSTORE=0
. . D P15
. . W !,LRLLOC," ",LRSTORE(1)
. . W:'$G(LRSTORE) " Not Accepted !! ",$C(7)
. . K LROR(LROR)
Q
;
;
P15 ;from LROE1, LRPHEXPT
N LRORIFN,LRX712,LRUIDA
;
Q:'$D(^LRO(69,LRODT,1,LRSN,1)) Q:$L($P(^(1),U,4)) S J1=^(1),LRX712=^(0)
S LRDFN=+LRX712 K LRDPF
D
. N LRRB
. D PT^LRX
S LROLLOC=$P(LRX712,U,9)
S LRTREA=+$G(VAIN(3))
S LRORIFN=$P(LRX712,U,11)
S LRNT=$$NOW^XLFDT
;
;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)
S $P(^LRO(69,LRODT,1,LRSN,1),U,3)=DUZ
;
S $P(^LRO(69,LRODT,1,LRSN,3),U)=LRNT,^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=""
S (LRAA,LRAD,LRAN,LRTN)=0
F S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:LRTN<1 D
. I '$D(^LRO(69,LRODT,1,LRSN,2,LRTN,0)) Q
. 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)
. D P15A
. I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) D
. . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)=LRNT
. . S ^LRO(68,LRAA,1,LRAD,1,"E",LRNT,LRAN)=""
;
I +$G(LRDPF)=2 D
. N CONTROL
. S CONTROL=$S($L(LRORIFN):"SC",1:"SN")
. D NEW^LR7OB1(LRODT,LRSN,CONTROL,,,6)
;
N LRX
S LRX=""
F S LRX=$O(LRUIDA(LRX)) Q:LRX="" D EN^LA7ADL(LRX)
;
Q
;
;
P15A ;
I $G(LRDPF)=2,$$VER^LR7OU1<3 D:LRAA OR^LRWLST S $P(^LRO(69,LRODT,1,LRSN,2,LRTN,0),U,7)=LRORIFN
Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
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)=""
S LRSTORE=1
;
; Save list of uid's on this order, used above to download to Lab UI.
N X
S X=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),U)
I $L(X) S LRUIDA(X)=""
Q
;
P16 ;from LRPHITE1
N X
Q:'$D(^LRO(69,LRODT,1,LRSN,1))#2
S LRSS=$P(^LRO(68,LRAA,0),"^",2)
Q:'$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S LRDFN=+^(0),LRDPF=$P(^(0),U,2)
S LRDTM=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U),LRIDT=+$P(^(3),U,5)
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
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
SKP S $P(^LRO(69,LRODT,1,LRSN,1),U,3)=DUZ,$P(^(1),U,4)="U" G P17:'LRBATCH
S X=$O(LRCOM(999-LROR)),LRRND=$S($L(LRRND):LRRND,X>0:LRCOM(X,1,1),1:"")
P17 G P18:$L(LRRND) W !,"REASON FOR NON-DRAW ON ORDER ",LROR(LROR)
W " ",$G(LRCCOM)
I $G(LREPISOD) K LREPISOD
S LRSAMP=1,LRSPEC=1,LREND=0 I '$L(LRRND) F D Q:$L(LRRND)!($G(LREND)) W !?5,"You must enter a reason.",!
. N LRCCOM,LRCCOM1,LRCCOMX D FX2^LRTSTOUT S LRRND=LRCCOM
Q:$G(LREND)
P18 S $P(^LRO(69,LRODT,1,LRSN,1),U,6)=LRRND
D:$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) OUT^LRPHITE2
Q
LP1 ;from LRPHEXPT
N Y1
S LRFORD=LROR K LRCCOM,LRCOM0
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
W ! F I=1:1 S LRSN=+$P(X,",",I) Q:LRSN=0 D
. S Y1=$O(^LRO(69,"C",+LRSN,LRODT,0))
. S Y=Y1 D:Y1<1 TEXT S LRSN0=Y1 ;----->LR*5.2*182
. I Y1'="",$$ALLCA(LRODT,+LRSN) S Y=0 D TEXT Q
. 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
198 ;
S LRSAMP=999-LRFORD,LRSPEC=1,LRCOM(LRSAMP,1,1)="",LRCOM(LRSAMP,1)=0
G LP1
ALLCA(LRSD,LRON) ;Are all tests cancelled?
N LRI,LRC,LRSN,LRX
S LRC=1,LRSN=0
F S LRSN=$O(^LRO(69,"C",LRON,LRSD,LRSN)) Q:+LRSN'>0 S LRI=0 D Q:LRC=0
. F S LRI=$O(^LRO(69,LRSD,1,LRSN,2,LRI)) Q:+LRI'>0 D I LRX'="CA" S LRC=0 Q
. . S LRX=^LRO(69,LRSD,1,LRSN,2,LRI,0),LRX=$P(LRX,U,9)
Q LRC
TEXT S:Y<1 Y="" W:$X>70 ! W +LRSN,$S(Y:" OK, ",1:" NOT ON LIST, ")
QUIT
;--> LR*5.2*182
SINGLE ;
N X
Q:$G(LREPISOD)=1
S LREPISOD=1
I '$G(LRSN) S LRSN=$G(LRSN0)
S LRITN=$G(LRITN,LRIX)
S LRRND=LRCCOM
Q:'$G(LRSN)
S $P(^LRO(69,LRODT,1,LRSN,1),U,6)=LRRND
S X=1+$O(^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,"A"),-1),X(1)=$P($G(^(0)),U,4)
S ^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,X,0)="*"_$G(LRCCOM1)_":"_LRCCOM,X=X+1,X(1)=X(1)+1
S ^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,0)="^^"_X_U_X(1)_U_DT
K LRSAMP,LRSPEC,LRCOM,LRCCOM
QUIT
POLY ;
N LRTIC
S LRTIC=0
F S LRTIC=$O(^LRO(69,LRODT,1,LRSN,2,LRTIC)) Q:+LRTIC'>0 S LRITN=LRTIC D
. S X=1+$O(^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,"A"),-1),X(1)=$P($G(^(0)),U,4)
. S ^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,X,0)="*"_$G(LRCCOM1)_":"_LRCCOM,X=X+1,X(1)=X(1)+1
. S ^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,0)="^^"_X_U_X(1)_U_DT
K DIE,LREPISOD
S LRCOM0=LRCCOM
K LRSAMP,LRSPEC,LRCOM
QUIT
;
MULT ;
S LRSN0=0 ;--> specimen number
F S LRSN0=$O(^LRO(69,"C",LRSN,LRODT,LRSN0)) Q:+LRSN0'>0 D LRSN
QUIT
LRSN ;
;--> From LRPHITE1 when multiple tests have been cancelled
; LRCCOM is still valid since only one comment per order
;
N LRTT3
S LRTT3=0
F S LRTT3=$O(^LRO(69,LRODT,1,LRSN0,2,LRTT3)) Q:+LRTT3'>0 D
. Q:$P(^LRO(69,LRODT,1,LRSN0,2,LRTT3,0),U,9)'="CA"
. S LRTIC=0
. F S LRTIC=$O(^LRO(69,LRODT,1,LRSN0,2,LRTT3,1,LRTIC)) Q:+LRTIC'>0 D
.. Q:$D(^LRO(69,LRODT,1,LRSN0,2,LRTT3,1,LRTIC,0))
.. N LRITN S LRITN=LRTT3
.. D SINGLE
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRPHITEM 6569 printed Sep 23, 2025@19:55:01 Page 2
LRPHITEM ;SLC/CJS/RWF-ITEMIZED LOGIN ;JUNE 06, 1991@1049
+1 ;;5.2;LAB SERVICE;**121,198,208,202,221,262,528**;Sep 27, 1994;Build 3
+2 ;
+3 SET LRODT=DT
SET LRNT=$$NOW^XLFDT
+4 ;
V1 DO FNDLOC^LRDRAW
if LRLLOC["^"
GOTO END^LRPHITE1
+1 IF LRLLOC=""
WRITE !,"All locations"
SET %=2
DO YN^DICN
if %=2!(%=0)
GOTO V1
if %=-1
GOTO END^LRPHITE1
+2 IF $LENGTH(LRLLOC)
IF '$DATA(^LRO(69.1,"LRPH",1,LRLLOC))
WRITE !,"Location ",LRLLOC," not found on collection list.",$CHAR(7)
GOTO V1
+3 ;
V2 ;
+1 KILL LRSN,LROR,LRCOM,LRTCOM,LRNOCOM
+2 WRITE !!,$CHAR(7),"Enter Order Numbers NOT collected: "
SET LROR=0
SET LRFIRST=1
DO LP1
if X="^"
GOTO END^LRPHITE1
+3 ; -->Fix for 208
+4 IF $ORDER(LROR(0))>0
WRITE !,"Exceptions first."
SET LROR=0
Begin DoDot:1
+5 NEW LRLLOC,LRODT
+6 FOR
SET LROR=$ORDER(LROR(LROR))
if LROR<1
QUIT
DO EXCEPT^LRPHITE3
End DoDot:1
+7 ;
+8 KILL LRSN,LROR,LRCOM,LRTCOM
+9 WRITE !!,"Enter Order Numbers COLLECTED: "
SET LRNOCOM=1
SET LROR=""
DO LP1
if X="^"
GOTO END^LRPHITE1
+10 if LRLLOC'=""
GOTO E1
SET LRLLOC=""
FOR
SET LRLLOC=$ORDER(^LRO(69,LRODT,1,"AC",LRLLOC))
if LRLLOC=""
QUIT
DO E2
+11 DO LEFT
GOTO END^LRPHITE1
+12 ;
E1 ;
+1 DO E2
DO LEFT
GOTO END^LRPHITE1
+2 ;
LEFT if $ORDER(LROR(0))=""
QUIT
WRITE !!,"DID NOT FIND THESE ORDERS:"
SET I=0
FOR
SET I=$ORDER(LROR(I))
if I=""
QUIT
WRITE $JUSTIFY(LROR(I),10)
if $X>69
WRITE !
+1 QUIT
+2 ;
E2 ;
+1 NEW LRSTORE
+2 SET LROR=0
+3 FOR
SET LROR=$ORDER(LROR(LROR))
if LROR<1
QUIT
Begin DoDot:1
+4 SET LRSTORE(1)=LROR(LROR)
+5 SET LRSN=0
+6 FOR
SET LRSN=$ORDER(^LRO(69,"C",LRSTORE(1),LRODT,LRSN))
if LRSN=""
QUIT
Begin DoDot:2
+7 IF $GET(^LRO(69,LRODT,1,"AC",LRLLOC,LRSN))'=1
QUIT
+8 SET LRSTORE=0
+9 DO P15
+10 WRITE !,LRLLOC," ",LRSTORE(1)
+11 if '$GET(LRSTORE)
WRITE " Not Accepted !! ",$CHAR(7)
+12 KILL LROR(LROR)
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
+15 ;
P15 ;from LROE1, LRPHEXPT
+1 NEW LRORIFN,LRX712,LRUIDA
+2 ;
+3 if '$DATA(^LRO(69,LRODT,1,LRSN,1))
QUIT
if $LENGTH($PIECE(^(1),U,4))
QUIT
SET J1=^(1)
SET LRX712=^(0)
+4 SET LRDFN=+LRX712
KILL LRDPF
+5 Begin DoDot:1
+6 NEW LRRB
+7 DO PT^LRX
End DoDot:1
+8 SET LROLLOC=$PIECE(LRX712,U,9)
+9 SET LRTREA=+$GET(VAIN(3))
+10 SET LRORIFN=$PIECE(LRX712,U,11)
+11 SET LRNT=$$NOW^XLFDT
+12 ;
+13 ;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)
+14 SET $PIECE(^LRO(69,LRODT,1,LRSN,1),U,3)=DUZ
+15 ;
+16 SET $PIECE(^LRO(69,LRODT,1,LRSN,3),U)=LRNT
SET ^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=""
+17 SET (LRAA,LRAD,LRAN,LRTN)=0
+18 FOR
SET LRTN=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTN))
if LRTN<1
QUIT
Begin DoDot:1
+19 IF '$DATA(^LRO(69,LRODT,1,LRSN,2,LRTN,0))
QUIT
+20 SET X=^LRO(69,LRODT,1,LRSN,2,LRTN,0)
SET LRAA=+$PIECE(X,U,4)
SET LRAD=+$PIECE(X,U,3)
SET LRAN=+$PIECE(X,U,5)
SET LRORIFN=$PIECE(X,U,7)
+21 DO P15A
+22 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
Begin DoDot:2
+23 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)=LRNT
+24 SET ^LRO(68,LRAA,1,LRAD,1,"E",LRNT,LRAN)=""
End DoDot:2
End DoDot:1
+25 ;
+26 IF +$GET(LRDPF)=2
Begin DoDot:1
+27 NEW CONTROL
+28 SET CONTROL=$SELECT($LENGTH(LRORIFN):"SC",1:"SN")
+29 DO NEW^LR7OB1(LRODT,LRSN,CONTROL,,,6)
End DoDot:1
+30 ;
+31 NEW LRX
+32 SET LRX=""
+33 FOR
SET LRX=$ORDER(LRUIDA(LRX))
if LRX=""
QUIT
DO EN^LA7ADL(LRX)
+34 ;
+35 QUIT
+36 ;
+37 ;
P15A ;
+1 IF $GET(LRDPF)=2
IF $$VER^LR7OU1<3
if LRAA
DO OR^LRWLST
SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRTN,0),U,7)=LRORIFN
+2 if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
QUIT
+3 SET $PIECE(^LRO(69,LRODT,1,LRSN,1),U,4)="C"
SET $PIECE(^(1),U,8)=DUZ(2)
SET LRRB=""
SET $PIECE(^LRO(69,LRODT,1,LRSN,1),U)=LRNT
SET ^LRO(69,"AA",+$GET(^(.1)),LRODT_"|"_LRSN)=""
+4 SET LRSTORE=1
+5 ;
+6 ; Save list of uid's on this order, used above to download to Lab UI.
+7 NEW X
+8 SET X=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),U)
+9 IF $LENGTH(X)
SET LRUIDA(X)=""
+10 QUIT
+11 ;
P16 ;from LRPHITE1
+1 NEW X
+2 if '$DATA(^LRO(69,LRODT,1,LRSN,1))#2
QUIT
+3 SET LRSS=$PIECE(^LRO(68,LRAA,0),"^",2)
+4 if '$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
QUIT
SET LRDFN=+^(0)
SET LRDPF=$PIECE(^(0),U,2)
+5 SET LRDTM=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U)
SET LRIDT=+$PIECE(^(3),U,5)
+6 IF $SELECT('LRIDT:1,'$DATA(^LR(LRDFN,LRSS,LRIDT,0))#2:1,1:0)
SET LRNOP=1
WRITE !?5,"Accession Information Corrupt for this Order",!!
QUIT
+7 IF $PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,3)
WRITE !,$CHAR(7),"CAN'T DO IT. The data has been verified for accession ",$PIECE(^(0),U,6)
SET LRNOP=1
QUIT
SKP SET $PIECE(^LRO(69,LRODT,1,LRSN,1),U,3)=DUZ
SET $PIECE(^(1),U,4)="U"
if 'LRBATCH
GOTO P17
+1 SET X=$ORDER(LRCOM(999-LROR))
SET LRRND=$SELECT($LENGTH(LRRND):LRRND,X>0:LRCOM(X,1,1),1:"")
P17 if $LENGTH(LRRND)
GOTO P18
WRITE !,"REASON FOR NON-DRAW ON ORDER ",LROR(LROR)
+1 WRITE " ",$GET(LRCCOM)
+2 IF $GET(LREPISOD)
KILL LREPISOD
+3 SET LRSAMP=1
SET LRSPEC=1
SET LREND=0
IF '$LENGTH(LRRND)
FOR
Begin DoDot:1
+4 NEW LRCCOM,LRCCOM1,LRCCOMX
DO FX2^LRTSTOUT
SET LRRND=LRCCOM
End DoDot:1
if $LENGTH(LRRND)!($GET(LREND))
QUIT
WRITE !?5,"You must enter a reason.",!
+5 if $GET(LREND)
QUIT
P18 SET $PIECE(^LRO(69,LRODT,1,LRSN,1),U,6)=LRRND
+1 if $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
DO OUT^LRPHITE2
+2 QUIT
LP1 ;from LRPHEXPT
+1 NEW Y1
+2 SET LRFORD=LROR
KILL LRCCOM,LRCOM0
+3 WRITE !,"Enter Order #(s) :",!
READ X:DTIME
if (X="^"!(X="")!('$TEST))
QUIT
WRITE !
IF (X="?"!($LENGTH(X)>80))
WRITE !,"Enter a string of numbers separated with A ',' UP TO 80 CHARACTERS LONG ",!
GOTO LP1
+4 WRITE !
FOR I=1:1
SET LRSN=+$PIECE(X,",",I)
if LRSN=0
QUIT
Begin DoDot:1
+5 SET Y1=$ORDER(^LRO(69,"C",+LRSN,LRODT,0))
+6 ;----->LR*5.2*182
SET Y=Y1
if Y1<1
DO TEXT
SET LRSN0=Y1
+7 IF Y1'=""
IF $$ALLCA(LRODT,+LRSN)
SET Y=0
DO TEXT
QUIT
+8 IF Y1'=""
SET LRWD=$PIECE(^LRO(69,LRODT,1,Y1,0),U,7)
if LRLLOC'=""
SET Y=$SELECT(LRWD=LRLLOC:$DATA(^LRO(69,LRODT,1,Y,1)),1:"")
if Y
SET LROR=LROR+1
SET LROR(LROR)=+LRSN
DO TEXT
End DoDot:1
198 ;
+1 SET LRSAMP=999-LRFORD
SET LRSPEC=1
SET LRCOM(LRSAMP,1,1)=""
SET LRCOM(LRSAMP,1)=0
+2 GOTO LP1
ALLCA(LRSD,LRON) ;Are all tests cancelled?
+1 NEW LRI,LRC,LRSN,LRX
+2 SET LRC=1
SET LRSN=0
+3 FOR
SET LRSN=$ORDER(^LRO(69,"C",LRON,LRSD,LRSN))
if +LRSN'>0
QUIT
SET LRI=0
Begin DoDot:1
+4 FOR
SET LRI=$ORDER(^LRO(69,LRSD,1,LRSN,2,LRI))
if +LRI'>0
QUIT
Begin DoDot:2
+5 SET LRX=^LRO(69,LRSD,1,LRSN,2,LRI,0)
SET LRX=$PIECE(LRX,U,9)
End DoDot:2
IF LRX'="CA"
SET LRC=0
QUIT
End DoDot:1
if LRC=0
QUIT
+6 QUIT LRC
TEXT if Y<1
SET Y=""
if $X>70
WRITE !
WRITE +LRSN,$SELECT(Y:" OK, ",1:" NOT ON LIST, ")
+1 QUIT
+2 ;--> LR*5.2*182
SINGLE ;
+1 NEW X
+2 if $GET(LREPISOD)=1
QUIT
+3 SET LREPISOD=1
+4 IF '$GET(LRSN)
SET LRSN=$GET(LRSN0)
+5 SET LRITN=$GET(LRITN,LRIX)
+6 SET LRRND=LRCCOM
+7 if '$GET(LRSN)
QUIT
+8 SET $PIECE(^LRO(69,LRODT,1,LRSN,1),U,6)=LRRND
+9 SET X=1+$ORDER(^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,"A"),-1)
SET X(1)=$PIECE($GET(^(0)),U,4)
+10 SET ^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,X,0)="*"_$GET(LRCCOM1)_":"_LRCCOM
SET X=X+1
SET X(1)=X(1)+1
+11 SET ^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,0)="^^"_X_U_X(1)_U_DT
+12 KILL LRSAMP,LRSPEC,LRCOM,LRCCOM
+13 QUIT
POLY ;
+1 NEW LRTIC
+2 SET LRTIC=0
+3 FOR
SET LRTIC=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTIC))
if +LRTIC'>0
QUIT
SET LRITN=LRTIC
Begin DoDot:1
+4 SET X=1+$ORDER(^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,"A"),-1)
SET X(1)=$PIECE($GET(^(0)),U,4)
+5 SET ^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,X,0)="*"_$GET(LRCCOM1)_":"_LRCCOM
SET X=X+1
SET X(1)=X(1)+1
+6 SET ^LRO(69,LRODT,1,LRSN,2,LRITN,1.1,0)="^^"_X_U_X(1)_U_DT
End DoDot:1
+7 KILL DIE,LREPISOD
+8 SET LRCOM0=LRCCOM
+9 KILL LRSAMP,LRSPEC,LRCOM
+10 QUIT
+11 ;
MULT ;
+1 ;--> specimen number
SET LRSN0=0
+2 FOR
SET LRSN0=$ORDER(^LRO(69,"C",LRSN,LRODT,LRSN0))
if +LRSN0'>0
QUIT
DO LRSN
+3 QUIT
LRSN ;
+1 ;--> From LRPHITE1 when multiple tests have been cancelled
+2 ; LRCCOM is still valid since only one comment per order
+3 ;
+4 NEW LRTT3
+5 SET LRTT3=0
+6 FOR
SET LRTT3=$ORDER(^LRO(69,LRODT,1,LRSN0,2,LRTT3))
if +LRTT3'>0
QUIT
Begin DoDot:1
+7 if $PIECE(^LRO(69,LRODT,1,LRSN0,2,LRTT3,0),U,9)'="CA"
QUIT
+8 SET LRTIC=0
+9 FOR
SET LRTIC=$ORDER(^LRO(69,LRODT,1,LRSN0,2,LRTT3,1,LRTIC))
if +LRTIC'>0
QUIT
Begin DoDot:2
+10 if $DATA(^LRO(69,LRODT,1,LRSN0,2,LRTT3,1,LRTIC,0))
QUIT
+11 NEW LRITN
SET LRITN=LRTT3
+12 DO SINGLE
End DoDot:2
End DoDot:1
+13 QUIT
