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