Routine: DIARR1

DIARR1 ;SFISC/DCM-ARCHIVING FUNCTION, PROMPT FOR ARCHIVED RECORD ;7/1/93  8:43 AM

 ;;22.0;VA FileMan;;Mar 30, 1999

 ;Per VHA Directive 10-93-142, this routine should not be modified.

PROC D N Q:$D(DTOUT)!($D(DUOUT)&(DIARREQ'>0))!('$D(DIARR))

 D PRINTDEV Q:POP

 I '$D(IO("Q")) U IO(0) W !,"Searching archived file..."

N U IO(0) I '$D(DIARIDX) W !!,"Type ?? at any prompt to display sampled entries.",!

 W !!,"Multiple requests may be made.",!,"One set of all prompts makes one request.",!

 I $D(DIARIDX) D ASKIX Q:$D(DIRUT)

N1 W !

 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"

 S DIR(0)="FO",DIR("A")="Enter "_DIAR01 D ^DIR

 S:((X]"")&(X'="^")) DIARR(DIARREQ+1,".01")=X

 Q:$D(DTOUT)!(DIAROUT&(X=""))!($D(DUOUT))!('$D(DIARID)&$D(DIRUT))

 I $D(DIARID) D IDS Q:$D(DTOUT)

 S:$D(DIARR(DIARREQ+1)) DIARREQ=DIARREQ+1 G N1

IDS S DIAROUT=0

 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."

 S DIR("??")="^D HELP^DIARR1"

 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

 I '$D(DIARR(DIARREQ+1)) S DIAROUT=1 Q

HELP S DIARZHP="" W @DIOF

 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)

E ;

 N DIR S DIR(0)="E" D ^DIR Q:$D(DTOUT)!$D(DIRUT)

 W @DIOF

PRINTDEV Q:'$D(DIARR)

 S %ZIS="QN",%ZIS("B")="",%ZIS("A")="PRINT FOUND ENTRIES TO DEVICE: " D ^%ZIS Q:POP

 S DIARPDEV=$S($D(ION)#2:ION,1:IO)

 I $D(IOST)#2,IOST]"" S DIARPDEV=DIARPDEV_";"_IOST

 F DIARZ="IOM","IOSL" S:($D(@DIARZ)#2&DIARZ) DIARPDEV=DIARPDEV_";"_@DIARZ

 I $D(IO("Q")) U IO(0) W !,"THE PRINTING OF REPORT WILL BE QUEUED.  PROCESSING CONTINUES..." S DIARQUED=""

ASKIX W !,"This archived file contains an index of all archived entries."

 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))

 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

 S DIARYY=""

 W ! F DIARXX=1:1:DIARCTR W ! S DIARTAB=0 D  I $Y>(DIOSL-2) D E Q:$D(DTOUT)!$D(DIRUT)

 . 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

. Q

 K DTOUT,DIRUT

DIARR1    ;SFISC/DCM-ARCHIVING FUNCTION, PROMPT FOR ARCHIVED RECORD ;7/1/93  8:43 AM

 +1       ;;22.0;VA FileMan;;Mar 30, 1999

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

PROC       DO N

           IF $DATA(DTOUT)!($DATA(DUOUT)&(DIARREQ'>0))!('$DATA(DIARR))

               QUIT

 +1        DO PRINTDEV

           IF POP

               QUIT

 +2        IF '$DATA(IO("Q"))

               USE IO(0)

               WRITE !,"Searching archived file..."

 +3        QUIT

 +4       ;

N          USE IO(0)

           IF '$DATA(DIARIDX)

               WRITE !!,"Type ?? at any prompt to display sampled entries.",!

 +1        WRITE !!,"Multiple requests may be made.",!,"One set of all prompts makes one request.",!

 +2        IF $DATA(DIARIDX)

               DO ASKIX

               IF $DATA(DIRUT)

                   QUIT

N1         WRITE !

 +1        KILL DIR

           SET DIR("?",1)="Enter the "_DIAR01_" (.01) field."

           SET DIR("?",2)="Answer to this prompt will retrieve all entries that match the "

           SET DIR("?")=DIAR01_" field."

           SET DIR("??")="^D HELP^DIARR1"

 +2        SET DIR(0)="FO"

           SET DIR("A")="Enter "_DIAR01

           DO ^DIR

 +3        IF ((X]"")&(X'="^"))

               SET DIARR(DIARREQ+1,".01")=X

 +4        IF $DATA(DTOUT)!(DIAROUT&(X=""))!($DATA(DUOUT))!('$DATA(DIARID)&$DATA(DIRUT))

               QUIT

 +5        IF $DATA(DIARID)

               DO IDS

               IF $DATA(DTOUT)

                   QUIT

 +6        IF $DATA(DIARR(DIARREQ+1))

               SET DIARREQ=DIARREQ+1

           GOTO N1

 +7       ;

IDS        SET DIAROUT=0

 +1        KILL DIR

           SET DIR(0)="FO"

           SET DIR("?",1)="Enter identifier information.  Answer to this prompt, along with all"

           SET DIR("?",2)="previously answered prompts for this request, will be used in the matching"

           SET DIR("?")="process."

 +2        SET DIR("??")="^D HELP^DIARR1"

 +3        FOR DIARZ=.019:0

               SET DIARZ=$ORDER(DIARID(DIARZ))

               IF DIARZ'>0

                   QUIT

               SET DIR("A")="Enter "_$PIECE(DIARID(DIARZ),U)_" (id) "

               DO ^DIR

               IF $DATA(DTOUT)!$DATA(DUOUT)

                   QUIT

               IF ((X]"")&(X'="^"))

                   SET DIARR(DIARREQ+1,"ID",+$PIECE(DIARID(DIARZ),U,2))=X

 +4        IF '$DATA(DIARR(DIARREQ+1))

               SET DIAROUT=1

               QUIT

 +5        QUIT

 +6       ;

HELP       SET DIARZHP=""

           WRITE @DIOF

 +1        FOR DIARHLP=0:0

               SET DIARHLP=$ORDER(^TMP("DIARHLP",$JOB,DIARHLP))

               IF DIARHLP'>0!$DATA(DTOUT)!$DATA(DIRUT)

                   QUIT

               WRITE !

FOR

                   SET DIARZHP=$ORDER(^TMP("DIARHLP",$JOB,DIARHLP,DIARZHP))

                   IF DIARZHP=""

                       QUIT

                   WRITE !,^(DIARZHP)

                   IF $Y>(DIOSL-3)

                       DO E

                       IF $DATA(DTOUT)!$DATA(DIRUT)

                           QUIT

 +2        QUIT

 +3       ;

E         ;

 +1        NEW DIR

           SET DIR(0)="E"

           DO ^DIR

           IF $DATA(DTOUT)!$DATA(DIRUT)

               QUIT

 +2        WRITE @DIOF

 +3        QUIT

 +4       ;

PRINTDEV   IF '$DATA(DIARR)

               QUIT

 +1        SET %ZIS="QN"

           SET %ZIS("B")=""

           SET %ZIS("A")="PRINT FOUND ENTRIES TO DEVICE: "

           DO ^%ZIS

           IF POP

               QUIT

 +2        SET DIARPDEV=$SELECT($DATA(ION)#2:ION,1:IO)

 +3        IF $DATA(IOST)#2

               IF IOST]""

                   SET DIARPDEV=DIARPDEV_";"_IOST

 +4        FOR DIARZ="IOM","IOSL"

               IF ($DATA(@DIARZ)#2&DIARZ)

                   SET DIARPDEV=DIARPDEV_";"_@DIARZ

 +5        IF $DATA(IO("Q"))

               USE IO(0)

               WRITE !,"THE PRINTING OF REPORT WILL BE QUEUED.  PROCESSING CONTINUES..."

               SET DIARQUED=""

 +6        QUIT

 +7       ;

ASKIX      WRITE !,"This archived file contains an index of all archived entries."

 +1        KILL DIR

           SET DIR(0)="Y"

           SET DIR("B")="YES"

           SET DIR("A")="Do you want to see the index now"

           DO ^DIR

           IF 'Y!($DATA(DIRUT))

               QUIT

 +2        WRITE @DIOF,!

           SET DIARTAB=0

           FOR DIARXX=1:1:DIARCNT

               SET DIARFLD=$PIECE(DIARPC(DIARXX),U,2)

               SET DIARTAB=DIARTAB+25

               WRITE $EXTRACT(DIARFLD,1,23),?DIARTAB

 +3        SET DIARYY=""

 +4        WRITE !

           FOR DIARXX=1:1:DIARCTR

               WRITE !

               SET DIARTAB=0

               Begin DoDot:1

 +5                FOR

                       SET DIARYY=$ORDER(DIARPC(DIARYY))

                       IF DIARYY'>0

                           QUIT

                       SET DIARFLD=+$GET(DIARPC(DIARYY))

                       SET DIARTAB=DIARTAB+25

                       WRITE $EXTRACT($PIECE($GET(^TMP("DIARHLP",$JOB,DIARXX,DIARFLD)),"= ",2),1,23),?DIARTAB

 +6                QUIT

               End DoDot:1

               IF $Y>(DIOSL-2)

                   DO E

                   IF $DATA(DTOUT)!$DATA(DIRUT)

                       QUIT

 +7        KILL DTOUT,DIRUT

 +8        QUIT

DIARR1.m