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