- DIARR5 ;SFISC/DCM-ARCHIVING(READ ARCHIVED FG)-PRINT REQUEST ;4/8/93 8:00 AM
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
- DIARR5 ;SFISC/DCM-ARCHIVING(READ ARCHIVED FG)-PRINT REQUEST ;4/8/93 8:00 AM
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
