- 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 Jan 18, 2025@03:46:10 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