LRXREF1 ;SLC/RWA,ALB/TMK - CONTINUE BUILD X-REF FOR RE-INDEX ;09/15/2010 10:42:09
;;5.2;LAB SERVICE;**425**;Sep 27, 1994;Build 30
;
AT ;^LRO(69,"AT" CROSS REFERENCE
I DA,DA(1),DA(2),$D(^LRO(69,DA(2),1,DA(1),2,DA,0)) D AT1
Q
AT1 S ATX=+^LRO(69,DA(2),1,DA(1),0),ATX(1)=DA(2),ATX(2)=+^(2,DA,0)
I $D(^LRO(69,DA(2),1,DA(1),4,1,0)) S ATX(3)=+^LRO(69,DA(2),1,DA(1),4,1,0) I ATX,ATX(1),ATX(2),ATX(3) S ^LRO(69,"AT",ATX,ATX(2),ATX(3),ATX(1))="",^(-ATX(1))=""
K ATX
Q
ATD ;KILL FOR ^LRO(69,"AT" CROSS REFERENCE
I DA,DA(1),DA(2),$D(^LRO(69,DA(2),1,DA(1),2,DA,0)) S ATX=+^LRO(69,DA(2),1,DA(1),0),ATX(1)=DA(2),ATX(2)=+^(2,DA,0)
I $D(^LRO(69,DA(2),1,DA(1),4,1,0)) S ATX(3)=+^LRO(69,DA(2),1,DA(1),4,1,0) I ATX,ATX(1),ATX(2),ATX(3) K ^LRO(69,"AT",ATX,ATX(2),ATX(3),ATX(1)),^(-ATX(1))
K ATX
Q
AC ;BUILD "AC" CROSS-REFERENCE IN FILE 68
S LRTN=0,LRTEST=""
F I=0:0 S LRTN=$O(^LRO(68,DA(2),1,DA(1),1,DA,4,LRTN)) Q:LRTN<1 S LRGTN=LRTN S:LRTEST'="" LRTEST=LRTEST_"^"_LRTN S:LRTEST="" LRTEST=LRTN
D ^LREXPD G:'$D(LRORD) SET F I=1:1:LRTSTS S LRGTN=LRORD(I) D SET
END K LRTEST,LRTSTS,^TMP("LR",$J),LRTN,LRGTN Q
SET I $D(LRGTN) I $D(^LAB(60,LRGTN,.2)) I $P(^LAB(60,LRGTN,0),U,3)'["N" I $P(^(0),U,3)'["I" S ^LRO(68,"AC",+^LRO(68,DA(2),1,DA(1),1,DA,0),$P(^LRO(68,DA(2),1,DA(1),1,DA,3),U,5),+^LAB(60,LRGTN,.2))="" Q
G:'$D(LRORD) END Q
AC1 ;KILL "AC" CROSS-REFERENCE IN FILE 68
S LRTN=0,LRTEST=""
F I=0:0 S LRTN=$O(^LRO(68,DA(2),1,DA(1),1,DA,4,LRTN)) Q:LRTN<1 S LRGTN=LRTN S:LRTEST'="" LRTEST=LRTEST_"^"_LRTN S:LRTEST="" LRTEST=LRTN
D ^LREXPD G:'$D(LRORD) KILL F I=1:1:LRTSTS S LRGTN=LRORD(I) D KILL
K LRTEST,LRTSTS,^TMP("LR",$J),LRTN,LRGTN Q
KILL I $D(^LAB(60,LRGTN,.2)) I $D(^LRO(68,"AC",+^LRO(68,DA(2),1,DA(1),1,DA,0),$P(^LRO(68,DA(2),1,DA(1),1,DA,3),U,5),+^LAB(60,LRGTN,.2))) K ^LRO(68,"AC",+^LRO(68,DA(2),1,DA(1),1,DA,0),$P(^LRO(68,DA(2),1,DA(1),1,DA,3),U,5),+^LAB(60,LRGTN,.2))
Q
A65 ;Rebuild "A" x-ref in file 65 for 65.15,.08 for Re-index utility
F LR=0:0 S LR=$O(^LRD(65,DA,15,LR)) Q:'LR S LR(1)=$P(^(LR,0),"^",8) S:LR(1) ^LRD(65,"A",LR(1),DA)=""
Q
A658 ;build "A" x-ref in file 65 for 65,.05 for Re-index utility
S LR=$P(^LRD(65,DA(1),0),"^",5) S:LR ^LRD(65,"A",LR,DA(1))="" Q
C ;build "C" x-ref in file 69
I '$D(DIU(0)) S ^LRO(69,"C",+X,DA(1),DA)="" Q
I $D(DIU(0)),$D(^LRO(69,DA(1),1,DA,2)) S ^LRO(69,"C",+X,DA(1),DA)=""
Q
A6599 ;Rebuild Archive "A" x-ref in file 65.9999 for 65.999915,.08 for Re-index utility
F LR=0:0 S LR=$O(^LRD(65.9999,DA,15,LR)) Q:'LR S LR(1)=$P(^(LR,0),"^",8) S:LR(1) ^LRD(65.9999,"A",LR(1),DA)=""
Q
A65899 ;build Archive "A" x-ref in file 65.9999 for 65.9999,.05 for Re-index utility
S LR=$P(^LRD(65.9999,DA(1),0),"^",5) S:LR ^LRD(65.9999,"A",LR,DA(1))="" Q
;
IT600101(DA,DINUM,X) ;
; Input Transform for Sub-File #60.01 field #.01 SITE/SPECIMEN
; Expects X (#61 IEN of SITE/SPECIMEN being added to the test) and DA array -- DA(1)=^LAB(60,DA(1)) DA=^LAB(60,DA(1),1,DA)
; Kills X if invalid selection
; Sets DINUM if valid selection
N LRA
S LRA=$P(^LAB(60,DA(1),0),U,5)
I LRA="" K X Q
S LRA=$O(^LAB(60,"C",LRA,0))
I LRA'=DA(1) D EN^DDIOL("Site/specimens may only be added for "_$P(^LAB(60,LRA,0),U,1),"","!") K X Q
; Make sure entry from file 61 is not inactive as of the current date
I '$$ACTV61^LRJUTL3(X,DT) D EN^DDIOL("Site/Specimen "_$P(^LAB(61,X,0),U,1)_" is inactive","","!") K X Q
S DINUM=X
Q
;
IT600301(DA,X) ;
; Input Transform for Sub-File #60.03 field #.01 COLLECTION SAMPLE
; Expects X (#62 IEN of COLLECTION SAMPLE being added to the test) and DA array -- DA(1)=^LAB(60,DA(1)) DA=^LAB(60,DA(1),1,DA)
; Kills X if invalid selection
I $P(^LAB(60,DA(1),0),U,8),$O(^(3,0))>0 D EN^DDIOL("ONLY ONE UNIQUE COLLECTION SAMPLE","","?0") K X Q
; Make sure entry from file 62 is not inactive as of the current date
I '$$ACTV62^LRJUTL3(X,DT) D EN^DDIOL("Collection Sample "_$P(^LAB(62,X,0),U,1)_" is inactive","","!") K X Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRXREF1 3960 printed Nov 22, 2024@17:33:33 Page 2
LRXREF1 ;SLC/RWA,ALB/TMK - CONTINUE BUILD X-REF FOR RE-INDEX ;09/15/2010 10:42:09
+1 ;;5.2;LAB SERVICE;**425**;Sep 27, 1994;Build 30
+2 ;
AT ;^LRO(69,"AT" CROSS REFERENCE
+1 IF DA
IF DA(1)
IF DA(2)
IF $DATA(^LRO(69,DA(2),1,DA(1),2,DA,0))
DO AT1
+2 QUIT
AT1 SET ATX=+^LRO(69,DA(2),1,DA(1),0)
SET ATX(1)=DA(2)
SET ATX(2)=+^(2,DA,0)
+1 IF $DATA(^LRO(69,DA(2),1,DA(1),4,1,0))
SET ATX(3)=+^LRO(69,DA(2),1,DA(1),4,1,0)
IF ATX
IF ATX(1)
IF ATX(2)
IF ATX(3)
SET ^LRO(69,"AT",ATX,ATX(2),ATX(3),ATX(1))=""
SET ^(-ATX(1))=""
+2 KILL ATX
+3 QUIT
ATD ;KILL FOR ^LRO(69,"AT" CROSS REFERENCE
+1 IF DA
IF DA(1)
IF DA(2)
IF $DATA(^LRO(69,DA(2),1,DA(1),2,DA,0))
SET ATX=+^LRO(69,DA(2),1,DA(1),0)
SET ATX(1)=DA(2)
SET ATX(2)=+^(2,DA,0)
+2 IF $DATA(^LRO(69,DA(2),1,DA(1),4,1,0))
SET ATX(3)=+^LRO(69,DA(2),1,DA(1),4,1,0)
IF ATX
IF ATX(1)
IF ATX(2)
IF ATX(3)
KILL ^LRO(69,"AT",ATX,ATX(2),ATX(3),ATX(1)),^(-ATX(1))
+3 KILL ATX
+4 QUIT
AC ;BUILD "AC" CROSS-REFERENCE IN FILE 68
+1 SET LRTN=0
SET LRTEST=""
+2 FOR I=0:0
SET LRTN=$ORDER(^LRO(68,DA(2),1,DA(1),1,DA,4,LRTN))
if LRTN<1
QUIT
SET LRGTN=LRTN
if LRTEST'=""
SET LRTEST=LRTEST_"^"_LRTN
if LRTEST=""
SET LRTEST=LRTN
+3 DO ^LREXPD
if '$DATA(LRORD)
GOTO SET
FOR I=1:1:LRTSTS
SET LRGTN=LRORD(I)
DO SET
END KILL LRTEST,LRTSTS,^TMP("LR",$JOB),LRTN,LRGTN
QUIT
SET IF $DATA(LRGTN)
IF $DATA(^LAB(60,LRGTN,.2))
IF $PIECE(^LAB(60,LRGTN,0),U,3)'["N"
IF $PIECE(^(0),U,3)'["I"
SET ^LRO(68,"AC",+^LRO(68,DA(2),1,DA(1),1,DA,0),$PIECE(^LRO(68,DA(2),1,DA(1),1,DA,3),U,5),+^LAB(60,LRGTN,.2))=""
QUIT
+1 if '$DATA(LRORD)
GOTO END
QUIT
AC1 ;KILL "AC" CROSS-REFERENCE IN FILE 68
+1 SET LRTN=0
SET LRTEST=""
+2 FOR I=0:0
SET LRTN=$ORDER(^LRO(68,DA(2),1,DA(1),1,DA,4,LRTN))
if LRTN<1
QUIT
SET LRGTN=LRTN
if LRTEST'=""
SET LRTEST=LRTEST_"^"_LRTN
if LRTEST=""
SET LRTEST=LRTN
+3 DO ^LREXPD
if '$DATA(LRORD)
GOTO KILL
FOR I=1:1:LRTSTS
SET LRGTN=LRORD(I)
DO KILL
+4 KILL LRTEST,LRTSTS,^TMP("LR",$JOB),LRTN,LRGTN
QUIT
KILL IF $DATA(^LAB(60,LRGTN,.2))
IF $DATA(^LRO(68,"AC",+^LRO(68,DA(2),1,DA(1),1,DA,0),$PIECE(^LRO(68,DA(2),1,DA(1),1,DA,3),U,5),+^LAB(60,LRGTN,.2)))
KILL ^LRO(68,"AC",+^LRO(68,DA(2),1,DA(1),1,DA,0),$PIECE(^LRO(68,DA(2),1,DA(1),1,DA,3),U,5),+^LAB(60,LRGTN,.2))
+1 QUIT
A65 ;Rebuild "A" x-ref in file 65 for 65.15,.08 for Re-index utility
+1 FOR LR=0:0
SET LR=$ORDER(^LRD(65,DA,15,LR))
if 'LR
QUIT
SET LR(1)=$PIECE(^(LR,0),"^",8)
if LR(1)
SET ^LRD(65,"A",LR(1),DA)=""
+2 QUIT
A658 ;build "A" x-ref in file 65 for 65,.05 for Re-index utility
+1 SET LR=$PIECE(^LRD(65,DA(1),0),"^",5)
if LR
SET ^LRD(65,"A",LR,DA(1))=""
QUIT
C ;build "C" x-ref in file 69
+1 IF '$DATA(DIU(0))
SET ^LRO(69,"C",+X,DA(1),DA)=""
QUIT
+2 IF $DATA(DIU(0))
IF $DATA(^LRO(69,DA(1),1,DA,2))
SET ^LRO(69,"C",+X,DA(1),DA)=""
+3 QUIT
A6599 ;Rebuild Archive "A" x-ref in file 65.9999 for 65.999915,.08 for Re-index utility
+1 FOR LR=0:0
SET LR=$ORDER(^LRD(65.9999,DA,15,LR))
if 'LR
QUIT
SET LR(1)=$PIECE(^(LR,0),"^",8)
if LR(1)
SET ^LRD(65.9999,"A",LR(1),DA)=""
+2 QUIT
A65899 ;build Archive "A" x-ref in file 65.9999 for 65.9999,.05 for Re-index utility
+1 SET LR=$PIECE(^LRD(65.9999,DA(1),0),"^",5)
if LR
SET ^LRD(65.9999,"A",LR,DA(1))=""
QUIT
+2 ;
IT600101(DA,DINUM,X) ;
+1 ; Input Transform for Sub-File #60.01 field #.01 SITE/SPECIMEN
+2 ; Expects X (#61 IEN of SITE/SPECIMEN being added to the test) and DA array -- DA(1)=^LAB(60,DA(1)) DA=^LAB(60,DA(1),1,DA)
+3 ; Kills X if invalid selection
+4 ; Sets DINUM if valid selection
+5 NEW LRA
+6 SET LRA=$PIECE(^LAB(60,DA(1),0),U,5)
+7 IF LRA=""
KILL X
QUIT
+8 SET LRA=$ORDER(^LAB(60,"C",LRA,0))
+9 IF LRA'=DA(1)
DO EN^DDIOL("Site/specimens may only be added for "_$PIECE(^LAB(60,LRA,0),U,1),"","!")
KILL X
QUIT
+10 ; Make sure entry from file 61 is not inactive as of the current date
+11 IF '$$ACTV61^LRJUTL3(X,DT)
DO EN^DDIOL("Site/Specimen "_$PIECE(^LAB(61,X,0),U,1)_" is inactive","","!")
KILL X
QUIT
+12 SET DINUM=X
+13 QUIT
+14 ;
IT600301(DA,X) ;
+1 ; Input Transform for Sub-File #60.03 field #.01 COLLECTION SAMPLE
+2 ; Expects X (#62 IEN of COLLECTION SAMPLE being added to the test) and DA array -- DA(1)=^LAB(60,DA(1)) DA=^LAB(60,DA(1),1,DA)
+3 ; Kills X if invalid selection
+4 IF $PIECE(^LAB(60,DA(1),0),U,8)
IF $ORDER(^(3,0))>0
DO EN^DDIOL("ONLY ONE UNIQUE COLLECTION SAMPLE","","?0")
KILL X
QUIT
+5 ; Make sure entry from file 62 is not inactive as of the current date
+6 IF '$$ACTV62^LRJUTL3(X,DT)
DO EN^DDIOL("Collection Sample "_$PIECE(^LAB(62,X,0),U,1)_" is inactive","","!")
KILL X
QUIT
+7 QUIT
+8 ;
