DIFROMSR ;SFISC/DCL,TKW-RESOLVE POINTERS ON TARGET SYSTEM ;5/14/98 12:29
;;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
RP(DIFRFLG,DIFRFIA,DIFRSA,DIFRMSGR) ; Resolve Pointers on Target System
;The "FRV1" and "FRVL" structures within the
;transport array are used.
;FILE,FLAGS,FIAROOT,SOURCE_ARRAY,MSG_ROOT
;*
;FLAGS=(RESERVED FOR LATER USE)
; (Optional)
; None
;*
;FIA_ARRAY="FIA"_ARRAY_INPUT_ARRAY_ROOT
; (Optional) - Close Input Array Reference
; See DIFROM SERVER documentation for FIA array structure
; definitions. If undefined SOURCE_ARRAY will be used
; by appending "FIA" to the source array root subscript.
;*
;SOURCE_ARRAY=CLOSED_INPUT_ARRAY_ROOT
; (Required) - Closed Input Array Reference where the file data
; is temporarily stored for distribution.
;*
;MSG_ROOT=CLOSED ARRAY REFERENCE
; (Optional) - Closed array reference where messages such as
; errors will be returned. If not passed, decendents of ^TMP
; will be used.
;*
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
I $G(DIFRSA)']"" D ERR(6) G EXIT
S DIFRFIA=$G(DIFRFIA) S:DIFRFIA="" DIFRFIA=$NA(@DIFRSA@("FIA"))
;
I '$D(DIFRFIA) D ERR(2) G EXIT
N DIFRFRVX,DIFRFILE
S DIFRFRVX="FRV1",DIFRFILE=0 F S DIFRFILE=$O(@DIFRSA@(DIFRFRVX,DIFRFILE)) Q:DIFRFILE'>0 D FILE
G EXIT
;
FILE N DIFRTART,DIFRDNSC,DIFRPCE,DIFRSDA,DIFRY,DIFRPRV,DIFRPTF,DIFRPTFR,DIFRPRVL,DIFR2DD,DIFRTARL
N C,D0,DA,DIC,DIK,F,G,I,R1,R2,R3,X,Y
S DIFRTART=$NA(@DIFRSA@(DIFRFRVX,DIFRFILE))
S DIFRTARL=$NA(@DIFRSA@("FRVL",DIFRFILE))
S DIFRSDA=$$OREF^DILF($NA(@DIFRSA@("DATA",DIFRFILE))),DIFRDNSC=""
F S DIFRDNSC=$O(@DIFRTART@(DIFRDNSC)) Q:DIFRDNSC="" D
.K R1
.S R2=DIFRDNSC,C=$P(R2,","),F=1,R1=0
.F I=1:1 Q:I>C S G=$P(R2,",",F,I) Q:G="" I G'[""""!($L(G,"""")#2&($E(G)="""")&($E(G,$L(G))="""")) S F=F+$L(G,","),I=F-1,R1(R1)=G,R1=R1+1,C=C+($L(G,",")-1)
.I R1'>3 S DIFR2DD=DIFRFILE
.E D
..S R3=""
..F I=0:1:R1-3 S R3=R3_R1(I)_","
..S DIFR2DD=+$P($G(@(DIFRSDA_R3_"0)")),"^",2)
..Q
.;
.S DIFRPCE=""
.F S DIFRPCE=$O(@DIFRTART@(DIFRDNSC,DIFRPCE)) Q:DIFRPCE'>0 D
..S DIFRPRV=$G(@DIFRTART@(DIFRDNSC,DIFRPCE)),DIFRPTF=$G(^(DIFRPCE,"F"))
..S DIFRPRVL=$G(@DIFRTARL@(DIFRDNSC)),DIFRPTFR=$P(DIFRPTF,";",2)
..I DIFRPRVL="" D ERR(7," (^"_DIFRPTFR_"/"_DIFRPRV_")") Q
..I DIFRPTFR="" D ERR(8," ("_DIFRPRVL_"/"_DIFRPRV_")") Q
..I DIFRPRV="" D ERR(9," (^"_DIFRPTFR_"/"_DIFRPRVL_")") Q
..I '$D(@("^"_DIFRPTFR_"0)")) D ERR(10," (^"_DIFRPTFR_"/"_DIFRPRV_")") Q
..D LOOKUP
..I +Y'>0 D ERR(11," ("_DIC_" Entry:"_DIFRPRV_")") S Y=-1
..S DIFRY=+Y S:DIFRPTF DIFRY=+Y_";"_DIFRPTFR
..S $P(@DIFRPRVL,"^",DIFRPCE)=DIFRY
..Q
;
S DIK=@DIFRFIA@(DIFRFILE,0),DIK(0)="AB"
D IXALL^DIK:$O(@(DIK_"0)"))
;
Q
;
LOOKUP ; Lookup entry on pointed-to file
N DIFRS S DIFRS=$NA(@DIFRSA@("FRV1K",DIFRFILE,DIFRDNSC,DIFRPCE))
S DIC="^"_DIFRPTFR
I '$O(@DIFRS@(0)) S DIC(0)="X",X=DIFRPRV D ^DIC Q
N DIFL,DIKEY,I,DIFRVAL
S DIKEY=@DIFRS
S DIFL=+$P(@("^"_DIFRPTFR_"0)"),U,2) I 'DIFL S Y=-1 Q
F I=0:0 S I=$O(@DIFRS@(I)) Q:'I S DIFRVAL(I)=@DIFRS@(I)
S Y=$$FIND1^DIC(DIFL,",","X",.DIFRVAL,DIKEY)
S:'Y Y=-1 Q
;
EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR)
Q
ERR(X,Y) S X=$P($T(ERR+X),";",5) S:$D(Y) Y(1)=Y Q:'X D BLD^DIALOG(X,.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
;;Source Array Root Missing;6;9533
;;Resolved Value Data Link Missing;7;9534
;;Pointed Too File Missing;8;9535
;;Pointer Resolved Value Missing;9;9538
;;Pointed Too File NOT on Target System;10;9536
;;Unable To Find Exact Match And Resolve Pointer;11;9537
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROMSR 4095 printed Apr 09, 2024@21:45:06 Page 2
DIFROMSR ;SFISC/DCL,TKW-RESOLVE POINTERS ON TARGET SYSTEM ;5/14/98 12:29
+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
RP(DIFRFLG,DIFRFIA,DIFRSA,DIFRMSGR) ; Resolve Pointers on Target System
+1 ;The "FRV1" and "FRVL" structures within the
+2 ;transport array are used.
+3 ;FILE,FLAGS,FIAROOT,SOURCE_ARRAY,MSG_ROOT
+4 ;*
+5 ;FLAGS=(RESERVED FOR LATER USE)
+6 ; (Optional)
+7 ; None
+8 ;*
+9 ;FIA_ARRAY="FIA"_ARRAY_INPUT_ARRAY_ROOT
+10 ; (Optional) - Close Input Array Reference
+11 ; See DIFROM SERVER documentation for FIA array structure
+12 ; definitions. If undefined SOURCE_ARRAY will be used
+13 ; by appending "FIA" to the source array root subscript.
+14 ;*
+15 ;SOURCE_ARRAY=CLOSED_INPUT_ARRAY_ROOT
+16 ; (Required) - Closed Input Array Reference where the file data
+17 ; is temporarily stored for distribution.
+18 ;*
+19 ;MSG_ROOT=CLOSED ARRAY REFERENCE
+20 ; (Optional) - Closed array reference where messages such as
+21 ; errors will be returned. If not passed, decendents of ^TMP
+22 ; will be used.
+23 ;*
+24 IF '$DATA(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+25 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
+26 IF $GET(U)'="^"!($GET(DT)'>0)!($GET(DTIME)'>0)!('$DATA(DUZ))
DO DT^DICRW
+27 IF $GET(DIFRSA)']""
DO ERR(6)
GOTO EXIT
+28 SET DIFRFIA=$GET(DIFRFIA)
if DIFRFIA=""
SET DIFRFIA=$NAME(@DIFRSA@("FIA"))
+29 ;
+30 IF '$DATA(DIFRFIA)
DO ERR(2)
GOTO EXIT
+31 NEW DIFRFRVX,DIFRFILE
+32 SET DIFRFRVX="FRV1"
SET DIFRFILE=0
FOR
SET DIFRFILE=$ORDER(@DIFRSA@(DIFRFRVX,DIFRFILE))
if DIFRFILE'>0
QUIT
DO FILE
+33 GOTO EXIT
+34 ;
FILE NEW DIFRTART,DIFRDNSC,DIFRPCE,DIFRSDA,DIFRY,DIFRPRV,DIFRPTF,DIFRPTFR,DIFRPRVL,DIFR2DD,DIFRTARL
+1 NEW C,D0,DA,DIC,DIK,F,G,I,R1,R2,R3,X,Y
+2 SET DIFRTART=$NAME(@DIFRSA@(DIFRFRVX,DIFRFILE))
+3 SET DIFRTARL=$NAME(@DIFRSA@("FRVL",DIFRFILE))
+4 SET DIFRSDA=$$OREF^DILF($NAME(@DIFRSA@("DATA",DIFRFILE)))
SET DIFRDNSC=""
+5 FOR
SET DIFRDNSC=$ORDER(@DIFRTART@(DIFRDNSC))
if DIFRDNSC=""
QUIT
Begin DoDot:1
+6 KILL R1
+7 SET R2=DIFRDNSC
SET C=$PIECE(R2,",")
SET F=1
SET R1=0
+8 FOR I=1:1
if I>C
QUIT
SET G=$PIECE(R2,",",F,I)
if G=""
QUIT
IF G'[""""!($LENGTH(G,"""")#2&($EXTRACT(G)="""")&($EXTRACT(G,$LENGTH(G))=""""))
SET F=F+$LENGTH(G,",")
SET I=F-1
SET R1(R1)=G
SET R1=R1+1
SET C=C+($LENGTH(G,",")-1)
+9 IF R1'>3
SET DIFR2DD=DIFRFILE
+10 IF '$TEST
Begin DoDot:2
+11 SET R3=""
+12 FOR I=0:1:R1-3
SET R3=R3_R1(I)_","
+13 SET DIFR2DD=+$PIECE($GET(@(DIFRSDA_R3_"0)")),"^",2)
+14 QUIT
End DoDot:2
+15 ;
+16 SET DIFRPCE=""
+17 FOR
SET DIFRPCE=$ORDER(@DIFRTART@(DIFRDNSC,DIFRPCE))
if DIFRPCE'>0
QUIT
Begin DoDot:2
+18 SET DIFRPRV=$GET(@DIFRTART@(DIFRDNSC,DIFRPCE))
SET DIFRPTF=$GET(^(DIFRPCE,"F"))
+19 SET DIFRPRVL=$GET(@DIFRTARL@(DIFRDNSC))
SET DIFRPTFR=$PIECE(DIFRPTF,";",2)
+20 IF DIFRPRVL=""
DO ERR(7," (^"_DIFRPTFR_"/"_DIFRPRV_")")
QUIT
+21 IF DIFRPTFR=""
DO ERR(8," ("_DIFRPRVL_"/"_DIFRPRV_")")
QUIT
+22 IF DIFRPRV=""
DO ERR(9," (^"_DIFRPTFR_"/"_DIFRPRVL_")")
QUIT
+23 IF '$DATA(@("^"_DIFRPTFR_"0)"))
DO ERR(10," (^"_DIFRPTFR_"/"_DIFRPRV_")")
QUIT
+24 DO LOOKUP
+25 IF +Y'>0
DO ERR(11," ("_DIC_" Entry:"_DIFRPRV_")")
SET Y=-1
+26 SET DIFRY=+Y
if DIFRPTF
SET DIFRY=+Y_";"_DIFRPTFR
+27 SET $PIECE(@DIFRPRVL,"^",DIFRPCE)=DIFRY
+28 QUIT
End DoDot:2
End DoDot:1
+29 ;
+30 SET DIK=@DIFRFIA@(DIFRFILE,0)
SET DIK(0)="AB"
+31 if $ORDER(@(DIK_"0)"))
DO IXALL^DIK
+32 ;
+33 QUIT
+34 ;
LOOKUP ; Lookup entry on pointed-to file
+1 NEW DIFRS
SET DIFRS=$NAME(@DIFRSA@("FRV1K",DIFRFILE,DIFRDNSC,DIFRPCE))
+2 SET DIC="^"_DIFRPTFR
+3 IF '$ORDER(@DIFRS@(0))
SET DIC(0)="X"
SET X=DIFRPRV
DO ^DIC
QUIT
+4 NEW DIFL,DIKEY,I,DIFRVAL
+5 SET DIKEY=@DIFRS
+6 SET DIFL=+$PIECE(@("^"_DIFRPTFR_"0)"),U,2)
IF 'DIFL
SET Y=-1
QUIT
+7 FOR I=0:0
SET I=$ORDER(@DIFRS@(I))
if 'I
QUIT
SET DIFRVAL(I)=@DIFRS@(I)
+8 SET Y=$$FIND1^DIC(DIFL,",","X",.DIFRVAL,DIKEY)
+9 if 'Y
SET Y=-1
QUIT
+10 ;
EXIT IF $GET(DIFRMSGR)]""
DO CALLOUT^DIEFU(DIFRMSGR)
+1 QUIT
ERR(X,Y) SET X=$PIECE($TEXT(ERR+X),";",5)
if $DATA(Y)
SET Y(1)=Y
if 'X
QUIT
DO BLD^DIALOG(X,.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 ;;Source Array Root Missing;6;9533
+7 ;;Resolved Value Data Link Missing;7;9534
+8 ;;Pointed Too File Missing;8;9535
+9 ;;Pointer Resolved Value Missing;9;9538
+10 ;;Pointed Too File NOT on Target System;10;9536
+11 ;;Unable To Find Exact Match And Resolve Pointer;11;9537
