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

LR567.m

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