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