Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LR72PRE

LR72PRE.m

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