- DIARX ;SFISC/DCM-ARCHIVING FUNCTION, BUILD INDEX ;8/12/98 10:25
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
- DIARX ;SFISC/DCM-ARCHIVING FUNCTION, BUILD INDEX ;8/12/98 10:25
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
