LRPXCHK ;SLC/STAFF - Lab PXRMINDX Index Validation ;3/30/04 12:01
;;5.2;LAB SERVICE;**295,445**;Sep 27, 1994;Build 6
;
PATS ; select patients for index check
N DFN,ERR,REPAIR
D CLEAN
F D GETPT^LRPXAPPU(.DFN,.ERR) Q:ERR D
. S ^TMP("LRLOG PATS",$J,DFN)=""
D
. I '$O(^TMP("LRLOG PATS",$J,0)) Q
. D GETREP(.REPAIR,.ERR) I ERR Q
. D CHECK(REPAIR)
D CLEAN
Q
;
DATES ; check indexes for a date range of patient collections
N CNT,DATE1,DATE2,DFN,LRDFN,LRIDT,OK,REPAIR,START,STOP,SUB
D CLEAN
D GETDATE^LRPXAPPU(.DATE1,.DATE2,.ERR) I ERR Q
D GETREP(.REPAIR,.ERR) I ERR Q
S STOP=$$LRIDT^LRPXAPIU(DATE1)
S START=$$LRIDT^LRPXAPIU(DATE2)
S CNT=0
S LRDFN=0
F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D
. S OK=0
. F SUB="CH","MI","CY","SP","EM" D Q:OK
.. S LRIDT=START
.. F S LRIDT=$O(^LR(LRDFN,SUB,LRIDT)) Q:LRIDT<1 Q:LRIDT>STOP D Q:OK
... S DFN=$$DFN^LRPXAPIU(LRDFN)
... I 'DFN Q
... S ^TMP("LRLOG PATS",$J,DFN)=""
... S OK=1,CNT=CNT+1
W !,CNT," Patients to check"
D CHECK(REPAIR)
D CLEAN
Q
;
CHECK(REPAIR) ;
N CNT,DFN
S REPAIR=$G(REPAIR)
S DFN=0
F S DFN=$O(^TMP("LRLOG PATS",$J,DFN)) Q:DFN<1 D
. W !,"DFN: ",DFN," LRDFN: ",$$LRDFN^LRPXAPIU(DFN)
. D CHKPAT(DFN)
S CNT=0
S DFN=0
F S DFN=$O(^TMP("LRLOG",$J,DFN)) Q:DFN<1 D
. S CNT=CNT+1
I 'CNT W !,"Indexes were valid" Q
W !,CNT," Patients with invalid indexes"
I REPAIR D REPAIR
Q
;
ALL ; check all patient indexes
; this takes a very long time
; to be used in small test accounts
; START and STOP determine range of DFNs to check
Q ; for testing
N DFN,ERR,REPAIR,START,STOP
D CLEAN
W !,"WARNING - checking ALL patients",!
D GETREP(.REPAIR,.ERR) I ERR Q
S START=1
S STOP=10000000000000
S DFN=START-.1
F S DFN=$O(^DPT(DFN)) Q:DFN<1 Q:DFN>STOP D
. W !,"DFN: ",DFN," LRDFN: ",$$LRDFN^LRPXAPIU(DFN)
. D CHKPAT(DFN)
I REPAIR D REPAIR
D CLEAN
Q
;
CHKPAT(DFN) ; from LRLOG
; find bad nodes,
; store as ^TMP("LRLOG",$J,DFN,DATE,ITEM,INDEX)=NODE
; only when ^TMP("LRLOG PATS",$J) is present
; if ^TMP("LRLOG PATS",$J) is not present, write to screen
N ITEM,LRDFN
K ^TMP("LRPXCHK",$J)
S LRDFN=$$LRDFN^LRPXAPIU(DFN)
I 'LRDFN Q
M ^TMP("LRPXCHK",$J,"LR",LRDFN)=^LR(LRDFN)
M ^TMP("LRPXCHK",$J,"PI",DFN)=^PXRMINDX(63,"PI",DFN)
M ^TMP("LRPXCHK",$J,"PDI",DFN)=^PXRMINDX(63,"PDI",DFN)
S ITEM=""
F S ITEM=$O(^PXRMINDX(63,"IP",ITEM)) Q:ITEM="" D
. I $D(^PXRMINDX(63,"IP",ITEM,DFN)) D
. M ^TMP("LRPXCHK",$J,"IP",ITEM,DFN)=^PXRMINDX(63,"IP",ITEM,DFN)
D INTEG(DFN)
D CHKLR(DFN)
D CHKPI(DFN,LRDFN)
K ^TMP("LRPXCHK",$J)
Q
;
INTEG(DFN) ; make sure "PI", "IP", and "PDI" are consistent
N DATE,ITEM,NODE
S DATE=0
F S DATE=$O(^TMP("LRPXCHK",$J,"PDI",DFN,DATE)) Q:DATE<1 D
. S ITEM="A"
. F S ITEM=$O(^TMP("LRPXCHK",$J,"PDI",DFN,DATE,ITEM)) Q:ITEM="" D
.. S NODE=""
.. F S NODE=$O(^TMP("LRPXCHK",$J,"PDI",DFN,DATE,ITEM,NODE)) Q:NODE="" D
... I '$D(^TMP("LRPXCHK",$J,"PI",DFN,ITEM,DATE,NODE)) D
.... D BAD("PDI-PI",DFN,ITEM,DATE,NODE)
... I '$D(^TMP("LRPXCHK",$J,"IP",ITEM,DFN,DATE,NODE)) D
.... D BAD("PDI-IP",DFN,ITEM,DATE,NODE)
S ITEM=""
F S ITEM=$O(^TMP("LRPXCHK",$J,"PI",DFN,ITEM)) Q:ITEM="" D
. S DATE=0
. F S DATE=$O(^TMP("LRPXCHK",$J,"PI",DFN,ITEM,DATE)) Q:DATE<1 D
.. S NODE=""
.. F S NODE=$O(^TMP("LRPXCHK",$J,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D
... I '$D(^TMP("LRPXCHK",$J,"IP",ITEM,DFN,DATE,NODE)) D
.... D BAD("PI-IP",DFN,ITEM,DATE,NODE)
... I 'ITEM,'$D(^TMP("LRPXCHK",$J,"PDI",DFN,DATE,ITEM,NODE)) D
.... D BAD("PI-PDI",DFN,ITEM,DATE,NODE)
S ITEM=""
F S ITEM=$O(^TMP("LRPXCHK",$J,"IP",ITEM)) Q:ITEM="" D
. S DATE=0
. F S DATE=$O(^TMP("LRPXCHK",$J,"IP",ITEM,DFN,DATE)) Q:DATE<1 D
.. S NODE=""
.. F S NODE=$O(^TMP("LRPXCHK",$J,"IP",ITEM,DFN,DATE,NODE)) Q:NODE="" D
... I '$D(^TMP("LRPXCHK",$J,"PI",DFN,ITEM,DATE,NODE)) D
.... D BAD("IP-PI",DFN,ITEM,DATE,NODE)
... I 'ITEM,'$D(^TMP("LRPXCHK",$J,"PDI",DFN,DATE,ITEM,NODE)) D
.... D BAD("IP-PDI",DFN,ITEM,DATE,NODE)
Q
;
CHKLR(DFN) ; go thru "PI" to make sure ^LR is consistent
N DATE,ITEM,NODE
S ITEM=""
F S ITEM=$O(^TMP("LRPXCHK",$J,"PI",DFN,ITEM)) Q:ITEM="" D
. S DATE=0
. F S DATE=$O(^TMP("LRPXCHK",$J,"PI",DFN,ITEM,DATE)) Q:DATE<1 D
.. S NODE=""
.. F S NODE=$O(^TMP("LRPXCHK",$J,"PI",DFN,ITEM,DATE,NODE)) Q:NODE="" D
... I '$$REFVAL(NODE) D BAD("LR",DFN,ITEM,DATE,NODE) Q
Q
;
CHKPI(DFN,LRDFN) ; go thru ^LR to make sure "PI" is consistent
N DATE,ITEM,LRIDT,LRDN,NODE,ZERO
S LRIDT=0
F S LRIDT=$O(^TMP("LRPXCHK",$J,"LR",LRDFN,"CH",LRIDT)) Q:LRIDT<1 D
. S ZERO=$G(^TMP("LRPXCHK",$J,"LR",LRDFN,"CH",LRIDT,0))
. S DATE=+ZERO I 'DATE Q
. I '$P(ZERO,U,3) Q
. S LRDN=1
. F S LRDN=$O(^TMP("LRPXCHK",$J,"LR",LRDFN,"CH",LRIDT,LRDN)) Q:LRDN<1 D
.. S ITEM=$$TEST^LRPXAPIU(LRDN)
.. I 'ITEM Q
.. S NODE=LRDFN_";CH;"_LRIDT_";"_LRDN
.. I '$D(^PXRMINDX(63,"PI",DFN,ITEM,DATE,NODE)) D BAD("CH",DFN,ITEM,DATE,NODE)
D MI^LRPXCHKM(DFN,LRDFN)
D AP^LRPXCHKA(DFN,LRDFN)
Q
;
TMPCHK(DFN,DATE,ITEM,NODE) ;
I '$D(^PXRMINDX(63,"PI",DFN,ITEM,DATE,NODE)) D BAD(NODE,DFN,ITEM,DATE,NODE)
Q
;
BAD(INDEX,DFN,ITEM,DATE,NODE) ; write error to screen, collect in global
W !,?5,INDEX," ",DFN," ",ITEM," ",DATE," ",NODE
S ^TMP("LRLOG",$J,DFN,DATE,ITEM,INDEX)=NODE
Q
;
CLEAN ; clear tmp globals
; "LRLOG" collects invalid nodes, "LRLOG PATS" are patients checked
K ^TMP("LRLOG",$J)
K ^TMP("LRLOG PATS",$J)
Q
;
REFVAL(REF) ; $$(reference location in ^LR) -> if ref exists 1, else 0
N SUB
I REF'[";" Q ""
S SUB=$P(REF,";",2)
S SUB=""""_SUB_""""
S $P(REF,";",2)=SUB
S REF=$TR(REF,";",",")
S REF="^LR("_REF_")"
I $D(@REF) Q 1
Q 0
;
REPAIR ; correct invalid indexes
; kill off bad indexes
; reset all indexes at date of bad index
N DATE,DFN,DOD,INDEX,ITEM,NODE,REPAIR K REPAIR
S DFN=0
F S DFN=$O(^TMP("LRLOG",$J,DFN)) Q:DFN<1 D
. S LRDFN=$$LRDFN^LRPXAPIU(DFN)
. S DOD=$$DOD^LRPXAPIU(DFN)
. S DATE=0
. F S DATE=$O(^TMP("LRLOG",$J,DFN,DATE)) Q:DATE<1 D
.. S LRIDT=$$LRIDT^LRPXAPIU(DATE)
.. K REPAIR
.. S ITEM=""
.. F S ITEM=$O(^TMP("LRLOG",$J,DFN,DATE,ITEM)) Q:ITEM="" D
... S INDEX=""
... F S INDEX=$O(^TMP("LRLOG",$J,DFN,DATE,ITEM,INDEX)) Q:INDEX="" D
.... S NODE=^TMP("LRLOG",$J,DFN,DATE,ITEM,INDEX)
.... I '$L(NODE) Q
.... S REPAIR($P(NODE,";",2))=""
.... D KLAB^LRPX(DFN,DATE,ITEM,NODE)
.. S SUB=""
.. F S SUB=$O(REPAIR(SUB)) Q:SUB="" D
... I SUB="CH" D CH(DFN,LRDFN,DATE,LRIDT) Q
... I SUB="MI" D MICRO(DFN,LRDFN,DATE,LRIDT) Q
... D AP(DFN,LRDFN,DATE,LRIDT,SUB)
.. I DATE=DOD D AU(DFN,LRDFN,DATE) Q
Q
;
CH(DFN,LRDFN,DATE,LRIDT) ;
N DAT,LRDN,NODE,TEMP,TEST
I '$$VERIFIED^LRPXAPI(LRDFN,LRIDT) Q
S DAT=LRDFN_";CH;"_LRIDT
S LRDN=1
F S LRDN=$O(^LR(LRDFN,"CH",LRIDT,LRDN)) Q:LRDN<1 D
. S NODE=DAT_";"_LRDN
. S TEMP=^LR(LRDFN,"CH",LRIDT,LRDN)
. S TEST=+$P($P(TEMP,U,3),"!",7)
. I 'TEST S TEST=$$TEST^LRPXAPIU(LRDN)
. I 'TEST Q
. D SLAB^LRPX(DFN,DATE,TEST,NODE)
Q
;
MICRO(DFN,LRDFN,DATE,LRIDT) ;
K ^TMP("LRPX",$J)
M ^TMP("LRPX",$J,"AR")=^LR(LRDFN,"MI",LRIDT)
M ^TMP("LRPX",$J,"B")=^PXRMINDX(63,"PDI",DFN,DATE)
D MICRO^LRPXRM(DFN,LRDFN,DATE,LRIDT)
K ^TMP("LRPX",$J)
Q
;
AP(DFN,LRDFN,DATE,LRIDT,SUB) ;
K ^TMP("LRPX",$J)
M ^TMP("LRPX",$J,"AR")=^LR(LRDFN,SUB,LRIDT)
M ^TMP("LRPX",$J,"B")=^PXRMINDX(63,"PDI",DFN,DATE)
D AP^LRPXRM(DFN,LRDFN,DATE,LRIDT,SUB)
K ^TMP("LRPX",$J)
Q
;
AU(DFN,LRDFN,DATE) ;
I '+$G(^LR(LRDFN,"AU")) Q
I '($P(^LR(LRDFN,"AU"),U,3)&($P(^("AU"),U,15))) Q
K ^TMP("LRPX",$J)
M ^TMP("LRPX",$J,"AR","AY")=^LR(LRDFN,"AY")
M ^TMP("LRPX",$J,"AR",80)=^LR(LRDFN,80)
M ^TMP("LRPX",$J,"AR",33)=^LR(LRDFN,33)
M ^TMP("LRPX",$J,"B")=^PXRMINDX(63,"PDI",DFN,DATE)
D AUTOPSY^LRPXRM(LRDFN)
K ^TMP("LRPX",$J)
Q
;
GETREP(REPAIR,ERR) ;
; asks to repair indexes
N DIR,DIRUT,DTOUT,X,Y K DIR
S ERR=0,REPAIR=""
S DIR(0)="YAO"
S DIR("A")="Repair invalid indexes? "
S DIR("B")="YES"
D ^DIR K DIR
I Y[U!$D(DTOUT) S ERR=1 Q
S REPAIR=Y
W !
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRPXCHK 8112 printed Nov 22, 2024@17:29:42 Page 2
LRPXCHK ;SLC/STAFF - Lab PXRMINDX Index Validation ;3/30/04 12:01
+1 ;;5.2;LAB SERVICE;**295,445**;Sep 27, 1994;Build 6
+2 ;
PATS ; select patients for index check
+1 NEW DFN,ERR,REPAIR
+2 DO CLEAN
+3 FOR
DO GETPT^LRPXAPPU(.DFN,.ERR)
if ERR
QUIT
Begin DoDot:1
+4 SET ^TMP("LRLOG PATS",$JOB,DFN)=""
End DoDot:1
+5 Begin DoDot:1
+6 IF '$ORDER(^TMP("LRLOG PATS",$JOB,0))
QUIT
+7 DO GETREP(.REPAIR,.ERR)
IF ERR
QUIT
+8 DO CHECK(REPAIR)
End DoDot:1
+9 DO CLEAN
+10 QUIT
+11 ;
DATES ; check indexes for a date range of patient collections
+1 NEW CNT,DATE1,DATE2,DFN,LRDFN,LRIDT,OK,REPAIR,START,STOP,SUB
+2 DO CLEAN
+3 DO GETDATE^LRPXAPPU(.DATE1,.DATE2,.ERR)
IF ERR
QUIT
+4 DO GETREP(.REPAIR,.ERR)
IF ERR
QUIT
+5 SET STOP=$$LRIDT^LRPXAPIU(DATE1)
+6 SET START=$$LRIDT^LRPXAPIU(DATE2)
+7 SET CNT=0
+8 SET LRDFN=0
+9 FOR
SET LRDFN=$ORDER(^LR(LRDFN))
if LRDFN<1
QUIT
Begin DoDot:1
+10 SET OK=0
+11 FOR SUB="CH","MI","CY","SP","EM"
Begin DoDot:2
+12 SET LRIDT=START
+13 FOR
SET LRIDT=$ORDER(^LR(LRDFN,SUB,LRIDT))
if LRIDT<1
QUIT
if LRIDT>STOP
QUIT
Begin DoDot:3
+14 SET DFN=$$DFN^LRPXAPIU(LRDFN)
+15 IF 'DFN
QUIT
+16 SET ^TMP("LRLOG PATS",$JOB,DFN)=""
+17 SET OK=1
SET CNT=CNT+1
End DoDot:3
if OK
QUIT
End DoDot:2
if OK
QUIT
End DoDot:1
+18 WRITE !,CNT," Patients to check"
+19 DO CHECK(REPAIR)
+20 DO CLEAN
+21 QUIT
+22 ;
CHECK(REPAIR) ;
+1 NEW CNT,DFN
+2 SET REPAIR=$GET(REPAIR)
+3 SET DFN=0
+4 FOR
SET DFN=$ORDER(^TMP("LRLOG PATS",$JOB,DFN))
if DFN<1
QUIT
Begin DoDot:1
+5 WRITE !,"DFN: ",DFN," LRDFN: ",$$LRDFN^LRPXAPIU(DFN)
+6 DO CHKPAT(DFN)
End DoDot:1
+7 SET CNT=0
+8 SET DFN=0
+9 FOR
SET DFN=$ORDER(^TMP("LRLOG",$JOB,DFN))
if DFN<1
QUIT
Begin DoDot:1
+10 SET CNT=CNT+1
End DoDot:1
+11 IF 'CNT
WRITE !,"Indexes were valid"
QUIT
+12 WRITE !,CNT," Patients with invalid indexes"
+13 IF REPAIR
DO REPAIR
+14 QUIT
+15 ;
ALL ; check all patient indexes
+1 ; this takes a very long time
+2 ; to be used in small test accounts
+3 ; START and STOP determine range of DFNs to check
+4 ; for testing
QUIT
+5 NEW DFN,ERR,REPAIR,START,STOP
+6 DO CLEAN
+7 WRITE !,"WARNING - checking ALL patients",!
+8 DO GETREP(.REPAIR,.ERR)
IF ERR
QUIT
+9 SET START=1
+10 SET STOP=10000000000000
+11 SET DFN=START-.1
+12 FOR
SET DFN=$ORDER(^DPT(DFN))
if DFN<1
QUIT
if DFN>STOP
QUIT
Begin DoDot:1
+13 WRITE !,"DFN: ",DFN," LRDFN: ",$$LRDFN^LRPXAPIU(DFN)
+14 DO CHKPAT(DFN)
End DoDot:1
+15 IF REPAIR
DO REPAIR
+16 DO CLEAN
+17 QUIT
+18 ;
CHKPAT(DFN) ; from LRLOG
+1 ; find bad nodes,
+2 ; store as ^TMP("LRLOG",$J,DFN,DATE,ITEM,INDEX)=NODE
+3 ; only when ^TMP("LRLOG PATS",$J) is present
+4 ; if ^TMP("LRLOG PATS",$J) is not present, write to screen
+5 NEW ITEM,LRDFN
+6 KILL ^TMP("LRPXCHK",$JOB)
+7 SET LRDFN=$$LRDFN^LRPXAPIU(DFN)
+8 IF 'LRDFN
QUIT
+9 MERGE ^TMP("LRPXCHK",$JOB,"LR",LRDFN)=^LR(LRDFN)
+10 MERGE ^TMP("LRPXCHK",$JOB,"PI",DFN)=^PXRMINDX(63,"PI",DFN)
+11 MERGE ^TMP("LRPXCHK",$JOB,"PDI",DFN)=^PXRMINDX(63,"PDI",DFN)
+12 SET ITEM=""
+13 FOR
SET ITEM=$ORDER(^PXRMINDX(63,"IP",ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+14 IF $DATA(^PXRMINDX(63,"IP",ITEM,DFN))
Begin DoDot:2
End DoDot:2
+15 MERGE ^TMP("LRPXCHK",$JOB,"IP",ITEM,DFN)=^PXRMINDX(63,"IP",ITEM,DFN)
End DoDot:1
+16 DO INTEG(DFN)
+17 DO CHKLR(DFN)
+18 DO CHKPI(DFN,LRDFN)
+19 KILL ^TMP("LRPXCHK",$JOB)
+20 QUIT
+21 ;
INTEG(DFN) ; make sure "PI", "IP", and "PDI" are consistent
+1 NEW DATE,ITEM,NODE
+2 SET DATE=0
+3 FOR
SET DATE=$ORDER(^TMP("LRPXCHK",$JOB,"PDI",DFN,DATE))
if DATE<1
QUIT
Begin DoDot:1
+4 SET ITEM="A"
+5 FOR
SET ITEM=$ORDER(^TMP("LRPXCHK",$JOB,"PDI",DFN,DATE,ITEM))
if ITEM=""
QUIT
Begin DoDot:2
+6 SET NODE=""
+7 FOR
SET NODE=$ORDER(^TMP("LRPXCHK",$JOB,"PDI",DFN,DATE,ITEM,NODE))
if NODE=""
QUIT
Begin DoDot:3
+8 IF '$DATA(^TMP("LRPXCHK",$JOB,"PI",DFN,ITEM,DATE,NODE))
Begin DoDot:4
+9 DO BAD("PDI-PI",DFN,ITEM,DATE,NODE)
End DoDot:4
+10 IF '$DATA(^TMP("LRPXCHK",$JOB,"IP",ITEM,DFN,DATE,NODE))
Begin DoDot:4
+11 DO BAD("PDI-IP",DFN,ITEM,DATE,NODE)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+12 SET ITEM=""
+13 FOR
SET ITEM=$ORDER(^TMP("LRPXCHK",$JOB,"PI",DFN,ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+14 SET DATE=0
+15 FOR
SET DATE=$ORDER(^TMP("LRPXCHK",$JOB,"PI",DFN,ITEM,DATE))
if DATE<1
QUIT
Begin DoDot:2
+16 SET NODE=""
+17 FOR
SET NODE=$ORDER(^TMP("LRPXCHK",$JOB,"PI",DFN,ITEM,DATE,NODE))
if NODE=""
QUIT
Begin DoDot:3
+18 IF '$DATA(^TMP("LRPXCHK",$JOB,"IP",ITEM,DFN,DATE,NODE))
Begin DoDot:4
+19 DO BAD("PI-IP",DFN,ITEM,DATE,NODE)
End DoDot:4
+20 IF 'ITEM
IF '$DATA(^TMP("LRPXCHK",$JOB,"PDI",DFN,DATE,ITEM,NODE))
Begin DoDot:4
+21 DO BAD("PI-PDI",DFN,ITEM,DATE,NODE)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+22 SET ITEM=""
+23 FOR
SET ITEM=$ORDER(^TMP("LRPXCHK",$JOB,"IP",ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+24 SET DATE=0
+25 FOR
SET DATE=$ORDER(^TMP("LRPXCHK",$JOB,"IP",ITEM,DFN,DATE))
if DATE<1
QUIT
Begin DoDot:2
+26 SET NODE=""
+27 FOR
SET NODE=$ORDER(^TMP("LRPXCHK",$JOB,"IP",ITEM,DFN,DATE,NODE))
if NODE=""
QUIT
Begin DoDot:3
+28 IF '$DATA(^TMP("LRPXCHK",$JOB,"PI",DFN,ITEM,DATE,NODE))
Begin DoDot:4
+29 DO BAD("IP-PI",DFN,ITEM,DATE,NODE)
End DoDot:4
+30 IF 'ITEM
IF '$DATA(^TMP("LRPXCHK",$JOB,"PDI",DFN,DATE,ITEM,NODE))
Begin DoDot:4
+31 DO BAD("IP-PDI",DFN,ITEM,DATE,NODE)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT
+33 ;
CHKLR(DFN) ; go thru "PI" to make sure ^LR is consistent
+1 NEW DATE,ITEM,NODE
+2 SET ITEM=""
+3 FOR
SET ITEM=$ORDER(^TMP("LRPXCHK",$JOB,"PI",DFN,ITEM))
if ITEM=""
QUIT
Begin DoDot:1
+4 SET DATE=0
+5 FOR
SET DATE=$ORDER(^TMP("LRPXCHK",$JOB,"PI",DFN,ITEM,DATE))
if DATE<1
QUIT
Begin DoDot:2
+6 SET NODE=""
+7 FOR
SET NODE=$ORDER(^TMP("LRPXCHK",$JOB,"PI",DFN,ITEM,DATE,NODE))
if NODE=""
QUIT
Begin DoDot:3
+8 IF '$$REFVAL(NODE)
DO BAD("LR",DFN,ITEM,DATE,NODE)
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
CHKPI(DFN,LRDFN) ; go thru ^LR to make sure "PI" is consistent
+1 NEW DATE,ITEM,LRIDT,LRDN,NODE,ZERO
+2 SET LRIDT=0
+3 FOR
SET LRIDT=$ORDER(^TMP("LRPXCHK",$JOB,"LR",LRDFN,"CH",LRIDT))
if LRIDT<1
QUIT
Begin DoDot:1
+4 SET ZERO=$GET(^TMP("LRPXCHK",$JOB,"LR",LRDFN,"CH",LRIDT,0))
+5 SET DATE=+ZERO
IF 'DATE
QUIT
+6 IF '$PIECE(ZERO,U,3)
QUIT
+7 SET LRDN=1
+8 FOR
SET LRDN=$ORDER(^TMP("LRPXCHK",$JOB,"LR",LRDFN,"CH",LRIDT,LRDN))
if LRDN<1
QUIT
Begin DoDot:2
+9 SET ITEM=$$TEST^LRPXAPIU(LRDN)
+10 IF 'ITEM
QUIT
+11 SET NODE=LRDFN_";CH;"_LRIDT_";"_LRDN
+12 IF '$DATA(^PXRMINDX(63,"PI",DFN,ITEM,DATE,NODE))
DO BAD("CH",DFN,ITEM,DATE,NODE)
End DoDot:2
End DoDot:1
+13 DO MI^LRPXCHKM(DFN,LRDFN)
+14 DO AP^LRPXCHKA(DFN,LRDFN)
+15 QUIT
+16 ;
TMPCHK(DFN,DATE,ITEM,NODE) ;
+1 IF '$DATA(^PXRMINDX(63,"PI",DFN,ITEM,DATE,NODE))
DO BAD(NODE,DFN,ITEM,DATE,NODE)
+2 QUIT
+3 ;
BAD(INDEX,DFN,ITEM,DATE,NODE) ; write error to screen, collect in global
+1 WRITE !,?5,INDEX," ",DFN," ",ITEM," ",DATE," ",NODE
+2 SET ^TMP("LRLOG",$JOB,DFN,DATE,ITEM,INDEX)=NODE
+3 QUIT
+4 ;
CLEAN ; clear tmp globals
+1 ; "LRLOG" collects invalid nodes, "LRLOG PATS" are patients checked
+2 KILL ^TMP("LRLOG",$JOB)
+3 KILL ^TMP("LRLOG PATS",$JOB)
+4 QUIT
+5 ;
REFVAL(REF) ; $$(reference location in ^LR) -> if ref exists 1, else 0
+1 NEW SUB
+2 IF REF'[";"
QUIT ""
+3 SET SUB=$PIECE(REF,";",2)
+4 SET SUB=""""_SUB_""""
+5 SET $PIECE(REF,";",2)=SUB
+6 SET REF=$TRANSLATE(REF,";",",")
+7 SET REF="^LR("_REF_")"
+8 IF $DATA(@REF)
QUIT 1
+9 QUIT 0
+10 ;
REPAIR ; correct invalid indexes
+1 ; kill off bad indexes
+2 ; reset all indexes at date of bad index
+3 NEW DATE,DFN,DOD,INDEX,ITEM,NODE,REPAIR
KILL REPAIR
+4 SET DFN=0
+5 FOR
SET DFN=$ORDER(^TMP("LRLOG",$JOB,DFN))
if DFN<1
QUIT
Begin DoDot:1
+6 SET LRDFN=$$LRDFN^LRPXAPIU(DFN)
+7 SET DOD=$$DOD^LRPXAPIU(DFN)
+8 SET DATE=0
+9 FOR
SET DATE=$ORDER(^TMP("LRLOG",$JOB,DFN,DATE))
if DATE<1
QUIT
Begin DoDot:2
+10 SET LRIDT=$$LRIDT^LRPXAPIU(DATE)
+11 KILL REPAIR
+12 SET ITEM=""
+13 FOR
SET ITEM=$ORDER(^TMP("LRLOG",$JOB,DFN,DATE,ITEM))
if ITEM=""
QUIT
Begin DoDot:3
+14 SET INDEX=""
+15 FOR
SET INDEX=$ORDER(^TMP("LRLOG",$JOB,DFN,DATE,ITEM,INDEX))
if INDEX=""
QUIT
Begin DoDot:4
+16 SET NODE=^TMP("LRLOG",$JOB,DFN,DATE,ITEM,INDEX)
+17 IF '$LENGTH(NODE)
QUIT
+18 SET REPAIR($PIECE(NODE,";",2))=""
+19 DO KLAB^LRPX(DFN,DATE,ITEM,NODE)
End DoDot:4
End DoDot:3
+20 SET SUB=""
+21 FOR
SET SUB=$ORDER(REPAIR(SUB))
if SUB=""
QUIT
Begin DoDot:3
+22 IF SUB="CH"
DO CH(DFN,LRDFN,DATE,LRIDT)
QUIT
+23 IF SUB="MI"
DO MICRO(DFN,LRDFN,DATE,LRIDT)
QUIT
+24 DO AP(DFN,LRDFN,DATE,LRIDT,SUB)
End DoDot:3
+25 IF DATE=DOD
DO AU(DFN,LRDFN,DATE)
QUIT
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
CH(DFN,LRDFN,DATE,LRIDT) ;
+1 NEW DAT,LRDN,NODE,TEMP,TEST
+2 IF '$$VERIFIED^LRPXAPI(LRDFN,LRIDT)
QUIT
+3 SET DAT=LRDFN_";CH;"_LRIDT
+4 SET LRDN=1
+5 FOR
SET LRDN=$ORDER(^LR(LRDFN,"CH",LRIDT,LRDN))
if LRDN<1
QUIT
Begin DoDot:1
+6 SET NODE=DAT_";"_LRDN
+7 SET TEMP=^LR(LRDFN,"CH",LRIDT,LRDN)
+8 SET TEST=+$PIECE($PIECE(TEMP,U,3),"!",7)
+9 IF 'TEST
SET TEST=$$TEST^LRPXAPIU(LRDN)
+10 IF 'TEST
QUIT
+11 DO SLAB^LRPX(DFN,DATE,TEST,NODE)
End DoDot:1
+12 QUIT
+13 ;
MICRO(DFN,LRDFN,DATE,LRIDT) ;
+1 KILL ^TMP("LRPX",$JOB)
+2 MERGE ^TMP("LRPX",$JOB,"AR")=^LR(LRDFN,"MI",LRIDT)
+3 MERGE ^TMP("LRPX",$JOB,"B")=^PXRMINDX(63,"PDI",DFN,DATE)
+4 DO MICRO^LRPXRM(DFN,LRDFN,DATE,LRIDT)
+5 KILL ^TMP("LRPX",$JOB)
+6 QUIT
+7 ;
AP(DFN,LRDFN,DATE,LRIDT,SUB) ;
+1 KILL ^TMP("LRPX",$JOB)
+2 MERGE ^TMP("LRPX",$JOB,"AR")=^LR(LRDFN,SUB,LRIDT)
+3 MERGE ^TMP("LRPX",$JOB,"B")=^PXRMINDX(63,"PDI",DFN,DATE)
+4 DO AP^LRPXRM(DFN,LRDFN,DATE,LRIDT,SUB)
+5 KILL ^TMP("LRPX",$JOB)
+6 QUIT
+7 ;
AU(DFN,LRDFN,DATE) ;
+1 IF '+$GET(^LR(LRDFN,"AU"))
QUIT
+2 IF '($PIECE(^LR(LRDFN,"AU"),U,3)&($PIECE(^("AU"),U,15)))
QUIT
+3 KILL ^TMP("LRPX",$JOB)
+4 MERGE ^TMP("LRPX",$JOB,"AR","AY")=^LR(LRDFN,"AY")
+5 MERGE ^TMP("LRPX",$JOB,"AR",80)=^LR(LRDFN,80)
+6 MERGE ^TMP("LRPX",$JOB,"AR",33)=^LR(LRDFN,33)
+7 MERGE ^TMP("LRPX",$JOB,"B")=^PXRMINDX(63,"PDI",DFN,DATE)
+8 DO AUTOPSY^LRPXRM(LRDFN)
+9 KILL ^TMP("LRPX",$JOB)
+10 QUIT
+11 ;
GETREP(REPAIR,ERR) ;
+1 ; asks to repair indexes
+2 NEW DIR,DIRUT,DTOUT,X,Y
KILL DIR
+3 SET ERR=0
SET REPAIR=""
+4 SET DIR(0)="YAO"
+5 SET DIR("A")="Repair invalid indexes? "
+6 SET DIR("B")="YES"
+7 DO ^DIR
KILL DIR
+8 IF Y[U!$DATA(DTOUT)
SET ERR=1
QUIT
+9 SET REPAIR=Y
+10 WRITE !
+11 QUIT
+12 ;
