Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DIFROMS3

DIFROMS3.m

Go to the documentation of this file.
  1. DIFROMS3 ;SFISC/DCL,TKW- DATA TO DISTRIBUTION ARRAY ;5/14/98 12:30
  1. ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
  1. ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
  1. ;;Licensed under the terms of the Apache License, Version 2.0.
  1. ;
  1. Q
  1. EN ;
  1. I '$D(@DIFRFIA) D ERR(2) Q
  1. G:$G(DIFRFILE) FILE
  1. S DIFRFILE=0 F S DIFRFILE=$O(@DIFRFIA@(DIFRFILE)) Q:DIFRFILE'>0 D FILE
  1. Q
  1. FCHK I '$D(@DIFRFIA@(DIFRFILE)) D ERR(5) Q ; * * * * PHASING OUT * * * *
  1. FILE N DIFRS,DIFRSCR,DIFRDA,DIFROOT,DIFRRLR,DIFR01,DIFRPR,DIFRDNSC,DIFRFRV,DIFRFRVX
  1. N DIFRQ,DIFRTART,DIFRK,R,R1,R2,R3,C,F,G,I,DIFR2DD,DIFRNODE,DIFRFELD,DIFRPCE,DIFRIENS,DIFRDD0
  1. S DIFR01=$G(@DIFRFIA@(DIFRFILE,0,1)),DIFRPR=$TR($P(DIFR01,"^",5),"Y","y")="y"
  1. I $TR($P(DIFR01,"^",7),"Y","y")'="y" Q
  1. I DIFRPR D PGL^DIFROMSP(DIFRFILE,"",DIFRTA)
  1. S DIFRS=$G(@DIFRFIA@(DIFRFILE,0,11))]"",DIFRSCR=$G(^(11))
  1. S DIFROOT=$NA(@($$ROOT^DILFD(DIFRFILE,"",1))),DIFRDA=0 ;$NA/trans gbl $Q
  1. S DIFRRLR=$G(@DIFRFIA@(DIFRFILE,0,"RLRO"))
  1. S:DIFRRLR="" DIFRRLR=DIFROOT
  1. I $D(@DIFRRLR)'>9 D ERR(4) Q
  1. N Y
  1. F S DIFRDA=$O(@DIFRRLR@(DIFRDA)) Q:DIFRDA'>0 D
  1. .I '$D(@DIFROOT@(DIFRDA,0)) D Q
  1. ..N DIFRERR S DIFRERR(1)=DIFRDA,DIFRERR(2)=DIFRFILE
  1. ..D BLD^DIALOG(9513,.DIFRERR)
  1. ..Q
  1. .I DIFRS,$D(@DIFRRLR@(DIFRDA,0)) S Y=DIFRDA X DIFRSCR Q:'$T ;set *NAKED* and *Y*
  1. .M @DIFRTA@("DATA",DIFRFILE,DIFRDA)=@DIFROOT@(DIFRDA)
  1. .Q
  1. S DIFRQ=$NA(@DIFRTA@("DATA",DIFRFILE)) ;$NA/trans gbl/$Q
  1. S DIFRTART=$$OREF^DILF(DIFRQ)
  1. F S DIFRQ=$Q(@DIFRQ) Q:$P(DIFRQ,DIFRTART)]""!(DIFRQ="") D:$P(DIFRQ,DIFRTART,2,99)[""""!(DIFRPR)
  1. .K R1
  1. .S DIFRK=1
  1. .S R2=$P(DIFRQ,DIFRTART,2,99),$E(R2,$L(R2))="",C=$L(R2,","),F=1,R1=0
  1. .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
  1. .I DIFRPR,DIFRK,'(R1#2) D Q ;RESOLVE POINTERS
  1. ..D Q:DIFR2DD'>0
  1. ...I R1'>3 S DIFR2DD=DIFRFILE Q
  1. ...S R3=""
  1. ...F I=0:1:R1-3 S R3=R3_R1(I)_","
  1. ...S DIFR2DD=+$P($G(@(DIFRTART_R3_"0)")),"^",2)
  1. ...Q
  1. ..S DIFRNODE=R1($O(R1(""),-1)),DIFRDNSC=R2
  1. ..Q:'$D(@DIFRTA@("PGL",DIFR2DD,DIFRNODE))
  1. ..S DIFRPCE=0
  1. ..F S DIFRPCE=$O(@DIFRTA@("PGL",DIFR2DD,DIFRNODE,DIFRPCE)) Q:DIFRPCE="" D:DIFRPCE>0
  1. ...Q:$P(@DIFRQ,"^",DIFRPCE)=""
  1. ...S DIFRFELD=$O(@DIFRTA@("PGL",DIFR2DD,DIFRNODE,DIFRPCE,"")),(I,DIFRIENS)=""
  1. ...;CREATE IENS * * * * * * * * * * * * * * * * *
  1. ...F S I=$O(R1(I),-1) Q:I="" S:'(I#2) DIFRIENS=DIFRIENS_R1(I)_","
  1. ...S DIFRDD0=^DD(DIFR2DD,DIFRFELD,0)
  1. ...D DIERR
  1. ...S DIFRFRV=$$GET1^DIQ(DIFR2DD,DIFRIENS,DIFRFELD)
  1. ...D DIERR
  1. ...I DIFRFRV']"" D Q
  1. ....N DIFRERR
  1. ....S DIFRERR(1)=DIFR2DD,DIFRERR(2)=DIFRIENS,DIFRERR(3)=DIFRFELD
  1. ....D BLD^DIALOG(9514,.DIFRERR)
  1. ....D DIERR
  1. ....Q
  1. ...S DIFRFRVX="FRV1"
  1. ...; If .01 field on file level is a pointer use "FRV0" subscript
  1. ...;I R1'>3,DIFRPCE=1,DIFRNODE=0 S DIFRFRVX="FRV0"
  1. ...S @DIFRTA@(DIFRFRVX,DIFRFILE,DIFRDNSC,DIFRPCE)=DIFRFRV
  1. ...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:"")
  1. ...D KEYVAL
  1. ...Q
  1. ..Q
  1. ..;Q:IF HEADER NODE OR IF NOT DATA NODE THEN FIND DD AND CHECK
  1. ..; IF DD#,"PGL",DATA NODE EXIST IF SO GET PIECE AND FIELD
  1. ..; AND SET IT UP INTO A STRUCTURE ; ALL RESOLVED; .01,IDs AND PTR.
  1. ..;IT WAS DECIDED NOT TO RESOLVE .01 AND ID POINTERS
  1. ..Q
  1. .Q:DIFRK
  1. .K @DIFRK
  1. .Q
  1. Q
  1. ;
  1. KEYVAL ; Send KEY values if pointed-to file has a primary KEY
  1. N DIFL S DIFL=$P(DIFRDD0,"^",2)
  1. I DIFL["P" S DIFL=+$P(DIFL,"P",2)
  1. E D
  1. . S DIFL=$P($P(@DIFRQ,"^",DIFRPCE),";",2)
  1. . S DIFL=+$P($G(@("^"_DIFL_"0)")),"^",2) Q
  1. Q:'DIFL
  1. N DIKEY S DIKEY=$O(^DD("KEY","AP",DIFL,"P",0)) Q:'DIKEY
  1. N X,DIOUT S DIOUT=0 D Q:DIOUT
  1. . S X=$P(^DD("KEY",DIKEY,0),U,4) I 'X S DIOUT=1 Q
  1. . S X=$P($G(^DD("IX",X,0)),U,2) I X="" S DIOUT=1 Q
  1. . S @DIFRTA@("FRV1K",DIFRFILE,DIFRDNSC,DIFRPCE)=X Q
  1. N DIFLD,DIVAL,DIPTR,DIER,DIERR,DIFLDDA,DISEQ
  1. S DIPTR=+$P(@DIFRQ,"^",DIFRPCE),DIFLDDA=0,DIOUT=0
  1. F S DIFLDDA=$O(^DD("KEY",DIKEY,2,DIFLDDA)) Q:'DIFLDDA S X=$G(^(DIFLDDA,0)) D Q:DIOUT
  1. . S DIFLD=$P(X,U),DISEQ=$P(X,U,3) I 'DISEQ S DIOUT=1 Q
  1. . I $P(X,U,2)'=DIFL S DIOUT=1 Q
  1. . I DIFLD=.01 S DIVAL=DIFRFRV
  1. . E S DIVAL=$$GET1^DIQ(DIFL,DIPTR_",",DIFLD,"","","DIER")
  1. . I $D(DIER) K DIER S DIOUT=1 Q
  1. . S @DIFRTA@("FRV1K",DIFRFILE,DIFRDNSC,DIFRPCE,DISEQ)=DIVAL
  1. . Q
  1. I DIOUT K @DIFRTA@("FRV1K",DIFRFILE,DIFRDNSC,DIFRPCE)
  1. Q
  1. ;
  1. DIERR I $G(DIERR) S DIFRERRC=$$ERRC($G(DIFRERRC),DIERR) K DIERR
  1. Q
  1. ;
  1. ERRC(X,Y) ;
  1. S X=$G(X),Y=$G(Y)
  1. S $P(X,"^")=+X+Y,$P(X,"^",2)=$P(X,"^",2)+$P(Y,"^",2)
  1. Q X
  1. ;
  1. ERR(X) N Y S Y=$P($T(ERR+X),";",5) Q:'Y D BLD^DIALOG(Y) Q
  1. ;;FIA Node Is Set To "No Data";1;9509
  1. ;;FIA Array Does Not Exist;2;9501
  1. ;;;3;
  1. ;;Records Do Not Exist;4;9510
  1. ;;FIA File Number Invalid;5;9502