DIFROMSY ;SFIRMFO/DCM/TKW-MOVE KEY FILE ENTRIES ;12:32 PM 31 Oct 2001
;;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.
;
DDKEYOUT(DIFRFILE,DIFRF2,DIFRTA) ; retrieve KEY entries for file
; DIFRFILE=top level file number
; DIFRF2=current file/subfile number
; DIFRTA=Global reference of transport global
N DINODE,DIFRNAME,DIFRDO,DIFRD1,DIFRF,DIFRFLD,DIOUT,X,Y,DICNT1,DICNT2
S DIFRNAME="",DIOUT=0
F S DIFRNAME=$O(^DD("KEY","BB",DIFRF2,DIFRNAME)) Q:DIFRNAME="" D Q:DIOUT
. S DIFRD0=$O(^DD("KEY","BB",DIFRF2,DIFRNAME,0)) Q:'DIFRD0
. S (DIFRD1,DICNT1,DICNT2)=0
. F S DIFRD1=$O(^DD("KEY",DIFRD0,2,DIFRD1)) Q:'DIFRD1 D Q:DIOUT
. . S X=$G(^DD("KEY",DIFRD0,2,DIFRD1,0))
. . S DIFRF=$P(X,U,2),DIFRFLD=$P(X,U)
. . I 'DIFRF!('DIFRFLD) Q
. . S DICNT1=DICNT1+1,X=$$FNO^DILIBF(DIFRF)
. . I '$D(@DIFRTA@("^DD",X,DIFRF,DIFRFLD)) D Q
. . . Q:'DIFRFDD&($G(@DIFRTA@("FIA",X,DIFRF))'=0)
. . . D ERR1^DIFROMSX(DIFRF,DIFRFLD,DIFRNAME,"KEY") Q
. . S DICNT2=DICNT2+1
. Q:DIOUT I DICNT2=0,'DIFRFDD Q
. ;I DICNT1'=DICNT2 D ERR2^DIFROMSX(DIFRF2,DIFRNAME,"KEY") Q
. M @DIFRTA@("KEY",DIFRFILE,DIFRF2,DIFRNAME)=^DD("KEY",DIFRD0)
. S X=$NA(@DIFRTA@("KEY",DIFRFILE,DIFRF2,DIFRNAME,2))
. F Y="B","BB","S" K @X@(Y)
. K @DIFRTA@("KEY",DIFRFILE,DIFRF2,DIFRNAME,DIFRD0,3.1,"B")
. D IXPTR Q
Q
IXPTR ; export index pointer
N DIIXPTR S DIIXPTR=$P(^DD("KEY",DIFRD0,0),U,4)
I 'DIIXPTR D ERR1(9546,DIFRF2,DIFRNAME) Q
N X,Y S X=$G(^DD("IX",DIIXPTR,0)),Y=$P(X,U,2),X=$P(X,U)
I (+$P(X,"E")'=X)!(Y="") D ERR1(9546,DIFRF2,DIFRNAME) Q
S @DIFRTA@("KEYPTR",DIFRFILE,DIFRF2,DIFRNAME)=X_"^"_Y
Q
;
DDKEYIN(DIFRFILE,DIFRF2,DIFRSA) ;
; DIFRFILE=top level file#
; DIFRF2=current file/subfile#
; DIFRSA=global reference of transport global
I '$D(^DD(.31)) N DIFRER S DIFRER("FILE")=.31 D BLD^DIALOG(401,.DIFRER) Q
N DIFRIN,DIFRNAME,DIFRD1,DIOUT,DIFRIN1,DIFRF,DIFRFLD,DIFRKPTR,X
S DIFRIN=$NA(@DIFRSA@("KEY",DIFRFILE,DIFRF2))
S DIFRNAME=""
F S DIFRNAME=$O(@DIFRIN@(DIFRNAME)) Q:DIFRNAME="" D
. S (DIFRD1,DIOUT)=0,DIFRIN1=$NA(@DIFRIN@(DIFRNAME))
. F S DIFRD1=$O(@DIFRIN1@(2,DIFRD1)) Q:'DIFRD1 D Q:DIOUT
. . S X=$G(@DIFRIN1@(2,DIFRD1,0))
. . S DIFRF=$P(X,U,2),DIFRFLD=$P(X,U)
. . I 'DIFRF!('DIFRFLD) Q
. . I '$D(^DD(DIFRF,DIFRFLD,0)) D ERR3^DIFROMSX(DIFRF,DIFRFLD,DIFRNAME,"KEY")
. . Q
. Q:DIOUT
. S X=$G(@DIFRSA@("KEYPTR",DIFRFILE,DIFRF2,DIFRNAME)) D Q:DIOUT
. . I X="" D ERR1(9547,DIFRF2,DIFRNAME) Q
. . S DIFRKPTR=$O(^DD("IX","BB",$P(X,U),$P(X,U,2),0))
. . I 'DIFRKPTR D ERR1(9547,DIFRF2,DIFRNAME) Q
. . S $P(@DIFRIN1@(0),U,4)=DIFRKPTR Q
. N DIEN,DIK,DA,DIC,DO
. S DIEN=$O(^DD("KEY","BB",DIFRF2,DIFRNAME,0))
. I DIEN D N DINUM S DINUM=DIEN
. . S DIK="^DD(""KEY"",",DA=DIEN N DIEN D ^DIK Q
. S DIC="^DD(""KEY"",",DIC(0)="L",DIC("DR")=".02///^S X="_""""_DIFRNAME_"""",X=DIFRF2 D FILE^DICN S DIEN=+Y
. I DIEN'>0 D ERR4^DIFROMSX(DIFRF2,DIFRNAME,"KEY") Q
. M ^DD("KEY",DIEN)=@DIFRIN1
. K DIK,DA S DIK="^DD(""KEY"",",DA=DIEN D IX1^DIK
. Q
Q
;
ERR1(DIER,DIFRF2,DIFRNAME) ;
N DIFRER S DIFRER(1)=DIFRNAME
S DIFRER(2)=DIFRF2
D BLD^DIALOG(DIER,.DIFRER) S DIOUT=1 Q
;
;9543 Field |1| of file |2|, part of '|3|' |4| entry, is missing from the transport global...
;9545 |1| entry |2| is not installed. The REFERENCE FIELD |3| in file |4| does not exist on the system.
;9546 KEY '|1|' for file |2| cannot be transported, problem with Uniqueness Index for the KEY.
;9547 Key '|1|' for file |2| not installed. Pointer to Uniqueness Index cannot be resolved.
;9549 |1| "|2|" on file |3| not installed, FILE^DICN call failed.
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROMSY 3883 printed Dec 13, 2024@02:48:30 Page 2
DIFROMSY ;SFIRMFO/DCM/TKW-MOVE KEY FILE ENTRIES ;12:32 PM 31 Oct 2001
+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 ;
DDKEYOUT(DIFRFILE,DIFRF2,DIFRTA) ; retrieve KEY entries for file
+1 ; DIFRFILE=top level file number
+2 ; DIFRF2=current file/subfile number
+3 ; DIFRTA=Global reference of transport global
+4 NEW DINODE,DIFRNAME,DIFRDO,DIFRD1,DIFRF,DIFRFLD,DIOUT,X,Y,DICNT1,DICNT2
+5 SET DIFRNAME=""
SET DIOUT=0
+6 FOR
SET DIFRNAME=$ORDER(^DD("KEY","BB",DIFRF2,DIFRNAME))
if DIFRNAME=""
QUIT
Begin DoDot:1
+7 SET DIFRD0=$ORDER(^DD("KEY","BB",DIFRF2,DIFRNAME,0))
if 'DIFRD0
QUIT
+8 SET (DIFRD1,DICNT1,DICNT2)=0
+9 FOR
SET DIFRD1=$ORDER(^DD("KEY",DIFRD0,2,DIFRD1))
if 'DIFRD1
QUIT
Begin DoDot:2
+10 SET X=$GET(^DD("KEY",DIFRD0,2,DIFRD1,0))
+11 SET DIFRF=$PIECE(X,U,2)
SET DIFRFLD=$PIECE(X,U)
+12 IF 'DIFRF!('DIFRFLD)
QUIT
+13 SET DICNT1=DICNT1+1
SET X=$$FNO^DILIBF(DIFRF)
+14 IF '$DATA(@DIFRTA@("^DD",X,DIFRF,DIFRFLD))
Begin DoDot:3
+15 if 'DIFRFDD&($GET(@DIFRTA@("FIA",X,DIFRF))'=0)
QUIT
+16 DO ERR1^DIFROMSX(DIFRF,DIFRFLD,DIFRNAME,"KEY")
QUIT
End DoDot:3
QUIT
+17 SET DICNT2=DICNT2+1
End DoDot:2
if DIOUT
QUIT
+18 if DIOUT
QUIT
IF DICNT2=0
IF 'DIFRFDD
QUIT
+19 ;I DICNT1'=DICNT2 D ERR2^DIFROMSX(DIFRF2,DIFRNAME,"KEY") Q
+20 MERGE @DIFRTA@("KEY",DIFRFILE,DIFRF2,DIFRNAME)=^DD("KEY",DIFRD0)
+21 SET X=$NAME(@DIFRTA@("KEY",DIFRFILE,DIFRF2,DIFRNAME,2))
+22 FOR Y="B","BB","S"
KILL @X@(Y)
+23 KILL @DIFRTA@("KEY",DIFRFILE,DIFRF2,DIFRNAME,DIFRD0,3.1,"B")
+24 DO IXPTR
QUIT
End DoDot:1
if DIOUT
QUIT
+25 QUIT
IXPTR ; export index pointer
+1 NEW DIIXPTR
SET DIIXPTR=$PIECE(^DD("KEY",DIFRD0,0),U,4)
+2 IF 'DIIXPTR
DO ERR1(9546,DIFRF2,DIFRNAME)
QUIT
+3 NEW X,Y
SET X=$GET(^DD("IX",DIIXPTR,0))
SET Y=$PIECE(X,U,2)
SET X=$PIECE(X,U)
+4 IF (+$PIECE(X,"E")'=X)!(Y="")
DO ERR1(9546,DIFRF2,DIFRNAME)
QUIT
+5 SET @DIFRTA@("KEYPTR",DIFRFILE,DIFRF2,DIFRNAME)=X_"^"_Y
+6 QUIT
+7 ;
DDKEYIN(DIFRFILE,DIFRF2,DIFRSA) ;
+1 ; DIFRFILE=top level file#
+2 ; DIFRF2=current file/subfile#
+3 ; DIFRSA=global reference of transport global
+4 IF '$DATA(^DD(.31))
NEW DIFRER
SET DIFRER("FILE")=.31
DO BLD^DIALOG(401,.DIFRER)
QUIT
+5 NEW DIFRIN,DIFRNAME,DIFRD1,DIOUT,DIFRIN1,DIFRF,DIFRFLD,DIFRKPTR,X
+6 SET DIFRIN=$NAME(@DIFRSA@("KEY",DIFRFILE,DIFRF2))
+7 SET DIFRNAME=""
+8 FOR
SET DIFRNAME=$ORDER(@DIFRIN@(DIFRNAME))
if DIFRNAME=""
QUIT
Begin DoDot:1
+9 SET (DIFRD1,DIOUT)=0
SET DIFRIN1=$NAME(@DIFRIN@(DIFRNAME))
+10 FOR
SET DIFRD1=$ORDER(@DIFRIN1@(2,DIFRD1))
if 'DIFRD1
QUIT
Begin DoDot:2
+11 SET X=$GET(@DIFRIN1@(2,DIFRD1,0))
+12 SET DIFRF=$PIECE(X,U,2)
SET DIFRFLD=$PIECE(X,U)
+13 IF 'DIFRF!('DIFRFLD)
QUIT
+14 IF '$DATA(^DD(DIFRF,DIFRFLD,0))
DO ERR3^DIFROMSX(DIFRF,DIFRFLD,DIFRNAME,"KEY")
+15 QUIT
End DoDot:2
if DIOUT
QUIT
+16 if DIOUT
QUIT
+17 SET X=$GET(@DIFRSA@("KEYPTR",DIFRFILE,DIFRF2,DIFRNAME))
Begin DoDot:2
+18 IF X=""
DO ERR1(9547,DIFRF2,DIFRNAME)
QUIT
+19 SET DIFRKPTR=$ORDER(^DD("IX","BB",$PIECE(X,U),$PIECE(X,U,2),0))
+20 IF 'DIFRKPTR
DO ERR1(9547,DIFRF2,DIFRNAME)
QUIT
+21 SET $PIECE(@DIFRIN1@(0),U,4)=DIFRKPTR
QUIT
End DoDot:2
if DIOUT
QUIT
+22 NEW DIEN,DIK,DA,DIC,DO
+23 SET DIEN=$ORDER(^DD("KEY","BB",DIFRF2,DIFRNAME,0))
+24 IF DIEN
Begin DoDot:2
+25 SET DIK="^DD(""KEY"","
SET DA=DIEN
NEW DIEN
DO ^DIK
QUIT
End DoDot:2
NEW DINUM
SET DINUM=DIEN
+26 SET DIC="^DD(""KEY"","
SET DIC(0)="L"
SET DIC("DR")=".02///^S X="_""""_DIFRNAME_""""
SET X=DIFRF2
DO FILE^DICN
SET DIEN=+Y
+27 IF DIEN'>0
DO ERR4^DIFROMSX(DIFRF2,DIFRNAME,"KEY")
QUIT
+28 MERGE ^DD("KEY",DIEN)=@DIFRIN1
+29 KILL DIK,DA
SET DIK="^DD(""KEY"","
SET DA=DIEN
DO IX1^DIK
+30 QUIT
End DoDot:1
+31 QUIT
+32 ;
ERR1(DIER,DIFRF2,DIFRNAME) ;
+1 NEW DIFRER
SET DIFRER(1)=DIFRNAME
+2 SET DIFRER(2)=DIFRF2
+3 DO BLD^DIALOG(DIER,.DIFRER)
SET DIOUT=1
QUIT
+4 ;
+5 ;9543 Field |1| of file |2|, part of '|3|' |4| entry, is missing from the transport global...
+6 ;9545 |1| entry |2| is not installed. The REFERENCE FIELD |3| in file |4| does not exist on the system.
+7 ;9546 KEY '|1|' for file |2| cannot be transported, problem with Uniqueness Index for the KEY.
+8 ;9547 Key '|1|' for file |2| not installed. Pointer to Uniqueness Index cannot be resolved.
+9 ;9549 |1| "|2|" on file |3| not installed, FILE^DICN call failed.
+10 ;
