LRAR01 ;DAL/HOAK EXTENSION OF LRAR00 ; 12/12/96 10:16 ;
;;5.2;LAB SERVICE;**111**;Sep 27, 1994
INIT ;
;
;
EN02 ;
CLEAN ;
; REMOVE ^LAR FOR READ TAPE IN
;
W !,"I will now CLEAR out the global"
D FLAG
;
S OK=1
I F1<2 W !,"Search pass has not completed. " D
. W "Want to CLEAR ^LAR anyway" S %=1 D YN^DICN S:%'=1 OK=0
Q:'OK
;
S X=100
F S X=$O(^LAR(X)) Q:X="" K ^LAR(X)
S ^LAR("Z",0)="ARCHIVED LR DATA^63.9999"
I P1,$P(^LAB(69.9,1,6,P1,0),U,4)=2 S $P(^(0),U,4)=3
W !!,"Now read the tape back in to make sure we have a good tape."
W !,"Then do the PURGE pass."
QUIT
EN03 ;
PURGE ;
; PURGE DATA FROM ^LR THAT IS IN ^LAR
D FLAG
;
I F1<3 W !," Please clear and reload the archive global.",$C(7) Q
;
I F1'=3 W !,"PURGE in progress, or completed. Please let it finish." Q
;
D DEV1^LRAR01 I POP D QUIT Q
;
I $D(IO("Q")) K IO("Q") S ZTRTN="DQ2^LRCHIV",ZTSAVE("P1")="" D QUIT
. S ZTSAVE("F1")="",ZTSAVE("LR(")="" D ^%ZTLOAD D QUIT
;
DQ2 ;
I $P(^LAB(69.9,1,6,P1,0),U,4)'=3 D D QUIT Q
. W !!,"Not in the right state.",!!
S $P(^LAB(69.9,1,6,P1,0),U,4)=4
D EN^LRAR05 S $P(^LAB(69.9,1,6,P1,0),U,4)=5
K ^LAR("NAME"),^LAR("SSN"),^LAR("Z"),^LAB(69.9,1,"TAPE")
K ^LAB(69.9,1,"LRDFN"),^LAB(69.9,1,"PURGE LRDFN")
S ^LAR("Z",0)="ARCHIVED LR DATA^63.9999"
D QUIT
Q
;
FLAG ;
; Whats happening in 69.9....
;
S P1=$S($D(^LAB(69.9,1,"TAPE")):^("TAPE"),1:0)
;
S F1=$S($D(^LAB(69.9,1,6,P1,0)):$P(^(0),U,4),1:0)
;
; ^LAB(69.9,1,6,1,0) = TEST^TEST PHYSICAL^2860808.0904^1^2860500
; Set a date range for LRIDT
;
Q
DEV ;
D DEVICE^LRARCHIV
QUIT
DEV1 S %ZIS="Q"
S:'$D(%ZIS("A")) %ZIS("A")="ERROR LOG REPORT: "
D ^%ZIS K %ZIS Q
Q
;
KILL ;
W ! W:$E(IOST,1,2)="P-" @IOF
S ZTQUE="@"
D ^%ZISC
K I,J,LRPAT,LRDAT,LRDPF,LRIDT,LRSS,LRSUB,P1,PNM,SSN,X0,X1,X2,X3
K ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE
Q
;
PRT ;
Q
S %ZIS="Q",%ZIS("A")="Printer "
D DEV
I POP D KILL Q
;
S LRPAT=1
I $D(IO("Q")) S ZTRTN="LST^LRARCHIV",ZTSAVE("LRPAT")="" D
. S ZTDESC="Print Archive Patients" D ^%ZTLOAD G KILL
D LST^LRARCHIV
QUIT D KILL
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAR01 2175 printed Oct 16, 2024@18:09:34 Page 2
LRAR01 ;DAL/HOAK EXTENSION OF LRAR00 ; 12/12/96 10:16 ;
+1 ;;5.2;LAB SERVICE;**111**;Sep 27, 1994
INIT ;
+1 ;
+2 ;
EN02 ;
CLEAN ;
+1 ; REMOVE ^LAR FOR READ TAPE IN
+2 ;
+3 WRITE !,"I will now CLEAR out the global"
+4 DO FLAG
+5 ;
+6 SET OK=1
+7 IF F1<2
WRITE !,"Search pass has not completed. "
Begin DoDot:1
+8 WRITE "Want to CLEAR ^LAR anyway"
SET %=1
DO YN^DICN
if %'=1
SET OK=0
End DoDot:1
+9 if 'OK
QUIT
+10 ;
+11 SET X=100
+12 FOR
SET X=$ORDER(^LAR(X))
if X=""
QUIT
KILL ^LAR(X)
+13 SET ^LAR("Z",0)="ARCHIVED LR DATA^63.9999"
+14 IF P1
IF $PIECE(^LAB(69.9,1,6,P1,0),U,4)=2
SET $PIECE(^(0),U,4)=3
+15 WRITE !!,"Now read the tape back in to make sure we have a good tape."
+16 WRITE !,"Then do the PURGE pass."
+17 QUIT
EN03 ;
PURGE ;
+1 ; PURGE DATA FROM ^LR THAT IS IN ^LAR
+2 DO FLAG
+3 ;
+4 IF F1<3
WRITE !," Please clear and reload the archive global.",$CHAR(7)
QUIT
+5 ;
+6 IF F1'=3
WRITE !,"PURGE in progress, or completed. Please let it finish."
QUIT
+7 ;
+8 DO DEV1^LRAR01
IF POP
DO QUIT
QUIT
+9 ;
+10 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN="DQ2^LRCHIV"
SET ZTSAVE("P1")=""
Begin DoDot:1
+11 SET ZTSAVE("F1")=""
SET ZTSAVE("LR(")=""
DO ^%ZTLOAD
DO QUIT
End DoDot:1
QUIT
+12 ;
DQ2 ;
+1 IF $PIECE(^LAB(69.9,1,6,P1,0),U,4)'=3
Begin DoDot:1
+2 WRITE !!,"Not in the right state.",!!
End DoDot:1
DO QUIT
QUIT
+3 SET $PIECE(^LAB(69.9,1,6,P1,0),U,4)=4
+4 DO EN^LRAR05
SET $PIECE(^LAB(69.9,1,6,P1,0),U,4)=5
+5 KILL ^LAR("NAME"),^LAR("SSN"),^LAR("Z"),^LAB(69.9,1,"TAPE")
+6 KILL ^LAB(69.9,1,"LRDFN"),^LAB(69.9,1,"PURGE LRDFN")
+7 SET ^LAR("Z",0)="ARCHIVED LR DATA^63.9999"
+8 DO QUIT
+9 QUIT
+10 ;
FLAG ;
+1 ; Whats happening in 69.9....
+2 ;
+3 SET P1=$SELECT($DATA(^LAB(69.9,1,"TAPE")):^("TAPE"),1:0)
+4 ;
+5 SET F1=$SELECT($DATA(^LAB(69.9,1,6,P1,0)):$PIECE(^(0),U,4),1:0)
+6 ;
+7 ; ^LAB(69.9,1,6,1,0) = TEST^TEST PHYSICAL^2860808.0904^1^2860500
+8 ; Set a date range for LRIDT
+9 ;
+10 QUIT
DEV ;
+1 DO DEVICE^LRARCHIV
+2 QUIT
DEV1 SET %ZIS="Q"
+1 if '$DATA(%ZIS("A"))
SET %ZIS("A")="ERROR LOG REPORT: "
+2 DO ^%ZIS
KILL %ZIS
QUIT
+3 QUIT
+4 ;
KILL ;
+1 WRITE !
if $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
+2 SET ZTQUE="@"
+3 DO ^%ZISC
+4 KILL I,J,LRPAT,LRDAT,LRDPF,LRIDT,LRSS,LRSUB,P1,PNM,SSN,X0,X1,X2,X3
+5 KILL ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE
+6 QUIT
+7 ;
PRT ;
+1 QUIT
+2 SET %ZIS="Q"
SET %ZIS("A")="Printer "
+3 DO DEV
+4 IF POP
DO KILL
QUIT
+5 ;
+6 SET LRPAT=1
+7 IF $DATA(IO("Q"))
SET ZTRTN="LST^LRARCHIV"
SET ZTSAVE("LRPAT")=""
Begin DoDot:1
+8 SET ZTDESC="Print Archive Patients"
DO ^%ZTLOAD
GOTO KILL
End DoDot:1
+9 DO LST^LRARCHIV
QUIT DO KILL
+1 QUIT
