freem_fileman/USER/DIFROMS3.m - view

File: [Coherent Logic Development] / freem_fileman / USER / DIFROMS3.m
Revision 1.1: download - view: text, annotated - select for diffs
Mon Apr 28 14:13:20 2025 UTC (3 months ago) by snw
Branches: MAIN
CVS tags: HEAD

Restructure repository

1: DIFROMS3 ;SFISC/DCL- DATA TO DISTRIBUTION ARRAY;02:37 PM 18 Nov 1994; 2: ;;21.0;VA FileMan;;Dec 28, 1994 3: ;Per VHA Directive 10-93-142, this routine should not be modified. 4: ; 5: Q 6: EN ; 7: I '$D(@DIFRFIA) D ERR(2) Q 8: G:$G(DIFRFILE) FILE 9: S DIFRFILE=0 F S DIFRFILE=$O(@DIFRFIA@(DIFRFILE)) Q:DIFRFILE'>0 D FILE 10: Q 11: FCHK I '$D(@DIFRFIA@(DIFRFILE)) D ERR(5) Q ; * * * * PHASING OUT * * * * 12: FILE N DIFRS,DIFRSCR,DIFRDA,DIFROOT,DIFRRLR,DIFR01,DIFRPR,DIFRDNSC,DIFRFRV,DIFRFRVX 13: N DIFRQ,DIFRTART,DIFRK,R,R1,R2,R3,C,F,G,I,DIFR2DD,DIFRNODE,DIFRFELD,DIFRPCE,DIFRIENS,DIFRDD0 14: S DIFR01=$G(@DIFRFIA@(DIFRFILE,0,1)),DIFRPR=$TR($P(DIFR01,"^",5),"Y","y")="y" 15: I $TR($P(DIFR01,"^",7),"Y","y")'="y" Q 16: I DIFRPR D PGL^DIFROMSP(DIFRFILE,"",DIFRTA) 17: S DIFRS=$G(@DIFRFIA@(DIFRFILE,0,11))]"",DIFRSCR=$G(^(11)) 18: S DIFROOT=$NA(@($$ROOT^DILFD(DIFRFILE,"",1))),DIFRDA=0 ;$NA/trans gbl $Q 19: S DIFRRLR=$G(@DIFRFIA@(DIFRFILE,0,"RLRO")) 20: S:DIFRRLR="" DIFRRLR=DIFROOT 21: I $D(@DIFRRLR)'>9 D ERR(4) Q 22: N Y 23: F S DIFRDA=$O(@DIFRRLR@(DIFRDA)) Q:DIFRDA'>0 D 24: .I '$D(@DIFROOT@(DIFRDA,0)) D Q 25: ..N DIFRERR S DIFRERR(1)=DIFRDA,DIFRERR(2)=DIFRFILE 26: ..D BLD^DIALOG(9513,.DIFRERR) 27: ..Q 28: .I DIFRS,$D(@DIFRRLR@(DIFRDA,0)) S Y=DIFRDA X DIFRSCR Q:'$T ;set *NAKED* and *Y* 29: .M @DIFRTA@("DATA",DIFRFILE,DIFRDA)=@DIFROOT@(DIFRDA) 30: .Q 31: S DIFRQ=$NA(@DIFRTA@("DATA",DIFRFILE)) ;$NA/trans gbl/$Q 32: S DIFRTART=$$OREF^DILF(DIFRQ) 33: F S DIFRQ=$Q(@DIFRQ) Q:$P(DIFRQ,DIFRTART)]""!(DIFRQ="") D:$P(DIFRQ,DIFRTART,2,99)[""""!(DIFRPR) 34: .K R1 35: .S DIFRK=1 36: .S R2=$P(DIFRQ,DIFRTART,2,99),$E(R2,$L(R2))="",C=$L(R2,","),F=1,R1=0 37: .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 38: .I DIFRPR,DIFRK,'(R1#2) D Q ;RESOLVE POINTERS 39: ..D Q:DIFR2DD'>0 40: ...I R1'>3 S DIFR2DD=DIFRFILE Q 41: ...S R3="" 42: ...F I=0:1:R1-3 S R3=R3_R1(I)_"," 43: ...S DIFR2DD=+$P($G(@(DIFRTART_R3_"0)")),"^",2) 44: ...Q 45: ..S DIFRNODE=R1($O(R1(""),-1)),DIFRDNSC=R2 46: ..Q:'$D(@DIFRTA@("PGL",DIFR2DD,DIFRNODE)) 47: ..S DIFRPCE=0 48: ..F S DIFRPCE=$O(@DIFRTA@("PGL",DIFR2DD,DIFRNODE,DIFRPCE)) Q:DIFRPCE="" D:DIFRPCE>0 49: ...Q:$P(@DIFRQ,"^",DIFRPCE)="" 50: ...S DIFRFELD=$O(@DIFRTA@("PGL",DIFR2DD,DIFRNODE,DIFRPCE,"")),(I,DIFRIENS)="" 51: ...;CREATE IENS * * * * * * * * * * * * * * * * * 52: ...F S I=$O(R1(I),-1) Q:I="" S:'(I#2) DIFRIENS=DIFRIENS_R1(I)_"," 53: ...S DIFRDD0=^DD(DIFR2DD,DIFRFELD,0) 54: ...S DIFRFRV=$$GET1^DIQ(DIFR2DD,DIFRIENS,DIFRFELD) 55: ...I DIFRFRV']"" D Q 56: ....N DIFRERR 57: ....S DIFRERR(1)=DIFR2DD,DIFRERR(2)=DIFRIENS,DIFRERR(3)=DIFRFELD 58: ....D BLD^DIALOG(9514,.DIFRERR) 59: ....Q 60: ...S DIFRFRVX="FRV1" 61: ...; If .01 field on file level is a pointer use "FRV0" subscript 62: ...;I R1'>3,DIFRPCE=1,DIFRNODE=0 S DIFRFRVX="FRV0" 63: ...S @DIFRTA@(DIFRFRVX,DIFRFILE,DIFRDNSC,DIFRPCE)=DIFRFRV 64: ...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:"") 65: ...Q 66: ..Q 67: ..;Q:IF HEADER NODE OR IF NOT DATA NODE THEN FIND DD AND CHECK 68: ..; IF DD#,"PGL",DATA NODE EXIST IF SO GET PIECE AND FIELD 69: ..; AND SET IT UP INTO A STRUCTURE ; ALL RESOLVED; .01,IDs AND PTR. 70: ..;IT WAS DECIDED NOT TO RESOLVE .01 AND ID POINTERS 71: ..Q 72: .Q:DIFRK 73: .K @DIFRK 74: .Q 75: Q 76: ; 77: ERR(X) N Y S Y=$P($T(ERR+X),";",5) Q:'Y D BLD^DIALOG(Y) Q 78: ;;FIA Node Is Set To "No Data";1;9509 79: ;;FIA Array Does Not Exist;2;9501 80: ;;;3; 81: ;;Records Do Not Exist;4;9510 82: ;;FIA File Number Invalid;5;9502