- DIFROMS4 ;SFISC/DCL- DATA FROM DISTRIBUTION ARRAY ;5/24/00 15:22
- ;;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.
- ;
- Q
- EN ;
- I '$D(@DIFRFIA) D ERR(2) Q
- ;N DIFRFILP S DIFRFILP=$D(DIFRFILP)#2
- N %,%H,A,B,D,D0,D1,DA,DDF,DDT,DFL,DFN,DFR,DIC,DIFL,DIIX,DIK,DINUM,DIU
- N DKP,DMRG,DTL,DTN,DTO,I,V,W,X,Y,Z
- G:$G(DIFRFILE) FILE
- S DIFRFILE=0 F S DIFRFILE=$O(@DIFRFIA@(DIFRFILE)) Q:DIFRFILE'>0 D FILE
- Q
- FCHK I '$D(@DIFRFIA@(DIFRFILE)) D ERR(5) Q ; * * * PHASING OUT * * *
- FILE N DIFRDA,DIFRND0,DIFROOT,DIFR01,DIFR02,DIFRRLR,DIFRFRV
- N DIFRDKP,DIFRDKPD,DIFRDKPR,DIFRDKPS
- D KILL
- I '$D(@DIFRFIA) D ERR(2) Q
- I $G(@DIFRFIA@(DIFRFILE,DIFRFILE)) D Q
- .N DIFRERR S DIFRERR(1)=DIFRFILE
- .D BLD^DIALOG(9515,.DIFRERR)
- .Q
- S DIFROOT=@DIFRFIA@(DIFRFILE,0),DIFRDA=0
- S DIFR01=@DIFRFIA@(DIFRFILE,0,1),DIFR02=$G(^(2))
- I $P(DIFR02,"^",8)="" S $P(DIFR02,"^",8)=$$TL^DIFROMSP(DIFRFILE,"",DIFRSA)
- S DIFRRLR=$G(@DIFRFIA@(DIFRFILE,0,"RLRI")) ; * * * phasing out * * *
- S:DIFRRLR="" DIFRRLR=$NA(@DIFRSA@("DATA",DIFRFILE))
- I $D(@DIFRRLR)'>9 D ERR(4) Q
- ;
- ; Recover from a failure in Replace Mode RE-INSTALL on target system
- I $D(@DIFRSA@("TMP")) D K @DIFRSA@("TMP")
- .S (D,DDF(1),DDT(0))=DIFRFILE
- .S DTO=0,DMRG=1,DTO(0)=DIFROOT,DKP=$S($TR($P(DIFR01,"^",8),"O","o")="o":0,1:1)
- .S DFR(1)=$$OREF^DILF(DIFRSA)_"""TMP"",DIFRFILE,D0,"
- .S D0=$O(@DIFRSA@("TMP",DIFRFILE,0)) Q:'$D(^(D0,0)) S Z=^(0)
- .D I^DITR,REINDEX
- .D KILL Q
- ;
- F S DIFRDA=$O(@DIFRRLR@(DIFRDA)) Q:DIFRDA'>0 D
- .S (D,DDF(1),DDT(0))=DIFRFILE
- .S DTO=0,DMRG=1,DTO(0)=DIFROOT
- .S DFR(1)=$$OREF^DILF($NA(@DIFRSA@("DATA")))_"DDF(1),D0,"
- .S DKP=$S($TR($P(DIFR01,"^",8),"O","o")="o":0,1:1)
- .S (DIFRDKPD,DIFRDKPR)=$S($TR($P(DIFR01,"^",8),"R","r")="r":1,1:0)
- .S (DIFRND0,DIFRDKP)=0
- .S:+DIFR02 (DIFRDKPD,DIFRDKPR)=0 ;if file is new Replace not needed
- .S DIFRDKPS=$P(DIFR02,"^",8) ;save local data
- .S DIFRFRV=$TR($P(DIFR01,"^",5),"Y","y")="y"
- .S D0=DIFRDA,Z=@DIFRSA@("DATA",DIFRFILE,DIFRDA,0)
- .K @DIFRSA@("TMP")
- .D I^DITR,REINDEX
- .; If no data in local fields, quit.
- .I $D(@DIFRSA@("TMP"))'>9 D KILL Q
- .; restore data in local fields from old entry
- .S DIFRDKP=1,DIFRFRV=0
- .K DFR,DA,D0
- .;S DFR(1)="^TMP(""DIFRDKPD"",$J,DIFRFILE,D0,"
- .S DFR(1)=$$OREF^DILF(DIFRSA)_"""TMP"",DIFRFILE,D0,"
- .S D0=$O(@DIFRSA@("TMP",DIFRFILE,0)) Q:'$D(^(D0,0)) S Z=^(0)
- .D I^DITR,REINDEX,KILL
- .Q
- K @DIFRSA@("TMP")
- ; DO A CHECK HERE LIKE Q:'$D(DIFQ) LATER ON
- Q
- ;
- KILL K %,%H,A,B,D,D0,D1,DA,DDF,DDT,DFL,DFN,DFR,DIC,DIFL,DIIX,DIK,DINUM,DIU
- K DKP,DMRG,DTL,DTN,DTO,I,V,W,X,Y,Z Q
- ;
- REINDEX ; REINDEX ENTRY
- Q:DIFRND0'>0
- N DIK,DA S DA=DIFRND0,DIK=DIFROOT,DIK(0)="AB"
- D IX1^DIK Q
- ;
- ERR(X) N Y S Y=$P($T(ERR+X),";",5) Q:'Y D BLD^DIALOG(Y) Q
- ;;FIA Node Is Set To "No Data";1;9509
- ;;FIA Array Does Not Exist;2;9501
- ;;;3;
- ;;Records Do Not Exist;4;9510
- ;;FIA File Number Invalid;5;9502
- ;;Partial DD. No sending of data allowed for file |1|;1;9515
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROMS4 3245 printed Feb 19, 2025@00:14:30 Page 2
- DIFROMS4 ;SFISC/DCL- DATA FROM DISTRIBUTION ARRAY ;5/24/00 15:22
- +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 ;
- +7 QUIT
- EN ;
- +1 IF '$DATA(@DIFRFIA)
- DO ERR(2)
- QUIT
- +2 ;N DIFRFILP S DIFRFILP=$D(DIFRFILP)#2
- +3 NEW %,%H,A,B,D,D0,D1,DA,DDF,DDT,DFL,DFN,DFR,DIC,DIFL,DIIX,DIK,DINUM,DIU
- +4 NEW DKP,DMRG,DTL,DTN,DTO,I,V,W,X,Y,Z
- +5 if $GET(DIFRFILE)
- GOTO FILE
- +6 SET DIFRFILE=0
- FOR
- SET DIFRFILE=$ORDER(@DIFRFIA@(DIFRFILE))
- if DIFRFILE'>0
- QUIT
- DO FILE
- +7 QUIT
- FCHK ; * * * PHASING OUT * * *
- IF '$DATA(@DIFRFIA@(DIFRFILE))
- DO ERR(5)
- QUIT
- FILE NEW DIFRDA,DIFRND0,DIFROOT,DIFR01,DIFR02,DIFRRLR,DIFRFRV
- +1 NEW DIFRDKP,DIFRDKPD,DIFRDKPR,DIFRDKPS
- +2 DO KILL
- +3 IF '$DATA(@DIFRFIA)
- DO ERR(2)
- QUIT
- +4 IF $GET(@DIFRFIA@(DIFRFILE,DIFRFILE))
- Begin DoDot:1
- +5 NEW DIFRERR
- SET DIFRERR(1)=DIFRFILE
- +6 DO BLD^DIALOG(9515,.DIFRERR)
- +7 QUIT
- End DoDot:1
- QUIT
- +8 SET DIFROOT=@DIFRFIA@(DIFRFILE,0)
- SET DIFRDA=0
- +9 SET DIFR01=@DIFRFIA@(DIFRFILE,0,1)
- SET DIFR02=$GET(^(2))
- +10 IF $PIECE(DIFR02,"^",8)=""
- SET $PIECE(DIFR02,"^",8)=$$TL^DIFROMSP(DIFRFILE,"",DIFRSA)
- +11 ; * * * phasing out * * *
- SET DIFRRLR=$GET(@DIFRFIA@(DIFRFILE,0,"RLRI"))
- +12 if DIFRRLR=""
- SET DIFRRLR=$NAME(@DIFRSA@("DATA",DIFRFILE))
- +13 IF $DATA(@DIFRRLR)'>9
- DO ERR(4)
- QUIT
- +14 ;
- +15 ; Recover from a failure in Replace Mode RE-INSTALL on target system
- +16 IF $DATA(@DIFRSA@("TMP"))
- Begin DoDot:1
- +17 SET (D,DDF(1),DDT(0))=DIFRFILE
- +18 SET DTO=0
- SET DMRG=1
- SET DTO(0)=DIFROOT
- SET DKP=$SELECT($TRANSLATE($PIECE(DIFR01,"^",8),"O","o")="o":0,1:1)
- +19 SET DFR(1)=$$OREF^DILF(DIFRSA)_"""TMP"",DIFRFILE,D0,"
- +20 SET D0=$ORDER(@DIFRSA@("TMP",DIFRFILE,0))
- if '$DATA(^(D0,0))
- QUIT
- SET Z=^(0)
- +21 DO I^DITR
- DO REINDEX
- +22 DO KILL
- QUIT
- End DoDot:1
- KILL @DIFRSA@("TMP")
- +23 ;
- +24 FOR
- SET DIFRDA=$ORDER(@DIFRRLR@(DIFRDA))
- if DIFRDA'>0
- QUIT
- Begin DoDot:1
- +25 SET (D,DDF(1),DDT(0))=DIFRFILE
- +26 SET DTO=0
- SET DMRG=1
- SET DTO(0)=DIFROOT
- +27 SET DFR(1)=$$OREF^DILF($NAME(@DIFRSA@("DATA")))_"DDF(1),D0,"
- +28 SET DKP=$SELECT($TRANSLATE($PIECE(DIFR01,"^",8),"O","o")="o":0,1:1)
- +29 SET (DIFRDKPD,DIFRDKPR)=$SELECT($TRANSLATE($PIECE(DIFR01,"^",8),"R","r")="r":1,1:0)
- +30 SET (DIFRND0,DIFRDKP)=0
- +31 ;if file is new Replace not needed
- if +DIFR02
- SET (DIFRDKPD,DIFRDKPR)=0
- +32 ;save local data
- SET DIFRDKPS=$PIECE(DIFR02,"^",8)
- +33 SET DIFRFRV=$TRANSLATE($PIECE(DIFR01,"^",5),"Y","y")="y"
- +34 SET D0=DIFRDA
- SET Z=@DIFRSA@("DATA",DIFRFILE,DIFRDA,0)
- +35 KILL @DIFRSA@("TMP")
- +36 DO I^DITR
- DO REINDEX
- +37 ; If no data in local fields, quit.
- +38 IF $DATA(@DIFRSA@("TMP"))'>9
- DO KILL
- QUIT
- +39 ; restore data in local fields from old entry
- +40 SET DIFRDKP=1
- SET DIFRFRV=0
- +41 KILL DFR,DA,D0
- +42 ;S DFR(1)="^TMP(""DIFRDKPD"",$J,DIFRFILE,D0,"
- +43 SET DFR(1)=$$OREF^DILF(DIFRSA)_"""TMP"",DIFRFILE,D0,"
- +44 SET D0=$ORDER(@DIFRSA@("TMP",DIFRFILE,0))
- if '$DATA(^(D0,0))
- QUIT
- SET Z=^(0)
- +45 DO I^DITR
- DO REINDEX
- DO KILL
- +46 QUIT
- End DoDot:1
- +47 KILL @DIFRSA@("TMP")
- +48 ; DO A CHECK HERE LIKE Q:'$D(DIFQ) LATER ON
- +49 QUIT
- +50 ;
- KILL KILL %,%H,A,B,D,D0,D1,DA,DDF,DDT,DFL,DFN,DFR,DIC,DIFL,DIIX,DIK,DINUM,DIU
- +1 KILL DKP,DMRG,DTL,DTN,DTO,I,V,W,X,Y,Z
- QUIT
- +2 ;
- REINDEX ; REINDEX ENTRY
- +1 if DIFRND0'>0
- QUIT
- +2 NEW DIK,DA
- SET DA=DIFRND0
- SET DIK=DIFROOT
- SET DIK(0)="AB"
- +3 DO IX1^DIK
- QUIT
- +4 ;
- ERR(X) NEW Y
- SET Y=$PIECE($TEXT(ERR+X),";",5)
- if 'Y
- QUIT
- DO BLD^DIALOG(Y)
- QUIT
- +1 ;;FIA Node Is Set To "No Data";1;9509
- +2 ;;FIA Array Does Not Exist;2;9501
- +3 ;;;3;
- +4 ;;Records Do Not Exist;4;9510
- +5 ;;FIA File Number Invalid;5;9502
- +6 ;;Partial DD. No sending of data allowed for file |1|;1;9515