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

LR258PO.m

Go to the documentation of this file. 
  1. LR258PO ;DALOI/FHS/RSH - LR*5.2*258 PATCH POST INSTALL ROUTINE
  1.  ;;5.2;LAB SERVICE;**258**;Sep 27,1994
  1. PRE ;
  1.  ;$$HTE^XLFDT supported by DBIA #10103
  1.  ;$$HTFE^XLFDT supported by DBIA #10103
  1.  ;$$NOW^XLFDT supported by DBIA #10103
  1.  ;$$CJ^XLFSTR supported by DBIA #10104
  1.  ;^XMD supported by DBIA #10070
  1.  ;$$PATCH^XPDUTL supported by DBIA #10141
  1.  ;BMES^XPDUTL supported by DBIA #10141
  1.  ;SETUP^XQALERT supported by DBIA $10081
  1.  ;FILE^DIE supported by DBIA #10018
  1.  ;GETS^DIQ supported by DBIA #2056
  1.  ;EN^DIU2 supported by DBIA #10014
  1.  ;$$SITE^VASITE supported by DBIA #10112
  1.  ;$$FMTE^XLFDT supported by DBIA #10103
  1.  ;$$THE^XLFDT supported by DBIA #10103
  1.  ;$$HTFM^XLFDT supported by DBIA #10103
  1.  Q:'$D(XPDNM)
  1.  I $O(^LAM(0)) D  Q:$G(XPDQUIT)
  1.  . Q:$$PATCH^XPDUTL("LR*5.2*263")
  1.  . S XPDQUIT=2
  1.  . W $$CJ^XLFSTR("You must install LR*5.2*263 Patch",80)
  1.  S LRLAST=$O(^LAB(64.2,9999),-1)
  1.  I '$D(^XTMP("LRNLT642")) D
  1.  . S ^XTMP("LRNLT642",.01)=LRLAST
  1.  . S ^XTMP("LRNLT642",0)=$$HTFM^XLFDT($H+60,1)_"^"_DT_"^ LAB(64.2 Save"
  1.  . M ^XTMP("LRNLT642",1)=^LAB(64.2)
  1.  S DIU="^LAB(64.81,",DIU(0)="DST" D EN^DIU2 K DIU
  1.  S:$D(^LAB(64.2,0))#2 $P(^(0),U,3)=$G(LRLAST,1)
  1.  K LRLAST
  1.  Q
  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
  1.  D BMES^XPDUTL($$CJ^XLFSTR("Re-indexing WKLD CODE (#64) file",80))
  1.  S DIK="^LAM(" D IXALL^DIK K DIK
  1.  D
  1.  . N LRI,DIC,X,Y,LRFDA,LRANS
  1.  . S DIC=64.3,DIC(0)="OX"
  1.  . S LRI=0 F  S LRI=$O(^LAB(64.2,LRI)) Q:LRI<1  D
  1.  . . Q:'$D(^LAB(64.2,LRI,2))  S X=$P(^(2),U,2)
  1.  . . Q:'$L(X)  D ^DIC Q:Y<1
  1.  . . K LRFDA,LRANS
  1.  . . S LRFDA(64.2,LRI_",",11)=+Y
  1.  . . D FILE^DIE("K","LRFDA","LRANS")
  1.  D BMES^XPDUTL($$CJ^XLFSTR("Re-indexing completed",80))
  1.  K ^XTMP("LRNLTERR",$J) S ^XTMP("LRNLTERR",$J,0)=$$HTFM^XLFDT($H+60,1)_"^"_DT_"^LR52 258 Error Messages"
  1.  K ^XTMP("LRNLT",$J)
  1.  S ^XTMP("LRNLT",$J,0)=$$HTFM^XLFDT($H+60,1)_"^"_DT_"^LR52 258 Messages"
  1.  N DA,DIK,LRIEN,LRN0,LRN1,LRFILE
  1.  S LRIEN=0 F  S LRIEN=$O(^LAB(64.81,LRIEN)) Q:LRIEN<1!(LRIEN>49)  D
  1.  . W "." S LRN0=$G(^LAB(64.81,LRIEN,0)),LRN1=$G(^(1))
  1.  . S LRFILE=$P(LRN1,U,4)
  1.  . I 'LRFILE D DEL Q
  1.  . D CHK
  1.  D BMES^XPDUTL($$CJ^XLFSTR("*** Spelling errors corrected in existing database ***",80))
  1.  D POST
  1. ALERT ;
  1.  D BMES^XPDUTL($$CJ^XLFSTR("Sending installation message to G.LMI mail group",80))
  1.  N XQA,XQAMSG
  1.  S XQAMSG="Installation of patch "_$G(XPDNM,"Unknown Patch")_" complete "_$$HTE^XLFDT($H)
  1.  S XQA("G.LMI")=""
  1.  D SETUP^XQALERT
  1.  L -^LAM
  1.  Q
  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(LRDEBUG) !,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.  . 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(LRDEBUG) !,"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. POST ;TRANSPORT FILE 64.81 INTO FILE 64 IF REQUIRED
  1.  S (LRLAST64,LRNEXT)=$O(^LAM(99999),-1)
  1.  S $P(^LAM(0),U,3)=$G(LRNEXT,1)
  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.  . I $G(LRDEBUG) W !,LRREC_" "
  1.  . S LRTRIEN=$P(LRREC,U)
  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,LRVR=$T(+2)
  1.  S ^LAM("VR")=LRVR
  1.  F I=64.061,64.2,64.21,64.22,64.3 I $D(^LAB(I,0))#2 S ^("VR")=LRVR
  1.  D:'$G(LRDEBUG) MAIL
  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
  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
  1.  S (LRADD,LRCHG,LRERR)=0
  1.  S LRCODE=$P(LRREC,U,3),LRPROCNM=$P(LRREC,U,2)
  1.  S DIC="^LAM(",DIC(0)="MXZ",X=LRCODE
  1.  D ^DIC
  1.  I Y=-1 D
  1.  . I '$D(^LAM("C",LRCODE_" ")) S LRADD=1 Q
  1.  . I $D(^LAM("C",LRCODE_" ")) D
  1.  . . S LRN=LRN+1
  1.  . . S ^XTMP("LRNLT642",1,LRN,0)="|"_LRCODE_"|"_LRPROCNM_"|"_"**Duplicate codes**"
  1.  . . S LRERR=1
  1.  I Y>0 D  ;COMPARE THE NAME IN BOTH FILES
  1.  . S LRFNAM=$P(Y(0),U)
  1.  . I LRPROCNM=LRFNAM S (LRADD,LRCHG)=0 Q
  1.  . I LRPROCNM'=LRFNAM S LRCHG=+Y
  1.  ;I LRADD!LRCHG W !,"ADD=",LRADD," CHG=",LRCHG
  1.  Q
  1. SCR(LRMSG) ;Store message in ^XTMP("LRNLT" Global
  1.  S LRSCR=$G(^XTMP("LRNLT",$J,1,0))+1,^(0)=LRSCR
  1.  S ^XTMP("LRNLT",$J,1,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(LRDEBUG) 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=LRN+1
  1.  S ^XTMP("LRNLT642",1,LRN,0)="|"_LRTRIEN_"|"_LRCODE_"|"_LRPROCNM_"|"
  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 LRERR=1
  1.  K LRENODE
  1.  Q
  1. KREC ; DELETES THE RECORD FROM THE FILE
  1.  Q:$G(LRDEBUG)
  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. MAIL ;Send message to G.LMI local mail group of added 64 codes
  1.  N DIFROM,XMSUB,XMDUZ,XMTEXT,XMY,LRIEN,LRN
  1. NEWLST ;Build list of added WKLD CODES
  1.  D
  1.  . D BMES^XPDUTL($$CJ^XLFSTR("Building List Of Added WKLD CODEs",80))
  1.  . N LRN,LRIEN,LRSTR,LRCNT
  1.  . S LRCNT=0
  1.  . S LRN="^LAM(""B"")" S:'$G(LRLAST64) LRLAST64=3203
  1.  . F  S LRN=$Q(@LRN) Q:$QS(LRN,1)'="B"  I '@LRN D
  1.  . . S LRIEN=$QS(LRN,3)
  1.  . . I LRIEN>LRLAST64,LRIEN<99999,$D(^LAM(LRIEN,0))#2 S LRSTR=$P(^(0),U,1,2) D
  1.  . . . S LRCNT=$G(LRCNT)+1
  1.  . . . S LRSTR=LRCNT_"|"_$TR(LRSTR,"^","|")_"|IEN= "_LRIEN
  1.  . . . D SCR(LRSTR)
  1.  . D BMES^XPDUTL($$CJ^XLFSTR("List Of Added WKLD CODEs Complete",80))
  1.  K LRLAST64
  1.  I '$O(^XTMP("LRNLT",$J,1,3)) D
  1.  . I '$G(LRPRT) D
  1.  . . D SCR("No WKLD CODES Added to Database")
  1.  D BMES^XPDUTL($$CJ^XLFSTR("Sending message to LMI Mail Group.",80))
  1.  S XMSUB="ADDED WKLD CODE REPORT "_$$FMTE^XLFDT($$NOW^XLFDT,"1S")
  1.  S XMY("G.LMI")="",XMTEXT="^XTMP(""LRNLT"","_$J_",1,",XMDUZ=.5
  1.  D ^XMD
  1. CHK642 ;Looking for locally added suffix
  1.  K DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
  1.  N LRSC,LRCNT,LRNX,LRI
  1.  S LRSC="",LRCNT=0
  1.  F  S LRCNT=$O(^XTMP("LRNLT642",1,LRCNT)) Q:LRCNT<1  K ^XTMP("LRNLT642",1,LRCNT,1)
  1.  S LRNX="^XTMP(""LRNLT642"",1,""C"")"
  1.  F  S LRNX=$Q(@LRNX) Q:$QS(LRNX,3)'="C"  D
  1.  . I $D(^LAB(64.2,"C",$QS(LRNX,4))) D  Q
  1.  . . K ^XTMP("LRNLT642",1,$QS(LRNX,5))
  1.  . W:$G(LRDBUG) !,LRNX
  1.  F LRI="AC","B","C","D","E","F" K ^XTMP("LRNLT642",1,LRI)
  1. MES642 ;
  1.  I '$O(^XTMP("LRNLT642",1,0)) K ^XTMP("LRNLT642") Q
  1.  S XMSUB=$TR($P($$SITE^VASITE,U,1,2),U,"|")_" LR 258 - 64 2 "_DT
  1.  S XMY("G.LMI@ISC-DALLAS")=""
  1.  S XMTEXT="^XTMP(""LRNLT642"",1,",XMDUZ=.5
  1.  D ^XMD
  1.  Q