LRVR ;DALOI/STAFF - LAB ROUTINE DATA VERIFICATION ;06/05/10 00:33
;;5.2;LAB SERVICE;**42,153,263,286,350**;Sep 27, 1994;Build 230
;
N LRDUZ,LRVBY
D INIT G QUIT:$G(LREND)
S LRVBY=$$GET^XPAR("USR^PKG","LR VER EA VERIFY BY UID","`"_LRAA,"Q")
I LRVBY<2 S LRVBY=$$SELBY^LRWU4("Verify by",LRVBY+1)
I "MISPEMCY"[$P($G(^LRO(68,LRAA,0)),U,2) D EN^LRVR0,QUIT Q
I LRVBY=0 D QUIT Q
I LRVBY=2 D ^LRVRA,QUIT Q
DAT D ADATE^LRWU G:LRAD<1 QUIT
I $P(^LRO(68,LRAA,0),U,3)="D" F I=0:0 S I=$O(^LRO(68,LRAA,1,LRAD,1,I)) Q:I<1 I $D(^LRO(68,LRAA,1,LRAD,1,I,3)),'$P(^(3),U,4) S LRAN=I Q
S:$D(^LRO(68,LRAA,1,LRAD,2))&'LRAN LRAN=$P(^(2),U,4)
;
L10 ;
S LRCFL="",EAMODE=1
K LRTEST,C5,LRSET,LRLDT,DIC,LRNM,LRNG,LRDL,LRDEL,T,LRFP,LRAB,LRVER,Y,Z
D WLN G QUIT:LREND
D ^LRVR1,NEXT
G L10
;
;
YN R X:DTIME Q:X=""!(X["N")!(X["Y") W !,"Answer 'Y' or 'N': " G YN
;
;
WLN ;
S LRNOP=0
K DIR,DIRUT,DTOUT,DUOUT
S DIR(0)="NAO^1:999999:0"
S DIR("A")="Accession NUMBER: ",DIR("?")="^D LW^LRVR"
I LRAN'="" S DIR("B")=LRAN
D ^DIR K DIR
I $D(DIRUT) G STOP
S LRAN=Y
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W !,"NOT ON FILE" S LRNOP=1
WLN2 ;
I '$G(LRNOP) D
. S LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRCEN=$S($D(^(.1)):^(.1),1:0),LRODT=$S($P(^(0),U,4):$P(^(0),U,4),1:$P(^(0),U,3)),LRSN=$P(^(0),U,5)
. S LRORU3=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
I '$G(LRNOP),$P(LRORU3,U)="" W !?10,"No UID number for this accession",! S LRNOP=1
I '$G(LRNOP) S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !,PNM,?30,SSN W:LRCEN !,"ORDER #: ",LRCEN
S LRCDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U)
I '$G(LRNOP),'$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",3) D
. N %DT,LRA1,LRA2,LRA3
. S %DT("B")=$$FMTE^XLFDT(LRCDT,"1")
. S LRSTATUS="C",LRA1=LRAA,LRA2=LRAD,LRA3=LRAN
. D P15^LROE1
. S LRAA=LRA1,LRAD=LRA2,LRAN=LRA3
. I LRCDT<1 S LRNOP=1 Q
. I '$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,3) S $P(^(3),U,3)=$$NOW^XLFDT
; If user did not update then go to next accession
I '$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,3) S LRNOP=1
S LRCDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U)
I $G(LRCDT)<1 S (LRCDT,LRNOP)=1
;
S LRSS=$P(^LRO(68,LRAA,0),U,2)
I '$G(LRNOP),LRSS'="CH" S LRNOP=1
; Check for valid pointer to file #63 and entry in file #63.
S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
I '$G(LRNOP),LRIDT<1 W !,">>>>ERROR - NO POINTER TO FILE #63 - PLEASE NOTIFY SYSTEM MANAGER^ <<<<<",! S LRNOP=1
I '$G(LRNOP),'$D(^LR(LRDFN,LRSS,LRIDT,0)) W !,">>>>ERROR - NO ENTRY IN FILE #63 - PLEASE NOTIFY SYSTEM MANAGER<<^ <<<",! S LRNOP=1
;
I '$G(LRNOP),$D(^LRO(69,LRODT,1,LRSN)),'$D(^(LRSN,1)) W !,"This Order # has not been collected",$C(7) S LRNOP=1
I '$G(LRNOP),$D(^LRO(69,LRODT,1,LRSN,1)),$P(^LRO(69,LRODT,1,LRSN,1),U,4)'="C" W !,"You cannot verify an accession which has not been collected.",$C(7) S LRNOP=1
I $G(LRNOP) D NEXT G WLN
;
Q
;
;
LW ;
N S
W !,"Enter range of accession numbers which might apply."
D LRAN^LRWU3 Q:LREND
S LRDT=$$FMTE^XLFDT($$DT^XLFDT,"5F")
S S("LRAA")=LRAA,S("LRAD")=LRAD,S("LRAN")=LRAN
D W^LRWRKLST
S LREND=0,LRAA=S("LRAA"),LRAD=S("LRAD"),LRAN=S("LRAN")
Q
;
;
QUIT I $G(LRAN),$G(LRAA),$G(LRAD) S LREND=1 I $D(^LRO(68,LRAA,1,LRAD,0)) S:'$D(^(2)) ^(2)="^^" S ^(2)=$P(^(2),U,1,3)_U_LRAN_U_$P(^(2),U,5,99),LREND=1
;
CLEAN ;
I $D(LRCSQ),'$O(^XTMP("LRCAP",LRCSQ,DUZ,0)) K ^XTMP("LRCAP",LRCSQ,DUZ)
E I $D(LRAA) D:$P(LRPARAM,U,14)&($P($G(^LRO(68,+LRAA,0)),U,16)) STD^LRCAPV K LRIDIV
K DIR,LRCMTDSP,LRNOP,XP
D ^LRVRKIL
S ZTIO="",ZTRTN="LRCAPV2",ZTDTH=$H,ZTDESC="LAB LRCAPV2 ROUTINE"
D ^%ZTLOAD K ZTSK
Q
;
;
NEXT S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN)) I LRAN'>0 W !,"LAST IN WORK LIST" S LRAN="^"
S LREND=0
Q
;
;
LIST W " the following tests: " F I=0:0 S I=$O(LRTST(I)) Q:I<1 W !,?10,$P(LRTST(I),"^",1)
Q
;
;
EXPAND D EXPLODE^LRGP2
SKPEX Q:$O(LRVTS(0)) ; READY TO GO
STOP S LREND=1
Q
;
;
INIT ;from LRVRW
N DIC,LRX
D ^LRPARAM Q:$G(LREND)
S LREND=0,LRAN=0 K LRORD,LRDUZ
S DIC="^LRO(68.2,",DIC(0)="AEMZ",DIC("S")="S LRX=$P(^(0),U,12) Q:'$L(LRX) I $D(^XUSEC($P($G(^DIC(19.1,LRX,0)),U),DUZ))"
D ^DIC K DIC("S") G STOP:Y<1 S LRLL=+Y,LRTYPE=$P(Y(0),U,3)
S LRPROF=$O(^LRO(68.2,LRLL,10,0))
I LRPROF<1 S LREND=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 G STOP:Y<1 S LRPROF=+Y
S X=^LRO(68.2,LRLL,10,LRPROF,0),LRAA=$P(X,U,2),LRPANEL=$P(X,U) I '$D(^LRO(68,LRAA,0))#2 W !?10,$C(7),"Error in your DATABASE. There is not an accession area # ",LRAA,!! Q
;
; Select performing laboratory to use
S LRX=$$SELPL^LRVERA($S($P(X,"^",5):$P(X,"^",5),1:DUZ(2)))
I LRX<1 S LREND=1 Q
I LRX,LRX'=DUZ(2) S LRDUZ(2)=LRX
;
D:$P(LRPARAM,U,14)&($P($G(^LRO(68,LRAA,0)),U,16)) AUTO^LRCAPV Q:LREND
;
I "MISPCYEM"[$P(^LRO(68,LRAA,0),U,2) Q
;
G STOP:$P(^LRO(68,LRAA,0),U,2)'="CH"
S LREND=0 D EXPAND G STOP:LREND!($O(LRVTS(0))<0)
;
CONT ;
F I=0:0 S I=$O(LRORD(I)) Q:I<1 S J=LRORD(I),X=$P(^LAB(60,J,0),U,5),LRORD(I)=$P(X,";",2)
S Y=^LRO(68,LRAA,0),LRTSE=-1
;
D CMTDSP^LRVERA
;
REV ;
K LRPER
D REV^LRVER
Q
;
;
LRTM60(LRX) ; Calculate days back for delta check based on specimen collection date/time
;
; Call with LRX = specimen collection date/time (FileMan D/T format)
;
; Return LRY = Inverse date/time value of delta days back
;
N LRDB,LRY
S LRDB=$P($G(^LAB(69.9,1,0)),U,7)
I LRDB="" S LRDB=1
S LRY=9999999-$$FMADD^XLFDT(LRX,-LRDB)
Q LRY
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRVR 5499 printed Nov 22, 2024@17:32:40 Page 2
LRVR ;DALOI/STAFF - LAB ROUTINE DATA VERIFICATION ;06/05/10 00:33
+1 ;;5.2;LAB SERVICE;**42,153,263,286,350**;Sep 27, 1994;Build 230
+2 ;
+3 NEW LRDUZ,LRVBY
+4 DO INIT
if $GET(LREND)
GOTO QUIT
+5 SET LRVBY=$$GET^XPAR("USR^PKG","LR VER EA VERIFY BY UID","`"_LRAA,"Q")
+6 IF LRVBY<2
SET LRVBY=$$SELBY^LRWU4("Verify by",LRVBY+1)
+7 IF "MISPEMCY"[$PIECE($GET(^LRO(68,LRAA,0)),U,2)
DO EN^LRVR0
DO QUIT
QUIT
+8 IF LRVBY=0
DO QUIT
QUIT
+9 IF LRVBY=2
DO ^LRVRA
DO QUIT
QUIT
DAT DO ADATE^LRWU
if LRAD<1
GOTO QUIT
+1 IF $PIECE(^LRO(68,LRAA,0),U,3)="D"
FOR I=0:0
SET I=$ORDER(^LRO(68,LRAA,1,LRAD,1,I))
if I<1
QUIT
IF $DATA(^LRO(68,LRAA,1,LRAD,1,I,3))
IF '$PIECE(^(3),U,4)
SET LRAN=I
QUIT
+2 if $DATA(^LRO(68,LRAA,1,LRAD,2))&'LRAN
SET LRAN=$PIECE(^(2),U,4)
+3 ;
L10 ;
+1 SET LRCFL=""
SET EAMODE=1
+2 KILL LRTEST,C5,LRSET,LRLDT,DIC,LRNM,LRNG,LRDL,LRDEL,T,LRFP,LRAB,LRVER,Y,Z
+3 DO WLN
if LREND
GOTO QUIT
+4 DO ^LRVR1
DO NEXT
+5 GOTO L10
+6 ;
+7 ;
YN READ X:DTIME
if X=""!(X["N")!(X["Y")
QUIT
WRITE !,"Answer 'Y' or 'N': "
GOTO YN
+1 ;
+2 ;
WLN ;
+1 SET LRNOP=0
+2 KILL DIR,DIRUT,DTOUT,DUOUT
+3 SET DIR(0)="NAO^1:999999:0"
+4 SET DIR("A")="Accession NUMBER: "
SET DIR("?")="^D LW^LRVR"
+5 IF LRAN'=""
SET DIR("B")=LRAN
+6 DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)
GOTO STOP
+8 SET LRAN=Y
+9 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
WRITE !,"NOT ON FILE"
SET LRNOP=1
WLN2 ;
+1 IF '$GET(LRNOP)
Begin DoDot:1
+2 SET LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRCEN=$SELECT($DATA(^(.1)):^(.1),1:0)
SET LRODT=$SELECT($PIECE(^(0),U,4):$PIECE(^(0),U,4),1:$PIECE(^(0),U,3))
SET LRSN=$PIECE(^(0),U,5)
+3 SET LRORU3=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
End DoDot:1
+4 IF '$GET(LRNOP)
IF $PIECE(LRORU3,U)=""
WRITE !?10,"No UID number for this accession",!
SET LRNOP=1
+5 IF '$GET(LRNOP)
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
WRITE !,PNM,?30,SSN
if LRCEN
WRITE !,"ORDER #: ",LRCEN
+6 SET LRCDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U)
+7 IF '$GET(LRNOP)
IF '$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",3)
Begin DoDot:1
+8 NEW %DT,LRA1,LRA2,LRA3
+9 SET %DT("B")=$$FMTE^XLFDT(LRCDT,"1")
+10 SET LRSTATUS="C"
SET LRA1=LRAA
SET LRA2=LRAD
SET LRA3=LRAN
+11 DO P15^LROE1
+12 SET LRAA=LRA1
SET LRAD=LRA2
SET LRAN=LRA3
+13 IF LRCDT<1
SET LRNOP=1
QUIT
+14 IF '$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,3)
SET $PIECE(^(3),U,3)=$$NOW^XLFDT
End DoDot:1
+15 ; If user did not update then go to next accession
+16 IF '$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,3)
SET LRNOP=1
+17 SET LRCDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U)
+18 IF $GET(LRCDT)<1
SET (LRCDT,LRNOP)=1
+19 ;
+20 SET LRSS=$PIECE(^LRO(68,LRAA,0),U,2)
+21 IF '$GET(LRNOP)
IF LRSS'="CH"
SET LRNOP=1
+22 ; Check for valid pointer to file #63 and entry in file #63.
+23 SET LRIDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
+24 IF '$GET(LRNOP)
IF LRIDT<1
WRITE !,">>>>ERROR - NO POINTER TO FILE #63 - PLEASE NOTIFY SYSTEM MANAGER^ <<<<<",!
SET LRNOP=1
+25 IF '$GET(LRNOP)
IF '$DATA(^LR(LRDFN,LRSS,LRIDT,0))
WRITE !,">>>>ERROR - NO ENTRY IN FILE #63 - PLEASE NOTIFY SYSTEM MANAGER<<^ <<<",!
SET LRNOP=1
+26 ;
+27 IF '$GET(LRNOP)
IF $DATA(^LRO(69,LRODT,1,LRSN))
IF '$DATA(^(LRSN,1))
WRITE !,"This Order # has not been collected",$CHAR(7)
SET LRNOP=1
+28 IF '$GET(LRNOP)
IF $DATA(^LRO(69,LRODT,1,LRSN,1))
IF $PIECE(^LRO(69,LRODT,1,LRSN,1),U,4)'="C"
WRITE !,"You cannot verify an accession which has not been collected.",$CHAR(7)
SET LRNOP=1
+29 IF $GET(LRNOP)
DO NEXT
GOTO WLN
+30 ;
+31 QUIT
+32 ;
+33 ;
LW ;
+1 NEW S
+2 WRITE !,"Enter range of accession numbers which might apply."
+3 DO LRAN^LRWU3
if LREND
QUIT
+4 SET LRDT=$$FMTE^XLFDT($$DT^XLFDT,"5F")
+5 SET S("LRAA")=LRAA
SET S("LRAD")=LRAD
SET S("LRAN")=LRAN
+6 DO W^LRWRKLST
+7 SET LREND=0
SET LRAA=S("LRAA")
SET LRAD=S("LRAD")
SET LRAN=S("LRAN")
+8 QUIT
+9 ;
+10 ;
QUIT IF $GET(LRAN)
IF $GET(LRAA)
IF $GET(LRAD)
SET LREND=1
IF $DATA(^LRO(68,LRAA,1,LRAD,0))
if '$DATA(^(2))
SET ^(2)="^^"
SET ^(2)=$PIECE(^(2),U,1,3)_U_LRAN_U_$PIECE(^(2),U,5,99)
SET LREND=1
+1 ;
CLEAN ;
+1 IF $DATA(LRCSQ)
IF '$ORDER(^XTMP("LRCAP",LRCSQ,DUZ,0))
KILL ^XTMP("LRCAP",LRCSQ,DUZ)
+2 IF '$TEST
IF $DATA(LRAA)
if $PIECE(LRPARAM,U,14)&($PIECE($GET(^LRO(68,+LRAA,0)),U,16))
DO STD^LRCAPV
KILL LRIDIV
+3 KILL DIR,LRCMTDSP,LRNOP,XP
+4 DO ^LRVRKIL
+5 SET ZTIO=""
SET ZTRTN="LRCAPV2"
SET ZTDTH=$HOROLOG
SET ZTDESC="LAB LRCAPV2 ROUTINE"
+6 DO ^%ZTLOAD
KILL ZTSK
+7 QUIT
+8 ;
+9 ;
NEXT SET LRAN=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN))
IF LRAN'>0
WRITE !,"LAST IN WORK LIST"
SET LRAN="^"
+1 SET LREND=0
+2 QUIT
+3 ;
+4 ;
LIST WRITE " the following tests: "
FOR I=0:0
SET I=$ORDER(LRTST(I))
if I<1
QUIT
WRITE !,?10,$PIECE(LRTST(I),"^",1)
+1 QUIT
+2 ;
+3 ;
EXPAND DO EXPLODE^LRGP2
SKPEX ; READY TO GO
if $ORDER(LRVTS(0))
QUIT
STOP SET LREND=1
+1 QUIT
+2 ;
+3 ;
INIT ;from LRVRW
+1 NEW DIC,LRX
+2 DO ^LRPARAM
if $GET(LREND)
QUIT
+3 SET LREND=0
SET LRAN=0
KILL LRORD,LRDUZ
+4 SET DIC="^LRO(68.2,"
SET DIC(0)="AEMZ"
SET DIC("S")="S LRX=$P(^(0),U,12) Q:'$L(LRX) I $D(^XUSEC($P($G(^DIC(19.1,LRX,0)),U),DUZ))"
+5 DO ^DIC
KILL DIC("S")
if Y<1
GOTO STOP
SET LRLL=+Y
SET LRTYPE=$PIECE(Y(0),U,3)
+6 SET LRPROF=$ORDER(^LRO(68.2,LRLL,10,0))
+7 IF LRPROF<1
SET LREND=1
WRITE !,"No profile defined."
QUIT
+8 SET B=$ORDER(^LRO(68.2,LRLL,10,LRPROF))
+9 IF B>0
SET DIC="^LRO(68.2,"_LRLL_",10,"
DO ^DIC
if Y<1
GOTO STOP
SET LRPROF=+Y
+10 SET X=^LRO(68.2,LRLL,10,LRPROF,0)
SET LRAA=$PIECE(X,U,2)
SET LRPANEL=$PIECE(X,U)
IF '$DATA(^LRO(68,LRAA,0))#2
WRITE !?10,$CHAR(7),"Error in your DATABASE. There is not an accession area # ",LRAA,!!
QUIT
+11 ;
+12 ; Select performing laboratory to use
+13 SET LRX=$$SELPL^LRVERA($SELECT($PIECE(X,"^",5):$PIECE(X,"^",5),1:DUZ(2)))
+14 IF LRX<1
SET LREND=1
QUIT
+15 IF LRX
IF LRX'=DUZ(2)
SET LRDUZ(2)=LRX
+16 ;
+17 if $PIECE(LRPARAM,U,14)&($PIECE($GET(^LRO(68,LRAA,0)),U,16))
DO AUTO^LRCAPV
if LREND
QUIT
+18 ;
+19 IF "MISPCYEM"[$PIECE(^LRO(68,LRAA,0),U,2)
QUIT
+20 ;
+21 if $PIECE(^LRO(68,LRAA,0),U,2)'="CH"
GOTO STOP
+22 SET LREND=0
DO EXPAND
if LREND!($ORDER(LRVTS(0))<0)
GOTO STOP
+23 ;
CONT ;
+1 FOR I=0:0
SET I=$ORDER(LRORD(I))
if I<1
QUIT
SET J=LRORD(I)
SET X=$PIECE(^LAB(60,J,0),U,5)
SET LRORD(I)=$PIECE(X,";",2)
+2 SET Y=^LRO(68,LRAA,0)
SET LRTSE=-1
+3 ;
+4 DO CMTDSP^LRVERA
+5 ;
REV ;
+1 KILL LRPER
+2 DO REV^LRVER
+3 QUIT
+4 ;
+5 ;
LRTM60(LRX) ; Calculate days back for delta check based on specimen collection date/time
+1 ;
+2 ; Call with LRX = specimen collection date/time (FileMan D/T format)
+3 ;
+4 ; Return LRY = Inverse date/time value of delta days back
+5 ;
+6 NEW LRDB,LRY
+7 SET LRDB=$PIECE($GET(^LAB(69.9,1,0)),U,7)
+8 IF LRDB=""
SET LRDB=1
+9 SET LRY=9999999-$$FMADD^XLFDT(LRX,-LRDB)
+10 QUIT LRY
