XDRDCOMP ;SF-IRMFO/IHS/OHPRD/JCM - COMPARE TWO PATIENTS VIA DUP CHECKER ;8/28/08 17:58
;;7.3;TOOLKIT;**23,113**;Apr 25, 1995;Build 5
;;Per VHA Directive 2004-038, this routine should not be modified.
;;
; This routine will compare two records (patients), and will result with
; a score (0 - 100%) as to how they match up. You can not compare the
; same record.
;
; *** NOTE *** As of patch XT*7.3*113, this routine is no longer
; available for use on the PATIENT file. *****
;
START ;
S XDRQFLG=0
; XT*7.3*113 - Input param to FILE^XDRDPICK makes PATIENT file unselectable.
S XDRFL=$$FILE^XDRDPICK(1) Q:XDRFL'>0
G:XDRQFLG END
S XDRGL=^DIC(XDRFL,0,"GL")
S XDRDTYPE="BASIC" ; ADDED 4/11/96 JLI
D LKUP G:XDRQFLG END
S %ZIS="Q" D ^%ZIS G:POP END
S (IOP,XDRDCOMP("DEVICE"))=ION_";"_IOM_";"_IOSL
I $D(IO("Q")) D G:XDRQFLG END
.S ZTRTN="DQ^XDRDCOMP",ZTIO=ION,ZTDESC=$P(^DIC(XDRFL,0),U)_" COMPARISON LIST"
.F %="XDRCD","XDRCD2","XDRFL","XDRDTYPE","XDRGL","XDRD(","XDRDCOMP(" S ZTSAVE(%)=""
.D ^%ZTLOAD W:$D(ZTSK) !,"Queued as task "_ZTSK,!
.S XDRQFLG=1
DQ ; Entry Point for Taskman
U IO W @IOF
D ^XDRDSCOR
D ^XDRDUP ;S XDRD("NOADD")="" D ^XDRDUP
D DITC
D SCORE
D ^%ZISC
END D EOJ
Q
;
LKUP ;Look up both reocord.
S DIC=XDRGL,DIC(0)="QEAM"
S DIC("A")="COMPARE "_$P(^DIC(XDRFL,0),U)_": "
D ^DIC ;W !,"X: ",X,"Y: ",Y
I $D(DIRUT)!(Y=-1) K DIC,DA S XDRQFLG=1 G LKUPX
S XDRCD=+Y S DIT(1)=+Y
LKUP2 S DIC("A")=" WITH "_$P(^DIC(XDRFL,0),U)_": "
D ^DIC K DIC,DA
G:$D(DIRUT)!(Y=-1) LKUP
S XDRCD2=+Y S DIT(2)=+Y
I XDRCD=XDRCD2 W *7,!!," CAN NOT COMPARE SAME PATIENT!! ",!! G LKUP
LKUPX Q
;
DITC ;
D SHOW^XDRDSHOW(XDRFL,XDRCD,XDRCD2)
;S DFF=XDRFL,DIC=XDRGL,DIT(1)=XDRCD,DIT(2)=XDRCD2,DDIF=2
;S IOP=XDRDCOMP("DEVICE")
;D EN^DITC K DIC,DFF,DIT,IOP,DDIF
Q
SCORE ;
S:XDRDSCOR("MAX")>0 XDRD("DUPSCORE%")=XDRD("DUPSCORE")/XDRDSCOR("MAX")
S:XDRDSCOR("MAX")=0 XDRD("DUPSCORE%")=0
S XDRD("DUPSCORE%")=$J(XDRD("DUPSCORE%"),1,2)
S XDRD("DUPSCORE%")=$S(XDRD("DUPSCORE%")<0:0,XDRD("DUPSCORE%")<1:$E(XDRD("DUPSCORE%"),3,4),1:100)
;S IOP=XDRDCOMP("DEVICE") D ^%ZIS U IO
W !! F I=0:0 S I=$O(XDRDUP("TEST SCORE",I)) Q:I'>0 I +XDRDUP("TEST SCORE",I)'=0 S J=XDRDTEST(I) W !,$P(J,U),?25,"VALUE = ",$J(XDRDUP("TEST SCORE",I),3,0)," MAX POSSIBLE = ",$J($P(J,U,6),3,0)
W !!,?40,"DUPLICATE THRESHOLD % ",XDRDSCOR("PDT%")
W !,?40,"DUPLICATE SCORE % ",$G(XDRD("DUPSCORE%")),!
K %,XDRDCNT
I '$D(ZTQUEUED),$E(IOST,1,2)'="P-" S DIR(0)="E" D ^DIR K DIR S:X=U XDRQFLG=1
;D ^%ZISC
Q
QUEUE ;** Remove after testing **
I '$D(IOP),'$D(XDRDCOMP("DEVICE")) S %ZIS="QMN" D ^%ZIS
I POP S XDRQFLG=1 G QUEUEX
I $D(IO("Q")),IO=IO(0) W !!,"Sorry, you can't queue to your screen or a slave device.",! K IO("Q") G QUEUE
S (IOP,XDRDCOMP("DEVICE"))=ION_";"_IOM_";"_IOSL K %ZIS
I '$D(IO("Q")) G QUEUEX
S ZTRTN="DQ^XDRDCOMP",ZTIO=ION,ZTDESC=$P(^DIC(XDRFL,0),U)_" COMPARISON LIST"
F %="XDRCD","XDRCD2","XDRFL","XDRDTYPE","XDRGL","XDRD(","XDRDCOMP(" S ZTSAVE(%)=""
K %
;S XYY=AAA ***************************
D ^%ZTLOAD W:$D(ZTSK) !,"Queued as task "_ZTSK,!
S XDRQFLG=1
K ZTSK
QUEUEX Q
;
EOJ ;
K XDRDCOMP,XDRDUP,XDRD,XDRFL,XDRGL,XDRQFLG,XDRDTEST,XDRDSCOR
K XDRCD,XDRCD2,%IS,POP,IO("C"),IOP,IO("Q"),X,Y,ZTSK
S:$D(ZTQUEUED) ZTREQ="@"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRDCOMP 3338 printed Oct 16, 2024@18:39:35 Page 2
XDRDCOMP ;SF-IRMFO/IHS/OHPRD/JCM - COMPARE TWO PATIENTS VIA DUP CHECKER ;8/28/08 17:58
+1 ;;7.3;TOOLKIT;**23,113**;Apr 25, 1995;Build 5
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;;
+4 ; This routine will compare two records (patients), and will result with
+5 ; a score (0 - 100%) as to how they match up. You can not compare the
+6 ; same record.
+7 ;
+8 ; *** NOTE *** As of patch XT*7.3*113, this routine is no longer
+9 ; available for use on the PATIENT file. *****
+10 ;
START ;
+1 SET XDRQFLG=0
+2 ; XT*7.3*113 - Input param to FILE^XDRDPICK makes PATIENT file unselectable.
+3 SET XDRFL=$$FILE^XDRDPICK(1)
if XDRFL'>0
QUIT
+4 if XDRQFLG
GOTO END
+5 SET XDRGL=^DIC(XDRFL,0,"GL")
+6 ; ADDED 4/11/96 JLI
SET XDRDTYPE="BASIC"
+7 DO LKUP
if XDRQFLG
GOTO END
+8 SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO END
+9 SET (IOP,XDRDCOMP("DEVICE"))=ION_";"_IOM_";"_IOSL
+10 IF $DATA(IO("Q"))
Begin DoDot:1
+11 SET ZTRTN="DQ^XDRDCOMP"
SET ZTIO=ION
SET ZTDESC=$PIECE(^DIC(XDRFL,0),U)_" COMPARISON LIST"
+12 FOR %="XDRCD","XDRCD2","XDRFL","XDRDTYPE","XDRGL","XDRD(","XDRDCOMP("
SET ZTSAVE(%)=""
+13 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Queued as task "_ZTSK,!
+14 SET XDRQFLG=1
End DoDot:1
if XDRQFLG
GOTO END
DQ ; Entry Point for Taskman
+1 USE IO
WRITE @IOF
+2 DO ^XDRDSCOR
+3 ;S XDRD("NOADD")="" D ^XDRDUP
DO ^XDRDUP
+4 DO DITC
+5 DO SCORE
+6 DO ^%ZISC
END DO EOJ
+1 QUIT
+2 ;
LKUP ;Look up both reocord.
+1 SET DIC=XDRGL
SET DIC(0)="QEAM"
+2 SET DIC("A")="COMPARE "_$PIECE(^DIC(XDRFL,0),U)_": "
+3 ;W !,"X: ",X,"Y: ",Y
DO ^DIC
+4 IF $DATA(DIRUT)!(Y=-1)
KILL DIC,DA
SET XDRQFLG=1
GOTO LKUPX
+5 SET XDRCD=+Y
SET DIT(1)=+Y
LKUP2 SET DIC("A")=" WITH "_$PIECE(^DIC(XDRFL,0),U)_": "
+1 DO ^DIC
KILL DIC,DA
+2 if $DATA(DIRUT)!(Y=-1)
GOTO LKUP
+3 SET XDRCD2=+Y
SET DIT(2)=+Y
+4 IF XDRCD=XDRCD2
WRITE *7,!!," CAN NOT COMPARE SAME PATIENT!! ",!!
GOTO LKUP
LKUPX QUIT
+1 ;
DITC ;
+1 DO SHOW^XDRDSHOW(XDRFL,XDRCD,XDRCD2)
+2 ;S DFF=XDRFL,DIC=XDRGL,DIT(1)=XDRCD,DIT(2)=XDRCD2,DDIF=2
+3 ;S IOP=XDRDCOMP("DEVICE")
+4 ;D EN^DITC K DIC,DFF,DIT,IOP,DDIF
+5 QUIT
SCORE ;
+1 if XDRDSCOR("MAX")>0
SET XDRD("DUPSCORE%")=XDRD("DUPSCORE")/XDRDSCOR("MAX")
+2 if XDRDSCOR("MAX")=0
SET XDRD("DUPSCORE%")=0
+3 SET XDRD("DUPSCORE%")=$JUSTIFY(XDRD("DUPSCORE%"),1,2)
+4 SET XDRD("DUPSCORE%")=$SELECT(XDRD("DUPSCORE%")<0:0,XDRD("DUPSCORE%")<1:$EXTRACT(XDRD("DUPSCORE%"),3,4),1:100)
+5 ;S IOP=XDRDCOMP("DEVICE") D ^%ZIS U IO
+6 WRITE !!
FOR I=0:0
SET I=$ORDER(XDRDUP("TEST SCORE",I))
if I'>0
QUIT
IF +XDRDUP("TEST SCORE",I)'=0
SET J=XDRDTEST(I)
WRITE !,$PIECE(J,U),?25,"VALUE = ",$JUSTIFY(XDRDUP("TEST SCORE",I),3,0)," MAX POSSIBLE = ",$JUSTIFY($PIECE(J,U,6),3,0)
+7 WRITE !!,?40,"DUPLICATE THRESHOLD % ",XDRDSCOR("PDT%")
+8 WRITE !,?40,"DUPLICATE SCORE % ",$GET(XDRD("DUPSCORE%")),!
+9 KILL %,XDRDCNT
+10 IF '$DATA(ZTQUEUED)
IF $EXTRACT(IOST,1,2)'="P-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
if X=U
SET XDRQFLG=1
+11 ;D ^%ZISC
+12 QUIT
QUEUE ;** Remove after testing **
+1 IF '$DATA(IOP)
IF '$DATA(XDRDCOMP("DEVICE"))
SET %ZIS="QMN"
DO ^%ZIS
+2 IF POP
SET XDRQFLG=1
GOTO QUEUEX
+3 IF $DATA(IO("Q"))
IF IO=IO(0)
WRITE !!,"Sorry, you can't queue to your screen or a slave device.",!
KILL IO("Q")
GOTO QUEUE
+4 SET (IOP,XDRDCOMP("DEVICE"))=ION_";"_IOM_";"_IOSL
KILL %ZIS
+5 IF '$DATA(IO("Q"))
GOTO QUEUEX
+6 SET ZTRTN="DQ^XDRDCOMP"
SET ZTIO=ION
SET ZTDESC=$PIECE(^DIC(XDRFL,0),U)_" COMPARISON LIST"
+7 FOR %="XDRCD","XDRCD2","XDRFL","XDRDTYPE","XDRGL","XDRD(","XDRDCOMP("
SET ZTSAVE(%)=""
+8 KILL %
+9 ;S XYY=AAA ***************************
+10 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Queued as task "_ZTSK,!
+11 SET XDRQFLG=1
+12 KILL ZTSK
QUEUEX QUIT
+1 ;
EOJ ;
+1 KILL XDRDCOMP,XDRDUP,XDRD,XDRFL,XDRGL,XDRQFLG,XDRDTEST,XDRDSCOR
+2 KILL XDRCD,XDRCD2,%IS,POP,IO("C"),IOP,IO("Q"),X,Y,ZTSK
+3 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
