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

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

initial load of WorldVistAEHR

File size: 2.3 KB
Line 
1XDRDADJ ;IHS/EDE/OHPRD;ADJUSTS DUPLICATE RECORD FILE UPON MERGE; [ 08/13/92 09:50 AM ]
2 ;;7.3;TOOLKIT;;Apr 25, 1995
3START ;
4 K XDRDADJ
5 S XDRDADJ("DA")=DA
6 NEW D,D0,DA,DB,DC,DE,DG,DH,DI,DIC,DICR,DIE,DIEL,DIFLD,DIG,DIH,DIK,DINAME,DIP,DIU,DIV,DIW,DK,DL,DM,DOV,DP,DQ,DR,DSC,DU,DV,DW,DXS,X,Y,F
7 D INIT
8 D ENTRIES
9END D EOJ
10 Q
11 ;
12 ;
13ENTRIES ; ADJUST ENTRIES
14 F XDRDADJY=0:0 S XDRDADJY=$O(^VA(15,"B",XDRDADJ("FRC"),XDRDADJY)) Q:XDRDADJY'=+XDRDADJY I XDRDADJY'=XDRDADJ("DA"),$P(^VA(15,XDRDADJY,0),U,8)="" S X=$P(^(0),U,1,3) D ENTRY
15 Q
16 ;
17ENTRY ; ADJUST ONE ENTRY
18 S DA=XDRDADJY
19 S XDRDADJ("PC")=$S($P(X,U,1)=XDRDADJ("FRC"):1,1:2)
20 S %=+$P(^VA(15,DA,0),U,XDRDADJ("PC")#2+1)_U_XDRDADJ("TO") S:+%>$P(%,U,2) %=$P(%,U,2)_U_$P(%,U,1)
21 S Y=0 F X="ANOT","APOT","AVDUP" S Y=$D(^VA(15,X,XDRDADJ("FL"),%)) Q:Y
22 I Y D DIK Q
23 D KILL
24 S $P(^VA(15,DA,0),U,XDRDADJ("PC"))=XDRDADJ("TOC")
25 D SET
26 I $P(^VA(15,DA,0),U,2)=$P(^(0),U) D DIK Q
27 S X="XDRDUP" X ^%ZOSF("TEST") I $T NEW XDRFL,XDRQFLG S XDRDPDA=XDRDADJY D EN^XDRDUP K XDRD,XDRDPDA ; Recompute duplicate score
28 Q
29 ;
30DIK ; CALL ^DIK TO DELETE ENTRY
31 ; Delete entry because another entry has same pair.
32 S DIK="^VA(15,"
33 D ^DIK K DIK
34 Q
35 ;
36KILL ; DO KILL SIDE OF XREFS
37 S XDRDADJ("FLD")=$S(XDRDADJ("PC")=1:.01,1:.02)
38 S X=$P(^VA(15,DA,0),U,XDRDADJ("PC"))
39 D KILL2
40 S XDRDADJ("FLD")=.03
41 S X=$P(^VA(15,DA,0),U,3)
42 D KILL2
43 Q
44 ;
45KILL2 ;
46 F Y=0:0 S Y=$O(XDRDXREF(XDRDADJ("FLD"),Y)) Q:Y'=+Y X XDRDXREF(XDRDADJ("FLD"),Y,"K")
47 Q
48 ;
49SET ; DO SET SIDE OF XREFS
50 S XDRDADJ("FLD")=$S(XDRDADJ("PC")=1:.01,1:.02)
51 S X=$P(^VA(15,DA,0),U,XDRDADJ("PC"))
52 D SET2
53 S XDRDADJ("FLD")=.03
54 S X=$P(^VA(15,DA,0),U,3)
55 D SET2
56 Q
57 ;
58SET2 ;
59 F Y=0:0 S Y=$O(XDRDXREF(XDRDADJ("FLD"),Y)) Q:Y'=+Y X XDRDXREF(XDRDADJ("FLD"),Y,"S")
60 Q
61 ;
62INIT ;
63 S F=15 F X=.01,.02,.03 D XREFS ; Get xrefs less triggers
64 S X=$P(^VA(15,XDRDADJ("DA"),0),U,1,4),%=$P(X,U,4)
65 S XDRDADJ("FR")=+$P(X,U,%)
66 S XDRDADJ("FPC")=%
67 S XDRDADJ("TO")=+$P(X,U,%#2+1)
68 S XDRDADJ("TPC")=%#2+1
69 S XDRDADJ("FL")=$P($P(X,U,1),";",2)
70 S XDRDADJ("FRC")=XDRDADJ("FR")_";"_XDRDADJ("FL")
71 S XDRDADJ("TOC")=XDRDADJ("TO")_";"_XDRDADJ("FL")
72 Q
73 ;
74XREFS ; GET XREFS LESS TRIGGERS
75 F Y=0:0 S Y=$O(^DD(F,X,1,Y)) Q:Y'=+Y S:^(Y,0)'["TRIGGER" XDRDXREF(X,Y)=^(0),XDRDXREF(X,Y,"S")=^(1),XDRDXREF(X,Y,"K")=^(2)
76 Q
77 ;
78EOJ ;
79 K XDRDADJ,XDRDADJY,XDRDXREF
80 Q
Note: See TracBrowser for help on using the repository browser.