LRIPRE1 ;SLC/AM/DALISC/FHS - WKLD (CAP) CODE LIST REPORT PRE INSTALL/INIT 5.2 ;1/16/91 15:34 ;
;;5.2;LR;;NOV 01, 1997
;
;;5.2;LAB SERVICE;;Sep 27, 1994
EN ;
Q:'$D(DIFQ)
G:$G(LRVR)>5.11 CLEAN
I $G(^LAB(60,"PREINIT")) W !?10," I see you already have a list of CAP codes ",!,"from LABORATORY TEST file. ",!!,"Would you like another" S %=2 D YN^DICN G PRE:%=2,PRE:%<0 I %=0 D HLP G EN
W !!?5,"I will produce a list of CAP codes in your file LABORATORY TEST (#60) "
K %ZIS,^XTMP($J,"CAP") S %ZIS="",%ZIS("A")="Printer Name " D ^%ZIS G:POP PRE U IO
QUE ;
S (LRNAM,LRTS,LRHED,LRPG)=0 F S LRNAM=$O(^LAB(60,"B",LRNAM)) Q:LRNAM="" F LRTS=0:0 S LRTS=$O(^LAB(60,"B",LRNAM,LRTS)) Q:LRTS<.5 D PRNT
S I=$O(^XTMP($J,"CAP",0)) I $L(I) W @IOF,!!?10,"Alphabetical Listing of All CAP [WKLD] Codes In Use",! S DIC="^LAM(",DR=0,I="" F S I=$O(^XTMP($J,"CAP",I)) Q:I="" S DA=^(I) D EN^DIQ
K ^XTMP($J,"CAP")
G:'$G(LRVR) CLEAN
W:IOST["P-" @IOF D ^%ZISC I $D(ZTQUEUED) S ZTREQ="@" Q
PRE G:'$D(LRVR) CLEAN I $G(LRVR)>5.11 G CLEAN
LRO ;
N LRDD
W !!?10,"Purging Obsolete CAP CODES from ^LAB(60)",!
W !?10,"Also checking for broken pointers to ^DD(63.04, ",!
W ! F I=0:0 S I=$O(^LAB(60,I)) Q:I<1 D
. I $D(^LAB(60,I,0))#2,$P(^(0),U,3)="" S $P(^(0),U,3)="N"
. K ^LAB(60,I,9),^LAB(60,I,9.1) W:'I#100 "." S LRDD=+$G(^(.2)) I LRDD D
. . I '$D(^DD(63.04,LRDD,0))#2 K ^LAB(60,"C","CH;"_LRDD_";1"),^LAB(60,I,.2) I $D(^LAB(60,I,0))#2 W !,"Removing bad Data Name pointer for lab test ",$P(^(0),U) F A=5,12 S $P(^(0),U,A)=""
. . F J=0:0 S J=$O(^LAB(60,I,3,J)) Q:J<1 S:$D(^(J,0))#2 $P(^(0),U,3)="" K ^LAB(60,I,3,J,9)
LAM W !?10,"Purging the CAP CODE file:",!
S LRSAVE=$P($G(^LAM(0)),U,1,2),I=0 F S I=$O(^LAM(I)) Q:I="" K ^LAM(I) W:'I#100 "."
S:$L(LRSAVE) ^LAM(0)=LRSAVE I $D(^DD(64,0))#2 S DIU="^LAM(",DIU(0)="T" K LRSAVE D EN^DIU2 K DIU
W !?25,"^LAM( HAS BEEN PURGED ",!!
Q
PRNT ;
I '($D(^LAB(60,LRTS,0))#2) Q
Q:$P(^LAB(60,LRTS,0),U,3)="N"
I 'LRHED S LRPG=LRPG+1 W @IOF,!!!,?23,"LIST OF CAP [WKLD] CODES",?65,"Pg ",LRPG,!!,"TEST",?15,"CAP Code",?50,"Cap Number",! S LRHED=1
S LRJ=$O(^LAB(60,LRTS,9,0)) Q:LRJ=""
W !,$P(^LAB(60,LRTS,0),U),!
D:$D(^LAB(60,LRTS,9,LRJ,0))#2 PCC F LRK=0:0 S LRJ=$O(^LAB(60,LRTS,9,LRJ)) Q:LRJ<1 D:$D(^LAB(60,LRTS,9,LRJ,0))#2 PCC
Q
PCC ;
S LRX=^LAB(60,LRTS,9,LRJ,0),LRCC=+LRX G ERR:'$D(^LAM(LRCC,0)) S ^XTMP($J,"CAP",$P(^(0),U))=LRCC
W ?10,$S($D(^LAM(LRCC,0))#2:$P(^LAM(LRCC,0),U,1),1:""),?50,$P(LRX,U,2),?73,$S($P(LRX,U,3)=1:"DEF",1:""),! I $Y>(IOSL-6) S LRHED=0
Q
HLP W !!,"During the installation process of V5.2, your CAP entries in the Laboratory Test file will be deleted.",!," A record maybe useful when setting up the files for V 5.2 " Q
ERR W !?10,$C(7)," Error in CAP Code pointer "_LRCC,! Q
CLEAN ;I $G(LRVR)>5.11 D ^LRIPRE2
D ^%ZISC K ^XTMP($J,"CAP"),%ZIS,I,LRCC,LRHED,LRI,LRJ,LRK,LRTS,LRX,ZTSK,%,DIC,DA,DR Q
LRIPRE1 ;SLC/AM/DALISC/FHS - WKLD (CAP) CODE LIST REPORT PRE INSTALL/INIT 5.2 ;1/16/91 15:34 ;
+1 ;;5.2;LR;;NOV 01, 1997
+2 ;
+3 ;;5.2;LAB SERVICE;;Sep 27, 1994
EN ;
+1 IF '$DATA(DIFQ)
QUIT
+2 IF $GET(LRVR)>5.11
GOTO CLEAN
+3 IF $GET(^LAB(60,"PREINIT"))
WRITE !?10," I see you already have a list of CAP codes ",!,"from LABORATORY TEST file. ",!!,"Would you like another"
SET %=2
DO YN^DICN
IF %=2
GOTO PRE
IF %<0
GOTO PRE
IF %=0
DO HLP
GOTO EN
+4 WRITE !!?5,"I will produce a list of CAP codes in your file LABORATORY TEST (#60) "
+5 KILL %ZIS,^XTMP($JOB,"CAP")
SET %ZIS=""
SET %ZIS("A")="Printer Name "
DO ^%ZIS
IF POP
GOTO PRE
USE IO
QUE ;
+1 SET (LRNAM,LRTS,LRHED,LRPG)=0
FOR
SET LRNAM=$ORDER(^LAB(60,"B",LRNAM))
IF LRNAM=""
QUIT
FOR LRTS=0:0
SET LRTS=$ORDER(^LAB(60,"B",LRNAM,LRTS))
IF LRTS<.5
QUIT
DO PRNT
+2 SET I=$ORDER(^XTMP($JOB,"CAP",0))
IF $LENGTH(I)
WRITE @IOF,!!?10,"Alphabetical Listing of All CAP [WKLD] Codes In Use",!
SET DIC="^LAM("
SET DR=0
SET I=""
FOR
SET I=$ORDER(^XTMP($JOB,"CAP",I))
IF I=""
QUIT
SET DA=^(I)
DO EN^DIQ
+3 KILL ^XTMP($JOB,"CAP")
+4 IF '$GET(LRVR)
GOTO CLEAN
+5 IF IOST["P-"
WRITE @IOF
DO ^%ZISC
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
PRE IF '$DATA(LRVR)
GOTO CLEAN
IF $GET(LRVR)>5.11
GOTO CLEAN
LRO ;
+1 NEW LRDD
+2 WRITE !!?10,"Purging Obsolete CAP CODES from ^LAB(60)",!
+3 WRITE !?10,"Also checking for broken pointers to ^DD(63.04, ",!
+4 WRITE !
FOR I=0:0
SET I=$ORDER(^LAB(60,I))
IF I<1
QUIT
Begin DoDot:1
+5 IF $DATA(^LAB(60,I,0))#2
IF $PIECE(^(0),U,3)=""
SET $PIECE(^(0),U,3)="N"
+6 KILL ^LAB(60,I,9),^LAB(60,I,9.1)
IF 'I#100
WRITE "."
SET LRDD=+$GET(^(.2))
IF LRDD
Begin DoDot:2
+7 IF '$DATA(^DD(63.04,LRDD,0))#2
KILL ^LAB(60,"C","CH;"_LRDD_";1"),^LAB(60,I,.2)
IF $DATA(^LAB(60,I,0))#2
WRITE !,"Removing bad Data Name pointer for lab test ",$PIECE(^(0),U)
FOR A=5,12
SET $PIECE(^(0),U,A)=""
+8 FOR J=0:0
SET J=$ORDER(^LAB(60,I,3,J))
IF J<1
QUIT
IF $DATA(^(J,0))#2
SET $PIECE(^(0),U,3)=""
KILL ^LAB(60,I,3,J,9)
End DoDot:2
End DoDot:1
LAM WRITE !?10,"Purging the CAP CODE file:",!
+1 SET LRSAVE=$PIECE($GET(^LAM(0)),U,1,2)
SET I=0
FOR
SET I=$ORDER(^LAM(I))
IF I=""
QUIT
KILL ^LAM(I)
IF 'I#100
WRITE "."
+2 IF $LENGTH(LRSAVE)
SET ^LAM(0)=LRSAVE
IF $DATA(^DD(64,0))#2
SET DIU="^LAM("
SET DIU(0)="T"
KILL LRSAVE
DO EN^DIU2
KILL DIU
+3 WRITE !?25,"^LAM( HAS BEEN PURGED ",!!
+4 QUIT
PRNT ;
+1 IF '($DATA(^LAB(60,LRTS,0))#2)
QUIT
+2 IF $PIECE(^LAB(60,LRTS,0),U,3)="N"
QUIT
+3 IF 'LRHED
SET LRPG=LRPG+1
WRITE @IOF,!!!,?23,"LIST OF CAP [WKLD] CODES",?65,"Pg ",LRPG,!!,"TEST",?15,"CAP Code",?50,"Cap Number",!
SET LRHED=1
+4 SET LRJ=$ORDER(^LAB(60,LRTS,9,0))
IF LRJ=""
QUIT
+5 WRITE !,$PIECE(^LAB(60,LRTS,0),U),!
+6 IF $DATA(^LAB(60,LRTS,9,LRJ,0))#2
DO PCC
FOR LRK=0:0
SET LRJ=$ORDER(^LAB(60,LRTS,9,LRJ))
IF LRJ<1
QUIT
IF $DATA(^LAB(60,LRTS,9,LRJ,0))#2
DO PCC
+7 QUIT
PCC ;
+1 SET LRX=^LAB(60,LRTS,9,LRJ,0)
SET LRCC=+LRX
IF '$DATA(^LAM(LRCC,0))
GOTO ERR
SET ^XTMP($JOB,"CAP",$PIECE(^(0),U))=LRCC
+2 WRITE ?10,$SELECT($DATA(^LAM(LRCC,0))#2:$PIECE(^LAM(LRCC,0),U,1),1:""),?50,$PIECE(LRX,U,2),?73,$SELECT($PIECE(LRX,U,3)=1:"DEF",1:""),!
IF $Y>(IOSL-6)
SET LRHED=0
+3 QUIT
HLP WRITE !!,"During the installation process of V5.2, your CAP entries in the Laboratory Test file will be deleted.",!," A record maybe useful when setting up the files for V 5.2 "
QUIT
ERR WRITE !?10,$CHAR(7)," Error in CAP Code pointer "_LRCC,!
QUIT
CLEAN ;I $G(LRVR)>5.11 D ^LRIPRE2
+1 DO ^%ZISC
KILL ^XTMP($JOB,"CAP"),%ZIS,I,LRCC,LRHED,LRI,LRJ,LRK,LRTS,LRX,ZTSK,%,DIC,DA,DR
QUIT
