| [613] | 1 | DIARR1 ;SFISC/DCM-ARCHIVING FUNCTION, PROMPT FOR ARCHIVED RECORD ;7/1/93 8:43 AM
|
|---|
| 2 | ;;22.0;VA FileMan;;Mar 30, 1999
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | PROC D N Q:$D(DTOUT)!($D(DUOUT)&(DIARREQ'>0))!('$D(DIARR))
|
|---|
| 5 | D PRINTDEV Q:POP
|
|---|
| 6 | I '$D(IO("Q")) U IO(0) W !,"Searching archived file..."
|
|---|
| 7 | Q
|
|---|
| 8 | ;
|
|---|
| 9 | N U IO(0) I '$D(DIARIDX) W !!,"Type ?? at any prompt to display sampled entries.",!
|
|---|
| 10 | W !!,"Multiple requests may be made.",!,"One set of all prompts makes one request.",!
|
|---|
| 11 | I $D(DIARIDX) D ASKIX Q:$D(DIRUT)
|
|---|
| 12 | N1 W !
|
|---|
| 13 | K DIR S DIR("?",1)="Enter the "_DIAR01_" (.01) field.",DIR("?",2)="Answer to this prompt will retrieve all entries that match the ",DIR("?")=DIAR01_" field.",DIR("??")="^D HELP^DIARR1"
|
|---|
| 14 | S DIR(0)="FO",DIR("A")="Enter "_DIAR01 D ^DIR
|
|---|
| 15 | S:((X]"")&(X'="^")) DIARR(DIARREQ+1,".01")=X
|
|---|
| 16 | Q:$D(DTOUT)!(DIAROUT&(X=""))!($D(DUOUT))!('$D(DIARID)&$D(DIRUT))
|
|---|
| 17 | I $D(DIARID) D IDS Q:$D(DTOUT)
|
|---|
| 18 | S:$D(DIARR(DIARREQ+1)) DIARREQ=DIARREQ+1 G N1
|
|---|
| 19 | ;
|
|---|
| 20 | IDS S DIAROUT=0
|
|---|
| 21 | K DIR S DIR(0)="FO",DIR("?",1)="Enter identifier information. Answer to this prompt, along with all",DIR("?",2)="previously answered prompts for this request, will be used in the matching",DIR("?")="process."
|
|---|
| 22 | S DIR("??")="^D HELP^DIARR1"
|
|---|
| 23 | F DIARZ=.019:0 S DIARZ=$O(DIARID(DIARZ)) Q:DIARZ'>0 S DIR("A")="Enter "_$P(DIARID(DIARZ),U)_" (id) " D ^DIR Q:$D(DTOUT)!$D(DUOUT) S:((X]"")&(X'="^")) DIARR(DIARREQ+1,"ID",+$P(DIARID(DIARZ),U,2))=X
|
|---|
| 24 | I '$D(DIARR(DIARREQ+1)) S DIAROUT=1 Q
|
|---|
| 25 | Q
|
|---|
| 26 | ;
|
|---|
| 27 | HELP S DIARZHP="" W @DIOF
|
|---|
| 28 | F DIARHLP=0:0 S DIARHLP=$O(^TMP("DIARHLP",$J,DIARHLP)) Q:DIARHLP'>0!$D(DTOUT)!$D(DIRUT) W ! F S DIARZHP=$O(^TMP("DIARHLP",$J,DIARHLP,DIARZHP)) Q:DIARZHP="" W !,^(DIARZHP) I $Y>(DIOSL-3) D E Q:$D(DTOUT)!$D(DIRUT)
|
|---|
| 29 | Q
|
|---|
| 30 | ;
|
|---|
| 31 | E ;
|
|---|
| 32 | N DIR S DIR(0)="E" D ^DIR Q:$D(DTOUT)!$D(DIRUT)
|
|---|
| 33 | W @DIOF
|
|---|
| 34 | Q
|
|---|
| 35 | ;
|
|---|
| 36 | PRINTDEV Q:'$D(DIARR)
|
|---|
| 37 | S %ZIS="QN",%ZIS("B")="",%ZIS("A")="PRINT FOUND ENTRIES TO DEVICE: " D ^%ZIS Q:POP
|
|---|
| 38 | S DIARPDEV=$S($D(ION)#2:ION,1:IO)
|
|---|
| 39 | I $D(IOST)#2,IOST]"" S DIARPDEV=DIARPDEV_";"_IOST
|
|---|
| 40 | F DIARZ="IOM","IOSL" S:($D(@DIARZ)#2&DIARZ) DIARPDEV=DIARPDEV_";"_@DIARZ
|
|---|
| 41 | I $D(IO("Q")) U IO(0) W !,"THE PRINTING OF REPORT WILL BE QUEUED. PROCESSING CONTINUES..." S DIARQUED=""
|
|---|
| 42 | Q
|
|---|
| 43 | ;
|
|---|
| 44 | ASKIX W !,"This archived file contains an index of all archived entries."
|
|---|
| 45 | K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you want to see the index now" D ^DIR Q:'Y!($D(DIRUT))
|
|---|
| 46 | W @DIOF,! S DIARTAB=0 F DIARXX=1:1:DIARCNT S DIARFLD=$P(DIARPC(DIARXX),U,2),DIARTAB=DIARTAB+25 W $E(DIARFLD,1,23),?DIARTAB
|
|---|
| 47 | S DIARYY=""
|
|---|
| 48 | W ! F DIARXX=1:1:DIARCTR W ! S DIARTAB=0 D I $Y>(DIOSL-2) D E Q:$D(DTOUT)!$D(DIRUT)
|
|---|
| 49 | . F S DIARYY=$O(DIARPC(DIARYY)) Q:DIARYY'>0 S DIARFLD=+$G(DIARPC(DIARYY)),DIARTAB=DIARTAB+25 W $E($P($G(^TMP("DIARHLP",$J,DIARXX,DIARFLD)),"= ",2),1,23),?DIARTAB
|
|---|
| 50 | . Q
|
|---|
| 51 | K DTOUT,DIRUT
|
|---|
| 52 | Q
|
|---|
