LR258PO ;DALOI/FHS/RSH - LR*5.2*258 PATCH POST INSTALL ROUTINE
;;5.2;LAB SERVICE;**258**;Sep 27,1994
PRE ;
;$$HTE^XLFDT supported by DBIA #10103
;$$HTFE^XLFDT supported by DBIA #10103
;$$NOW^XLFDT supported by DBIA #10103
;$$CJ^XLFSTR supported by DBIA #10104
;^XMD supported by DBIA #10070
;$$PATCH^XPDUTL supported by DBIA #10141
;BMES^XPDUTL supported by DBIA #10141
;SETUP^XQALERT supported by DBIA $10081
;FILE^DIE supported by DBIA #10018
;GETS^DIQ supported by DBIA #2056
;EN^DIU2 supported by DBIA #10014
;$$SITE^VASITE supported by DBIA #10112
;$$FMTE^XLFDT supported by DBIA #10103
;$$THE^XLFDT supported by DBIA #10103
;$$HTFM^XLFDT supported by DBIA #10103
Q:'$D(XPDNM)
I $O(^LAM(0)) D Q:$G(XPDQUIT)
. Q:$$PATCH^XPDUTL("LR*5.2*263")
. S XPDQUIT=2
. W $$CJ^XLFSTR("You must install LR*5.2*263 Patch",80)
S LRLAST=$O(^LAB(64.2,9999),-1)
I '$D(^XTMP("LRNLT642")) D
. S ^XTMP("LRNLT642",.01)=LRLAST
. S ^XTMP("LRNLT642",0)=$$HTFM^XLFDT($H+60,1)_"^"_DT_"^ LAB(64.2 Save"
. M ^XTMP("LRNLT642",1)=^LAB(64.2)
S DIU="^LAB(64.81,",DIU(0)="DST" D EN^DIU2 K DIU
S:$D(^LAB(64.2,0))#2 $P(^(0),U,3)=$G(LRLAST,1)
K LRLAST
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
D BMES^XPDUTL($$CJ^XLFSTR("Re-indexing WKLD CODE (#64) file",80))
S DIK="^LAM(" D IXALL^DIK K DIK
D
. N LRI,DIC,X,Y,LRFDA,LRANS
. S DIC=64.3,DIC(0)="OX"
. S LRI=0 F S LRI=$O(^LAB(64.2,LRI)) Q:LRI<1 D
. . Q:'$D(^LAB(64.2,LRI,2)) S X=$P(^(2),U,2)
. . Q:'$L(X) D ^DIC Q:Y<1
. . K LRFDA,LRANS
. . S LRFDA(64.2,LRI_",",11)=+Y
. . D FILE^DIE("K","LRFDA","LRANS")
D BMES^XPDUTL($$CJ^XLFSTR("Re-indexing completed",80))
K ^XTMP("LRNLTERR",$J) S ^XTMP("LRNLTERR",$J,0)=$$HTFM^XLFDT($H+60,1)_"^"_DT_"^LR52 258 Error Messages"
K ^XTMP("LRNLT",$J)
S ^XTMP("LRNLT",$J,0)=$$HTFM^XLFDT($H+60,1)_"^"_DT_"^LR52 258 Messages"
N DA,DIK,LRIEN,LRN0,LRN1,LRFILE
S LRIEN=0 F S LRIEN=$O(^LAB(64.81,LRIEN)) Q:LRIEN<1!(LRIEN>49) D
. W "." S LRN0=$G(^LAB(64.81,LRIEN,0)),LRN1=$G(^(1))
. S LRFILE=$P(LRN1,U,4)
. I 'LRFILE D DEL Q
. D CHK
D BMES^XPDUTL($$CJ^XLFSTR("*** Spelling errors corrected in existing database ***",80))
D POST
ALERT ;
D BMES^XPDUTL($$CJ^XLFSTR("Sending installation message to G.LMI mail group",80))
N XQA,XQAMSG
S XQAMSG="Installation of patch "_$G(XPDNM,"Unknown Patch")_" complete "_$$HTE^XLFDT($H)
S XQA("G.LMI")=""
D SETUP^XQALERT
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(LRDEBUG) !,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
. 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(LRDEBUG) !,"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
POST ;TRANSPORT FILE 64.81 INTO FILE 64 IF REQUIRED
S (LRLAST64,LRNEXT)=$O(^LAM(99999),-1)
S $P(^LAM(0),U,3)=$G(LRNEXT,1)
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
. I $G(LRDEBUG) W !,LRREC_" "
. S LRTRIEN=$P(LRREC,U)
. 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,LRVR=$T(+2)
S ^LAM("VR")=LRVR
F I=64.061,64.2,64.21,64.22,64.3 I $D(^LAB(I,0))#2 S ^("VR")=LRVR
D:'$G(LRDEBUG) MAIL
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
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
S (LRADD,LRCHG,LRERR)=0
S LRCODE=$P(LRREC,U,3),LRPROCNM=$P(LRREC,U,2)
S DIC="^LAM(",DIC(0)="MXZ",X=LRCODE
D ^DIC
I Y=-1 D
. I '$D(^LAM("C",LRCODE_" ")) S LRADD=1 Q
. I $D(^LAM("C",LRCODE_" ")) D
. . S LRN=LRN+1
. . S ^XTMP("LRNLT642",1,LRN,0)="|"_LRCODE_"|"_LRPROCNM_"|"_"**Duplicate codes**"
. . S LRERR=1
I Y>0 D ;COMPARE THE NAME IN BOTH FILES
. S LRFNAM=$P(Y(0),U)
. I LRPROCNM=LRFNAM S (LRADD,LRCHG)=0 Q
. I LRPROCNM'=LRFNAM S LRCHG=+Y
;I LRADD!LRCHG W !,"ADD=",LRADD," CHG=",LRCHG
Q
SCR(LRMSG) ;Store message in ^XTMP("LRNLT" Global
S LRSCR=$G(^XTMP("LRNLT",$J,1,0))+1,^(0)=LRSCR
S ^XTMP("LRNLT",$J,1,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(LRDEBUG) 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=LRN+1
S ^XTMP("LRNLT642",1,LRN,0)="|"_LRTRIEN_"|"_LRCODE_"|"_LRPROCNM_"|"
F S LRENODE=$Q(@LRENODE) Q:LRENODE="" D
. S LRN=LRN+1
. S ^XTMP("LRNLT642",1,LRN,0)="|"_LRENODE_"|="_@LRENODE
S LRERR=1
K LRENODE
Q
KREC ; DELETES THE RECORD FROM THE FILE
Q:$G(LRDEBUG)
N DA,DIK
S DA(1)=LRIEN,DA=LRTRIEN
S DIK="^LAB(64.81,"_DA(1)_",2," D ^DIK
Q
MAIL ;Send message to G.LMI local mail group of added 64 codes
N DIFROM,XMSUB,XMDUZ,XMTEXT,XMY,LRIEN,LRN
NEWLST ;Build list of added WKLD CODES
D
. D BMES^XPDUTL($$CJ^XLFSTR("Building List Of Added WKLD CODEs",80))
. N LRN,LRIEN,LRSTR,LRCNT
. S LRCNT=0
. S LRN="^LAM(""B"")" S:'$G(LRLAST64) LRLAST64=3203
. F S LRN=$Q(@LRN) Q:$QS(LRN,1)'="B" I '@LRN D
. . S LRIEN=$QS(LRN,3)
. . I LRIEN>LRLAST64,LRIEN<99999,$D(^LAM(LRIEN,0))#2 S LRSTR=$P(^(0),U,1,2) D
. . . S LRCNT=$G(LRCNT)+1
. . . S LRSTR=LRCNT_"|"_$TR(LRSTR,"^","|")_"|IEN= "_LRIEN
. . . D SCR(LRSTR)
. D BMES^XPDUTL($$CJ^XLFSTR("List Of Added WKLD CODEs Complete",80))
K LRLAST64
I '$O(^XTMP("LRNLT",$J,1,3)) D
. I '$G(LRPRT) D
. . D SCR("No WKLD CODES Added to Database")
D BMES^XPDUTL($$CJ^XLFSTR("Sending message to LMI Mail Group.",80))
S XMSUB="ADDED WKLD CODE REPORT "_$$FMTE^XLFDT($$NOW^XLFDT,"1S")
S XMY("G.LMI")="",XMTEXT="^XTMP(""LRNLT"","_$J_",1,",XMDUZ=.5
D ^XMD
CHK642 ;Looking for locally added suffix
K DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
N LRSC,LRCNT,LRNX,LRI
S LRSC="",LRCNT=0
F S LRCNT=$O(^XTMP("LRNLT642",1,LRCNT)) Q:LRCNT<1 K ^XTMP("LRNLT642",1,LRCNT,1)
S LRNX="^XTMP(""LRNLT642"",1,""C"")"
F S LRNX=$Q(@LRNX) Q:$QS(LRNX,3)'="C" D
. I $D(^LAB(64.2,"C",$QS(LRNX,4))) D Q
. . K ^XTMP("LRNLT642",1,$QS(LRNX,5))
. W:$G(LRDBUG) !,LRNX
F LRI="AC","B","C","D","E","F" K ^XTMP("LRNLT642",1,LRI)
MES642 ;
I '$O(^XTMP("LRNLT642",1,0)) K ^XTMP("LRNLT642") Q
S XMSUB=$TR($P($$SITE^VASITE,U,1,2),U,"|")_" LR 258 - 64 2 "_DT
S XMY("G.LMI@ISC-DALLAS")=""
S XMTEXT="^XTMP(""LRNLT642"",1,",XMDUZ=.5
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR258PO 9836 printed Dec 13, 2024@02:03:31 Page 2
LR258PO ;DALOI/FHS/RSH - LR*5.2*258 PATCH POST INSTALL ROUTINE
+1 ;;5.2;LAB SERVICE;**258**;Sep 27,1994
PRE ;
+1 ;$$HTE^XLFDT supported by DBIA #10103
+2 ;$$HTFE^XLFDT supported by DBIA #10103
+3 ;$$NOW^XLFDT supported by DBIA #10103
+4 ;$$CJ^XLFSTR supported by DBIA #10104
+5 ;^XMD supported by DBIA #10070
+6 ;$$PATCH^XPDUTL supported by DBIA #10141
+7 ;BMES^XPDUTL supported by DBIA #10141
+8 ;SETUP^XQALERT supported by DBIA $10081
+9 ;FILE^DIE supported by DBIA #10018
+10 ;GETS^DIQ supported by DBIA #2056
+11 ;EN^DIU2 supported by DBIA #10014
+12 ;$$SITE^VASITE supported by DBIA #10112
+13 ;$$FMTE^XLFDT supported by DBIA #10103
+14 ;$$THE^XLFDT supported by DBIA #10103
+15 ;$$HTFM^XLFDT supported by DBIA #10103
+16 if '$DATA(XPDNM)
QUIT
+17 IF $ORDER(^LAM(0))
Begin DoDot:1
+18 if $$PATCH^XPDUTL("LR*5.2*263")
QUIT
+19 SET XPDQUIT=2
+20 WRITE $$CJ^XLFSTR("You must install LR*5.2*263 Patch",80)
End DoDot:1
if $GET(XPDQUIT)
QUIT
+21 SET LRLAST=$ORDER(^LAB(64.2,9999),-1)
+22 IF '$DATA(^XTMP("LRNLT642"))
Begin DoDot:1
+23 SET ^XTMP("LRNLT642",.01)=LRLAST
+24 SET ^XTMP("LRNLT642",0)=$$HTFM^XLFDT($HOROLOG+60,1)_"^"_DT_"^ LAB(64.2 Save"
+25 MERGE ^XTMP("LRNLT642",1)=^LAB(64.2)
End DoDot:1
+26 SET DIU="^LAB(64.81,"
SET DIU(0)="DST"
DO EN^DIU2
KILL DIU
+27 if $DATA(^LAB(64.2,0))#2
SET $PIECE(^(0),U,3)=$GET(LRLAST,1)
+28 KILL LRLAST
+29 QUIT
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
+2 DO BMES^XPDUTL($$CJ^XLFSTR("Re-indexing WKLD CODE (#64) file",80))
+3 SET DIK="^LAM("
DO IXALL^DIK
KILL DIK
+4 Begin DoDot:1
+5 NEW LRI,DIC,X,Y,LRFDA,LRANS
+6 SET DIC=64.3
SET DIC(0)="OX"
+7 SET LRI=0
FOR
SET LRI=$ORDER(^LAB(64.2,LRI))
if LRI<1
QUIT
Begin DoDot:2
+8 if '$DATA(^LAB(64.2,LRI,2))
QUIT
SET X=$PIECE(^(2),U,2)
+9 if '$LENGTH(X)
QUIT
DO ^DIC
if Y<1
QUIT
+10 KILL LRFDA,LRANS
+11 SET LRFDA(64.2,LRI_",",11)=+Y
+12 DO FILE^DIE("K","LRFDA","LRANS")
End DoDot:2
End DoDot:1
+13 DO BMES^XPDUTL($$CJ^XLFSTR("Re-indexing completed",80))
+14 KILL ^XTMP("LRNLTERR",$JOB)
SET ^XTMP("LRNLTERR",$JOB,0)=$$HTFM^XLFDT($HOROLOG+60,1)_"^"_DT_"^LR52 258 Error Messages"
+15 KILL ^XTMP("LRNLT",$JOB)
+16 SET ^XTMP("LRNLT",$JOB,0)=$$HTFM^XLFDT($HOROLOG+60,1)_"^"_DT_"^LR52 258 Messages"
+17 NEW DA,DIK,LRIEN,LRN0,LRN1,LRFILE
+18 SET LRIEN=0
FOR
SET LRIEN=$ORDER(^LAB(64.81,LRIEN))
if LRIEN<1!(LRIEN>49)
QUIT
Begin DoDot:1
+19 WRITE "."
SET LRN0=$GET(^LAB(64.81,LRIEN,0))
SET LRN1=$GET(^(1))
+20 SET LRFILE=$PIECE(LRN1,U,4)
+21 IF 'LRFILE
DO DEL
QUIT
+22 DO CHK
End DoDot:1
+23 DO BMES^XPDUTL($$CJ^XLFSTR("*** Spelling errors corrected in existing database ***",80))
+24 DO POST
ALERT ;
+1 DO BMES^XPDUTL($$CJ^XLFSTR("Sending installation message to G.LMI mail group",80))
+2 NEW XQA,XQAMSG
+3 SET XQAMSG="Installation of patch "_$GET(XPDNM,"Unknown Patch")_" complete "_$$HTE^XLFDT($HOROLOG)
+4 SET XQA("G.LMI")=""
+5 DO SETUP^XQALERT
+6 LOCK -^LAM
+7 QUIT
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(LRDEBUG)
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 SET (LRNAMX,LRNAMY,X)=$PIECE(LRN0,U)
+18 SET DIC=64.2
SET LRNUMX=$PIECE(LRN1,U,2)
+19 SET DIC("S")="I $P(^(0),U,2)=LRNUMX"
+20 DO ^DIC
IF Y<1
DO DEL
QUIT
+21 SET LRIENS=+Y_","
+22 IF $LENGTH($PIECE(LRN0,U,8))
Begin DoDot:2
+23 SET LRNAMY=$PIECE(LRN0,U,8)
+24 SET LRFDA(LRFILE,LRIENS,.01)=LRNAMY
End DoDot:2
+25 IF $PIECE(LRN1,U,3)
Begin DoDot:2
+26 SET LRNUMY=$PIECE(LRN1,U,3)
+27 SET LRFDA(LRFILE,LRIENS,1)=LRNUMY
End DoDot:2
+28 IF $LENGTH($PIECE(LRN1,U,7))
Begin DoDot:2
+29 SET LRSYN=$PIECE(LRN1,U,7)
SET LRSYNIEN=$ORDER(^LAB(64.2,+LRIENS,1,"B",LRSYN,0))
+30 if 'LRSYNIEN
QUIT
+31 SET LRFDA(64.23,LRSYNIEN_","_LRIENS,.01)="@"
End DoDot:2
+32 if $GET(LRDBUG)
WRITE !,Y_" ( "_LRFILE
End DoDot:1
+33 IF $DATA(LRFDA)
DO SET
+34 QUIT
SET ;
+1 DO FILE^DIE("KS","LRFDA","LRANS")
+2 IF '$DATA(LRANS)
if $GET(LRDEBUG)
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
POST ;TRANSPORT FILE 64.81 INTO FILE 64 IF REQUIRED
+1 SET (LRLAST64,LRNEXT)=$ORDER(^LAM(99999),-1)
+2 SET $PIECE(^LAM(0),U,3)=$GET(LRNEXT,1)
+3 SET LRN=$ORDER(^XTMP("LRNLT642",1,99999),-1)
+4 SET (LRADD,LRCHG,LRDOT)=0
+5 DO SCR("==========================")
+6 DO SCR("List of WKLD CODES added to ^LAM (#64)")
+7 DO SCR(" ")
+8 SET LRNEXT=0
SET LRIEN=50
+9 FOR
SET LRNEXT=$ORDER(^LAB(64.81,LRIEN,2,LRNEXT))
if LRNEXT<1
QUIT
Begin DoDot:1
+10 KILL LRFDA,LROUT,LRAR1,LRSIXT4
+11 SET LRDOT=$GET(LRDOT)+1
IF LRDOT#50=0
WRITE ". "
+12 SET LRREC=^LAB(64.81,LRIEN,2,LRNEXT,0)
SET LRERR=0
+13 IF $GET(LRDEBUG)
WRITE !,LRREC_" "
+14 SET LRTRIEN=$PIECE(LRREC,U)
+15 DO CMP
+16 if LRERR
QUIT
+17 IF LRCHG
DO CHGNM
+18 IF LRADD
DO GNDE
+19 IF $SELECT($GET(LROUT(42,"DIERR")):0,$GET(LROUT(45,"DIERR")):0,1:1)
DO KREC
+20 KILL LROUT
End DoDot:1
+21 SET $PIECE(^LAM(0),U,3)=99999
SET LRVR=$TEXT(+2)
+22 SET ^LAM("VR")=LRVR
+23 FOR I=64.061,64.2,64.21,64.22,64.3
IF $DATA(^LAB(I,0))#2
SET ^("VR")=LRVR
+24 if '$GET(LRDEBUG)
DO MAIL
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
+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
+2 SET (LRADD,LRCHG,LRERR)=0
+3 SET LRCODE=$PIECE(LRREC,U,3)
SET LRPROCNM=$PIECE(LRREC,U,2)
+4 SET DIC="^LAM("
SET DIC(0)="MXZ"
SET X=LRCODE
+5 DO ^DIC
+6 IF Y=-1
Begin DoDot:1
+7 IF '$DATA(^LAM("C",LRCODE_" "))
SET LRADD=1
QUIT
+8 IF $DATA(^LAM("C",LRCODE_" "))
Begin DoDot:2
+9 SET LRN=LRN+1
+10 SET ^XTMP("LRNLT642",1,LRN,0)="|"_LRCODE_"|"_LRPROCNM_"|"_"**Duplicate codes**"
+11 SET LRERR=1
End DoDot:2
End DoDot:1
+12 ;COMPARE THE NAME IN BOTH FILES
IF Y>0
Begin DoDot:1
+13 SET LRFNAM=$PIECE(Y(0),U)
+14 IF LRPROCNM=LRFNAM
SET (LRADD,LRCHG)=0
QUIT
+15 IF LRPROCNM'=LRFNAM
SET LRCHG=+Y
End DoDot:1
+16 ;I LRADD!LRCHG W !,"ADD=",LRADD," CHG=",LRCHG
+17 QUIT
SCR(LRMSG) ;Store message in ^XTMP("LRNLT" Global
+1 SET LRSCR=$GET(^XTMP("LRNLT",$JOB,1,0))+1
SET ^(0)=LRSCR
+2 SET ^XTMP("LRNLT",$JOB,1,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(LRDEBUG)
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=LRN+1
+2 SET ^XTMP("LRNLT642",1,LRN,0)="|"_LRTRIEN_"|"_LRCODE_"|"_LRPROCNM_"|"
+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 LRERR=1
+7 KILL LRENODE
+8 QUIT
KREC ; DELETES THE RECORD FROM THE FILE
+1 if $GET(LRDEBUG)
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
MAIL ;Send message to G.LMI local mail group of added 64 codes
+1 NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY,LRIEN,LRN
NEWLST ;Build list of added WKLD CODES
+1 Begin DoDot:1
+2 DO BMES^XPDUTL($$CJ^XLFSTR("Building List Of Added WKLD CODEs",80))
+3 NEW LRN,LRIEN,LRSTR,LRCNT
+4 SET LRCNT=0
+5 SET LRN="^LAM(""B"")"
if '$GET(LRLAST64)
SET LRLAST64=3203
+6 FOR
SET LRN=$QUERY(@LRN)
if $QSUBSCRIPT(LRN,1)'="B"
QUIT
IF '@LRN
Begin DoDot:2
+7 SET LRIEN=$QSUBSCRIPT(LRN,3)
+8 IF LRIEN>LRLAST64
IF LRIEN<99999
IF $DATA(^LAM(LRIEN,0))#2
SET LRSTR=$PIECE(^(0),U,1,2)
Begin DoDot:3
+9 SET LRCNT=$GET(LRCNT)+1
+10 SET LRSTR=LRCNT_"|"_$TRANSLATE(LRSTR,"^","|")_"|IEN= "_LRIEN
+11 DO SCR(LRSTR)
End DoDot:3
End DoDot:2
+12 DO BMES^XPDUTL($$CJ^XLFSTR("List Of Added WKLD CODEs Complete",80))
End DoDot:1
+13 KILL LRLAST64
+14 IF '$ORDER(^XTMP("LRNLT",$JOB,1,3))
Begin DoDot:1
+15 IF '$GET(LRPRT)
Begin DoDot:2
+16 DO SCR("No WKLD CODES Added to Database")
End DoDot:2
End DoDot:1
+17 DO BMES^XPDUTL($$CJ^XLFSTR("Sending message to LMI Mail Group.",80))
+18 SET XMSUB="ADDED WKLD CODE REPORT "_$$FMTE^XLFDT($$NOW^XLFDT,"1S")
+19 SET XMY("G.LMI")=""
SET XMTEXT="^XTMP(""LRNLT"","_$JOB_",1,"
SET XMDUZ=.5
+20 DO ^XMD
CHK642 ;Looking for locally added suffix
+1 KILL DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
+2 NEW LRSC,LRCNT,LRNX,LRI
+3 SET LRSC=""
SET LRCNT=0
+4 FOR
SET LRCNT=$ORDER(^XTMP("LRNLT642",1,LRCNT))
if LRCNT<1
QUIT
KILL ^XTMP("LRNLT642",1,LRCNT,1)
+5 SET LRNX="^XTMP(""LRNLT642"",1,""C"")"
+6 FOR
SET LRNX=$QUERY(@LRNX)
if $QSUBSCRIPT(LRNX,3)'="C"
QUIT
Begin DoDot:1
+7 IF $DATA(^LAB(64.2,"C",$QSUBSCRIPT(LRNX,4)))
Begin DoDot:2
+8 KILL ^XTMP("LRNLT642",1,$QSUBSCRIPT(LRNX,5))
End DoDot:2
QUIT
+9 if $GET(LRDBUG)
WRITE !,LRNX
End DoDot:1
+10 FOR LRI="AC","B","C","D","E","F"
KILL ^XTMP("LRNLT642",1,LRI)
MES642 ;
+1 IF '$ORDER(^XTMP("LRNLT642",1,0))
KILL ^XTMP("LRNLT642")
QUIT
+2 SET XMSUB=$TRANSLATE($PIECE($$SITE^VASITE,U,1,2),U,"|")_" LR 258 - 64 2 "_DT
+3 SET XMY("G.LMI@ISC-DALLAS")=""
+4 SET XMTEXT="^XTMP(""LRNLT642"",1,"
SET XMDUZ=.5
+5 DO ^XMD
+6 QUIT
