XUPCZRT.m

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 ---XUPCZRT   6735     printed  Mar 13, 2025@21:16:29                                                                                                                                                                                                     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