- 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 Feb 19, 2025@00:20:21 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 ;