LRSRVR9B ;BPFO/DTG - UPDATE DATA FOR 61, 61.2, AND 62 FOR SNOMED AND INACTIVE ;07/7/2017
;;5.2;LAB SERVICE;**495**;Sep 27, 1994;Build 6
;
Q
;
SERVER ; entry for message processing
N I,D,LRCNT,LREND,LRL,LRMSUBJ,LRTXT,LRX,LRY,FIL,CR,XMZ,XMPOS,XMER,XMRG,XMCHAN,LRCRLF
N ZTQUEUED,DR,DIE,DTOUT,DROUT,II,LRTEXT,LRVRD4,LRVRD5,LRVRD6,LRSTR,CR,FIL
N A,B,C,E,G,L,LRINSTR,DN,LRGOOD
;
S CR=$C(13),FIL=$P(LRSUB," ",2,999),FIL=$$UP^XLFSTR(FIL),U="^",LRCRLF=$C(13,10),D=""
K ^TMP($J,"LRDATA")
; header of message text
;Station #-File #-IEN|Entry Name|SNOMED I|SNOMED CT|STS_EXCEPTION|STS_EXCEPTION_REASON|TRANSACTION NUMBER|
;get message from XMB(3.9)
S XMZ=XQMSG,D=0,XMCHAN="SERVER" K XMER
S LRVRD4="^TMP(""LRREAD-ERR"",$J)" K @LRVRD4
S LRVRD5="^TMP(""LRREAD"",$J)" K @LRVRD5
S LRVRD6="^TMP(""LRREAD-RAW"",$J)" K @LRVRD6
SLI ; start
S K=0,(L,M,N,O)="",STRT=$$NOW^XLFDT
; get inbound message and now get the the start lines
D GET^XML
F X XMREC Q:($D(XMER)&($G(XMER)<0)) I XMRG["base64" Q
I $D(XMER)&($G(XMER)<0) G SL5Q
S OK=0 F X XMREC Q:($D(XMER)&($G(XMER)<0)) D I OK=1 Q
. S A=XMRG,B=$$B64DECD^XUSHSH(A)
. I $E(B,1,32)="Station #-File #-IEN|Entry Name|" S OK=1
I $D(XMER)&($G(XMER)<0) G SL5Q
I OK'=1 G SL5Q
I $E(B,1,32)="Station #-File #-IEN|Entry Name|" D
. S N=$L(B,CR),I=1
. D SL5S3(I,B)
SL5 ; loop through message
X XMREC
I $D(XMER) G SL5Q:XMER<0
I XMRG="" G SL5
I $E(XMRG,1,6)="--_004"&($E(XMRG,($L(XMRG)-1),($L(XMRG)))="--") G SL5Q
S B=$$B64DECD^XUSHSH(XMRG),N=$L(B,CR) F I=1:1:N D SL5S3(I,B)
G SL5
;
SL5S3(II,BB) ; set finish file
; II where in for loop
; NN number of CR pieces
; KK update counter
; BB data
; saved data
N P
S P=$P(BB,CR,II)
S:$E(P,1)=$C(10) P=$E(P,2,9999)
I II=1 S O=O_P
I II>1 S K=K+1,@LRVRD6@(K,0)=O,O=P
Q
;
;
SL5Q ;finish pulling message
S DN=$$NOW^XLFDT
S @LRVRD6@(0)=K_U_STRT_U_DN
;remove items from raw that are not for this facility
S (A,B,C,D,E,G,LRGOOD)=0
F S A=$O(@LRVRD6@(A)) Q:'A D
. S B=$G(@LRVRD6@(A,0))
. I B="" Q
. I LRST'=$P(B,"-",1)&($P(B,"-",1)'["Station") D Q
. . ; save bad entry to send back to sender
. . S C=$G(@LRVRD4@(0)),C=C+1,@LRVRD4@(0)=C,@LRVRD4@(C,0)=B
. ; save into file for placing into LRMAP file
. S D=$G(@LRVRD5@(0)),D=D+1,@LRVRD5@(0)=D,@LRVRD5@(D,0)=B,LRGOOD=D
;
; make sure there is one entry to place in 95.4 via LRMAP
S A=$G(@LRVRD5@(1,0)) I A="" G CLOSE
;
; run purge of 95.4
N LRDAYS,LRDATE,LRSTAT
;
S LRDAYS=0
S LRDATE=$$FMADD^XLFDT(DT,-LRDAYS,0,0,0)
F LRSTAT=0,.5,.7,1,2 D PURGE^LRSRVR5(LRSTAT,LRDATE)
K LRDAYS,LRDATE,LRSTAT
;
; save into LAB TEMP FILE
K ^TMP($J,"LRMAP") M ^TMP($J,"LRMAP")=@LRVRD5 K ^TMP($J,"LRMAP",0)
S LRTYPE=2,LRTYPE(0)="SCT",ZTQUEUED=1
;
D IMPORT^LRSRVR8(LRTYPE) ; Process file from TMP global into file #95.4
K ZTQUEUED
;
; send message to G.LMI
S (LRMAILGROUP,LRMAILGROUPXQA)="G.LMI"
S XMSUB="SITE: "_LRST_" "_LRSTN_" SNOMED UPDATE READY FOR PROCESSING "_DT
S XMY(DUZ)="",XMY("G.LMI")=""
K LRTEXT S LRTEXT(1)="The SNOMED update for files 61, 61.2, and 62 has been placed on your system"
S LRTEXT(2)="and is ready for processing."
S LRTEXT(3)="Use option [ LA7S LOAD MAPPING SCT ] to apply the update."
S LRTEXT(4)="Select Item '2 Process previous loaded file'"
S LRTEXT(4)=""
S XMTEXT="LRTEXT(" D ^XMD
K LRTEXT,XMTEXT
;
; send return message to sender
;
CLOSE ;
S LRMSUBJ=LRST_" "_LRSTN_" SCTLOAD "_$$HTE^XLFDT($H,"1M")
S LRRECORD=K
S ^TMP($J,"LRDATA",6)="Total Number of Records: "_$J((LRRECORD-1),($L(LRRECORD)+1))
S A=$$FMTE^XLFDT($P($G(@LRVRD6@(0)),U,3))
S ^TMP($J,"LRDATA",7)="End Date..: "_$J(A,($L(A)+1))
S ^TMP($J,"LRDATA",8)="Message Number: "_$J(XQMSG,($L(XQMSG)+1))
S A=$G(@LRVRD4@(0))+0
S ^TMP($J,"LRDATA",10)="Total Number of Records rejected Due to Station Number: "_$J(A,($L(A)+1))
S A=$G(LRGOOD)+0
S ^TMP($J,"LRDATA",11)="Total Number of Records accepted for processing by the site: "_$J(A,($L(A)+1))
S ^TMP($J,"LRDATA",12)=" "
S A=$$FMTE^XLFDT($$NOW^XLFDT)_" at "_LRSTN
S ^TMP($J,"LRDATA",1)="File Uploaded.......: "_$J(A,($L(A)+1))
S ^TMP($J,"LRDATA",2)="File Received.......: "_$J(LRSUB,($L(LRSUB)+1))
S A=$P($G(@LRVRD6@(2,0)),"|",1)
S ^TMP($J,"LRDATA",3)="First Record..........: "_$J(A,($L(A)+1))
S A=$P($G(@LRVRD6@(LRRECORD,0)),"|",1)
S ^TMP($J,"LRDATA",4)="Last Record.....: "_$J(A,($L(A)+1))
S A=$$FMTE^XLFDT($P($G(@LRVRD6@(0)),U,2))
S ^TMP($J,"LRDATA",5)="Start Date........: "_$J(A,($L(A)+1))
S LRFILENM=$TR(LRSTN," ","_")_"-("_LRST_")-"_$P(LRSUB," ",1)_"-"_$P($$FMTHL7^XLFDT($$NOW^XLFDT),"-")_".TXT"
S ^TMP($J,"LRDATA",13)="Attached LMOF file.....: "_$J(LRFILENM,($L(LRFILENM)+1))
F I=14:1:16 S ^TMP($J,"LRDATA",I)=" "
S ^TMP($J,"LRDATA",17)="begin 644 "_LRFILENM
S LRSTR=""
; include e-mail statements into attachment
;F I=1:1:12 S A=$G(^TMP($J,"LRDATA",I)) S LRSTR=LRSTR D SETDATA
; check for errors
S A=$G(@LRVRD4@(0)) I +A<1 D G CLOSE1
. S LRSTR=LRSTR_"No Errors Encountered with Station Number"_LRCRLF D SETDATA
. I LRSTR'="" S LRNODE=LRNODE+1,^TMP($J,"LRDATA",LRNODE)=$$UUEN(LRSTR)
. S ^TMP($J,"LRDATA",LRNODE+1)=" "
. S ^TMP($J,"LRDATA",LRNODE+2)="end"
;
; loop through errors and place in file
S ^TMP($J,"LRDATA",14)="Legend:"
S A="Station #-File #-IEN|Entry Name|SNOMED I|SNOMED CT|STS_EXCEPTION|STS_EXCEPTION_REASON|TRANSACTION NUMBER|"
S ^TMP($J,"LRDATA",15)=A
S ^TMP($J,"LRDATA",16)=$$REPEAT^XLFSTR("-",($L(A)))
S A=0
F S A=$O(@LRVRD4@(A)) Q:'A S B=$G(@LRVRD4@(A,0)) S LRSTR=LRSTR_B_LRCRLF D SETDATA
I LRSTR'="" S LRNODE=LRNODE+1,^TMP($J,"LRDATA",LRNODE)=$$UUEN(LRSTR)
S ^TMP($J,"LRDATA",LRNODE+1)=" "
S ^TMP($J,"LRDATA",LRNODE+2)="end"
G CLOSE1
;
CLOSE1 ; send message back to sender
S LRTO(XQSND)=""
S LRINSTR("ADDR FLAGS")="R"
S LRINSTR("FROM")="LAB_PACKAGE"
S LRMSUBJ=$E(LRMSUBJ,1,65)
D SENDMSG^XMXAPI(.5,LRMSUBJ,"^TMP($J,""LRDATA"")",.LRTO,.LRINSTR,.LRTASK)
Q
;
CLEAN ;
K @LRVRD4,@LRVRD5,@LRVRD6
K I,D,LRCNT,LREND,LRL,LRMSUBJ,LRTXT,LRX,LRY,FIL,CR,XMZ,XMPOS,XMER,XMRG,XMCHAN
K ZTQUEUED,DR,DIE,DTOUT,DROUT,II,LRTEXT,LRVRD4,LRVRD5,LRVRD6,LRSTR,CR,FIL,LRCRLF
K A,B,C,E,G,L,LRINSTR,DN,LRGOOD
D CLEAN^LRSRVR
D ^%ZISC
Q
;
SETDATA ; Set error data into report structure
S LRNODE=$O(^TMP($J,"LRDATA",""),-1)
S LRQUIT=0,LRLEN=$L(LRSTR)
F D Q:LRQUIT
. I $L(LRSTR)<45 S LRQUIT=1 Q
. S LRX=$E(LRSTR,1,45)
. S LRNODE=LRNODE+1,^TMP($J,"LRDATA",LRNODE)=$$UUEN(LRX)
. S LRSTR=$E(LRSTR,46,LRLEN)
Q
;
UUEN(STR) ; Uuencode string passed in.
N J,K,LEN,LRI,LRX,S,TMP,X,Y
S TMP="",LEN=$L(STR)
F LRI=1:3:LEN D
. S LRX=$E(STR,LRI,LRI+2)
. I $L(LRX)<3 S LRX=LRX_$E(" ",1,3-$L(LRX))
. S S=$A(LRX,1)*256+$A(LRX,2)*256+$A(LRX,3),Y=""
. F K=0:1:23 S Y=(S\(2**K)#2)_Y
. F K=1:6:24 D
. . S J=$$DEC^XLFUTL($E(Y,K,K+5),2)
. . S TMP=TMP_$C(J+32)
S TMP=$C(LEN+32)_TMP
Q TMP
;
UUBEGFN(LRFILENM) ; Construct uuencode "begin" coding
; Call with LRFILENM = name of uuencoded file attachment
;
; Returns LRX = string with "begin..."_file name
;
N LRX
S LRX="begin 644 "_LRFILENM
Q LRX
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSRVR9B 7171 printed Dec 13, 2024@02:20:58 Page 2
LRSRVR9B ;BPFO/DTG - UPDATE DATA FOR 61, 61.2, AND 62 FOR SNOMED AND INACTIVE ;07/7/2017
+1 ;;5.2;LAB SERVICE;**495**;Sep 27, 1994;Build 6
+2 ;
+3 QUIT
+4 ;
SERVER ; entry for message processing
+1 NEW I,D,LRCNT,LREND,LRL,LRMSUBJ,LRTXT,LRX,LRY,FIL,CR,XMZ,XMPOS,XMER,XMRG,XMCHAN,LRCRLF
+2 NEW ZTQUEUED,DR,DIE,DTOUT,DROUT,II,LRTEXT,LRVRD4,LRVRD5,LRVRD6,LRSTR,CR,FIL
+3 NEW A,B,C,E,G,L,LRINSTR,DN,LRGOOD
+4 ;
+5 SET CR=$CHAR(13)
SET FIL=$PIECE(LRSUB," ",2,999)
SET FIL=$$UP^XLFSTR(FIL)
SET U="^"
SET LRCRLF=$CHAR(13,10)
SET D=""
+6 KILL ^TMP($JOB,"LRDATA")
+7 ; header of message text
+8 ;Station #-File #-IEN|Entry Name|SNOMED I|SNOMED CT|STS_EXCEPTION|STS_EXCEPTION_REASON|TRANSACTION NUMBER|
+9 ;get message from XMB(3.9)
+10 SET XMZ=XQMSG
SET D=0
SET XMCHAN="SERVER"
KILL XMER
+11 SET LRVRD4="^TMP(""LRREAD-ERR"",$J)"
KILL @LRVRD4
+12 SET LRVRD5="^TMP(""LRREAD"",$J)"
KILL @LRVRD5
+13 SET LRVRD6="^TMP(""LRREAD-RAW"",$J)"
KILL @LRVRD6
SLI ; start
+1 SET K=0
SET (L,M,N,O)=""
SET STRT=$$NOW^XLFDT
+2 ; get inbound message and now get the the start lines
+3 DO GET^XML
+4 FOR
XECUTE XMREC
if ($DATA(XMER)&($GET(XMER)<0))
QUIT
IF XMRG["base64"
QUIT
+5 IF $DATA(XMER)&($GET(XMER)<0)
GOTO SL5Q
+6 SET OK=0
FOR
XECUTE XMREC
if ($DATA(XMER)&($GET(XMER)<0))
QUIT
Begin DoDot:1
+7 SET A=XMRG
SET B=$$B64DECD^XUSHSH(A)
+8 IF $EXTRACT(B,1,32)="Station #-File #-IEN|Entry Name|"
SET OK=1
End DoDot:1
IF OK=1
QUIT
+9 IF $DATA(XMER)&($GET(XMER)<0)
GOTO SL5Q
+10 IF OK'=1
GOTO SL5Q
+11 IF $EXTRACT(B,1,32)="Station #-File #-IEN|Entry Name|"
Begin DoDot:1
+12 SET N=$LENGTH(B,CR)
SET I=1
+13 DO SL5S3(I,B)
End DoDot:1
SL5 ; loop through message
+1 XECUTE XMREC
+2 IF $DATA(XMER)
if XMER<0
GOTO SL5Q
+3 IF XMRG=""
GOTO SL5
+4 IF $EXTRACT(XMRG,1,6)="--_004"&($EXTRACT(XMRG,($LENGTH(XMRG)-1),($LENGTH(XMRG)))="--")
GOTO SL5Q
+5 SET B=$$B64DECD^XUSHSH(XMRG)
SET N=$LENGTH(B,CR)
FOR I=1:1:N
DO SL5S3(I,B)
+6 GOTO SL5
+7 ;
SL5S3(II,BB) ; set finish file
+1 ; II where in for loop
+2 ; NN number of CR pieces
+3 ; KK update counter
+4 ; BB data
+5 ; saved data
+6 NEW P
+7 SET P=$PIECE(BB,CR,II)
+8 if $EXTRACT(P,1)=$CHAR(10)
SET P=$EXTRACT(P,2,9999)
+9 IF II=1
SET O=O_P
+10 IF II>1
SET K=K+1
SET @LRVRD6@(K,0)=O
SET O=P
+11 QUIT
+12 ;
+13 ;
SL5Q ;finish pulling message
+1 SET DN=$$NOW^XLFDT
+2 SET @LRVRD6@(0)=K_U_STRT_U_DN
+3 ;remove items from raw that are not for this facility
+4 SET (A,B,C,D,E,G,LRGOOD)=0
+5 FOR
SET A=$ORDER(@LRVRD6@(A))
if 'A
QUIT
Begin DoDot:1
+6 SET B=$GET(@LRVRD6@(A,0))
+7 IF B=""
QUIT
+8 IF LRST'=$PIECE(B,"-",1)&($PIECE(B,"-",1)'["Station")
Begin DoDot:2
+9 ; save bad entry to send back to sender
+10 SET C=$GET(@LRVRD4@(0))
SET C=C+1
SET @LRVRD4@(0)=C
SET @LRVRD4@(C,0)=B
End DoDot:2
QUIT
+11 ; save into file for placing into LRMAP file
+12 SET D=$GET(@LRVRD5@(0))
SET D=D+1
SET @LRVRD5@(0)=D
SET @LRVRD5@(D,0)=B
SET LRGOOD=D
End DoDot:1
+13 ;
+14 ; make sure there is one entry to place in 95.4 via LRMAP
+15 SET A=$GET(@LRVRD5@(1,0))
IF A=""
GOTO CLOSE
+16 ;
+17 ; run purge of 95.4
+18 NEW LRDAYS,LRDATE,LRSTAT
+19 ;
+20 SET LRDAYS=0
+21 SET LRDATE=$$FMADD^XLFDT(DT,-LRDAYS,0,0,0)
+22 FOR LRSTAT=0,.5,.7,1,2
DO PURGE^LRSRVR5(LRSTAT,LRDATE)
+23 KILL LRDAYS,LRDATE,LRSTAT
+24 ;
+25 ; save into LAB TEMP FILE
+26 KILL ^TMP($JOB,"LRMAP")
MERGE ^TMP($JOB,"LRMAP")=@LRVRD5
KILL ^TMP($JOB,"LRMAP",0)
+27 SET LRTYPE=2
SET LRTYPE(0)="SCT"
SET ZTQUEUED=1
+28 ;
+29 ; Process file from TMP global into file #95.4
DO IMPORT^LRSRVR8(LRTYPE)
+30 KILL ZTQUEUED
+31 ;
+32 ; send message to G.LMI
+33 SET (LRMAILGROUP,LRMAILGROUPXQA)="G.LMI"
+34 SET XMSUB="SITE: "_LRST_" "_LRSTN_" SNOMED UPDATE READY FOR PROCESSING "_DT
+35 SET XMY(DUZ)=""
SET XMY("G.LMI")=""
+36 KILL LRTEXT
SET LRTEXT(1)="The SNOMED update for files 61, 61.2, and 62 has been placed on your system"
+37 SET LRTEXT(2)="and is ready for processing."
+38 SET LRTEXT(3)="Use option [ LA7S LOAD MAPPING SCT ] to apply the update."
+39 SET LRTEXT(4)="Select Item '2 Process previous loaded file'"
+40 SET LRTEXT(4)=""
+41 SET XMTEXT="LRTEXT("
DO ^XMD
+42 KILL LRTEXT,XMTEXT
+43 ;
+44 ; send return message to sender
+45 ;
CLOSE ;
+1 SET LRMSUBJ=LRST_" "_LRSTN_" SCTLOAD "_$$HTE^XLFDT($HOROLOG,"1M")
+2 SET LRRECORD=K
+3 SET ^TMP($JOB,"LRDATA",6)="Total Number of Records: "_$JUSTIFY((LRRECORD-1),($LENGTH(LRRECORD)+1))
+4 SET A=$$FMTE^XLFDT($PIECE($GET(@LRVRD6@(0)),U,3))
+5 SET ^TMP($JOB,"LRDATA",7)="End Date..: "_$JUSTIFY(A,($LENGTH(A)+1))
+6 SET ^TMP($JOB,"LRDATA",8)="Message Number: "_$JUSTIFY(XQMSG,($LENGTH(XQMSG)+1))
+7 SET A=$GET(@LRVRD4@(0))+0
+8 SET ^TMP($JOB,"LRDATA",10)="Total Number of Records rejected Due to Station Number: "_$JUSTIFY(A,($LENGTH(A)+1))
+9 SET A=$GET(LRGOOD)+0
+10 SET ^TMP($JOB,"LRDATA",11)="Total Number of Records accepted for processing by the site: "_$JUSTIFY(A,($LENGTH(A)+1))
+11 SET ^TMP($JOB,"LRDATA",12)=" "
+12 SET A=$$FMTE^XLFDT($$NOW^XLFDT)_" at "_LRSTN
+13 SET ^TMP($JOB,"LRDATA",1)="File Uploaded.......: "_$JUSTIFY(A,($LENGTH(A)+1))
+14 SET ^TMP($JOB,"LRDATA",2)="File Received.......: "_$JUSTIFY(LRSUB,($LENGTH(LRSUB)+1))
+15 SET A=$PIECE($GET(@LRVRD6@(2,0)),"|",1)
+16 SET ^TMP($JOB,"LRDATA",3)="First Record..........: "_$JUSTIFY(A,($LENGTH(A)+1))
+17 SET A=$PIECE($GET(@LRVRD6@(LRRECORD,0)),"|",1)
+18 SET ^TMP($JOB,"LRDATA",4)="Last Record.....: "_$JUSTIFY(A,($LENGTH(A)+1))
+19 SET A=$$FMTE^XLFDT($PIECE($GET(@LRVRD6@(0)),U,2))
+20 SET ^TMP($JOB,"LRDATA",5)="Start Date........: "_$JUSTIFY(A,($LENGTH(A)+1))
+21 SET LRFILENM=$TRANSLATE(LRSTN," ","_")_"-("_LRST_")-"_$PIECE(LRSUB," ",1)_"-"_$PIECE($$FMTHL7^XLFDT($$NOW^XLFDT),"-")_".TXT"
+22 SET ^TMP($JOB,"LRDATA",13)="Attached LMOF file.....: "_$JUSTIFY(LRFILENM,($LENGTH(LRFILENM)+1))
+23 FOR I=14:1:16
SET ^TMP($JOB,"LRDATA",I)=" "
+24 SET ^TMP($JOB,"LRDATA",17)="begin 644 "_LRFILENM
+25 SET LRSTR=""
+26 ; include e-mail statements into attachment
+27 ;F I=1:1:12 S A=$G(^TMP($J,"LRDATA",I)) S LRSTR=LRSTR D SETDATA
+28 ; check for errors
+29 SET A=$GET(@LRVRD4@(0))
IF +A<1
Begin DoDot:1
+30 SET LRSTR=LRSTR_"No Errors Encountered with Station Number"_LRCRLF
DO SETDATA
+31 IF LRSTR'=""
SET LRNODE=LRNODE+1
SET ^TMP($JOB,"LRDATA",LRNODE)=$$UUEN(LRSTR)
+32 SET ^TMP($JOB,"LRDATA",LRNODE+1)=" "
+33 SET ^TMP($JOB,"LRDATA",LRNODE+2)="end"
End DoDot:1
GOTO CLOSE1
+34 ;
+35 ; loop through errors and place in file
+36 SET ^TMP($JOB,"LRDATA",14)="Legend:"
+37 SET A="Station #-File #-IEN|Entry Name|SNOMED I|SNOMED CT|STS_EXCEPTION|STS_EXCEPTION_REASON|TRANSACTION NUMBER|"
+38 SET ^TMP($JOB,"LRDATA",15)=A
+39 SET ^TMP($JOB,"LRDATA",16)=$$REPEAT^XLFSTR("-",($LENGTH(A)))
+40 SET A=0
+41 FOR
SET A=$ORDER(@LRVRD4@(A))
if 'A
QUIT
SET B=$GET(@LRVRD4@(A,0))
SET LRSTR=LRSTR_B_LRCRLF
DO SETDATA
+42 IF LRSTR'=""
SET LRNODE=LRNODE+1
SET ^TMP($JOB,"LRDATA",LRNODE)=$$UUEN(LRSTR)
+43 SET ^TMP($JOB,"LRDATA",LRNODE+1)=" "
+44 SET ^TMP($JOB,"LRDATA",LRNODE+2)="end"
+45 GOTO CLOSE1
+46 ;
CLOSE1 ; send message back to sender
+1 SET LRTO(XQSND)=""
+2 SET LRINSTR("ADDR FLAGS")="R"
+3 SET LRINSTR("FROM")="LAB_PACKAGE"
+4 SET LRMSUBJ=$EXTRACT(LRMSUBJ,1,65)
+5 DO SENDMSG^XMXAPI(.5,LRMSUBJ,"^TMP($J,""LRDATA"")",.LRTO,.LRINSTR,.LRTASK)
+6 QUIT
+7 ;
CLEAN ;
+1 KILL @LRVRD4,@LRVRD5,@LRVRD6
+2 KILL I,D,LRCNT,LREND,LRL,LRMSUBJ,LRTXT,LRX,LRY,FIL,CR,XMZ,XMPOS,XMER,XMRG,XMCHAN
+3 KILL ZTQUEUED,DR,DIE,DTOUT,DROUT,II,LRTEXT,LRVRD4,LRVRD5,LRVRD6,LRSTR,CR,FIL,LRCRLF
+4 KILL A,B,C,E,G,L,LRINSTR,DN,LRGOOD
+5 DO CLEAN^LRSRVR
+6 DO ^%ZISC
+7 QUIT
+8 ;
SETDATA ; Set error data into report structure
+1 SET LRNODE=$ORDER(^TMP($JOB,"LRDATA",""),-1)
+2 SET LRQUIT=0
SET LRLEN=$LENGTH(LRSTR)
+3 FOR
Begin DoDot:1
+4 IF $LENGTH(LRSTR)<45
SET LRQUIT=1
QUIT
+5 SET LRX=$EXTRACT(LRSTR,1,45)
+6 SET LRNODE=LRNODE+1
SET ^TMP($JOB,"LRDATA",LRNODE)=$$UUEN(LRX)
+7 SET LRSTR=$EXTRACT(LRSTR,46,LRLEN)
End DoDot:1
if LRQUIT
QUIT
+8 QUIT
+9 ;
UUEN(STR) ; Uuencode string passed in.
+1 NEW J,K,LEN,LRI,LRX,S,TMP,X,Y
+2 SET TMP=""
SET LEN=$LENGTH(STR)
+3 FOR LRI=1:3:LEN
Begin DoDot:1
+4 SET LRX=$EXTRACT(STR,LRI,LRI+2)
+5 IF $LENGTH(LRX)<3
SET LRX=LRX_$EXTRACT(" ",1,3-$LENGTH(LRX))
+6 SET S=$ASCII(LRX,1)*256+$ASCII(LRX,2)*256+$ASCII(LRX,3)
SET Y=""
+7 FOR K=0:1:23
SET Y=(S\(2**K)#2)_Y
+8 FOR K=1:6:24
Begin DoDot:2
+9 SET J=$$DEC^XLFUTL($EXTRACT(Y,K,K+5),2)
+10 SET TMP=TMP_$CHAR(J+32)
End DoDot:2
End DoDot:1
+11 SET TMP=$CHAR(LEN+32)_TMP
+12 QUIT TMP
+13 ;
UUBEGFN(LRFILENM) ; Construct uuencode "begin" coding
+1 ; Call with LRFILENM = name of uuencoded file attachment
+2 ;
+3 ; Returns LRX = string with "begin..."_file name
+4 ;
+5 NEW LRX
+6 SET LRX="begin 644 "_LRFILENM
+7 QUIT LRX
+8 ;
