LRARREP ;DALISC/CKA - PRINT REPORT OF ARCHIVAL ACTIVITY;6/95
;;5.2;LABORATORY;**59**;August 31,1995
EN ;Entry point to print an archival activity report.
D DT^DICRW
AAR S DIC(0)="AEMZ",DIC="^LAB(95.11,"
D ^DIC
G:$D(DTOUT)!($D(DUOUT))!(Y<0) EXIT
S LRARID=+Y
Q S %ZIS="Q" D ^%ZIS G:POP EXIT I '$D(IO("Q")) U IO D START G EXIT
S ZTRTN="START^LRARREP",ZTSAVE("LRAR*")="",ZTDESC="REPORT OF ARCHIVAL ACTIVITY" D ^%ZTLOAD,HOME^%ZIS G EXIT
START ; BEGINS THE PRINT OF THIS ARCHIVE REPORT
K ^UTILITY("DIQ1",$J) S (END,PAGE)=0 D HDR G:END EXIT
S DIC="^LAB(95.11,",DA=LRARID,DR=".01;1;2;3;4;5;7;7.5;8;9;10;11;15;16;18;19;20",DIQ(0)="E" D EN^DIQ1 I '$D(^UTILITY("DIQ1",$J,95.11,DA)) W !,"RECORD DOESN'T EXIST!" G EXIT
NUM W !,"ARCHIVE NUMBER: ",$G(^UTILITY("DIQ1",$J,95.11,DA,.01,"E"))
FILE W !,"FILE: ",$G(^UTILITY("DIQ1",$J,95.11,DA,1,"E"))
DF W !,"DESTINATION FILE: ",$G(^UTILITY("DIQ1",$J,95.11,DA,15,"E"))
STAT W !,"ARCHIVAL STATUS: ",$G(^UTILITY("DIQ1",$J,95.11,DA,7,"E"))
SD W !,"SELECT DATE: ",$G(^UTILITY("DIQ1",$J,95.11,DA,4,"E"))
SEL W !,"SELECTOR: ",$G(^UTILITY("DIQ1",$J,95.11,DA,7.5,"E"))
ARD W !,"ARCHIVE DATE: ",$G(^UTILITY("DIQ1",$J,95.11,DA,9,"E"))
ARC W !,"ARCHIVER: ",$G(^UTILITY("DIQ1",$J,95.11,DA,5,"E"))
TASK W !,"ARCHIVE TASK NUMBER: ",$G(^UTILITY("DIQ1",$J,95.11,DA,18,"E"))
PD W !,"PURGE DATE: ",$G(^UTILITY("DIQ1",$J,95.11,DA,10,"E"))
PUR W !,"PURGER: ",$G(^UTILITY("DIQ1",$J,95.11,DA,8,"E"))
ADL W !,"ARCHIVE DEVICE LABEL: ",$G(^UTILITY("DIQ1",$J,95.11,DA,16,"E"))
BEG W !,"BEGINNING DATE: ",$G(^UTILITY("DIQ1",$J,95.11,DA,19,"E"))
EDT W !,"ENDING DATE: ",$G(^UTILITY("DIQ1",$J,95.11,DA,20,"E"))
RESULT I '$D(^LAB(95.11,LRARID,"RESULT")) W !!,"NO RESULTS"
ERROR W !!,"THE FOLLOWING RECORDS IN THE FILE WERE NOT MOVED BECAUSE OF ONE OR MORE ERRORS:",!
N REC,LINE,FILE S PAGE=0,FILE=0,REC=0,END=0 D FIL
W !!,"*** PLEASE KEEP THIS FOR FUTURE REFERENCE ***"
G END
FIL ;
S LINE="Entry # "
S FILE=$O(^LAB(95.11,LRARID,"RESULT","ERR",FILE)) Q:'FILE D REC
Q:END
G FIL
REC S REC=$O(^LAB(95.11,LRARID,"RESULT","ERR",FILE,REC)) Q:'REC S ERR=^(REC)
S LINE=LINE_REC_" was NOT processed because:"
W !!,LINE N A,B S A=1,LINE="Entry # " D ERR
Q:END
G REC
ERR S B=$P(ERR,";",A) Q:B="" S A=A+1
N Z S Z=0
F S Z=$O(^LAB(95.11,LRARID,"RESULT","DIERR",+B,"TEXT",Z)) Q:'Z W !?5,$G(^(Z)) D HDR:($Y+1>IOSL)
Q:END
G ERR
;
END I $E(IOST)'="C",$Y W @IOF
D ^%ZISC
Q
EXIT K %ZIS,DA,DIC,DIQ,DIR,DIRUT,DIWF,DIWL,DIWR,DR,END,ERR,LRARID,PAGE,X,Y,ZTDESC,ZTRTN,ZTSAVE
K ^UTILITY("DIQ1",$J)
D CLN^LRARU1
QUIT
HDR ;PRINT HEADING
I $E(IOST,1,2)="C-" W !,"Press RETURN to continue or '^' to exit: " R X:DTIME S END='$T!(X="^") Q:END
S PAGE=PAGE+1 W @IOF,!?25,"ARCHIVAL ACTIVITY REPORT",?(IOM-10),"Page ",$J(PAGE,3)
W !!?61,"Date/Time Printed"
D NOW^%DTC S Y=% X ^DD("DD") W !?61,$P(Y,":",1,2)
W !!
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRARREP 2881 printed Oct 16, 2024@18:10:20 Page 2
LRARREP ;DALISC/CKA - PRINT REPORT OF ARCHIVAL ACTIVITY;6/95
+1 ;;5.2;LABORATORY;**59**;August 31,1995
EN ;Entry point to print an archival activity report.
+1 DO DT^DICRW
AAR SET DIC(0)="AEMZ"
SET DIC="^LAB(95.11,"
+1 DO ^DIC
+2 if $DATA(DTOUT)!($DATA(DUOUT))!(Y<0)
GOTO EXIT
+3 SET LRARID=+Y
Q SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO EXIT
IF '$DATA(IO("Q"))
USE IO
DO START
GOTO EXIT
+1 SET ZTRTN="START^LRARREP"
SET ZTSAVE("LRAR*")=""
SET ZTDESC="REPORT OF ARCHIVAL ACTIVITY"
DO ^%ZTLOAD
DO HOME^%ZIS
GOTO EXIT
START ; BEGINS THE PRINT OF THIS ARCHIVE REPORT
+1 KILL ^UTILITY("DIQ1",$JOB)
SET (END,PAGE)=0
DO HDR
if END
GOTO EXIT
+2 SET DIC="^LAB(95.11,"
SET DA=LRARID
SET DR=".01;1;2;3;4;5;7;7.5;8;9;10;11;15;16;18;19;20"
SET DIQ(0)="E"
DO EN^DIQ1
IF '$DATA(^UTILITY("DIQ1",$JOB,95.11,DA))
WRITE !,"RECORD DOESN'T EXIST!"
GOTO EXIT
NUM WRITE !,"ARCHIVE NUMBER: ",$GET(^UTILITY("DIQ1",$JOB,95.11,DA,.01,"E"))
FILE WRITE !,"FILE: ",$GET(^UTILITY("DIQ1",$JOB,95.11,DA,1,"E"))
DF WRITE !,"DESTINATION FILE: ",$GET(^UTILITY("DIQ1",$JOB,95.11,DA,15,"E"))
STAT WRITE !,"ARCHIVAL STATUS: ",$GET(^UTILITY("DIQ1",$JOB,95.11,DA,7,"E"))
SD WRITE !,"SELECT DATE: ",$GET(^UTILITY("DIQ1",$JOB,95.11,DA,4,"E"))
SEL WRITE !,"SELECTOR: ",$GET(^UTILITY("DIQ1",$JOB,95.11,DA,7.5,"E"))
ARD WRITE !,"ARCHIVE DATE: ",$GET(^UTILITY("DIQ1",$JOB,95.11,DA,9,"E"))
ARC WRITE !,"ARCHIVER: ",$GET(^UTILITY("DIQ1",$JOB,95.11,DA,5,"E"))
TASK WRITE !,"ARCHIVE TASK NUMBER: ",$GET(^UTILITY("DIQ1",$JOB,95.11,DA,18,"E"))
PD WRITE !,"PURGE DATE: ",$GET(^UTILITY("DIQ1",$JOB,95.11,DA,10,"E"))
PUR WRITE !,"PURGER: ",$GET(^UTILITY("DIQ1",$JOB,95.11,DA,8,"E"))
ADL WRITE !,"ARCHIVE DEVICE LABEL: ",$GET(^UTILITY("DIQ1",$JOB,95.11,DA,16,"E"))
BEG WRITE !,"BEGINNING DATE: ",$GET(^UTILITY("DIQ1",$JOB,95.11,DA,19,"E"))
EDT WRITE !,"ENDING DATE: ",$GET(^UTILITY("DIQ1",$JOB,95.11,DA,20,"E"))
RESULT IF '$DATA(^LAB(95.11,LRARID,"RESULT"))
WRITE !!,"NO RESULTS"
ERROR WRITE !!,"THE FOLLOWING RECORDS IN THE FILE WERE NOT MOVED BECAUSE OF ONE OR MORE ERRORS:",!
+1 NEW REC,LINE,FILE
SET PAGE=0
SET FILE=0
SET REC=0
SET END=0
DO FIL
+2 WRITE !!,"*** PLEASE KEEP THIS FOR FUTURE REFERENCE ***"
+3 GOTO END
FIL ;
+1 SET LINE="Entry # "
+2 SET FILE=$ORDER(^LAB(95.11,LRARID,"RESULT","ERR",FILE))
if 'FILE
QUIT
DO REC
+3 if END
QUIT
+4 GOTO FIL
REC SET REC=$ORDER(^LAB(95.11,LRARID,"RESULT","ERR",FILE,REC))
if 'REC
QUIT
SET ERR=^(REC)
+1 SET LINE=LINE_REC_" was NOT processed because:"
+2 WRITE !!,LINE
NEW A,B
SET A=1
SET LINE="Entry # "
DO ERR
+3 if END
QUIT
+4 GOTO REC
ERR SET B=$PIECE(ERR,";",A)
if B=""
QUIT
SET A=A+1
+1 NEW Z
SET Z=0
+2 FOR
SET Z=$ORDER(^LAB(95.11,LRARID,"RESULT","DIERR",+B,"TEXT",Z))
if 'Z
QUIT
WRITE !?5,$GET(^(Z))
if ($Y+1>IOSL)
DO HDR
+3 if END
QUIT
+4 GOTO ERR
+5 ;
END IF $EXTRACT(IOST)'="C"
IF $Y
WRITE @IOF
+1 DO ^%ZISC
+2 QUIT
EXIT KILL %ZIS,DA,DIC,DIQ,DIR,DIRUT,DIWF,DIWL,DIWR,DR,END,ERR,LRARID,PAGE,X,Y,ZTDESC,ZTRTN,ZTSAVE
+1 KILL ^UTILITY("DIQ1",$JOB)
+2 DO CLN^LRARU1
+3 QUIT
HDR ;PRINT HEADING
+1 IF $EXTRACT(IOST,1,2)="C-"
WRITE !,"Press RETURN to continue or '^' to exit: "
READ X:DTIME
SET END='$TEST!(X="^")
if END
QUIT
+2 SET PAGE=PAGE+1
WRITE @IOF,!?25,"ARCHIVAL ACTIVITY REPORT",?(IOM-10),"Page ",$JUSTIFY(PAGE,3)
+3 WRITE !!?61,"Date/Time Printed"
+4 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
WRITE !?61,$PIECE(Y,":",1,2)
+5 WRITE !!
+6 QUIT
