Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XDRDCOMP

XDRDCOMP.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;;
  1. ; This routine will compare two records (patients), and will result with
  1. ; a score (0 - 100%) as to how they match up. You can not compare the
  1. ; same record.
  1. ;
  1. ; *** NOTE *** As of patch XT*7.3*113, this routine is no longer
  1. ; available for use on the PATIENT file. *****
  1. ;
  1. START ;
  1. S XDRQFLG=0
  1. ; XT*7.3*113 - Input param to FILE^XDRDPICK makes PATIENT file unselectable.
  1. S XDRFL=$$FILE^XDRDPICK(1) Q:XDRFL'>0
  1. G:XDRQFLG END
  1. S XDRGL=^DIC(XDRFL,0,"GL")
  1. S XDRDTYPE="BASIC" ; ADDED 4/11/96 JLI
  1. D LKUP G:XDRQFLG END
  1. S %ZIS="Q" D ^%ZIS G:POP END
  1. S (IOP,XDRDCOMP("DEVICE"))=ION_";"_IOM_";"_IOSL
  1. I $D(IO("Q")) D G:XDRQFLG END
  1. .S ZTRTN="DQ^XDRDCOMP",ZTIO=ION,ZTDESC=$P(^DIC(XDRFL,0),U)_" COMPARISON LIST"
  1. .F %="XDRCD","XDRCD2","XDRFL","XDRDTYPE","XDRGL","XDRD(","XDRDCOMP(" S ZTSAVE(%)=""
  1. .D ^%ZTLOAD W:$D(ZTSK) !,"Queued as task "_ZTSK,!
  1. .S XDRQFLG=1
  1. DQ ; Entry Point for Taskman
  1. U IO W @IOF
  1. D ^XDRDSCOR
  1. D ^XDRDUP ;S XDRD("NOADD")="" D ^XDRDUP
  1. D DITC
  1. D SCORE
  1. D ^%ZISC
  1. END D EOJ
  1. Q
  1. ;
  1. LKUP ;Look up both reocord.
  1. S DIC=XDRGL,DIC(0)="QEAM"
  1. S DIC("A")="COMPARE "_$P(^DIC(XDRFL,0),U)_": "
  1. D ^DIC ;W !,"X: ",X,"Y: ",Y
  1. I $D(DIRUT)!(Y=-1) K DIC,DA S XDRQFLG=1 G LKUPX
  1. S XDRCD=+Y S DIT(1)=+Y
  1. LKUP2 S DIC("A")=" WITH "_$P(^DIC(XDRFL,0),U)_": "
  1. D ^DIC K DIC,DA
  1. G:$D(DIRUT)!(Y=-1) LKUP
  1. S XDRCD2=+Y S DIT(2)=+Y
  1. I XDRCD=XDRCD2 W *7,!!," CAN NOT COMPARE SAME PATIENT!! ",!! G LKUP
  1. LKUPX Q
  1. ;
  1. DITC ;
  1. D SHOW^XDRDSHOW(XDRFL,XDRCD,XDRCD2)
  1. ;S DFF=XDRFL,DIC=XDRGL,DIT(1)=XDRCD,DIT(2)=XDRCD2,DDIF=2
  1. ;S IOP=XDRDCOMP("DEVICE")
  1. ;D EN^DITC K DIC,DFF,DIT,IOP,DDIF
  1. Q
  1. SCORE ;
  1. S:XDRDSCOR("MAX")>0 XDRD("DUPSCORE%")=XDRD("DUPSCORE")/XDRDSCOR("MAX")
  1. S:XDRDSCOR("MAX")=0 XDRD("DUPSCORE%")=0
  1. S XDRD("DUPSCORE%")=$J(XDRD("DUPSCORE%"),1,2)
  1. S XDRD("DUPSCORE%")=$S(XDRD("DUPSCORE%")<0:0,XDRD("DUPSCORE%")<1:$E(XDRD("DUPSCORE%"),3,4),1:100)
  1. ;S IOP=XDRDCOMP("DEVICE") D ^%ZIS U IO
  1. 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)
  1. W !!,?40,"DUPLICATE THRESHOLD % ",XDRDSCOR("PDT%")
  1. W !,?40,"DUPLICATE SCORE % ",$G(XDRD("DUPSCORE%")),!
  1. K %,XDRDCNT
  1. I '$D(ZTQUEUED),$E(IOST,1,2)'="P-" S DIR(0)="E" D ^DIR K DIR S:X=U XDRQFLG=1
  1. ;D ^%ZISC
  1. Q
  1. QUEUE ;** Remove after testing **
  1. I '$D(IOP),'$D(XDRDCOMP("DEVICE")) S %ZIS="QMN" D ^%ZIS
  1. I POP S XDRQFLG=1 G QUEUEX
  1. 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
  1. S (IOP,XDRDCOMP("DEVICE"))=ION_";"_IOM_";"_IOSL K %ZIS
  1. I '$D(IO("Q")) G QUEUEX
  1. S ZTRTN="DQ^XDRDCOMP",ZTIO=ION,ZTDESC=$P(^DIC(XDRFL,0),U)_" COMPARISON LIST"
  1. F %="XDRCD","XDRCD2","XDRFL","XDRDTYPE","XDRGL","XDRD(","XDRDCOMP(" S ZTSAVE(%)=""
  1. K %
  1. ;S XYY=AAA ***************************
  1. D ^%ZTLOAD W:$D(ZTSK) !,"Queued as task "_ZTSK,!
  1. S XDRQFLG=1
  1. K ZTSK
  1. QUEUEX Q
  1. ;
  1. EOJ ;
  1. K XDRDCOMP,XDRDUP,XDRD,XDRFL,XDRGL,XDRQFLG,XDRDTEST,XDRDSCOR
  1. K XDRCD,XDRCD2,%IS,POP,IO("C"),IOP,IO("Q"),X,Y,ZTSK
  1. S:$D(ZTQUEUED) ZTREQ="@"
  1. Q