LRFLAG ; IHS/DIR/FJE - SEARCH ^LRO(68.2,INST,8, FOR FLAGED SAMP 2/5/91 13:16 ;
;;5.2;LR;**1013**;JUL 15, 2002
;
;;5.2;LAB SERVICE;;Sep 27, 1994
D FLAG,END Q
FLAG W !!,"PROCESS FLAGGED SPECIMENS",!
D INST Q:LRLL<1
S %H=$H-60,X=DUZ D DUZ^LRX,YMD^LRX S LRTM60=9999999-X
S LRSQ=0 F S LRSQ=$O(^LRO(68.2,LRLL,8,LRSQ)) Q:LRSQ<1 D VER
W !!,$C(7),"Do you want to clear the FLAG Specimen List" S %=1 D YN^DICN I %=1 K ^LRO(68.2,LRLL,8)
W:%=1 !!,"DONE" Q
VER ;
S X=$S($D(^LAH(LRLL,1,LRSQ,0)):^(0),1:""),LRAD=+$P(X,U,4),LRAA=+$P(X,U,3),LRAN=+$P(X,U,5) I X="" Q ;W "DON'T KNOW WHO'S DATA THIS IS" Q
S LREND=0,LRTSE=-1 I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) Q ;W " CAN'T FIND THE ACCESSION" Q
S LRPDT=LRAD,X=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)):^(0),1:"") Q:X="" S LRDFN=+X,LRCEN=0,LRIDT=9999999-^(3),LRODT=$P(X,U,4),LRSN=$P(X,U,5)
;S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3) D PT^LRX W !,PNM,?30,SSN W:LRCEN !,"ORDER #: ",LRCEN
S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3) D PT^LRX W !,PNM,?30,HRCN W:LRCEN !,"ORDER #: ",LRCEN ;IHS/ANMC/CLS 11/1/95
K LRVTS F I6=1:0 S I6=$O(^LAH(LRLL,1,LRSQ,I6)) Q:I6<1 I ^(I6)]"",+^(I6)'=^(I6) S LRVTS(I6)=""
W !,"Auto Sequence #:",LRSQ," Accession #:",LRAN
I '$D(LRVTS) W !,"DIDN'T FIND ANY TESTS THAT NEED EDITING" Q
D VER^LRVR1
Q
INST S LRSS="CH",LRPER=0,LRLL=0 D ADATE^LRWU Q:LRAD<1
S U="^",DIC="^LRO(68.2,",DIC(0)="AEMQ" D ^DIC S LRLL=+Y Q:Y<1
S LRPROF=$O(^LRO(68.2,LRLL,10,0)) I LRPROF<1 W !,"No profile defined." Q
S B=$O(^LRO(68.2,LRLL,10,LRPROF))
I B>0 S DIC="^LRO(68.2,"_LRLL_",10," D ^DIC Q:Y<1 S LRPROF=+Y
S LRAA=$P(^LRO(68.2,LRLL,10,LRPROF,0),U,2),LRPANEL=$P(^(0),U,1)
D EXPAND^LRVR
F I=0:0 S I=$O(LRORD(I)) Q:I'>0 S X=LRORD(I),X=$P(^LAB(60,+X,0),U,5),LRORD(I)=$P(X,";",2)
Q
CLEAR D INST Q:LRLL<1
K ^LRO(68.2,LRLL,8) W !,"DONE" Q
END K LRAA,LRACD,LRAD,LRAN,LRAOD,LRCDT,LRCW,LRDAT,LRDEL,LRDFN,LRDPF,LRDV,LRDVF,LREAL,LREDIT,LREXEC,LRFFLG,LRFP,LRGVP,LRIDT,LRINI,LRIOZERO,LRLCT,LRLDT,LRLK,LRLL,LRLLOC,LRMETH,LRMK,LRNG,LRNG2,LRNG3,LRNG4,LRNG5,LRNT,LRNTN,LRNX
;K I6,LRODT,LROUTINE,LRPANEL,LRPDT,LRPER,LRPLOC,LRPROF,LRSAMP,LRSN,LRSPEC,LRSQ,LRSS,LRSSQ,LRSUB,LRTEC,LRTM60,LRTN,LRTRAY,LRTRCP,LRTS,LRTSE,LRTX,LRUSI,LRVF,LRVOL,LRVRM,LRXD,LRXDH,LRXDP,N,N2,PNM,SEX,SSN,T,T1,X1,X2,X5,X6,X7,X9,Z1,Z2
K I6,LRODT,LROUTINE,LRPANEL,LRPDT,LRPER,LRPLOC,LRPROF,LRSAMP,LRSN,LRSPEC,LRSQ,LRSS,LRSSQ,LRSUB,LRTEC,LRTM60,LRTN,LRTRAY,LRTRCP,LRTS,LRTSE,LRTX,LRUSI,LRVF,LRVOL,LRVRM,LRXD,LRXDH,LRXDP,N,N2,PNM,SEX,SSN,HRCN,T,T1,X1,X2,X5,X6,X7,X9,Z1,Z2
Q ;IHS/ANMC/CLS 11/1/95
LRFLAG ; IHS/DIR/FJE - SEARCH ^LRO(68.2,INST,8, FOR FLAGED SAMP 2/5/91 13:16 ;
+1 ;;5.2;LR;**1013**;JUL 15, 2002
+2 ;
+3 ;;5.2;LAB SERVICE;;Sep 27, 1994
+4 DO FLAG
DO END
QUIT
FLAG WRITE !!,"PROCESS FLAGGED SPECIMENS",!
+1 DO INST
IF LRLL<1
QUIT
+2 SET %H=$HOROLOG-60
SET X=DUZ
DO DUZ^LRX
DO YMD^LRX
SET LRTM60=9999999-X
+3 SET LRSQ=0
FOR
SET LRSQ=$ORDER(^LRO(68.2,LRLL,8,LRSQ))
IF LRSQ<1
QUIT
DO VER
+4 WRITE !!,$CHAR(7),"Do you want to clear the FLAG Specimen List"
SET %=1
DO YN^DICN
IF %=1
KILL ^LRO(68.2,LRLL,8)
+5 IF %=1
WRITE !!,"DONE"
QUIT
VER ;
+1 ;W "DON'T KNOW WHO'S DATA THIS IS" Q
SET X=$SELECT($DATA(^LAH(LRLL,1,LRSQ,0)):^(0),1:"")
SET LRAD=+$PIECE(X,U,4)
SET LRAA=+$PIECE(X,U,3)
SET LRAN=+$PIECE(X,U,5)
IF X=""
QUIT
+2 ;W " CAN'T FIND THE ACCESSION" Q
SET LREND=0
SET LRTSE=-1
IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
QUIT
+3 SET LRPDT=LRAD
SET X=$SELECT($DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0)):^(0),1:"")
IF X=""
QUIT
SET LRDFN=+X
SET LRCEN=0
SET LRIDT=9999999-^(3)
SET LRODT=$PIECE(X,U,4)
SET LRSN=$PIECE(X,U,5)
+4 ;S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3) D PT^LRX W !,PNM,?30,SSN W:LRCEN !,"ORDER #: ",LRCEN
+5 ;IHS/ANMC/CLS 11/1/95
SET LRDPF=$PIECE(^LR(LRDFN,0),"^",2)
SET DFN=$PIECE(^(0),"^",3)
DO PT^LRX
WRITE !,PNM,?30,HRCN
IF LRCEN
WRITE !,"ORDER #: ",LRCEN
+6 KILL LRVTS
FOR I6=1:0
SET I6=$ORDER(^LAH(LRLL,1,LRSQ,I6))
IF I6<1
QUIT
IF ^(I6)]""
IF +^(I6)'=^(I6)
SET LRVTS(I6)=""
+7 WRITE !,"Auto Sequence #:",LRSQ," Accession #:",LRAN
+8 IF '$DATA(LRVTS)
WRITE !,"DIDN'T FIND ANY TESTS THAT NEED EDITING"
QUIT
+9 DO VER^LRVR1
+10 QUIT
INST SET LRSS="CH"
SET LRPER=0
SET LRLL=0
DO ADATE^LRWU
IF LRAD<1
QUIT
+1 SET U="^"
SET DIC="^LRO(68.2,"
SET DIC(0)="AEMQ"
DO ^DIC
SET LRLL=+Y
IF Y<1
QUIT
+2 SET LRPROF=$ORDER(^LRO(68.2,LRLL,10,0))
IF LRPROF<1
WRITE !,"No profile defined."
QUIT
+3 SET B=$ORDER(^LRO(68.2,LRLL,10,LRPROF))
+4 IF B>0
SET DIC="^LRO(68.2,"_LRLL_",10,"
DO ^DIC
IF Y<1
QUIT
SET LRPROF=+Y
+5 SET LRAA=$PIECE(^LRO(68.2,LRLL,10,LRPROF,0),U,2)
SET LRPANEL=$PIECE(^(0),U,1)
+6 DO EXPAND^LRVR
+7 FOR I=0:0
SET I=$ORDER(LRORD(I))
IF I'>0
QUIT
SET X=LRORD(I)
SET X=$PIECE(^LAB(60,+X,0),U,5)
SET LRORD(I)=$PIECE(X,";",2)
+8 QUIT
CLEAR DO INST
IF LRLL<1
QUIT
+1 KILL ^LRO(68.2,LRLL,8)
WRITE !,"DONE"
QUIT
END KILL LRAA,LRACD,LRAD,LRAN,LRAOD,LRCDT,LRCW,LRDAT,LRDEL,LRDFN,LRDPF,LRDV,LRDVF,LREAL,LREDIT,LREXEC,LRFFLG,LRFP,LRGVP,LRIDT,LRINI,LRIOZERO,LRLCT,LRLDT,LRLK,LRLL,LRLLOC,LRMETH,LRMK,LRNG,LRNG2,LRNG3,LRNG4,LRNG5,LRNT,LRNTN,LRNX
+1 ;K I6,LRODT,LROUTINE,LRPANEL,LRPDT,LRPER,LRPLOC,LRPROF,LRSAMP,LRSN,LRSPEC,LRSQ,LRSS,LRSSQ,LRSUB,LRTEC,LRTM60,LRTN,LRTRAY,LRTRCP,LRTS,LRTSE,LRTX,LRUSI,LRVF,LRVOL,LRVRM,LRXD,LRXDH,LRXDP,N,N2,PNM,SEX,SSN,T,T1,X1,X2,X5,X6,X7,X9,Z1,Z2
+2 KILL I6,LRODT,LROUTINE,LRPANEL,LRPDT,LRPER,LRPLOC,LRPROF,LRSAMP,LRSN,LRSPEC,LRSQ,LRSS,LRSSQ,LRSUB,LRTEC,LRTM60,LRTN,LRTRAY,LRTRCP,LRTS,LRTSE,LRTX,LRUSI,LRVF,LRVOL,LRVRM,LRXD,LRXDH,LRXDP,N,N2,PNM,SEX,SSN,HRCN,T,T1,X1,X2,X5,X6,X7,X9,Z1,Z2
+3 ;IHS/ANMC/CLS 11/1/95
QUIT
