LRVRA ;DALOI/JMC-Lab Routine Data Verification by UID ;06/04/10 19:12
;;5.2;LAB SERVICE;**153,221,263,350**;Sep 27, 1994;Build 230
;
;
N LRANYAA,LRUID,LRNOP
S LRANYAA=+$P($G(^LRO(68.2,LRLL,10,LRPROF,0)),"^",3)
S LRUID="" D NEXT
;
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 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 LRACC=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
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_" Age: "_AGE(2)
W !,"ORDER #: ",LRCEN," "_LRACC," [",LRUID_"]"
;
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)
. W !,$$CJ^XLFSTR("Associated with "_$$GET1^DIQ(68,LRAA_",",.02)_" subscript",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)
. W !,$$CJ^XLFSTR("Associated with "_$$GET1^DIQ(68,LRAA_",",.02)_" subscript",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 LRUID'="" S LRQUIT=1 ; Found a UID from this accession area.
S LRUID=LRUIDX
Q
;
;
UID ; Setup accession variables for a given UID.
; UID selected must be from same subscript as profile accession area.
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
I $P($G(^LRO(68,LRAA,0)),"^",2)'=$P($G(^LRO(68,$QS(X,4),0)),"^",2) 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,LRSS,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),LRSS=$P($G(^LRO(68,LRAA,0)),"^",2)
S I="",K=0
F S I=$O(^LAH(LRLL,1,"U",I)) Q:I=""!(K>500) D
. I 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 $P($G(^LRO(68,LRAA,0)),"^",2)'=LRSS Q ; Not in subscript currently working with
. 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRVRA 5173 printed Oct 16, 2024@18:23:26 Page 2
LRVRA ;DALOI/JMC-Lab Routine Data Verification by UID ;06/04/10 19:12
+1 ;;5.2;LAB SERVICE;**153,221,263,350**;Sep 27, 1994;Build 230
+2 ;
+3 ;
+4 NEW LRANYAA,LRUID,LRNOP
+5 SET LRANYAA=+$PIECE($GET(^LRO(68.2,LRLL,10,LRPROF,0)),"^",3)
+6 SET LRUID=""
DO NEXT
+7 ;
+8 FOR
Begin DoDot:1
+9 KILL LRTEST,C5,LRSET,LRLDT,DIC,LRNM,LRNG,LRDL,LRDEL,T,LRFP,LRAB,LRVER,Y,Z
+10 SET LRCFL=""
SET EAMODE=1
+11 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+12 DO WLN
IF $GET(LRNOP)
DO NEXT
QUIT
+13 DO ^LRVR1
DO NEXT
End DoDot:1
if LREND
QUIT
+14 QUIT
+15 ;
+16 ;
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 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 ;
+16 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)
+17 SET LRACC=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
+18 SET LRORU3=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
+19 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+20 DO PT^LRX
+21 ;
+22 WRITE !,PNM,?30,SSN_" Age: "_AGE(2)
+23 WRITE !,"ORDER #: ",LRCEN," "_LRACC," [",LRUID_"]"
+24 ;
+25 IF '$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",3)
Begin DoDot:1
+26 NEW LRAA,LRAD,LRAN
+27 SET LRSTATUS="C"
DO P15^LROE1
+28 IF LRCDT<1
SET LRNOP=1
End DoDot:1
+29 IF '$GET(LRNOP)
IF $PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),U,4)'="C"
Begin DoDot:1
+30 WRITE !,"You cannot verify an accession which has not been collected.",$CHAR(7)
+31 SET LRNOP=1
End DoDot:1
+32 IF $GET(LRNOP)
DO NEXT
+33 ;
+34 QUIT
+35 ;
+36 ;
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 WRITE !,$$CJ^XLFSTR("Associated with "_$$GET1^DIQ(68,LRAA_",",.02)_" subscript",IOM),!!
+9 FOR K=((J*2)*I)+1:1:((J*2)*I)+J
Begin DoDot:2
+10 WRITE ?3,$PIECE($GET(^TMP($JOB,"LR","UIDHELP",K)),"^",2)
+11 WRITE ?43,$PIECE($GET(^TMP($JOB,"LR","UIDHELP",(K+J))),"^",2),!
End DoDot:2
+12 WRITE !
SET DIR(0)="E"
DO ^DIR
+13 IF $DATA(DIRUT)
DO STOP^LRVR
QUIT
End DoDot:1
if LREND
QUIT
+14 KILL ^TMP($JOB,"LR","UIDHELP")
+15 QUIT
+16 ;
+17 ;
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 WRITE !,$$CJ^XLFSTR("Associated with "_$$GET1^DIQ(68,LRAA_",",.02)_" subscript",IOM),!!
+9 FOR K=((J*2)*I)+1:1:((J*2)*I)+J
Begin DoDot:2
+10 IF $DATA(^TMP($JOB,"LR","UIDHELP",K))
Begin DoDot:3
+11 WRITE ?3,$JUSTIFY(K,3),". ",$PIECE($GET(^TMP($JOB,"LR","UIDHELP",K)),"^",2)
+12 IF K>M
SET M=K
End DoDot:3
+13 IF $DATA(^TMP($JOB,"LR","UIDHELP",K+J))
Begin DoDot:3
+14 WRITE ?43,$JUSTIFY(K+J,3),". ",$PIECE($GET(^TMP($JOB,"LR","UIDHELP",(K+J))),"^",2)
+15 IF (K+J)>M
SET M=K+J
End DoDot:3
+16 WRITE !
End DoDot:2
+17 WRITE !
SET DIR(0)="NO^1:"_$SELECT(M>500:500,1:M)
SET DIR("A")="Select UID"
+18 DO ^DIR
+19 WRITE @IOF
+20 IF $DATA(DUOUT)
DO STOP^LRVR
QUIT
+21 IF '$DATA(DIRUT)
IF Y
Begin DoDot:2
+22 SET LRUID=$PIECE(^TMP($JOB,"LR","UIDHELP",Y),"^")
+23 DO STOP^LRVR
End DoDot:2
End DoDot:1
if LREND
QUIT
+24 KILL ^TMP($JOB,"LR","UIDHELP")
+25 QUIT LRUID
+26 ;
+27 ;
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 LRUID'=""
SET LRQUIT=1
End DoDot:1
if LRQUIT
QUIT
+9 SET LRUID=LRUIDX
+10 QUIT
+11 ;
+12 ;
UID ; Setup accession variables for a given UID.
+1 ; UID selected must be from same subscript as profile accession area.
+2 NEW X
+3 SET X=$QUERY(^LRO(68,"C",LRUID))
+4 IF $QSUBSCRIPT(X,3)'=LRUID
SET (LRAD,LRAN)=0
SET LRUID=""
QUIT
+5 IF 'LRANYAA
IF $QSUBSCRIPT(X,4)'=LRAA
SET (LRAD,LRAN)=0
SET LRUID=""
QUIT
+6 IF $PIECE($GET(^LRO(68,LRAA,0)),"^",2)'=$PIECE($GET(^LRO(68,$QSUBSCRIPT(X,4),0)),"^",2)
SET (LRAD,LRAN)=0
SET LRUID=""
QUIT
+7 SET LRAA=$QSUBSCRIPT(X,4)
SET LRAD=$QSUBSCRIPT(X,5)
SET LRAN=$QSUBSCRIPT(X,6)
+8 QUIT
+9 ;
+10 ;
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,LRSS,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)
SET LRSS=$PIECE($GET(^LRO(68,LRAA,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 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 ; Not in subscript currently working with
IF $PIECE($GET(^LRO(68,LRAA,0)),"^",2)'=LRSS
QUIT
+19 IF LRAA
IF LRAD
IF LRAN
SET Y=Y_"^"_Y_" ["_$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^")_"]"
+20 IF '$TEST
QUIT
+21 IF K=500
SET Y="^Display abort - too many to list"
+22 SET K=K+1
SET ^TMP($JOB,"LR","UIDHELP",K)=Y
End DoDot:1
+23 QUIT K
