LR588 ;SLC/PBB - LR*5.2*588 PATCH UNIVERSAL ENVIRONMENT CHECK ROUTINE ;01/21/06
;;5.2;LAB SERVICE;**588**;Sep 27, 1994;Build 6
;;
EN ; Does not prevent loading of the transport global.
; Environment check is done only during the install.
; DBIA #7126
; DBIA #7127
;N ZZV,ZZP
;S ZZV=2.80,ZZP=588
I '$G(XPDENV) D Q
.N XQA,XQAMSG
.S XQAMSG="Transport global for patch "_$G(XPDNM,"Unknown patch")
.S XQAMSG=XQAMSG_" loaded on "_$$HTE^XLFDT($H)
.S XQA("G.LMI")=""
.D SETUP^XQALERT
.S MSG="Sending transport global loaded alert to mail group G.LMI"
.D BMES^XPDUTL($$CJ^XLFSTR(MSG,80)) K MSG
;
Q
;
PRE(ZZP,ZZV) ; KIDS Pre install for LR*5.2*588
;
N XQA,XQAMSG,LRZZP
S LRZZP="LR"_ZZP ;"LR588"
S LRZZPP=LRZZP_" " ;"LR588 "
;K ^XTEMP($J,"LR588") ;Keep field 80 identifier
S XQAMSG="Installation of patch "_$G(XPDNM,"Unknown patch")
S XQAMSG=XQAMSG_" started on "_$$HTE^XLFDT($H)
S XQA("G.LMI")=""
D SETUP^XQALERT
;
S MSG="Sending install started alert to mail group G.LMI"
D BMES^XPDUTL($$CJ^XLFSTR(MSG,80)) K MSG
;
;Disable Screening records with status DEL.
;^DD(95.3,0,"SCR")=I $P($G(^LAB(95.3,Y,4)),U)'=1
; DBIA #7126
K ^DD(95.3,0,"ID",80)
;K ^DD(64.2,0,"ID",1)
; Be sure screening is not there.
K ^DD(95.3,0,"SCR")
;S $P(^LAB(95.3,0),U,3)="95.3Is"
S $P(^LAB(95.3,0),U,3)="95.3I"
; DBIA #7127
K ^DD(64.061,0,"ID",8)
N FDA,ERR
S FDA(64.061,"7489,",.01)="CARDIAC STRESS STUDY" D UPDATE^DIE(,"FDA","","ERR")
I $D(ERR) D Q
.S MSG="Unable to update file 64.061 7489 CARDIAC STRESS STUDY"
.D BMES^XPDUTL($$CJ^XLFSTR(MSG,80)) K MSG
.;W !,"Unable to update file 64.061 7489 CARDIAC STRESS STUDY"
;
D BMES^XPDUTL($$CJ^XLFSTR("*** Pre install completed ***",80))
;
Q
;
POST(ZZP,ZZV) ; KIDS Post install for LR*5.2*588
;
N XQA,XQAMSG,LRZZP,LRZZPP
S LRZZP="LR"_ZZP ;"LR588"
S LRZZPP=LRZZP_" " ;"LR588 "
D BMES^XPDUTL($$CJ^XLFSTR("*** Post install started ***",80))
; Debugging of DDs change ************************
; D BMES^XPDUTL($$CJ^XLFSTR("*** ^DD(95.3,0,""ID"",80) after PREINSTALL ="_$G(^DD(95.3,0,"ID",80))_" ***",80))
; ***********************************************
;
;IDENTIFIED BY: CHECK DIGIT (#15), FULLY SPECIFIED NAME(#80)
; DBIA #7126
S ^DD(95.3,0,"ID",80)="W:$D(^(80)) !,"" "",$P(^(80),U,1)"
;S ^DD(64.2,0,"ID",1)="W "" "",$P(^(0),U,2)"
;S $P(^LAB(95.3,0),U,3)="95.3Is"
;S ^DD(95.3,0,"SCR")="I $P($G(^LAB(95.3,Y,4)),U)'=1"
; Be sure screening is not there.
K ^DD(95.3,0,"SCR")
S $P(^LAB(95.3,0),U,3)="95.3I"
; DBIA #7127
S ^DD(64.061,0,"ID",8)="W "" "",$P(^(0),U,8)"
;Restore file screening if STATUS is DEL.
;IDENTIFIED BY: TYPE (#7), DESCRIPTION (#8)
;S ^DD(64.061,0,"ID",7)="W "" "",@(""$P($P($C(59)_$S($D(^DD(64.061,7,0)):$P(^(0),U,3),1:0)_$E(""_DIC_""Y,0),0),$C(59)_$P(^(0),U,7)_"""":"""",2),$C(59),1)"")"
;K ^XTEMP($J,"LR588")
;
S XQAMSG="Installation of patch "_$G(XPDNM,"Unknown patch")
S XQAMSG=XQAMSG_" completed on "_$$HTE^XLFDT($H)
S XQA("G.LMI")=""
D SETUP^XQALERT
D EN1,NLT1
;Reindex file 64 field 1 "C" x-ref
K DIK S DIK="^LAM(",DIK(1)="1^C" D ENALL2^DIK
K DIK S DIK="^LAM(",DIK(1)="1^C" D ENALL^DIK
;Reindex file 64 field 25 "AH" x-ref
K DIK S DIK="^LAM(",DIK(1)="25^AH" D ENALL2^DIK
K DIK S DIK="^LAM(",DIK(1)="25^AH" D ENALL^DIK
D BMES^XPDUTL($$CJ^XLFSTR("*** Update of LOINC Files: 129.1 129.11 129.12 129.13 started ***",80))
;D PRE^LR588RX
D BMES^XPDUTL($$CJ^XLFSTR("*** Update of LOINC Files: 129.1 129.11 129.12 129.13 completed ***",80))
D BMES^XPDUTL($$CJ^XLFSTR("*** Post install completed ***",80))
;N X S X="LRXXX" X ^%ZOSF("DEL") ;Delete obsolete install routine.
D SSS
Q
SSS ; Special Update some entries of 64.2 Workload Code Change suffix + NAME *******************************************
N ERR,IEN,FDA,SPX1,SPX01,S1 S U="^"
S SPX1=$P(^DD(64.2,1,0),U,2)
S $P(^DD(64.2,1,0),U,2)=$P(SPX1,"I")_$P(SPX1,"I",2)
S SPX01=$P(^DD(64.2,.01,0),U,2)
S $P(^DD(64.2,.01,0),U,2)=$P(SPX01,"I")_$P(SPX01,"I",2)
F S1="BAYLOR GENETICS^.8783","EXACT SCIENCES^.8784","NPOP MOLECULAR LAB SENDOUT 1^.8785","NPOP MOLECULAR LAB SENDOUT 2^.8786","NPOP MOLECULAR LAB SENDOUT 3^.8787","NPOP MOLECULAR LAB SENDOUT 4^.8788" D SSS1
F S1="NPOP MOLECULAR LAB SENDOUT 5^.8789","Neogenomics^.8762","Molecular Analysis SendOut^.8763","Sanford Genetics Laboratories^.8764","Auto Inst Multiplex PCR 2^.2428" D SSS1
S $P(^DD(64.2,1,0),U,2)=SPX1
S $P(^DD(64.2,.01,0),U,2)=SPX01
;S $P(^DD(64.2,1,0),U,2)="RFXI"
;S $P(^DD(64.2,.01,0),U,2)="RFI"
Q
SSS1 ;Process
K OUT D FIND^DIC(64.2,"",.01,"MX",$P(S1,U),"*","","","","OUT") S IEN=+$G(OUT("DILIST",2,1))
I 'IEN D MES^XPDUTL("Error in update of 64.2 file, entry: "_S1_" doesn't exist") Q
K FDA S IEN=IEN_","
S FDA(64.2,IEN,.01)=$$UP^XLFSTR($P(S1,U))
S FDA(64.2,IEN,1)=$P(S1,U,2) ;W ! ZW FDA
K ERR D FILE^DIE(,"FDA","ERR") ;ZW ERR
I $D(ERR) D MES^XPDUTL("Error in update of record "_$c(34)_S1_$C(34)_" to file #64.2") ;B
Q
;
NLT1 ;
N I
F I=.01,1,1.5,1.6,1.7,2,3,3.1,4,5,6,7,8,10,11,13,15,20,21,22,23,24,30,31,32,33,34,35,36,37,38,40,41,56,80,81,99.98,99.99,99.991 S ^DD(95.3,I,9)="^"
S ^DD(95.3099,.01,9)="^"
S ^DD(95.3,0,"VRRV")=ZZV ;LAB LOINC
S ^DD(95.31,0,"VRRV")=ZZV ;LAB LOINC COMPONENT
S ^DD(64,0,"VRRV")=ZZV ;WKLD CODE
S ^DD(64.061,0,"VRRV")=ZZV ;LAB ELECTRONIC CODES
S ^DD(64.2,0,"VRRV")=ZZV ;WKLD SUFFIX CODES
S ^DD(64.21,0,"VRRV")=ZZV ;WKLD CODE LAB SECT
;S ^DD(64.22,0,"VRRV")=ZZV
;S ^DD(64.3,0,"VRRV")=ZZV
;S Y=$$NOW^XLFDT\1 D DD^%DT S Y="2.52 ;;5.2;LAB SERVICE;**588**;"_Y_";Build 01"
;S Y="5.2;LAB SERVICE;**588**;MAY 05, 2016;Build 1"
;S Y="2.80;;5.2;LAB SERVICE;**588**;Sep 27, 1994"
S Y=ZZV_";;5.2;LAB SERVICE;**"_ZZP_"**;Sep 27, 1994"
S ^LAB(95.3,"VR")=Y
S ^LAB(95.31,"VR")=Y
S ^LAM("VR")=Y
S ^LAB(64.061,"VR")=Y
S ^LAB(64.2,"VR")=Y
S ^LAB(64.21,"VR")=Y
;;;;;;;;;;;;;;;;
;S ^LAB(64.22,"VR")=Y
;S ^LAB(64.3,"VR")=Y
;^LAB(95.3,"VR")="2.14 ;;5.2;LAB SERVICE;**334**;Sep 27, 1994;Build 12"
;^LAB(64.21,"VR")="2.14 ;;5.2;LAB SERVICE;**334**;Sep 27, 1994;Build 12"
;^LAB(64.2,"VR")="2.14 ;;5.2;LAB SERVICE;**334**;Sep 27, 1994;Build 12"
;^LAB(95.31,"VR")="2.14 ;;5.2;LAB SERVICE;**334**;Sep 27, 1994;Build 12"
;^LAM("VR")="2.14 ;;5.2;LAB SERVICE;**334**;Sep 27, 1994;Build 12"
;^LAB(64.061,"VR")=""
;$$GET1^DID(95.3,"","","PACKAGE REVISION DATA")
Q
;
EN1 ;Find and correct existing spelling or duplicate numbers errors.
N DA,DIC,DIK,DIU,X,Y,DIRUT,DTOUT,DUOUT
REINDEX ;Reindex LAM to fire new x-refs
L +^LAM:999 I '$T G EN1
D
. ;N DIK
. N DIK,DIU
. ;S DIK="^LAM(" D IXALL^DIK
. S DIU(0)=1,DIK="^LAM(" D IXALL^DIK
. S $P(^LAM(0),U,3)=99999
;K ^XTMP("LRNLTERR","LR588") S ^XTMP("LRNLTERR",0)=$$HTFM^XLFDT($H+90,1)_"^"_DT_"^LR52 588 Error Messages"
K ^XTMP("LRNLTERR",LRZZP) S ^XTMP("LRNLTERR",0)=$$HTFM^XLFDT($H+90,1)_"^"_DT_"^LR52 "_ZZP_" Error Messages"
;K ^XTMP("LRNLT","LR588")
K ^XTMP("LRNLT",LRZZP)
;S ^XTMP("LRNLT",0)=$$HTFM^XLFDT($H+90,1)_"^"_DT_"^LR52 588 Messages"
S ^XTMP("LRNLT",0)=$$HTFM^XLFDT($H+90,1)_"^"_DT_"^LR52 "_ZZP_" Messages"
N DA,DIK,LRIEN,LRN0,LRN1,LRFILE
D POST1 ;,ALERT^LR334POA
L -^LAM
Q
;
CHK N DIC,X,Y
K LRFDA,LRANS,LRNAMX,LRNUMX,LRNAMY,LRNUMY
S DIC(0)="ZNMO",(LRNAMX,LRNAMY,X)=$P(LRN0,U)
I $G(LRFILE)=64 D
. S DIC=64,(LRNUMY,LRNUMX)=$P(LRN0,U,2)
. S DIC("S")="I $P(^(0),U,2)=LRNUMX"
. D ^DIC I Y<1 D DEL Q
. W:$G(LRDBUG) !,Y_" ( "_LRFILE
. S LRIENS=+Y_","
. I $L($P(LRN0,U,8)) D
. . S LRNAMY=$P(LRN0,U,8)
. . S LRFDA(LRFILE,LRIENS,.01)=LRNAMY
. I $P(LRN0,U,3) D
. . S LRNUMY=$P(LRN0,U,3)
. . Q:$O(^LAM("C",LRNUMY_" ",0))
. . S LRFDA(LRFILE,LRIENS,1)=LRNUMY
I $G(LRFILE)=64.2 D
. N DIC
. S (LRNAMX,LRNAMY,X)=$P(LRN0,U)
. S DIC=64.2,LRNUMX=$P(LRN1,U,2)
. S DIC("S")="I $P(^(0),U,2)=LRNUMX"
. D ^DIC I Y<1 D DEL Q
. S LRIENS=+Y_","
. I $L($P(LRN0,U,8)) D
. . S LRNAMY=$P(LRN0,U,8)
. . S LRFDA(LRFILE,LRIENS,.01)=LRNAMY
. I $P(LRN1,U,3) D
. . S LRNUMY=$P(LRN1,U,3)
. . S LRFDA(LRFILE,LRIENS,1)=LRNUMY
. I $L($P(LRN1,U,7)) D
. . S LRSYN=$P(LRN1,U,7),LRSYNIEN=$O(^LAB(64.2,+LRIENS,1,"B",LRSYN,0))
. . Q:'LRSYNIEN
. . S LRFDA(64.23,LRSYNIEN_","_LRIENS,.01)="@"
. W:$G(LRDBUG) !,Y_" ( "_LRFILE
I $D(LRFDA) D SET
Q
SET ;
D FILE^DIE("KS","LRFDA","LRANS")
I '$D(LRANS) W:$G(LRDBUG) !,"Okay" D Q
. D WRT,DEL
Q ; EDIT ERRORS are left in ^LAB(64.81)
;
DEL ;
N DA,DIK
S DA=LRIEN,DIK="^LAB(64.81," D ^DIK
Q
ERR ;
W !,LRIEN_" ( "_LRFILE_" ERROR"
Q
WRT ;
D SCR(LRNUMX_" "_LRNAMX)
D SCR("Was changed to: "_LRNUMY_" "_LRNAMY)
Q
POST1 ;TRANSPORT FILE 64.81 INTO FILE 64 IF REQUIRED
N LRREC,LRREC9
;K ^XTMP("LRNLT","LR588 ") D
K ^XTMP("LRNLT",LRZZPP) D
. ;S ^XTMP("LRNLT",0)=$$HTFM^XLFDT($H+90,1)_U_DT_U_"LR588 Added NLT Codes List"
. S ^XTMP("LRNLT",0)=$$HTFM^XLFDT($H+90,1)_U_DT_U_LRZZPP_" Added NLT Codes List"
. ;S ^XTMP("LRNLT","LR588 ",0)=""
. S ^XTMP("LRNLT",LRZZPP,0)=""
;D DSS W !
P1 F L +^LAM:10 Q:$T D BMES^XPDUTL("Attempting to Lock ^LAM Global.")
S (LRLAST64,LRNEXT)=$O(^LAM(99999),-1)
S:LRNEXT<1 (LRLAST64,LRNEXT)=0
S $P(^LAM(0),U,3)=LRNEXT
S LRN=$O(^XTMP("LRNLT642",1,99999),-1)
S (LRADD,LRCHG,LRDOT)=0
D SCR("==========================")
D SCR("List of WKLD CODES added to ^LAM (#64)")
D SCR(" ")
S LRNEXT=0,LRIEN=50
F S LRNEXT=$O(^LAB(64.81,LRIEN,2,LRNEXT)) Q:LRNEXT<1 D
. K LRFDA,LROUT,LRAR1,LRSIXT4
. S LRDOT=$G(LRDOT)+1 I LRDOT#50=0 W ". "
. S LRREC=^LAB(64.81,LRIEN,2,LRNEXT,0),LRERR=0
. S LRREC9=+$G(^LAB(64.81,LRIEN,2,LRNEXT,9))
. I $G(LRDBUG) W !,LRREC_" "
. S LRTRIEN=$P(LRREC,U)
. I $S($P(LRREC,U,2)["~":1,$P($P(LRREC,U,3),".",2):1,1:0) D KREC Q
. D CMP
. Q:LRERR
. I LRCHG D CHGNM
. I LRADD D GNDE
. I $S($G(LROUT(42,"DIERR")):0,$G(LROUT(45,"DIERR")):0,1:1) D KREC
. K LROUT
S $P(^LAM(0),U,3)=99999
D:'$G(LRDBUG)
. ;S $ZE="LR588 : Application Error! please disregard NO need to report it" D ^%ZTER ;MAIL^LR588POA
. ;S $ZE=LRZZPP_": Application Error! please disregard NO need to report it" D ^%ZTER
. D APPERROR^%ZTER(LRZZPP_": Application Error! please disregard NO need to report")
S MSG="Sending install completion alert to mail group G.LMI"
S MSG="Sending install completion alert to mail group G.LMI"
D BMES^XPDUTL($$CJ^XLFSTR(MSG,80)) K MSG
KIL K LRADD,LRANS,LRAR1,LRBEG,LRCHG,LRCNT,LRCODE,LRCTR,LRDOT,LREND
K LRENODE,LRERR,LRFDA,LRFILE,LRFLD,LRFLE,LRFNAM,LRI,LRIEN,LRIENS
K LRMLT,LRN,LRN0,LRN1,LRNAMX,LRNAMY,LRNEXT,LRNIEN,LRNODE,LRNUM,LRLAST
K LRNUMX,LRNUMY,LRNX,LROUT,LRPROCNM,LRREC,LRSC,LRSCR,LRSEQ,LRSIXT4
K LRSUBFLE,LRSYN,LRSYNIEN,LRTRIEN,LRVAL,LRVR,X,Y
Q
CHGNM ; CHANGE THE PROCEDURE NAME IN THE RECORD
K LRFDA
S LRFDA(42,64,LRCHG_",",.01)=LRPROCNM
D FILE^DIE("K","LRFDA(42)","LROUT(42)")
I $G(LROUT(42,"DIERR")) D
. S LRERR=1
. S LRENODE="LROUT(42,""DIERR"")"
. D ERMSG
I '$G(LROUT(42,"DIERR")) D SCR(LRCODE_"|"_LRPROCNM_"|"_"**Procedure Name Changed**")
K LRFDA(42),LRPROCNM
Q
CMP ; COMPARE FOUND CODES AND PROCEDURE NAMES
N DIC,X,Y,ANS
S (LRADD,LRCHG,LRERR)=0
S LRCODE=$P(LRREC,U,3),LRPROCNM=$P(LRREC,U,2)
S Y=+$$FIND1^DIC(64,"","XO",LRCODE_" ","C","","ANS")
I Y<1 D
. S LRADD=1,LRN=$G(LRN)+1
. D SCR(LRCODE_"|"_LRPROCNM_"|")
I Y>1,$G(LRREC9) D
. I $D(^LAM(+Y,0)),$G(^LAM(+Y,9))<1 S $P(^LAM(+Y,9),U)=LRREC9
Q
SCR(LRMSG) ;Store message in ^XTMP("LRNLT" Global
;S LRSCR=$G(^XTMP("LRNLT","LR588 ",1,0))+1,^(0)=LRSCR
S LRSCR=$G(^XTMP("LRNLT",LRZZPP,1,0))+1,^(0)=LRSCR
;S ^XTMP("LRNLT","LR588 ",1,LRSCR)=LRSCR_"|"_LRMSG
S ^XTMP("LRNLT",LRZZPP,1,LRSCR)=LRSCR_"|"_LRMSG
Q
SETUP ; SETS UP THE FDA ARRAY TO ADD A NODE
F S LRNODE=$Q(@LRNODE) Q:LRNODE="" D
. S LRFLE=$QS(LRNODE,1)
. S LRFLD=$QS(LRNODE,3)
. I LRFLE=64.8117 D
. . S LRSUBFLE=64
. . I LRFLD=1 S LRFLD=.01
. . I LRFLD>1 S LRFLD=LRFLD-1
. . S LRIENS="+"_LRTRIEN_","
. I LRFLE'=64.8117 D
. .; CONSTRUCT THE SUBFILE NUMBER FOR FILE 64 FROM 64.81
. . S LRBEG=$P(LRFLE,"8117")
. . S LREND=$P(LRFLE,"8117",2)
. . S LRSUBFLE=LRBEG_"0"_LREND
. . I LRFLD=.01 S LRSEQ=LRSEQ+1
. . S LRIENS="+"_LRSEQ_","_"+"_LRTRIEN_","
. S LRVAL=@LRNODE
. S LRFDA(45,LRSUBFLE,LRIENS,LRFLD)=LRVAL
. ;W !,"LRFDA(45,"_LRSUBFLE_","_LRIENS_LRFLD_")="_LRVAL
K LRAR1
Q
GNDE ; RETRIEVES NODES FROM THE TRANSPORT MULTIPLE
S LRMLT="",LRCTR=1
D GETS^DIQ(64.8117,LRTRIEN_","_LRIEN_",",LRMLT_"*","INZ","LRAR1")
S LRNODE="LRAR1(64.8117_LRMLT)"
D SETUP
I $D(^LAB(64.81,50,2,LRTRIEN,1,0)) S LRNUM=$P(^LAB(64.81,50,2,LRTRIEN,1,0),U,4),LRSEQ=LRNUM+1
E I '$D(^LAB(64.81,50,2,LRTRIEN,1,0)) S LRSEQ=2
S LRMLT=18
D GETS^DIQ(64.8117,LRTRIEN_","_LRIEN_",",LRMLT_"*","INZ","LRAR1")
S LRNODE="LRAR1(64.8117_LRMLT)"
D SETUP
S LRMLT=19,LRSEQ=1
D GETS^DIQ(64.8117,LRTRIEN_","_LRIEN_",",LRMLT_"*","INZ","LRAR1")
S LRNODE="LRAR1(64.8117_LRMLT)"
D SETUP
D AREC I $G(LRDBUG) W !,"NEW IEN=",$G(LRSIXT4(LRTRIEN))
K LRSIXT4,LRFDA(45)
Q
AREC ; ADDS ENTRIES FROM THE TRANSPORT MULTIPLE TO FILE 64
D UPDATE^DIE("","LRFDA(45)","LRSIXT4","LROUT(45)")
I $G(LROUT(45,"DIERR")) D
. S LRENODE="LROUT(45,""DIERR"")"
. D ERMSG
K LRFDA(45)
Q
ERMSG ;STUFF THE TEMP GLOBAL WITH ANY ERROR MESSAGES
S ^XTMP("LRNLT642",0)=$$HTFM^XLFDT($H+90,1)_U_DT_U_" LR"_LRZZP_" LRNLT642"
S LRN=$G(^XTMP("LRNLT642",1,0))+1
S ^XTMP("LRNLT642",1,LRN,0)="|"_LRTRIEN_"|"_LRCODE_"|"_LRPROCNM_"|ERR"
F S LRENODE=$Q(@LRENODE) Q:LRENODE="" D
. S LRN=LRN+1
. S ^XTMP("LRNLT642",1,LRN,0)="|"_LRENODE_"|="_@LRENODE
S ^XTMP("LRNLT642",1,0)=LRN
S LRERR=1
K LRENODE
Q
KREC ; DELETES THE RECORD FROM THE FILE
Q:$G(LRDBUG)
N DA,DIK
S DA(1)=LRIEN,DA=LRTRIEN
S DIK="^LAB(64.81,"_DA(1)_",2," D ^DIK
Q
DSS ;Update WKLD CODE file , DSS Feeder Key (#14) field to 'Yes"
;for those NLT codes used for AP professional services
;D BMES^XPDUTL("Updating DSS Feeder Key for AP NLT Codes")
N ERR,FDA,IEN,LST,OUT,NODE,X
S NODE="^LAB(64.81,""AC"")"
F S NODE=$Q(@NODE) Q:$QS(NODE,2)'="AC" D
. S X=$P($$GET1^DIQ(64.8117,$QS(NODE,5)_","_$QS(NODE,4)_",",2,"I","ERR"),".")
. Q:'X
. K OUT,ERR
. D FIND^DIC(64,"","@;1","M",X,"","C","","","OUT","ERR")
. Q:$D(ERR)
. S LST=0 F S LST=$O(OUT("DILIST",2,LST)) Q:'LST D
. . S IEN=$G(OUT("DILIST",2,LST))
. . Q:'($D(^LAM(IEN,0))#2)
. . K FDA,ERR S FDA(1,64,IEN_",",14)=1
. . D FILE^DIE("","FDA(1)","ERR")
. . I $D(ERR) W !,$C(7),ERR
. . W "*"
;D BMES^LR334("Update DSS AP Feeder Key Complete")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR588 14553 printed Jul 11, 2026@02:00:52 Page 2
LR588 ;SLC/PBB - LR*5.2*588 PATCH UNIVERSAL ENVIRONMENT CHECK ROUTINE ;01/21/06
+1 ;;5.2;LAB SERVICE;**588**;Sep 27, 1994;Build 6
+2 ;;
EN ; Does not prevent loading of the transport global.
+1 ; Environment check is done only during the install.
+2 ; DBIA #7126
+3 ; DBIA #7127
+4 ;N ZZV,ZZP
+5 ;S ZZV=2.80,ZZP=588
+6 IF '$GET(XPDENV)
Begin DoDot:1
+7 NEW XQA,XQAMSG
+8 SET XQAMSG="Transport global for patch "_$GET(XPDNM,"Unknown patch")
+9 SET XQAMSG=XQAMSG_" loaded on "_$$HTE^XLFDT($HOROLOG)
+10 SET XQA("G.LMI")=""
+11 DO SETUP^XQALERT
+12 SET MSG="Sending transport global loaded alert to mail group G.LMI"
+13 DO BMES^XPDUTL($$CJ^XLFSTR(MSG,80))
KILL MSG
End DoDot:1
QUIT
+14 ;
+15 QUIT
+16 ;
PRE(ZZP,ZZV) ; KIDS Pre install for LR*5.2*588
+1 ;
+2 NEW XQA,XQAMSG,LRZZP
+3 ;"LR588"
SET LRZZP="LR"_ZZP
+4 ;"LR588 "
SET LRZZPP=LRZZP_" "
+5 ;K ^XTEMP($J,"LR588") ;Keep field 80 identifier
+6 SET XQAMSG="Installation of patch "_$GET(XPDNM,"Unknown patch")
+7 SET XQAMSG=XQAMSG_" started on "_$$HTE^XLFDT($HOROLOG)
+8 SET XQA("G.LMI")=""
+9 DO SETUP^XQALERT
+10 ;
+11 SET MSG="Sending install started alert to mail group G.LMI"
+12 DO BMES^XPDUTL($$CJ^XLFSTR(MSG,80))
KILL MSG
+13 ;
+14 ;Disable Screening records with status DEL.
+15 ;^DD(95.3,0,"SCR")=I $P($G(^LAB(95.3,Y,4)),U)'=1
+16 ; DBIA #7126
+17 KILL ^DD(95.3,0,"ID",80)
+18 ;K ^DD(64.2,0,"ID",1)
+19 ; Be sure screening is not there.
+20 KILL ^DD(95.3,0,"SCR")
+21 ;S $P(^LAB(95.3,0),U,3)="95.3Is"
+22 SET $PIECE(^LAB(95.3,0),U,3)="95.3I"
+23 ; DBIA #7127
+24 KILL ^DD(64.061,0,"ID",8)
+25 NEW FDA,ERR
+26 SET FDA(64.061,"7489,",.01)="CARDIAC STRESS STUDY"
DO UPDATE^DIE(,"FDA","","ERR")
+27 IF $DATA(ERR)
Begin DoDot:1
+28 SET MSG="Unable to update file 64.061 7489 CARDIAC STRESS STUDY"
+29 DO BMES^XPDUTL($$CJ^XLFSTR(MSG,80))
KILL MSG
+30 ;W !,"Unable to update file 64.061 7489 CARDIAC STRESS STUDY"
End DoDot:1
QUIT
+31 ;
+32 DO BMES^XPDUTL($$CJ^XLFSTR("*** Pre install completed ***",80))
+33 ;
+34 QUIT
+35 ;
POST(ZZP,ZZV) ; KIDS Post install for LR*5.2*588
+1 ;
+2 NEW XQA,XQAMSG,LRZZP,LRZZPP
+3 ;"LR588"
SET LRZZP="LR"_ZZP
+4 ;"LR588 "
SET LRZZPP=LRZZP_" "
+5 DO BMES^XPDUTL($$CJ^XLFSTR("*** Post install started ***",80))
+6 ; Debugging of DDs change ************************
+7 ; D BMES^XPDUTL($$CJ^XLFSTR("*** ^DD(95.3,0,""ID"",80) after PREINSTALL ="_$G(^DD(95.3,0,"ID",80))_" ***",80))
+8 ; ***********************************************
+9 ;
+10 ;IDENTIFIED BY: CHECK DIGIT (#15), FULLY SPECIFIED NAME(#80)
+11 ; DBIA #7126
+12 SET ^DD(95.3,0,"ID",80)="W:$D(^(80)) !,"" "",$P(^(80),U,1)"
+13 ;S ^DD(64.2,0,"ID",1)="W "" "",$P(^(0),U,2)"
+14 ;S $P(^LAB(95.3,0),U,3)="95.3Is"
+15 ;S ^DD(95.3,0,"SCR")="I $P($G(^LAB(95.3,Y,4)),U)'=1"
+16 ; Be sure screening is not there.
+17 KILL ^DD(95.3,0,"SCR")
+18 SET $PIECE(^LAB(95.3,0),U,3)="95.3I"
+19 ; DBIA #7127
+20 SET ^DD(64.061,0,"ID",8)="W "" "",$P(^(0),U,8)"
+21 ;Restore file screening if STATUS is DEL.
+22 ;IDENTIFIED BY: TYPE (#7), DESCRIPTION (#8)
+23 ;S ^DD(64.061,0,"ID",7)="W "" "",@(""$P($P($C(59)_$S($D(^DD(64.061,7,0)):$P(^(0),U,3),1:0)_$E(""_DIC_""Y,0),0),$C(59)_$P(^(0),U,7)_"""":"""",2),$C(59),1)"")"
+24 ;K ^XTEMP($J,"LR588")
+25 ;
+26 SET XQAMSG="Installation of patch "_$GET(XPDNM,"Unknown patch")
+27 SET XQAMSG=XQAMSG_" completed on "_$$HTE^XLFDT($HOROLOG)
+28 SET XQA("G.LMI")=""
+29 DO SETUP^XQALERT
+30 DO EN1
DO NLT1
+31 ;Reindex file 64 field 1 "C" x-ref
+32 KILL DIK
SET DIK="^LAM("
SET DIK(1)="1^C"
DO ENALL2^DIK
+33 KILL DIK
SET DIK="^LAM("
SET DIK(1)="1^C"
DO ENALL^DIK
+34 ;Reindex file 64 field 25 "AH" x-ref
+35 KILL DIK
SET DIK="^LAM("
SET DIK(1)="25^AH"
DO ENALL2^DIK
+36 KILL DIK
SET DIK="^LAM("
SET DIK(1)="25^AH"
DO ENALL^DIK
+37 DO BMES^XPDUTL($$CJ^XLFSTR("*** Update of LOINC Files: 129.1 129.11 129.12 129.13 started ***",80))
+38 ;D PRE^LR588RX
+39 DO BMES^XPDUTL($$CJ^XLFSTR("*** Update of LOINC Files: 129.1 129.11 129.12 129.13 completed ***",80))
+40 DO BMES^XPDUTL($$CJ^XLFSTR("*** Post install completed ***",80))
+41 ;N X S X="LRXXX" X ^%ZOSF("DEL") ;Delete obsolete install routine.
+42 DO SSS
+43 QUIT
SSS ; Special Update some entries of 64.2 Workload Code Change suffix + NAME *******************************************
+1 NEW ERR,IEN,FDA,SPX1,SPX01,S1
SET U="^"
+2 SET SPX1=$PIECE(^DD(64.2,1,0),U,2)
+3 SET $PIECE(^DD(64.2,1,0),U,2)=$PIECE(SPX1,"I")_$PIECE(SPX1,"I",2)
+4 SET SPX01=$PIECE(^DD(64.2,.01,0),U,2)
+5 SET $PIECE(^DD(64.2,.01,0),U,2)=$PIECE(SPX01,"I")_$PIECE(SPX01,"I",2)
+6 FOR S1="BAYLOR GENETICS^.8783","EXACT SCIENCES^.8784","NPOP MOLECULAR LAB SENDOUT 1^.8785","NPOP MOLECULAR LAB SENDOUT 2^.8786","NPOP MOLECULAR LAB SENDOUT 3^.8787","NPOP MOLECULAR LAB SENDOUT 4^.8788"
DO SSS1
+7 FOR S1="NPOP MOLECULAR LAB SENDOUT 5^.8789","Neogenomics^.8762","Molecular Analysis SendOut^.8763","Sanford Genetics Laboratories^.8764","Auto Inst Multiplex PCR 2^.2428"
DO SSS1
+8 SET $PIECE(^DD(64.2,1,0),U,2)=SPX1
+9 SET $PIECE(^DD(64.2,.01,0),U,2)=SPX01
+10 ;S $P(^DD(64.2,1,0),U,2)="RFXI"
+11 ;S $P(^DD(64.2,.01,0),U,2)="RFI"
+12 QUIT
SSS1 ;Process
+1 KILL OUT
DO FIND^DIC(64.2,"",.01,"MX",$PIECE(S1,U),"*","","","","OUT")
SET IEN=+$GET(OUT("DILIST",2,1))
+2 IF 'IEN
DO MES^XPDUTL("Error in update of 64.2 file, entry: "_S1_" doesn't exist")
QUIT
+3 KILL FDA
SET IEN=IEN_","
+4 SET FDA(64.2,IEN,.01)=$$UP^XLFSTR($PIECE(S1,U))
+5 ;W ! ZW FDA
SET FDA(64.2,IEN,1)=$PIECE(S1,U,2)
+6 ;ZW ERR
KILL ERR
DO FILE^DIE(,"FDA","ERR")
+7 ;B
IF $DATA(ERR)
