- LRARREP ; IHS/DIR/AAB - PRINT REPORT OF ARCHIVAL ACTIVITY 6/95 ; [ 07/22/2002 1:08 PM ]
- ;;5.2;LR;**1002,1013**;JUL 15, 2002
- ;;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
- LRARREP ; IHS/DIR/AAB - PRINT REPORT OF ARCHIVAL ACTIVITY 6/95 ; [ 07/22/2002 1:08 PM ]
- +1 ;;5.2;LR;**1002,1013**;JUL 15, 2002
- +2 ;;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
