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

LR263.m

Go to the documentation of this file. 
  1. LR263 ;DALOI/FHS - LR*5.2*263 PATCH ENVIRONMENT CHECK & CONVERT ROUTINE ; 5/1/99 ;
  1.  ;;5.2;LAB SERVICE;**263**;Sep 27, 1994
  1. EN ; Does not prevent loading of the transport global.
  1.  ; Environment check is done only during the install.
  1.  Q:'$G(XPDENV)
  1.  D CHECK
  1.  D EXIT
  1.  Q
  1.  ;
  1. CHECK ; Perform environment check
  1.  N VER
  1.  I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D
  1.  . D BMES^XPDUTL($$CJ^XLFSTR("Terminal Device is not defined",80))
  1.  . S XPDQUIT=2
  1.  I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D
  1.  . D BMES^XPDUTL($$CJ^XLFSTR("Please log in to set local DUZ... variables",80))
  1.  . S XPDQUIT=2
  1.  I '$D(^VA(200,$G(DUZ),0))#2 D
  1.  . D BMES^XPDUTL($$CJ^XLFSTR("You are not a valid user on this system",80))
  1.  . S XPDQUIT=2
  1.  S VER=$$VERSION^XPDUTL("LA7")
  1.  I VER'>5.1 D
  1.  . D BMES^XPDUTL($$CJ^XLFSTR("You must have LAB MESSAGING PACKAGE V5.2 Installed",80))
  1.  . S XPDQUIT=2
  1.  S VER=$$VERSION^XPDUTL("LR")
  1.  I VER'>5.1 D
  1.  . D BMES^XPDUTL($$CJ^XLFSTR("You must have LAB SERVICE PACKAGE V5.2 Installed",80))
  1.  . S XPDQUIT=2
  1. LMI ;
  1.  N DIC,X,Y
  1.  S DIC=3.8,DIC(0)="NMXO",X="LMI" D ^DIC
  1.  I Y<1 D
  1.  . D BMES^XPDUTL($$CJ^XLFSTR("You must have Mail Group [ LMI ] defined.",80))
  1.  . S XPDQUIT=2
  1.  Q:$G(XPDQUIT)<1
  1.  S XPDIQ("XPZ1","B")="NO"
  1.  Q
  1.  ;
  1. EXIT ;
  1.  I $G(XPDQUIT) D BMES^XPDUTL($$CJ^XLFSTR("--- Install Environment Check FAILED ---",80))
  1.  I '$G(XPDQUIT) D BMES^XPDUTL($$CJ^XLFSTR("--- Environment Check is Ok ---",80))
  1.  Q
  1. CONV ;Convert data to new DD structure
  1.  K ^TMP("LRCPT",$J),^TMP("LRCPT@",$J),LRDA,LRROOT,LRDEL,LRTXT
  1.  K ^TMP("LRCPTERR",$J)
  1.  S LRMSG="^TMP(""LRCPT"","_$J_")",CNT=0
  1.  S LRSUB="LRCPTERR",$P(LRTXT(5),"=",40)="",LRTXT(4)=""
  1.  S LRDA(1)=0 F  S LRDA(1)=$O(^LAM(LRDA(1))) Q:LRDA(1)<1  D
  1.  . S LRDA=0 F  S LRDA=$O(^LAM(LRDA(1),4,LRDA)) Q:LRDA<1  D
  1.  . . I '$D(^LAM(LRDA(1),4,LRDA,0)) K ^LAM(LRDA(1),4,LRDA) Q
  1.  . . S LRN=^LAM(LRDA(1),4,LRDA,0)
  1.  . . K LRROOT
  1.  . . S LRS=$P(LRN,U,2) I '$L(LRS) D BMES^XPDUTL($$CJ^XLFSTR("DATA BASE ERROR",80)) D DEL Q
  1.  . . S:LRS="L" LRS="LOINC"
  1.  . . S LRROOT(64.018,$$IENS^DILF(.LRDA),.01)=LRS_"."_+$P(LRN,U) D UPDATE
  1. MAIL ;Send message to G.LMI local mail group
  1.  I '$O(^TMP(LRSUB,$J,0)) D BMES^XPDUTL($$CJ^XLFSTR("No CPT Errors were found - No Mail message required.",80))
  1.  I $O(^TMP(LRSUB,$J,0)) D
  1.  . D BMES^XPDUTL($$CJ^XLFSTR("Creating Mail Message containing CPT Changes",80))
  1.  . D BMES^XPDUTL($$CJ^XLFSTR("Sending message to LMI Mail Group.",80))
  1.  . N DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
  1.  . S XMSUB="WKLD CODE - CODE CHECK REPORT "_$$FMTE^XLFDT($$NOW^XLFDT,"1S")
  1.  . S XMY("G.LMI")="",XMTEXT="^TMP(""LRCPTERR"","_$J_",",XMDUZ=.5
  1.  . D ^XMD
  1.  D LNK6064
  1.  S:$D(^LAM(0))#2 $P(^(0),U,3)=99999
  1. PUNCT ;Make venipuncture WKLD CODE(s) billable
  1.  D
  1.  . N DIC,X,Y
  1.  . S DIC="^LAM(",DIC(0)="ONMX"
  1.  . F X="89343.0000","89341.0000" D ^DIC I Y>1 D
  1.  . . I $D(^LAM(+Y,0))#2 S $P(^(0),U,5)=1
  1. END ;
  1.  Q:$G(LRDBUG)
  1.  K ^LRO(69,"AE"),^LRO(69,"AA",0)
  1.  K ^TMP("LRCPT",$J),^TMP("LRCPT@",$J),^TMP("LRCPTERR",$J)
  1.  K CNT,I,LRCMT,LRDA,LRDEL,LRMSG,LRN,LRROOT,LRS,LRSUB,LRTXT,SUB,TXT
  1.  K XMDUZ,XMSUB,XMTEXT,XMY
  1.  Q
  1. LNK6064 ; Relink NATIONAL VA LAB CODE with WKLD CODE file
  1.  D BMES^XPDUTL($$CJ^XLFSTR("Relinking NATIONAL VA LAB CODES TO WKLD CODES",80))
  1.  N CNT,CNTT,RT,IEN,LR64,CODE,NAME,DATA,LRX,I
  1.  S I=0 F  S I=$O(^LAM(I)) Q:I<1  K ^LAM(I,7)
  1.  K ^LAM("AE","LAB(60,")
  1.  S (CNTT,CNT)=0
  1.  S LRX=0 F  S LRX=$O(^LAB(60,LRX)) Q:LRX<1  D
  1.  . S CODE=+$P($G(^LAB(60,LRX,64)),U)
  1.  . Q:'$D(^LAM(CODE,0))#2    ; no code to update
  1.  . S NAME=$P(^LAB(60,LRX,0),U)
  1.  . S CNT=CNT+1 K ERR,RT,IEN
  1.  . S DATA="LAB(60,.`"_LRX,CNTT=CNTT+1
  1.  . S IEN="+1,"_CODE_",",RT(64.023,IEN,.01)=DATA
  1.  . D UPDATE^DIE("ES","RT","IEN","^LAH(""ERR243"")")
  1.  . W "."
  1.  Q
  1. UPDATE ;
  1.  S CNT=$G(CNT)+1
  1.  D FILE^DIE("E","LRROOT","^TMP(""LRCPT"","_$J_","_CNT_")")
  1.  I $D(LRROOT) W ! D DEL Q
  1.  W:'$D(ZTQUEUED) "."
  1.  Q
  1. DEL K LRDEL
  1.  N LRNOP
  1.  S LRTXT(2)="Removing "_LRS_" Code "_$P(LRN,U) D BMES^XPDUTL(LRTXT(2))
  1.  I $D(^LAM(LRDA(1),0))#2 S LRTXT(3)="From "_$P(^LAM(LRDA(1),0),U,2)_"  "_$S($P(^(0),U,5):"+",1:"")_$P(^(0),U)
  1.  E  S LRTXT(3)="DATABASE ERROR FOR ENTRY "_LRDA(1),LRNOP=1
  1.  S LRTXT(4)=$$FMTE^XLFDT($$NOW^XLFDT)
  1.  D BMES^XPDUTL(LRTXT(3))
  1.  S LRDEL(64.018,$$IENS^DILF(.LRDA),.01)="@"
  1.  D:'$G(LRNOP) FILE^DIE("E","LRDEL","TMP(""LRCPT@"","_$J_","_CNT_")")
  1.  D MSGSET(LRSUB,.LRTXT)
  1.  I '$G(LRNOP) D WP^DIE(64,LRDA(1)_",",24,"A","LRTXT","TMP(""LRCPT@"","_$J_","_CNT_")")
  1.  Q
  1. MSGSET(SUB,TXT) ;SUB=subscript - TXT = array containing the message
  1.  N I        ;
  1.  S LRCMT=$P($G(^TMP(SUB,$J,0)),U,4)
  1.  S I=0 F  S I=$O(TXT(I)) Q:I<1  D
  1.  . S LRCMT=LRCMT+1,^TMP(SUB,$J,LRCMT,0)=TXT(I)
  1.  S $P(^TMP(SUB,$J,0),U,4)=LRCMT
  1.  Q