DIARR1 ;SFISC/DCM-ARCHIVING FUNCTION, PROMPT FOR ARCHIVED RECORD ;7/1/93 8:43 AM
;;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.
;
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..."
Q
;
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
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)
Q
;
E ;
N DIR S DIR(0)="E" D ^DIR Q:$D(DTOUT)!$D(DIRUT)
W @DIOF
Q
;
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=""
Q
;
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIARR1 3007 printed Sep 23, 2025@20:20:57 Page 2
DIARR1 ;SFISC/DCM-ARCHIVING FUNCTION, PROMPT FOR ARCHIVED RECORD ;7/1/93 8:43 AM
+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 ;
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
