LR72PRE ; IHS/DIR/AAB - PRE-INSTALL ROUTINE FOR LR*5.2*72 ;
;;5.2;LR;**1002**;JUN 01, 1998
;;5.2;LAB SERVICE;**72**;SEP 27, 1994
;
D LR127P ;IHS/OIRM TUC/AAB 2/17/98
D DD ;IHS/DIR TUC/AAB 05/22/98
D LRARIPRE ;IHS/DIR TUC/AAB 05/18/98
D LR138P ;IHS/DIR TUC/AAB 05/19/98
D PRELR163 ;IHS/DIR TUC/AAB 05/20/98
W !!,"Pre Install Completed ",!!
Q
LR127P ;
EN ;
Q:'$D(XPDNM)
I $O(^LAB(64.81,0)) W !?5,"You have old data in LAB NLT/CPT CODES file ",!,"INSTALL ABORTED ",$C(7) S XPDQUIT=2 Q
N DA,DIK
S DA(1)=69.9,DA=615,DIK="^DD(69.9," D ^DIK
K DA,DIK S DA(1)=64,DA=18,DIK="^DD(64," D ^DIK
K DA,DIK S DA(1)=64,DA=14,DIK="^DD(64," D ^DIK
K DA,DIK S DA(1)=69.9,DA=614,DIK="^DD(69.9," D ^DIK
K:'$D(^LAB(64.81,0)) ^LAM("AD")
W !,$$CJ^XLFSTR("Pre Install 127 Complete",80),!!
Q
DD ;
K DIK,DA S DIK="^DD(66,",DA(1)=66 F DA=1,2 D ^DIK
K DIK,DA S DIK="^DD(69.9,",DA=1 D ^DIK
K DIK,DA
Q
LRARIPRE ;
EN1 ;
W !!,">>> Deleting OLD 'LAB' ARCHIVE FILES.",!
AWD W !!,"DELETING ARCHIVED WKLD DATA FILE."
S DIU="^LRO(64.19999,",DIU(0)="D" D EN^DIU2
ALM W !!,"DELETING ARCHIVED LAB MONTHLY WORKLOADS FILE."
S DIU="^LRO(67.99999,",DIU(0)="D" D EN^DIU2
ABI W !!,"DELETING ARCHIVED BLOOD INVENTORY FILE."
S DIU="^LRD(65.9999,",DIU(0)="D" D EN^DIU2
K DIU
W !!,"The data dictionaries for these files will be reinstalled during the inits."
Q
BXREF ;Kills B xref on PATIENT XMATCH field (#65.01)
;This xref is in the DD's but not the file.
Q:'$D(^DD(65.01,0,"IX","B",65.01,.01)) ;already deleted
S LRARI=0 F S LRARI=$O(^DD(65.01,.01,1,LRARI)) Q:'LRARI D
. K:$G(^DD(65.01,.01,1,LRARI,0))="65.01^B" ^DD(65.01,.01,1,LRARI)
K ^DD(65.01,0,"IX","B",65.01,.01)
K:'$O(^DD(65.01,.01,1,0)) ^DD(65.01,"IX",.01) ;no xrefs left on field
Q
LR138P ;
EN2 ;
Q:'$D(XPDNM)
;Removing Alpha site dds
K DIK,DA S DA(1)=63.04,DIK="^DD(63.04," F DA=.064,.065,.066,.067 D ^DIK
K DIK,DA S DA(1)=63.05,DIK="^DD(63.05," F DA=.064,.065,.066,.067 D ^DIK
K DIK,DA S DA(1)=68.02,DIK="^DD(68.02," F DA=95,96,97,98 D ^DIK
K DIK,DA
I $O(^LAB(64.81,0)) W !?5,"You still have unistalled data in LAB NLT/CPT CODES file ",!,$C(7)
S X="SCDXUAPI" X ^%ZOSF("TEST") I '$T D S XPDQUIT=2 Q
.;W !!,$$CJ^XLFSTR("You must Load the SD*5.3*63 to add OOS clinic locations",80),!,$$CJ^XLFSTR("BEFORE YOU INSTALL THIS PATCH",80),!! S LRSDCX=1
S LRPKG=$O(^DIC(9.4,"B","LR",0))
I 'LRPKG S LRPKG=$O(^DIC(9.4,"B","LAB SERVICE",0))
I 'LRPKG W !!?10,"Not able to find 'LAB SERVICE' in your Package (#9.4) file.",!,"Contact your IRM Service !!",!!,$C(7) H 5 S XPDQUIT=2 Q
K DA,DIK S DA(1)=64,DA=14,DIK="^DD(64," D ^DIK K DA,DIK
W !!,$$CJ^XLFSTR("LOCKING THE ^LRO(69,AA) GLOBAL",80),!
L +LRO(69,"AA"):10 I '$T W !!?5,"Not able to LOCK ^LRO(69,AA) Global" S XPDQUIT=2 Q
W !,$$CJ^XLFSTR("Pre Install 138 Complete",80),!!
Q
PRELR163 ;
PRE ;LR*5.2*163 AFTER USER COMMITS ROUTINE KIDS INSTALL"
ENPRE ;
Q:'$D(XPDNM)
;Cleanup broken X-Ref
N I,N
S I=0 F S I=$O(^LAM(I)) Q:I<1 D
. Q:'$D(^LAM(I,"7","B","LRDATA"))
. S N=0 F S N=$O(^LAM(I,7,"B","LRDATA",N)) Q:N<1 D
. . K ^LAM(I,7,"B","LRDATA",N),^LAM(I,7,N,0)
. . I $P(^LAM(I,7,0),U,4) S $P(^LAM(I,7,0),U,4)=$P(^LAM(I,7,0),U,4)-1
I $D(^LAB(64.81,0))#2 S X=$P(^(0),U,1,2) K ^LAB(64.81) S ^LAB(64.81,0)=X
S:$D(^LAM(0))#2 $P(^LAM(0),U,3)=2225 D
. D BMES^XPDUTL($$CJ^XLFSTR("Removing 'Reserve 2 field (#8) in WKLD CODE file (#64).",80))
. D BMES^XPDUTL($$CJ^XLFSTR("The field will be renamed 'PRICE'.",80))
. N DA,DIK
. S DA=8,DIK="^DD(64," D ^DIK
D BMES^XPDUTL($$CJ^XLFSTR("Removing 'Reserve 2 field (#8) in WKLD CODE SUFFIX file (#64.2).",80))
D BMES^XPDUTL($$CJ^XLFSTR("The field will be renamed 'PRICE'.",80)) D
. N DA,DIK
. S DA=8,DIK="^DD(64.2," D ^DIK
D BMES^XPDUTL($$CJ^XLFSTR("Removing existing CPT codes for WKLD CODE file.",80))
W ! S I=0 F S I=$O(^LAM(I)) Q:I<1 D
. I '$D(^LAM(I,0))#2 K ^LAM(I) Q
. S:'$P(^LAM(I,0),U,7) $P(^(0),U,7)=38 K:$D(^LAM(I,4)) ^LAM(I,4) W:'(I#50) "."
K ^LAM("AD")
D SPCK
D BMES^XPDUTL($$CJ^XLFSTR("** Pre Install 163 Complete **",80))
Q
SPCK K ^XTMP("LR","SPELL ERR")
S ^XTMP("LR","SPELL ERR")="LR*5.2*163 Spelling errors"
D BMES^XPDUTL($$CJ^XLFSTR("Correcting Duplicates or Spelling Errors",80))
D BMES^XPDUTL($$CJ^XLFSTR("Names that begin with 'X*' have codes that are incorrect.",80))
K CK S CK="" F I=1:1 S LN=$T(SPELL+I) Q:$P(LN,";;",2)="STOP" S CK(I)=LN
S I=0 F S I=$O(CK(I)) Q:I<1 D BMES^XPDUTL($$CJ^XLFSTR($P(CK(I),";",3)_" "_$P(CK(I),";",4),80))
K DIC S DIC=64,DIC(0)="XNZM"
S II=0 F S II=$O(CK(II)) Q:II<1 D
. S X=$P(CK(II),";",3)_".0000",NM=$P(CK(II),";",4) D ^DIC
. I Y<1 D BMES^XPDUTL($$CJ^XLFSTR("*** Unable to find WKLD Code [ "_X_" ] in your file #64 ****",80)) Q
. ;W !,Y W:Y>1 !,Y(0)
. S LNX=$P(Y,U,2) I LNX'=NM S CK=1 D FILE
D BMES^XPDUTL($$CJ^XLFSTR("Spelling updates completed.",80))
Q
SPELL ;
;;97485;X*Hepatitis C RNA;
;;STOP
FILE ;
N LRROOT,DA
D BMES^XPDUTL($$CJ^XLFSTR("Correcting Spelling of entry "_+Y_" from "_LNX_" to "_NM,80))
S DA=+Y,LRROOT(64,DA_",",.01)=NM
D FILE^DIE("","LRROOT",^XTMP("LR","SPELL ERR"))
Q
LR72PRE ; IHS/DIR/AAB - PRE-INSTALL ROUTINE FOR LR*5.2*72 ;
+1 ;;5.2;LR;**1002**;JUN 01, 1998
+2 ;;5.2;LAB SERVICE;**72**;SEP 27, 1994
+3 ;
+4 ;IHS/OIRM TUC/AAB 2/17/98
DO LR127P
+5 ;IHS/DIR TUC/AAB 05/22/98
DO DD
+6 ;IHS/DIR TUC/AAB 05/18/98
DO LRARIPRE
+7 ;IHS/DIR TUC/AAB 05/19/98
DO LR138P
+8 ;IHS/DIR TUC/AAB 05/20/98
DO PRELR163
+9 WRITE !!,"Pre Install Completed ",!!
+10 QUIT
LR127P ;
EN ;
+1 IF '$DATA(XPDNM)
QUIT
+2 IF $ORDER(^LAB(64.81,0))
WRITE !?5,"You have old data in LAB NLT/CPT CODES file ",!,"INSTALL ABORTED ",$CHAR(7)
SET XPDQUIT=2
QUIT
+3 NEW DA,DIK
+4 SET DA(1)=69.9
SET DA=615
SET DIK="^DD(69.9,"
DO ^DIK
+5 KILL DA,DIK
SET DA(1)=64
SET DA=18
SET DIK="^DD(64,"
DO ^DIK
+6 KILL DA,DIK
SET DA(1)=64
SET DA=14
SET DIK="^DD(64,"
DO ^DIK
+7 KILL DA,DIK
SET DA(1)=69.9
SET DA=614
SET DIK="^DD(69.9,"
DO ^DIK
+8 IF '$DATA(^LAB(64.81,0))
KILL ^LAM("AD")
+9 WRITE !,$$CJ^XLFSTR("Pre Install 127 Complete",80),!!
+10 QUIT
DD ;
+1 KILL DIK,DA
SET DIK="^DD(66,"
SET DA(1)=66
FOR DA=1,2
DO ^DIK
+2 KILL DIK,DA
SET DIK="^DD(69.9,"
SET DA=1
DO ^DIK
+3 KILL DIK,DA
+4 QUIT
LRARIPRE ;
EN1 ;
+1 WRITE !!,">>> Deleting OLD 'LAB' ARCHIVE FILES.",!
AWD WRITE !!,"DELETING ARCHIVED WKLD DATA FILE."
+1 SET DIU="^LRO(64.19999,"
SET DIU(0)="D"
DO EN^DIU2
ALM WRITE !!,"DELETING ARCHIVED LAB MONTHLY WORKLOADS FILE."
+1 SET DIU="^LRO(67.99999,"
SET DIU(0)="D"
DO EN^DIU2
ABI WRITE !!,"DELETING ARCHIVED BLOOD INVENTORY FILE."
+1 SET DIU="^LRD(65.9999,"
SET DIU(0)="D"
DO EN^DIU2
+2 KILL DIU
+3 WRITE !!,"The data dictionaries for these files will be reinstalled during the inits."
+4 QUIT
BXREF ;Kills B xref on PATIENT XMATCH field (#65.01)
+1 ;This xref is in the DD's but not the file.
+2 ;already deleted
IF '$DATA(^DD(65.01,0,"IX","B",65.01,.01))
QUIT
+3 SET LRARI=0
FOR
SET LRARI=$ORDER(^DD(65.01,.01,1,LRARI))
IF 'LRARI
QUIT
Begin DoDot:1
+4 IF $GET(^DD(65.01,.01,1,LRARI,0))="65.01^B"
KILL ^DD(65.01,.01,1,LRARI)
End DoDot:1
+5 KILL ^DD(65.01,0,"IX","B",65.01,.01)
+6 ;no xrefs left on field
IF '$ORDER(^DD(65.01,.01,1,0))
KILL ^DD(65.01,"IX",.01)
+7 QUIT
LR138P ;
EN2 ;
+1 IF '$DATA(XPDNM)
QUIT
+2 ;Removing Alpha site dds
+3 KILL DIK,DA
SET DA(1)=63.04
SET DIK="^DD(63.04,"
FOR DA=.064,.065,.066,.067
DO ^DIK
+4 KILL DIK,DA
SET DA(1)=63.05
SET DIK="^DD(63.05,"
FOR DA=.064,.065,.066,.067
DO ^DIK
+5 KILL DIK,DA
SET DA(1)=68.02
SET DIK="^DD(68.02,"
FOR DA=95,96,97,98
DO ^DIK
+6 KILL DIK,DA
+7 IF $ORDER(^LAB(64.81,0))
WRITE !?5,"You still have unistalled data in LAB NLT/CPT CODES file ",!,$CHAR(7)
+8 SET X="SCDXUAPI"
XECUTE ^%ZOSF("TEST")
IF '$TEST
Begin DoDot:1
+9 ;W !!,$$CJ^XLFSTR("You must Load the SD*5.3*63 to add OOS clinic locations",80),!,$$CJ^XLFSTR("BEFORE YOU INSTALL THIS PATCH",80),!! S LRSDCX=1
End DoDot:1
SET XPDQUIT=2
QUIT
+10 SET LRPKG=$ORDER(^DIC(9.4,"B","LR",0))
+11 IF 'LRPKG
SET LRPKG=$ORDER(^DIC(9.4,"B","LAB SERVICE",0))
+12 IF 'LRPKG
WRITE !!?10,"Not able to find 'LAB SERVICE' in your Package (#9.4) file.",!,"Contact your IRM Service !!",!!,$CHAR(7)
HANG 5
SET XPDQUIT=2
QUIT
+13 KILL DA,DIK
SET DA(1)=64
SET DA=14
SET DIK="^DD(64,"
DO ^DIK
KILL DA,DIK
+14 WRITE !!,$$CJ^XLFSTR("LOCKING THE ^LRO(69,AA) GLOBAL",80),!
+15 LOCK +LRO(69,"AA"):10
IF '$TEST
WRITE !!?5,"Not able to LOCK ^LRO(69,AA) Global"
SET XPDQUIT=2
QUIT
+16 WRITE !,$$CJ^XLFSTR("Pre Install 138 Complete",80),!!
+17 QUIT
PRELR163 ;
PRE ;LR*5.2*163 AFTER USER COMMITS ROUTINE KIDS INSTALL"
ENPRE ;
+1 IF '$DATA(XPDNM)
QUIT
+2 ;Cleanup broken X-Ref
+3 NEW I,N
+4 SET I=0
FOR
SET I=$ORDER(^LAM(I))
IF I<1
QUIT
Begin DoDot:1
+5 IF '$DATA(^LAM(I,"7","B","LRDATA"))
QUIT
+6 SET N=0
FOR
SET N=$ORDER(^LAM(I,7,"B","LRDATA",N))
IF N<1
QUIT
Begin DoDot:2
+7 KILL ^LAM(I,7,"B","LRDATA",N),^LAM(I,7,N,0)
+8 IF $PIECE(^LAM(I,7,0),U,4)
SET $PIECE(^LAM(I,7,0),U,4)=$PIECE(^LAM(I,7,0),U,4)-1
End DoDot:2
End DoDot:1
+9 IF $DATA(^LAB(64.81,0))#2
SET X=$PIECE(^(0),U,1,2)
KILL ^LAB(64.81)
SET ^LAB(64.81,0)=X
+10 IF $DATA(^LAM(0))#2
SET $PIECE(^LAM(0),U,3)=2225
Begin DoDot:1
+11 DO BMES^XPDUTL($$CJ^XLFSTR("Removing 'Reserve 2 field (#8) in WKLD CODE file (#64).",80))
+12 DO BMES^XPDUTL($$CJ^XLFSTR("The field will be renamed 'PRICE'.",80))
+13 NEW DA,DIK
+14 SET DA=8
SET DIK="^DD(64,"
DO ^DIK
End DoDot:1
+15 DO BMES^XPDUTL($$CJ^XLFSTR("Removing 'Reserve 2 field (#8) in WKLD CODE SUFFIX file (#64.2).",80))
+16 DO BMES^XPDUTL($$CJ^XLFSTR("The field will be renamed 'PRICE'.",80))
Begin DoDot:1
+17 NEW DA,DIK
+18 SET DA=8
SET DIK="^DD(64.2,"
DO ^DIK
End DoDot:1
+19 DO BMES^XPDUTL($$CJ^XLFSTR("Removing existing CPT codes for WKLD CODE file.",80))
+20 WRITE !
SET I=0
FOR
SET I=$ORDER(^LAM(I))
IF I<1
QUIT
Begin DoDot:1
+21 IF '$DATA(^LAM(I,0))#2
KILL ^LAM(I)
QUIT
+22 IF '$PIECE(^LAM(I,0),U,7)
SET $PIECE(^(0),U,7)=38
IF $DATA(^LAM(I,4))
KILL ^LAM(I,4)
IF '(I#50)
WRITE "."
End DoDot:1
+23 KILL ^LAM("AD")
+24 DO SPCK
+25 DO BMES^XPDUTL($$CJ^XLFSTR("** Pre Install 163 Complete **",80))
+26 QUIT
SPCK KILL ^XTMP("LR","SPELL ERR")
+1 SET ^XTMP("LR","SPELL ERR")="LR*5.2*163 Spelling errors"
+2 DO BMES^XPDUTL($$CJ^XLFSTR("Correcting Duplicates or Spelling Errors",80))
+3 DO BMES^XPDUTL($$CJ^XLFSTR("Names that begin with 'X*' have codes that are incorrect.",80))
+4 KILL CK
SET CK=""
FOR I=1:1
SET LN=$TEXT(SPELL+I)
IF $PIECE(LN,";;",2)="STOP"
QUIT
SET CK(I)=LN
+5 SET I=0
FOR
SET I=$ORDER(CK(I))
IF I<1
QUIT
DO BMES^XPDUTL($$CJ^XLFSTR($PIECE(CK(I),";",3)_" "_$PIECE(CK(I),";",4),80))
+6 KILL DIC
SET DIC=64
SET DIC(0)="XNZM"
+7 SET II=0
FOR
SET II=$ORDER(CK(II))
IF II<1
QUIT
Begin DoDot:1
+8 SET X=$PIECE(CK(II),";",3)_".0000"
SET NM=$PIECE(CK(II),";",4)
DO ^DIC
+9 IF Y<1
DO BMES^XPDUTL($$CJ^XLFSTR("*** Unable to find WKLD Code [ "_X_" ] in your file #64 ****",80))
QUIT
+10 ;W !,Y W:Y>1 !,Y(0)
+11 SET LNX=$PIECE(Y,U,2)
IF LNX'=NM
SET CK=1
DO FILE
End DoDot:1
+12 DO BMES^XPDUTL($$CJ^XLFSTR("Spelling updates completed.",80))
+13 QUIT
SPELL ;
+1 ;;97485;X*Hepatitis C RNA;
+2 ;;STOP
FILE ;
+1 NEW LRROOT,DA
+2 DO BMES^XPDUTL($$CJ^XLFSTR("Correcting Spelling of entry "_+Y_" from "_LNX_" to "_NM,80))
+3 SET DA=+Y
SET LRROOT(64,DA_",",.01)=NM
+4 DO FILE^DIE("","LRROOT",^XTMP("LR","SPELL ERR"))
+5 QUIT
