DIFROMSU ;SCISC/DCL-DIFROM SERVER BUILD "FIA" SUBSCRIPTS IN TRANSPORT ARRAY ;6/2/96 18:48
;;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.
;
FIA(DIFRFILE,DIFRFLG,DIFRPFL,DIFRTAR,DIFR222,DIFR223,DIFRDSCR,DIFRVER,DIFRMSGR) ;
;FILE,FLAGS,PARTIAL_FILE_LIST,TARGET_ARRAY_ROOT,ANSWERS,DD_SCREEN,DATA_SCREEN,VERSION,MSG_ARRAY
I '$D(DIQUIET) N DIQUIET S DIQUIET=1
I '$D(DIFM) N DIFM S DIFM=1
I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
N DIFRFD,DIFRFE,DIFRX,FIELD,FIELDNR,DIFRTA,DIFRP,DIFR00
S DIFRTA=$NA(@DIFRTAR@("FIA"))
I $G(DIFRFILE)'>0 D BLD^DIALOG(9542) Q
I '$D(^DIC(DIFRFILE)) D BLD^DIALOG(9539,DIFRFILE) Q
I $P($G(DIFR222),"^",3)'="p" G F
I $G(DIFRPFL)']"" G F
I $D(@DIFRPFL)'>9 G F
G F:$O(@DIFRPFL@(0))'>0
N DIFRDDC,DIFRFLDC,DIFRTMP
K ^TMP("FIA",$J)
S DIFRDDC=0,DIFRTMP=$NA(^TMP("FIA",$J))
M @DIFRTMP=@DIFRPFL
F S DIFRDDC=$O(@DIFRTMP@(DIFRFILE,DIFRDDC)) Q:DIFRDDC'>0 D
.I '$D(^DD(DIFRDDC)) K @DIFRTMP@(DIFRFILE,DIFRDDC) D BLD^DIALOG(9540,DIFRDDC) Q
.I '$O(@DIFRTMP@(DIFRFILE,DIFRDDC,0)) D Q
..Q:@DIFRTMP@(DIFRFILE,DIFRDDC)="SUB"
..D SB^DIFROMSS(DIFRDDC,"W",$NA(@DIFRTMP@(DIFRFILE)),"SUB")
..Q
.S DIFRFLDC=0
.F S DIFRFLDC=$O(@DIFRTMP@(DIFRFILE,DIFRDDC,DIFRFLDC)) Q:DIFRFLDC'>0 D
..I '$D(^DD(DIFRDDC,DIFRFLDC,0)) K @DIFRTMP@(DIFRFILE,DIFRDDC,DIFRFLDC) D Q
...N DIFRX S DIFRX(1)=DIFRFLDC,DIFRX(2)=DIFRDDC
...D BLD^DIALOG(9541,.DIFRX)
...Q
..I $P(^DD(DIFRDDC,DIFRFLDC,0),"^",2) S DIFRX=$P(^DD(+$P(^(0),"^",2),.01,0),"^",2) D
...I DIFRX["W" S @DIFRTMP@(DIFRFILE,+$P(^DD(DIFRDDC,DIFRFLDC,0),"^",2))=0 Q
...K @DIFRTMP@(DIFRFILE,DIFRDDC,DIFRFLDC)
...Q
..Q
.Q
;
M @DIFRTA@(DIFRFILE)=@DIFRTMP@(DIFRFILE)
K @DIFRTMP
;
I $D(@DIFRTA@(DIFRFILE,DIFRFILE))=1 G F
S @DIFRTA@(DIFRFILE,DIFRFILE)=1,DIFRFE=DIFRFILE
;F S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0 S:$P(^DD(DIFRFE,.01,0),"^",2)'["W" @DIFRTA@(DIFRFILE,DIFRFE,.01)=0
F S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0 D
.S @DIFRTA@(DIFRFILE,DIFRFE)=$D(@DIFRTA@(DIFRFILE,DIFRFE))>9
.N DIFRX,DIFRY
.S DIFRY=$$UP^DIQGU(DIFRFE,.DIFRX)
.Q:'$D(DIFRX)
.;K DIFRX($O(DIFRX(""))) <<REMOVED IN PATCH 10>>
.M @DIFRTAR@("UP",DIFRFILE,DIFRFE)=DIFRX
.Q
S DIFRFE=DIFRFILE
F S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0 D:'^(DIFRFE)!($D(@DIFRTA@(DIFRFILE,DIFRFE,.01)))
.Q:'$D(^DD(DIFRFE,0,"UP"))
.N DIFRUP,DIFRFLD
.S DIFRUP=^DD(DIFRFE,0,"UP"),DIFRFLD=$O(^DD(DIFRUP,"SB",DIFRFE,0))
.Q:$G(@DIFRTA@(DIFRFILE,DIFRUP))=0!($D(@DIFRTA@(DIFRFILE,DIFRUP,DIFRFLD)))
.S @DIFRTA@(DIFRFILE,DIFRUP,DIFRFLD)=""
.Q:$D(@DIFRTA@(DIFRFILE,DIFRUP))#2
.S @DIFRTA@(DIFRFILE,DIFRUP)=1
.Q
;
G G
F S @DIFRTA@(DIFRFILE,DIFRFILE)=0,DIFRFE=0
S:$P(DIFR222,"^",3)'="f" $P(DIFR222,"^",3)="f"
E F S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0 D
.S DIFRFD=0
.F S DIFRFD=$O(^DD(DIFRFE,"SB",DIFRFD)) Q:DIFRFD'>0 S @DIFRTA@(DIFRFILE,DIFRFD)=0
.Q
G S @DIFRTA@(DIFRFILE)=$P(^DIC(DIFRFILE,0),"^")
S (DIFR00,@DIFRTA@(DIFRFILE,0))=^DIC(DIFRFILE,0,"GL")
S @DIFRTA@(DIFRFILE,0,0)=$P(@(DIFR00_"0)"),"^",2)
S @DIFRTA@(DIFRFILE,0,1)=$G(DIFR222)
S @DIFRTA@(DIFRFILE,0,10)=$G(DIFR223)
S @DIFRTA@(DIFRFILE,0,11)=$G(DIFRDSCR)
S @DIFRTA@(DIFRFILE,0,"RLRO")=$$ROOT($P(DIFR222,"^",6))
I $G(DIFRVER)]"" S @DIFRTA@(DIFRFILE,0,"VR")=DIFRVER
FE I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR)
Q
;
ERR501(DIFRFILE,DIFRFLD) ; 501 Errors
N DIFRERRX
S DIFRERRX("FILE")=DIFRFILE,DIFRERRX(1)=DIFRFLD
D BLD^DIALOG(501,.DIFRERRX)
Q
ROOT(IEN) ;Create root from DIBT(ien
;
I $G(IEN)>0,$D(^DIBT(IEN,1))>9 Q "^DIBT("_IEN_",1)"
I $G(IEN)]"" S IEN=$O(^DIBT("F"_DIFRFILE,IEN,"")) Q:IEN>0 $$ROOT(IEN)
Q ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROMSU 3942 printed Dec 13, 2024@02:48:27 Page 2
DIFROMSU ;SCISC/DCL-DIFROM SERVER BUILD "FIA" SUBSCRIPTS IN TRANSPORT ARRAY ;6/2/96 18:48
+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 ;
FIA(DIFRFILE,DIFRFLG,DIFRPFL,DIFRTAR,DIFR222,DIFR223,DIFRDSCR,DIFRVER,DIFRMSGR) ;
+1 ;FILE,FLAGS,PARTIAL_FILE_LIST,TARGET_ARRAY_ROOT,ANSWERS,DD_SCREEN,DATA_SCREEN,VERSION,MSG_ARRAY
+2 IF '$DATA(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+3 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
+4 IF $GET(U)'="^"!($GET(DT)'>0)!($GET(DTIME)'>0)!('$DATA(DUZ))
DO DT^DICRW
+5 NEW DIFRFD,DIFRFE,DIFRX,FIELD,FIELDNR,DIFRTA,DIFRP,DIFR00
+6 SET DIFRTA=$NAME(@DIFRTAR@("FIA"))
+7 IF $GET(DIFRFILE)'>0
DO BLD^DIALOG(9542)
QUIT
+8 IF '$DATA(^DIC(DIFRFILE))
DO BLD^DIALOG(9539,DIFRFILE)
QUIT
+9 IF $PIECE($GET(DIFR222),"^",3)'="p"
GOTO F
+10 IF $GET(DIFRPFL)']""
GOTO F
+11 IF $DATA(@DIFRPFL)'>9
GOTO F
+12 if $ORDER(@DIFRPFL@(0))'>0
GOTO F
+13 NEW DIFRDDC,DIFRFLDC,DIFRTMP
+14 KILL ^TMP("FIA",$JOB)
+15 SET DIFRDDC=0
SET DIFRTMP=$NAME(^TMP("FIA",$JOB))
+16 MERGE @DIFRTMP=@DIFRPFL
+17 FOR
SET DIFRDDC=$ORDER(@DIFRTMP@(DIFRFILE,DIFRDDC))
if DIFRDDC'>0
QUIT
Begin DoDot:1
+18 IF '$DATA(^DD(DIFRDDC))
KILL @DIFRTMP@(DIFRFILE,DIFRDDC)
DO BLD^DIALOG(9540,DIFRDDC)
QUIT
+19 IF '$ORDER(@DIFRTMP@(DIFRFILE,DIFRDDC,0))
Begin DoDot:2
+20 if @DIFRTMP@(DIFRFILE,DIFRDDC)="SUB"
QUIT
+21 DO SB^DIFROMSS(DIFRDDC,"W",$NAME(@DIFRTMP@(DIFRFILE)),"SUB")
+22 QUIT
End DoDot:2
QUIT
+23 SET DIFRFLDC=0
+24 FOR
SET DIFRFLDC=$ORDER(@DIFRTMP@(DIFRFILE,DIFRDDC,DIFRFLDC))
if DIFRFLDC'>0
QUIT
Begin DoDot:2
+25 IF '$DATA(^DD(DIFRDDC,DIFRFLDC,0))
KILL @DIFRTMP@(DIFRFILE,DIFRDDC,DIFRFLDC)
Begin DoDot:3
+26 NEW DIFRX
SET DIFRX(1)=DIFRFLDC
SET DIFRX(2)=DIFRDDC
+27 DO BLD^DIALOG(9541,.DIFRX)
+28 QUIT
End DoDot:3
QUIT
+29 IF $PIECE(^DD(DIFRDDC,DIFRFLDC,0),"^",2)
SET DIFRX=$PIECE(^DD(+$PIECE(^(0),"^",2),.01,0),"^",2)
Begin DoDot:3
+30 IF DIFRX["W"
SET @DIFRTMP@(DIFRFILE,+$PIECE(^DD(DIFRDDC,DIFRFLDC,0),"^",2))=0
QUIT
+31 KILL @DIFRTMP@(DIFRFILE,DIFRDDC,DIFRFLDC)
+32 QUIT
End DoDot:3
+33 QUIT
End DoDot:2
+34 QUIT
End DoDot:1
+35 ;
+36 MERGE @DIFRTA@(DIFRFILE)=@DIFRTMP@(DIFRFILE)
+37 KILL @DIFRTMP
+38 ;
+39 IF $DATA(@DIFRTA@(DIFRFILE,DIFRFILE))=1
GOTO F
+40 SET @DIFRTA@(DIFRFILE,DIFRFILE)=1
SET DIFRFE=DIFRFILE
+41 ;F S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0 S:$P(^DD(DIFRFE,.01,0),"^",2)'["W" @DIFRTA@(DIFRFILE,DIFRFE,.01)=0
+42 FOR
SET DIFRFE=$ORDER(@DIFRTA@(DIFRFILE,DIFRFE))
if DIFRFE'>0
QUIT
Begin DoDot:1
+43 SET @DIFRTA@(DIFRFILE,DIFRFE)=$DATA(@DIFRTA@(DIFRFILE,DIFRFE))>9
+44 NEW DIFRX,DIFRY
+45 SET DIFRY=$$UP^DIQGU(DIFRFE,.DIFRX)
+46 if '$DATA(DIFRX)
QUIT
+47 ;K DIFRX($O(DIFRX(""))) <<REMOVED IN PATCH 10>>
+48 MERGE @DIFRTAR@("UP",DIFRFILE,DIFRFE)=DIFRX
+49 QUIT
End DoDot:1
+50 SET DIFRFE=DIFRFILE
+51 FOR
SET DIFRFE=$ORDER(@DIFRTA@(DIFRFILE,DIFRFE))
if DIFRFE'>0
QUIT
if '^(DIFRFE)!($DATA(@DIFRTA@(DIFRFILE,DIFRFE,.01)))
Begin DoDot:1
+52 if '$DATA(^DD(DIFRFE,0,"UP"))
QUIT
+53 NEW DIFRUP,DIFRFLD
+54 SET DIFRUP=^DD(DIFRFE,0,"UP")
SET DIFRFLD=$ORDER(^DD(DIFRUP,"SB",DIFRFE,0))
+55 if $GET(@DIFRTA@(DIFRFILE,DIFRUP))=0!($DATA(@DIFRTA@(DIFRFILE,DIFRUP,DIFRFLD)))
QUIT
+56 SET @DIFRTA@(DIFRFILE,DIFRUP,DIFRFLD)=""
+57 if $DATA(@DIFRTA@(DIFRFILE,DIFRUP))#2
QUIT
+58 SET @DIFRTA@(DIFRFILE,DIFRUP)=1
+59 QUIT
End DoDot:1
+60 ;
+61 GOTO G
F SET @DIFRTA@(DIFRFILE,DIFRFILE)=0
SET DIFRFE=0
+1 if $PIECE(DIFR222,"^",3)'="f"
SET $PIECE(DIFR222,"^",3)="f"
E FOR
SET DIFRFE=$ORDER(@DIFRTA@(DIFRFILE,DIFRFE))
if DIFRFE'>0
QUIT
Begin DoDot:1
+1 SET DIFRFD=0
+2 FOR
SET DIFRFD=$ORDER(^DD(DIFRFE,"SB",DIFRFD))
if DIFRFD'>0
QUIT
SET @DIFRTA@(DIFRFILE,DIFRFD)=0
+3 QUIT
End DoDot:1
G SET @DIFRTA@(DIFRFILE)=$PIECE(^DIC(DIFRFILE,0),"^")
+1 SET (DIFR00,@DIFRTA@(DIFRFILE,0))=^DIC(DIFRFILE,0,"GL")
+2 SET @DIFRTA@(DIFRFILE,0,0)=$PIECE(@(DIFR00_"0)"),"^",2)
+3 SET @DIFRTA@(DIFRFILE,0,1)=$GET(DIFR222)
+4 SET @DIFRTA@(DIFRFILE,0,10)=$GET(DIFR223)
+5 SET @DIFRTA@(DIFRFILE,0,11)=$GET(DIFRDSCR)
+6 SET @DIFRTA@(DIFRFILE,0,"RLRO")=$$ROOT($PIECE(DIFR222,"^",6))
+7 IF $GET(DIFRVER)]""
SET @DIFRTA@(DIFRFILE,0,"VR")=DIFRVER
FE IF $GET(DIFRMSGR)]""
DO CALLOUT^DIEFU(DIFRMSGR)
+1 QUIT
+2 ;
ERR501(DIFRFILE,DIFRFLD) ; 501 Errors
+1 NEW DIFRERRX
+2 SET DIFRERRX("FILE")=DIFRFILE
SET DIFRERRX(1)=DIFRFLD
+3 DO BLD^DIALOG(501,.DIFRERRX)
+4 QUIT
ROOT(IEN) ;Create root from DIBT(ien
+1 ;
+2 IF $GET(IEN)>0
IF $DATA(^DIBT(IEN,1))>9
QUIT "^DIBT("_IEN_",1)"
+3 IF $GET(IEN)]""
SET IEN=$ORDER(^DIBT("F"_DIFRFILE,IEN,""))
if IEN>0
QUIT $$ROOT(IEN)
+4 QUIT ""
