LRSETUP ;SLC/CJS/DALISC/FHS - REINITIALIZE DATA FILES ;2/6/91 14:34 ;
;;5.2;LAB SERVICE;;Sep 27, 1994
W !!,">> I WILL DO SOME FILE CHECKING AND THIS MAY TAKE A LITTLE WHILE <<",!!
I $D(^LAB(62.4,1,0))[0 D
. F L +^LAB(62.4):1 Q:$T W !!?7,"Someone else is editing the Automated Instrument file ",!!,$C(7) H 30
. S ^(0)="^LABDATA",DIE="^LAB(62.4,",DR=".01///LSI#1;2///LAB",DA=1 D ^DIE W !,"I have added a LSI controller #1 to the auto instrument file",!,"Please check this entry after the init is finished",!,$C(7)
. L -^LAB(62.4)
F I=0:0 S I=$O(^LRO(68.2,I)) Q:I'>0 F J=0:0 S J=$O(^LRO(68.2,I,10,J)) Q:J'>0 F K=0:0 S K=$O(^LRO(68.2,I,10,J,1,K)) Q:K'>0 I $S($D(^(K,0)):$E($P(^(0),"^",3),1),1:0)="Y" S $P(^(0),"^",3)=1
S $P(^LAB(64.5,1,1,0),"^")="MAJOR HEADER"
Q
FRESH I '$D(^XUSEC("LRLIASON",DUZ)) W !,"Not cleared for this option." Q
POST W !!,"This procedure will purge/kill all entries in the ^LR( global"
W !,"and the ^LRO( global. This should not be ran by any site already"
W !,"running the Laboratory Package. It should only be used by First"
W !,"Time Installation Sites. If your are not a First Time installation"
W !,"DO NOT RUN this routine. If you have questions, contact your "
W !,"Information Systems Center (ISC) before continuing"
W !!?10,"Do you Wish to continue "
S %=2 D YN^DICN G:%=0 POST Q:%'=1
W !!?10,"ARE YOU CERTAIN - LAST CHANCE " S %=2 D YN^DICN G:%=0 POST Q:%'=1
W !!,"In order to continue, you must answer the next prompt by"
W !,"entering 'YES' -- A simple 'Y' will not work",!
W !!,"IF YOU ARE READY ANSWER 'YES' " R ANS:100 Q:'$T Q:ANS'="YES"
W !!?5,"This will take a while ",!
K ^LR("AAU"),^("AAUA"),^("ACY"),^("ACYA"),^("AEM"),^("AEMA"),^("ASP"),^("ASPA"),^("B"),^("AD") S ^LR(0)=$P(^LR(0),"^",1,2) S I=0 F S I=$O(^LR(I)) Q:I<1 K ^LR(I)
I $D(^LRD(65,0)) S X=$P(^LRD(65,0),"^",1,2),^LRD(65,0)=X,I=0 F A=0:0 S I=$O(^LRD(65,I)) Q:I="" K ^(I)
I $D(^LRE(0)) K ^LRE("AD"),^LRE("AT"),^LRE("B"),^("C"),^("D"),^("G"),^("G4") S ^LRE(0)=$P(^LRE(0),"^",1,2) S I=0 F S I=$O(^LRE(I)) Q:I<1 K ^LRE(I)
S I=0 F S I=$O(^DPT(I)) Q:I<1 I $D(^DPT(I,"LR")) K ^DPT(I,"LR")
F I=0:0 S I=$O(^LAB(62.3,I)) Q:I<1 S X=$P(^(I,0),U) I '$D(^LAB(62.3,"B",X)) K ^LAB(62.3,I)
S LRDPF="62.3^LAB(62.3," S I=0 F S I=$O(^LAB(62.3,I)) Q:I<1 K ^LAB(62.3,I,"LR") S DFN=I D END^LRDPA
F F=67,67.1,67.2,67.3 S I=0 F S I=$O(^LRT(F,I)) Q:I<1 K ^LRT(F,I,"LR")
S X=$P(^LRO(67.9,0),U,1,2) K ^LRO(67.9) S ^LRO(67.9,0)=X
S I=0 F S I=$O(^LRO(68,I)) Q:I<1 K ^LRO(68,I,1)
S I=0 F S I=$O(^LRO(69.2,I)) Q:I<1 S J=0 F S J=$O(^LRO(69.2,I,J)) Q:J<1 K ^LRO(69.2,I,J)
S ^LAC(0)="" F I=0:0 S I=$O(^LAC(I)) Q:I="" K ^(I)
K ^LRO(68,"AA"),^("AC"),^("MI"),^("AVS"),^LAC("LRAC"),^("LRPHSET"),^("LGOT"),^("DEV") S ^LAC("LRAC",0)="CUMULATIVE^64.7",X=$P(^LRO(69,0),"^",1,2) K ^LRO(69) S ^LRO(69,0)=X
F I=0:0 S I=$O(^LRO(68.2,I)) Q:I<1 K ^(I,1)
S X=$P(^LRO(69.1,0),U,1,2) K ^LRO(69.1) S ^LRO(69.1,0)=X
S X=$P(^LRO(69.2,0),U,1,2) K ^LRO(69.2) S ^LRO(69.2,0)=X
S X=$P(^LRO(64.1,0),U,1,2) K ^LRO(64.1) S ^LRO(64.1,0)=X
W !!?10,"Your files have been purged to day 1 status",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSETUP 3147 printed Apr 09, 2024@21:14:02 Page 2
LRSETUP ;SLC/CJS/DALISC/FHS - REINITIALIZE DATA FILES ;2/6/91 14:34 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
+2 WRITE !!,">> I WILL DO SOME FILE CHECKING AND THIS MAY TAKE A LITTLE WHILE <<",!!
+3 IF $DATA(^LAB(62.4,1,0))[0
Begin DoDot:1
+4 FOR
LOCK +^LAB(62.4):1
if $TEST
QUIT
WRITE !!?7,"Someone else is editing the Automated Instrument file ",!!,$CHAR(7)
HANG 30
+5 SET ^(0)="^LABDATA"
SET DIE="^LAB(62.4,"
SET DR=".01///LSI#1;2///LAB"
SET DA=1
DO ^DIE
WRITE !,"I have added a LSI controller #1 to the auto instrument file",!,"Please check this entry after the init is finished",!,$CHAR(7)
+6 LOCK -^LAB(62.4)
End DoDot:1
+7 FOR I=0:0
SET I=$ORDER(^LRO(68.2,I))
if I'>0
QUIT
FOR J=0:0
SET J=$ORDER(^LRO(68.2,I,10,J))
if J'>0
QUIT
FOR K=0:0
SET K=$ORDER(^LRO(68.2,I,10,J,1,K))
if K'>0
QUIT
IF $SELECT($DATA(^(K,0)):$EXTRACT($PIECE(^(0),"^",3),1),1:0)="Y"
SET $PIECE(^(0),"^",3)=1
+8 SET $PIECE(^LAB(64.5,1,1,0),"^")="MAJOR HEADER"
+9 QUIT
FRESH IF '$DATA(^XUSEC("LRLIASON",DUZ))
WRITE !,"Not cleared for this option."
QUIT
POST WRITE !!,"This procedure will purge/kill all entries in the ^LR( global"
+1 WRITE !,"and the ^LRO( global. This should not be ran by any site already"
+2 WRITE !,"running the Laboratory Package. It should only be used by First"
+3 WRITE !,"Time Installation Sites. If your are not a First Time installation"
+4 WRITE !,"DO NOT RUN this routine. If you have questions, contact your "
+5 WRITE !,"Information Systems Center (ISC) before continuing"
+6 WRITE !!?10,"Do you Wish to continue "
+7 SET %=2
DO YN^DICN
if %=0
GOTO POST
if %'=1
QUIT
+8 WRITE !!?10,"ARE YOU CERTAIN - LAST CHANCE "
SET %=2
DO YN^DICN
if %=0
GOTO POST
if %'=1
QUIT
+9 WRITE !!,"In order to continue, you must answer the next prompt by"
+10 WRITE !,"entering 'YES' -- A simple 'Y' will not work",!
+11 WRITE !!,"IF YOU ARE READY ANSWER 'YES' "
READ ANS:100
if '$TEST
QUIT
if ANS'="YES"
QUIT
+12 WRITE !!?5,"This will take a while ",!
+13 KILL ^LR("AAU"),^("AAUA"),^("ACY"),^("ACYA"),^("AEM"),^("AEMA"),^("ASP"),^("ASPA"),^("B"),^("AD")
SET ^LR(0)=$PIECE(^LR(0),"^",1,2)
SET I=0
FOR
SET I=$ORDER(^LR(I))
if I<1
QUIT
KILL ^LR(I)
+14 IF $DATA(^LRD(65,0))
SET X=$PIECE(^LRD(65,0),"^",1,2)
SET ^LRD(65,0)=X
SET I=0
FOR A=0:0
SET I=$ORDER(^LRD(65,I))
if I=""
QUIT
KILL ^(I)
+15 IF $DATA(^LRE(0))
KILL ^LRE("AD"),^LRE("AT"),^LRE("B"),^("C"),^("D"),^("G"),^("G4")
SET ^LRE(0)=$PIECE(^LRE(0),"^",1,2)
SET I=0
FOR
SET I=$ORDER(^LRE(I))
if I<1
QUIT
KILL ^LRE(I)
+16 SET I=0
FOR
SET I=$ORDER(^DPT(I))
if I<1
QUIT
IF $DATA(^DPT(I,"LR"))
KILL ^DPT(I,"LR")
+17 FOR I=0:0
SET I=$ORDER(^LAB(62.3,I))
if I<1
QUIT
SET X=$PIECE(^(I,0),U)
IF '$DATA(^LAB(62.3,"B",X))
KILL ^LAB(62.3,I)
+18 SET LRDPF="62.3^LAB(62.3,"
SET I=0
FOR
SET I=$ORDER(^LAB(62.3,I))
if I<1
QUIT
KILL ^LAB(62.3,I,"LR")
SET DFN=I
DO END^LRDPA
+19 FOR F=67,67.1,67.2,67.3
SET I=0
FOR
SET I=$ORDER(^LRT(F,I))
if I<1
QUIT
KILL ^LRT(F,I,"LR")
+20 SET X=$PIECE(^LRO(67.9,0),U,1,2)
KILL ^LRO(67.9)
SET ^LRO(67.9,0)=X
+21 SET I=0
FOR
SET I=$ORDER(^LRO(68,I))
if I<1
QUIT
KILL ^LRO(68,I,1)
+22 SET I=0
FOR
SET I=$ORDER(^LRO(69.2,I))
if I<1
QUIT
SET J=0
FOR
SET J=$ORDER(^LRO(69.2,I,J))
if J<1
QUIT
KILL ^LRO(69.2,I,J)
+23 SET ^LAC(0)=""
FOR I=0:0
SET I=$ORDER(^LAC(I))
if I=""
QUIT
KILL ^(I)
+24 KILL ^LRO(68,"AA"),^("AC"),^("MI"),^("AVS"),^LAC("LRAC"),^("LRPHSET"),^("LGOT"),^("DEV")
SET ^LAC("LRAC",0)="CUMULATIVE^64.7"
SET X=$PIECE(^LRO(69,0),"^",1,2)
KILL ^LRO(69)
SET ^LRO(69,0)=X
+25 FOR I=0:0
SET I=$ORDER(^LRO(68.2,I))
if I<1
QUIT
KILL ^(I,1)
+26 SET X=$PIECE(^LRO(69.1,0),U,1,2)
KILL ^LRO(69.1)
SET ^LRO(69.1,0)=X
+27 SET X=$PIECE(^LRO(69.2,0),U,1,2)
KILL ^LRO(69.2)
SET ^LRO(69.2,0)=X
+28 SET X=$PIECE(^LRO(64.1,0),U,1,2)
KILL ^LRO(64.1)
SET ^LRO(64.1,0)=X
+29 WRITE !!?10,"Your files have been purged to day 1 status",!!
+30 QUIT
