DIAXD ;SFISC/DCM-GET SOURCE DATA ;9/6/96 15:17
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;
N DILL,FRFILE,TOFILE,DIAXIEN,DIAXI,DIAXFR,DIAXTO,DATAFR,DATALST,Z
S (DILL,DIAXI)=$G(DILL)+1,FRFILE=@DIAXTFR@(DILL,"FR"),TOFILE=@DIAXTFR@(FRFILE,"TO"),Z=","
S DIAXFR="^TMP($J,""DIAXFR"")",DIAXTO="^TMP($J,""DIAXTO"")",DATAFR="^TMP($J,""DATAFR"")",DATALST="^TMP($J,""DATALST"")"
D Q,TOP I $G(DIERR) D Q Q
D NEXTLVL
Q K @DIAXFR,@DIAXTO,@DATAFR
K:$G(DIERR) ^TMP("DIAX",$J)
Q
TOP ;
N FRIENS,TOIENS
S (FRIENS,@DIAXFR@(FRFILE,"IENS"))=DIAXFE_Z
S (TOIENS,@DIAXTO@(TOFILE,"IENS"),@DIAXTO@(FRFILE,"IENS",FRIENS))=$$DIAXIEN()
D GETFDA(FRIENS,TOIENS)
Q
GETFDA(FRIENS,TOIENS) ;
D GETS Q:$G(DIERR)
D FDA
Q
GETS ;
N DR,FLAGS,FIELDS
F S DR=$G(DR)+1 Q:'$G(@DIAXTFR@(FRFILE,"DR",DR)) D Q:$G(DIERR)
. S FLAGS="EIN"
. S FIELDS=@DIAXTFR@(FRFILE,"DR",DR)
. D GETS^DIQ(FRFILE,FRIENS,FIELDS,FLAGS,DATAFR,DIAXERR) D:$G(DIERR) ERR
Q
FDA ;
N A,B,C S A=0
F S A=$O(@DATAFR@(FRFILE,FRIENS,A)) Q:A'>0 F C=0,1 S B=$G(@DIAXTTO@(FRFILE,A,C)) D:B]"" Q:$G(DIERR)
. I $O(@DATAFR@(FRFILE,FRIENS,A,0)) S ^TMP("DIAX",$J,TOFILE,TOIENS,+$P(B,U,2))=U_$P($$GET1^DIQ(FRFILE,FRIENS,A,"B"),U,2) Q
. S ^TMP("DIAX",$J,TOFILE,TOIENS,+$P(B,U,2))=$S(+$P(B,U,3):@DATAFR@(FRFILE,FRIENS,A,"E"),1:@DATAFR@(FRFILE,FRIENS,A,"I"))
I '$D(^TMP("DIAX",$J,TOFILE,TOIENS,.01)) S ^TMP("DIAX",$J,TOFILE,TOIENS,.01)=$$GET1^DIQ(FRFILE,FRIENS,.01,"I","",DIAXERR) D:$G(DIERR) ERR
K @DATAFR
Q
GETLIST ;
N SCR,A,B S SCR=$G(DIAXSCR(FRFILE))
S FRIENS=$G(FRIENS),PART=$G(PART),INDEX=$G(INDEX) K @DATALST
D LIST^DIC(FRFILE,FRIENS,"","","","",PART,INDEX,.SCR,"",DATALST,DIAXERR)
I $G(DIERR) D ERR,Q1 Q
I '$P(@DATALST@("DILIST",0),U) D Q1 Q
I $G(PART)]"" S FRIENS=Z_@DIAXFR@(PARENT,"IENS")
S A=0 F S A=$O(@DATALST@("DILIST",2,A)) Q:A'>0 S B=@DATALST@("DILIST",2,A),@DIAXFR@(FRFILE,"IENS",$E(FRIENS,2,99),B_FRIENS)=""
Q1 K @DATALST,PART,INDEX
Q
TOIENS ;
N A,B S A=""
F S A=$O(@DIAXFR@(FRFILE,"IENS",FRIENS,A)) Q:A="" S B=$$DIAXIEN(),@DIAXTO@(FRFILE,"IENS",A)=B_@DIAXTO@(PARENT,"IENS",FRIENS)
Q
GETDATA ;
Q:'$D(@DIAXTFR@(FRFILE,"DR"))
N A,ZFRIENS S A="",ZFRIENS=FRIENS N FRIENS
F S A=$O(@DIAXFR@(FRFILE,"IENS",ZFRIENS,A)) Q:A="" S FRIENS=A D Q:$G(DIERR)
. N TOIENS
. S TOIENS=@DIAXTO@(FRFILE,"IENS",FRIENS)
. D GETFDA(FRIENS,TOIENS) Q:$G(DIERR)
. I $D(DIAXFILE(FRFILE)) D Q
. . N Y,DIERZ
. . D RECURSE
. . I $G(DIERZ) N DIERR,Y S Y("IEN")=DIAXFE D BLD^DIALOG(1300,"",.Y) D STE^DIAXU()
Q
MULT(FRIENS) ;
S FRIENS=Z_FRIENS
D GETLIST Q:$G(DIERR)
S FRIENS=$E(FRIENS,2,99)
D TOIENS
D GETDATA
Q
ERR ;
Q:'$D(FRFILE)!('$D(FRIENS))
Q:'$D(DIAXFILE(FRFILE))
D STE^DIAXU(FRFILE,FRIENS)
Q
NEXTLVL ;
F DIAXI=$G(DIAXI):0 S DIAXI=$O(@DIAXTFR@(DIAXI)) Q:'$D(@DIAXTFR@(+DIAXI,"FR")) D NEXTLVL2 Q:$G(DIERR)!(DIAXI="")
Q
NEXTLVL2 ;
N FRFILE,TOFILE,PARENT,DILL,FRIENS,TOIENS,TAG
S FRFILE=@DIAXTFR@(DIAXI,"FR"),TOFILE=@DIAXTFR@(FRFILE,"TO"),PARENT=^("PRT"),DILL=^("P2"),TAG=^("P4")
D @TAG
Q
3 ;
I $D(DIAXFILE(FRFILE)) D FILE Q:$G(DIERR)
I DILL=2 S FRIENS=@DIAXFR@(PARENT,"IENS") D MULT(FRIENS) Q
N A,B S (A,B)="" F S B=$O(@DIAXFR@(PARENT,"IENS",B)) Q:B="" D
. F S A=$O(@DIAXFR@(PARENT,"IENS",B,A)) Q:A="" D Q:$D(DIAXFILE(PARENT))
. . S FRIENS=A D MULT(FRIENS) Q:$G(DIERR)
Q
2 ;
N PTRFLD,FRIENS,PTRIEN,A,B
S PTRFLD=$P(@DIAXTFR@(FRFILE,"P5"),":")
I DILL=2 S FRIENS=@DIAXFR@(PARENT,"IENS") D 21 Q
S (A,B)="" F S B=$O(@DIAXFR@(PARENT,"IENS",B)) Q:B="" D Q:$G(DIERR)!('PTRIEN)
. F S A=$O(@DIAXFR@(PARENT,"IENS",B,A)) Q:A="" D Q:$G(DIERR)!'(PTRIEN)!($D(DIAXFILE(PARENT)))
. . S FRIENS=A D 21
Q
21 N TOIENS
S PTRIEN=$$GET1^DIQ(PARENT,FRIENS,PTRFLD,"I","",DIAXERR) D:$G(DIERR) Q:$G(DIERR)!('PTRIEN)
. N FRFILE
. S FRFILE=PARENT
. D ERR
S FRIENS=PTRIEN_Z
S TOIENS=@DIAXTO@(PARENT,"IENS",A)
D GETFDA(FRIENS,TOIENS)
Q
4 ;
N PART,INDEX,FRIENS
S PART=$$GET1^DIQ(PARENT,@DIAXFR@(PARENT,"IENS"),.01,"I","",DIAXERR) D:$G(DIERR) Q:PART']""!$G(DIERR)
. N FRFILE,FRIENS
. S FRFILE=PARENT
. S FRIENS=@DIAXFR@(PARENT,"IENS")
. D ERR
S INDEX=@DIAXTFR@(FRFILE,"P7")
I $D(DIAXFILE(FRFILE)) D FILE Q:$G(DIERR)
S FRIENS="" D GETLIST Q:$G(DIERR)
S FRIENS=@DIAXFR@(PARENT,"IENS")
D TOIENS,GETDATA
Q
DIAXIEN() ;
S DIAXIEN=$G(DIAXIEN)+1
Q "+"_DIAXIEN_Z
FILE ;
Q:'$D(^TMP("DIAX",$J))
N IEN S IEN="^TMP($J,""IEN"")"
D Q2,UPDATE^DIE("E","^TMP(""DIAX"",$J)",IEN,DIAXERR)
I $G(DIERR) D Q
. K ^TMP("DIAX",$J)
. D ERR
N %,NODE,A,B,FI,VAL,DA S %=0,NODE=DIAXTO
I $G(@IEN@(1)) S DIAXDA=^(1),FI=0,FI=$O(@NODE@(FI))
E S FI=FRFILE
F S %=$O(@IEN@(%)) Q:'% S DA=@IEN@(%) D VAL
Q2 K @IEN Q
VAL S NODE=DIAXTO,NODE=$NA(@NODE@(FI)) F S NODE=$Q(@NODE) Q:NODE'["DIAXTO" Q:$QS(NODE,5)'[$G(FRIENS) S VAL=@NODE I VAL[("+"_%_Z) S VAL=$P(VAL,"+"_%_Z,1)_DA_Z_$P(VAL,"+"_%_Z,2) S @NODE=VAL D
. S A=$QS(NODE,3),B=$QS(NODE,5)
. Q:(A'=DIAXF)&('$D(DIAXFILE(A)))
. Q:A=""!(B="")
. I A=DIAXF S B=+B,VAL=+VAL
. S @DIAXRSLT@("RESULT",A,B)=VAL
Q
RECURSE ;
N DIAXIZ,DILLZ,DIERR
S DIAXIZ=DIAXI,DILLZ=DILL
D NEXTLVL,FILE
N NODE,SUB,FILE S FILE=FRFILE
F S FILE=$O(@DIAXFR@(FILE)) Q:'FILE F NODE=$NA(@DIAXFR@(FILE)),$NA(@DIAXTO@(FILE)) F S NODE=$Q(@NODE) Q:NODE'["IENS" S SUB=$QS(NODE,5) I SUB[FRIENS K @NODE
K @DIAXFR@(FRFILE,"IENS",ZFRIENS,FRIENS),@DIAXTO@(FRFILE,"IENS",FRIENS)
S DIAXI=DIAXIZ,DILL=DILLZ,A=""
I $G(DIERR) K DIAXDA S DIERZ=1
Q
DIAXD ;SFISC/DCM-GET SOURCE DATA ;9/6/96 15:17
+1 ;;22.0;VA FileMan;;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;
+1 NEW DILL,FRFILE,TOFILE,DIAXIEN,DIAXI,DIAXFR,DIAXTO,DATAFR,DATALST,Z
+2 SET (DILL,DIAXI)=$GET(DILL)+1
SET FRFILE=@DIAXTFR@(DILL,"FR")
SET TOFILE=@DIAXTFR@(FRFILE,"TO")
SET Z=","
+3 SET DIAXFR="^TMP($J,""DIAXFR"")"
SET DIAXTO="^TMP($J,""DIAXTO"")"
SET DATAFR="^TMP($J,""DATAFR"")"
SET DATALST="^TMP($J,""DATALST"")"
+4 DO Q
DO TOP
IF $GET(DIERR)
DO Q
QUIT
+5 DO NEXTLVL
Q KILL @DIAXFR,@DIAXTO,@DATAFR
+1 IF $GET(DIERR)
KILL ^TMP("DIAX",$JOB)
+2 QUIT
TOP ;
+1 NEW FRIENS,TOIENS
+2 SET (FRIENS,@DIAXFR@(FRFILE,"IENS"))=DIAXFE_Z
+3 SET (TOIENS,@DIAXTO@(TOFILE,"IENS"),@DIAXTO@(FRFILE,"IENS",FRIENS))=$$DIAXIEN()
+4 DO GETFDA(FRIENS,TOIENS)
+5 QUIT
GETFDA(FRIENS,TOIENS) ;
+1 DO GETS
IF $GET(DIERR)
QUIT
+2 DO FDA
+3 QUIT
GETS ;
+1 NEW DR,FLAGS,FIELDS
+2 FOR
SET DR=$GET(DR)+1
IF '$GET(@DIAXTFR@(FRFILE,"DR",DR))
QUIT
Begin DoDot:1
+3 SET FLAGS="EIN"
+4 SET FIELDS=@DIAXTFR@(FRFILE,"DR",DR)
+5 DO GETS^DIQ(FRFILE,FRIENS,FIELDS,FLAGS,DATAFR,DIAXERR)
IF $GET(DIERR)
DO ERR
End DoDot:1
IF $GET(DIERR)
QUIT
+6 QUIT
FDA ;
+1 NEW A,B,C
SET A=0
+2 FOR
SET A=$ORDER(@DATAFR@(FRFILE,FRIENS,A))
IF A'>0
QUIT
FOR C=0,1
SET B=$GET(@DIAXTTO@(FRFILE,A,C))
IF B]""
Begin DoDot:1
+3 IF $ORDER(@DATAFR@(FRFILE,FRIENS,A,0))
SET ^TMP("DIAX",$JOB,TOFILE,TOIENS,+$PIECE(B,U,2))=U_$PIECE($$GET1^DIQ(FRFILE,FRIENS,A,"B"),U,2)
QUIT
+4 SET ^TMP("DIAX",$JOB,TOFILE,TOIENS,+$PIECE(B,U,2))=$SELECT(+$PIECE(B,U,3):@DATAFR@(FRFILE,FRIENS,A,"E"),1:@DATAFR@(FRFILE,FRIENS,A,"I"))
End DoDot:1
IF $GET(DIERR)
QUIT
+5 IF '$DATA(^TMP("DIAX",$JOB,TOFILE,TOIENS,.01))
SET ^TMP("DIAX",$JOB,TOFILE,TOIENS,.01)=$$GET1^DIQ(FRFILE,FRIENS,.01,"I","",DIAXERR)
IF $GET(DIERR)
DO ERR
+6 KILL @DATAFR
+7 QUIT
GETLIST ;
+1 NEW SCR,A,B
SET SCR=$GET(DIAXSCR(FRFILE))
+2 SET FRIENS=$GET(FRIENS)
SET PART=$GET(PART)
SET INDEX=$GET(INDEX)
KILL @DATALST
+3 DO LIST^DIC(FRFILE,FRIENS,"","","","",PART,INDEX,.SCR,"",DATALST,DIAXERR)
+4 IF $GET(DIERR)
DO ERR
DO Q1
QUIT
+5 IF '$PIECE(@DATALST@("DILIST",0),U)
DO Q1
QUIT
+6 IF $GET(PART)]""
SET FRIENS=Z_@DIAXFR@(PARENT,"IENS")
+7 SET A=0
FOR
SET A=$ORDER(@DATALST@("DILIST",2,A))
IF A'>0
QUIT
SET B=@DATALST@("DILIST",2,A)
SET @DIAXFR@(FRFILE,"IENS",$EXTRACT(FRIENS,2,99),B_FRIENS)=""
Q1 KILL @DATALST,PART,INDEX
+1 QUIT
TOIENS ;
+1 NEW A,B
SET A=""
+2 FOR
SET A=$ORDER(@DIAXFR@(FRFILE,"IENS",FRIENS,A))
IF A=""
QUIT
SET B=$$DIAXIEN()
SET @DIAXTO@(FRFILE,"IENS",A)=B_@DIAXTO@(PARENT,"IENS",FRIENS)
+3 QUIT
GETDATA ;
+1 IF '$DATA(@DIAXTFR@(FRFILE,"DR"))
QUIT
+2 NEW A,ZFRIENS
SET A=""
SET ZFRIENS=FRIENS
NEW FRIENS
+3 FOR
SET A=$ORDER(@DIAXFR@(FRFILE,"IENS",ZFRIENS,A))
IF A=""
QUIT
SET FRIENS=A
Begin DoDot:1
+4 NEW TOIENS
+5 SET TOIENS=@DIAXTO@(FRFILE,"IENS",FRIENS)
+6 DO GETFDA(FRIENS,TOIENS)
IF $GET(DIERR)
QUIT
+7 IF $DATA(DIAXFILE(FRFILE))
Begin DoDot:2
+8 NEW Y,DIERZ
+9 DO RECURSE
+10 IF $GET(DIERZ)
NEW DIERR,Y
SET Y("IEN")=DIAXFE
DO BLD^DIALOG(1300,"",.Y)
DO STE^DIAXU()
End DoDot:2
QUIT
End DoDot:1
IF $GET(DIERR)
QUIT
+11 QUIT
MULT(FRIENS) ;
+1 SET FRIENS=Z_FRIENS
+2 DO GETLIST
IF $GET(DIERR)
QUIT
+3 SET FRIENS=$EXTRACT(FRIENS,2,99)
+4 DO TOIENS
+5 DO GETDATA
+6 QUIT
ERR ;
+1 IF '$DATA(FRFILE)!('$DATA(FRIENS))
QUIT
+2 IF '$DATA(DIAXFILE(FRFILE))
QUIT
+3 DO STE^DIAXU(FRFILE,FRIENS)
+4 QUIT
NEXTLVL ;
+1 FOR DIAXI=$GET(DIAXI):0
SET DIAXI=$ORDER(@DIAXTFR@(DIAXI))
IF '$DATA(@DIAXTFR@(+DIAXI,"FR"))
QUIT
DO NEXTLVL2
IF $GET(DIERR)!(DIAXI="")
QUIT
+2 QUIT
NEXTLVL2 ;
+1 NEW FRFILE,TOFILE,PARENT,DILL,FRIENS,TOIENS,TAG
+2 SET FRFILE=@DIAXTFR@(DIAXI,"FR")
SET TOFILE=@DIAXTFR@(FRFILE,"TO")
SET PARENT=^("PRT")
SET DILL=^("P2")
SET TAG=^("P4")
+3 DO @TAG
+4 QUIT
3 ;
+1 IF $DATA(DIAXFILE(FRFILE))
DO FILE
IF $GET(DIERR)
QUIT
+2 IF DILL=2
SET FRIENS=@DIAXFR@(PARENT,"IENS")
DO MULT(FRIENS)
QUIT
+3 NEW A,B
SET (A,B)=""
FOR
SET B=$ORDER(@DIAXFR@(PARENT,"IENS",B))
IF B=""
QUIT
Begin DoDot:1
+4 FOR
SET A=$ORDER(@DIAXFR@(PARENT,"IENS",B,A))
IF A=""
QUIT
Begin DoDot:2
+5 SET FRIENS=A
DO MULT(FRIENS)
IF $GET(DIERR)
QUIT
End DoDot:2
IF $DATA(DIAXFILE(PARENT))
QUIT
End DoDot:1
+6 QUIT
2 ;
+1 NEW PTRFLD,FRIENS,PTRIEN,A,B
+2 SET PTRFLD=$PIECE(@DIAXTFR@(FRFILE,"P5"),":")
+3 IF DILL=2
SET FRIENS=@DIAXFR@(PARENT,"IENS")
DO 21
QUIT
+4 SET (A,B)=""
FOR
SET B=$ORDER(@DIAXFR@(PARENT,"IENS",B))
IF B=""
QUIT
Begin DoDot:1
+5 FOR
SET A=$ORDER(@DIAXFR@(PARENT,"IENS",B,A))
IF A=""
QUIT
Begin DoDot:2
+6 SET FRIENS=A
DO 21
End DoDot:2
IF $GET(DIERR)!'(PTRIEN)!($DATA(DIAXFILE(PARENT)))
QUIT
End DoDot:1
IF $GET(DIERR)!('PTRIEN)
QUIT
+7 QUIT
21 NEW TOIENS
+1 SET PTRIEN=$$GET1^DIQ(PARENT,FRIENS,PTRFLD,"I","",DIAXERR)
IF $GET(DIERR)
Begin DoDot:1
+2 NEW FRFILE
+3 SET FRFILE=PARENT
+4 DO ERR
End DoDot:1
IF $GET(DIERR)!('PTRIEN)
QUIT
+5 SET FRIENS=PTRIEN_Z
+6 SET TOIENS=@DIAXTO@(PARENT,"IENS",A)
+7 DO GETFDA(FRIENS,TOIENS)
+8 QUIT
4 ;
+1 NEW PART,INDEX,FRIENS
+2 SET PART=$$GET1^DIQ(PARENT,@DIAXFR@(PARENT,"IENS"),.01,"I","",DIAXERR)
IF $GET(DIERR)
Begin DoDot:1
+3 NEW FRFILE,FRIENS
+4 SET FRFILE=PARENT
+5 SET FRIENS=@DIAXFR@(PARENT,"IENS")
+6 DO ERR
End DoDot:1
IF PART']""!$GET(DIERR)
QUIT
+7 SET INDEX=@DIAXTFR@(FRFILE,"P7")
+8 IF $DATA(DIAXFILE(FRFILE))
DO FILE
IF $GET(DIERR)
QUIT
+9 SET FRIENS=""
DO GETLIST
IF $GET(DIERR)
QUIT
+10 SET FRIENS=@DIAXFR@(PARENT,"IENS")
+11 DO TOIENS
DO GETDATA
+12 QUIT
DIAXIEN() ;
+1 SET DIAXIEN=$GET(DIAXIEN)+1
+2 QUIT "+"_DIAXIEN_Z
FILE ;
+1 IF '$DATA(^TMP("DIAX",$JOB))
QUIT
+2 NEW IEN
SET IEN="^TMP($J,""IEN"")"
+3 DO Q2
DO UPDATE^DIE("E","^TMP(""DIAX"",$J)",IEN,DIAXERR)
+4 IF $GET(DIERR)
Begin DoDot:1
+5 KILL ^TMP("DIAX",$JOB)
+6 DO ERR
End DoDot:1
QUIT
+7 NEW %,NODE,A,B,FI,VAL,DA
SET %=0
SET NODE=DIAXTO
+8 IF $GET(@IEN@(1))
SET DIAXDA=^(1)
SET FI=0
SET FI=$ORDER(@NODE@(FI))
+9 IF '$TEST
SET FI=FRFILE
+10 FOR
SET %=$ORDER(@IEN@(%))
IF '%
QUIT
SET DA=@IEN@(%)
DO VAL
Q2 KILL @IEN
QUIT
VAL SET NODE=DIAXTO
SET NODE=$NAME(@NODE@(FI))
FOR
SET NODE=$QUERY(@NODE)
IF NODE'["DIAXTO"
QUIT
IF $QSUBSCRIPT(NODE,5)'[$GET(FRIENS)
QUIT
SET VAL=@NODE
IF VAL[("+"_%_Z)
SET VAL=$PIECE(VAL,"+"_%_Z,1)_DA_Z_$PIECE(VAL,"+"_%_Z,2)
SET @NODE=VAL
Begin DoDot:1
+1 SET A=$QSUBSCRIPT(NODE,3)
SET B=$QSUBSCRIPT(NODE,5)
+2 IF (A'=DIAXF)&('$DATA(DIAXFILE(A)))
QUIT
+3 IF A=""!(B="")
QUIT
+4 IF A=DIAXF
SET B=+B
SET VAL=+VAL
+5 SET @DIAXRSLT@("RESULT",A,B)=VAL
End DoDot:1
+6 QUIT
RECURSE ;
+1 NEW DIAXIZ,DILLZ,DIERR
+2 SET DIAXIZ=DIAXI
SET DILLZ=DILL
+3 DO NEXTLVL
DO FILE
+4 NEW NODE,SUB,FILE
SET FILE=FRFILE
+5 FOR
SET FILE=$ORDER(@DIAXFR@(FILE))
IF 'FILE
QUIT
FOR NODE=$NAME(@DIAXFR@(FILE)),$NAME(@DIAXTO@(FILE))
FOR
SET NODE=$QUERY(@NODE)
IF NODE'["IENS"
QUIT
SET SUB=$QSUBSCRIPT(NODE,5)
IF SUB[FRIENS
KILL @NODE
+6 KILL @DIAXFR@(FRFILE,"IENS",ZFRIENS,FRIENS),@DIAXTO@(FRFILE,"IENS",FRIENS)
+7 SET DIAXI=DIAXIZ
SET DILL=DILLZ
SET A=""
+8 IF $GET(DIERR)
KILL DIAXDA
SET DIERZ=1
+9 QUIT
