- LR567 ;SLC/PBB - LR*5.2*567 PATCH ENVIRONMENT CHECK ROUTINE ;01/21/06
- ;;5.2;LAB SERVICE;**567**;Sep 27, 1994;Build 5
- ;;
- EN ; Does not prevent loading of the transport global.
- ; Environment check is done only during the install.
- ; DBIA #7126
- ; DBIA #7127
- 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 ; KIDS Pre install for LR*5.2*567
- ;
- N XQA,XQAMSG
- ;K ^XTEMP($J,"LR567") ;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 Screaning 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)
- ; 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 ; KIDS Post install for LR*5.2*567
- ;
- N XQA,XQAMSG
- 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 $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,"LR567")
- ;
- 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^LR567RX
- 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))
- 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")=2.76 ;LAB LOINC
- S ^DD(95.31,0,"VRRV")=2.76 ;LAB LOINC COMPONENT
- S ^DD(64,0,"VRRV")=2.76 ;WKLD CODE
- S ^DD(64.061,0,"VRRV")=2.76 ;LAB ELECTRONIC CODES
- S ^DD(64.2,0,"VRRV")=2.76 ;WKLD SUFFIX CODES
- S ^DD(64.21,0,"VRRV")=2.76 ;WKLD CODE LAB SECT
- ;S ^DD(64.22,0,"VRRV")=2.76
- ;S ^DD(64.3,0,"VRRV")=2.76
- ;S Y=$$NOW^XLFDT\1 D DD^%DT S Y="2.52 ;;5.2;LAB SERVICE;**567**;"_Y_";Build 01"
- ;S Y="5.2;LAB SERVICE;**567**;MAY 05, 2016;Build 1"
- S Y="2.76;;5.2;LAB SERVICE;**567**;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","LR567") S ^XTMP("LRNLTERR",0)=$$HTFM^XLFDT($H+90,1)_"^"_DT_"^LR52 567 Error Messages"
- K ^XTMP("LRNLT","LR567")
- S ^XTMP("LRNLT",0)=$$HTFM^XLFDT($H+90,1)_"^"_DT_"^LR52 567 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","LR567 ") D
- . S ^XTMP("LRNLT",0)=$$HTFM^XLFDT($H+90,1)_U_DT_U_"LR567 Added NLT Codes List"
- . S ^XTMP("LRNLT","LR567 ",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="LR567 : Application Error! please disregard NO need to report it" D ^%ZTER ;MAIL^LR567POA
- 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","LR567 ",1,0))+1,^(0)=LRSCR
- S ^XTMP("LRNLT","LR567 ",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 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[HLR567 12066 printed Jan 18, 2025@03:05:18 Page 2
- LR567 ;SLC/PBB - LR*5.2*567 PATCH ENVIRONMENT CHECK ROUTINE ;01/21/06
- +1 ;;5.2;LAB SERVICE;**567**;Sep 27, 1994;Build 5
- +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 IF '$GET(XPDENV)
- Begin DoDot:1
- +5 NEW XQA,XQAMSG
- +6 SET XQAMSG="Transport global for patch "_$GET(XPDNM,"Unknown patch")
- +7 SET XQAMSG=XQAMSG_" loaded on "_$$HTE^XLFDT($HOROLOG)
- +8 SET XQA("G.LMI")=""
- +9 DO SETUP^XQALERT
- +10 SET MSG="Sending transport global loaded alert to mail group G.LMI"
- +11 DO BMES^XPDUTL($$CJ^XLFSTR(MSG,80))
- KILL MSG
- End DoDot:1
- QUIT
- +12 ;
- +13 QUIT
- +14 ;
- PRE ; KIDS Pre install for LR*5.2*567
- +1 ;
- +2 NEW XQA,XQAMSG
- +3 ;K ^XTEMP($J,"LR567") ;Keep field 80 identifier
- +4 SET XQAMSG="Installation of patch "_$GET(XPDNM,"Unknown patch")
- +5 SET XQAMSG=XQAMSG_" started on "_$$HTE^XLFDT($HOROLOG)
- +6 SET XQA("G.LMI")=""
- +7 DO SETUP^XQALERT
- +8 ;
- +9 SET MSG="Sending install started alert to mail group G.LMI"
- +10 DO BMES^XPDUTL($$CJ^XLFSTR(MSG,80))
- KILL MSG
- +11 ;
- +12 ;Disable Screaning records with status DEL.
- +13 ;^DD(95.3,0,"SCR")=I $P($G(^LAB(95.3,Y,4)),U)'=1
- +14 ; DBIA #7126
- +15 KILL ^DD(95.3,0,"ID",80)
- +16 ; Be sure screening is not there.
- +17 KILL ^DD(95.3,0,"SCR")
- +18 ;S $P(^LAB(95.3,0),U,3)="95.3Is"
- +19 SET $PIECE(^LAB(95.3,0),U,3)="95.3I"
- +20 ; DBIA #7127
- +21 KILL ^DD(64.061,0,"ID",8)
- +22 NEW FDA,ERR
- +23 SET FDA(64.061,"7489,",.01)="CARDIAC STRESS STUDY"
- DO UPDATE^DIE(,"FDA","","ERR")
- +24 IF $DATA(ERR)
- Begin DoDot:1
- +25 SET MSG="Unable to update file 64.061 7489 CARDIAC STRESS STUDY"
- +26 DO BMES^XPDUTL($$CJ^XLFSTR(MSG,80))
- KILL MSG
- +27 ;W !,"Unable to update file 64.061 7489 CARDIAC STRESS STUDY"
- End DoDot:1
- QUIT
- +28 ;
- +29 DO BMES^XPDUTL($$CJ^XLFSTR("*** Pre install completed ***",80))
- +30 ;
- +31 QUIT
- +32 ;
- POST ; KIDS Post install for LR*5.2*567
- +1 ;
- +2 NEW XQA,XQAMSG
- +3 DO BMES^XPDUTL($$CJ^XLFSTR("*** Post install started ***",80))
- +4 ; Debugging of DDs change ************************
- +5 ; D BMES^XPDUTL($$CJ^XLFSTR("*** ^DD(95.3,0,""ID"",80) after PREINSTALL ="_$G(^DD(95.3,0,"ID",80))_" ***",80))
- +6 ; ***********************************************
- +7 ;
- +8 ;IDENTIFIED BY: CHECK DIGIT (#15), FULLY SPECIFIED NAME(#80)
- +9 ; DBIA #7126
- +10 SET ^DD(95.3,0,"ID",80)="W:$D(^(80)) !,"" "",$P(^(80),U,1)"
- +11 ;S $P(^LAB(95.3,0),U,3)="95.3Is"
- +12 ;S ^DD(95.3,0,"SCR")="I $P($G(^LAB(95.3,Y,4)),U)'=1"
- +13 ; Be sure screening is not there.
- +14 KILL ^DD(95.3,0,"SCR")
- +15 SET $PIECE(^LAB(95.3,0),U,3)="95.3I"
- +16 ; DBIA #7127
- +17 SET ^DD(64.061,0,"ID",8)="W "" "",$P(^(0),U,8)"
- +18 ;Restore file screening if STATUS is DEL.
- +19 ;IDENTIFIED BY: TYPE (#7), DESCRIPTION (#8)
- +20 ;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)"")"
- +21 ;K ^XTEMP($J,"LR567")
- +22 ;
- +23 SET XQAMSG="Installation of patch "_$GET(XPDNM,"Unknown patch")
- +24 SET XQAMSG=XQAMSG_" completed on "_$$HTE^XLFDT($HOROLOG)
- +25 SET XQA("G.LMI")=""
- +26 DO SETUP^XQALERT
- +27 DO EN1
- DO NLT1
- +28 ;Reindex file 64 field 1 "C" x-ref
- +29 KILL DIK
- SET DIK="^LAM("
- SET DIK(1)="1^C"
- DO ENALL2^DIK
- +30 KILL DIK
- SET DIK="^LAM("
- SET DIK(1)="1^C"
- DO ENALL^DIK
- +31 ;Reindex file 64 field 25 "AH" x-ref
- +32 KILL DIK
- SET DIK="^LAM("
- SET DIK(1)="25^AH"
- DO ENALL2^DIK
- +33 KILL DIK
- SET DIK="^LAM("
- SET DIK(1)="25^AH"
- DO ENALL^DIK
- +34 DO BMES^XPDUTL($$CJ^XLFSTR("*** Update of LOINC Files: 129.1 129.11 129.12 129.13 started ***",80))
- +35 ;D PRE^LR567RX
- +36 DO BMES^XPDUTL($$CJ^XLFSTR("*** Update of LOINC Files: 129.1 129.11 129.12 129.13 completed ***",80))
- +37 DO BMES^XPDUTL($$CJ^XLFSTR("*** Post install completed ***",80))
- +38 QUIT
- NLT1 ;
- +1 NEW I
- +2 FOR 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
- SET ^DD(95.3,I,9)="^"
- +3 SET ^DD(95.3099,.01,9)="^"
- +4 ;LAB LOINC
- SET ^DD(95.3,0,"VRRV")=2.76
- +5 ;LAB LOINC COMPONENT
- SET ^DD(95.31,0,"VRRV")=2.76
- +6 ;WKLD CODE
- SET ^DD(64,0,"VRRV")=2.76
- +7 ;LAB ELECTRONIC CODES
- SET ^DD(64.061,0,"VRRV")=2.76
- +8 ;WKLD SUFFIX CODES
- SET ^DD(64.2,0,"VRRV")=2.76
- +9 ;WKLD CODE LAB SECT
- SET ^DD(64.21,0,"VRRV")=2.76
- +10 ;S ^DD(64.22,0,"VRRV")=2.76
- +11 ;S ^DD(64.3,0,"VRRV")=2.76
- +12 ;S Y=$$NOW^XLFDT\1 D DD^%DT S Y="2.52 ;;5.2;LAB SERVICE;**567**;"_Y_";Build 01"
- +13 ;S Y="5.2;LAB SERVICE;**567**;MAY 05, 2016;Build 1"
- +14 SET Y="2.76;;5.2;LAB SERVICE;**567**;Sep 27, 1994"
- +15 SET ^LAB(95.3,"VR")=Y
- +16 SET ^LAB(95.31,"VR")=Y
- +17 SET ^LAM("VR")=Y
- +18 SET ^LAB(64.061,"VR")=Y
- +19 SET ^LAB(64.2,"VR")=Y
- +20 SET ^LAB(64.21,"VR")=Y
- +21 ;;;;;;;;;;;;;;;;
- +22 ;S ^LAB(64.22,"VR")=Y
- +23 ;S ^LAB(64.3,"VR")=Y
- +24 ;^LAB(95.3,"VR")="2.14 ;;5.2;LAB SERVICE;**334**;Sep 27, 1994;Build 12"
- +25 ;^LAB(64.21,"VR")="2.14 ;;5.2;LAB SERVICE;**334**;Sep 27, 1994;Build 12"
- +26 ;^LAB(64.2,"VR")="2.14 ;;5.2;LAB SERVICE;**334**;Sep 27, 1994;Build 12"
- +27 ;^LAB(95.31,"VR")="2.14 ;;5.2;LAB SERVICE;**334**;Sep 27, 1994;Build 12"
- +28 ;^LAM("VR")="2.14 ;;5.2;LAB SERVICE;**334**;Sep 27, 1994;Build 12"
- +29 ;^LAB(64.061,"VR")=""
- +30 ;$$GET1^DID(95.3,"","","PACKAGE REVISION DATA")
- +31 QUIT
- +32 ;
- EN1 ;Find and correct existing spelling or duplicate numbers errors.
- +1 NEW DA,DIC,DIK,DIU,X,Y,DIRUT,DTOUT,DUOUT
- REINDEX ;Reindex LAM to fire new x-refs
- +1 LOCK +^LAM:999
- IF '$TEST
- GOTO EN1
- +2 Begin DoDot:1
- +3 ;N DIK
- +4 NEW DIK,DIU
- +5 ;S DIK="^LAM(" D IXALL^DIK
- +6 SET DIU(0)=1
- SET DIK="^LAM("
- DO IXALL^DIK
- +7 SET $PIECE(^LAM(0),U,3)=99999
- End DoDot:1
- +8 KILL ^XTMP("LRNLTERR","LR567")
- SET ^XTMP("LRNLTERR",0)=$$HTFM^XLFDT($HOROLOG+90,1)_"^"_DT_"^LR52 567 Error Messages"
- +9 KILL ^XTMP("LRNLT","LR567")
- +10 SET ^XTMP("LRNLT",0)=$$HTFM^XLFDT($HOROLOG+90,1)_"^"_DT_"^LR52 567 Messages"
- +11 NEW DA,DIK,LRIEN,LRN0,LRN1,LRFILE
- +12 ;,ALERT^LR334POA
- DO POST1
- +13 LOCK -^LAM
- +14 QUIT
- +15 ;
- CHK NEW DIC,X,Y
- +1 KILL LRFDA,LRANS,LRNAMX,LRNUMX,LRNAMY,LRNUMY
- +2 SET DIC(0)="ZNMO"
- SET (LRNAMX,LRNAMY,X)=$PIECE(LRN0,U)
- +3 IF $GET(LRFILE)=64
- Begin DoDot:1
- +4 SET DIC=64
- SET (LRNUMY,LRNUMX)=$PIECE(LRN0,U,2)
- +5 SET DIC("S")="I $P(^(0),U,2)=LRNUMX"
- +6 DO ^DIC
- IF Y<1
- DO DEL
- QUIT
- +7 if $GET(LRDBUG)
- WRITE !,Y_" ( "_LRFILE
- +8 SET LRIENS=+Y_","
- +9 IF $LENGTH($PIECE(LRN0,U,8))
- Begin DoDot:2
- +10 SET LRNAMY=$PIECE(LRN0,U,8)
- +11 SET LRFDA(LRFILE,LRIENS,.01)=LRNAMY
- End DoDot:2
- +12 IF $PIECE(LRN0,U,3)
- Begin DoDot:2
- +13 SET LRNUMY=$PIECE(LRN0,U,3)
- +14 if $ORDER(^LAM("C",LRNUMY_" ",0))
- QUIT
- +15 SET LRFDA(LRFILE,LRIENS,1)=LRNUMY
- End DoDot:2
- End DoDot:1
- +16 IF $GET(LRFILE)=64.2
- Begin DoDot:1
- +17 NEW DIC
- +18 SET (LRNAMX,LRNAMY,X)=$PIECE(LRN0,U)
- +19 SET DIC=64.2
- SET LRNUMX=$PIECE(LRN1,U,2)
- +20 SET DIC("S")="I $P(^(0),U,2)=LRNUMX"
- +21 DO ^DIC
- IF Y<1
- DO DEL
- QUIT
- +22 SET LRIENS=+Y_","
- +23 IF $LENGTH($PIECE(LRN0,U,8))
- Begin DoDot:2
- +24 SET LRNAMY=$PIECE(LRN0,U,8)
- +25 SET LRFDA(LRFILE,LRIENS,.01)=LRNAMY
- End DoDot:2
- +26 IF $PIECE(LRN1,U,3)
- Begin DoDot:2
- +27 SET LRNUMY=$PIECE(LRN1,U,3)
- +28 SET LRFDA(LRFILE,LRIENS,1)=LRNUMY
- End DoDot:2
- +29 IF $LENGTH($PIECE(LRN1,U,7))
- Begin DoDot:2
- +30 SET LRSYN=$PIECE(LRN1,U,7)
- SET LRSYNIEN=$ORDER(^LAB(64.2,+LRIENS,1,"B",LRSYN,0))
- +31 if 'LRSYNIEN
- QUIT
- +32 SET LRFDA(64.23,LRSYNIEN_","_LRIENS,.01)="@"
- End DoDot:2
- +33 if $GET(LRDBUG)
- WRITE !,Y_" ( "_LRFILE
- End DoDot:1
- +34 IF $DATA(LRFDA)
- DO SET
- +35 QUIT
- SET ;
- +1 DO FILE^DIE("KS","LRFDA","LRANS")
- +2 IF '$DATA(LRANS)
- if $GET(LRDBUG)
- WRITE !,"Okay"
- Begin DoDot:1
- +3 DO WRT
- DO DEL
- End DoDot:1
- QUIT
- +4 ; EDIT ERRORS are left in ^LAB(64.81)
- QUIT
- +5 ;
- DEL ;
- +1 NEW DA,DIK
- +2 SET DA=LRIEN
- SET DIK="^LAB(64.81,"
- DO ^DIK
- +3 QUIT
- ERR ;
- +1 WRITE !,LRIEN_" ( "_LRFILE_" ERROR"
- +2 QUIT
- WRT ;
- +1 DO SCR(LRNUMX_" "_LRNAMX)
- +2 DO SCR("Was changed to: "_LRNUMY_" "_LRNAMY)
- +3 QUIT
- POST1 ;TRANSPORT FILE 64.81 INTO FILE 64 IF REQUIRED
- +1 NEW LRREC,LRREC9
- +2 KILL ^XTMP("LRNLT","LR567 ")
- Begin DoDot:1
- +3 SET ^XTMP("LRNLT",0)=$$HTFM^XLFDT($HOROLOG+90,1)_U_DT_U_"LR567 Added NLT Codes List"
- +4 SET ^XTMP("LRNLT","LR567 ",0)=""
- End DoDot:1
- +5 ;D DSS W !
- P1 FOR
- LOCK +^LAM:10
- if $TEST
- QUIT
- DO BMES^XPDUTL("Attempting to Lock ^LAM Global.")
- +1 SET (LRLAST64,LRNEXT)=$ORDER(^LAM(99999),-1)
- +2 if LRNEXT<1
- SET (LRLAST64,LRNEXT)=0
- +3 SET $PIECE(^LAM(0),U,3)=LRNEXT
- +4 SET LRN=$ORDER(^XTMP("LRNLT642",1,99999),-1)
- +5 SET (LRADD,LRCHG,LRDOT)=0
- +6 DO SCR("==========================")
- +7 DO SCR("List of WKLD CODES added to ^LAM (#64)")
- +8 DO SCR(" ")
- +9 SET LRNEXT=0
- SET LRIEN=50
- +10 FOR
- SET LRNEXT=$ORDER(^LAB(64.81,LRIEN,2,LRNEXT))
- if LRNEXT<1
- QUIT
- Begin DoDot:1
- +11 KILL LRFDA,LROUT,LRAR1,LRSIXT4
- +12 SET LRDOT=$GET(LRDOT)+1
- IF LRDOT#50=0
- WRITE ". "
- +13 SET LRREC=^LAB(64.81,LRIEN,2,LRNEXT,0)
- SET LRERR=0
- +14 SET LRREC9=+$GET(^LAB(64.81,LRIEN,2,LRNEXT,9))
- +15 IF $GET(LRDBUG)
- WRITE !,LRREC_" "
- +16 SET LRTRIEN=$PIECE(LRREC,U)
- +17 IF $SELECT($PIECE(LRREC,U,2)["~":1,$PIECE($PIECE(LRREC,U,3),".",2):1,1:0)
- DO KREC
- QUIT
- +18 DO CMP
- +19 if LRERR
- QUIT
- +20 IF LRCHG
- DO CHGNM
- +21 IF LRADD
- DO GNDE
- +22 IF $SELECT($GET(LROUT(42,"DIERR")):0,$GET(LROUT(45,"DIERR")):0,1:1)
- DO KREC
- +23 KILL LROUT
- End DoDot:1
- +24 SET $PIECE(^LAM(0),U,3)=99999
- +25 if '$GET(LRDBUG)
- Begin DoDot:1
- +26 ;MAIL^LR567POA
- SET $ZE="LR567 : Application Error! please disregard NO need to report it"
- DO ^%ZTER
- End DoDot:1
- +27 SET MSG="Sending install completion alert to mail group G.LMI"
- +28 DO BMES^XPDUTL($$CJ^XLFSTR(MSG,80))
- KILL MSG
- KIL KILL LRADD,LRANS,LRAR1,LRBEG,LRCHG,LRCNT,LRCODE,LRCTR,LRDOT,LREND
- +1 KILL LRENODE,LRERR,LRFDA,LRFILE,LRFLD,LRFLE,LRFNAM,LRI,LRIEN,LRIENS
- +2 KILL LRMLT,LRN,LRN0,LRN1,LRNAMX,LRNAMY,LRNEXT,LRNIEN,LRNODE,LRNUM,LRLAST
- +3 KILL LRNUMX,LRNUMY,LRNX,LROUT,LRPROCNM,LRREC,LRSC,LRSCR,LRSEQ,LRSIXT4
- +4 KILL LRSUBFLE,LRSYN,LRSYNIEN,LRTRIEN,LRVAL,LRVR,X,Y
- +5 QUIT
- CHGNM ; CHANGE THE PROCEDURE NAME IN THE RECORD
- +1 KILL LRFDA
- +2 SET LRFDA(42,64,LRCHG_",",.01)=LRPROCNM
- +3 DO FILE^DIE("K","LRFDA(42)","LROUT(42)")
- +4 IF $GET(LROUT(42,"DIERR"))
- Begin DoDot:1
- +5 SET LRERR=1
- +6 SET LRENODE="LROUT(42,""DIERR"")"
- +7 DO ERMSG
- End DoDot:1
- +8 IF '$GET(LROUT(42,"DIERR"))
- DO SCR(LRCODE_"|"_LRPROCNM_"|"_"**Procedure Name Changed**")
- +9 KILL LRFDA(42),LRPROCNM
- +10 QUIT
- CMP ; COMPARE FOUND CODES AND PROCEDURE NAMES
- +1 NEW DIC,X,Y,ANS
- +2 SET (LRADD,LRCHG,LRERR)=0
- +3 SET LRCODE=$PIECE(LRREC,U,3)
- SET LRPROCNM=$PIECE(LRREC,U,2)
- +4 SET Y=+$$FIND1^DIC(64,"","XO",LRCODE_" ","C","","ANS")
- +5 IF Y<1
- Begin DoDot:1
- +6 SET LRADD=1
- SET LRN=$GET(LRN)+1
- +7 DO SCR(LRCODE_"|"_LRPROCNM_"|")
- End DoDot:1
- +8 IF Y>1
- IF $GET(LRREC9)
- Begin DoDot:1
- +9 IF $DATA(^LAM(+Y,0))
- IF $GET(^LAM(+Y,9))<1
- SET $PIECE(^LAM(+Y,9),U)=LRREC9
- End DoDot:1
- +10 QUIT
- SCR(LRMSG) ;Store message in ^XTMP("LRNLT" Global
- +1 SET LRSCR=$GET(^XTMP("LRNLT","LR567 ",1,0))+1
- SET ^(0)=LRSCR
- +2 SET ^XTMP("LRNLT","LR567 ",1,LRSCR)=LRSCR_"|"_LRMSG
- +3 QUIT
- SETUP ; SETS UP THE FDA ARRAY TO ADD A NODE
- +1 FOR
- SET LRNODE=$QUERY(@LRNODE)
- if LRNODE=""
- QUIT
- Begin DoDot:1
- +2 SET LRFLE=$QSUBSCRIPT(LRNODE,1)
- +3 SET LRFLD=$QSUBSCRIPT(LRNODE,3)
- +4 IF LRFLE=64.8117
- Begin DoDot:2
- +5 SET LRSUBFLE=64
- +6 IF LRFLD=1
- SET LRFLD=.01
- +7 IF LRFLD>1
- SET LRFLD=LRFLD-1
- +8 SET LRIENS="+"_LRTRIEN_","
- End DoDot:2
- +9 IF LRFLE'=64.8117
- Begin DoDot:2
- +10 ; CONSTRUCT THE SUBFILE NUMBER FOR FILE 64 FROM 64.81
- +11 SET LRBEG=$PIECE(LRFLE,"8117")
- +12 SET LREND=$PIECE(LRFLE,"8117",2)
- +13 SET LRSUBFLE=LRBEG_"0"_LREND
- +14 IF LRFLD=.01
- SET LRSEQ=LRSEQ+1
- +15 SET LRIENS="+"_LRSEQ_","_"+"_LRTRIEN_","
- End DoDot:2
- +16 SET LRVAL=@LRNODE
- +17 SET LRFDA(45,LRSUBFLE,LRIENS,LRFLD)=LRVAL
- +18 ;W !,"LRFDA(45,"_LRSUBFLE_","_LRIENS_LRFLD_")="_LRVAL
- End DoDot:1
- +19 KILL LRAR1
- +20 QUIT
- GNDE ; RETRIEVES NODES FROM THE TRANSPORT MULTIPLE
- +1 SET LRMLT=""
- SET LRCTR=1
- +2 DO GETS^DIQ(64.8117,LRTRIEN_","_LRIEN_",",LRMLT_"*","INZ","LRAR1")
- +3 SET LRNODE="LRAR1(64.8117_LRMLT)"
- +4 DO SETUP
- +5 IF $DATA(^LAB(64.81,50,2,LRTRIEN,1,0))
- SET LRNUM=$PIECE(^LAB(64.81,50,2,LRTRIEN,1,0),U,4)
- SET LRSEQ=LRNUM+1
- +6 IF '$TEST
- IF '$DATA(^LAB(64.81,50,2,LRTRIEN,1,0))
- SET LRSEQ=2
- +7 SET LRMLT=18
- +8 DO GETS^DIQ(64.8117,LRTRIEN_","_LRIEN_",",LRMLT_"*","INZ","LRAR1")
- +9 SET LRNODE="LRAR1(64.8117_LRMLT)"
- +10 DO SETUP
- +11 SET LRMLT=19
- SET LRSEQ=1
- +12 DO GETS^DIQ(64.8117,LRTRIEN_","_LRIEN_",",LRMLT_"*","INZ","LRAR1")
- +13 SET LRNODE="LRAR1(64.8117_LRMLT)"
- +14 DO SETUP
- +15 DO AREC
- IF $GET(LRDBUG)
- WRITE !,"NEW IEN=",$GET(LRSIXT4(LRTRIEN))
- +16 KILL LRSIXT4,LRFDA(45)
- +17 QUIT
- AREC ; ADDS ENTRIES FROM THE TRANSPORT MULTIPLE TO FILE 64
- +1 DO UPDATE^DIE("","LRFDA(45)","LRSIXT4","LROUT(45)")
- +2 IF $GET(LROUT(45,"DIERR"))
- Begin DoDot:1
- +3 SET LRENODE="LROUT(45,""DIERR"")"
- +4 DO ERMSG
- End DoDot:1
- +5 KILL LRFDA(45)
- +6 QUIT
- ERMSG ;STUFF THE TEMP GLOBAL WITH ANY ERROR MESSAGES
- +1 SET LRN=$GET(^XTMP("LRNLT642",1,0))+1
- +2 SET ^XTMP("LRNLT642",1,LRN,0)="|"_LRTRIEN_"|"_LRCODE_"|"_LRPROCNM_"|ERR"
- +3 FOR
- SET LRENODE=$QUERY(@LRENODE)
- if LRENODE=""
- QUIT
- Begin DoDot:1
- +4 SET LRN=LRN+1
- +5 SET ^XTMP("LRNLT642",1,LRN,0)="|"_LRENODE_"|="_@LRENODE
- End DoDot:1
- +6 SET ^XTMP("LRNLT642",1,0)=LRN
- +7 SET LRERR=1
- +8 KILL LRENODE
- +9 QUIT
- KREC ; DELETES THE RECORD FROM THE FILE
- +1 if $GET(LRDBUG)
- QUIT
- +2 NEW DA,DIK
- +3 SET DA(1)=LRIEN
- SET DA=LRTRIEN
- +4 SET DIK="^LAB(64.81,"_DA(1)_",2,"
- DO ^DIK
- +5 QUIT
- DSS ;Update WKLD CODE file , DSS Feeder Key (#14) field to 'Yes"
- +1 ;for those NLT codes used for AP professional services
- +2 ;D BMES^XPDUTL("Updating DSS Feeder Key for AP NLT Codes")
- +3 NEW ERR,FDA,IEN,LST,OUT,NODE,X
- +4 SET NODE="^LAB(64.81,""AC"")"
- +5 FOR
- SET NODE=$QUERY(@NODE)
- if $QSUBSCRIPT(NODE,2)'="AC"
- QUIT
- Begin DoDot:1
- +6 SET X=$PIECE($$GET1^DIQ(64.8117,$QSUBSCRIPT(NODE,5)_","_$QSUBSCRIPT(NODE,4)_",",2,"I","ERR"),".")
- +7 if 'X
- QUIT
- +8 KILL OUT,ERR
- +9 DO FIND^DIC(64,"","@;1","M",X,"","C","","","OUT","ERR")
- +10 if $DATA(ERR)
- QUIT
- +11 SET LST=0
- FOR
- SET LST=$ORDER(OUT("DILIST",2,LST))
- if 'LST
- QUIT
- Begin DoDot:2
- +12 SET IEN=$GET(OUT("DILIST",2,LST))
- +13 if '($DATA(^LAM(IEN,0))#2)
- QUIT
- +14 KILL FDA,ERR
- SET FDA(1,64,IEN_",",14)=1
- +15 DO FILE^DIE("","FDA(1)","ERR")
- +16 IF $DATA(ERR)
- WRITE !,$CHAR(7),ERR
- +17 WRITE "*"
- End DoDot:2
- End DoDot:1
- +18 ;D BMES^LR334("Update DSS AP Feeder Key Complete")
- +19 QUIT