PSXDODH1.m

PSXDODH1 ;BIR/HTW-HL7 Message Conversion ;01/15/02 13:10:52

 ;;2.0;CMOP;**38,45**;11 Apr 97

 ;  Convert CMOP transmission messages from HL7 V 2.3.1 to V 2.1

TESTBT ;test the sequence of the messages in the batch

 ; stored in ^tmp($j,"PSXDOD","MSG0",I)

 S PSXERR="",LSEG="",PTCNT=0,ORDCNT=0

 F LNNUM=1:1 S LN=$G(@G@(LNNUM)) Q:LN=""  S SEG=$P(LN,"|") S:SEG="NTE" SEG=$P(LN,"|",1,2) D

 . Q:SEG="FTS"

 . I LNNUM=1,SEG="FHS" S LSEG=SEG,FHS=LN Q

 . I '$D(SEGSEQ(LSEG,SEG)) S PSXERR=PSXERR_$S($L(PSXERR):"~",1:"")_"SEQ^"_LSEG_U_SEG S LSEG=SEG Q

 . S LSEG=SEG

 . I "BHS,MSH,ORC,RXE,ZR1,PID,BTS"[SEG D CHECK

 Q

CHECK ;patient safety check

 I SEG="BHS" S BATIDB=$P(LN,"|",11),BHS=LN Q

 I SEG="MSH" S BATIDM=$P(LN,"|",10),ORDSEQ=$P(BATIDM,"-",3),BATIDM=$P(BATIDM,"-",1,2) I BATIDM'=BATIDB S PSXERR=PSXERR_$S($L(PSXERR):"~",1:"")_"22^"_ORDSEQ D  Q

 . I $E(IOST)="C" W !,"Order Sequence ",PSXERR,!,BATIDM,?40,BATIDB

 I SEG="ORC",LNNUM'=3 S RXIDC=$P(LN,"|",3),RXSEQ=$$GETELM(LN,"5,2","|,^") Q

 I SEG="RXE" S RXIDE=$P(LN,"|",16),ORDCNT=ORDCNT+1 I RXIDE'=RXIDC S PSXERR=PSXERR_$S($L(PSXERR):"~",1:"")_"41^"_ORDSEQ_U_RXSEQ D  Q

 . I $E(IOST)="C" W !,"Prescription Number ",PSXERR,!,RXIDE,?40,RXIDC

 I SEG="ZR1" S RXID1=$P(LN,"|",2) I RXID1'=RXIDC S PSXERR=PSXERR_$S($L(PSXERR):"~",1:"")_"44^"_ORDSEQ_U_RXSEQ D  Q

 . I $E(IOST)="C" W !,"RX Number ",PSXERR,!,RXID1,?40,RXIDC

 I SEG="PID" S PTCNT=PTCNT+1 Q

 I SEG="BTS" S PTCNTB=$P(LN,"|",2),ORDCNTB=$P(LN,"|",4),BTS=LN D

 . I PTCNTB'=PTCNT S PSXERR=PSXERR_$S($L(PSXERR):"~",1:"")_"56^" D

 .. I $E(IOST)="C" W !,"Batch Orders ",PSXERR,!,PTCNTB,?40,PTCNT

 . I ORDCNTB'=ORDCNT S PSXERR=PSXERR_$S($L(PSXERR):"~",1:"")_"58^" D

 .. I $E(IOST)="C" W !,"Batch Totals ",PSXERR,!,ORDCNTB,?40,ORDCNT

 Q

HEADER ; read FHS,BHS,ORC assemble $$XMIT,NTE|1   called from PSXDODH

 ;FHS|^~\&|CHCS|BALBOA||CMOP LEAVENWORTH|20020403115125|0124_020931151.TRN

 ;BHS|^~\&|CHCS||VistA||20020403115100||RAR^RAR||0124-020931151

 ;ORC|NW||||||||||||||||||||^^^^^^^0124&BALBOA&0124|500 PARK ST^^SAN DIEGO^CA^92130|(858)826-4923

 ;

 ;$$XMIT^020931151^BALBOA^CMOP LEAVENWORTH^0124^3020403.115125^DOD Facility^1^8^BALBOA^0124

 ; NTE|1||673BS\S\CBC-BARTOW\S\673\F\13000 BRUCE B DOWNS BLVD\S\\S\TAMPA\S\FL\S\33612\F\(888) 903-546

 ; Use document for the mapping of segments & elements between HL7 2.3.1 & CMOP 2.1

 ; CMOP DOD to Vista Message Mapping 3_24.xls

 K XM,NTE1

 S FHS=@G@(1),BHS=@G@(2),ORC=@G@(3)

 F YY="BATNM^11","FACNM^4","CMOP^6","TRANDTS^7" D PIECE(FHS,"|",YY)

 S BATNM=$$GETELM(BHS,"11,2","|,-") ; FHS SEGMENT is file name with "_"

 S TRANDTS=$$FMDATE^HLFNC(TRANDTS)

 S START=1,END=PTCNTB

 S ORC=$P(ORC,"ORC|",2)

 S DIVISION=$$GETELM(ORC,"21,8","|,^")

 F YY="DIVNUM^1","DIVNM^2","FACNUM^3" D PIECE(DIVISION,"&",YY)

 F YY="ADDRESS^22","PHONE^23" D PIECE(ORC,"|",YY)

 F YY="ADD1^1","ADD2^2","CITY^3","STATE^4","ZIP^5" D PIECE(ADDRESS,"^",YY)

 S DIVNUM="1"_DIVNUM,FACNUM="1"_FACNUM ;****Institution file change

 ; assemble XM - $$XMIT

 S XM="$$XMIT"

 F YY="BATNM^2","FACNM^3","CMOP^4","FACNUM^5","TRANDTS^6","START^8","END^9","DIVNM^10","DIVNUM^11" D PUT(.XM,"^",YY)

 S $P(XM,"^",7)="DOD Facility"

 ; change site number for testing to acceptable site number 693

 ;S XM=$$SETELM(XM,5,"^",693) ;****TESTING

 ;S XM=$$SETELM(XM,11,"^",693) ;****TESTING

 ; assemble NTE1(4)

 S NTE1DIV="" F YY="DIVNUM^1","DIVNM^2","FACNUM^3" D PUT(.NTE1DIV,"\S\",YY)

 S NTE1ADD="" F YY="ADD1^1","ADD2^2","CITY^3","STATE^4","ZIP^5" D PUT(.NTE1ADD,"\S\",YY)

 S NTE1LOC="" F YY="NTE1DIV^1","NTE1ADD^2","PHONE^3" D PUT(.NTE1LOC,"\F\",YY)

 ; assemble NTE1

 S NTE1="NTE|1||"_NTE1LOC

 ; change NTE1 site number to 693 for testing

 ;S NTE1=$$SETELM(NTE1,"4,1,1","|,\F\,\S\",693) ;****TESTING

 ;S NTE1=$$SETELM(NTE1,"4,1,3","|,\F\,\S\",693) ;****TESTING

 ; store $$XMIT,NTE1

 Q

BLDSEQ ;build check sequence of SEGMENTS

 K SEGSEQ

 F I=1:1 S LINE=$P($T(SEGBLD+I),";;",2,99) Q:LINE["$$END"  D

 . S LSEG=$P(LINE,";;")

 . F J=2:1 S SEG=$P(LINE,";;",J) Q:SEG=""  S SEGSEQ(LSEG,SEG)="" ;W !,LSEG,?10,SEG

 Q

SEGBLD ; data for checking sequence of segments. ZR1 needs special handling.

 ;;FHS;;BHS

 ;;BHS;;ORC

 ;;ORC;;NTE|2;;NTE|3;;NTE|4;;MSH

 ;;NTE|2;;NTE|2;;NTE|3;;NTE|4;;MSH

 ;;NTE|3;;NTE|3;;NTE|4;;MSH

 ;;NTE|4;;NTE|4;;MSH

 ;;MSH;;PID

 ;;PID;;NTE|8;;ORC

 ;;NTE|8;;ORC;;NTE|8;;ZML;;ZSL

 ;;ZML;;ZML;;ZSL

 ;;ZSL;;ZSL;;ORC

 ;;ORC;;RXE

 ;;RXE;;ZR1;;NTE|7

 ;;NTE|7;;NTE|7;;ZR1

 ;;ZR1;;ORC;;BTS;;MSH;;PID

 ;;BTS;;FTS

 ;;$$END

PIECE(REC,DLM,XX) ;

 ; Set VAR = piece I of REC using delimiter DLM

 N Y,I S Y=$P(XX,U),I=$P(XX,U,2),@Y=$P(REC,DLM,I)

 Q

PUT(REC,DLM,XX) ;

 ; Set VAR into piece I of REC using delimiter DLM

 N Y,I S Y=$P(XX,U),I=$P(XX,U,2)

 S $P(REC,DLM,I)=$G(@Y)

 Q

GETELM(STR,PIECES,SEPS) ;

 ; uses STRing and

 ; returns value of the element located by path of pieces and seperators

 ; ex: PIECES "3,2,1"  SEPS "|,^,&"

 N P,S,PI,V S V=STR

 F I=1:1 S PI=$P(PIECES,",",I) Q:PI=""  S P=I,P(I)=PI,S(I)=$P(SEPS,",",I)

 F I=1:1:P S V=$P(V,S(I),P(I))

 Q V

SETELM(STR,PIECES,SEPS,VALUE)      ;

 ; gets STRing and

 ; inserts value into element located by path of pieces and separators

 ; ex: PIECES "3,2,1"  SEPS "|,^,&"

 N P,S,PI,V

 S (V,V(0))=STR

 F I=1:1 S PI=$P(PIECES,",",I) Q:PI=""  S P=I,P(I)=PI,S(I)=$P(SEPS,",",I)

 F I=1:1:P S (V,V(I))=$P(V,S(I),P(I)) ; unpack

 S V(I)=VALUE ; insert value

 F I=P:-1:1 S $P(V(I-1),S(I),P(I))=V(I) ; repack

 Q V(0)

 ;

STRBLD(STR0,SEPS) ;

 ; default separators for all segments, fields, components are | ^ &  

 ; other separators can be passed in SEPS ex: "|,^,&" or "|,\F\,\S\"

 ; or placed within the field and segment nodes STR0( , , ..,"S")= separator

 ; ex: for NTE|1 of HL7 2.1 

 ;               segment NTE|1                   STR0("S")="|"

 ;               facility field          STR0(4,"S")="\F\"

 ;               address component       STR0(4,2,"S")="\S\" 

 N P1,P2,P3,S1,S2,S3,STR

 S:'$L($G(SEPS)) SEPS="|,^,&"

 M STR=STR0

L1 S P1=0,STR=""

 I '$D(STR("S")) S STR("S")=$P(SEPS,",",1)

 S S1=STR("S")

 F  S P1=$O(STR(P1)) Q:P1'>0  D

 . I +$O(STR(P1,0)) D L2

 . S $P(STR,S1,P1)=STR(P1)

 Q STR

L2 S P2=0 ; S STR(P1)=""

 I '$D(STR(P1,"S")) S STR(P1,"S")=$P(SEPS,",",2)

 S S2=STR(P1,"S")

 F  S P2=$O(STR(P1,P2)) Q:P2'>0  D

 . I +$O(STR(P1,P2,0)) D L3

 . S $P(STR(P1),S2,P2)=STR(P1,P2)

 I STR(P1)'[S2 S STR(P1)=STR(P1)_S2

 Q

L3 S P3=0 ; S STR(P1,P2)=""

 I '$D(STR(P1,P2,"S")) S STR(P1,P2,"S")=$P(SEPS,",",3)

 S S3=STR(P1,P2,"S")

 F  S P3=$O(STR(P1,P2,P3)) Q:P3'>0  D

 . S $P(STR(P1,P2),S3,P3)=STR(P1,P2,P3)

 I STR(P1,P2)'[S3 S STR(P1,P2)=STR(P1,P2)_S3

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSXDODH1   6622     printed  Feb 18, 2025@23:10:27                                                                                                                                                                                                    Page 2

PSXDODH1  ;BIR/HTW-HL7 Message Conversion ;01/15/02 13:10:52

 +1       ;;2.0;CMOP;**38,45**;11 Apr 97

 +2       ;  Convert CMOP transmission messages from HL7 V 2.3.1 to V 2.1

TESTBT    ;test the sequence of the messages in the batch

 +1       ; stored in ^tmp($j,"PSXDOD","MSG0",I)

 +2        SET PSXERR=""

           SET LSEG=""

           SET PTCNT=0

           SET ORDCNT=0

 +3        FOR LNNUM=1:1

               SET LN=$GET(@G@(LNNUM))

               if LN=""

                   QUIT 

               SET SEG=$PIECE(LN,"|")

               if SEG="NTE"

                   SET SEG=$PIECE(LN,"|",1,2)

               Begin DoDot:1

 +4                if SEG="FTS"

                       QUIT 

 +5                IF LNNUM=1

                       IF SEG="FHS"

                           SET LSEG=SEG

                           SET FHS=LN

                           QUIT 

 +6                IF '$DATA(SEGSEQ(LSEG,SEG))

                       SET PSXERR=PSXERR_$SELECT($LENGTH(PSXERR):"~",1:"")_"SEQ^"_LSEG_U_SEG

                       SET LSEG=SEG

                       QUIT 

 +7                SET LSEG=SEG

 +8                IF "BHS,MSH,ORC,RXE,ZR1,PID,BTS"[SEG

                       DO CHECK

               End DoDot:1

 +9        QUIT 

CHECK     ;patient safety check

 +1        IF SEG="BHS"

               SET BATIDB=$PIECE(LN,"|",11)

               SET BHS=LN

               QUIT 

 +2        IF SEG="MSH"

               SET BATIDM=$PIECE(LN,"|",10)

               SET ORDSEQ=$PIECE(BATIDM,"-",3)

               SET BATIDM=$PIECE(BATIDM,"-",1,2)

               IF BATIDM'=BATIDB

                   SET PSXERR=PSXERR_$SELECT($LENGTH(PSXERR):"~",1:"")_"22^"_ORDSEQ

                   Begin DoDot:1

 +3                    IF $EXTRACT(IOST)="C"

                           WRITE !,"Order Sequence ",PSXERR,!,BATIDM,?40,BATIDB

                   End DoDot:1

                   QUIT 

 +4        IF SEG="ORC"

               IF LNNUM'=3

                   SET RXIDC=$PIECE(LN,"|",3)

                   SET RXSEQ=$$GETELM(LN,"5,2","|,^")

                   QUIT 

 +5        IF SEG="RXE"

               SET RXIDE=$PIECE(LN,"|",16)

               SET ORDCNT=ORDCNT+1

               IF RXIDE'=RXIDC

                   SET PSXERR=PSXERR_$SELECT($LENGTH(PSXERR):"~",1:"")_"41^"_ORDSEQ_U_RXSEQ

                   Begin DoDot:1

 +6                    IF $EXTRACT(IOST)="C"

                           WRITE !,"Prescription Number ",PSXERR,!,RXIDE,?40,RXIDC

                   End DoDot:1

                   QUIT 

 +7        IF SEG="ZR1"

               SET RXID1=$PIECE(LN,"|",2)

               IF RXID1'=RXIDC

                   SET PSXERR=PSXERR_$SELECT($LENGTH(PSXERR):"~",1:"")_"44^"_ORDSEQ_U_RXSEQ

                   Begin DoDot:1

 +8                    IF $EXTRACT(IOST)="C"

                           WRITE !,"RX Number ",PSXERR,!,RXID1,?40,RXIDC

                   End DoDot:1

                   QUIT 

 +9        IF SEG="PID"

               SET PTCNT=PTCNT+1

               QUIT 

 +10       IF SEG="BTS"

               SET PTCNTB=$PIECE(LN,"|",2)

               SET ORDCNTB=$PIECE(LN,"|",4)

               SET BTS=LN

               Begin DoDot:1

 +11               IF PTCNTB'=PTCNT

                       SET PSXERR=PSXERR_$SELECT($LENGTH(PSXERR):"~",1:"")_"56^"

                       Begin DoDot:2

 +12                       IF $EXTRACT(IOST)="C"

                               WRITE !,"Batch Orders ",PSXERR,!,PTCNTB,?40,PTCNT

                       End DoDot:2

 +13               IF ORDCNTB'=ORDCNT

                       SET PSXERR=PSXERR_$SELECT($LENGTH(PSXERR):"~",1:"")_"58^"

                       Begin DoDot:2

 +14                       IF $EXTRACT(IOST)="C"

                               WRITE !,"Batch Totals ",PSXERR,!,ORDCNTB,?40,ORDCNT

                       End DoDot:2

               End DoDot:1

 +15       QUIT 

HEADER    ; read FHS,BHS,ORC assemble $$XMIT,NTE|1   called from PSXDODH

 +1       ;FHS|^~\&|CHCS|BALBOA||CMOP LEAVENWORTH|20020403115125|0124_020931151.TRN

 +2       ;BHS|^~\&|CHCS||VistA||20020403115100||RAR^RAR||0124-020931151

 +3       ;ORC|NW||||||||||||||||||||^^^^^^^0124&BALBOA&0124|500 PARK ST^^SAN DIEGO^CA^92130|(858)826-4923

 +4       ;

 +5       ;$$XMIT^020931151^BALBOA^CMOP LEAVENWORTH^0124^3020403.115125^DOD Facility^1^8^BALBOA^0124

 +6       ; NTE|1||673BS\S\CBC-BARTOW\S\673\F\13000 BRUCE B DOWNS BLVD\S\\S\TAMPA\S\FL\S\33612\F\(888) 903-546

 +7       ; Use document for the mapping of segments & elements between HL7 2.3.1 & CMOP 2.1

 +8       ; CMOP DOD to Vista Message Mapping 3_24.xls

 +9        KILL XM,NTE1

 +10       SET FHS=@G@(1)

           SET BHS=@G@(2)

           SET ORC=@G@(3)

 +11       FOR YY="BATNM^11","FACNM^4","CMOP^6","TRANDTS^7"

               DO PIECE(FHS,"|",YY)

 +12      ; FHS SEGMENT is file name with "_"

           SET BATNM=$$GETELM(BHS,"11,2","|,-")

 +13       SET TRANDTS=$$FMDATE^HLFNC(TRANDTS)

 +14       SET START=1

           SET END=PTCNTB

 +15       SET ORC=$PIECE(ORC,"ORC|",2)

 +16       SET DIVISION=$$GETELM(ORC,"21,8","|,^")

 +17       FOR YY="DIVNUM^1","DIVNM^2","FACNUM^3"

               DO PIECE(DIVISION,"&",YY)

 +18       FOR YY="ADDRESS^22","PHONE^23"

               DO PIECE(ORC,"|",YY)

 +19       FOR YY="ADD1^1","ADD2^2","CITY^3","STATE^4","ZIP^5"

               DO PIECE(ADDRESS,"^",YY)

 +20      ;****Institution file change

           SET DIVNUM="1"_DIVNUM

           SET FACNUM="1"_FACNUM

 +21      ; assemble XM - $$XMIT

 +22       SET XM="$$XMIT"

 +23       FOR YY="BATNM^2","FACNM^3","CMOP^4","FACNUM^5","TRANDTS^6","START^8","END^9","DIVNM^10","DIVNUM^11"

               DO PUT(.XM,"^",YY)

 +24       SET $PIECE(XM,"^",7)="DOD Facility"

 +25      ; change site number for testing to acceptable site number 693

 +26      ;S XM=$$SETELM(XM,5,"^",693) ;****TESTING

 +27      ;S XM=$$SETELM(XM,11,"^",693) ;****TESTING

 +28      ; assemble NTE1(4)

 +29       SET NTE1DIV=""

           FOR YY="DIVNUM^1","DIVNM^2","FACNUM^3"

               DO PUT(.NTE1DIV,"\S\",YY)

 +30       SET NTE1ADD=""

           FOR YY="ADD1^1","ADD2^2","CITY^3","STATE^4","ZIP^5"

               DO PUT(.NTE1ADD,"\S\",YY)

 +31       SET NTE1LOC=""

           FOR YY="NTE1DIV^1","NTE1ADD^2","PHONE^3"

               DO PUT(.NTE1LOC,"\F\",YY)

 +32      ; assemble NTE1

 +33       SET NTE1="NTE|1||"_NTE1LOC

 +34      ; change NTE1 site number to 693 for testing

 +35      ;S NTE1=$$SETELM(NTE1,"4,1,1","|,\F\,\S\",693) ;****TESTING

 +36      ;S NTE1=$$SETELM(NTE1,"4,1,3","|,\F\,\S\",693) ;****TESTING

 +37      ; store $$XMIT,NTE1

 +38       QUIT 

BLDSEQ    ;build check sequence of SEGMENTS

 +1        KILL SEGSEQ

 +2        FOR I=1:1

               SET LINE=$PIECE($TEXT(SEGBLD+I),";;",2,99)

               if LINE["$$END"

                   QUIT 

               Begin DoDot:1

 +3                SET LSEG=$PIECE(LINE,";;")

 +4       ;W !,LSEG,?10,SEG

                   FOR J=2:1

                       SET SEG=$PIECE(LINE,";;",J)

                       if SEG=""

                           QUIT 

                       SET SEGSEQ(LSEG,SEG)=""

               End DoDot:1

 +5        QUIT 

SEGBLD    ; data for checking sequence of segments. ZR1 needs special handling.

 +1       ;;FHS;;BHS

 +2       ;;BHS;;ORC

 +3       ;;ORC;;NTE|2;;NTE|3;;NTE|4;;MSH

 +4       ;;NTE|2;;NTE|2;;NTE|3;;NTE|4;;MSH

 +5       ;;NTE|3;;NTE|3;;NTE|4;;MSH

 +6       ;;NTE|4;;NTE|4;;MSH

 +7       ;;MSH;;PID

 +8       ;;PID;;NTE|8;;ORC

 +9       ;;NTE|8;;ORC;;NTE|8;;ZML;;ZSL

 +10      ;;ZML;;ZML;;ZSL

 +11      ;;ZSL;;ZSL;;ORC

 +12      ;;ORC;;RXE

 +13      ;;RXE;;ZR1;;NTE|7

 +14      ;;NTE|7;;NTE|7;;ZR1

 +15      ;;ZR1;;ORC;;BTS;;MSH;;PID

 +16      ;;BTS;;FTS

 +17      ;;$$END

PIECE(REC,DLM,XX) ;

 +1       ; Set VAR = piece I of REC using delimiter DLM

 +2        NEW Y,I

           SET Y=$PIECE(XX,U)

           SET I=$PIECE(XX,U,2)

           SET @Y=$PIECE(REC,DLM,I)

 +3        QUIT 

PUT(REC,DLM,XX) ;

 +1       ; Set VAR into piece I of REC using delimiter DLM

 +2        NEW Y,I

           SET Y=$PIECE(XX,U)

           SET I=$PIECE(XX,U,2)

 +3        SET $PIECE(REC,DLM,I)=$GET(@Y)

 +4        QUIT 

GETELM(STR,PIECES,SEPS) ;

 +1       ; uses STRing and

 +2       ; returns value of the element located by path of pieces and seperators

 +3       ; ex: PIECES "3,2,1"  SEPS "|,^,&"

 +4        NEW P,S,PI,V

           SET V=STR

 +5        FOR I=1:1

               SET PI=$PIECE(PIECES,",",I)

               if PI=""

                   QUIT 

               SET P=I

               SET P(I)=PI

               SET S(I)=$PIECE(SEPS,",",I)

 +6        FOR I=1:1:P

               SET V=$PIECE(V,S(I),P(I))

 +7        QUIT V

SETELM(STR,PIECES,SEPS,VALUE) ;

 +1       ; gets STRing and

 +2       ; inserts value into element located by path of pieces and separators

 +3       ; ex: PIECES "3,2,1"  SEPS "|,^,&"

 +4        NEW P,S,PI,V

 +5        SET (V,V(0))=STR

 +6        FOR I=1:1

               SET PI=$PIECE(PIECES,",",I)

               if PI=""

                   QUIT 

               SET P=I

               SET P(I)=PI

               SET S(I)=$PIECE(SEPS,",",I)

 +7       ; unpack

           FOR I=1:1:P

               SET (V,V(I))=$PIECE(V,S(I),P(I))

 +8       ; insert value

           SET V(I)=VALUE

 +9       ; repack

           FOR I=P:-1:1

               SET $PIECE(V(I-1),S(I),P(I))=V(I)

 +10       QUIT V(0)

 +11      ;

STRBLD(STR0,SEPS) ;

 +1       ; default separators for all segments, fields, components are | ^ &  

 +2       ; other separators can be passed in SEPS ex: "|,^,&" or "|,\F\,\S\"

 +3       ; or placed within the field and segment nodes STR0( , , ..,"S")= separator

 +4       ; ex: for NTE|1 of HL7 2.1 

 +5       ;               segment NTE|1                   STR0("S")="|"

 +6       ;               facility field          STR0(4,"S")="\F\"

 +7       ;               address component       STR0(4,2,"S")="\S\" 

 +8        NEW P1,P2,P3,S1,S2,S3,STR

 +9        if '$LENGTH($GET(SEPS))

               SET SEPS="|,^,&"

 +10       MERGE STR=STR0

L1         SET P1=0

           SET STR=""

 +1        IF '$DATA(STR("S"))

               SET STR("S")=$PIECE(SEPS,",",1)

 +2        SET S1=STR("S")

 +3        FOR 

               SET P1=$ORDER(STR(P1))

               if P1'>0

                   QUIT 

               Begin DoDot:1

 +4                IF +$ORDER(STR(P1,0))

                       DO L2

 +5                SET $PIECE(STR,S1,P1)=STR(P1)

               End DoDot:1

 +6        QUIT STR

L2        ; S STR(P1)=""

           SET P2=0

 +1        IF '$DATA(STR(P1,"S"))

               SET STR(P1,"S")=$PIECE(SEPS,",",2)

 +2        SET S2=STR(P1,"S")

 +3        FOR 

               SET P2=$ORDER(STR(P1,P2))

               if P2'>0

                   QUIT 

               Begin DoDot:1

 +4                IF +$ORDER(STR(P1,P2,0))

                       DO L3

 +5                SET $PIECE(STR(P1),S2,P2)=STR(P1,P2)

               End DoDot:1

 +6        IF STR(P1)'[S2

               SET STR(P1)=STR(P1)_S2

 +7        QUIT 

L3        ; S STR(P1,P2)=""

           SET P3=0

 +1        IF '$DATA(STR(P1,P2,"S"))

               SET STR(P1,P2,"S")=$PIECE(SEPS,",",3)

 +2        SET S3=STR(P1,P2,"S")

 +3        FOR 

               SET P3=$ORDER(STR(P1,P2,P3))

               if P3'>0

                   QUIT 

               Begin DoDot:1

 +4                SET $PIECE(STR(P1,P2),S3,P3)=STR(P1,P2,P3)

               End DoDot:1

 +5        IF STR(P1,P2)'[S3

               SET STR(P1,P2)=STR(P1,P2)_S3

 +6        QUIT