XDRLRFIX ;SF-CIOFO/JLI - FIX TO SET UP MERGE PROCESS CONTAINING PAIRS EXCLUDED BY LAB POINTER PROBLEMS ;05/10/99 13:53
;;7.3;TOOLKIT;**36**;Mar 24, 1999
; new routine to be called by XT*7.3*36 post-init
; two entry points, LAB and CLEANUP
; LAB will build a merge process if previous merge process
; have problems in LAB.
; CLEANUP will $order thru file 15 to ensure statuses of
; merged records are accurate.
EN ;
D CLEANUP
D LAB
Q
;
CLEANUP ;
N I,X,XS,XD,XM,XF,XN
F I=0:0 S I=$O(^VA(15,I)) Q:I'>0 D
. S X=^VA(15,I,0),XS=$P(X,U,3),XD=$P(X,U,4),XM=$P(X,U,5)
. I XS="V",$P($P(X,U),";",2)="DPT(" D
. . S XF=+$P(X,U,+XD),XN=$P($G(^DPT(XF,0)),U)
. . I $D(^DPT(XF,-9)) D
. . . I XN["MERGING INTO" S XN=$P($P(XN,"(",2),")",1),$P(^DPT(XF,0),U,1)=XN
. . . I XM'=2 S $P(^VA(15,I,0),U,5)=2
Q
;
LAB ;
N I,X,DFN,XARRAY
S XARRAY=$NA(^TMP("XDRLRFIX",$J))
K @XARRAY
F I=0:0 S I=$O(^VA(15,I)) Q:I'>0 S X=^(I,0) I $P($P(X,U),";",2)="DPT(",$P(X,U,5)=2 D
. I $P(X,U,4)'>0 N PROCES S PROCES=$P(X,U,20) I PROCES>0 D
. . I $O(^VA(15.2,PROCES,2,+X,0))>0 S $P(X,U,4)=1
. . I $O(^VA(15.2,PROCES,2,+$P(X,U,2),0))>0 S $P(X,U,4)=2
. . Q
. I $P(X,U,4)'>0 Q
. S DFN=+$P(X,U,$P(X,U,4)) I '$D(^DPT(DFN,-9)) D
. . S @XARRAY@(DFN,+$P(X,U,$S($P(X,U,4)=1:2,1:1)))=I
. . Q
. Q
I $D(@XARRAY) D
. N XDRXX,XDRYY,XDRMA,XDRFDA,XDRFDA
. S XDRXX(15.2,"+1,",.01)="LR FIX PROCESS"
. S XDRXX(15.2,"+1,",.02)=2
. S XDRXX(15.2,"+1,",.04)="U"
. S XDRXX(15.2,"+1,",.09)=1
. D UPDATE^DIE("","XDRXX","XDRYY","XDRMA")
. S XDRFDA=$G(XDRYY(1))
. ;
. ; NOW MOVE LIST OF DUPLICATES TO BE PROCESSED INTO THIS ENTRY
. S XDRIENS="+1,"_XDRFDA_","
. F XDRI=0:0 S XDRI=$O(@XARRAY@(XDRI)) Q:XDRI'>0 D
. . S XDRJ=$O(@XARRAY@(XDRI,0))
. . S XDRK=@XARRAY@(XDRI,XDRJ)
. . K XDRXX,XDRYY
. . S XDRXX(15.22,XDRIENS,.01)=XDRI ; IEN1
. . S XDRXX(15.22,XDRIENS,.02)=XDRJ ; IEN2
. . S XDRXX(15.22,XDRIENS,.03)=XDRK ; ENTRY # IN FILE 15
. . D UPDATE^DIE("","XDRXX","XDRYY","XDRMA")
. . K XDRXX,XDRYY,XDRMA
. . ; AND MARK THEM AS IN THIS MERGE PROCESS IN FILE 15
. . S XDRXX(15,XDRK_",",.2)=XDRFDA
. . D FILE^DIE("","XDRXX")
. . Q
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRLRFIX 2190 printed Apr 09, 2024@21:45:13 Page 2
XDRLRFIX ;SF-CIOFO/JLI - FIX TO SET UP MERGE PROCESS CONTAINING PAIRS EXCLUDED BY LAB POINTER PROBLEMS ;05/10/99 13:53
+1 ;;7.3;TOOLKIT;**36**;Mar 24, 1999
+2 ; new routine to be called by XT*7.3*36 post-init
+3 ; two entry points, LAB and CLEANUP
+4 ; LAB will build a merge process if previous merge process
+5 ; have problems in LAB.
+6 ; CLEANUP will $order thru file 15 to ensure statuses of
+7 ; merged records are accurate.
EN ;
+1 DO CLEANUP
+2 DO LAB
+3 QUIT
+4 ;
CLEANUP ;
+1 NEW I,X,XS,XD,XM,XF,XN
+2 FOR I=0:0
SET I=$ORDER(^VA(15,I))
if I'>0
QUIT
Begin DoDot:1
+3 SET X=^VA(15,I,0)
SET XS=$PIECE(X,U,3)
SET XD=$PIECE(X,U,4)
SET XM=$PIECE(X,U,5)
+4 IF XS="V"
IF $PIECE($PIECE(X,U),";",2)="DPT("
Begin DoDot:2
+5 SET XF=+$PIECE(X,U,+XD)
SET XN=$PIECE($GET(^DPT(XF,0)),U)
+6 IF $DATA(^DPT(XF,-9))
Begin DoDot:3
+7 IF XN["MERGING INTO"
SET XN=$PIECE($PIECE(XN,"(",2),")",1)
SET $PIECE(^DPT(XF,0),U,1)=XN
+8 IF XM'=2
SET $PIECE(^VA(15,I,0),U,5)=2
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
LAB ;
+1 NEW I,X,DFN,XARRAY
+2 SET XARRAY=$NAME(^TMP("XDRLRFIX",$JOB))
+3 KILL @XARRAY
+4 FOR I=0:0
SET I=$ORDER(^VA(15,I))
if I'>0
QUIT
SET X=^(I,0)
IF $PIECE($PIECE(X,U),";",2)="DPT("
IF $PIECE(X,U,5)=2
Begin DoDot:1
+5 IF $PIECE(X,U,4)'>0
NEW PROCES
SET PROCES=$PIECE(X,U,20)
IF PROCES>0
Begin DoDot:2
+6 IF $ORDER(^VA(15.2,PROCES,2,+X,0))>0
SET $PIECE(X,U,4)=1
+7 IF $ORDER(^VA(15.2,PROCES,2,+$PIECE(X,U,2),0))>0
SET $PIECE(X,U,4)=2
+8 QUIT
End DoDot:2
+9 IF $PIECE(X,U,4)'>0
QUIT
+10 SET DFN=+$PIECE(X,U,$PIECE(X,U,4))
IF '$DATA(^DPT(DFN,-9))
Begin DoDot:2
+11 SET @XARRAY@(DFN,+$PIECE(X,U,$SELECT($PIECE(X,U,4)=1:2,1:1)))=I
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 IF $DATA(@XARRAY)
Begin DoDot:1
+15 NEW XDRXX,XDRYY,XDRMA,XDRFDA,XDRFDA
+16 SET XDRXX(15.2,"+1,",.01)="LR FIX PROCESS"
+17 SET XDRXX(15.2,"+1,",.02)=2
+18 SET XDRXX(15.2,"+1,",.04)="U"
+19 SET XDRXX(15.2,"+1,",.09)=1
+20 DO UPDATE^DIE("","XDRXX","XDRYY","XDRMA")
+21 SET XDRFDA=$GET(XDRYY(1))
+22 ;
+23 ; NOW MOVE LIST OF DUPLICATES TO BE PROCESSED INTO THIS ENTRY
+24 SET XDRIENS="+1,"_XDRFDA_","
+25 FOR XDRI=0:0
SET XDRI=$ORDER(@XARRAY@(XDRI))
if XDRI'>0
QUIT
Begin DoDot:2
+26 SET XDRJ=$ORDER(@XARRAY@(XDRI,0))
+27 SET XDRK=@XARRAY@(XDRI,XDRJ)
+28 KILL XDRXX,XDRYY
+29 ; IEN1
SET XDRXX(15.22,XDRIENS,.01)=XDRI
+30 ; IEN2
SET XDRXX(15.22,XDRIENS,.02)=XDRJ
+31 ; ENTRY # IN FILE 15
SET XDRXX(15.22,XDRIENS,.03)=XDRK
+32 DO UPDATE^DIE("","XDRXX","XDRYY","XDRMA")
+33 KILL XDRXX,XDRYY,XDRMA
+34 ; AND MARK THEM AS IN THIS MERGE PROCESS IN FILE 15
+35 SET XDRXX(15,XDRK_",",.2)=XDRFDA
+36 DO FILE^DIE("","XDRXX")
+37 QUIT
End DoDot:2
+38 QUIT
End DoDot:1
+39 QUIT
