SDCCRSCU ;CCRA/LB,PB - Appointment Message Parsing Utilities;APR 4, 2019
;;5.3;Scheduling;**707**;APR 4, 2019;Build 57
;;Per VA directive 6402, this routine should not be modified.
Q
PARSE(FIELD,REP,COMP,SUBCOMP,ESCAPE,SEG,TO) ;
;Parses the segment stored in SEG(1),SEG(2),... into TO()
;Input:
; FIELD - field separator
; REP - field repetition separator
; COMP - component separator
; SUBCOMP - subcomponent separator
; ESCAPE - escape character
; SEG - (pass by reference) the array holding the unparsed segment.
;Output:
; Function returns 1 on success, 0 on failure
; TO - (pass by reference) - the parsed values
; SEG- This input variable is deleted during the processing. If it is needs to be retained, pass in a copy!
;
N VALUE,CHAR,COUNTS
K TO
Q:$L($G(FIELD))'=1 0
Q:$L($G(REP))'=1 0
Q:$L($G(COMP))'=1 0
Q:'$D(SUBCOMP) 0
Q:'$D(SEG) 0
S COUNTS("FIELD")=0
S COUNTS("REP")=1
S COUNTS("COMP")=1
S COUNTS("SUBCOMP")=1
S VALUE=""
S SEG("LINE")=$O(SEG(0)),SEG("CHAR")=0
F S CHAR=$$NEXTCHAR(.SEG) D Q:'$L(CHAR)
.I '$L(CHAR) D Q
..I $L(VALUE) S TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=VALUE
.E I CHAR=FIELD D Q
..I $L(VALUE) S TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=$$DESCAPE(VALUE,.FIELD,.COMP,.SUBCOMP,.REP,.ESCAPE),VALUE=""
..S COUNTS("FIELD")=COUNTS("FIELD")+1,COUNTS("REP")=1,COUNTS("COMP")=1,COUNTS("SUBCOMP")=1
.E I CHAR=REP D Q
..I $L(VALUE) S TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=$$DESCAPE(VALUE,.FIELD,.COMP,.SUBCOMP,.REP,.ESCAPE),VALUE=""
..S COUNTS("REP")=COUNTS("REP")+1,COUNTS("COMP")=1,COUNTS("SUBCOMP")=1
.E I CHAR=COMP D Q
..I $L(VALUE) S TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=$$DESCAPE(VALUE,.FIELD,.COMP,.SUBCOMP,.REP,.ESCAPE),VALUE=""
..S COUNTS("COMP")=COUNTS("COMP")+1,COUNTS("SUBCOMP")=1
.E I CHAR=SUBCOMP D Q
..I $L(VALUE) S TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=$$DESCAPE(VALUE,.FIELD,.COMP,.SUBCOMP,.REP,.ESCAPE),VALUE=""
..S COUNTS("SUBCOMP")=COUNTS("SUBCOMP")+1
.E S VALUE=VALUE_CHAR
S TO("SEGMENT TYPE")=$G(TO(0,1,1,1)),TO(0)=TO("SEGMENT TYPE")
I (TO("SEGMENT TYPE")="BHS")!(TO("SEGMENT TYPE")="MSH") S TO("FIELD SEPARATOR")=FIELD
Q 1
;
NEXTCHAR(SEG) ;
;returns the next character in the segment array
;
Q:'SEG("LINE") ""
N RET
S SEG("CHAR")=SEG("CHAR")+1
S RET=$E(SEG(SEG("LINE")),SEG("CHAR"))
Q:RET]"" RET
S SEG("LINE")=$O(SEG(SEG("LINE")))
I SEG("LINE") S SEG("CHAR")=1 Q $E(SEG(SEG("LINE")))
Q ""
;
DESCAPE(VALUE,FIELD,COMP,SUBCOMP,REP,ESCAPE) ;
;Replaces the escape sequences with the corresponding encoding character and returns the result as the function value
;
Q:ESCAPE="" VALUE
N NEWSTRNG,SUBSTRNG,SET,LEN,I,SUBLEN,CHAR
S (NEWSTRNG,SUBSTRNG,SUBLEN)=""
S SET="FSTRE"
S LEN=$L(VALUE)
F I=1:1:LEN S SUBSTRNG=SUBSTRNG_$E(VALUE,I),SUBLEN=SUBLEN+1 D:SUBLEN=3
.S CHAR=$E(SUBSTRNG,2)
.I $E(SUBSTRNG,1)=ESCAPE,$E(SUBSTRNG,3)=ESCAPE,SET[CHAR D
..I CHAR="F" S NEWSTRNG=NEWSTRNG_FIELD,SUBSTRNG="",SUBLEN=0 Q
..I CHAR="S" S NEWSTRNG=NEWSTRNG_COMP,SUBSTRNG="",SUBLEN=0 Q
..I CHAR="T" S NEWSTRNG=NEWSTRNG_SUBCOMP,SUBSTRNG="",SUBLEN=0 Q
..I CHAR="R" S NEWSTRNG=NEWSTRNG_REP,SUBSTRNG="",SUBLEN=0 Q
..I CHAR="E" S NEWSTRNG=NEWSTRNG_ESCAPE,SUBSTRNG="",SUBLEN=0 Q
.E S NEWSTRNG=NEWSTRNG_$E(SUBSTRNG),SUBSTRNG=$E(SUBSTRNG,2,3),SUBLEN=2
Q NEWSTRNG_SUBSTRNG
;
GETCODE(SEG,VALUE,FIELD,COMP,REP) ;
;Implements GETCNE and GETCWE
;
N SUB,VAR
Q:'$G(FIELD)
I '$G(COMP) D
.S VAR="COMP",SUB=1
E D
.S VAR="SUB"
S:'$G(REP) REP=1
S @VAR=1,VALUE("ID")=$$GET(.SEG,FIELD,COMP,SUB,REP)
S @VAR=2,VALUE("TEXT")=$$GET(.SEG,FIELD,COMP,SUB,REP)
S @VAR=3,VALUE("SYSTEM")=$$GET(.SEG,FIELD,COMP,SUB,REP)
S @VAR=4,VALUE("ALTERNATE ID")=$$GET(.SEG,FIELD,COMP,SUB,REP)
S @VAR=5,VALUE("ALTERNATE TEXT")=$$GET(.SEG,FIELD,COMP,SUB,REP)
S @VAR=6,VALUE("ALTERNATE SYSTEM")=$$GET(.SEG,FIELD,COMP,SUB,REP)
S @VAR=7,VALUE("SYSTEM VERSION")=$$GET(.SEG,FIELD,COMP,SUB,REP)
S @VAR=8,VALUE("ALTERNATE SYSTEM VERSION")=$$GET(.SEG,FIELD,COMP)
S @VAR=9,VALUE("ORIGINAL TEXT")=$$GET(.SEG,FIELD,COMP,SUB,REP)
Q
;
GET(SEG,FIELD,COMP,SUBCOMP,REP) ;
;This function gets a specified value from a segment that was parsed by
;$$NEXTSEG. The FIELD,COMP,SUBCOMP,REP parameters are optional - if not
;specified, they default to 1.
; Example:
; $$GET(.SEG,1) will return the value of the first field, first
; component, first subcomponent, in the first occurrence of field #1.
;Input:
;SEG - (required, pass by reference) - this is the array where the parsed segment was placed by $$NEXTSEG
;FIELD - the sequence # of the field (optional, defaults to 1)
;COMP - the # of the component (optional, defaults to 1)
;SUBCOMP - the # of the subcomponent (optional, defaults to 1)
;REP - the occurrence# (optional, defaults to 1) For a non-repeating field, the occurrence # need not be provided, because it would be 1.
;Output:
; Function returns the requested value on success, "" if not valued.
;
;allow the segment type to be obtained via field #0 (shorthand)
I $D(FIELD),$G(FIELD)=0 Q $G(SEG("SEGMENT TYPE"))
S:'$G(FIELD) FIELD=1
;
;for MSH or BHS, SEQ#1 is the field separator
I FIELD=1,$G(SEG("SEGMENT TYPE"))="MSH"!($G(SEG("SEGMENT TYPE"))="BHS"),$G(REP)<2,$G(COMP)<2,$G(SUBCOMP)<2 Q SEG("FIELD SEPARATOR")
I FIELD=1,$G(SEG("SEGMENT TYPE"))="MSH"!($G(SEG("SEGMENT TYPE"))="BHS") Q ""
;
S:'$G(COMP) COMP=1
S:'$G(SUBCOMP) SUBCOMP=1
S:'$G(REP) REP=1
Q $G(SEG(FIELD,REP,COMP,SUBCOMP))
;
PARSEHDR(HDR) ;
;Parses the segment (HDR, pass by reference) into the HDR() array using meaningful subscripts.
;Input:
; HDR (pass by reference, required) contains the segment in the format HDR(1),HDR(2), etc..
;Output:
; HDR (pass by reference, required) This array will contain all the individual values. Also will contain HDR(1) with components 1-6 and HDR(2) with components 1-end
; Function - returns 1 if the segment is indeed an MSH or BHS segment, 0 otherwise
;
ZB25 ;
N VALUE,FS,CS,REP,SUBCOMP,ESCAPE
S VALUE=$E(HDR(1),1,3)
I VALUE'="MSH",VALUE'="BHS" Q 0
S HDR("SEGMENT TYPE")=VALUE
S FS=$E(HDR(1),4)
Q:FS="" 0
S HDR("ENCODING CHARACTERS")=$P(HDR(1),FS,2)
S CS=$E(HDR("ENCODING CHARACTERS"),1)
S REP=$E(HDR("ENCODING CHARACTERS"),2)
S ESCAPE=$E(HDR("ENCODING CHARACTERS"),3)
S SUBCOMP=$E(HDR("ENCODING CHARACTERS"),4)
Q:REP="" 0
S HDR("FIELD SEPARATOR")=FS
S HDR("COMPONENT SEPARATOR")=CS
S HDR("REPETITION SEPARATOR")=REP
S HDR("ESCAPE CHARACTER")=ESCAPE
S HDR("SUBCOMPONENT SEPARATOR")=SUBCOMP
S HDR("SENDING APPLICATION")=$$DESCAPE($P($P(HDR(1),FS,3),CS))
S VALUE=$P(HDR(1),FS,4)
S HDR("SENDING FACILITY",1)=$$DESCAPE($P(VALUE,CS))
S HDR("SENDING FACILITY",2)=$$DESCAPE($P(VALUE,CS,2))
S HDR("SENDING FACILITY",3)=$$DESCAPE($P(VALUE,CS,3))
S HDR("RECEIVING APPLICATION")=$$DESCAPE($P($P(HDR(1),FS,5),CS))
S VALUE=$P(HDR(1),FS,6)
S HDR("RECEIVING FACILITY",1)=$$DESCAPE($P(VALUE,CS))
S HDR("RECEIVING FACILITY",2)=$$DESCAPE($P(VALUE,CS,2))
S HDR("RECEIVING FACILITY",3)=$$DESCAPE($P(VALUE,CS,3))
S HDR("DT/TM OF MESSAGE")=$$FMDATE^HLFNC($$DESCAPE($P($P(HDR(2),FS,2),CS)))
S HDR("SECURITY")=$$DESCAPE($P($P(HDR(2),FS,3),CS))
;
I HDR("SEGMENT TYPE")="MSH" D
.S VALUE=$P(HDR(2),FS,4)
.S HDR("MESSAGE TYPE")=$P(VALUE,CS)
.S HDR("EVENT")=$P(VALUE,CS,2)
.S HDR("MESSAGE STRUCTURE")=$$DESCAPE($P(VALUE,CS,3))
.S HDR("MESSAGE CONTROL ID")=$$DESCAPE($P($P(HDR(2),FS,5),CS))
.S VALUE=$P(HDR(2),FS,6)
.S HDR("PROCESSING ID")=$P(VALUE,CS)
.S HDR("PROCESSING MODE")=$$DESCAPE($P(VALUE,CS,2))
.S HDR("VERSION")=$$DESCAPE($P($P(HDR(2),FS,7),CS))
.S HDR("CONTINUATION POINTER")=$$DESCAPE($P($P(HDR(2),FS,9),CS))
.S HDR("ACCEPT ACK TYPE")=$P($P(HDR(2),FS,10),CS)
.S HDR("APP ACK TYPE")=$P($P(HDR(2),FS,11),CS)
.S HDR("COUNTRY")=$$DESCAPE($P($P(HDR(2),FS,12),CS))
;
I HDR("SEGMENT TYPE")="BHS" D
.S VALUE=$P(HDR(2),FS,4)
.S HDR("BATCH NAME/ID/TYPE")=$$DESCAPE(VALUE)
.S HDR("PROCESSING ID")=$E($P(VALUE,"PROCESSING ID=",2),1)
.S HDR("ACCEPT ACK TYPE")=$E($P(VALUE,"ACCEPT ACK TYPE=",2),1,2)
.S HDR("APP ACK TYPE")=$E($P(VALUE,"APP ACK TYPE=",2),1,2)
.S HDR("BATCH COMMENT")=$$DESCAPE($P(HDR(2),FS,5))
.S HDR("BATCH CONTROL ID")=$$DESCAPE($P($P(HDR(2),FS,6),CS))
.S HDR("REFERENCE BATCH CONTROL ID")=$$DESCAPE($P($P(HDR(2),FS,7),CS))
.;
ZB26 ;
Q 1
;
PARSESEG(SEG,DATA,HL) ;Generic segment parser
;This procedure parses a single HL7 segment and builds an array
;subscripted by the field number containing the data for that field.
; Does not handle segments that span nodes
;
; Input:
; SEG - HL7 segment to parse
; HL - HL7 environment array
;
; Output:
; Function value - field data array [SUB1:field, SUB2:repetition,
; SUB3:component, SUB4:sub-component]
;
N CMP ;component subscript
N CMPVAL ;component value
N FLD ;field subscript
N FLDVAL ;field value
N REP ;repetition subscript
N REPVAL ;repetition value
N SUB ;sub-component subscript
N SUBVAL ;sub-component value
N FS ;field separator
N CS ;component separator
N RS ;repetition separator
N SS ;sub-component separator
N ES ;escape character
;
K DATA
S FS=$G(HL("FS"),"|") S:FS="" FS="|"
S CS=$E($G(HL("ECH")),1) S:CS="" CS="^"
S RS=$E($G(HL("ECH")),2) S:RS="" RS="~"
S ES=$E($G(HL("ECH")),3) S:ES="" ES="\"
S SS=$E($G(HL("ECH")),4) S:SS="" SS="&"
;
S DATA(0)=$P(SEG,FS)
S SEG=$P(SEG,FS,2,9999)
;
F FLD=1:1:$L(SEG,FS) D
. S FLDVAL=$P(SEG,FS,FLD)
. F REP=1:1:$L(FLDVAL,RS) D
. . S REPVAL=$P(FLDVAL,RS,REP)
. . I REPVAL[CS F CMP=1:1:$L(REPVAL,CS) D
. . . S CMPVAL=$P(REPVAL,CS,CMP)
. . . I CMPVAL[SS F SUB=1:1:$L(CMPVAL,SS) D
. . . . S SUBVAL=$P(CMPVAL,SS,SUB)
. . . . I SUBVAL'="" S DATA(FLD,REP,CMP,SUB)=SUBVAL
. . . I '$D(DATA(FLD,REP,CMP)),CMPVAL'="" S DATA(FLD,REP,CMP)=CMPVAL
. . I '$D(DATA(FLD,REP)),REPVAL'="",FLDVAL[RS S DATA(FLD,REP)=REPVAL
. I '$D(DATA(FLD)),FLDVAL'="" S DATA(FLD)=FLDVAL
Q
INP ; set up the INP array for calling ARSET^SDECAR2 to update the RTC orders
; Need to add code to add the rtcparent to the HL7 message and to parse it out.
;D APPERROR^%ZTER("SDHL7APU 196")
N NODE3,INTV,NUMAPTS,ORDATE,CONSID1,ORDNUM
S CONSID1=$P(SDAPTYP,"|",2) S:$G(CONSID1)>0 SDDDT=$P(^GMR(123,CONSID1,0),"^",24),ORDNUM=$P(^GMR(123,CONSID1,0),"^",3)
K INP
S INP(1)="" ; This is a new request so this is always null for a new request
S INP(2)=$G(SDDFN)
D NOW^%DTC N NOW S NOW=$$HTFM^XLFDT($H),INP(3)=$$FMTE^XLFDT(NOW)
;S INP(3)=$G(ORDATE)
;NEEDS THE TEXT INSTITUTION NAME
S INP(4)=$$NAME^XUAF4(+$G(DUZ(2))) ;Required, DUZ(2) is the signed on users division they are signed into, +DUZ(2) is the parent station number
S INP(5)="APPT"
S INP(6)=$G(SDCL)
S INP(8)="FUTURE"
S INP(9)="PROVIDER"
S INP(11)=$G(SDDDT) ; Clinically Indicate Date for first appointment in the sequence, each of the remaining appointments have to be calculated
S INP(12)=$G(SDECNOTE)
S PCE="" S PCE=$P($G(^DPT(SDDFN,"ENR")),U,1) I PCE'="" D
.S INP(13)=$$GET1^DIQ(27.11,PCE,.07,"E")
;S INP(13)="" ;Enrollment priority will be null for TMP
S INP(14)=""
S INP(17)="" ;null for TMP
S SCPERC=0
S SCPERC=$P(^DPT($G(INP(2)),.3),"^",2)
S INP(19)=SCPERC
S INP(22)="9"
S INP(23)="NEW"
S INP(28)=$G(ORDNUM)
K SCPERC,PCE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDCCRSCU 11602 printed Oct 16, 2024@18:49:27 Page 2
SDCCRSCU ;CCRA/LB,PB - Appointment Message Parsing Utilities;APR 4, 2019
+1 ;;5.3;Scheduling;**707**;APR 4, 2019;Build 57
+2 ;;Per VA directive 6402, this routine should not be modified.
+3 QUIT
PARSE(FIELD,REP,COMP,SUBCOMP,ESCAPE,SEG,TO) ;
+1 ;Parses the segment stored in SEG(1),SEG(2),... into TO()
+2 ;Input:
+3 ; FIELD - field separator
+4 ; REP - field repetition separator
+5 ; COMP - component separator
+6 ; SUBCOMP - subcomponent separator
+7 ; ESCAPE - escape character
+8 ; SEG - (pass by reference) the array holding the unparsed segment.
+9 ;Output:
+10 ; Function returns 1 on success, 0 on failure
+11 ; TO - (pass by reference) - the parsed values
+12 ; SEG- This input variable is deleted during the processing. If it is needs to be retained, pass in a copy!
+13 ;
+14 NEW VALUE,CHAR,COUNTS
+15 KILL TO
+16 if $LENGTH($GET(FIELD))'=1
QUIT 0
+17 if $LENGTH($GET(REP))'=1
QUIT 0
+18 if $LENGTH($GET(COMP))'=1
QUIT 0
+19 if '$DATA(SUBCOMP)
QUIT 0
+20 if '$DATA(SEG)
QUIT 0
+21 SET COUNTS("FIELD")=0
+22 SET COUNTS("REP")=1
+23 SET COUNTS("COMP")=1
+24 SET COUNTS("SUBCOMP")=1
+25 SET VALUE=""
+26 SET SEG("LINE")=$ORDER(SEG(0))
SET SEG("CHAR")=0
+27 FOR
SET CHAR=$$NEXTCHAR(.SEG)
Begin DoDot:1
+28 IF '$LENGTH(CHAR)
Begin DoDot:2
+29 IF $LENGTH(VALUE)
SET TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=VALUE
End DoDot:2
QUIT
+30 IF '$TEST
IF CHAR=FIELD
Begin DoDot:2
+31 IF $LENGTH(VALUE)
SET TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=$$DESCAPE(VALUE,.FIELD,.COMP,.SUBCOMP,.REP,.ESCAPE)
SET VALUE=""
+32 SET COUNTS("FIELD")=COUNTS("FIELD")+1
SET COUNTS("REP")=1
SET COUNTS("COMP")=1
SET COUNTS("SUBCOMP")=1
End DoDot:2
QUIT
+33 IF '$TEST
IF CHAR=REP
Begin DoDot:2
+34 IF $LENGTH(VALUE)
SET TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=$$DESCAPE(VALUE,.FIELD,.COMP,.SUBCOMP,.REP,.ESCAPE)
SET VALUE=""
+35 SET COUNTS("REP")=COUNTS("REP")+1
SET COUNTS("COMP")=1
SET COUNTS("SUBCOMP")=1
End DoDot:2
QUIT
+36 IF '$TEST
IF CHAR=COMP
Begin DoDot:2
+37 IF $LENGTH(VALUE)
SET TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=$$DESCAPE(VALUE,.FIELD,.COMP,.SUBCOMP,.REP,.ESCAPE)
SET VALUE=""
+38 SET COUNTS("COMP")=COUNTS("COMP")+1
SET COUNTS("SUBCOMP")=1
End DoDot:2
QUIT
+39 IF '$TEST
IF CHAR=SUBCOMP
Begin DoDot:2
+40 IF $LENGTH(VALUE)
SET TO(COUNTS("FIELD"),COUNTS("REP"),COUNTS("COMP"),COUNTS("SUBCOMP"))=$$DESCAPE(VALUE,.FIELD,.COMP,.SUBCOMP,.REP,.ESCAPE)
SET VALUE=""
+41 SET COUNTS("SUBCOMP")=COUNTS("SUBCOMP")+1
End DoDot:2
QUIT
+42 IF '$TEST
SET VALUE=VALUE_CHAR
End DoDot:1
if '$LENGTH(CHAR)
QUIT
+43 SET TO("SEGMENT TYPE")=$GET(TO(0,1,1,1))
SET TO(0)=TO("SEGMENT TYPE")
+44 IF (TO("SEGMENT TYPE")="BHS")!(TO("SEGMENT TYPE")="MSH")
SET TO("FIELD SEPARATOR")=FIELD
+45 QUIT 1
+46 ;
NEXTCHAR(SEG) ;
+1 ;returns the next character in the segment array
+2 ;
+3 if 'SEG("LINE")
QUIT ""
+4 NEW RET
+5 SET SEG("CHAR")=SEG("CHAR")+1
+6 SET RET=$EXTRACT(SEG(SEG("LINE")),SEG("CHAR"))
+7 if RET]""
QUIT RET
+8 SET SEG("LINE")=$ORDER(SEG(SEG("LINE")))
+9 IF SEG("LINE")
SET SEG("CHAR")=1
QUIT $EXTRACT(SEG(SEG("LINE")))
+10 QUIT ""
+11 ;
DESCAPE(VALUE,FIELD,COMP,SUBCOMP,REP,ESCAPE) ;
+1 ;Replaces the escape sequences with the corresponding encoding character and returns the result as the function value
+2 ;
+3 if ESCAPE=""
QUIT VALUE
+4 NEW NEWSTRNG,SUBSTRNG,SET,LEN,I,SUBLEN,CHAR
+5 SET (NEWSTRNG,SUBSTRNG,SUBLEN)=""
+6 SET SET="FSTRE"
+7 SET LEN=$LENGTH(VALUE)
+8 FOR I=1:1:LEN
SET SUBSTRNG=SUBSTRNG_$EXTRACT(VALUE,I)
SET SUBLEN=SUBLEN+1
if SUBLEN=3
Begin DoDot:1
+9 SET CHAR=$EXTRACT(SUBSTRNG,2)
+10 IF $EXTRACT(SUBSTRNG,1)=ESCAPE
IF $EXTRACT(SUBSTRNG,3)=ESCAPE
IF SET[CHAR
Begin DoDot:2
+11 IF CHAR="F"
SET NEWSTRNG=NEWSTRNG_FIELD
SET SUBSTRNG=""
SET SUBLEN=0
QUIT
+12 IF CHAR="S"
SET NEWSTRNG=NEWSTRNG_COMP
SET SUBSTRNG=""
SET SUBLEN=0
QUIT
+13 IF CHAR="T"
SET NEWSTRNG=NEWSTRNG_SUBCOMP
SET SUBSTRNG=""
SET SUBLEN=0
QUIT
+14 IF CHAR="R"
SET NEWSTRNG=NEWSTRNG_REP
SET SUBSTRNG=""
SET SUBLEN=0
QUIT
+15 IF CHAR="E"
SET NEWSTRNG=NEWSTRNG_ESCAPE
SET SUBSTRNG=""
SET SUBLEN=0
QUIT
End DoDot:2
+16 IF '$TEST
SET NEWSTRNG=NEWSTRNG_$EXTRACT(SUBSTRNG)
SET SUBSTRNG=$EXTRACT(SUBSTRNG,2,3)
SET SUBLEN=2
End DoDot:1
+17 QUIT NEWSTRNG_SUBSTRNG
+18 ;
GETCODE(SEG,VALUE,FIELD,COMP,REP) ;
+1 ;Implements GETCNE and GETCWE
+2 ;
+3 NEW SUB,VAR
+4 if '$GET(FIELD)
QUIT
+5 IF '$GET(COMP)
Begin DoDot:1
+6 SET VAR="COMP"
SET SUB=1
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET VAR="SUB"
End DoDot:1
+9 if '$GET(REP)
SET REP=1
+10 SET @VAR=1
SET VALUE("ID")=$$GET(.SEG,FIELD,COMP,SUB,REP)
+11 SET @VAR=2
SET VALUE("TEXT")=$$GET(.SEG,FIELD,COMP,SUB,REP)
+12 SET @VAR=3
SET VALUE("SYSTEM")=$$GET(.SEG,FIELD,COMP,SUB,REP)
+13 SET @VAR=4
SET VALUE("ALTERNATE ID")=$$GET(.SEG,FIELD,COMP,SUB,REP)
+14 SET @VAR=5
SET VALUE("ALTERNATE TEXT")=$$GET(.SEG,FIELD,COMP,SUB,REP)
+15 SET @VAR=6
SET VALUE("ALTERNATE SYSTEM")=$$GET(.SEG,FIELD,COMP,SUB,REP)
+16 SET @VAR=7
SET VALUE("SYSTEM VERSION")=$$GET(.SEG,FIELD,COMP,SUB,REP)
+17 SET @VAR=8
SET VALUE("ALTERNATE SYSTEM VERSION")=$$GET(.SEG,FIELD,COMP)
+18 SET @VAR=9
SET VALUE("ORIGINAL TEXT")=$$GET(.SEG,FIELD,COMP,SUB,REP)
+19 QUIT
+20 ;
GET(SEG,FIELD,COMP,SUBCOMP,REP) ;
+1 ;This function gets a specified value from a segment that was parsed by
+2 ;$$NEXTSEG. The FIELD,COMP,SUBCOMP,REP parameters are optional - if not
+3 ;specified, they default to 1.
+4 ; Example:
+5 ; $$GET(.SEG,1) will return the value of the first field, first
+6 ; component, first subcomponent, in the first occurrence of field #1.
+7 ;Input:
+8 ;SEG - (required, pass by reference) - this is the array where the parsed segment was placed by $$NEXTSEG
+9 ;FIELD - the sequence # of the field (optional, defaults to 1)
+10 ;COMP - the # of the component (optional, defaults to 1)
+11 ;SUBCOMP - the # of the subcomponent (optional, defaults to 1)
+12 ;REP - the occurrence# (optional, defaults to 1) For a non-repeating field, the occurrence # need not be provided, because it would be 1.
+13 ;Output:
+14 ; Function returns the requested value on success, "" if not valued.
+15 ;
+16 ;allow the segment type to be obtained via field #0 (shorthand)
+17 IF $DATA(FIELD)
IF $GET(FIELD)=0
QUIT $GET(SEG("SEGMENT TYPE"))
+18 if '$GET(FIELD)
SET FIELD=1
+19 ;
+20 ;for MSH or BHS, SEQ#1 is the field separator
+21 IF FIELD=1
IF $GET(SEG("SEGMENT TYPE"))="MSH"!($GET(SEG("SEGMENT TYPE"))="BHS")
IF $GET(REP)<2
IF $GET(COMP)<2
IF $GET(SUBCOMP)<2
QUIT SEG("FIELD SEPARATOR")
+22 IF FIELD=1
IF $GET(SEG("SEGMENT TYPE"))="MSH"!($GET(SEG("SEGMENT TYPE"))="BHS")
QUIT ""
+23 ;
+24 if '$GET(COMP)
SET COMP=1
+25 if '$GET(SUBCOMP)
SET SUBCOMP=1
+26 if '$GET(REP)
SET REP=1
+27 QUIT $GET(SEG(FIELD,REP,COMP,SUBCOMP))
+28 ;
PARSEHDR(HDR) ;
+1 ;Parses the segment (HDR, pass by reference) into the HDR() array using meaningful subscripts.
+2 ;Input:
+3 ; HDR (pass by reference, required) contains the segment in the format HDR(1),HDR(2), etc..
+4 ;Output:
+5 ; HDR (pass by reference, required) This array will contain all the individual values. Also will contain HDR(1) with components 1-6 and HDR(2) with components 1-end
+6 ; Function - returns 1 if the segment is indeed an MSH or BHS segment, 0 otherwise
+7 ;
ZB25 ;
+1 NEW VALUE,FS,CS,REP,SUBCOMP,ESCAPE
+2 SET VALUE=$EXTRACT(HDR(1),1,3)
+3 IF VALUE'="MSH"
IF VALUE'="BHS"
QUIT 0
+4 SET HDR("SEGMENT TYPE")=VALUE
+5 SET FS=$EXTRACT(HDR(1),4)
+6 if FS=""
QUIT 0
+7 SET HDR("ENCODING CHARACTERS")=$PIECE(HDR(1),FS,2)
+8 SET CS=$EXTRACT(HDR("ENCODING CHARACTERS"),1)
+9 SET REP=$EXTRACT(HDR("ENCODING CHARACTERS"),2)
+10 SET ESCAPE=$EXTRACT(HDR("ENCODING CHARACTERS"),3)
+11 SET SUBCOMP=$EXTRACT(HDR("ENCODING CHARACTERS"),4)
+12 if REP=""
QUIT 0
+13 SET HDR("FIELD SEPARATOR")=FS
+14 SET HDR("COMPONENT SEPARATOR")=CS
+15 SET HDR("REPETITION SEPARATOR")=REP
+16 SET HDR("ESCAPE CHARACTER")=ESCAPE
+17 SET HDR("SUBCOMPONENT SEPARATOR")=SUBCOMP
+18 SET HDR("SENDING APPLICATION")=$$DESCAPE($PIECE($PIECE(HDR(1),FS,3),CS))
+19 SET VALUE=$PIECE(HDR(1),FS,4)
+20 SET HDR("SENDING FACILITY",1)=$$DESCAPE($PIECE(VALUE,CS))
+21 SET HDR("SENDING FACILITY",2)=$$DESCAPE($PIECE(VALUE,CS,2))
+22 SET HDR("SENDING FACILITY",3)=$$DESCAPE($PIECE(VALUE,CS,3))
+23 SET HDR("RECEIVING APPLICATION")=$$DESCAPE($PIECE($PIECE(HDR(1),FS,5),CS))
+24 SET VALUE=$PIECE(HDR(1),FS,6)
+25 SET HDR("RECEIVING FACILITY",1)=$$DESCAPE($PIECE(VALUE,CS))
+26 SET HDR("RECEIVING FACILITY",2)=$$DESCAPE($PIECE(VALUE,CS,2))
+27 SET HDR("RECEIVING FACILITY",3)=$$DESCAPE($PIECE(VALUE,CS,3))
+28 SET HDR("DT/TM OF MESSAGE")=$$FMDATE^HLFNC($$DESCAPE($PIECE($PIECE(HDR(2),FS,2),CS)))
+29 SET HDR("SECURITY")=$$DESCAPE($PIECE($PIECE(HDR(2),FS,3),CS))
+30 ;
+31 IF HDR("SEGMENT TYPE")="MSH"
Begin DoDot:1
+32 SET VALUE=$PIECE(HDR(2),FS,4)
+33 SET HDR("MESSAGE TYPE")=$PIECE(VALUE,CS)
+34 SET HDR("EVENT")=$PIECE(VALUE,CS,2)
+35 SET HDR("MESSAGE STRUCTURE")=$$DESCAPE($PIECE(VALUE,CS,3))
+36 SET HDR("MESSAGE CONTROL ID")=$$DESCAPE($PIECE($PIECE(HDR(2),FS,5),CS))
+37 SET VALUE=$PIECE(HDR(2),FS,6)
+38 SET HDR("PROCESSING ID")=$PIECE(VALUE,CS)
+39 SET HDR("PROCESSING MODE")=$$DESCAPE($PIECE(VALUE,CS,2))
+40 SET HDR("VERSION")=$$DESCAPE($PIECE($PIECE(HDR(2),FS,7),CS))
+41 SET HDR("CONTINUATION POINTER")=$$DESCAPE($PIECE($PIECE(HDR(2),FS,9),CS))
+42 SET HDR("ACCEPT ACK TYPE")=$PIECE($PIECE(HDR(2),FS,10),CS)
+43 SET HDR("APP ACK TYPE")=$PIECE($PIECE(HDR(2),FS,11),CS)
+44 SET HDR("COUNTRY")=$$DESCAPE($PIECE($PIECE(HDR(2),FS,12),CS))
End DoDot:1
+45 ;
+46 IF HDR("SEGMENT TYPE")="BHS"
Begin DoDot:1
+47 SET VALUE=$PIECE(HDR(2),FS,4)
+48 SET HDR("BATCH NAME/ID/TYPE")=$$DESCAPE(VALUE)
+49 SET HDR("PROCESSING ID")=$EXTRACT($PIECE(VALUE,"PROCESSING ID=",2),1)
+50 SET HDR("ACCEPT ACK TYPE")=$EXTRACT($PIECE(VALUE,"ACCEPT ACK TYPE=",2),1,2)
+51 SET HDR("APP ACK TYPE")=$EXTRACT($PIECE(VALUE,"APP ACK TYPE=",2),1,2)
+52 SET HDR("BATCH COMMENT")=$$DESCAPE($PIECE(HDR(2),FS,5))
+53 SET HDR("BATCH CONTROL ID")=$$DESCAPE($PIECE($PIECE(HDR(2),FS,6),CS))
+54 SET HDR("REFERENCE BATCH CONTROL ID")=$$DESCAPE($PIECE($PIECE(HDR(2),FS,7),CS))
+55 ;
End DoDot:1
ZB26 ;
+1 QUIT 1
+2 ;
PARSESEG(SEG,DATA,HL) ;Generic segment parser
+1 ;This procedure parses a single HL7 segment and builds an array
+2 ;subscripted by the field number containing the data for that field.
+3 ; Does not handle segments that span nodes
+4 ;
+5 ; Input:
+6 ; SEG - HL7 segment to parse
+7 ; HL - HL7 environment array
+8 ;
+9 ; Output:
+10 ; Function value - field data array [SUB1:field, SUB2:repetition,
+11 ; SUB3:component, SUB4:sub-component]
+12 ;
+13 ;component subscript
NEW CMP
+14 ;component value
NEW CMPVAL
+15 ;field subscript
NEW FLD
+16 ;field value
NEW FLDVAL
+17 ;repetition subscript
NEW REP
+18 ;repetition value
NEW REPVAL
+19 ;sub-component subscript
NEW SUB
+20 ;sub-component value
NEW SUBVAL
+21 ;field separator
NEW FS
+22 ;component separator
NEW CS
+23 ;repetition separator
NEW RS
+24 ;sub-component separator
NEW SS
+25 ;escape character
NEW ES
+26 ;
+27 KILL DATA
+28 SET FS=$GET(HL("FS"),"|")
if FS=""
SET FS="|"
+29 SET CS=$EXTRACT($GET(HL("ECH")),1)
if CS=""
SET CS="^"
+30 SET RS=$EXTRACT($GET(HL("ECH")),2)
if RS=""
SET RS="~"
+31 SET ES=$EXTRACT($GET(HL("ECH")),3)
if ES=""
SET ES="\"
+32 SET SS=$EXTRACT($GET(HL("ECH")),4)
if SS=""
SET SS="&"
+33 ;
+34 SET DATA(0)=$PIECE(SEG,FS)
+35 SET SEG=$PIECE(SEG,FS,2,9999)
+36 ;
+37 FOR FLD=1:1:$LENGTH(SEG,FS)
Begin DoDot:1
+38 SET FLDVAL=$PIECE(SEG,FS,FLD)
+39 FOR REP=1:1:$LENGTH(FLDVAL,RS)
Begin DoDot:2
+40 SET REPVAL=$PIECE(FLDVAL,RS,REP)
+41 IF REPVAL[CS
FOR CMP=1:1:$LENGTH(REPVAL,CS)
Begin DoDot:3
+42 SET CMPVAL=$PIECE(REPVAL,CS,CMP)
+43 IF CMPVAL[SS
FOR SUB=1:1:$LENGTH(CMPVAL,SS)
Begin DoDot:4
+44 SET SUBVAL=$PIECE(CMPVAL,SS,SUB)
+45 IF SUBVAL'=""
SET DATA(FLD,REP,CMP,SUB)=SUBVAL
End DoDot:4
+46 IF '$DATA(DATA(FLD,REP,CMP))
IF CMPVAL'=""
SET DATA(FLD,REP,CMP)=CMPVAL
End DoDot:3
+47 IF '$DATA(DATA(FLD,REP))
IF REPVAL'=""
IF FLDVAL[RS
SET DATA(FLD,REP)=REPVAL
End DoDot:2
+48 IF '$DATA(DATA(FLD))
IF FLDVAL'=""
SET DATA(FLD)=FLDVAL
End DoDot:1
+49 QUIT
INP ; set up the INP array for calling ARSET^SDECAR2 to update the RTC orders
+1 ; Need to add code to add the rtcparent to the HL7 message and to parse it out.
+2 ;D APPERROR^%ZTER("SDHL7APU 196")
+3 NEW NODE3,INTV,NUMAPTS,ORDATE,CONSID1,ORDNUM
+4 SET CONSID1=$PIECE(SDAPTYP,"|",2)
if $GET(CONSID1)>0
SET SDDDT=$PIECE(^GMR(123,CONSID1,0),"^",24)
SET ORDNUM=$PIECE(^GMR(123,CONSID1,0),"^",3)
+5 KILL INP
+6 ; This is a new request so this is always null for a new request
SET INP(1)=""
+7 SET INP(2)=$GET(SDDFN)
+8 DO NOW^%DTC
NEW NOW
SET NOW=$$HTFM^XLFDT($HOROLOG)
SET INP(3)=$$FMTE^XLFDT(NOW)
+9 ;S INP(3)=$G(ORDATE)
+10 ;NEEDS THE TEXT INSTITUTION NAME
+11 ;Required, DUZ(2) is the signed on users division they are signed into, +DUZ(2) is the parent station number
SET INP(4)=$$NAME^XUAF4(+$GET(DUZ(2)))
+12 SET INP(5)="APPT"
+13 SET INP(6)=$GET(SDCL)
+14 SET INP(8)="FUTURE"
+15 SET INP(9)="PROVIDER"
+16 ; Clinically Indicate Date for first appointment in the sequence, each of the remaining appointments have to be calculated
SET INP(11)=$GET(SDDDT)
+17 SET INP(12)=$GET(SDECNOTE)
+18 SET PCE=""
SET PCE=$PIECE($GET(^DPT(SDDFN,"ENR")),U,1)
IF PCE'=""
Begin DoDot:1
+19 SET INP(13)=$$GET1^DIQ(27.11,PCE,.07,"E")
End DoDot:1
+20 ;S INP(13)="" ;Enrollment priority will be null for TMP
+21 SET INP(14)=""
+22 ;null for TMP
SET INP(17)=""
+23 SET SCPERC=0
+24 SET SCPERC=$PIECE(^DPT($GET(INP(2)),.3),"^",2)
+25 SET INP(19)=SCPERC
+26 SET INP(22)="9"
+27 SET INP(23)="NEW"
+28 SET INP(28)=$GET(ORDNUM)
+29 KILL SCPERC,PCE
+30 QUIT
