LRCKPTR ;VA/SLC/RWF - CHECK ^LR & ^DPT CROSS POINTERS ;JUL 06, 2010 3:14 PM;
;;5.2;LAB SERVICE;**1018,1027**;NOV 01, 1997
;;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)
; ----- BEGIH IHS/OIT/MKK - LR*5.2*1027 -- DO NOT allow "FIX" of MISSING nodes
W !,"CHECK OF POINTERS TO/FROM THE ^LR FILE",!!
S LRFIX=0 ; Set Flag to DO NOT FIX
D ^XBFMK
S DIR(0)="EO"
D ^DIR
I +$G(DIRUT) Q
; ----- END IHS/OIT/MKK - LR*5.2*1027
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
LRCKPTR ;VA/SLC/RWF - CHECK ^LR & ^DPT CROSS POINTERS ;JUL 06, 2010 3:14 PM;
+1 ;;5.2;LAB SERVICE;**1018,1027**;NOV 01, 1997
+2 ;;5.2;LAB SERVICE;**272,293**;Sep 27, 1994
+3 ; 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
+4 ; S LRFIX=(%=1)
+5 ; ----- BEGIH IHS/OIT/MKK - LR*5.2*1027 -- DO NOT allow "FIX" of MISSING nodes
+6 WRITE !,"CHECK OF POINTERS TO/FROM THE ^LR FILE",!!
+7 ; Set Flag to DO NOT FIX
SET LRFIX=0
+8 DO ^XBFMK
+9 SET DIR(0)="EO"
+10 DO ^DIR
+11 IF +$GET(DIRUT)
QUIT
+12 ; ----- END IHS/OIT/MKK - LR*5.2*1027
+13 SET DFN=0
SET %ZIS="Q"
DO ^%ZIS
IF POP
QUIT
+14 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
