DIFROMS3 ;SFISC/DCL,TKW- DATA TO DISTRIBUTION ARRAY ;5/14/98 12:30
;;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
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 DIFRS,DIFRSCR,DIFRDA,DIFROOT,DIFRRLR,DIFR01,DIFRPR,DIFRDNSC,DIFRFRV,DIFRFRVX
N DIFRQ,DIFRTART,DIFRK,R,R1,R2,R3,C,F,G,I,DIFR2DD,DIFRNODE,DIFRFELD,DIFRPCE,DIFRIENS,DIFRDD0
S DIFR01=$G(@DIFRFIA@(DIFRFILE,0,1)),DIFRPR=$TR($P(DIFR01,"^",5),"Y","y")="y"
I $TR($P(DIFR01,"^",7),"Y","y")'="y" Q
I DIFRPR D PGL^DIFROMSP(DIFRFILE,"",DIFRTA)
S DIFRS=$G(@DIFRFIA@(DIFRFILE,0,11))]"",DIFRSCR=$G(^(11))
S DIFROOT=$NA(@($$ROOT^DILFD(DIFRFILE,"",1))),DIFRDA=0 ;$NA/trans gbl $Q
S DIFRRLR=$G(@DIFRFIA@(DIFRFILE,0,"RLRO"))
S:DIFRRLR="" DIFRRLR=DIFROOT
I $D(@DIFRRLR)'>9 D ERR(4) Q
N Y
F S DIFRDA=$O(@DIFRRLR@(DIFRDA)) Q:DIFRDA'>0 D
.I '$D(@DIFROOT@(DIFRDA,0)) D Q
..N DIFRERR S DIFRERR(1)=DIFRDA,DIFRERR(2)=DIFRFILE
..D BLD^DIALOG(9513,.DIFRERR)
..Q
.I DIFRS,$D(@DIFRRLR@(DIFRDA,0)) S Y=DIFRDA X DIFRSCR Q:'$T ;set *NAKED* and *Y*
.M @DIFRTA@("DATA",DIFRFILE,DIFRDA)=@DIFROOT@(DIFRDA)
.Q
S DIFRQ=$NA(@DIFRTA@("DATA",DIFRFILE)) ;$NA/trans gbl/$Q
S DIFRTART=$$OREF^DILF(DIFRQ)
F S DIFRQ=$Q(@DIFRQ) Q:$P(DIFRQ,DIFRTART)]""!(DIFRQ="") D:$P(DIFRQ,DIFRTART,2,99)[""""!(DIFRPR)
.K R1
.S DIFRK=1
.S R2=$P(DIFRQ,DIFRTART,2,99),$E(R2,$L(R2))="",C=$L(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 'G,G'?1"0".E,R1#2 S DIFRK=DIFRTART_$P(R2,",",1,I)_")" Q
.I DIFRPR,DIFRK,'(R1#2) D Q ;RESOLVE POINTERS
..D Q:DIFR2DD'>0
...I R1'>3 S DIFR2DD=DIFRFILE Q
...S R3=""
...F I=0:1:R1-3 S R3=R3_R1(I)_","
...S DIFR2DD=+$P($G(@(DIFRTART_R3_"0)")),"^",2)
...Q
..S DIFRNODE=R1($O(R1(""),-1)),DIFRDNSC=R2
..Q:'$D(@DIFRTA@("PGL",DIFR2DD,DIFRNODE))
..S DIFRPCE=0
..F S DIFRPCE=$O(@DIFRTA@("PGL",DIFR2DD,DIFRNODE,DIFRPCE)) Q:DIFRPCE="" D:DIFRPCE>0
...Q:$P(@DIFRQ,"^",DIFRPCE)=""
...S DIFRFELD=$O(@DIFRTA@("PGL",DIFR2DD,DIFRNODE,DIFRPCE,"")),(I,DIFRIENS)=""
...;CREATE IENS * * * * * * * * * * * * * * * * *
...F S I=$O(R1(I),-1) Q:I="" S:'(I#2) DIFRIENS=DIFRIENS_R1(I)_","
...S DIFRDD0=^DD(DIFR2DD,DIFRFELD,0)
...D DIERR
...S DIFRFRV=$$GET1^DIQ(DIFR2DD,DIFRIENS,DIFRFELD)
...D DIERR
...I DIFRFRV']"" D Q
....N DIFRERR
....S DIFRERR(1)=DIFR2DD,DIFRERR(2)=DIFRIENS,DIFRERR(3)=DIFRFELD
....D BLD^DIALOG(9514,.DIFRERR)
....D DIERR
....Q
...S DIFRFRVX="FRV1"
...; If .01 field on file level is a pointer use "FRV0" subscript
...;I R1'>3,DIFRPCE=1,DIFRNODE=0 S DIFRFRVX="FRV0"
...S @DIFRTA@(DIFRFRVX,DIFRFILE,DIFRDNSC,DIFRPCE)=DIFRFRV
...S @DIFRTA@(DIFRFRVX,DIFRFILE,DIFRDNSC,DIFRPCE,"F")=$S($P(DIFRDD0,"^",2)["P":";"_$P(DIFRDD0,"^",3),$P(DIFRDD0,"^",2)["V":"1;"_$P($P(@DIFRQ,"^",DIFRPCE),";",2),1:"")
...D KEYVAL
...Q
..Q
..;Q:IF HEADER NODE OR IF NOT DATA NODE THEN FIND DD AND CHECK
..; IF DD#,"PGL",DATA NODE EXIST IF SO GET PIECE AND FIELD
..; AND SET IT UP INTO A STRUCTURE ; ALL RESOLVED; .01,IDs AND PTR.
..;IT WAS DECIDED NOT TO RESOLVE .01 AND ID POINTERS
..Q
.Q:DIFRK
.K @DIFRK
.Q
Q
;
KEYVAL ; Send KEY values if pointed-to file has a primary KEY
N DIFL S DIFL=$P(DIFRDD0,"^",2)
I DIFL["P" S DIFL=+$P(DIFL,"P",2)
E D
. S DIFL=$P($P(@DIFRQ,"^",DIFRPCE),";",2)
. S DIFL=+$P($G(@("^"_DIFL_"0)")),"^",2) Q
Q:'DIFL
N DIKEY S DIKEY=$O(^DD("KEY","AP",DIFL,"P",0)) Q:'DIKEY
N X,DIOUT S DIOUT=0 D Q:DIOUT
. S X=$P(^DD("KEY",DIKEY,0),U,4) I 'X S DIOUT=1 Q
. S X=$P($G(^DD("IX",X,0)),U,2) I X="" S DIOUT=1 Q
. S @DIFRTA@("FRV1K",DIFRFILE,DIFRDNSC,DIFRPCE)=X Q
N DIFLD,DIVAL,DIPTR,DIER,DIERR,DIFLDDA,DISEQ
S DIPTR=+$P(@DIFRQ,"^",DIFRPCE),DIFLDDA=0,DIOUT=0
F S DIFLDDA=$O(^DD("KEY",DIKEY,2,DIFLDDA)) Q:'DIFLDDA S X=$G(^(DIFLDDA,0)) D Q:DIOUT
. S DIFLD=$P(X,U),DISEQ=$P(X,U,3) I 'DISEQ S DIOUT=1 Q
. I $P(X,U,2)'=DIFL S DIOUT=1 Q
. I DIFLD=.01 S DIVAL=DIFRFRV
. E S DIVAL=$$GET1^DIQ(DIFL,DIPTR_",",DIFLD,"","","DIER")
. I $D(DIER) K DIER S DIOUT=1 Q
. S @DIFRTA@("FRV1K",DIFRFILE,DIFRDNSC,DIFRPCE,DISEQ)=DIVAL
. Q
I DIOUT K @DIFRTA@("FRV1K",DIFRFILE,DIFRDNSC,DIFRPCE)
Q
;
DIERR I $G(DIERR) S DIFRERRC=$$ERRC($G(DIFRERRC),DIERR) K DIERR
Q
;
ERRC(X,Y) ;
S X=$G(X),Y=$G(Y)
S $P(X,"^")=+X+Y,$P(X,"^",2)=$P(X,"^",2)+$P(Y,"^",2)
Q X
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROMS3 5039 printed Apr 09, 2024@21:53:17 Page 2
DIFROMS3 ;SFISC/DCL,TKW- DATA TO DISTRIBUTION ARRAY ;5/14/98 12:30
+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 if $GET(DIFRFILE)
GOTO FILE
+3 SET DIFRFILE=0
FOR
SET DIFRFILE=$ORDER(@DIFRFIA@(DIFRFILE))
if DIFRFILE'>0
QUIT
DO FILE
+4 QUIT
FCHK ; * * * * PHASING OUT * * * *
IF '$DATA(@DIFRFIA@(DIFRFILE))
DO ERR(5)
QUIT
FILE NEW DIFRS,DIFRSCR,DIFRDA,DIFROOT,DIFRRLR,DIFR01,DIFRPR,DIFRDNSC,DIFRFRV,DIFRFRVX
+1 NEW DIFRQ,DIFRTART,DIFRK,R,R1,R2,R3,C,F,G,I,DIFR2DD,DIFRNODE,DIFRFELD,DIFRPCE,DIFRIENS,DIFRDD0
+2 SET DIFR01=$GET(@DIFRFIA@(DIFRFILE,0,1))
SET DIFRPR=$TRANSLATE($PIECE(DIFR01,"^",5),"Y","y")="y"
+3 IF $TRANSLATE($PIECE(DIFR01,"^",7),"Y","y")'="y"
QUIT
+4 IF DIFRPR
DO PGL^DIFROMSP(DIFRFILE,"",DIFRTA)
+5 SET DIFRS=$GET(@DIFRFIA@(DIFRFILE,0,11))]""
SET DIFRSCR=$GET(^(11))
+6 ;$NA/trans gbl $Q
SET DIFROOT=$NAME(@($$ROOT^DILFD(DIFRFILE,"",1)))
SET DIFRDA=0
+7 SET DIFRRLR=$GET(@DIFRFIA@(DIFRFILE,0,"RLRO"))
+8 if DIFRRLR=""
SET DIFRRLR=DIFROOT
+9 IF $DATA(@DIFRRLR)'>9
DO ERR(4)
QUIT
+10 NEW Y
+11 FOR
SET DIFRDA=$ORDER(@DIFRRLR@(DIFRDA))
if DIFRDA'>0
QUIT
Begin DoDot:1
+12 IF '$DATA(@DIFROOT@(DIFRDA,0))
Begin DoDot:2
+13 NEW DIFRERR
SET DIFRERR(1)=DIFRDA
SET DIFRERR(2)=DIFRFILE
+14 DO BLD^DIALOG(9513,.DIFRERR)
+15 QUIT
End DoDot:2
QUIT
+16 ;set *NAKED* and *Y*
IF DIFRS
IF $DATA(@DIFRRLR@(DIFRDA,0))
SET Y=DIFRDA
XECUTE DIFRSCR
if '$TEST
QUIT
+17 MERGE @DIFRTA@("DATA",DIFRFILE,DIFRDA)=@DIFROOT@(DIFRDA)
+18 QUIT
End DoDot:1
+19 ;$NA/trans gbl/$Q
SET DIFRQ=$NAME(@DIFRTA@("DATA",DIFRFILE))
+20 SET DIFRTART=$$OREF^DILF(DIFRQ)
+21 FOR
SET DIFRQ=$QUERY(@DIFRQ)
if $PIECE(DIFRQ,DIFRTART)]""!(DIFRQ="")
QUIT
if $PIECE(DIFRQ,DIFRTART,2,99)[""""!(DIFRPR)
Begin DoDot:1
+22 KILL R1
+23 SET DIFRK=1
+24 SET R2=$PIECE(DIFRQ,DIFRTART,2,99)
SET $EXTRACT(R2,$LENGTH(R2))=""
SET C=$LENGTH(R2,",")
SET F=1
SET R1=0
+25 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)
IF 'G
IF G'?1"0".E
IF R1#2
SET DIFRK=DIFRTART_$PIECE(R2,",",1,I)_")"
QUIT
+26 ;RESOLVE POINTERS
IF DIFRPR
IF DIFRK
IF '(R1#2)
Begin DoDot:2
+27 Begin DoDot:3
+28 IF R1'>3
SET DIFR2DD=DIFRFILE
QUIT
+29 SET R3=""
+30 FOR I=0:1:R1-3
SET R3=R3_R1(I)_","
+31 SET DIFR2DD=+$PIECE($GET(@(DIFRTART_R3_"0)")),"^",2)
+32 QUIT
End DoDot:3
if DIFR2DD'>0
QUIT
+33 SET DIFRNODE=R1($ORDER(R1(""),-1))
SET DIFRDNSC=R2
+34 if '$DATA(@DIFRTA@("PGL",DIFR2DD,DIFRNODE))
QUIT
+35 SET DIFRPCE=0
+36 FOR
SET DIFRPCE=$ORDER(@DIFRTA@("PGL",DIFR2DD,DIFRNODE,DIFRPCE))
if DIFRPCE=""
QUIT
if DIFRPCE>0
Begin DoDot:3
+37 if $PIECE(@DIFRQ,"^",DIFRPCE)=""
QUIT
+38 SET DIFRFELD=$ORDER(@DIFRTA@("PGL",DIFR2DD,DIFRNODE,DIFRPCE,""))
SET (I,DIFRIENS)=""
+39 ;CREATE IENS * * * * * * * * * * * * * * * * *
+40 FOR
SET I=$ORDER(R1(I),-1)
if I=""
QUIT
if '(I#2)
SET DIFRIENS=DIFRIENS_R1(I)_","
+41 SET DIFRDD0=^DD(DIFR2DD,DIFRFELD,0)
+42 DO DIERR
+43 SET DIFRFRV=$$GET1^DIQ(DIFR2DD,DIFRIENS,DIFRFELD)
+44 DO DIERR
+45 IF DIFRFRV']""
Begin DoDot:4
+46 NEW DIFRERR
+47 SET DIFRERR(1)=DIFR2DD
SET DIFRERR(2)=DIFRIENS
SET DIFRERR(3)=DIFRFELD
+48 DO BLD^DIALOG(9514,.DIFRERR)
+49 DO DIERR
+50 QUIT
End DoDot:4
QUIT
+51 SET DIFRFRVX="FRV1"
+52 ; If .01 field on file level is a pointer use "FRV0" subscript
+53 ;I R1'>3,DIFRPCE=1,DIFRNODE=0 S DIFRFRVX="FRV0"
+54 SET @DIFRTA@(DIFRFRVX,DIFRFILE,DIFRDNSC,DIFRPCE)=DIFRFRV
+55 SET @DIFRTA@(DIFRFRVX,DIFRFILE,DIFRDNSC,DIFRPCE,"F")=$SELECT($PIECE(DIFRDD0,"^",2)["P":";"_$PIECE(DIFRDD0,"^",3),$PIECE(DIFRDD0,"^",2)["V":"1;"_$PIECE($PIECE(@DIFRQ,"^",DIFRPCE),";",2),1:"")
+56 DO KEYVAL
+57 QUIT
End DoDot:3
+58 QUIT
+59 ;Q:IF HEADER NODE OR IF NOT DATA NODE THEN FIND DD AND CHECK
+60 ; IF DD#,"PGL",DATA NODE EXIST IF SO GET PIECE AND FIELD
+61 ; AND SET IT UP INTO A STRUCTURE ; ALL RESOLVED; .01,IDs AND PTR.
+62 ;IT WAS DECIDED NOT TO RESOLVE .01 AND ID POINTERS
+63 QUIT
End DoDot:2
QUIT
+64 if DIFRK
QUIT
+65 KILL @DIFRK
+66 QUIT
End DoDot:1
+67 QUIT
+68 ;
KEYVAL ; Send KEY values if pointed-to file has a primary KEY
+1 NEW DIFL
SET DIFL=$PIECE(DIFRDD0,"^",2)
+2 IF DIFL["P"
SET DIFL=+$PIECE(DIFL,"P",2)
+3 IF '$TEST
Begin DoDot:1
+4 SET DIFL=$PIECE($PIECE(@DIFRQ,"^",DIFRPCE),";",2)
+5 SET DIFL=+$PIECE($GET(@("^"_DIFL_"0)")),"^",2)
QUIT
End DoDot:1
+6 if 'DIFL
QUIT
+7 NEW DIKEY
SET DIKEY=$ORDER(^DD("KEY","AP",DIFL,"P",0))
if 'DIKEY
QUIT
+8 NEW X,DIOUT
SET DIOUT=0
Begin DoDot:1
+9 SET X=$PIECE(^DD("KEY",DIKEY,0),U,4)
IF 'X
SET DIOUT=1
QUIT
+10 SET X=$PIECE($GET(^DD("IX",X,0)),U,2)
IF X=""
SET DIOUT=1
QUIT
+11 SET @DIFRTA@("FRV1K",DIFRFILE,DIFRDNSC,DIFRPCE)=X
QUIT
End DoDot:1
if DIOUT
QUIT
+12 NEW DIFLD,DIVAL,DIPTR,DIER,DIERR,DIFLDDA,DISEQ
+13 SET DIPTR=+$PIECE(@DIFRQ,"^",DIFRPCE)
SET DIFLDDA=0
SET DIOUT=0
+14 FOR
SET DIFLDDA=$ORDER(^DD("KEY",DIKEY,2,DIFLDDA))
if 'DIFLDDA
QUIT
SET X=$GET(^(DIFLDDA,0))
Begin DoDot:1
+15 SET DIFLD=$PIECE(X,U)
SET DISEQ=$PIECE(X,U,3)
IF 'DISEQ
SET DIOUT=1
QUIT
+16 IF $PIECE(X,U,2)'=DIFL
SET DIOUT=1
QUIT
+17 IF DIFLD=.01
SET DIVAL=DIFRFRV
+18 IF '$TEST
SET DIVAL=$$GET1^DIQ(DIFL,DIPTR_",",DIFLD,"","","DIER")
+19 IF $DATA(DIER)
KILL DIER
SET DIOUT=1
QUIT
+20 SET @DIFRTA@("FRV1K",DIFRFILE,DIFRDNSC,DIFRPCE,DISEQ)=DIVAL
+21 QUIT
End DoDot:1
if DIOUT
QUIT
+22 IF DIOUT
KILL @DIFRTA@("FRV1K",DIFRFILE,DIFRDNSC,DIFRPCE)
+23 QUIT
+24 ;
DIERR IF $GET(DIERR)
SET DIFRERRC=$$ERRC($GET(DIFRERRC),DIERR)
KILL DIERR
+1 QUIT
+2 ;
ERRC(X,Y) ;
+1 SET X=$GET(X)
SET Y=$GET(Y)
+2 SET $PIECE(X,"^")=+X+Y
SET $PIECE(X,"^",2)=$PIECE(X,"^",2)+$PIECE(Y,"^",2)
+3 QUIT X
+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
