- 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
