- 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 Jan 18, 2025@03:40:06 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