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