XUPCZRT ;BPFO/PB - KERNEL - CALLABLE ENTRY POINTS FOR ZRT SEGMENT ; 15 FEBRUARY 2017 12:58 PM
;;8.0;KERNEL;**671**;Jul 10, 1995;Build 16
;
;
Q
ZRT ;Manipulate update of MFN ZRT segment for 8932.1 file
I IEN,((NAME="Term")!(NAME="Status")) K XXIEN ;This is the indication that it's first update for any subfile
;S:$D(HLNODE(1)) HLNODE=HLNODE_HLNODE(1)
G 89321:IFN=8932.1
Q
;
89321 ;Manipulate update of MFN ZRT segment for 8932.1 File
I NAME="Status" K XXIEN Q ;XXIEN01 is the .01 of record without IEN
I NAME="VistA_Textual_Definition" D S OUT=1 Q
.I $P(HLNODE,HLFS,3)="""""" D Q
..S $P(HLNODE,HLFS,3)=""
..;Q ;QUIT here means, we put extra NULL line if WP field deleted. its for VETS-Discovery Functionality testing.
..D WP^DIE(8932.1,IENS,11,"K","@","ERR")
..I $D(ERR) S ERROR="1^Error in delete file: 8932.1 of WP field 11, IENS="_IENS D EM^XUMF1H(ERROR,.ERR) K ERR
..Q
.;WP ;codng from WP^XUMF1H we need to do so because coding there is: D SEGPRSE^XUMFXHL7("HLNODE","X",HLFS,60)
.;
.N X,Y,A,I,CNT,X1,X2,ESC
.D SEGPRSE^XUMFXHL7("HLNODE","X",HLFS)
.S CNT=1
.S A(CNT)=X(2)
.S I=0
.F S I=$O(X(2,I)) Q:'I D
..S Y=X(2,I)
..I $E(Y,1)=" " D Q
...S A(CNT)=A(CNT)_" "
...Q:$P(Y," ",2)=""
...S CNT=CNT+1
...S A(CNT)=$P(Y," ",2,99)
..S X1=$P(Y," ",1)
..S X2=$P(Y," ",2,99)
..S A(CNT)=A(CNT)_X1_$S(X2="":"",1:" ")
..Q:X2=""
..S CNT=CNT+1
..S A(CNT)=X2
.;
.D UNESCWP^XUMF0(.A,.HL)
.;
.D WP^DIE(IFN,IENS,11,"K","A","ERR")
.;
.I $D(ERR) D
..S ERROR="1^wp field error"
..D EM^XUMF1H(ERROR,.ERR) K ERR
.;
.Q
;
S:$D(HLNODE(1)) HLNODE=HLNODE_HLNODE(1)
Q:IEN
I NAME="Term" S XXIEN(.01)=$$UNESC^XUMF0($P(HLNODE,HLFS,3),.HL),OUT=1 Q
I NAME="VistA_VA_Code" S XXIEN(5)=$P(HLNODE,HLFS,3),OUT=1 S:XXIEN(5)="""""" XXIEN(5)="" Q ;Field #5 "F" X-ref
I NAME="VistA_ASC_X12_Code" S XXIEN(6)=$P(HLNODE,HLFS,3),OUT=1 S:XXIEN(6)="""""" XXIEN(6)="" Q ;Field #6 "G" X-REF
D ;Check if all definition fields are included in ZRT segment
.N ERMM
.S:'$D(XXIEN(.01)) ERMM=ERMM_"Term,"
.S:'$D(XXIEN(5)) ERMM=ERMM_",VistA_VA_Code,"
.S:'$D(XXIEN(6)) ERMM=ERMM_",VistA_ASC_X12_Code"
.I $D(ERMM) S ERROR="1^"_ERMM_"^Missing in ZRT Segment"
N I,X5,X6,XX,NEWIEN
S NEWIEN=0
S X5=$S($L(XXIEN(5)):1,1:0) S:'X5 XXIEN(5)=" "
S X6=$S($L(XXIEN(6)):1,1:0) S:'X6 XXIEN(6)=" "
I X5 S I=0 F S I=$O(^USC(8932.1,"F",XXIEN(5),I)) Q:'I S XXIEN(5,I)=""
I X6 S I=0 F S I=$O(^USC(8932.1,"G",XXIEN(6),I)) Q:'I S XXIEN(6,I)=""
I 'X5!('X6) S I=0 F S I=$O(^USC(8932.1,I)) Q:'I S XX=^(I,0) S:'$L($P(XX,U,6))&'X5 XXIEN(5,I)="" S:'$L($P(XX,U,7))&'X6 XXIEN(6,I)=""
S I=0 F S I=$O(XXIEN(5,I)) Q:'I K:'$D(XXIEN(6,I)) XXIEN(5,I)
S I=0 F S I=$O(XXIEN(6,I)) Q:'I K:'$D(XXIEN(5,I)) XXIEN(6,I)
;New entry should be created.
I '$O(XXIEN(5,0))!'$O(XXIEN(6,0)) D NEW,SM1(IEN,1,0) Q ;New entry
;
;So now we have one or multiple results
K XX S I=0 F S I=$O(XXIEN(5,I)) Q:'I S XX(I)=""
S I=0 F S I=$O(XXIEN(6,I)) Q:'I S XX(I)=""
S I=$O(XX(0)) D SM1(I,1,0) K XX(I) ;First IEN Set master to 0 No status set
S IEN=I,IENS=IEN_","
S I=0 F S I=$O(XX(I)) Q:'I D SM1(I,0,1) ;Set master to 0 and status to 0 as well.
;I '$O(XXIEN(5,$O(XXIEN(5,0)))) ; Multiple entries in field 6
;I '$O(XXIEN(5,$O(XXIEN(6,0)))) ; Multiple entries in field 5
Q
NEW ;New entry
N X,DIC,Y
;
S XUMF=1
D CHK^DIE(IFN,.01,,XXIEN(.01),.X,"ERR")
I $D(ERR) S ERROR="1^Error - .01 is invalid"_" File #: "_IFN_" HLNODE="_HLNODE Q
K DIC S DIC=IFN,DIC(0)="F" D FILE^DICN K DIC
I Y="-1" S ERROR="1^Error - stub entry IFN: "_IFN_" failed HLNODE: "_HLNODE Q
S IEN=+Y,RECORD("NEW")=1
S IENS=IEN_","
S NEWIEN=1
Q
SM1(IEN,XY,X0) ;Set master to one/zero and possibly status to 0
;XY=Master Yes/No
;If X0=1 Status set to 0?
N ROOT,IENS,XUMF,X
D CHK^DIE(IFN,.01,,XXIEN(.01),.X,"ERR")
I $D(ERR) S ERROR="1^Error - .01 from VETS is invalid"_" File #: "_IFN_" HLNODE="_HLNODE Q
S IENS=IEN_","
S ROOT=$$ROOT^DILFD(IFN,,1)
M RECORD("BEFORE")=@ROOT@(IEN)
S RECORD("STATUS")=$$GETSTAT^XTID(IFN,,IEN_",")
S FDA(IFN,IENS,.01)=XXIEN(.01) ;Validation??
S FDA(IFN,IENS,5)=$S(XXIEN(5)=" ":"@",1:XXIEN(5))
S FDA(IFN,IENS,6)=$S(XXIEN(6)=" ":"@",1:XXIEN(6))
S FDA(IFN,IENS,99.99)=VUID
S FDA(IFN,IENS,99.98)=XY
N ERR
S XUMF=1
D FILE^DIE("E","FDA","ERR")
I $D(ERR) D Q
.S ERROR="1^VUID update error IFN: "_IFN_" IEN: "_IEN_" VUID: "_VUID_" HLNODE: "_HLNODE
.D EM^XUMF1H(ERROR,.ERR) K ERR
D:X0 ;SET STATUS TO 0
.N FDA,SUBFILE
.S SUBFILE=8932.199
.;I VALUE=$P($$GETSTAT^XTID(IFN,,IEN_","),U) Q
.S FDA(SUBFILE,"?+1,"_IENS,.01)=$$NOW^XLFDT
.S FDA(SUBFILE,"?+1,"_IENS,.02)=0
.D UPDATE^DIE(,"FDA",,"ERR")
.I $D(ERR) D
..S ERROR="1^effective date and status error"
..D EM^XUMF1H(ERROR,.ERR) K ERR
;
;
D ADD^XUMF1H
;
; clean multiple flag
K:'$D(XIEN(IEN)) XIEN
S XIEN(IEN)=$G(XIEN(IEN))+1
;
Q
;
P89321 ;Post processing logic. 4.001,2 POST-PROCESSING LOGIC 2;E1,245 MUMPS
Q:$G(ERROR)
N I,X0,X1,X2,C,XV
S I=0,C=10 F S I=$O(^USC(8932.1,I)) Q:'I S XV=$G(^(I,"VUID"),"^"),XV=$P(XV,U) D:'$L(XV)
.S X0=$G(^USC(8932.1,I,0))
.S C=C+1,ERR("DIERR",1,"TEXT",C)="EIN="_I_" .01="_$P(X0,U)_" VA CODE="_$P(X0,U,6)_" X12 CODE="_$P(X0,U,7)
D:$D(ERR)
.S ERR("DIERR",1,"TEXT",10)="List of records not associated with VUID on site: "_$$SITE^VASITE()
.S ERROR="1^Missing VUIDs in update of IFN: "_IFN_" Listing of records see in MFS ERROR/WARNING/INFO"
.Q
Q
D89321 ; Discovery coding to get conversion to escape characters.. + set VistA_Individual_Flag to I/N
N II,CNT,CNT1,VAL,VAL1
S CNT=0,(VAL,VAL1)=""
F S CNT=$O(^TMP("HLA",$J,CNT)) Q:'CNT S II=$G(^TMP("HLA",$J,CNT)) Q:'$L(II) Q:$G(ERROR) D:$P(II,HLFS)="ZRT"
.S VAL=$P(II,HLFS,3)
.Q:'$L(VAL)
.S:$P(II,HLFS,2)="VistA_Individual_Flag" VAL=$E(VAL,1)
.S VAL=$$ESC(VAL,.HL)
.S $P(II,HLFS,3)=VAL
.S ^TMP("HLA",$J,CNT)=II
.D:$O(^TMP("HLA",$J,CNT,0))
..S CNT1=0 F S CNT1=$O(^TMP("HLA",$J,CNT,CNT1)) Q:'CNT1 D
...S VAL=$G(^TMP("HLA",$J,CNT,CNT1))
...S ^TMP("HLA",$J,CNT,CNT1)=$$ESC(VAL,.HL)
Q
ESC(VALUE,HL) ;Escape value
N ESC,ESCFS,ESCCMP,ESCSUB,ESCREP,ESCESC,ESCSEQ,CVRT
S ESC=$E(HL("ECH"),3)
S ESCFS=ESC_"F"_ESC S CVRT("ESCFS")=HL("FS")
S ESCCMP=ESC_"S"_ESC S CVRT("ESCCMP")=$E(HL("ECH"),1)
S ESCREP=ESC_"R"_ESC S CVRT("ESCREP")=$E(HL("ECH"),2)
S ESCESC=ESC_"E"_ESC S CVRT("ESCESC")=ESC
S ESCSUB=ESC_"T"_ESC S CVRT("ESCSUB")=$E(HL("ECH"),4)
;F ESCSEQ="ESCFS","ESCCMP","ESCSUB","ESCREP","ESCESC" D
F ESCSEQ="ESCFS","ESCCMP","ESCSUB","ESCREP" D
.F Q:VALUE'[CVRT(ESCSEQ) D
..S VALUE=$P(VALUE,CVRT(ESCSEQ))_@ESCSEQ_$P(VALUE,CVRT(ESCSEQ),2,9999)
Q VALUE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUPCZRT 6735 printed Apr 09, 2024@21:10:22 Page 2
XUPCZRT ;BPFO/PB - KERNEL - CALLABLE ENTRY POINTS FOR ZRT SEGMENT ; 15 FEBRUARY 2017 12:58 PM
+1 ;;8.0;KERNEL;**671**;Jul 10, 1995;Build 16
+2 ;
+3 ;
+4 QUIT
ZRT ;Manipulate update of MFN ZRT segment for 8932.1 file
+1 ;This is the indication that it's first update for any subfile
IF IEN
IF ((NAME="Term")!(NAME="Status"))
KILL XXIEN
+2 ;S:$D(HLNODE(1)) HLNODE=HLNODE_HLNODE(1)
+3 if IFN=8932.1
GOTO 89321
+4 QUIT
+5 ;
89321 ;Manipulate update of MFN ZRT segment for 8932.1 File
+1 ;XXIEN01 is the .01 of record without IEN
IF NAME="Status"
KILL XXIEN
QUIT
+2 IF NAME="VistA_Textual_Definition"
Begin DoDot:1
+3 IF $PIECE(HLNODE,HLFS,3)=""""""
Begin DoDot:2
+4 SET $PIECE(HLNODE,HLFS,3)=""
+5 ;Q ;QUIT here means, we put extra NULL line if WP field deleted. its for VETS-Discovery Functionality testing.
+6 DO WP^DIE(8932.1,IENS,11,"K","@","ERR")
+7 IF $DATA(ERR)
SET ERROR="1^Error in delete file: 8932.1 of WP field 11, IENS="_IENS
DO EM^XUMF1H(ERROR,.ERR)
KILL ERR
+8 QUIT
End DoDot:2
QUIT
+9 ;WP ;codng from WP^XUMF1H we need to do so because coding there is: D SEGPRSE^XUMFXHL7("HLNODE","X",HLFS,60)
+10 ;
+11 NEW X,Y,A,I,CNT,X1,X2,ESC
+12 DO SEGPRSE^XUMFXHL7("HLNODE","X",HLFS)
+13 SET CNT=1
+14 SET A(CNT)=X(2)
+15 SET I=0
+16 FOR
SET I=$ORDER(X(2,I))
if 'I
QUIT
Begin DoDot:2
+17 SET Y=X(2,I)
+18 IF $EXTRACT(Y,1)=" "
Begin DoDot:3
+19 SET A(CNT)=A(CNT)_" "
+20 if $PIECE(Y," ",2)=""
QUIT
+21 SET CNT=CNT+1
+22 SET A(CNT)=$PIECE(Y," ",2,99)
End DoDot:3
QUIT
+23 SET X1=$PIECE(Y," ",1)
+24 SET X2=$PIECE(Y," ",2,99)
+25 SET A(CNT)=A(CNT)_X1_$SELECT(X2="":"",1:" ")
+26 if X2=""
QUIT
+27 SET CNT=CNT+1
+28 SET A(CNT)=X2
End DoDot:2
+29 ;
+30 DO UNESCWP^XUMF0(.A,.HL)
+31 ;
+32 DO WP^DIE(IFN,IENS,11,"K","A","ERR")
+33 ;
+34 IF $DATA(ERR)
Begin DoDot:2
+35 SET ERROR="1^wp field error"
+36 DO EM^XUMF1H(ERROR,.ERR)
KILL ERR
End DoDot:2
+37 ;
+38 QUIT
End DoDot:1
SET OUT=1
QUIT
+39 ;
+40 if $DATA(HLNODE(1))
SET HLNODE=HLNODE_HLNODE(1)
+41 if IEN
QUIT
+42 IF NAME="Term"
SET XXIEN(.01)=$$UNESC^XUMF0($PIECE(HLNODE,HLFS,3),.HL)
SET OUT=1
QUIT
+43 ;Field #5 "F" X-ref
IF NAME="VistA_VA_Code"
SET XXIEN(5)=$PIECE(HLNODE,HLFS,3)
SET OUT=1
if XXIEN(5)=""""""
SET XXIEN(5)=""
QUIT
+44 ;Field #6 "G" X-REF
IF NAME="VistA_ASC_X12_Code"
SET XXIEN(6)=$PIECE(HLNODE,HLFS,3)
SET OUT=1
if XXIEN(6)=""""""
SET XXIEN(6)=""
QUIT
+45 ;Check if all definition fields are included in ZRT segment
Begin DoDot:1
+46 NEW ERMM
+47 if '$DATA(XXIEN(.01))
SET ERMM=ERMM_"Term,"
+48 if '$DATA(XXIEN(5))
SET ERMM=ERMM_",VistA_VA_Code,"
+49 if '$DATA(XXIEN(6))
SET ERMM=ERMM_",VistA_ASC_X12_Code"
+50 IF $DATA(ERMM)
SET ERROR="1^"_ERMM_"^Missing in ZRT Segment"
End DoDot:1
+51 NEW I,X5,X6,XX,NEWIEN
+52 SET NEWIEN=0
+53 SET X5=$SELECT($LENGTH(XXIEN(5)):1,1:0)
if 'X5
SET XXIEN(5)=" "
+54 SET X6=$SELECT($LENGTH(XXIEN(6)):1,1:0)
if 'X6
SET XXIEN(6)=" "
+55 IF X5
SET I=0
FOR
SET I=$ORDER(^USC(8932.1,"F",XXIEN(5),I))
if 'I
QUIT
SET XXIEN(5,I)=""
+56 IF X6
SET I=0
FOR
SET I=$ORDER(^USC(8932.1,"G",XXIEN(6),I))
if 'I
QUIT
SET XXIEN(6,I)=""
+57 IF 'X5!('X6)
SET I=0
FOR
SET I=$ORDER(^USC(8932.1,I))
if 'I
QUIT
SET XX=^(I,0)
if '$LENGTH($PIECE(XX,U,6))&'X5
SET XXIEN(5,I)=""
if '$LENGTH($PIECE(XX,U,7))&'X6
SET XXIEN(6,I)=""
+58 SET I=0
FOR
SET I=$ORDER(XXIEN(5,I))
if 'I
QUIT
if '$DATA(XXIEN(6,I))
KILL XXIEN(5,I)
+59 SET I=0
FOR
SET I=$ORDER(XXIEN(6,I))
if 'I
QUIT
if '$DATA(XXIEN(5,I))
KILL XXIEN(6,I)
+60 ;New entry should be created.
+61 ;New entry
IF '$ORDER(XXIEN(5,0))!'$ORDER(XXIEN(6,0))
DO NEW
DO SM1(IEN,1,0)
QUIT
+62 ;
+63 ;So now we have one or multiple results
+64 KILL XX
SET I=0
FOR
SET I=$ORDER(XXIEN(5,I))
if 'I
QUIT
SET XX(I)=""
+65 SET I=0
FOR
SET I=$ORDER(XXIEN(6,I))
if 'I
QUIT
SET XX(I)=""
+66 ;First IEN Set master to 0 No status set
SET I=$ORDER(XX(0))
DO SM1(I,1,0)
KILL XX(I)
+67 SET IEN=I
SET IENS=IEN_","
+68 ;Set master to 0 and status to 0 as well.
SET I=0
FOR
SET I=$ORDER(XX(I))
if 'I
QUIT
DO SM1(I,0,1)
+69 ;I '$O(XXIEN(5,$O(XXIEN(5,0)))) ; Multiple entries in field 6
+70 ;I '$O(XXIEN(5,$O(XXIEN(6,0)))) ; Multiple entries in field 5
+71 QUIT
NEW ;New entry
+1 NEW X,DIC,Y
+2 ;
+3 SET XUMF=1
+4 DO CHK^DIE(IFN,.01,,XXIEN(.01),.X,"ERR")
+5 IF $DATA(ERR)
SET ERROR="1^Error - .01 is invalid"_" File #: "_IFN_" HLNODE="_HLNODE
QUIT
+6 KILL DIC
SET DIC=IFN
SET DIC(0)="F"
DO FILE^DICN
KILL DIC
+7 IF Y="-1"
SET ERROR="1^Error - stub entry IFN: "_IFN_" failed HLNODE: "_HLNODE
QUIT
+8 SET IEN=+Y
SET RECORD("NEW")=1
+9 SET IENS=IEN_","
+10 SET NEWIEN=1
+11 QUIT
SM1(IEN,XY,X0) ;Set master to one/zero and possibly status to 0
+1 ;XY=Master Yes/No
+2 ;If X0=1 Status set to 0?
+3 NEW ROOT,IENS,XUMF,X
+4 DO CHK^DIE(IFN,.01,,XXIEN(.01),.X,"ERR")
+5 IF $DATA(ERR)
SET ERROR="1^Error - .01 from VETS is invalid"_" File #: "_IFN_" HLNODE="_HLNODE
QUIT
+6 SET IENS=IEN_","
+7 SET ROOT=$$ROOT^DILFD(IFN,,1)
+8 MERGE RECORD("BEFORE")=@ROOT@(IEN)
+9 SET RECORD("STATUS")=$$GETSTAT^XTID(IFN,,IEN_",")
+10 ;Validation??
SET FDA(IFN,IENS,.01)=XXIEN(.01)
+11 SET FDA(IFN,IENS,5)=$SELECT(XXIEN(5)=" ":"@",1:XXIEN(5))
+12 SET FDA(IFN,IENS,6)=$SELECT(XXIEN(6)=" ":"@",1:XXIEN(6))
+13 SET FDA(IFN,IENS,99.99)=VUID
+14 SET FDA(IFN,IENS,99.98)=XY
+15 NEW ERR
+16 SET XUMF=1
+17 DO FILE^DIE("E","FDA","ERR")
+18 IF $DATA(ERR)
Begin DoDot:1
+19 SET ERROR="1^VUID update error IFN: "_IFN_" IEN: "_IEN_" VUID: "_VUID_" HLNODE: "_HLNODE
+20 DO EM^XUMF1H(ERROR,.ERR)
KILL ERR
End DoDot:1
QUIT
+21 ;SET STATUS TO 0
if X0
Begin DoDot:1
+22 NEW FDA,SUBFILE
+23 SET SUBFILE=8932.199
+24 ;I VALUE=$P($$GETSTAT^XTID(IFN,,IEN_","),U) Q
+25 SET FDA(SUBFILE,"?+1,"_IENS,.01)=$$NOW^XLFDT
+26 SET FDA(SUBFILE,"?+1,"_IENS,.02)=0
+27 DO UPDATE^DIE(,"FDA",,"ERR")
+28 IF $DATA(ERR)
Begin DoDot:2
+29 SET ERROR="1^effective date and status error"
+30 DO EM^XUMF1H(ERROR,.ERR)
KILL ERR
End DoDot:2
End DoDot:1
+31 ;
+32 ;
+33 DO ADD^XUMF1H
+34 ;
+35 ; clean multiple flag
+36 if '$DATA(XIEN(IEN))
KILL XIEN
+37 SET XIEN(IEN)=$GET(XIEN(IEN))+1
+38 ;
+39 QUIT
+40 ;
P89321 ;Post processing logic. 4.001,2 POST-PROCESSING LOGIC 2;E1,245 MUMPS
+1 if $GET(ERROR)
QUIT
+2 NEW I,X0,X1,X2,C,XV
+3 SET I=0
SET C=10
FOR
SET I=$ORDER(^USC(8932.1,I))
if 'I
QUIT
SET XV=$GET(^(I,"VUID"),"^")
SET XV=$PIECE(XV,U)
if '$LENGTH(XV)
Begin DoDot:1
+4 SET X0=$GET(^USC(8932.1,I,0))
+5 SET C=C+1
SET ERR("DIERR",1,"TEXT",C)="EIN="_I_" .01="_$PIECE(X0,U)_" VA CODE="_$PIECE(X0,U,6)_" X12 CODE="_$PIECE(X0,U,7)
End DoDot:1
+6 if $DATA(ERR)
Begin DoDot:1
+7 SET ERR("DIERR",1,"TEXT",10)="List of records not associated with VUID on site: "_$$SITE^VASITE()
+8 SET ERROR="1^Missing VUIDs in update of IFN: "_IFN_" Listing of records see in MFS ERROR/WARNING/INFO"
+9 QUIT
End DoDot:1
+10 QUIT
D89321 ; Discovery coding to get conversion to escape characters.. + set VistA_Individual_Flag to I/N
+1 NEW II,CNT,CNT1,VAL,VAL1
+2 SET CNT=0
SET (VAL,VAL1)=""
+3 FOR
SET CNT=$ORDER(^TMP("HLA",$JOB,CNT))
if 'CNT
QUIT
SET II=$GET(^TMP("HLA",$JOB,CNT))
if '$LENGTH(II)
QUIT
if $GET(ERROR)
QUIT
if $PIECE(II,HLFS)="ZRT"
Begin DoDot:1
+4 SET VAL=$PIECE(II,HLFS,3)
+5 if '$LENGTH(VAL)
QUIT
+6 if $PIECE(II,HLFS,2)="VistA_Individual_Flag"
SET VAL=$EXTRACT(VAL,1)
+7 SET VAL=$$ESC(VAL,.HL)
+8 SET $PIECE(II,HLFS,3)=VAL
+9 SET ^TMP("HLA",$JOB,CNT)=II
+10 if $ORDER(^TMP("HLA",$JOB,CNT,0))
Begin DoDot:2
+11 SET CNT1=0
FOR
SET CNT1=$ORDER(^TMP("HLA",$JOB,CNT,CNT1))
if 'CNT1
QUIT
Begin DoDot:3
+12 SET VAL=$GET(^TMP("HLA",$JOB,CNT,CNT1))
+13 SET ^TMP("HLA",$JOB,CNT,CNT1)=$$ESC(VAL,.HL)
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
ESC(VALUE,HL) ;Escape value
+1 NEW ESC,ESCFS,ESCCMP,ESCSUB,ESCREP,ESCESC,ESCSEQ,CVRT
+2 SET ESC=$EXTRACT(HL("ECH"),3)
+3 SET ESCFS=ESC_"F"_ESC
SET CVRT("ESCFS")=HL("FS")
+4 SET ESCCMP=ESC_"S"_ESC
SET CVRT("ESCCMP")=$EXTRACT(HL("ECH"),1)
+5 SET ESCREP=ESC_"R"_ESC
SET CVRT("ESCREP")=$EXTRACT(HL("ECH"),2)
+6 SET ESCESC=ESC_"E"_ESC
SET CVRT("ESCESC")=ESC
+7 SET ESCSUB=ESC_"T"_ESC
SET CVRT("ESCSUB")=$EXTRACT(HL("ECH"),4)
+8 ;F ESCSEQ="ESCFS","ESCCMP","ESCSUB","ESCREP","ESCESC" D
+9 FOR ESCSEQ="ESCFS","ESCCMP","ESCSUB","ESCREP"
Begin DoDot:1
+10 FOR
if VALUE'[CVRT(ESCSEQ)
QUIT
Begin DoDot:2
+11 SET VALUE=$PIECE(VALUE,CVRT(ESCSEQ))_@ESCSEQ_$PIECE(VALUE,CVRT(ESCSEQ),2,9999)
End DoDot:2
End DoDot:1
+12 QUIT VALUE
