- ORELR5 ; slc/dcm - Check 69 against 100 ;
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**42**;Dec 17, 1997
- 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,"^",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)=""
- ...... 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
- ORELR5 ; slc/dcm - Check 69 against 100 ;
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**42**;Dec 17, 1997
- EN ;Check file 69 against 100 for inconsistencies
- +1 NEW %,UPD,ZTSAVE
- +2 WRITE !!,"This routine will go through the LAB ORDER ENTRY file (69)"
- +3 WRITE !,"and check for inconsistencies between Lab files and CPRS files."
- +4 WRITE !,"This process could take several hours to complete."
- +5 WRITE !,"Are you sure you want to continue"
- +6 SET %=2
- DO YN^DICN
- +7 IF %=0
- WRITE !!,"Answer YES to continue"
- GOTO EN
- +8 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 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
- +25 SET $PIECE(^OR(100,ORIFN,8,1,0),"^")=LRENT
- SET ^OR(100,"AF",LRENT,ORIFN,1)=""
- +26 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
- +27 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
