XDRDADJ ;IHS/EDE/OHPRD;ADJUSTS DUPLICATE RECORD FILE UPON MERGE; [ 08/13/92 09:50 AM ]
;;7.3;TOOLKIT;;Apr 25, 1995
START ;
K XDRDADJ
S XDRDADJ("DA")=DA
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
D INIT
D ENTRIES
END D EOJ
Q
;
;
ENTRIES ; ADJUST ENTRIES
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
Q
;
ENTRY ; ADJUST ONE ENTRY
S DA=XDRDADJY
S XDRDADJ("PC")=$S($P(X,U,1)=XDRDADJ("FRC"):1,1:2)
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)
S Y=0 F X="ANOT","APOT","AVDUP" S Y=$D(^VA(15,X,XDRDADJ("FL"),%)) Q:Y
I Y D DIK Q
D KILL
S $P(^VA(15,DA,0),U,XDRDADJ("PC"))=XDRDADJ("TOC")
D SET
I $P(^VA(15,DA,0),U,2)=$P(^(0),U) D DIK Q
S X="XDRDUP" X ^%ZOSF("TEST") I $T NEW XDRFL,XDRQFLG S XDRDPDA=XDRDADJY D EN^XDRDUP K XDRD,XDRDPDA ; Recompute duplicate score
Q
;
DIK ; CALL ^DIK TO DELETE ENTRY
; Delete entry because another entry has same pair.
S DIK="^VA(15,"
D ^DIK K DIK
Q
;
KILL ; DO KILL SIDE OF XREFS
S XDRDADJ("FLD")=$S(XDRDADJ("PC")=1:.01,1:.02)
S X=$P(^VA(15,DA,0),U,XDRDADJ("PC"))
D KILL2
S XDRDADJ("FLD")=.03
S X=$P(^VA(15,DA,0),U,3)
D KILL2
Q
;
KILL2 ;
F Y=0:0 S Y=$O(XDRDXREF(XDRDADJ("FLD"),Y)) Q:Y'=+Y X XDRDXREF(XDRDADJ("FLD"),Y,"K")
Q
;
SET ; DO SET SIDE OF XREFS
S XDRDADJ("FLD")=$S(XDRDADJ("PC")=1:.01,1:.02)
S X=$P(^VA(15,DA,0),U,XDRDADJ("PC"))
D SET2
S XDRDADJ("FLD")=.03
S X=$P(^VA(15,DA,0),U,3)
D SET2
Q
;
SET2 ;
F Y=0:0 S Y=$O(XDRDXREF(XDRDADJ("FLD"),Y)) Q:Y'=+Y X XDRDXREF(XDRDADJ("FLD"),Y,"S")
Q
;
INIT ;
S F=15 F X=.01,.02,.03 D XREFS ; Get xrefs less triggers
S X=$P(^VA(15,XDRDADJ("DA"),0),U,1,4),%=$P(X,U,4)
S XDRDADJ("FR")=+$P(X,U,%)
S XDRDADJ("FPC")=%
S XDRDADJ("TO")=+$P(X,U,%#2+1)
S XDRDADJ("TPC")=%#2+1
S XDRDADJ("FL")=$P($P(X,U,1),";",2)
S XDRDADJ("FRC")=XDRDADJ("FR")_";"_XDRDADJ("FL")
S XDRDADJ("TOC")=XDRDADJ("TO")_";"_XDRDADJ("FL")
Q
;
XREFS ; GET XREFS LESS TRIGGERS
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)
Q
;
EOJ ;
K XDRDADJ,XDRDADJY,XDRDXREF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRDADJ 2388 printed Dec 13, 2024@02:38:57 Page 2
XDRDADJ ;IHS/EDE/OHPRD;ADJUSTS DUPLICATE RECORD FILE UPON MERGE; [ 08/13/92 09:50 AM ]
+1 ;;7.3;TOOLKIT;;Apr 25, 1995
START ;
+1 KILL XDRDADJ
+2 SET XDRDADJ("DA")=DA
+3 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
+4 DO INIT
+5 DO ENTRIES
END DO EOJ
+1 QUIT
+2 ;
+3 ;
ENTRIES ; ADJUST ENTRIES
+1 FOR XDRDADJY=0:0
SET XDRDADJY=$ORDER(^VA(15,"B",XDRDADJ("FRC"),XDRDADJY))
if XDRDADJY'=+XDRDADJY
QUIT
IF XDRDADJY'=XDRDADJ("DA")
IF $PIECE(^VA(15,XDRDADJY,0),U,8)=""
SET X=$PIECE(^(0),U,1,3)
DO ENTRY
+2 QUIT
+3 ;
ENTRY ; ADJUST ONE ENTRY
+1 SET DA=XDRDADJY
+2 SET XDRDADJ("PC")=$SELECT($PIECE(X,U,1)=XDRDADJ("FRC"):1,1:2)
+3 SET %=+$PIECE(^VA(15,DA,0),U,XDRDADJ("PC")#2+1)_U_XDRDADJ("TO")
if +%>$PIECE(%,U,2)
SET %=$PIECE(%,U,2)_U_$PIECE(%,U,1)
+4 SET Y=0
FOR X="ANOT","APOT","AVDUP"
SET Y=$DATA(^VA(15,X,XDRDADJ("FL"),%))
if Y
QUIT
+5 IF Y
DO DIK
QUIT
+6 DO KILL
+7 SET $PIECE(^VA(15,DA,0),U,XDRDADJ("PC"))=XDRDADJ("TOC")
+8 DO SET
+9 IF $PIECE(^VA(15,DA,0),U,2)=$PIECE(^(0),U)
DO DIK
QUIT
+10 ; Recompute duplicate score
SET X="XDRDUP"
XECUTE ^%ZOSF("TEST")
IF $TEST
NEW XDRFL,XDRQFLG
SET XDRDPDA=XDRDADJY
DO EN^XDRDUP
KILL XDRD,XDRDPDA
+11 QUIT
+12 ;
DIK ; CALL ^DIK TO DELETE ENTRY
+1 ; Delete entry because another entry has same pair.
+2 SET DIK="^VA(15,"
+3 DO ^DIK
KILL DIK
+4 QUIT
+5 ;
KILL ; DO KILL SIDE OF XREFS
+1 SET XDRDADJ("FLD")=$SELECT(XDRDADJ("PC")=1:.01,1:.02)
+2 SET X=$PIECE(^VA(15,DA,0),U,XDRDADJ("PC"))
+3 DO KILL2
+4 SET XDRDADJ("FLD")=.03
+5 SET X=$PIECE(^VA(15,DA,0),U,3)
+6 DO KILL2
+7 QUIT
+8 ;
KILL2 ;
+1 FOR Y=0:0
SET Y=$ORDER(XDRDXREF(XDRDADJ("FLD"),Y))
if Y'=+Y
QUIT
XECUTE XDRDXREF(XDRDADJ("FLD"),Y,"K")
+2 QUIT
+3 ;
SET ; DO SET SIDE OF XREFS
+1 SET XDRDADJ("FLD")=$SELECT(XDRDADJ("PC")=1:.01,1:.02)
+2 SET X=$PIECE(^VA(15,DA,0),U,XDRDADJ("PC"))
+3 DO SET2
+4 SET XDRDADJ("FLD")=.03
+5 SET X=$PIECE(^VA(15,DA,0),U,3)
+6 DO SET2
+7 QUIT
+8 ;
SET2 ;
+1 FOR Y=0:0
SET Y=$ORDER(XDRDXREF(XDRDADJ("FLD"),Y))
if Y'=+Y
QUIT
XECUTE XDRDXREF(XDRDADJ("FLD"),Y,"S")
+2 QUIT
+3 ;
INIT ;
+1 ; Get xrefs less triggers
SET F=15
FOR X=.01,.02,.03
DO XREFS
+2 SET X=$PIECE(^VA(15,XDRDADJ("DA"),0),U,1,4)
SET %=$PIECE(X,U,4)
+3 SET XDRDADJ("FR")=+$PIECE(X,U,%)
+4 SET XDRDADJ("FPC")=%
+5 SET XDRDADJ("TO")=+$PIECE(X,U,%#2+1)
+6 SET XDRDADJ("TPC")=%#2+1
+7 SET XDRDADJ("FL")=$PIECE($PIECE(X,U,1),";",2)
+8 SET XDRDADJ("FRC")=XDRDADJ("FR")_";"_XDRDADJ("FL")
+9 SET XDRDADJ("TOC")=XDRDADJ("TO")_";"_XDRDADJ("FL")
+10 QUIT
+11 ;
XREFS ; GET XREFS LESS TRIGGERS
+1 FOR Y=0:0
SET Y=$ORDER(^DD(F,X,1,Y))
if Y'=+Y
QUIT
if ^(Y,0)'["TRIGGER"
SET XDRDXREF(X,Y)=^(0)
SET XDRDXREF(X,Y,"S")=^(1)
SET XDRDXREF(X,Y,"K")=^(2)
+2 QUIT
+3 ;
EOJ ;
+1 KILL XDRDADJ,XDRDADJY,XDRDXREF
+2 QUIT
