LRCKPTR ;SLC/RWF - CHECK ^LR & ^DPT CROSS POINTERS ; 8/30/87 17:20 ;
;;5.2;LAB SERVICE;**272,293**;Sep 27, 1994
W !,"CHECK OF POINTERS TO/FROM THE ^LR FILE",!!,"Want me to add missing nodes. " S %=2,U="^" D YN^DICN I %<1 W:%=0 !!,"a 'yes' and I will add missing zero nodes that are reported,",!," and missing pointers to ^LR." Q:%<0 G LRCKPTR
S LRFIX=(%=1)
S DFN=0,%ZIS="Q" D ^%ZIS Q:POP
I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^LRCKPTR",ZTSAVE("LRFIX")="",ZTDESC="Integrity Report" D ^%ZTLOAD K ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK D ^%ZISC Q
DQ S:$D(ZTQUEUED) ZTREQ="@" D ENT W !! W:$E(IOST,1,2)="P-" @IOF K LRFIX Q
ENT ;from LRCKF
U IO W ! S:'$D(LRFIX) LRFIX=0
F LRF=0:0 S LRF=$O(^DIC("AC","LR",LRF)) Q:LRF'>0 D LRP
G LRS
LRP S U="^",DFN=0,DIC=$S($D(^DIC(LRF,0,"GL")):^("GL"),1:"") I DIC'[U W !,"BAD ENTRY IN APPLICATION GROUP" Q
W !,"CHECKING THE ",$P(^DIC(LRF,0),U)," FILE (#",LRF,") POINTERS.",!
DPT S @("DFN=$O("_DIC_"DFN))") G END:DFN'>0 S @("D=$D("_DIC_"DFN,""LR""))[0") G DPT:D S LR=^("LR")
I LR'>0!(+LR'=LR) W !,"Entry: ",DFN," has a invalid LR Pointer: '",LR,"'." G DPT
W:'$D(^LR(LR,0)) !,"Entry: ",DFN," Pointer to MISSING node LR: ",LR
IF $D(^LR(LR,0))[0 W !,"LR: ",LR," Is missing the zero node." S:LRFIX ^LR(LR,0)=LR_U_LRF_U_DFN W:LRFIX " added" G DPT
S X=^LR(LR,0),LRDPF=$P(X,U,2) W:LRDPF'=LRF !,"Entry: ",DFN," points to LR: ",LR," Which doesn't point back to this file.",!?5," ^LR points to file: ",LRDPF
W:$P(X,U,3)'=DFN !,"Entry: ",DFN," Points to a entry that points to Entry: ",$P(X,U,3)
G DPT
LRS S LR=0 W !!,"CHECKING THE LAB DATA FILE POINTERS.",!
LR S LR=$O(^LR(LR)) G END:LR'>0 I $D(^LR(LR,0))[0 W !,"LR: ",LR," Lacks a zero node." G LR
S LRDPF=+$P(^LR(LR,0),U,2),DFN=+$P(^(0),U,3),LRGBL=$S(LRDPF=2:"^DPT(",1:$S($D(^DIC(LRDPF,0,"GL")):^("GL"),1:""))_DFN_","
I LRDPF<2!(DFN'>0) W !,"LR: ",LR," has a BAD file or entry pointer. File: ",LRDPF," Entry: ",DFN G LR
I $D(^DIC(LRDPF,0,"GL"))[0 W !,"LR: ",LR,?11," Points to a BAD file: ",LRDPF G LR
I @("$D("_LRGBL_"0))[0") W !,"LR: ",LR,?11," Points to a missing ",$P(^DIC(LRDPF,0),U)," FILE ENTRY, Entry: ",DFN S:LRFIX @(LRGBL_"0)=""LOST,PT."""),@(LRGBL_"""LR"")="_LR) W:LRFIX " added" G LR
I @("$D("_LRGBL_"""LR""))[0") W !,"LR: ",LR,?11," Points to file: ",LRDPF," Entry: ",DFN,", that doesn't have a pointer." S:LRFIX @(LRGBL_"""LR"")="_LR) W:LRFIX " added" G LR
W:@(LRGBL_"""LR"")")'=LR !,"LR: ",LR,?11," Points to file: ",LRDPF," Entry: ",DFN,", That points to LR: ",^("LR")
G LR
END K LRGBL W !,"ALL DONE",! W:$E(IOST,1,2)="P-" @IOF Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCKPTR 2565 printed Dec 13, 2024@02:13:48 Page 2
LRCKPTR ;SLC/RWF - CHECK ^LR & ^DPT CROSS POINTERS ; 8/30/87 17:20 ;
+1 ;;5.2;LAB SERVICE;**272,293**;Sep 27, 1994
+2 WRITE !,"CHECK OF POINTERS TO/FROM THE ^LR FILE",!!,"Want me to add missing nodes. "
SET %=2
SET U="^"
DO YN^DICN
IF %<1
if %=0
WRITE !!,"a 'yes' and I will add missing zero nodes that are reported,",!," and missing pointers to ^LR."
if %<0
QUIT
GOTO LRCKPTR
+3 SET LRFIX=(%=1)
+4 SET DFN=0
SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
+5 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN="DQ^LRCKPTR"
SET ZTSAVE("LRFIX")=""
SET ZTDESC="Integrity Report"
DO ^%ZTLOAD
KILL ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK
DO ^%ZISC
QUIT
DQ if $DATA(ZTQUEUED)
SET ZTREQ="@"
DO ENT
WRITE !!
if $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
KILL LRFIX
QUIT
ENT ;from LRCKF
+1 USE IO
WRITE !
if '$DATA(LRFIX)
SET LRFIX=0
+2 FOR LRF=0:0
SET LRF=$ORDER(^DIC("AC","LR",LRF))
if LRF'>0
QUIT
DO LRP
+3 GOTO LRS
LRP SET U="^"
SET DFN=0
SET DIC=$SELECT($DATA(^DIC(LRF,0,"GL")):^("GL"),1:"")
IF DIC'[U
WRITE !,"BAD ENTRY IN APPLICATION GROUP"
QUIT
+1 WRITE !,"CHECKING THE ",$PIECE(^DIC(LRF,0),U)," FILE (#",LRF,") POINTERS.",!
DPT SET @("DFN=$O("_DIC_"DFN))")
if DFN'>0
GOTO END
SET @("D=$D("_DIC_"DFN,""LR""))[0")
if D
GOTO DPT
SET LR=^("LR")
+1 IF LR'>0!(+LR'=LR)
WRITE !,"Entry: ",DFN," has a invalid LR Pointer: '",LR,"'."
GOTO DPT
+2 if '$DATA(^LR(LR,0))
WRITE !,"Entry: ",DFN," Pointer to MISSING node LR: ",LR
+3 IF $DATA(^LR(LR,0))[0
WRITE !,"LR: ",LR," Is missing the zero node."
if LRFIX
SET ^LR(LR,0)=LR_U_LRF_U_DFN
if LRFIX
WRITE " added"
GOTO DPT
+4 SET X=^LR(LR,0)
SET LRDPF=$PIECE(X,U,2)
if LRDPF'=LRF
WRITE !,"Entry: ",DFN," points to LR: ",LR," Which doesn't point back to this file.",!?5," ^LR points to file: ",LRDPF
+5 if $PIECE(X,U,3)'=DFN
WRITE !,"Entry: ",DFN," Points to a entry that points to Entry: ",$PIECE(X,U,3)
+6 GOTO DPT
LRS SET LR=0
WRITE !!,"CHECKING THE LAB DATA FILE POINTERS.",!
LR SET LR=$ORDER(^LR(LR))
if LR'>0
GOTO END
IF $DATA(^LR(LR,0))[0
WRITE !,"LR: ",LR," Lacks a zero node."
GOTO LR
+1 SET LRDPF=+$PIECE(^LR(LR,0),U,2)
SET DFN=+$PIECE(^(0),U,3)
SET LRGBL=$SELECT(LRDPF=2:"^DPT(",1:$SELECT($DATA(^DIC(LRDPF,0,"GL")):^("GL"),1:""))_DFN_","
+2 IF LRDPF<2!(DFN'>0)
WRITE !,"LR: ",LR," has a BAD file or entry pointer. File: ",LRDPF," Entry: ",DFN
GOTO LR
+3 IF $DATA(^DIC(LRDPF,0,"GL"))[0
WRITE !,"LR: ",LR,?11," Points to a BAD file: ",LRDPF
GOTO LR
+4 IF @("$D("_LRGBL_"0))[0")
WRITE !,"LR: ",LR,?11," Points to a missing ",$PIECE(^DIC(LRDPF,0),U)," FILE ENTRY, Entry: ",DFN
if LRFIX
SET @(LRGBL_"0)=""LOST,PT.""")
SET @(LRGBL_"""LR"")="_LR)
if LRFIX
WRITE " added"
GOTO LR
+5 IF @("$D("_LRGBL_"""LR""))[0")
WRITE !,"LR: ",LR,?11," Points to file: ",LRDPF," Entry: ",DFN,", that doesn't have a pointer."
if LRFIX
SET @(LRGBL_"""LR"")="_LR)
if LRFIX
WRITE " added"
GOTO LR
+6 if @(LRGBL_"""LR"")")'=LR
WRITE !,"LR: ",LR,?11," Points to file: ",LRDPF," Entry: ",DFN,", That points to LR: ",^("LR")
+7 GOTO LR
END KILL LRGBL
WRITE !,"ALL DONE",!
if $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
QUIT
+1 QUIT
