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