DIARR5 ;SFISC/DCM-ARCHIVING(READ ARCHIVED FG)-PRINT REQUEST ;4/8/93 8:00 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.
;
PRINT I $D(DIARQUED) G Q
S IOP=DIARPDEV D ^%ZIS G Q:POP
DQ S DIARPG=0
F DIARY=0:0 S DIARY=$O(DIARR(DIARY)) Q:DIARY'>0 D HD Q:$D(DTOUT)!($D(DIRUT)) D PRINT1:$D(^TMP("DIARO",$J,DIARY)) W:'$D(^TMP("DIARO",$J,DIARY)) !,?11,"MATCHES FOUND: ",DIARRF(DIARY)
D ^%ZISC
Q
;
PRINT1 F DIARZ=0:0 S DIARZ=$O(^TMP("DIARO",$J,DIARY,DIARZ)) Q:DIARZ'>0!$D(DTOUT)!$D(DIRUT) W ! F DIARZ1=0:0 S DIARZ1=$O(^TMP("DIARO",$J,DIARY,DIARZ,DIARZ1)) Q:DIARZ1'>0 W ^(DIARZ1),! I $Y>(IOSL-2) D HD Q:$D(DTOUT)!$D(DIRUT)
W !,?11,"MATCHES FOUND: ",DIARRF(DIARY)
Q
;
HD U IO
I "C"[$E(IOST) K DIR S DIR(0)="E" D ^DIR Q:$D(DTOUT)!($D(DIRUT))
S Y=DT X ^DD("DD")
W:$Y @IOF W "ARCHIVE RETRIEVAL LIST",?60,Y,?72,"PAGE: ",DIARPG+1
HD1 W !,"REQUEST: ",DIARY W:$D(DIARR(DIARY,.01)) !,?2,DIAR01," = ",DIARR(DIARY,.01) D HD2:$D(DIARR(DIARY,"ID"))
S $P(DIARLINE,"-",IOM)="" W !,DIARLINE,! S DIARPG=DIARPG+1
Q
;
HD2 F DIARX1=0:0 S DIARX1=$O(DIARR(DIARY,"ID",DIARX1)) Q:DIARX1'>0 W:DIARX1 !,?2,$P(DIARID(DIARX1),U)," = ",DIARR(DIARY,"ID",DIARX1)
Q
;
Q S ZTRTN="DQ^DIARR5",ZTDTH=$H,ZTSAVE("DIARR(")="",ZTSAVE("^TMP(""DIARO"",$J,")="",ZTSAVE("DIARRF(")="",ZTDESC="RETRIEVAL OF ARCHIVED DATA",ZTIO=DIARPDEV,ZTSAVE("DIAR01")="",ZTSAVE("DIARID(")=""
D ^%ZTLOAD,HOME^%ZIS
U IO(0) W !! I '$D(DIARQUED) W:POP "UNABLE TO OPEN SELECTED PRINTER AT THIS TIME. "
W "OUTPUT QUEUED!"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIARR5 1763 printed Oct 16, 2024@18:45:28 Page 2
DIARR5 ;SFISC/DCM-ARCHIVING(READ ARCHIVED FG)-PRINT REQUEST ;4/8/93 8:00 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 ;
PRINT IF $DATA(DIARQUED)
GOTO Q
+1 SET IOP=DIARPDEV
DO ^%ZIS
if POP
GOTO Q
DQ SET DIARPG=0
+1 FOR DIARY=0:0
SET DIARY=$ORDER(DIARR(DIARY))
if DIARY'>0
QUIT
DO HD
if $DATA(DTOUT)!($DATA(DIRUT))
QUIT
if $DATA(^TMP("DIARO",$JOB,DIARY))
DO PRINT1
if '$DATA(^TMP("DIARO",$JOB,DIARY))
WRITE !,?11,"MATCHES FOUND: ",DIARRF(DIARY)
+2 DO ^%ZISC
+3 QUIT
+4 ;
PRINT1 FOR DIARZ=0:0
SET DIARZ=$ORDER(^TMP("DIARO",$JOB,DIARY,DIARZ))
if DIARZ'>0!$DATA(DTOUT)!$DATA(DIRUT)
QUIT
WRITE !
FOR DIARZ1=0:0
SET DIARZ1=$ORDER(^TMP("DIARO",$JOB,DIARY,DIARZ,DIARZ1))
if DIARZ1'>0
QUIT
WRITE ^(DIARZ1),!
IF $Y>(IOSL-2)
DO HD
if $DATA(DTOUT)!$DATA(DIRUT)
QUIT
+1 WRITE !,?11,"MATCHES FOUND: ",DIARRF(DIARY)
+2 QUIT
+3 ;
HD USE IO
+1 IF "C"[$EXTRACT(IOST)
KILL DIR
SET DIR(0)="E"
DO ^DIR
if $DATA(DTOUT)!($DATA(DIRUT))
QUIT
+2 SET Y=DT
XECUTE ^DD("DD")
+3 if $Y
WRITE @IOF
WRITE "ARCHIVE RETRIEVAL LIST",?60,Y,?72,"PAGE: ",DIARPG+1
HD1 WRITE !,"REQUEST: ",DIARY
if $DATA(DIARR(DIARY,.01))
WRITE !,?2,DIAR01," = ",DIARR(DIARY,.01)
if $DATA(DIARR(DIARY,"ID"))
DO HD2
+1 SET $PIECE(DIARLINE,"-",IOM)=""
WRITE !,DIARLINE,!
SET DIARPG=DIARPG+1
+2 QUIT
+3 ;
HD2 FOR DIARX1=0:0
SET DIARX1=$ORDER(DIARR(DIARY,"ID",DIARX1))
if DIARX1'>0
QUIT
if DIARX1
WRITE !,?2,$PIECE(DIARID(DIARX1),U)," = ",DIARR(DIARY,"ID",DIARX1)
+1 QUIT
+2 ;
Q SET ZTRTN="DQ^DIARR5"
SET ZTDTH=$HOROLOG
SET ZTSAVE("DIARR(")=""
SET ZTSAVE("^TMP(""DIARO"",$J,")=""
SET ZTSAVE("DIARRF(")=""
SET ZTDESC="RETRIEVAL OF ARCHIVED DATA"
SET ZTIO=DIARPDEV
SET ZTSAVE("DIAR01")=""
SET ZTSAVE("DIARID(")=""
+1 DO ^%ZTLOAD
DO HOME^%ZIS
+2 USE IO(0)
WRITE !!
IF '$DATA(DIARQUED)
if POP
WRITE "UNABLE TO OPEN SELECTED PRINTER AT THIS TIME. "
+3 WRITE "OUTPUT QUEUED!"
+4 QUIT
