source: FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XDRDCOMP.m@ 1424

Last change on this file since 1424 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.9 KB
Line 
1XDRDCOMP ;SF-IRMFO/IHS/OHPRD/JCM - COMPARE TWO PATIENTS VIA DUP CHECKER ;12/1/97 16:34
2 ;;7.3;TOOLKIT;**23**;Apr 25, 1995
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 ;
8START ;
9 S XDRQFLG=0
10 S XDRFL=$$FILE^XDRDPICK() Q:XDRFL'>0
11 G:XDRQFLG END
12 S XDRGL=^DIC(XDRFL,0,"GL")
13 S XDRDTYPE="BASIC" ; ADDED 4/11/96 JLI
14 D LKUP G:XDRQFLG END
15 S %ZIS="Q" D ^%ZIS G:POP END
16 S (IOP,XDRDCOMP("DEVICE"))=ION_";"_IOM_";"_IOSL
17 I $D(IO("Q")) D G:XDRQFLG END
18 .S ZTRTN="DQ^XDRDCOMP",ZTIO=ION,ZTDESC=$P(^DIC(XDRFL,0),U)_" COMPARISON LIST"
19 .F %="XDRCD","XDRCD2","XDRFL","XDRDTYPE","XDRGL","XDRD(","XDRDCOMP(" S ZTSAVE(%)=""
20 .D ^%ZTLOAD W:$D(ZTSK) !,"Queued as task "_ZTSK,!
21 .S XDRQFLG=1
22DQ ; Entry Point for Taskman
23 U IO W @IOF
24 D ^XDRDSCOR
25 D ^XDRDUP ;S XDRD("NOADD")="" D ^XDRDUP
26 D DITC
27 D SCORE
28 D ^%ZISC
29END D EOJ
30 Q
31 ;
32LKUP ;Look up both reocord.
33 S DIC=XDRGL,DIC(0)="QEAM"
34 S DIC("A")="COMPARE "_$P(^DIC(XDRFL,0),U)_": "
35 D ^DIC ;W !,"X: ",X,"Y: ",Y
36 I $D(DIRUT)!(Y=-1) K DIC,DA S XDRQFLG=1 G LKUPX
37 S XDRCD=+Y S DIT(1)=+Y
38LKUP2 S DIC("A")=" WITH "_$P(^DIC(XDRFL,0),U)_": "
39 D ^DIC K DIC,DA
40 G:$D(DIRUT)!(Y=-1) LKUP
41 S XDRCD2=+Y S DIT(2)=+Y
42 I XDRCD=XDRCD2 W *7,!!," CAN NOT COMPARE SAME PATIENT!! ",!! G LKUP
43LKUPX Q
44 ;
45DITC ;
46 D SHOW^XDRDSHOW(XDRFL,XDRCD,XDRCD2)
47 ;S DFF=XDRFL,DIC=XDRGL,DIT(1)=XDRCD,DIT(2)=XDRCD2,DDIF=2
48 ;S IOP=XDRDCOMP("DEVICE")
49 ;D EN^DITC K DIC,DFF,DIT,IOP,DDIF
50 Q
51SCORE ;
52 S:XDRDSCOR("MAX")>0 XDRD("DUPSCORE%")=XDRD("DUPSCORE")/XDRDSCOR("MAX")
53 S:XDRDSCOR("MAX")=0 XDRD("DUPSCORE%")=0
54 S XDRD("DUPSCORE%")=$J(XDRD("DUPSCORE%"),1,2)
55 S XDRD("DUPSCORE%")=$S(XDRD("DUPSCORE%")<0:0,XDRD("DUPSCORE%")<1:$E(XDRD("DUPSCORE%"),3,4),1:100)
56 ;S IOP=XDRDCOMP("DEVICE") D ^%ZIS U IO
57 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)
58 W !!,?40,"DUPLICATE THRESHOLD % ",XDRDSCOR("PDT%")
59 W !,?40,"DUPLICATE SCORE % ",$G(XDRD("DUPSCORE%")),!
60 K %,XDRDCNT
61 I '$D(ZTQUEUED),$E(IOST,1,2)'="P-" S DIR(0)="E" D ^DIR K DIR S:X=U XDRQFLG=1
62 ;D ^%ZISC
63 Q
64QUEUE ;** Remove after testing **
65 I '$D(IOP),'$D(XDRDCOMP("DEVICE")) S %ZIS="QMN" D ^%ZIS
66 I POP S XDRQFLG=1 G QUEUEX
67 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
68 S (IOP,XDRDCOMP("DEVICE"))=ION_";"_IOM_";"_IOSL K %ZIS
69 I '$D(IO("Q")) G QUEUEX
70 S ZTRTN="DQ^XDRDCOMP",ZTIO=ION,ZTDESC=$P(^DIC(XDRFL,0),U)_" COMPARISON LIST"
71 F %="XDRCD","XDRCD2","XDRFL","XDRDTYPE","XDRGL","XDRD(","XDRDCOMP(" S ZTSAVE(%)=""
72 K %
73 ;S XYY=AAA ***************************
74 D ^%ZTLOAD W:$D(ZTSK) !,"Queued as task "_ZTSK,!
75 S XDRQFLG=1
76 K ZTSK
77QUEUEX Q
78 ;
79EOJ ;
80 K XDRDCOMP,XDRDUP,XDRD,XDRFL,XDRGL,XDRQFLG,XDRDTEST,XDRDSCOR
81 K XDRCD,XDRCD2,%IS,POP,IO("C"),IOP,IO("Q"),X,Y,ZTSK
82 S:$D(ZTQUEUED) ZTREQ="@"
83 Q
Note: See TracBrowser for help on using the repository browser.