LRVRA ;DALOI/JMC-Lab Routine Data Verification by UID ;2/12/97 11:06
;;5.2T9;LR;**1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**153,221,263**;Sep 27, 1994
N LRANYAA,LRUID,LRNOP
S LRANYAA=+$P($G(^LRO(68.2,LRLL,10,LRPROF,0)),"^",3)
S LRUID="" D NEXT
D
. N X
. S X=$S(+$P($G(^LAB(69.9,1,0)),U,7):+$P(^(0),U,7),1:1)
. S LRTM60=9999999-$$FMADD^XLFDT(DT,-X)
F D Q:LREND
. K LRTEST,C5,LRSET,LRLDT,DIC,LRNM,LRNG,LRDL,LRDEL,T,LRFP,LRAB,LRVER,Y,Z
. S LRCFL="",EAMODE=1
. N DIR,DIRUT,DTOUT,DUOUT,X,Y
. D WLN I $G(LRNOP) D NEXT Q
. D ^LRVR1,NEXT
Q
;
WLN ; Select next accession (UID) to work with.
W ! S LRNOP=0
K DIR
S DIR(0)="FO^1:10",DIR("A")="Unique Identifier",DIR("?")="^D LW^LRVRA"
I $L(LRUID) S DIR("B")=LRUID
D ^DIR
I $D(DIRUT) D STOP^LRVR S LRNOP=1 Q
S LRUID=Y
I LRUID'?1.10N S LRUID=$$UP^XLFSTR(LRUID)
I $L(LRUID)<10 S LRUID=$$LWP(LRUID)
I $L(LRUID)<10 S LRUID="" G WLN
D UID
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D G WLN
. W !,"No accession on file for this UID."
. D NEXT
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))
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
D PT^LRX W !,PNM,?30,SSN
W:LRCEN !,"ORDER #: ",LRCEN
I '$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",3) D
. N LRAA,LRAD,LRAN
. S LRSTATUS="C" D P15^LROE1
. I LRCDT<1 S LRNOP=1
I '$G(LRNOP),$P($G(^LRO(69,LRODT,1,LRSN,1)),U,4)'="C" D
. W !,"You cannot verify an accession which has not been collected.",$C(7)
. S LRNOP=1
I $G(LRNOP) D NEXT
Q
;
LW ; Display list of UID's available
N DIR,DIRUT,DUOUT,DTOUT,I,J,K,L,LREND,X,Y
S LREND=0
S K=$$BLDHELP("",LRLL,LRPROF)
I 'K W !,$C(7),"No results found in UID cross-reference." Q
S J=IOSL-6,L=K\(J*2) S:'(K#(J*2)) L=L-1
F I=0:1:L D Q:LREND
. W @IOF,$$CJ^XLFSTR("Current Unique Identifiers with Results Available",IOM),!!
. F K=((J*2)*I)+1:1:((J*2)*I)+J D
. . W ?3,$P($G(^TMP($J,"LR","UIDHELP",K)),"^",2)
. . W ?43,$P($G(^TMP($J,"LR","UIDHELP",(K+J))),"^",2),!
. W ! S DIR(0)="E" D ^DIR
. I $D(DIRUT) D STOP^LRVR Q
K ^TMP($J,"LR","UIDHELP")
Q
;
LWP(LRSD) ; Display list of partial UID's available
N DIR,DIRUT,DUOUT,DTOUT,I,J,K,L,LREND,LRUID,M,X,Y
S LRSD=$G(LRSD),(LREND,M)=0,LRUID=""
S K=$$BLDHELP(LRSD,LRLL,LRPROF)
I 'K W !,$C(7),"No results found in UID cross-reference." Q LRUID
S J=IOSL-6,L=K\(J*2) S:'(K#(J*2)) L=L-1
F I=0:1:L D Q:LREND
. W @IOF,$$CJ^XLFSTR("Current Unique Identifiers with Results Available",IOM),!!
. F K=((J*2)*I)+1:1:((J*2)*I)+J D
. . I $D(^TMP($J,"LR","UIDHELP",K)) D
. . . W ?3,$J(K,3),". ",$P($G(^TMP($J,"LR","UIDHELP",K)),"^",2)
. . . I K>M S M=K
. . I $D(^TMP($J,"LR","UIDHELP",K+J)) D
. . . W ?43,$J(K+J,3),". ",$P($G(^TMP($J,"LR","UIDHELP",(K+J))),"^",2)
. . . I (K+J)>M S M=K+J
. . W !
. W ! S DIR(0)="NO^1:"_$S(M>500:500,1:M),DIR("A")="Select UID"
. D ^DIR
. W @IOF
. I $D(DUOUT) D STOP^LRVR Q
. I '$D(DIRUT),Y D
. . S LRUID=$P(^TMP($J,"LR","UIDHELP",Y),"^")
. . D STOP^LRVR
K ^TMP($J,"LR","UIDHELP")
Q LRUID
;
NEXT ; Retrieve next UID in xref.
N LRUIDX,LRQUIT
S LRQUIT=0 ; Set flag
S LRUIDX=$G(LRUID) ; Define if undefined
F S LRUIDX=$O(^LAH(LRLL,1,"U",LRUIDX)) Q:LRUIDX="" D Q:LRQUIT
. N LRUID
. S LRUID=LRUIDX
. D UID
. I $L(LRUID) S LRQUIT=1 ; Found a UID from this accession area.
S LRUID=LRUIDX
Q
;
UID ; Setup accession variables for a given UID.
N X
S X=$Q(^LRO(68,"C",LRUID))
I $QS(X,3)'=LRUID S (LRAD,LRAN)=0,LRUID="" Q
I 'LRANYAA,$QS(X,4)'=LRAA S (LRAD,LRAN)=0,LRUID="" Q
S LRAA=$QS(X,4),LRAD=$QS(X,5),LRAN=$QS(X,6)
Q
;
BLDHELP(LRSD,LRLL,LRPROF) ; Build list of UID's
; Input LRSD - seed value for partial lookups
; if null or missing then return all UID's in xref.
; LRLL - ien of loadlist.
; LRPROF - ien of profile on loadlist.
; Only max of 500 allow to be displayed.
N I,K,LRAA,LRAD,LRAN,X,Y
K ^TMP($J,"LR","UIDHELP")
S LRSD=$G(LRSD),LRLL=+$G(LRLL),LRPROF=+$G(LRPROF)
S LRAA=$P($G(^LRO(68.2,LRLL,10,LRPROF,0)),"^",2)
S I="",K=0
F S I=$O(^LAH(LRLL,1,"U",I)) Q:I=""!(K>500) D
. I $L(LRSD),LRSD'=$E(I,($L(I)-$L(LRSD))+1,$L(I)) Q ; Is not a partial match
. S Y=I
. S X=$Q(^LRO(68,"C",I))
. I $QS(X,3)'=I Q ; UID not in "C" x-reference.
. I 'LRANYAA,LRAA'=$QS(X,4) Q ; Not in this accession area.
. S LRAA=$QS(X,4),LRAD=$QS(X,5),LRAN=$QS(X,6)
. I LRAA,LRAD,LRAN S Y=Y_"^"_Y_" ["_$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^")_"]"
. E Q
. I K=500 S Y="^Display abort - too many to list"
. S K=K+1,^TMP($J,"LR","UIDHELP",K)=Y
Q K
LRVRA ;DALOI/JMC-Lab Routine Data Verification by UID ;2/12/97 11:06
+1 ;;5.2T9;LR;**1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**153,221,263**;Sep 27, 1994
+3 NEW LRANYAA,LRUID,LRNOP
+4 SET LRANYAA=+$PIECE($GET(^LRO(68.2,LRLL,10,LRPROF,0)),"^",3)
+5 SET LRUID=""
DO NEXT
+6 Begin DoDot:1
+7 NEW X
+8 SET X=$SELECT(+$PIECE($GET(^LAB(69.9,1,0)),U,7):+$PIECE(^(0),U,7),1:1)
+9 SET LRTM60=9999999-$$FMADD^XLFDT(DT,-X)
End DoDot:1
+10 FOR
Begin DoDot:1
+11 KILL LRTEST,C5,LRSET,LRLDT,DIC,LRNM,LRNG,LRDL,LRDEL,T,LRFP,LRAB,LRVER,Y,Z
+12 SET LRCFL=""
SET EAMODE=1
+13 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+14 DO WLN
IF $GET(LRNOP)
DO NEXT
QUIT
+15 DO ^LRVR1
DO NEXT
End DoDot:1
IF LREND
QUIT
+16 QUIT
+17 ;
WLN ; Select next accession (UID) to work with.
+1 WRITE !
SET LRNOP=0
+2 KILL DIR
+3 SET DIR(0)="FO^1:10"
SET DIR("A")="Unique Identifier"
SET DIR("?")="^D LW^LRVRA"
+4 IF $LENGTH(LRUID)
SET DIR("B")=LRUID
+5 DO ^DIR
+6 IF $DATA(DIRUT)
DO STOP^LRVR
SET LRNOP=1
QUIT
+7 SET LRUID=Y
+8 IF LRUID'?1.10N
SET LRUID=$$UP^XLFSTR(LRUID)
+9 IF $LENGTH(LRUID)<10
SET LRUID=$$LWP(LRUID)
+10 IF $LENGTH(LRUID)<10
SET LRUID=""
GOTO WLN
+11 DO UID
+12 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
Begin DoDot:1
+13 WRITE !,"No accession on file for this UID."
+14 DO NEXT
End DoDot:1
GOTO WLN
+15 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)
+16 SET LRORU3=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
+17 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+18 DO PT^LRX
WRITE !,PNM,?30,SSN
+19 IF LRCEN
WRITE !,"ORDER #: ",LRCEN
+20 IF '$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",3)
Begin DoDot:1
+21 NEW LRAA,LRAD,LRAN
+22 SET LRSTATUS="C"
DO P15^LROE1
+23 IF LRCDT<1
SET LRNOP=1
End DoDot:1
+24 IF '$GET(LRNOP)
IF $PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),U,4)'="C"
Begin DoDot:1
+25 WRITE !,"You cannot verify an accession which has not been collected.",$CHAR(7)
+26 SET LRNOP=1
End DoDot:1
+27 IF $GET(LRNOP)
DO NEXT
+28 QUIT
+29 ;
LW ; Display list of UID's available
+1 NEW DIR,DIRUT,DUOUT,DTOUT,I,J,K,L,LREND,X,Y
+2 SET LREND=0
+3 SET K=$$BLDHELP("",LRLL,LRPROF)
+4 IF 'K
WRITE !,$CHAR(7),"No results found in UID cross-reference."
QUIT
+5 SET J=IOSL-6
SET L=K\(J*2)
IF '(K#(J*2))
SET L=L-1
+6 FOR I=0:1:L
Begin DoDot:1
+7 WRITE @IOF,$$CJ^XLFSTR("Current Unique Identifiers with Results Available",IOM),!!
+8 FOR K=((J*2)*I)+1:1:((J*2)*I)+J
Begin DoDot:2
+9 WRITE ?3,$PIECE($GET(^TMP($JOB,"LR","UIDHELP",K)),"^",2)
+10 WRITE ?43,$PIECE($GET(^TMP($JOB,"LR","UIDHELP",(K+J))),"^",2),!
End DoDot:2
+11 WRITE !
SET DIR(0)="E"
DO ^DIR
+12 IF $DATA(DIRUT)
DO STOP^LRVR
QUIT
End DoDot:1
IF LREND
QUIT
+13 KILL ^TMP($JOB,"LR","UIDHELP")
+14 QUIT
+15 ;
LWP(LRSD) ; Display list of partial UID's available
+1 NEW DIR,DIRUT,DUOUT,DTOUT,I,J,K,L,LREND,LRUID,M,X,Y
+2 SET LRSD=$GET(LRSD)
SET (LREND,M)=0
SET LRUID=""
+3 SET K=$$BLDHELP(LRSD,LRLL,LRPROF)
+4 IF 'K
WRITE !,$CHAR(7),"No results found in UID cross-reference."
QUIT LRUID
+5 SET J=IOSL-6
SET L=K\(J*2)
IF '(K#(J*2))
SET L=L-1
+6 FOR I=0:1:L
Begin DoDot:1
+7 WRITE @IOF,$$CJ^XLFSTR("Current Unique Identifiers with Results Available",IOM),!!
+8 FOR K=((J*2)*I)+1:1:((J*2)*I)+J
Begin DoDot:2
+9 IF $DATA(^TMP($JOB,"LR","UIDHELP",K))
Begin DoDot:3
+10 WRITE ?3,$JUSTIFY(K,3),". ",$PIECE($GET(^TMP($JOB,"LR","UIDHELP",K)),"^",2)
+11 IF K>M
SET M=K
End DoDot:3
+12 IF $DATA(^TMP($JOB,"LR","UIDHELP",K+J))
Begin DoDot:3
+13 WRITE ?43,$JUSTIFY(K+J,3),". ",$PIECE($GET(^TMP($JOB,"LR","UIDHELP",(K+J))),"^",2)
+14 IF (K+J)>M
SET M=K+J
End DoDot:3
+15 WRITE !
End DoDot:2
+16 WRITE !
SET DIR(0)="NO^1:"_$SELECT(M>500:500,1:M)
SET DIR("A")="Select UID"
+17 DO ^DIR
+18 WRITE @IOF
+19 IF $DATA(DUOUT)
DO STOP^LRVR
QUIT
+20 IF '$DATA(DIRUT)
IF Y
Begin DoDot:2
+21 SET LRUID=$PIECE(^TMP($JOB,"LR","UIDHELP",Y),"^")
+22 DO STOP^LRVR
End DoDot:2
End DoDot:1
IF LREND
QUIT
+23 KILL ^TMP($JOB,"LR","UIDHELP")
+24 QUIT LRUID
+25 ;
NEXT ; Retrieve next UID in xref.
+1 NEW LRUIDX,LRQUIT
+2 ; Set flag
SET LRQUIT=0
+3 ; Define if undefined
SET LRUIDX=$GET(LRUID)
+4 FOR
SET LRUIDX=$ORDER(^LAH(LRLL,1,"U",LRUIDX))
IF LRUIDX=""
QUIT
Begin DoDot:1
+5 NEW LRUID
+6 SET LRUID=LRUIDX
+7 DO UID
+8 ; Found a UID from this accession area.
IF $LENGTH(LRUID)
SET LRQUIT=1
End DoDot:1
IF LRQUIT
QUIT
+9 SET LRUID=LRUIDX
+10 QUIT
+11 ;
UID ; Setup accession variables for a given UID.
+1 NEW X
+2 SET X=$QUERY(^LRO(68,"C",LRUID))
+3 IF $QSUBSCRIPT(X,3)'=LRUID
SET (LRAD,LRAN)=0
SET LRUID=""
QUIT
+4 IF 'LRANYAA
IF $QSUBSCRIPT(X,4)'=LRAA
SET (LRAD,LRAN)=0
SET LRUID=""
QUIT
+5 SET LRAA=$QSUBSCRIPT(X,4)
SET LRAD=$QSUBSCRIPT(X,5)
SET LRAN=$QSUBSCRIPT(X,6)
+6 QUIT
+7 ;
BLDHELP(LRSD,LRLL,LRPROF) ; Build list of UID's
+1 ; Input LRSD - seed value for partial lookups
+2 ; if null or missing then return all UID's in xref.
+3 ; LRLL - ien of loadlist.
+4 ; LRPROF - ien of profile on loadlist.
+5 ; Only max of 500 allow to be displayed.
+6 NEW I,K,LRAA,LRAD,LRAN,X,Y
+7 KILL ^TMP($JOB,"LR","UIDHELP")
+8 SET LRSD=$GET(LRSD)
SET LRLL=+$GET(LRLL)
SET LRPROF=+$GET(LRPROF)
+9 SET LRAA=$PIECE($GET(^LRO(68.2,LRLL,10,LRPROF,0)),"^",2)
+10 SET I=""
SET K=0
+11 FOR
SET I=$ORDER(^LAH(LRLL,1,"U",I))
IF I=""!(K>500)
QUIT
Begin DoDot:1
+12 ; Is not a partial match
IF $LENGTH(LRSD)
IF LRSD'=$EXTRACT(I,($LENGTH(I)-$LENGTH(LRSD))+1,$LENGTH(I))
QUIT
+13 SET Y=I
+14 SET X=$QUERY(^LRO(68,"C",I))
+15 ; UID not in "C" x-reference.
IF $QSUBSCRIPT(X,3)'=I
QUIT
+16 ; Not in this accession area.
IF 'LRANYAA
IF LRAA'=$QSUBSCRIPT(X,4)
QUIT
+17 SET LRAA=$QSUBSCRIPT(X,4)
SET LRAD=$QSUBSCRIPT(X,5)
SET LRAN=$QSUBSCRIPT(X,6)
+18 IF LRAA
IF LRAD
IF LRAN
SET Y=Y_"^"_Y_" ["_$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^")_"]"
+19 IF '$TEST
QUIT
+20 IF K=500
SET Y="^Display abort - too many to list"
+21 SET K=K+1
SET ^TMP($JOB,"LR","UIDHELP",K)=Y
End DoDot:1
+22 QUIT K
