DIAXU ;SFISC/DCM-UPDATE DESTINATION FILE ;8/16/96 16:42
;;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
DIAX ;called from ^DIAX (Update Destination File option)
DQ ;
I $D(ZTQUEUED) N DIAR,DIAX S ZTREQ="@",DIAR=6,DIAX=1 D MRK^DIARU
N DIAXF,DIAXFRT S DIAXF=$P(^DIAR(1.11,DIARC,0),U,2),DIAXFRT=$$ROOT^DILFD(DIAXF)
D EXTRACT(DIAXF,DIARB,DIARP)
D UPDATE^DIARU
I $D(ZTQUEUED),$G(DIERR) S ZTIO=DIAXIOP,ZTRTN="XREP^DIAXU",ZTDESC="EXTRACT TOOL EXCEPTION REPORT",ZTSAVE("^TMP(""DIAXU"",$J)")="",ZTSAVE("^TMP(""DIERR"",$J)")="",ZTSAVE("DIARC")="" D ^%ZTLOAD Q
XREP ;
I $D(ZTQUEUED) S ZTREQ="@"
D ^DIAXP
Q
EN ; obsolete, replaced by EXTRACT
N %,DIAXERR S DIAXERR=""
D CLEAN^DIEFU
F %=$G(DIAXF)_U_"DIAXF",$G(DIAXFE)_U_"DIAXFE",$G(DIAXT)_U_"DIAXT" I $P(%,U,1)']"" D ERR(201,$P(%,U,2))
Q:$G(DIERR)
D EXTRACT(DIAXF,DIAXFE,DIAXT,$S($D(DIAXDEL):"D",1:""))
I '$G(DIERR),$D(^TMP("DIAXU",$J,"RESULT",DIAXF,DIAXFE)) S DIAXDA=^(DIAXFE)
Q
;
DIPT N X,D,SCR,DIARP,DIAR,DIPG
S X=$S(DIAXT:DIAXT,1:$P($P(DIAXT,"[",2),"]")),D="F"_DIAXF,SCR="I $P(^(0),U,8)=2"
S DIARP=$$FIND1^DIC(.4,"","XA",X,D,SCR,DIAXERR)
Q:$G(DIERR) I 'DIARP D ERR(202,"EXTRACT TEMPLATE") Q
S DIAR=6,DIPG=1,DIAXT=DIARP,DIAXDF=$P(^DIPT(DIAXT,0),U,9),DIAXDFRT=$$ROOT^DILFD(DIAXDF)
D EN^DIAXM
Q
DIK N DIK,DA
S DIK=$$ROOT^DILFD(DIAXF),DA=DIAXFE
D ^DIK
Q
K K @DIAXTFR,@DIAXTTO
Q
ONE I '$$VENTRY^DIEFU(DIAXF,DIAXFE) D ERR(601,DIAXFE),STE() Q
D ^DIAXD I $G(DIERR) D:$D(DIAXFILE) D STE() Q
. N DIERR,A S A("IEN")=DIAXFE
. D BLD^DIALOG(1300,"",.A)
D ^DIAXF I $G(DIERR) D STE() Q
Q:$D(DIAX)
I $G(DIAXFLGS)["D" D DIK
I $G(DIAXDA) S @DIAXRSLT@("RESULT",DIAXF,DIAXFE)=DIAXDA
Q
;
DIBT N SCR,D
S D="F"_DIAXF,SCR="I $P(^(0),U,4)="_DIAXF_",'$P(^(0),U,8)"
S DIAXST=$S($G(DIAXST):DIAXST,1:$$FIND1^DIC(.401,"","AX",DIAXST,D,SCR,DIAXERR))
I 'DIAXST!('$D(^DIBT(DIAXST,1))) D ERR(202,"SEARCH TEMPLATE") S:$G(DIAR) DIAR="" Q
N Z S Z=0 F S Z=$O(^DIBT(DIAXST,1,Z)) Q:Z'>0 D
. N DIAXDA,DIAXFE,DIERR
. S DIAXFE=Z
. D ONE
. Q:$G(DIERR)
. I $G(DIAX) D Q
. . N FDA,IEN
. . S FDA(1.14,"+"_+DIAXFE_","_DIARC_",",.01)=DIAXDA,IEN(DIAXFE)=DIAXDA
. . D UPDATE^DIE("","FDA","IEN")
. . S @(DIAXFRT_"DIAXFE,-9)")=DIARC
. I $G(DIAXFLGS)["D" K ^DIBT(DIAXST,1,DIAXFE)
Q
STE(FI,IEN) N Z
S:$G(FI)="" FI=DIAXF
S:$G(IEN)="" IEN=DIAXFE
S DIERRZ=(DIERR+DIERRZ)_U_($P(DIERR,U,2)+($P(DIERRZ,U,2)))
F DIERRLST=DIERRLST:1:$O(^TMP("DIERR",$J,"E"),-1) S Z=DIERRLST_";"
S @DIAXRSLT@("RESULT","ERR",FI,IEN)=Z
Q
ERR(DIAXER,DIAXTXT) ;
D BLD^DIALOG(DIAXER,DIAXTXT,"",DIAXERR,"F")
Q
N DIAXST,DIAXFE,T,DIFM,DIOVRD,DIERRLST,DIAXTFR,DIAXTTO,DIAXDF,DIAXDFRT,DIAXERR,DIERRZ,DIAXDA
S DIAXRSLT=$S($G(DIAXRSLT)]"":DIAXRSLT,1:"^TMP(""DIAXU"",$J)"),(DIFM,DIOVRD)=1,(DIERRLST,DIERRZ)=0,DIAXERR=""
K ^TMP("DIAXU",$J),^TMP("DIAX",$J),^TMP($J) D CLEAN^DIEFU
I '$G(DIAR) D Q:$G(DIERR)
. N %,PARAM F %=1:1:3 S PARAM=$S(%=1:$G(DIAXF)_U_"FILE",%=2:$G(DIAXSRCE)_U_"SOURCE",1:$G(DIAXT)_U_"EXTRACT TEMPLATE") I $P(PARAM,U)']"" D ERR(202,$P(PARAM,U,2))
. Q:$G(DIERR)
. I '$$VFILE^DIEFU(DIAXF) D ERR(202,"FILE") Q
. I $G(DIAXSRCE) S DIAXFE=+DIAXSRCE,T="ONE"
. I $E(DIAXSRCE)="[" S DIAXST=$P($P(DIAXSRCE,"[",2),"]"),T="DIBT"
. D DIPT
. Q
E S T="DIBT",DIAXST=DIAXSRCE
D ^DIAXT I $G(DIERR) S:$G(DIAR) DIAR="" Q
D @T,K
I $G(DIERRZ) S DIERR=DIERRZ
I $G(DIERR),$G(DIAXERRA)]"" M @DIAXERRA@("DIERR")=^TMP("DIERR",$J) K ^TMP("DIERR",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIAXU 3800 printed Oct 16, 2024@18:45:44 Page 2
DIAXU ;SFISC/DCM-UPDATE DESTINATION FILE ;8/16/96 16:42
+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
DIAX ;called from ^DIAX (Update Destination File option)
DQ ;
+1 IF $DATA(ZTQUEUED)
NEW DIAR,DIAX
SET ZTREQ="@"
SET DIAR=6
SET DIAX=1
DO MRK^DIARU
+2 NEW DIAXF,DIAXFRT
SET DIAXF=$PIECE(^DIAR(1.11,DIARC,0),U,2)
SET DIAXFRT=$$ROOT^DILFD(DIAXF)
+3 DO EXTRACT(DIAXF,DIARB,DIARP)
+4 DO UPDATE^DIARU
+5 IF $DATA(ZTQUEUED)
IF $GET(DIERR)
SET ZTIO=DIAXIOP
SET ZTRTN="XREP^DIAXU"
SET ZTDESC="EXTRACT TOOL EXCEPTION REPORT"
SET ZTSAVE("^TMP(""DIAXU"",$J)")=""
SET ZTSAVE("^TMP(""DIERR"",$J)")=""
SET ZTSAVE("DIARC")=""
DO ^%ZTLOAD
QUIT
XREP ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 DO ^DIAXP
+3 QUIT
EN ; obsolete, replaced by EXTRACT
+1 NEW %,DIAXERR
SET DIAXERR=""
+2 DO CLEAN^DIEFU
+3 FOR %=$GET(DIAXF)_U_"DIAXF",$GET(DIAXFE)_U_"DIAXFE",$GET(DIAXT)_U_"DIAXT"
IF $PIECE(%,U,1)']""
DO ERR(201,$PIECE(%,U,2))
+4 if $GET(DIERR)
QUIT
+5 DO EXTRACT(DIAXF,DIAXFE,DIAXT,$SELECT($DATA(DIAXDEL):"D",1:""))
+6 IF '$GET(DIERR)
IF $DATA(^TMP("DIAXU",$JOB,"RESULT",DIAXF,DIAXFE))
SET DIAXDA=^(DIAXFE)
+7 QUIT
+8 ;
DIPT NEW X,D,SCR,DIARP,DIAR,DIPG
+1 SET X=$SELECT(DIAXT:DIAXT,1:$PIECE($PIECE(DIAXT,"[",2),"]"))
SET D="F"_DIAXF
SET SCR="I $P(^(0),U,8)=2"
+2 SET DIARP=$$FIND1^DIC(.4,"","XA",X,D,SCR,DIAXERR)
+3 if $GET(DIERR)
QUIT
IF 'DIARP
DO ERR(202,"EXTRACT TEMPLATE")
QUIT
+4 SET DIAR=6
SET DIPG=1
SET DIAXT=DIARP
SET DIAXDF=$PIECE(^DIPT(DIAXT,0),U,9)
SET DIAXDFRT=$$ROOT^DILFD(DIAXDF)
+5 DO EN^DIAXM
+6 QUIT
DIK NEW DIK,DA
+1 SET DIK=$$ROOT^DILFD(DIAXF)
SET DA=DIAXFE
+2 DO ^DIK
+3 QUIT
K KILL @DIAXTFR,@DIAXTTO
+1 QUIT
ONE IF '$$VENTRY^DIEFU(DIAXF,DIAXFE)
DO ERR(601,DIAXFE)
DO STE()
QUIT
+1 DO ^DIAXD
IF $GET(DIERR)
if $DATA(DIAXFILE)
Begin DoDot:1
+2 NEW DIERR,A
SET A("IEN")=DIAXFE
+3 DO BLD^DIALOG(1300,"",.A)
End DoDot:1
DO STE()
QUIT
+4 DO ^DIAXF
IF $GET(DIERR)
DO STE()
QUIT
+5 if $DATA(DIAX)
QUIT
+6 IF $GET(DIAXFLGS)["D"
DO DIK
+7 IF $GET(DIAXDA)
SET @DIAXRSLT@("RESULT",DIAXF,DIAXFE)=DIAXDA
+8 QUIT
+9 ;
DIBT NEW SCR,D
+1 SET D="F"_DIAXF
SET SCR="I $P(^(0),U,4)="_DIAXF_",'$P(^(0),U,8)"
+2 SET DIAXST=$SELECT($GET(DIAXST):DIAXST,1:$$FIND1^DIC(.401,"","AX",DIAXST,D,SCR,DIAXERR))
+3 IF 'DIAXST!('$DATA(^DIBT(DIAXST,1)))
DO ERR(202,"SEARCH TEMPLATE")
if $GET(DIAR)
SET DIAR=""
QUIT
+4 NEW Z
SET Z=0
FOR
SET Z=$ORDER(^DIBT(DIAXST,1,Z))
if Z'>0
QUIT
Begin DoDot:1
+5 NEW DIAXDA,DIAXFE,DIERR
+6 SET DIAXFE=Z
+7 DO ONE
+8 if $GET(DIERR)
QUIT
+9 IF $GET(DIAX)
Begin DoDot:2
+10 NEW FDA,IEN
+11 SET FDA(1.14,"+"_+DIAXFE_","_DIARC_",",.01)=DIAXDA
SET IEN(DIAXFE)=DIAXDA
+12 DO UPDATE^DIE("","FDA","IEN")
+13 SET @(DIAXFRT_"DIAXFE,-9)")=DIARC
End DoDot:2
QUIT
+14 IF $GET(DIAXFLGS)["D"
KILL ^DIBT(DIAXST,1,DIAXFE)
End DoDot:1
+15 QUIT
STE(FI,IEN) NEW Z
+1 if $GET(FI)=""
SET FI=DIAXF
+2 if $GET(IEN)=""
SET IEN=DIAXFE
+3 SET DIERRZ=(DIERR+DIERRZ)_U_($PIECE(DIERR,U,2)+($PIECE(DIERRZ,U,2)))
+4 FOR DIERRLST=DIERRLST:1:$ORDER(^TMP("DIERR",$JOB,"E"),-1)
SET Z=DIERRLST_";"
+5 SET @DIAXRSLT@("RESULT","ERR",FI,IEN)=Z
+6 QUIT
ERR(DIAXER,DIAXTXT) ;
+1 DO BLD^DIALOG(DIAXER,DIAXTXT,"",DIAXERR,"F")
+2 QUIT
+1 NEW DIAXST,DIAXFE,T,DIFM,DIOVRD,DIERRLST,DIAXTFR,DIAXTTO,DIAXDF,DIAXDFRT,DIAXERR,DIERRZ,DIAXDA
+2 SET DIAXRSLT=$SELECT($GET(DIAXRSLT)]"":DIAXRSLT,1:"^TMP(""DIAXU"",$J)")
SET (DIFM,DIOVRD)=1
SET (DIERRLST,DIERRZ)=0
SET DIAXERR=""
+3 KILL ^TMP("DIAXU",$JOB),^TMP("DIAX",$JOB),^TMP($JOB)
DO CLEAN^DIEFU
+4 IF '$GET(DIAR)
Begin DoDot:1
+5 NEW %,PARAM
FOR %=1:1:3
SET PARAM=$SELECT(%=1:$GET(DIAXF)_U_"FILE",%=2:$GET(DIAXSRCE)_U_"SOURCE",1:$GET(DIAXT)_U_"EXTRACT TEMPLATE")
IF $PIECE(PARAM,U)']""
DO ERR(202,$PIECE(PARAM,U,2))
+6 if $GET(DIERR)
QUIT
+7 IF '$$VFILE^DIEFU(DIAXF)
DO ERR(202,"FILE")
QUIT
+8 IF $GET(DIAXSRCE)
SET DIAXFE=+DIAXSRCE
SET T="ONE"
+9 IF $EXTRACT(DIAXSRCE)="["
SET DIAXST=$PIECE($PIECE(DIAXSRCE,"[",2),"]")
SET T="DIBT"
+10 DO DIPT
+11 QUIT
End DoDot:1
if $GET(DIERR)
QUIT
+12 IF '$TEST
SET T="DIBT"
SET DIAXST=DIAXSRCE
+13 DO ^DIAXT
IF $GET(DIERR)
if $GET(DIAR)
SET DIAR=""
QUIT
+14 DO @T
DO K
+15 IF $GET(DIERRZ)
SET DIERR=DIERRZ
+16 IF $GET(DIERR)
IF $GET(DIAXERRA)]""
MERGE @DIAXERRA@("DIERR")=^TMP("DIERR",$JOB)
KILL ^TMP("DIERR",$JOB)
+17 QUIT
