- 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 Feb 19, 2025@00:05:25 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