DIARX ;SFISC/DCM-ARCHIVING FUNCTION, BUILD INDEX ;8/12/98 10:25
;;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.
;
IX K ^UTILITY("DIQ1",$J) N DIC
S DIARREC=^DIAR(1.11,DIARC,0),(DIARIXF,DIC)=$P(DIARREC,U,2),DIARIXST=$P(DIARREC,U,3),(DA,DIARDR,DIARIX,DIARDA)="",DR=".01",DIARLINE=.01_":"_$P(^DD(DIARIXF,.01,0),U)
N DIXIEN S DIXIEN=$O(^DD("KEY","AP",DIARIXF,"P",0))
I DIXIEN F S DIARDR=$O(^DD("KEY",DIXIEN,2,"BB",DIARDR)) Q:'DIARDR I DIARDR'=.01,$O(^(DIARDR,0))=DIARIXF,$D(^DD(DIARIXF,DIARDR,0)) D IDKEY
F S DIARDR=$O(^DD(DIARIXF,0,"ID",DIARDR)) Q:DIARDR'>0 I DIARLINE'[("^"_DIARDR_":"),$D(^DD(DIARIXF,DIARDR,0)) D IDKEY
S DIARBLNE=DIARLINE
S DIARLINE="$INDEX"_U_DIARIXF_U_$P(^DIC(DIARIXF,0),U)_U_DIARLINE U IO W DIARLINE,!
F S DA=$O(^DIBT(DIARIXST,1,DA)) Q:DA'>0 S DIQ(0)="E" D EN^DIQ1
F S DIARDA=$O(^DIBT(DIARIXST,1,DIARDA)) Q:DIARDA'>0 D IX1
K DIARREC,DIARIXF,DIARIXST,DA,DIARDR,DIARIX,DIARDA,DR,DIARLINE
Q
;
IDKEY ; Save KEY or Identifier data
S DIARLINE=DIARLINE_U_DIARDR_":"_$P(^DD(DIARIXF,DIARDR,0),U)
S DR=DR_";"_DIARDR Q
Q
;
IX1 S DIARLINE="" F S DIARIX=$O(^UTILITY("DIQ1",$J,DIARIXF,DIARDA,DIARIX)) Q:DIARIX'>0 S DIARLINE=DIARLINE_^(DIARIX,"E")_U
W DIARLINE,!
Q
;
OUT I $D(DIARQUED) G QP
S IOP=DIARPDEV D ^%ZIS G QP:POP
DQ ;print archive activity report
S DIARPG=0,DIARLINE="",DIARX=^DIAR(1.11,DIARC,0),DIARFI=$P(DIARX,U,2) U IO S Y=DT X ^DD("DD") S DIARXY=Y
D HDR,BODY
Q
HDR W:$Y @IOF W !,"ARCHIVE ACTIVITY REPORT",?IOM-24,DIARXY,?IOM-10,"PAGE: ",DIARPG+1
S DIARPG=DIARPG+1,$P(DIARLINE,"-",IOM)="" W !,DIARLINE Q
;
BODY W !!,"ARCHIVAL ACTIVITY: ",DIARC,!,"ARCHIVE DEVICE LABEL INFORMATION: ",$P(^DIAR(1.11,DIARC,0),U,19)
W !,"PRIMARY ARCHIVED FILE: ",$P($G(^DIC(DIARFI,0)),U)_" (#"_DIARFI_")"
W !,"ARCHIVER: ",$P($G(^VA(200,$P(DIARX,U,6),0)),U)
W !,"SEARCH CRITERIA: " S DIARU=$P(DIARX,U,3),DIARXZ=0
F S DIARXZ=$O(^DIBT(DIARU,"O",DIARXZ)) Q:DIARXZ'>0 Q:'$D(^(DIARXZ,0)) W !,?5,^(0)
W !!,"INDEX INFORMATION: ",! S (DIARTAB,DIARFLD)=0 F DIARXZ=1:1 S DIARFLD=$P($P(DIARBLNE,U,DIARXZ),":",2) Q:DIARFLD="" W DIARFLD S DIARTAB=DIARTAB+25 W ?DIARTAB
F DIARXZ=0:0 S DIARXZ=$O(^UTILITY("DIQ1",$J,DIARFI,DIARXZ)) Q:DIARXZ'>0 D HDRC Q:$D(DTOUT)!$D(DIRUT) W ! S DIARTAB=0 F S DIARFLD=$O(^UTILITY("DIQ1",$J,DIARFI,DIARXZ,DIARFLD)) Q:DIARFLD'>0 W ^(DIARFLD,"E") S DIARTAB=DIARTAB+25 W ?DIARTAB
W !!,"*** PLEASE KEEP THIS FOR FUTURE REFERENCE ***"
I $E(IOST)'="C",$Y W @IOF
D ^%ZISC
Q
;
HDRC Q:($Y+1<IOSL)
I "C"[$E(IOST) K DIR S DIR(0)="E" D ^DIR Q:$D(DTOUT)!($D(DIRUT))
D HDR
Q
;
QP S ZTRTN="DQ^DIARX",ZTSAVE("DIARC")="",ZTDESC="ARCHIVE ACTIVITY REPORT",ZTSAVE("^UTILITY(""DIQ1"",$J,")="",ZTSAVE("DIARBLNE")="",ZTIO=DIARPDEV,ZTDTH=$H
D ^%ZTLOAD,HOME^%ZIS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIARX 3017 printed Apr 09, 2024@21:50:22 Page 2
DIARX ;SFISC/DCM-ARCHIVING FUNCTION, BUILD INDEX ;8/12/98 10:25
+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 ;
IX KILL ^UTILITY("DIQ1",$JOB)
NEW DIC
+1 SET DIARREC=^DIAR(1.11,DIARC,0)
SET (DIARIXF,DIC)=$PIECE(DIARREC,U,2)
SET DIARIXST=$PIECE(DIARREC,U,3)
SET (DA,DIARDR,DIARIX,DIARDA)=""
SET DR=".01"
SET DIARLINE=.01_":"_$PIECE(^DD(DIARIXF,.01,0),U)
+2 NEW DIXIEN
SET DIXIEN=$ORDER(^DD("KEY","AP",DIARIXF,"P",0))
+3 IF DIXIEN
FOR
SET DIARDR=$ORDER(^DD("KEY",DIXIEN,2,"BB",DIARDR))
if 'DIARDR
QUIT
IF DIARDR'=.01
IF $ORDER(^(DIARDR,0))=DIARIXF
IF $DATA(^DD(DIARIXF,DIARDR,0))
DO IDKEY
+4 FOR
SET DIARDR=$ORDER(^DD(DIARIXF,0,"ID",DIARDR))
if DIARDR'>0
QUIT
IF DIARLINE'[("^"_DIARDR_":")
IF $DATA(^DD(DIARIXF,DIARDR,0))
DO IDKEY
+5 SET DIARBLNE=DIARLINE
+6 SET DIARLINE="$INDEX"_U_DIARIXF_U_$PIECE(^DIC(DIARIXF,0),U)_U_DIARLINE
USE IO
WRITE DIARLINE,!
+7 FOR
SET DA=$ORDER(^DIBT(DIARIXST,1,DA))
if DA'>0
QUIT
SET DIQ(0)="E"
DO EN^DIQ1
+8 FOR
SET DIARDA=$ORDER(^DIBT(DIARIXST,1,DIARDA))
if DIARDA'>0
QUIT
DO IX1
+9 KILL DIARREC,DIARIXF,DIARIXST,DA,DIARDR,DIARIX,DIARDA,DR,DIARLINE
+10 QUIT
+11 ;
IDKEY ; Save KEY or Identifier data
+1 SET DIARLINE=DIARLINE_U_DIARDR_":"_$PIECE(^DD(DIARIXF,DIARDR,0),U)
+2 SET DR=DR_";"_DIARDR
QUIT
+3 QUIT
+4 ;
IX1 SET DIARLINE=""
FOR
SET DIARIX=$ORDER(^UTILITY("DIQ1",$JOB,DIARIXF,DIARDA,DIARIX))
if DIARIX'>0
QUIT
SET DIARLINE=DIARLINE_^(DIARIX,"E")_U
+1 WRITE DIARLINE,!
+2 QUIT
+3 ;
OUT IF $DATA(DIARQUED)
GOTO QP
+1 SET IOP=DIARPDEV
DO ^%ZIS
if POP
GOTO QP
DQ ;print archive activity report
+1 SET DIARPG=0
SET DIARLINE=""
SET DIARX=^DIAR(1.11,DIARC,0)
SET DIARFI=$PIECE(DIARX,U,2)
USE IO
SET Y=DT
XECUTE ^DD("DD")
SET DIARXY=Y
+2 DO HDR
DO BODY
+3 QUIT
HDR if $Y
WRITE @IOF
WRITE !,"ARCHIVE ACTIVITY REPORT",?IOM-24,DIARXY,?IOM-10,"PAGE: ",DIARPG+1
+1 SET DIARPG=DIARPG+1
SET $PIECE(DIARLINE,"-",IOM)=""
WRITE !,DIARLINE
QUIT
+2 ;
BODY WRITE !!,"ARCHIVAL ACTIVITY: ",DIARC,!,"ARCHIVE DEVICE LABEL INFORMATION: ",$PIECE(^DIAR(1.11,DIARC,0),U,19)
+1 WRITE !,"PRIMARY ARCHIVED FILE: ",$PIECE($GET(^DIC(DIARFI,0)),U)_" (#"_DIARFI_")"
+2 WRITE !,"ARCHIVER: ",$PIECE($GET(^VA(200,$PIECE(DIARX,U,6),0)),U)
+3 WRITE !,"SEARCH CRITERIA: "
SET DIARU=$PIECE(DIARX,U,3)
SET DIARXZ=0
+4 FOR
SET DIARXZ=$ORDER(^DIBT(DIARU,"O",DIARXZ))
if DIARXZ'>0
QUIT
if '$DATA(^(DIARXZ,0))
QUIT
WRITE !,?5,^(0)
+5 WRITE !!,"INDEX INFORMATION: ",!
SET (DIARTAB,DIARFLD)=0
FOR DIARXZ=1:1
SET DIARFLD=$PIECE($PIECE(DIARBLNE,U,DIARXZ),":",2)
if DIARFLD=""
QUIT
WRITE DIARFLD
SET DIARTAB=DIARTAB+25
WRITE ?DIARTAB
+6 FOR DIARXZ=0:0
SET DIARXZ=$ORDER(^UTILITY("DIQ1",$JOB,DIARFI,DIARXZ))
if DIARXZ'>0
QUIT
DO HDRC
if $DATA(DTOUT)!$DATA(DIRUT)
QUIT
WRITE !
SET DIARTAB=0
FOR
SET DIARFLD=$ORDER(^UTILITY("DIQ1",$JOB,DIARFI,DIARXZ,DIARFLD))
if DIARFLD'>0
QUIT
WRITE ^(DIARFLD,"E")
SET DIARTAB=DIARTAB+25
WRITE ?DIARTAB
+7 WRITE !!,"*** PLEASE KEEP THIS FOR FUTURE REFERENCE ***"
+8 IF $EXTRACT(IOST)'="C"
IF $Y
WRITE @IOF
+9 DO ^%ZISC
+10 QUIT
+11 ;
HDRC if ($Y+1<IOSL)
QUIT
+1 IF "C"[$EXTRACT(IOST)
KILL DIR
SET DIR(0)="E"
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
QUIT
+2 DO HDR
+3 QUIT
+4 ;
QP SET ZTRTN="DQ^DIARX"
SET ZTSAVE("DIARC")=""
SET ZTDESC="ARCHIVE ACTIVITY REPORT"
SET ZTSAVE("^UTILITY(""DIQ1"",$J,")=""
SET ZTSAVE("DIARBLNE")=""
SET ZTIO=DIARPDEV
SET ZTDTH=$HOROLOG
+1 DO ^%ZTLOAD
DO HOME^%ZIS
