| [613] | 1 | DIARR ;SFISC/DCM-ARCHIVING FUNCTION, RETRIEVAL OF ARCHIVED RECORD ;8/11/98 13:19
|
|---|
| 2 | ;;22.0;VA FileMan;;Mar 30, 1999
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | START W !!,"This option will scan your archived file and will attempt to retrieve entries"
|
|---|
| 5 | W !,"that match the name (.01) field and",!,"either Primary KEY or identifier field(s) of the archived file."
|
|---|
| 6 | W !!,"Magnetic tapes should be opened with variable length records."
|
|---|
| 7 | ;
|
|---|
| 8 | INIT S DIARX="F U DIARIO R DIARL Q:DIARL]""""&($A(DIARL)'=13) "
|
|---|
| 9 | D HOME^%ZIS S DIOF=IOF,DIOSL=IOSL
|
|---|
| 10 | D DT^DICRW
|
|---|
| 11 | K ^TMP("DIAR",$J)
|
|---|
| 12 | S (DIARREQ,DIAROUT,DIARZ,DIAREOF,DIARMTCH,DIARFGEN,DIARPG,DIARRCT,DIARZID,DIARZL,DIARZ1,DIARZ2,DIARX1,DIARY,DIARNM,DIARRCT,DIARFND,DIARRHP)=0,DIARLINE=""
|
|---|
| 13 | ;
|
|---|
| 14 | SEQDEV S %ZIS("A")="SEQUENTIAL ARCHIVE DEVICE: ",%ZIS("HFSMODE")="R" D ^%ZIS G EOJ:POP
|
|---|
| 15 | I IOT'["MT",IOT'["SDP",IOT'["HFS" D ^%ZISC W !,$C(7),"This has to be a sequential device." G SEQDEV
|
|---|
| 16 | I IOT["MT",IOPAR'["V" D ^%ZISC W !,$C(7),"Open this device with variable length records." G SEQDEV
|
|---|
| 17 | S DIARIO=IO
|
|---|
| 18 | ;
|
|---|
| 19 | 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
|
|---|
| 20 | I $E(DIARL,1,6)="$INDEX" S DIARIDX=1 D ^DIARR6 G RC3
|
|---|
| 21 | U IO(0) W !!,"Sampling archived file...",!
|
|---|
| 22 | RC2 I $P(DIARL,U)="$DAT" S DIARFILE=$P(DIARL,U,2),DIARFN=+$P(DIARL,U,3)
|
|---|
| 23 | X DIARX S DIARNAME=$P(DIARL,"=",2) X DIARX
|
|---|
| 24 | 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
|
|---|
| 25 | 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
|
|---|
| 26 | I '$D(DIAR01) S DIARNM=1,^TMP("DIARHLP",$J,DIARRCT+1,.01)="NAME = "_DIARNAME
|
|---|
| 27 | S DIARRCT=DIARRCT+1
|
|---|
| 28 | F X DIARX Q:((DIARL["#$#")!(DIARRCT>5)) G RC2:((DIARRCT'>5)&($P(DIARL,U)["$DAT"))
|
|---|
| 29 | ;
|
|---|
| 30 | RC3 I DIARNM,'$D(DIAR01) S DIAR01="NAME"
|
|---|
| 31 | S DIARXXX=$$REWIND^%ZIS(IO,IOT,IOPAR)
|
|---|
| 32 | ;
|
|---|
| 33 | FILE U IO(0) W !,"You are reading archived information from the "_DIARFILE_" file."
|
|---|
| 34 | K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you want to continue"
|
|---|
| 35 | D ^DIR G EOJ:'Y!($D(DIRUT))
|
|---|
| 36 | ;
|
|---|
| 37 | D ^DIARR1 G EOJ:$D(DTOUT)!($D(DUOUT)&(DIARREQ'>0))!('$D(DIARR))!POP K DIRUT,DUOUT
|
|---|
| 38 | D ^DIARR2
|
|---|
| 39 | D ^DIARR3
|
|---|
| 40 | D ^DIARR5
|
|---|
| 41 | D EOJ
|
|---|
| 42 | Q
|
|---|
| 43 | ;
|
|---|
| 44 | ID S DIARID(+$P(DIARL,U,2))=$P($P(DIARL,U),":",2)_U_+$P(DIARL,U,2)
|
|---|
| 45 | S ^TMP("DIARHLP",$J,DIARRCT+1,$P($P(DIARL,U),":",2))=$P($P(DIARL,U),":",2)_" = "_$P(DIARL,"=",2)
|
|---|
| 46 | Q
|
|---|
| 47 | ;
|
|---|
| 48 | RC1 S DIARFN1=+$P(DIARL,U,2)
|
|---|
| 49 | F X DIARX Q:(($P(DIARL,":")="END")&(+$P(DIARL,U,2)=DIARFN1))
|
|---|
| 50 | Q
|
|---|
| 51 | ;
|
|---|
| 52 | EOJ D ^%ZISC
|
|---|
| 53 | K POP,DIARX,DIARFILE,DIARFN,DIARIO,DIARID,DIAR01,DIARZ,DIARREQ,DIARR,DIR,DIRUT,DTOUT,DUOUT,%MT,DIAROUT,DIARPDEV
|
|---|
| 54 | K DIARL,DIARA,DIAREOF,DIARF2,DIARFGEN,DIARFGL,DIARMTCH,DIARNM,DIARY,DIARIDDN,DIARMTID,DIARMT01,DIARZID
|
|---|
| 55 | K ^TMP("DIAR",$J),DIARRF,DIARZ1,DIARZ2,DIARRCT,DIARPG,DIARZL,DIARX1,DIARLINE,DIARIDS,DIARQUED,DIARFN1
|
|---|
| 56 | K DIARHLP,DIARRHP,DIARZHP,DIARNAME,DIAROFLD,DIAROIDF,DIAROAT,DIAROFLD,DIAROIDF,DIAROLVL,DIAROSTK,DIAROVAL,DIAROXPL
|
|---|
| 57 | K DIAROLNE,DIAROLUP,DIAROM,DIAROREQ,DIAROSUB,DIAROTAB,DIAROX,DIAROX1,DIAROZ,DIARZZ,DIARTAB,DIAROBPT,^TMP("DIARO",$J)
|
|---|
| 58 | K DIAROBCK,DIAROBF,DIAROBFN,DIAROBF1,DIAROSF,DIAROSFN,DIAROXX,DIARCNT,DIARCTR,DIARFLD,DIARFLGT,DIARFNA,DIARFNO,DIARIDX
|
|---|
| 59 | K DIARIXCT,DIARIXX,DIARPC,DIARREC,DIARVAL,DIARXX,DIARFND,DIARYY,DIARXXX,^TMP("DIARHLP",$J),DIAROX2,DIOF,DIOSL
|
|---|
| 60 | Q
|
|---|
