DIARR ;SFISC/DCM-ARCHIVING FUNCTION, RETRIEVAL OF ARCHIVED RECORD ;8/11/98 13:19
;;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.
;
START W !!,"This option will scan your archived file and will attempt to retrieve entries"
W !,"that match the name (.01) field and",!,"either Primary KEY or identifier field(s) of the archived file."
W !!,"Magnetic tapes should be opened with variable length records."
;
INIT S DIARX="F U DIARIO R DIARL Q:DIARL]""""&($A(DIARL)'=13) "
D HOME^%ZIS S DIOF=IOF,DIOSL=IOSL
D DT^DICRW
K ^TMP("DIAR",$J)
S (DIARREQ,DIAROUT,DIARZ,DIAREOF,DIARMTCH,DIARFGEN,DIARPG,DIARRCT,DIARZID,DIARZL,DIARZ1,DIARZ2,DIARX1,DIARY,DIARNM,DIARRCT,DIARFND,DIARRHP)=0,DIARLINE=""
;
SEQDEV S %ZIS("A")="SEQUENTIAL ARCHIVE DEVICE: ",%ZIS("HFSMODE")="R" D ^%ZIS G EOJ:POP
I IOT'["MT",IOT'["SDP",IOT'["HFS" D ^%ZISC W !,$C(7),"This has to be a sequential device." G SEQDEV
I IOT["MT",IOPAR'["V" D ^%ZISC W !,$C(7),"Open this device with variable length records." G SEQDEV
S DIARIO=IO
;
RC X DIARX I $E(DIARL,1,4)'["$IND",$E(DIARL,1,4)'["$DAT" D ^%ZISC W !,$C(7),"Archive information is not in filegram format" G SEQDEV
I $E(DIARL,1,6)="$INDEX" S DIARIDX=1 D ^DIARR6 G RC3
U IO(0) W !!,"Sampling archived file...",!
RC2 I $P(DIARL,U)="$DAT" S DIARFILE=$P(DIARL,U,2),DIARFN=+$P(DIARL,U,3)
X DIARX S DIARNAME=$P(DIARL,"=",2) X DIARX
F X DIARX Q:(($P(DIARL,":")="END")&(+$P(DIARL,U,2)=DIARFN)) D RC1:$P(DIARL,":")="BEGIN" I ($P($P(DIARL,U),":")="IDENTIFIER")!($P($P(DIARL,U),":")="SPECIFIER") D ID
F X DIARX Q:$P(DIARL,U)["$END DAT" I +$P(DIARL,U,2)=".01" S DIAR01=$P(DIARL,U) S ^TMP("DIARHLP",$J,DIARRCT+1,.01)=DIAR01_" = "_$P(DIARL,"=",2) Q
I '$D(DIAR01) S DIARNM=1,^TMP("DIARHLP",$J,DIARRCT+1,.01)="NAME = "_DIARNAME
S DIARRCT=DIARRCT+1
F X DIARX Q:((DIARL["#$#")!(DIARRCT>5)) G RC2:((DIARRCT'>5)&($P(DIARL,U)["$DAT"))
;
RC3 I DIARNM,'$D(DIAR01) S DIAR01="NAME"
S DIARXXX=$$REWIND^%ZIS(IO,IOT,IOPAR)
;
FILE U IO(0) W !,"You are reading archived information from the "_DIARFILE_" file."
K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you want to continue"
D ^DIR G EOJ:'Y!($D(DIRUT))
;
D ^DIARR1 G EOJ:$D(DTOUT)!($D(DUOUT)&(DIARREQ'>0))!('$D(DIARR))!POP K DIRUT,DUOUT
D ^DIARR2
D ^DIARR3
D ^DIARR5
D EOJ
Q
;
ID S DIARID(+$P(DIARL,U,2))=$P($P(DIARL,U),":",2)_U_+$P(DIARL,U,2)
S ^TMP("DIARHLP",$J,DIARRCT+1,$P($P(DIARL,U),":",2))=$P($P(DIARL,U),":",2)_" = "_$P(DIARL,"=",2)
Q
;
RC1 S DIARFN1=+$P(DIARL,U,2)
F X DIARX Q:(($P(DIARL,":")="END")&(+$P(DIARL,U,2)=DIARFN1))
Q
;
EOJ D ^%ZISC
K POP,DIARX,DIARFILE,DIARFN,DIARIO,DIARID,DIAR01,DIARZ,DIARREQ,DIARR,DIR,DIRUT,DTOUT,DUOUT,%MT,DIAROUT,DIARPDEV
K DIARL,DIARA,DIAREOF,DIARF2,DIARFGEN,DIARFGL,DIARMTCH,DIARNM,DIARY,DIARIDDN,DIARMTID,DIARMT01,DIARZID
K ^TMP("DIAR",$J),DIARRF,DIARZ1,DIARZ2,DIARRCT,DIARPG,DIARZL,DIARX1,DIARLINE,DIARIDS,DIARQUED,DIARFN1
K DIARHLP,DIARRHP,DIARZHP,DIARNAME,DIAROFLD,DIAROIDF,DIAROAT,DIAROFLD,DIAROIDF,DIAROLVL,DIAROSTK,DIAROVAL,DIAROXPL
K DIAROLNE,DIAROLUP,DIAROM,DIAROREQ,DIAROSUB,DIAROTAB,DIAROX,DIAROX1,DIAROZ,DIARZZ,DIARTAB,DIAROBPT,^TMP("DIARO",$J)
K DIAROBCK,DIAROBF,DIAROBFN,DIAROBF1,DIAROSF,DIAROSFN,DIAROXX,DIARCNT,DIARCTR,DIARFLD,DIARFLGT,DIARFNA,DIARFNO,DIARIDX
K DIARIXCT,DIARIXX,DIARPC,DIARREC,DIARVAL,DIARXX,DIARFND,DIARYY,DIARXXX,^TMP("DIARHLP",$J),DIAROX2,DIOF,DIOSL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIARR 3637 printed Sep 23, 2025@20:20:56 Page 2
DIARR ;SFISC/DCM-ARCHIVING FUNCTION, RETRIEVAL OF ARCHIVED RECORD ;8/11/98 13:19
+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 ;
START WRITE !!,"This option will scan your archived file and will attempt to retrieve entries"
+1 WRITE !,"that match the name (.01) field and",!,"either Primary KEY or identifier field(s) of the archived file."
+2 WRITE !!,"Magnetic tapes should be opened with variable length records."
+3 ;
INIT SET DIARX="F U DIARIO R DIARL Q:DIARL]""""&($A(DIARL)'=13) "
+1 DO HOME^%ZIS
SET DIOF=IOF
SET DIOSL=IOSL
+2 DO DT^DICRW
+3 KILL ^TMP("DIAR",$JOB)
+4 SET (DIARREQ,DIAROUT,DIARZ,DIAREOF,DIARMTCH,DIARFGEN,DIARPG,DIARRCT,DIARZID,DIARZL,DIARZ1,DIARZ2,DIARX1,DIARY,DIARNM,DIARRCT,DIARFND,DIARRHP)=0
SET DIARLINE=""
+5 ;
SEQDEV SET %ZIS("A")="SEQUENTIAL ARCHIVE DEVICE: "
SET %ZIS("HFSMODE")="R"
DO ^%ZIS
if POP
GOTO EOJ
+1 IF IOT'["MT"
IF IOT'["SDP"
IF IOT'["HFS"
DO ^%ZISC
WRITE !,$CHAR(7),"This has to be a sequential device."
GOTO SEQDEV
+2 IF IOT["MT"
IF IOPAR'["V"
DO ^%ZISC
WRITE !,$CHAR(7),"Open this device with variable length records."
GOTO SEQDEV
+3 SET DIARIO=IO
+4 ;
RC XECUTE DIARX
IF $EXTRACT(DIARL,1,4)'["$IND"
IF $EXTRACT(DIARL,1,4)'["$DAT"
DO ^%ZISC
WRITE !,$CHAR(7),"Archive information is not in filegram format"
GOTO SEQDEV
+1 IF $EXTRACT(DIARL,1,6)="$INDEX"
SET DIARIDX=1
DO ^DIARR6
GOTO RC3
+2 USE IO(0)
WRITE !!,"Sampling archived file...",!
RC2 IF $PIECE(DIARL,U)="$DAT"
SET DIARFILE=$PIECE(DIARL,U,2)
SET DIARFN=+$PIECE(DIARL,U,3)
+1 XECUTE DIARX
SET DIARNAME=$PIECE(DIARL,"=",2)
XECUTE DIARX
+2 FOR
XECUTE DIARX
if (($PIECE(DIARL,"
QUIT
if $PIECE(DIARL,":")="BEGIN"
DO RC1
IF ($PIECE($PIECE(DIARL,U),":")="IDENTIFIER")!($PIECE($PIECE(DIARL,U),":")="SPECIFIER")
DO ID
+3 FOR
XECUTE DIARX
if $PIECE(DIARL,U)["$END DAT"
QUIT
IF +$PIECE(DIARL,U,2)=".01"
SET DIAR01=$PIECE(DIARL,U)
SET ^TMP("DIARHLP",$JOB,DIARRCT+1,.01)=DIAR01_" = "_$PIECE(DIARL,"=",2)
QUIT
+4 IF '$DATA(DIAR01)
SET DIARNM=1
SET ^TMP("DIARHLP",$JOB,DIARRCT+1,.01)="NAME = "_DIARNAME
+5 SET DIARRCT=DIARRCT+1
+6 FOR
XECUTE DIARX
if ((DIARL["#$#")!(DIARRCT>5))
QUIT
if ((DIARRCT'>5)&($PIECE(DIARL,U)["$DAT"))
GOTO RC2
+7 ;
RC3 IF DIARNM
IF '$DATA(DIAR01)
SET DIAR01="NAME"
+1 SET DIARXXX=$$REWIND^%ZIS(IO,IOT,IOPAR)
+2 ;
FILE USE IO(0)
WRITE !,"You are reading archived information from the "_DIARFILE_" file."
+1 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Do you want to continue"
+2 DO ^DIR
if 'Y!($DATA(DIRUT))
GOTO EOJ
+3 ;
+4 DO ^DIARR1
if $DATA(DTOUT)!($DATA(DUOUT)&(DIARREQ'>0))!('$DATA(DIARR))!POP
GOTO EOJ
KILL DIRUT,DUOUT
+5 DO ^DIARR2
+6 DO ^DIARR3
+7 DO ^DIARR5
+8 DO EOJ
+9 QUIT
+10 ;
ID SET DIARID(+$PIECE(DIARL,U,2))=$PIECE($PIECE(DIARL,U),":",2)_U_+$PIECE(DIARL,U,2)
+1 SET ^TMP("DIARHLP",$JOB,DIARRCT+1,$PIECE($PIECE(DIARL,U),":",2))=$PIECE($PIECE(DIARL,U),":",2)_" = "_$PIECE(DIARL,"=",2)
+2 QUIT
+3 ;
RC1 SET DIARFN1=+$PIECE(DIARL,U,2)
+1 FOR
XECUTE DIARX
if (($PIECE(DIARL,"
QUIT
+2 QUIT
+3 ;
EOJ DO ^%ZISC
+1 KILL POP,DIARX,DIARFILE,DIARFN,DIARIO,DIARID,DIAR01,DIARZ,DIARREQ,DIARR,DIR,DIRUT,DTOUT,DUOUT,%MT,DIAROUT,DIARPDEV
+2 KILL DIARL,DIARA,DIAREOF,DIARF2,DIARFGEN,DIARFGL,DIARMTCH,DIARNM,DIARY,DIARIDDN,DIARMTID,DIARMT01,DIARZID
+3 KILL ^TMP("DIAR",$JOB),DIARRF,DIARZ1,DIARZ2,DIARRCT,DIARPG,DIARZL,DIARX1,DIARLINE,DIARIDS,DIARQUED,DIARFN1
+4 KILL DIARHLP,DIARRHP,DIARZHP,DIARNAME,DIAROFLD,DIAROIDF,DIAROAT,DIAROFLD,DIAROIDF,DIAROLVL,DIAROSTK,DIAROVAL,DIAROXPL
+5 KILL DIAROLNE,DIAROLUP,DIAROM,DIAROREQ,DIAROSUB,DIAROTAB,DIAROX,DIAROX1,DIAROZ,DIARZZ,DIARTAB,DIAROBPT,^TMP("DIARO",$JOB)
+6 KILL DIAROBCK,DIAROBF,DIAROBFN,DIAROBF1,DIAROSF,DIAROSFN,DIAROXX,DIARCNT,DIARCTR,DIARFLD,DIARFLGT,DIARFNA,DIARFNO,DIARIDX
+7 KILL DIARIXCT,DIARIXX,DIARPC,DIARREC,DIARVAL,DIARXX,DIARFND,DIARYY,DIARXXX,^TMP("DIARHLP",$JOB),DIAROX2,DIOF,DIOSL
+8 QUIT
