DIT3 ;SFISC/TKW - SILENT TRANSFER/MERGE ROUTINE ;10/14/94 13:50
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
TRNMRG ; TRANSFER OR MERGE RECORDS SILENTLY (CALLED FROM TRNMRG^DIT)
N I,J,Z,DITYPM,DDF,DDT,DFR,DMRG,DKP,DTO,DFL,DTL,DA,DIZZ,DIERRMSG,DIK,DITF D CLEAN^DIEFU
F I=1:1 S DITYPM=$E(DIFLG,I) Q:DITYPM="" Q:"MOAR"[DITYPM
I DITYPM="" G ERR0
I '$G(DIFFNO),$G(DITFNO) S DFR=DIFFNO,DIFFNO=+DITFNO I $E(DFR,$L(DFR))=")" S DFR=$$OREF^DIQGU(DFR)
I '$G(DIFFNO)!('$D(^DD(+$G(DIFFNO),.01,0))) S DIERRMSG=$$EZBLD^DIALOG(8082)_" "_$$EZBLD^DIALOG(8084) G ERR3
S DITFNO=+$G(DITFNO) S:'DITFNO DITFNO=DIFFNO I DITFNO'=DIFFNO,'$D(^DD(DITFNO,.01,0)) S DIERRMSG=$$EZBLD^DIALOG(8083)_" "_$$EZBLD^DIALOG(8084) G ERR3
I '$G(DIFIEN) S DIERRMSG=$$EZBLD^DIALOG(8082)_" "_$$EZBLD^DIALOG(8085) G ERR3
F I=0:1 S J=$P(DIFIEN,",",I+1) Q:'J S DA(I)=J,DFL=I*2+1
S (I,J)=I-1 D G:I'=J ERR5
. I I=0,$D(^DD(DIFFNO,0,"UP")) S J=-1 Q
. N Z S Z=DIFFNO,J=0 F Q:'$D(^DD(Z,0,"UP")) S J=J+1,Z=^("UP")
. Q
S J=0
SD0 N @("D"_J) S @("D"_J)=DA(I),I=I-1,J=J+1 I I>-1 G SD0
S DA=DA(0) K DA(0)
S DDF(DFL)=DIFFNO,DDT(DFL-1)=DITFNO S:DIFFNO=DITFNO DDT(DFL)=DITFNO
S DFR(DFL)=$S($G(DFR)]"":DFR,1:$$ROOT^DIQGU(DIFFNO,DIFIEN,"",1))_+DIFIEN_"," Q:$D(DIERR) G:'$D(@(DFR(DFL)_"0)")) ERR1 S DIZZ=^(0)
S:$G(DITIEN)="" DITIEN="+?1,"_$P(DIFIEN,",",2,99)
Q:'$$IENCHK(DITFNO,DITIEN)
S (DTO(DFL-1),DIK)=$$ROOT^DIQGU(DITFNO,DITIEN,"",1) Q:$D(DIERR)
I DITIEN S DTO(DFL)=DTO(DFL-1)_+DITIEN_"," I '$D(@(DTO(DFL)_"0)")) G ERR2
I 'DITIEN,$D(^DD(DITFNO,0,"UP")) D I '$D(DITIEN) G ERR2
. N X,Y,Z S X=^DD(DITFNO,0,"UP"),Y=$P(DITIEN,",",2,99),Z=$$ROOT^DIQGU(X,Y) I $D(DIERR) K DITIEN Q
. I '$D(@(Z_$P(Y,",")_",0)")) K DITIEN Q
. I $P($G(^DD(DITFNO,.01,0)),U,2)["W" K DITIEN Q
. I '$D(@(DTO(DFL-1)_"0)")) S Z=$O(^DD(X,"SB",DITFNO,0)) I Z S Z=$P($G(^DD(X,Z,0)),U,2) I Z S @(DTO(DFL-1)_"0)")="^"_Z_"^^"
. Q
I DIFFNO'=DITFNO D I '$D(DITF) G ERR4
. N %,A,L,V,X,Y,Z,DIC K ^UTILITY("DITR",$J)
. S A=1,L=0,L(DDF(DFL))=DDT(DFL-1)
. D MAP2^DIT Q
S DMRG=$S(DIFLG["A":0,1:1),DKP=$S(DIFLG["M":1,1:0),DTO=$S(DIFFNO=DITFNO:0,1:1)
N %,A,B,V,W,X,Y,DFN,DTN,DINUM,DIC,DIIX
I 'DITIEN D Q:A
. S (DFL,DTL)=DFL-1,Z=DIZZ D ^DITR1 Q:A
. S DFL=DFL+1,DITIEN=+Y_","_$P(DITIEN,",",2,99)
. Q
S DTL=DFL,DFN(DFL)=-1 D N^DITR
I DIFLG'["X" Q
K DA F I=1:1 S J=$P(DITIEN,",",I) Q:'J S:I=1 DA=J I I>1 S DA(I-1)=J
D IXALL^DIK
Q
;
IENCHK(DIFILE,DIIEN) ;EXTRINSIC FUNCTIO TO CHECK THAT IEN STRING AND FILE/SUBFILE NO. ARE IN SYNC
;DIFILE=file/subfile#, DIIEN=IEN string
N I,J
S I=$L($G(DIIEN),",") I I=1 G ERX
S I=I-1,J=0 D I I'=J G ERX
. I I=1,$D(^DD(DIFILE,0,"UP")) Q
. S J=1 F Q:'$D(^DD(DIFILE,0,"UP")) S J=J+1,DIFILE=^("UP")
. Q
Q 1
ERX K I S I(1)=DIFILE,I("IENS")=DIIEN D BLD^DIALOG(205,.I) Q 0
;
ERR0 D BLD^DIALOG(301,DIFLG) Q
ERR1 S DIERRMSG=$$EZBLD^DIALOG(8082)_" "_$$EZBLD^DIALOG(8078) G ERR3
ERR2 S DIERRMSG=$$EZBLD^DIALOG(8083)_" "_$$EZBLD^DIALOG(8078)
ERR3 D BLD^DIALOG(202,DIERRMSG) Q
ERR4 D BLD^DIALOG(1504) Q
ERR5 K I S I(1)=DIFFNO,I("IENS")=DIFIEN D BLD^DIALOG(205,.I) Q
;202 The input param...that identifies...|1| is missing or invalid.
;205 File...number and IEN string represent different...levels.
;301 The passed flag(s) '|1|' are unknown or inconsistent.
;1504 No matching .01 field names...Transfer/Merge cannot be done
;8082 Transfer FROM
;8083 Transfer TO
;8084 file number
;8085 IEN string
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIT3 3731 printed Apr 09, 2024@21:52:39 Page 2
DIT3 ;SFISC/TKW - SILENT TRANSFER/MERGE ROUTINE ;10/14/94 13:50
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
TRNMRG ; TRANSFER OR MERGE RECORDS SILENTLY (CALLED FROM TRNMRG^DIT)
+1 NEW I,J,Z,DITYPM,DDF,DDT,DFR,DMRG,DKP,DTO,DFL,DTL,DA,DIZZ,DIERRMSG,DIK,DITF
DO CLEAN^DIEFU
+2 FOR I=1:1
SET DITYPM=$EXTRACT(DIFLG,I)
if DITYPM=""
QUIT
if "MOAR"[DITYPM
QUIT
+3 IF DITYPM=""
GOTO ERR0
+4 IF '$GET(DIFFNO)
IF $GET(DITFNO)
SET DFR=DIFFNO
SET DIFFNO=+DITFNO
IF $EXTRACT(DFR,$LENGTH(DFR))=")"
SET DFR=$$OREF^DIQGU(DFR)
+5 IF '$GET(DIFFNO)!('$DATA(^DD(+$GET(DIFFNO),.01,0)))
SET DIERRMSG=$$EZBLD^DIALOG(8082)_" "_$$EZBLD^DIALOG(8084)
GOTO ERR3
+6 SET DITFNO=+$GET(DITFNO)
if 'DITFNO
SET DITFNO=DIFFNO
IF DITFNO'=DIFFNO
IF '$DATA(^DD(DITFNO,.01,0))
SET DIERRMSG=$$EZBLD^DIALOG(8083)_" "_$$EZBLD^DIALOG(8084)
GOTO ERR3
+7 IF '$GET(DIFIEN)
SET DIERRMSG=$$EZBLD^DIALOG(8082)_" "_$$EZBLD^DIALOG(8085)
GOTO ERR3
+8 FOR I=0:1
SET J=$PIECE(DIFIEN,",",I+1)
if 'J
QUIT
SET DA(I)=J
SET DFL=I*2+1
+9 SET (I,J)=I-1
Begin DoDot:1
+10 IF I=0
IF $DATA(^DD(DIFFNO,0,"UP"))
SET J=-1
QUIT
+11 NEW Z
SET Z=DIFFNO
SET J=0
FOR
if '$DATA(^DD(Z,0,"UP"))
QUIT
SET J=J+1
SET Z=^("UP")
+12 QUIT
End DoDot:1
if I'=J
GOTO ERR5
+13 SET J=0
SD0 NEW @("D"_J)
SET @("D"_J)=DA(I)
SET I=I-1
SET J=J+1
IF I>-1
GOTO SD0
+1 SET DA=DA(0)
KILL DA(0)
+2 SET DDF(DFL)=DIFFNO
SET DDT(DFL-1)=DITFNO
if DIFFNO=DITFNO
SET DDT(DFL)=DITFNO
+3 SET DFR(DFL)=$SELECT($GET(DFR)]"":DFR,1:$$ROOT^DIQGU(DIFFNO,DIFIEN,"",1))_+DIFIEN_","
if $DATA(DIERR)
QUIT
if '$DATA(@(DFR(DFL)_"0)"))
GOTO ERR1
SET DIZZ=^(0)
+4 if $GET(DITIEN)=""
SET DITIEN="+?1,"_$PIECE(DIFIEN,",",2,99)
+5 if '$$IENCHK(DITFNO,DITIEN)
QUIT
+6 SET (DTO(DFL-1),DIK)=$$ROOT^DIQGU(DITFNO,DITIEN,"",1)
if $DATA(DIERR)
QUIT
+7 IF DITIEN
SET DTO(DFL)=DTO(DFL-1)_+DITIEN_","
IF '$DATA(@(DTO(DFL)_"0)"))
GOTO ERR2
+8 IF 'DITIEN
IF $DATA(^DD(DITFNO,0,"UP"))
Begin DoDot:1
+9 NEW X,Y,Z
SET X=^DD(DITFNO,0,"UP")
SET Y=$PIECE(DITIEN,",",2,99)
SET Z=$$ROOT^DIQGU(X,Y)
IF $DATA(DIERR)
KILL DITIEN
QUIT
+10 IF '$DATA(@(Z_$PIECE(Y,",")_",0)"))
KILL DITIEN
QUIT
+11 IF $PIECE($GET(^DD(DITFNO,.01,0)),U,2)["W"
KILL DITIEN
QUIT
+12 IF '$DATA(@(DTO(DFL-1)_"0)"))
SET Z=$ORDER(^DD(X,"SB",DITFNO,0))
IF Z
SET Z=$PIECE($GET(^DD(X,Z,0)),U,2)
IF Z
SET @(DTO(DFL-1)_"0)")="^"_Z_"^^"
+13 QUIT
End DoDot:1
IF '$DATA(DITIEN)
GOTO ERR2
+14 IF DIFFNO'=DITFNO
Begin DoDot:1
+15 NEW %,A,L,V,X,Y,Z,DIC
KILL ^UTILITY("DITR",$JOB)
+16 SET A=1
SET L=0
SET L(DDF(DFL))=DDT(DFL-1)
+17 DO MAP2^DIT
QUIT
End DoDot:1
IF '$DATA(DITF)
GOTO ERR4
+18 SET DMRG=$SELECT(DIFLG["A":0,1:1)
SET DKP=$SELECT(DIFLG["M":1,1:0)
SET DTO=$SELECT(DIFFNO=DITFNO:0,1:1)
+19 NEW %,A,B,V,W,X,Y,DFN,DTN,DINUM,DIC,DIIX
+20 IF 'DITIEN
Begin DoDot:1
+21 SET (DFL,DTL)=DFL-1
SET Z=DIZZ
DO ^DITR1
if A
QUIT
+22 SET DFL=DFL+1
SET DITIEN=+Y_","_$PIECE(DITIEN,",",2,99)
+23 QUIT
End DoDot:1
if A
QUIT
+24 SET DTL=DFL
SET DFN(DFL)=-1
DO N^DITR
+25 IF DIFLG'["X"
QUIT
+26 KILL DA
FOR I=1:1
SET J=$PIECE(DITIEN,",",I)
if 'J
QUIT
if I=1
SET DA=J
IF I>1
SET DA(I-1)=J
+27 DO IXALL^DIK
+28 QUIT
+29 ;
IENCHK(DIFILE,DIIEN) ;EXTRINSIC FUNCTIO TO CHECK THAT IEN STRING AND FILE/SUBFILE NO. ARE IN SYNC
+1 ;DIFILE=file/subfile#, DIIEN=IEN string
+2 NEW I,J
+3 SET I=$LENGTH($GET(DIIEN),",")
IF I=1
GOTO ERX
+4 SET I=I-1
SET J=0
Begin DoDot:1
+5 IF I=1
IF $DATA(^DD(DIFILE,0,"UP"))
QUIT
+6 SET J=1
FOR
if '$DATA(^DD(DIFILE,0,"UP"))
QUIT
SET J=J+1
SET DIFILE=^("UP")
+7 QUIT
End DoDot:1
IF I'=J
GOTO ERX
+8 QUIT 1
ERX KILL I
SET I(1)=DIFILE
SET I("IENS")=DIIEN
DO BLD^DIALOG(205,.I)
QUIT 0
+1 ;
ERR0 DO BLD^DIALOG(301,DIFLG)
QUIT
ERR1 SET DIERRMSG=$$EZBLD^DIALOG(8082)_" "_$$EZBLD^DIALOG(8078)
GOTO ERR3
ERR2 SET DIERRMSG=$$EZBLD^DIALOG(8083)_" "_$$EZBLD^DIALOG(8078)
ERR3 DO BLD^DIALOG(202,DIERRMSG)
QUIT
ERR4 DO BLD^DIALOG(1504)
QUIT
ERR5 KILL I
SET I(1)=DIFFNO
SET I("IENS")=DIFIEN
DO BLD^DIALOG(205,.I)
QUIT
+1 ;202 The input param...that identifies...|1| is missing or invalid.
+2 ;205 File...number and IEN string represent different...levels.
+3 ;301 The passed flag(s) '|1|' are unknown or inconsistent.
+4 ;1504 No matching .01 field names...Transfer/Merge cannot be done
+5 ;8082 Transfer FROM
+6 ;8083 Transfer TO
+7 ;8084 file number
+8 ;8085 IEN string
+9 ;
