LR334PO ;DALOI/FHS/RSH - LR*5.2*334 PATCH POST INSTALL ROUTINE;31-AUG-2001
;;5.2;LAB SERVICE;**334**;Sep 27, 1994;Build 12
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)
VENDOR ;Save the vender pointer name into the VENDOR field.
N LRI,LRVEN
S LRI=0 F S LRI=$O(^LAB(64.2,LRI)) Q:LRI<1 S LRVEN=$P($G(^(LRI,0)),U,14) I LRVEN D
. S LRVEN=$P($G(^LAB(64.3,+LRVEN,0)),U)
. I $L(LRVEN) S $P(^LAB(64.2,LRI,2),U,2)=LRVEN
I '$D(^XTMP("LRNLT642")) D
. N LRLAST
. S LRLAST=$O(^LAB(64.2,99999),-1)
. S ^XTMP("LRNLT642",.01)=LRLAST
. S ^XTMP("LRNLT642",0)=$$HTFM^XLFDT($H+90,1)_"^"_DT_"^ LAB(64.2 Save"
. M ^XTMP("LRNLT642",1)=^LAB(64.2)
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
. S DIK="^LAM(" D IXALL^DIK
. S $P(^LAM(0),U,3)=99999
K ^XTMP("LRNLTERR","LR334") S ^XTMP("LRNLTERR",0)=$$HTFM^XLFDT($H+90,1)_"^"_DT_"^LR52 334 Error Messages"
K ^XTMP("LRNLT","LR334")
S ^XTMP("LRNLT",0)=$$HTFM^XLFDT($H+90,1)_"^"_DT_"^LR52 334 Messages"
N DA,DIK,LRIEN,LRN0,LRN1,LRFILE
D POST,ALERT^LR334POA
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
POST ;TRANSPORT FILE 64.81 INTO FILE 64 IF REQUIRED
N LRREC,LRREC9
K ^XTMP("LRNLT","LR334") D
. S ^XTMP("LRNLT",0)=$$HTFM^XLFDT($H+90,1)_U_DT_U_"LR334 Added NLT Codes List"
. S ^XTMP("LRNLT","LR334",0)=""
;D DSS W !
P1 F L +^LAM:10 Q:$T D BMES^LR334("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) MAIL^LR334POA
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,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","LR334",1,0))+1,^(0)=LRSCR
S ^XTMP("LRNLT","LR334",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^LR334("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[HLR334PO 8285 printed Dec 13, 2024@02:03:52 Page 2
LR334PO ;DALOI/FHS/RSH - LR*5.2*334 PATCH POST INSTALL ROUTINE;31-AUG-2001
+1 ;;5.2;LAB SERVICE;**334**;Sep 27, 1994;Build 12
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
VENDOR ;Save the vender pointer name into the VENDOR field.
+1 NEW LRI,LRVEN
+2 SET LRI=0
FOR
SET LRI=$ORDER(^LAB(64.2,LRI))
if LRI<1
QUIT
SET LRVEN=$PIECE($GET(^(LRI,0)),U,14)
IF LRVEN
Begin DoDot:1
+3 SET LRVEN=$PIECE($GET(^LAB(64.3,+LRVEN,0)),U)
+4 IF $LENGTH(LRVEN)
SET $PIECE(^LAB(64.2,LRI,2),U,2)=LRVEN
End DoDot:1
+5 IF '$DATA(^XTMP("LRNLT642"))
Begin DoDot:1
+6 NEW LRLAST
+7 SET LRLAST=$ORDER(^LAB(64.2,99999),-1)
+8 SET ^XTMP("LRNLT642",.01)=LRLAST
+9 SET ^XTMP("LRNLT642",0)=$$HTFM^XLFDT($HOROLOG+90,1)_"^"_DT_"^ LAB(64.2 Save"
+10 MERGE ^XTMP("LRNLT642",1)=^LAB(64.2)
End DoDot:1
+11 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:999
IF '$TEST
GOTO EN1
+2 Begin DoDot:1
+3 NEW DIK
+4 SET DIK="^LAM("
DO IXALL^DIK
+5 SET $PIECE(^LAM(0),U,3)=99999
End DoDot:1
+6 KILL ^XTMP("LRNLTERR","LR334")
SET ^XTMP("LRNLTERR",0)=$$HTFM^XLFDT($HOROLOG+90,1)_"^"_DT_"^LR52 334 Error Messages"
+7 KILL ^XTMP("LRNLT","LR334")
+8 SET ^XTMP("LRNLT",0)=$$HTFM^XLFDT($HOROLOG+90,1)_"^"_DT_"^LR52 334 Messages"
+9 NEW DA,DIK,LRIEN,LRN0,LRN1,LRFILE
+10 DO POST
DO ALERT^LR334POA
+11 QUIT
+12 ;
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
POST ;TRANSPORT FILE 64.81 INTO FILE 64 IF REQUIRED
+1 NEW LRREC,LRREC9
+2 KILL ^XTMP("LRNLT","LR334")
Begin DoDot:1
+3 SET ^XTMP("LRNLT",0)=$$HTFM^XLFDT($HOROLOG+90,1)_U_DT_U_"LR334 Added NLT Codes List"
+4 SET ^XTMP("LRNLT","LR334",0)=""
End DoDot:1
+5 ;D DSS W !
P1 FOR
LOCK +^LAM:10
if $TEST
QUIT
DO BMES^LR334("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)
DO MAIL^LR334POA
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,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","LR334",1,0))+1
SET ^(0)=LRSCR
+2 SET ^XTMP("LRNLT","LR334",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 DO BMES^LR334("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 DO BMES^LR334("Update DSS AP Feeder Key Complete")
+19 QUIT
