ORELR5 ;slc/dcm - Check 69 against 100 ;Jul 08, 2019@12:17:53
;;3.0;ORDER ENTRY/RESULTS REPORTING;**42,453**;Dec 17, 1997;Build 47
;
;
; Reference to ^LAB(60 supported by ICR #2387
; Reference to ^LR( is supported by ICR #1948
;
EN ;Check file 69 against 100 for inconsistencies
;
N %,UPD,ZTSAVE
W !!,"This routine will go through the LAB ORDER ENTRY file (69)"
W !,"and check for inconsistencies between Lab files and CPRS files."
W !,"This process could take several hours to complete."
W !,"Are you sure you want to continue"
S %=2 D YN^DICN
I %=0 W !!,"Answer YES to continue" G EN
Q:%'=1
UPD W !!,"You have the option of just checking the database, or updating the database."
W !,"Do you want to update the database now"
S %=2 D YN^DICN
I %=0 W !!,"Select YES to update the database" G UPD
Q:%=-1
S UPD=$S(%=1:1,1:0)
S ZTSAVE("UPD")=""
D QUE^ORUTL1("DEQUE^ORELR5","Check from 69 to 100",.ZTSAVE)
Q
DEQUE ;Queued entry point
U IO
W !,"Inconsistency report between LAB (69) and OE/RR (100) files..."
W !,"Date/time Started: "_$$DATETIME^ORU($$NOW^XLFDT())
W !,"Now looking for data..."
N LRDFN,ORAFIX,STCNT,TOTCNT,DCNT,PTCNT,F100CNT,ENTCNT
S (ORAFIX,STCNT,TOTCNT,DCNT,PTCNT,F100CNT,ENTCNT,LRDFN)=0
F S LRDFN=$O(^LRO(69,"D",LRDFN)) Q:LRDFN<1 D LOOP(LRDFN,UPD)
W:IOSL-$Y<10 @IOF
W !!,"Total Inconsistencies Found"
W !,"Date/time Completed: "_$$DATETIME^ORU($$NOW^XLFDT())
W !,"-------------------------------------------------"
I DCNT W !,"Bad entry in ^LRO(69,""D""",?40,$J(DCNT,7)
I F100CNT W !,"Broken pointer to 100",?40,$J(F100CNT,7)
I ENTCNT W !,"Inconsistent entry dates",?40,$J(ENTCNT,7)
I PTCNT W !,"Patient mismatch"_$S(UPD:" (not fixed)",1:""),?40,$J(PTCNT,7)
I STCNT W !,"Status update on panel test",?40,$J(STCNT,7)
W !,"================================================="
W !,"Total: ",?40,$J(TOTCNT,7)
I $D(ZTQUEUED) S ZTREQ="@"
Q
LOOP(LRDFN,ORAFIX) ;Loop on patient
I '$D(^LR(LRDFN,0)) D WRT(,,,"No entry in ^LR("_LRDFN,ORAFIX) S DCNT=DCNT+1,TOTCNT=TOTCNT+1 K:ORAFIX ^LRO(69,"D",LRDFN) Q
Q:$P(^LR(LRDFN,0),"^",2)'=2 ;Not in patient file.
S DFN=$P(^LR(LRDFN,0),"^",3)
Q:'$D(^LRO(69,"D",$G(LRDFN)))
N LRODT,LRSN,LRTI,LRTST,LRENT,X,X0,X3,ORX1,ORX2,ORIFN,X8O
S LRODT=0 F S LRODT=$O(^LRO(69,"D",LRDFN,LRODT)) Q:'LRODT S LRSN=0 F S LRSN=$O(^LRO(69,"D",LRDFN,LRODT,LRSN)) Q:'LRSN D
. I '$D(^LRO(69,LRODT,1,LRSN,0)) D WRT(LRODT,LRSN,,"D X-ref invalid",ORAFIX) S DCNT=DCNT+1,TOTCNT=TOTCNT+1 K:ORAFIX ^LRO(69,"D",LRDFN,LRODT,LRSN) Q
. S X=^LRO(69,LRODT,1,LRSN,0),LRENT=$P(X,"^",5)
. S LRTI=0 F S LRTI=$O(^LRO(69,LRODT,1,LRSN,2,LRTI)) Q:LRTI<1 S X0=^(LRTI,0) D
.. S LRTST=+X0,ORIFN=$P(X0,"^",7)
.. I ORIFN D
... I '$D(^OR(100,ORIFN)) D WRT(LRODT,LRSN,LRTI,"Broken pointer to 100:"_ORIFN,ORAFIX) S F100CNT=F100CNT+1,TOTCNT=TOTCNT+1 S:ORAFIX $P(^LRO(69,LRODT,1,LRSN,2,LRTI,0),"^",7)="P" Q ;P=purged
... S X=^OR(100,ORIFN,0),X3=$G(^(3))
... I DFN'=+$P(X,"^",2) D WRT(LRODT,LRSN,LRTI,"Patient mismatch:"_ORIFN_"<"_$P(X3,"^",3)_">") S PTCNT=PTCNT+1,TOTCNT=TOTCNT+1 Q
... D STATUS(LRODT,LRSN,LRTI,X0,ORAFIX)
... I LRENT,$P(X,"^",7)>$S($P($P(X,"^",8),".",2):$P(X,"^",8),1:$P(X,"^",8)_".2359") D
.... S ORX1=$$FMADD^XLFDT($P(X,"^",7),,,30),ORX2=$$FMADD^XLFDT($P(X,"^",7),,,-30)
.... I LRENT<ORX2!(LRENT>ORX1) S ENTCNT=ENTCNT+1,TOTCNT=TOTCNT+1 I ORAFIX D
..... S $P(^OR(100,ORIFN,0),"^",7)=LRENT
..... I $P(X,"^",7)=+$G(^OR(100,ORIFN,8,1,0)) S X8O=$G(^(0)) D
...... N DI,DIC,DIE,DA,DR,D0,DQ,DISYS
...... I $P(X,"^",11) K ^OR(100,"ACT",$P(X,"^",2),9999999-+X8O,$P(X,"^",11),ORIFN,1)
...... K ^OR(100,"AC",$P(X,"^",2),9999999-+X8O,ORIFN,1),^OR(100,"AF",+X8O,ORIFN,1),^OR(100,"AS",$P(X,"^",2),9999999-(+X8O),ORIFN,1)
...... I $P(X8O,"^",3) K ^OR(100,"EPRACDT",$P(X8O,"^",3),+X8O,ORIFN,1) ; RBD OR*3.0*453 Clean up new EPRACDT index also
...... I $P(X8O,"^",16)=+X8O K ^OR(100,"AR",$P(X,"^",2),9999999-(+X8O),ORIFN,1) S ^OR(100,"AR",$P(X,"^",2),9999999-LRENT,ORIFN,1)="",$P(^OR(100,ORIFN,8,1,0),"^",16)=LRENT
...... S $P(^OR(100,ORIFN,8,1,0),"^")=LRENT,^OR(100,"AF",LRENT,ORIFN,1)=""
...... S ^OR(100,"EPRACDT",$P(X8O,"^",3),LRENT,ORIFN,1)="" ; RBD OR*3.0*453 Reset EPRACDT index also
...... D S1^ORDD100(ORIFN,1,"",LRENT),SET^ORDD100(ORIFN,1),ACT1^ORDD100A(ORIFN,1)
Q
WRT(LRODT,LRSN,LRTST,TEXT,FIXED) ;Write error message
Q:$E(IOST,1,2)="P-"
W "."
;W !,$G(LRODT)_";"_$G(LRSN)_";"_$G(LRTST)_"=>"_TEXT_$S($G(FIXED):" FIXED",1:"")
Q
STATUS(I,J,K,Z,UPDATE) ;Check status of exploded panels
Q:'$D(^LRO(69,I,1,J,2,K,0)) S:'$D(Z) Z=^(0)
N F,X,X7,Z7,ORSTS,ORIFN
K ^TMP("ORCHKLRO",$J)
S F=1,Z7=$P(Z,"^",7)
I $P(Z,"^",8) D
. N TST,T,N
. S T=0 F S T=$O(^LAB(60,+Z,2,T)) Q:'T S TST(+^(T,0))=""
. S T=0 F S T=$O(TST(T)) Q:'T I $D(^LRO(69,I,1,J,2,"B",T)) S N=$O(^(T,0)) I $D(^LRO(69,I,1,J,2,N,0)) S X=^(0),X7=$P(X,"^",7) D
.. I X7,Z7,X7'=Z7,'$D(^TMP("ORCHKLRO",$J,Z7)) D Q
... N X1,X2
... S X1=$P($G(^OR(100,X7,3)),"^",3),X2=$P($G(^OR(100,Z7,3)),"^",3)
... Q:X1="" Q:X2="" Q:X1=X2 Q:X2=14 Q:X2=1 Q:X2=2 Q:X2=13
... I F S STCNT=STCNT+1,TOTCNT=TOTCNT+1
... S F=0
... I $G(UPDATE) D
.... I $S(+$G(^DD(100,0,"VR")):+^("VR"),1:0)<3 S ORSTS=X1,ORIFN=Z7 D ST^ORX
.... I $S(+$G(^DD(100,0,"VR")):+^("VR"),1:0)'<3 D STATUS^ORCSAVE2(Z7,X1)
.... S ^TMP("ORCHKLRO",$J,Z7)=""
K ^TMP("ORCHKLRO",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORELR5 5391 printed Sep 23, 2025@20:06:49 Page 2
ORELR5 ;slc/dcm - Check 69 against 100 ;Jul 08, 2019@12:17:53
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**42,453**;Dec 17, 1997;Build 47
+2 ;
+3 ;
+4 ; Reference to ^LAB(60 supported by ICR #2387
+5 ; Reference to ^LR( is supported by ICR #1948
+6 ;
EN ;Check file 69 against 100 for inconsistencies
+1 ;
+2 NEW %,UPD,ZTSAVE
+3 WRITE !!,"This routine will go through the LAB ORDER ENTRY file (69)"
+4 WRITE !,"and check for inconsistencies between Lab files and CPRS files."
+5 WRITE !,"This process could take several hours to complete."
+6 WRITE !,"Are you sure you want to continue"
+7 SET %=2
DO YN^DICN
+8 IF %=0
WRITE !!,"Answer YES to continue"
GOTO EN
+9 if %'=1
QUIT
UPD WRITE !!,"You have the option of just checking the database, or updating the database."
+1 WRITE !,"Do you want to update the database now"
+2 SET %=2
DO YN^DICN
+3 IF %=0
WRITE !!,"Select YES to update the database"
GOTO UPD
+4 if %=-1
QUIT
+5 SET UPD=$SELECT(%=1:1,1:0)
+6 SET ZTSAVE("UPD")=""
+7 DO QUE^ORUTL1("DEQUE^ORELR5","Check from 69 to 100",.ZTSAVE)
+8 QUIT
DEQUE ;Queued entry point
+1 USE IO
+2 WRITE !,"Inconsistency report between LAB (69) and OE/RR (100) files..."
+3 WRITE !,"Date/time Started: "_$$DATETIME^ORU($$NOW^XLFDT())
+4 WRITE !,"Now looking for data..."
+5 NEW LRDFN,ORAFIX,STCNT,TOTCNT,DCNT,PTCNT,F100CNT,ENTCNT
+6 SET (ORAFIX,STCNT,TOTCNT,DCNT,PTCNT,F100CNT,ENTCNT,LRDFN)=0
+7 FOR
SET LRDFN=$ORDER(^LRO(69,"D",LRDFN))
if LRDFN<1
QUIT
DO LOOP(LRDFN,UPD)
+8 if IOSL-$Y<10
WRITE @IOF
+9 WRITE !!,"Total Inconsistencies Found"
+10 WRITE !,"Date/time Completed: "_$$DATETIME^ORU($$NOW^XLFDT())
+11 WRITE !,"-------------------------------------------------"
+12 IF DCNT
WRITE !,"Bad entry in ^LRO(69,""D""",?40,$JUSTIFY(DCNT,7)
+13 IF F100CNT
WRITE !,"Broken pointer to 100",?40,$JUSTIFY(F100CNT,7)
+14 IF ENTCNT
WRITE !,"Inconsistent entry dates",?40,$JUSTIFY(ENTCNT,7)
+15 IF PTCNT
WRITE !,"Patient mismatch"_$SELECT(UPD:" (not fixed)",1:""),?40,$JUSTIFY(PTCNT,7)
+16 IF STCNT
WRITE !,"Status update on panel test",?40,$JUSTIFY(STCNT,7)
+17 WRITE !,"================================================="
+18 WRITE !,"Total: ",?40,$JUSTIFY(TOTCNT,7)
+19 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+20 QUIT
LOOP(LRDFN,ORAFIX) ;Loop on patient
+1 IF '$DATA(^LR(LRDFN,0))
DO WRT(,,,"No entry in ^LR("_LRDFN,ORAFIX)
SET DCNT=DCNT+1
SET TOTCNT=TOTCNT+1
if ORAFIX
KILL ^LRO(69,"D",LRDFN)
QUIT
+2 ;Not in patient file.
if $PIECE(^LR(LRDFN,0),"^",2)'=2
QUIT
+3 SET DFN=$PIECE(^LR(LRDFN,0),"^",3)
+4 if '$DATA(^LRO(69,"D",$GET(LRDFN)))
QUIT
+5 NEW LRODT,LRSN,LRTI,LRTST,LRENT,X,X0,X3,ORX1,ORX2,ORIFN,X8O
+6 SET LRODT=0
FOR
SET LRODT=$ORDER(^LRO(69,"D",LRDFN,LRODT))
if 'LRODT
QUIT
SET LRSN=0
FOR
SET LRSN=$ORDER(^LRO(69,"D",LRDFN,LRODT,LRSN))
if 'LRSN
QUIT
Begin DoDot:1
+7 IF '$DATA(^LRO(69,LRODT,1,LRSN,0))
DO WRT(LRODT,LRSN,,"D X-ref invalid",ORAFIX)
SET DCNT=DCNT+1
SET TOTCNT=TOTCNT+1
if ORAFIX
KILL ^LRO(69,"D",LRDFN,LRODT,LRSN)
QUIT
+8 SET X=^LRO(69,LRODT,1,LRSN,0)
SET LRENT=$PIECE(X,"^",5)
+9 SET LRTI=0
FOR
SET LRTI=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTI))
if LRTI<1
QUIT
SET X0=^(LRTI,0)
Begin DoDot:2
+10 SET LRTST=+X0
SET ORIFN=$PIECE(X0,"^",7)
+11 IF ORIFN
Begin DoDot:3
+12 ;P=purged
IF '$DATA(^OR(100,ORIFN))
DO WRT(LRODT,LRSN,LRTI,"Broken pointer to 100:"_ORIFN,ORAFIX)
SET F100CNT=F100CNT+1
SET TOTCNT=TOTCNT+1
if ORAFIX
SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRTI,0),"^",7)="P"
QUIT
+13 SET X=^OR(100,ORIFN,0)
SET X3=$GET(^(3))
+14 IF DFN'=+$PIECE(X,"^",2)
DO WRT(LRODT,LRSN,LRTI,"Patient mismatch:"_ORIFN_"<"_$PIECE(X3,"^",3)_">")
SET PTCNT=PTCNT+1
SET TOTCNT=TOTCNT+1
QUIT
+15 DO STATUS(LRODT,LRSN,LRTI,X0,ORAFIX)
+16 IF LRENT
IF $PIECE(X,"^",7)>$SELECT($PIECE($PIECE(X,"^",8),".",2):$PIECE(X,"^",8),1:$PIECE(X,"^",8)_".2359")
Begin DoDot:4
+17 SET ORX1=$$FMADD^XLFDT($PIECE(X,"^",7),,,30)
SET ORX2=$$FMADD^XLFDT($PIECE(X,"^",7),,,-30)
+18 IF LRENT<ORX2!(LRENT>ORX1)
SET ENTCNT=ENTCNT+1
SET TOTCNT=TOTCNT+1
IF ORAFIX
Begin DoDot:5
+19 SET $PIECE(^OR(100,ORIFN,0),"^",7)=LRENT
+20 IF $PIECE(X,"^",7)=+$GET(^OR(100,ORIFN,8,1,0))
SET X8O=$GET(^(0))
Begin DoDot:6
+21 NEW DI,DIC,DIE,DA,DR,D0,DQ,DISYS
+22 IF $PIECE(X,"^",11)
KILL ^OR(100,"ACT",$PIECE(X,"^",2),9999999-+X8O,$PIECE(X,"^",11),ORIFN,1)
+23 KILL ^OR(100,"AC",$PIECE(X,"^",2),9999999-+X8O,ORIFN,1),^OR(100,"AF",+X8O,ORIFN,1),^OR(100,"AS",$PIECE(X,"^",2),9999999-(+X8O),ORIFN,1)
+24 ; RBD OR*3.0*453 Clean up new EPRACDT index also
IF $PIECE(X8O,"^",3)
KILL ^OR(100,"EPRACDT",$PIECE(X8O,"^",3),+X8O,ORIFN,1)
+25 IF $PIECE(X8O,"^",16)=+X8O
KILL ^OR(100,"AR",$PIECE(X,"^",2),9999999-(+X8O),ORIFN,1)
SET ^OR(100,"AR",$PIECE(X,"^",2),9999999-LRENT,ORIFN,1)=""
SET $PIECE(^OR(100,ORIFN,8,1,0),"^",16)=LRENT
+26 SET $PIECE(^OR(100,ORIFN,8,1,0),"^")=LRENT
SET ^OR(100,"AF",LRENT,ORIFN,1)=""
+27 ; RBD OR*3.0*453 Reset EPRACDT index also
SET ^OR(100,"EPRACDT",$PIECE(X8O,"^",3),LRENT,ORIFN,1)=""
+28 DO S1^ORDD100(ORIFN,1,"",LRENT)
DO SET^ORDD100(ORIFN,1)
DO ACT1^ORDD100A(ORIFN,1)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+29 QUIT
WRT(LRODT,LRSN,LRTST,TEXT,FIXED) ;Write error message
+1 if $EXTRACT(IOST,1,2)="P-"
QUIT
+2 WRITE "."
+3 ;W !,$G(LRODT)_";"_$G(LRSN)_";"_$G(LRTST)_"=>"_TEXT_$S($G(FIXED):" FIXED",1:"")
+4 QUIT
STATUS(I,J,K,Z,UPDATE) ;Check status of exploded panels
+1 if '$DATA(^LRO(69,I,1,J,2,K,0))
QUIT
if '$DATA(Z)
SET Z=^(0)
+2 NEW F,X,X7,Z7,ORSTS,ORIFN
+3 KILL ^TMP("ORCHKLRO",$JOB)
+4 SET F=1
SET Z7=$PIECE(Z,"^",7)
+5 IF $PIECE(Z,"^",8)
Begin DoDot:1
+6 NEW TST,T,N
+7 SET T=0
FOR
SET T=$ORDER(^LAB(60,+Z,2,T))
if 'T
QUIT
SET TST(+^(T,0))=""
+8 SET T=0
FOR
SET T=$ORDER(TST(T))
if 'T
QUIT
IF $DATA(^LRO(69,I,1,J,2,"B",T))
SET N=$ORDER(^(T,0))
IF $DATA(^LRO(69,I,1,J,2,N,0))
SET X=^(0)
SET X7=$PIECE(X,"^",7)
Begin DoDot:2
+9 IF X7
IF Z7
IF X7'=Z7
IF '$DATA(^TMP("ORCHKLRO",$JOB,Z7))
Begin DoDot:3
+10 NEW X1,X2
+11 SET X1=$PIECE($GET(^OR(100,X7,3)),"^",3)
SET X2=$PIECE($GET(^OR(100,Z7,3)),"^",3)
+12 if X1=""
QUIT
if X2=""
QUIT
if X1=X2
QUIT
if X2=14
QUIT
if X2=1
QUIT
if X2=2
QUIT
if X2=13
QUIT
+13 IF F
SET STCNT=STCNT+1
SET TOTCNT=TOTCNT+1
+14 SET F=0
+15 IF $GET(UPDATE)
Begin DoDot:4
+16 IF $SELECT(+$GET(^DD(100,0,"VR")):+^("VR"),1:0)<3
SET ORSTS=X1
SET ORIFN=Z7
DO ST^ORX
+17 IF $SELECT(+$GET(^DD(100,0,"VR")):+^("VR"),1:0)'<3
DO STATUS^ORCSAVE2(Z7,X1)
+18 SET ^TMP("ORCHKLRO",$JOB,Z7)=""
End DoDot:4
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+19 KILL ^TMP("ORCHKLRO",$JOB)
+20 QUIT
