source: WorldVistAEHR/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XDRDUP.m@ 1297

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

initial load of WorldVistAEHR

File size: 2.6 KB
RevLine 
[613]1XDRDUP ;SF-IRMFO/IHS/OHPRD/JCM - COMPARES TWO RECORDS TO SEE IF DUP OF EACH OTHER; [ 08/13/92 09:50 AM ] ;04/30/2001 10:35
2 ;;7.3;TOOLKIT;**23,46,49,56**;Apr 25, 1995
3 ;;
4START ;
5 K % S XDRQFLG=0
6 I '$D(XDRCD)!('$D(XDRCD2)) S XDRERR=7 D ^XDREMSG G END
7 I '$D(XDRDSCOR) D ^XDRDSCOR G:XDRQFLG END
8 F %="MAX","PDT" S XDRDSCOR(%)=0
9 S:$D(XDRDSCOR("VDT%")) XDRDSCOR("VDT")=0
10 D VALUE I $D(XDRCD2)'>1 Q
11 ; sites are requesting to merge test patients, REMing next line
12 ;I XDRFL=2,$E(XDRCD2(2,XDRCD2,.09,"I"),1,5)="00000" Q
13 D MAIN
14END D EOJ
15 Q
16 ;
17MAIN ;
18 F XDRDUPFL=0:0 S XDRDUPFL=$O(XDRDSCOR("DR",XDRDUPFL)) Q:'XDRDUPFL D DIQ1
19 K XDRDUPFL
20 I $D(XDRCD2)'>0 S ^XTMP("XDRERR",2,XDRDTYPE,"NO DATA",XDRCD2)="" Q
21 S XDRD("DUPSCORE")=0
22 F XDRDTO=0:0 S XDRDTO=$O(XDRDTEST(XDRDTO)) Q:'XDRDTO!(XDRQFLG) D TEST
23 K XDRDTO F %=0:0 S %=$O(XDRCD2(%)) Q:'% K XDRCD2(%)
24 K %
25 S XDRDSCOR("PDT")="."_XDRDSCOR("PDT%")*XDRDSCOR("MAX")
26 S:$D(XDRDSCOR("VDT%")) XDRDSCOR("VDT")="."_XDRDSCOR("VDT%")*XDRDSCOR("MAX")
27 I XDRDSCOR("MAX")>0 D
28 . N J1,J2
29 . S J1=+$J(XDRD("DUPSCORE")/XDRDSCOR("MAX"),1,2)
30 . S (^(J1),J2)=$G(^TMP("XDRDUPSC",XDRFL,XDRDTYPE,J1))+1
31 . I J1>.6 S ^TMP("XDRDUPS1",XDRFL,XDRDTYPE,J1,J2)=XDRCD_U_XDRCD2
32 I '$D(XDRD("NOADD")),XDRD("DUPSCORE")'<XDRDSCOR("PDT"),'$D(XDRDCOMP) D ^XDRDADD
33MAINX Q
34 ;
35DIQ1 ;
36 S DIC=XDRDUPFL,DIQ(0)="I",DR=XDRDSCOR("DR",XDRDUPFL)
37 I '$D(XDRCD(XDRDUPFL)) S DA=XDRCD,DIQ="XDRCD" D EN^DIQ1 K DA,D0
38 S DA=XDRCD2,DIQ="XDRCD2" D EN^DIQ1 K DIC,DR,DIQ,DA,D0
39 Q
40 ;
41TEST ;
42 S XDRD("TEST ROUTINE")=$S($P($P(XDRDTEST(XDRDTO),U,3),"-",2)]"":$P($P(XDRDTEST(XDRDTO),U,3),"-")_"^"_$P($P(XDRDTEST(XDRDTO),U,3),"-",2),1:U_$P(XDRDTEST(XDRDTO),U,3))
43 S X=$P(XDRD("TEST ROUTINE"),U,2) X ^%ZOSF("TEST") K X I '$T S XDRERR=8 D ^XDREMSG G TESTX
44 S XDRD("TEST SCORE")=0
45 D @XDRD("TEST ROUTINE")
46 S XDRDUP("TEST SCORE",XDRDTO)=XDRD("TEST SCORE")
47 S XDRD("DUPSCORE")=XDRD("DUPSCORE")+(XDRD("TEST SCORE"))
48 S:+XDRD("TEST SCORE")'=0 XDRDSCOR("MAX")=XDRDSCOR("MAX")+($P(XDRDTEST(XDRDTO),U,6))
49TESTX K XDRD("TEST ROUTINE")
50 Q
51 ;
52EN ; EP - Called by XDRDADJ,XDRDPDTI
53 ;
54 N XDRDTYPE
55 S XDRDTYPE="BASIC"
56 K XDRCD,XDRCD2
57 S XDRCD=+$P(^VA(15,XDRDPDA,0),U)
58 S XDRCD2=+$P(^VA(15,XDRDPDA,0),U,2)
59 S XDRFL=$O(^VA(15.1,"AGL",$P($P(^VA(15,XDRDPDA,0),U),";",2),0))
60 I 'XDRFL S XDRERR=6 D ^XDREMSG G ENX
61 S:XDRFL XDRD(0)=^VA(15.1,XDRFL,0)
62 D START
63ENX Q
64 ;
65EOJ ;
66 I $D(XDRDPDA),'$D(XDRDPDTI) K XDRFL,XDRDSCOR,XDRDTEST,XDRD,XDRQFLG,XDRCD,XDRCD2
67 Q
68VALUE ;
69 S DA=XDRCD2 K XDRCD2 S XDRCD2=DA
70 F XDRI=0:0 S XDRI=$O(XDRDSCOR("DR",XDRI)) Q:XDRI'>0 D
71 . S DIC=XDRI,DA=XDRCD2,DIQ(0)="I",DIQ="XX",DR=XDRDSCOR("DR",XDRI)
72 . K XX
73 . D EN^DIQ1
74 . M XDRCD2=XX K XX,DA,DIC,DR,DIQ
75 Q
Note: See TracBrowser for help on using the repository browser.