LRCHIV ;SLC/RWF - SET UP O("S") VARIABLES FOR ARCHIVE. ;2/5/91 12:30 ;
;;5.2;LAB SERVICE;;Sep 27, 1994
EN01 ;
SEARCH ;
D FLAG G RESTART:F1=1
I F1>1 W !,"Please finish the Clear and Purge steps first." G QUIT
I F1=0 S:'$D(^LAB(69.9,1,6,0)) ^LAB(69.9,1,6,0)="^69.9003A^^" D TAPE G QUIT:DA<1
G QUIT:P1<1 D DEV G QUIT:POP S LRDFN=0
PAT W !,"Do you want a list of patients that will have data archived" S %=2 D YN^DICN I %=0 W !,"Answering YES to this question will produce a list of patients that will have data archived." G PAT
S LRPAT=0 S:%=1 LRPAT=1
T S ^LAB(69.9,1,"TAPE")=P1,$P(^LAB(69.9,1,6,P1,0),U,4)=1,X=1
I $D(IO("Q")) S ZTRTN="DQ1^LRCHIV" F I="F1","P1","LR(","LRDFN","LRPAT" S ZTSAVE(I)=""
I $D(IO("Q")) D ^%ZTLOAD K IO("Q") G QUIT
DQ1 U IO S C1=1,C2=0,C3=0,Y=LR(1) D DD^LRX W @IOF,!,"LAB DATA ARCHIVED for data before ",Y W ". on" D STAMP^LRX S X=1 X ^%ZOSF("PRIORITY")
S LRSUB=1 F S LRSUB=$O(^DD(63.04,LRSUB)) Q:LRSUB<1 I $D(^(LRSUB,0)),'$D(^DD(63.999904,LRSUB)) S X0=^DD(63.04,LRSUB,0),X3=$S($D(^(3)):^(3),1:""),^DD(63.999904,LRSUB,0)=X0 S:X3'="" ^(3)=X3 S ^DD(63.999904,"B",$P(X0,U),LRSUB)=""
K X,Y,L1,L2
L +^LAR D DFN^LRCHIVE S $P(^LAB(69.9,1,6,P1,0),U,4)=2 L -^LAR
LST I LRPAT W @IOF S PNM="" F S PNM=$O(^LAR("NAME",PNM)) Q:PNM="" S LRDFN=0 F S LRDFN=$O(^LAR("NAME",PNM,LRDFN)) Q:LRDFN<1 D
. I $D(^LR(LRDFN,0))#2 N PNM S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3) D DEM^LRX W !,PNM,?30,SSN
. I '$D(^LR(LRDFN,0))#2 W !!,PNM," LRDFN # "_LRDFN_" Has Been Deleted from ^LR( ",!,$C(7),"SSN = Unknown",!
QUIT D KILL D ^%ZISC,KVAR^VADPT K F1,C1,C2,C3 U IO(0) Q
RESTART W !,"Search not complete." L +^LAR:1 I '$T W !,"Searching in progress, please wait for it to finish." G QUIT
L -^LAR
W !,"Do you want to restart the search" S %=1 D YN^DICN I %'=1 W:%=0 !,"Continue where the last search stopped." G RESTART:%=0,QUIT
D DEV G QUIT:POP S LRDFN=$S($D(^LAB(69.9,1,"LRDFN")):^("LRDFN"),1:0) G PAT
TAPE S DA=0,DIC="^LAB(69.9,1,6,",DIC(0)="AEMQL",DLAYGO=69 D ^DIC K DLAYGO Q:Y<1 S DA=+Y I '$P(Y,U,3) W !,"You must create a NEW name for this ARCHIVE." G TAPE
DT S %DT("A")="Archive DATE: ",%DT("B")="T-90",%DT="AEQ" D ^%DT I Y<1 W !,"OK, lets forget it." S DA=-1 Q
S LR(1)=$E(Y,1,5)_"00",LR(2)=9999999-LR(1),X1=LR(1),X2=-365 D C^%DTC S LR(3)=9999999-X
S P1=DA,DIE=DIC,DR="1;2///N;4///"_LR(1) D ^DIE K DIC Q
EN02 ;
CLEAN ;REMOVE ^LAR FOR READ TAPE IN
W !,"I will now CLEAR out the global"
D FLAG I F1<2 W !,"Search pass has not completed. Want to CLEAR ^LAR anyway" S %=1 D YN^DICN G QUIT:%'=1
S X="" F I=0:0 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." Q
EN03 ;
PURGE ;PURGE DATA FROM ^LR THAT IS IN ^LAR
D FLAG
I F1<3 W !,"You have not done the clear and reload of the global yet.",$C(7) Q
I F1'=3 W !,"PURGE in progress, or completed. Please let it finish." Q
D DEV G QUIT:POP
I $D(IO("Q")) K IO("Q") S ZTRTN="DQ2^LRCHIV",ZTSAVE("P1")="",ZTSAVE("F1")="",ZTSAVE("LR(")="" D ^%ZTLOAD G QUIT
DQ2 I $P(^LAB(69.9,1,6,P1,0),U,4)'=3 W !!,"Not in the right state.",!! G QUIT
S $P(^LAB(69.9,1,6,P1,0),U,4)=4 D EN^LRCHIVK S $P(^LAB(69.9,1,6,P1,0),U,4)=5
K ^LAR("NAME"),^LAR("SSN"),^LAR("Z"),^LAB(69.9,1,"TAPE"),^LAB(69.9,1,"LRDFN"),^LAB(69.9,1,"PURGE LRDFN") S ^LAR("Z",0)="ARCHIVED LR DATA^63.9999" G QUIT
FLAG S U="^",P1=$S($D(^LAB(69.9,1,"TAPE")):^("TAPE"),1:0),F1=$S($D(^LAB(69.9,1,6,P1,0)):$P(^(0),U,4),1:0)
I P1,F1 S LR(1)=$P(^LAB(69.9,1,6,P1,0),U,5),LR(2)=9999999-LR(1),X1=LR(1),X2=-365 D C^%DTC S LR(3)=9999999-X
Q
DEV 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,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE
Q
PRT ;
S %ZIS="Q",%ZIS("A")="Printer " D DEV I POP D KILL Q
S LRPAT=1 I $D(IO("Q")) S ZTRTN="LST^LRCHIV",ZTSAVE("LRPAT")="",ZTDESC="Print Archive Patients" D ^%ZTLOAD G KILL
D LST G KILL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCHIV 4124 printed Apr 09, 2024@21:18:28 Page 2
LRCHIV ;SLC/RWF - SET UP O("S") VARIABLES FOR ARCHIVE. ;2/5/91 12:30 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
EN01 ;
SEARCH ;
+1 DO FLAG
if F1=1
GOTO RESTART
+2 IF F1>1
WRITE !,"Please finish the Clear and Purge steps first."
GOTO QUIT
+3 IF F1=0
if '$DATA(^LAB(69.9,1,6,0))
SET ^LAB(69.9,1,6,0)="^69.9003A^^"
DO TAPE
if DA<1
GOTO QUIT
+4 if P1<1
GOTO QUIT
DO DEV
if POP
GOTO QUIT
SET LRDFN=0
PAT WRITE !,"Do you want a list of patients that will have data archived"
SET %=2
DO YN^DICN
IF %=0
WRITE !,"Answering YES to this question will produce a list of patients that will have data archived."
GOTO PAT
+1 SET LRPAT=0
if %=1
SET LRPAT=1
T SET ^LAB(69.9,1,"TAPE")=P1
SET $PIECE(^LAB(69.9,1,6,P1,0),U,4)=1
SET X=1
+1 IF $DATA(IO("Q"))
SET ZTRTN="DQ1^LRCHIV"
FOR I="F1","P1","LR(","LRDFN","LRPAT"
SET ZTSAVE(I)=""
+2 IF $DATA(IO("Q"))
DO ^%ZTLOAD
KILL IO("Q")
GOTO QUIT
DQ1 USE IO
SET C1=1
SET C2=0
SET C3=0
SET Y=LR(1)
DO DD^LRX
WRITE @IOF,!,"LAB DATA ARCHIVED for data before ",Y
WRITE ". on"
DO STAMP^LRX
SET X=1
XECUTE ^%ZOSF("PRIORITY")
+1 SET LRSUB=1
FOR
SET LRSUB=$ORDER(^DD(63.04,LRSUB))
if LRSUB<1
QUIT
IF $DATA(^(LRSUB,0))
IF '$DATA(^DD(63.999904,LRSUB))
SET X0=^DD(63.04,LRSUB,0)
SET X3=$SELECT($DATA(^(3)):^(3),1:"")
SET ^DD(63.999904,LRSUB,0)=X0
if X3'=""
SET ^(3)=X3
SET ^DD(63.999904,"B",$PIECE(X0,U),LRSUB)=""
+2 KILL X,Y,L1,L2
+3 LOCK +^LAR
DO DFN^LRCHIVE
SET $PIECE(^LAB(69.9,1,6,P1,0),U,4)=2
LOCK -^LAR
LST IF LRPAT
WRITE @IOF
SET PNM=""
FOR
SET PNM=$ORDER(^LAR("NAME",PNM))
if PNM=""
QUIT
SET LRDFN=0
FOR
SET LRDFN=$ORDER(^LAR("NAME",PNM,LRDFN))
if LRDFN<1
QUIT
Begin DoDot:1
+1 IF $DATA(^LR(LRDFN,0))#2
NEW PNM
SET LRDPF=$PIECE(^LR(LRDFN,0),"^",2)
SET DFN=$PIECE(^(0),"^",3)
DO DEM^LRX
WRITE !,PNM,?30,SSN
+2 IF '$DATA(^LR(LRDFN,0))#2
WRITE !!,PNM," LRDFN # "_LRDFN_" Has Been Deleted from ^LR( ",!,$CHAR(7),"SSN = Unknown",!
End DoDot:1
QUIT DO KILL
DO ^%ZISC
DO KVAR^VADPT
KILL F1,C1,C2,C3
USE IO(0)
QUIT
RESTART WRITE !,"Search not complete."
LOCK +^LAR:1
IF '$TEST
WRITE !,"Searching in progress, please wait for it to finish."
GOTO QUIT
+1 LOCK -^LAR
+2 WRITE !,"Do you want to restart the search"
SET %=1
DO YN^DICN
IF %'=1
if %=0
WRITE !,"Continue where the last search stopped."
if %=0
GOTO RESTART
GOTO QUIT
+3 DO DEV
if POP
GOTO QUIT
SET LRDFN=$SELECT($DATA(^LAB(69.9,1,"LRDFN")):^("LRDFN"),1:0)
GOTO PAT
TAPE SET DA=0
SET DIC="^LAB(69.9,1,6,"
SET DIC(0)="AEMQL"
SET DLAYGO=69
DO ^DIC
KILL DLAYGO
if Y<1
QUIT
SET DA=+Y
IF '$PIECE(Y,U,3)
WRITE !,"You must create a NEW name for this ARCHIVE."
GOTO TAPE
DT SET %DT("A")="Archive DATE: "
SET %DT("B")="T-90"
SET %DT="AEQ"
DO ^%DT
IF Y<1
WRITE !,"OK, lets forget it."
SET DA=-1
QUIT
+1 SET LR(1)=$EXTRACT(Y,1,5)_"00"
SET LR(2)=9999999-LR(1)
SET X1=LR(1)
SET X2=-365
DO C^%DTC
SET LR(3)=9999999-X
+2 SET P1=DA
SET DIE=DIC
SET DR="1;2///N;4///"_LR(1)
DO ^DIE
KILL DIC
QUIT
EN02 ;
CLEAN ;REMOVE ^LAR FOR READ TAPE IN
+1 WRITE !,"I will now CLEAR out the global"
+2 DO FLAG
IF F1<2
WRITE !,"Search pass has not completed. Want to CLEAR ^LAR anyway"
SET %=1
DO YN^DICN
if %'=1
GOTO QUIT
+3 SET X=""
FOR I=0:0
SET X=$ORDER(^LAR(X))
if X=""
QUIT
KILL ^LAR(X)
+4 SET ^LAR("Z",0)="ARCHIVED LR DATA^63.9999"
+5 IF P1
IF $PIECE(^LAB(69.9,1,6,P1,0),U,4)=2
SET $PIECE(^(0),U,4)=3
+6 WRITE !!,"Now read the tape back in to make sure we have a good tape."
+7 WRITE !,"Then do the PURGE pass."
QUIT
EN03 ;
PURGE ;PURGE DATA FROM ^LR THAT IS IN ^LAR
+1 DO FLAG
+2 IF F1<3
WRITE !,"You have not done the clear and reload of the global yet.",$CHAR(7)
QUIT
+3 IF F1'=3
WRITE !,"PURGE in progress, or completed. Please let it finish."
QUIT
+4 DO DEV
if POP
GOTO QUIT
+5 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN="DQ2^LRCHIV"
SET ZTSAVE("P1")=""
SET ZTSAVE("F1")=""
SET ZTSAVE("LR(")=""
DO ^%ZTLOAD
GOTO QUIT
DQ2 IF $PIECE(^LAB(69.9,1,6,P1,0),U,4)'=3
WRITE !!,"Not in the right state.",!!
GOTO QUIT
+1 SET $PIECE(^LAB(69.9,1,6,P1,0),U,4)=4
DO EN^LRCHIVK
SET $PIECE(^LAB(69.9,1,6,P1,0),U,4)=5
+2 KILL ^LAR("NAME"),^LAR("SSN"),^LAR("Z"),^LAB(69.9,1,"TAPE"),^LAB(69.9,1,"LRDFN"),^LAB(69.9,1,"PURGE LRDFN")
SET ^LAR("Z",0)="ARCHIVED LR DATA^63.9999"
GOTO QUIT
FLAG SET U="^"
SET P1=$SELECT($DATA(^LAB(69.9,1,"TAPE")):^("TAPE"),1:0)
SET F1=$SELECT($DATA(^LAB(69.9,1,6,P1,0)):$PIECE(^(0),U,4),1:0)
+1 IF P1
IF F1
SET LR(1)=$PIECE(^LAB(69.9,1,6,P1,0),U,5)
SET LR(2)=9999999-LR(1)
SET X1=LR(1)
SET X2=-365
DO C^%DTC
SET LR(3)=9999999-X
+2 QUIT
DEV SET %ZIS="Q"
if '$DATA(%ZIS("A"))
SET %ZIS("A")="ERROR LOG REPORT: "
DO ^%ZIS
KILL %ZIS
QUIT
+1 QUIT
KILL WRITE !
if $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
+1 SET ZTQUE="@"
DO ^%ZISC
KILL I,J,LRPAT,LRDAT,LRDPF,LRIDT,LRSS,LRSUB,P1,PNM,SSN,X0,X1,X2,X3,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE
+2 QUIT
PRT ;
+1 SET %ZIS="Q"
SET %ZIS("A")="Printer "
DO DEV
IF POP
DO KILL
QUIT
+2 SET LRPAT=1
IF $DATA(IO("Q"))
SET ZTRTN="LST^LRCHIV"
SET ZTSAVE("LRPAT")=""
SET ZTDESC="Print Archive Patients"
DO ^%ZTLOAD
GOTO KILL
+3 DO LST
GOTO KILL
