SCDXMSG1 ;ALB/JRP - AMB CARE MESSAGE BUILDER UTILS;08-MAY-1996 ; 6/21/05 2:08pm
;;5.3;Scheduling;**44,55,70,77,85,66,143,142,162,172,180,239,245,254,293,325,387,459,472,441,552**;AUG 13, 1993;Build 5
;
;-- Line tags for building HL7 segment
BLDEVN S VAFEVN=$$EN^VAFHLEVN(EVNTHL7,ENCNDT,VAFSTR,HL("Q"),HL("FS"))
;SD*5.3*387 replaced EVNTDATE with ENCNDT
Q
BLDPID K VAFPID D BLDPID^VAFCQRY(DFN,1,VAFSTR,.VAFPID,.HL)
;check marital/religion status; rebuild PID segment.
D SETMAR^SCMSVUT0(.VAFPID,HL("Q"),HL("FS"),HL("ECH"))
Q
BLDZPD S VAFZPD=$$EN1^VAFHLZPD(DFN,VAFSTR)
D SETPOW^SCMSVUT0(DFN,.VAFZPD,HL("Q"),HL("FS"))
Q
BLDPV1 D SETID^SCMSVUT0(ENCPTR,DELPTR)
S VAFPV1=$$EN^VAFHLPV1(ENCPTR,DELPTR,VAFSTR,1,HL("Q"),HL("FS"))
Q
BLDDG1 K @VAFARRY
D EN^VAFHLDG1(ENCPTR,VAFSTR,HL("Q"),HL("FS"),VAFARRY)
Q
BLDPR1 K @VAFARRY
D SETPRTY^SCMSVUT0(ENCPTR)
D EN^VAFHLPR1(ENCPTR,VAFSTR,HL("Q"),HL("FS"),HL("ECH"),VAFARRY)
Q
BLDZEL N ELCOD,ELIGENC,I,VAFMSTDT
S VAFMSTDT=ENCDT
D EN1^VAFHLZEL(DFN,VAFSTR,1,.VAFZEL)
S ELCOD=$P($G(^SCE(ENCPTR,0)),"^",13),ELIGENC=$P($G(^DIC(8,+ELCOD,0)),"^",9)
S $P(VAFZEL(1),HL("FS"),3)=ELIGENC
Q
BLDZIR K DGREL,DGINC,DGINR,DGDEP
D ALL^DGMTU21(DFN,"V",ENCDT,"R")
S VAFZIR=$$EN^VAFHLZIR(+$G(DGINR("V")),VAFSTR,1,ENCPTR)
K DGREL,DGINC,DGINR,DGDEP
Q
BLDZCL K @VAFARRY
D EN^VAFHLZCL(DFN,ENCPTR,VAFSTR,HL("Q"),HL("FS"),VAFARRY)
Q
BLDZSC K @VAFARRY
D EN^VAFHLZSC(ENCPTR,VAFSTR,HL("Q"),HL("FS"),VAFARRY)
Q
BLDZSP S VAFZSP=$$EN^VAFHLZSP(DFN,1,1)
S VAFZSP=$$SETVSI^SCMSVUT0(DFN,$G(VAFZSP),HL("Q"),HL("FS"))
Q
BLDROL K @VAFARRY
N SCDXPRV,SCDXPAR,SCDXROL,PTRPRV,NODE,PRVNUM,TMP
D GETPRV^SDOE(ENCPTR,"SCDXPRV")
S PTRPRV=0
F PRVNUM=1:1 S PTRPRV=+$O(SCDXPRV(PTRPRV)) Q:('PTRPRV) D
.K SCDXPAR,SCDXROL
.S NODE=SCDXPRV(PTRPRV)
.S SCDXPAR("PTR200")=+NODE
.S SCDXPAR("INSTID")=$$VID4XMIT^SCDXFU11(XMITPTR)_"-"_(+NODE)_"*"_PRVNUM
.S SCDXPAR("ACTION")="CO"
.S SCDXPAR("ALTROLE")=($TR($P(NODE,"^",4),"PS","10"))_$E(HL("ECH"),1)_HL("Q")_$E(HL("ECH"),1)_"VA01"
.S SCDXPAR("CODEONLY")=0
.S SCDXPAR("RDATE")=ENCDT
.D OUTPAT^VAFHLROL("SCDXPAR","SCDXROL",VAFSTR,HL("FS"),HL("ECH"),HL("Q"),240)
.K SCDXROL("ERROR"),SCDXROL("WARNING")
.M @VAFARRY@(PRVNUM)=SCDXROL
Q
BLDPD1 S VAFPD1=$$EN^VAFHLPD1(DFN,VAFSTR)
Q
BLDZEN S VAFZEN=$$EN^VAFHLZEN(DFN,VAFSTR,1,HL("Q"),HL("FS"))
Q
;
;-- Line tags for validating HL7 segments
VLDEVN S ERROR=$$EN^SCMSVEVN(VAFEVN,HL("Q"),HL("FS"),VALERR)
S:(ERROR>0) ERROR=0
Q
VLDPID S ERROR=$$EN^SCMSVPID(.VAFPID,HL("Q"),HL("FS"),HL("ECH"),VALERR,ENCDT,EVNTHL7)
S:(ERROR>0) ERROR=0
Q
VLDZPD S ERROR=$$EN^SCMSVZPD(.VAFZPD,HL("Q"),HL("FS"),VALERR,ENCDT,NODE)
S:(ERROR>0) ERROR=0
Q
VLDPV1 S ERROR=$$EN^SCMSVPV1(VAFPV1,HL("Q"),HL("FS"),VALERR,NODE,EVNTHL7,ENCNDT)
S:(ERROR>0) ERROR=0
Q
VLDDG1 S ERROR=$$EN^SCMSVDG1(VAFARRY,HL("Q"),HL("FS"),ENCPTR,VALERR,ENCDT)
S:(ERROR>0) ERROR=0
Q
VLDPR1 S ERROR=$$EN^SCMSVPR1(VAFARRY,HL("Q"),HL("FS"),HL("ECH"),VALERR,ENCDT)
S:(ERROR>0) ERROR=0
Q
VLDZEL N VAFZELSV M VAFZELSV=VAFZEL
S ERROR=$$EN^SCMSVZEL(.VAFZELSV,HL("Q"),HL("FS"),VALERR,DFN)
S:(ERROR>0) ERROR=0
Q
VLDZIR S ERROR=$$EN^SCMSVZIR(VAFZIR,HL("Q"),HL("FS"),VALERR)
S:(ERROR>0) ERROR=0
Q
VLDZCL S ERROR=$$EN^SCMSVZCL(VAFARRY,HL("Q"),HL("FS"),VALERR,DFN)
S:(ERROR>0) ERROR=0
Q
VLDZSC S ERROR=$$EN^SCMSVZSC(VAFARRY,HL("Q"),HL("FS"),VALERR,ENCPTR)
S:(ERROR>0) ERROR=0
Q
VLDZSP S ERROR=$$EN^SCMSVZSP(VAFZSP,HL("Q"),HL("FS"),VALERR,DFN)
S:(ERROR>0) ERROR=0
Q
VLDROL S ERROR=$$EN^SCMSVROL(VAFARRY,HL("Q"),HL("FS"),HL("ECH"),VALERR)
S:(ERROR>0) ERROR=0
Q
VLDPD1 S ERROR=0
Q
VLDZEN S ERROR=0
Q
;
;-- Line tags for copying HL7 segments into HL7 message
CPYEVN N I
S @XMITARRY@(CURLINE)=VAFEVN
S LINESADD=LINESADD+1
S I=""
F S I=+$O(VAFEVN(I)) Q:('I) D
.S @XMITARRY@(CURLINE,I)=VAFEVN(I)
.S LINESADD=LINESADD+1
Q
CPYPID N I
S @XMITARRY@(CURLINE)=VAFPID
S LINESADD=LINESADD+1
S I=""
F S I=+$O(VAFPID(I)) Q:('I) D
.S @XMITARRY@(CURLINE,I)=VAFPID(I)
.S LINESADD=LINESADD+1
Q
CPYZPD N I
S @XMITARRY@(CURLINE)=VAFZPD
S LINESADD=LINESADD+1
S I=""
F S I=+$O(VAFZPD(I)) Q:('I) D
.S @XMITARRY@(CURLINE,I)=VAFZPD(I)
.S LINESADD=LINESADD+1
Q
CPYPV1 N I
S @XMITARRY@(CURLINE)=VAFPV1
S LINESADD=LINESADD+1
S I=""
F S I=+$O(VAFPV1(I)) Q:('I) D
.S @XMITARRY@(CURLINE,I)=VAFPV1(I)
.S LINESADD=LINESADD+1
Q
CPYDG1 N I,J,K
S I=""
F K=0:1 S I=+$O(@VAFARRY@(I)) Q:('I) D
.S J=""
.F S J=$O(@VAFARRY@(I,J)) Q:(J="") D
..S:('J) @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J)
..S:(J) @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J)
..S LINESADD=LINESADD+1
S CURLINE=CURLINE+K-1
Q
CPYPR1 N I,J,K
S I=""
F K=0:1 S I=+$O(@VAFARRY@(I)) Q:('I) D
.S J=""
.F S J=$O(@VAFARRY@(I,J)) Q:(J="") D
..S:('J) @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J)
..S:(J) @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J)
..S LINESADD=LINESADD+1
S CURLINE=CURLINE+K-1
Q
CPYZEL N I
S @XMITARRY@(CURLINE)=VAFZEL(1)
S LINESADD=LINESADD+1
S I=""
F S I=+$O(VAFZEL(1,I)) Q:('I) D
.S @XMITARRY@(CURLINE,I)=VAFZEL(1,I)
.S LINESADD=LINESADD+1
Q
CPYZIR N I
S @XMITARRY@(CURLINE)=VAFZIR
S LINESADD=LINESADD+1
N I
S I=""
F S I=+$O(VAFZIR(I)) Q:('I) D
.S @XMITARRY@(CURLINE,I)=VAFZIR(I)
.S LINESADD=LINESADD+1
Q
CPYZCL N I,J,K
S I=""
F K=0:1 S I=+$O(@VAFARRY@(I)) Q:('I) D
.S J=""
.F S J=$O(@VAFARRY@(I,J)) Q:(J="") D
..S:('J) @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J)
..S:(J) @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J)
..S LINESADD=LINESADD+1
S CURLINE=CURLINE+K-1
Q
CPYZSC N I,J,K
S I=""
F K=0:1 S I=+$O(@VAFARRY@(I)) Q:('I) D
.S J=""
.F S J=$O(@VAFARRY@(I,J)) Q:(J="") D
..S:('J) @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J)
..S:(J) @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J)
..S LINESADD=LINESADD+1
S CURLINE=CURLINE+K-1
Q
CPYZSP N I
S @XMITARRY@(CURLINE)=VAFZSP
S LINESADD=LINESADD+1
S I=""
F S I=+$O(VAFZSP(I)) Q:('I) D
.S @XMITARRY@(CURLINE,I)=VAFZSP(I)
.S LINESADD=LINESADD+1
Q
CPYROL N I,J,K
S I=""
F K=0:1 S I=+$O(@VAFARRY@(I)) Q:('I) D
.S J=""
.F S J=$O(@VAFARRY@(I,J)) Q:(J="") D
..S:('J) @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J)
..S:(J) @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J)
..S LINESADD=LINESADD+1
S CURLINE=CURLINE+K-1
Q
CPYPD1 N I
S @XMITARRY@(CURLINE)=VAFPD1
S LINESADD=LINESADD+1
S I=""
F S I=+$O(VAFPD1(I)) Q:('I) D
.S @XMITARRY@(CURLINE,I)=VAFPD1(I)
.S LINESADD=LINESADD+1
Q
CPYZEN N I
S @XMITARRY@(CURLINE)=VAFZEN
S LINESADD=LINESADD+1
S I=""
F S I=+$O(VAFZEN(I)) Q:('I) D
.S @XMITARRY@(CURLINE,I)=VAFZEN(I)
.S LINESADD=LINESADD+1
Q
;
;-- Line tags for deleting HL7 segments
DELEVN K VAFEVN
Q
DELPID K VAFPID
Q
DELZPD K VAFZPD
Q
DELPV1 K VAFPV1
Q
DELDG1 K @VAFARRY
Q
DELPR1 K @VAFARRY
Q
DELZEL K VAFZEL
Q
DELZIR K VAFZIR
Q
DELZCL K @VAFARRY
Q
DELZSC K @VAFARRY
Q
DELZSP K VAFZSP
Q
DELROL K @VAFARRY
Q
DELPD1 K VAFPD1
Q
DELZEN K VAFZEN
Q
;
;
SEGMENTS(EVNTTYPE,SEGARRY) ;Build list of HL7 segments for a given
; event type
;
;Input : EVNTTYPE - Event type to build list for
; A08 & A23 are the only types currently supported
; (Defaults to A08)
; SEGARRY - Array to place output in (full global reference)
; (Defaults to ^TMP("SCDX SEGMENTS",$J))
;Output : None
; SEGARRY(Seq,Name) = Fields
; Seq - Sequencing number to order the segments as
; they should be placed in the HL7 message
; Name - Name of HL7 segment
; Fields - List of fields used by Ambulatory Care
; VAFSTR would be set to this value
; : MSH segment is not included
;
;Check input
S EVNTTYPE=$G(EVNTTYPE)
S:(EVNTTYPE'="A23") EVNTTYPE="A08"
S SEGARRY=$G(SEGARRY)
S:(SEGARRY="") SEGARRY="^TMP(""SCDX SEGMENTS"","_$J_")"
;Segments used by A08 & A23
S @SEGARRY@(1,"EVN")="1,2"
S @SEGARRY@(2,"PID")="1,2,3,4,5,6,7,8,10,11,13,14,16,17,19,22"
S @SEGARRY@(3,"PD1")="3,4"
S @SEGARRY@(4,"PV1")="1,2,4,14,19,39,44,50"
;Building list for A23 - add ZPD segment and quit
I (EVNTTYPE="A23") D Q
.S @SEGARRY@(5,"ZPD")="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,40"
S @SEGARRY@(5,"DG1")="1,2,3,4,5,15"
S @SEGARRY@(6,"PR1")="1,3,16"
S @SEGARRY@(7,"ROL")="1,2,3,4"
S @SEGARRY@(8,"ZPD")="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,40"
S @SEGARRY@(9,"ZEL")="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,29,37,38,40"
S @SEGARRY@(10,"ZIR")="1,2,3,4,5,6,7,8,9,10,11,12,13"
S @SEGARRY@(11,"ZCL")="1,2,3"
S @SEGARRY@(12,"ZSC")="1,2,3"
S @SEGARRY@(13,"ZSP")="1,2,3,4"
S @SEGARRY@(14,"ZEN")="1,2,3,4,5,6,7,8,9,10"
Q
;
UNWIND(XMITARRY,INSRTPNT) ;Remove all data that was put into HL7 message
;
;Input : XMITARRY - Array containing HL7 message (full global ref)
; (Defaults to ^TMP("HLS",$J))
; INSRTPNT - Where to begin deletion from (Defaults to 1)
;Output : None
;
;Check input
S XMITARRY=$G(XMITARRY)
S:(XMITARRY="") XMITARRY="^TMP(""HLS"","_$J_")"
S INSRTPNT=$G(INSRTPNT)
S:(INSRTPNT="") INSRTPNT=1
;Remove insertion point from array
K @XMITARRY@(INSRTPNT)
;Remove everything from insertion point to end of array
F S INSRTPNT=$O(@XMITARRY@(INSRTPNT)) Q:(INSRTPNT="") K @XMITARRY@(INSRTPNT)
;Done
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCDXMSG1 9477 printed Oct 16, 2024@18:39:56 Page 2
SCDXMSG1 ;ALB/JRP - AMB CARE MESSAGE BUILDER UTILS;08-MAY-1996 ; 6/21/05 2:08pm
+1 ;;5.3;Scheduling;**44,55,70,77,85,66,143,142,162,172,180,239,245,254,293,325,387,459,472,441,552**;AUG 13, 1993;Build 5
+2 ;
+3 ;-- Line tags for building HL7 segment
BLDEVN SET VAFEVN=$$EN^VAFHLEVN(EVNTHL7,ENCNDT,VAFSTR,HL("Q"),HL("FS"))
+1 ;SD*5.3*387 replaced EVNTDATE with ENCNDT
+2 QUIT
BLDPID KILL VAFPID
DO BLDPID^VAFCQRY(DFN,1,VAFSTR,.VAFPID,.HL)
+1 ;check marital/religion status; rebuild PID segment.
+2 DO SETMAR^SCMSVUT0(.VAFPID,HL("Q"),HL("FS"),HL("ECH"))
+3 QUIT
BLDZPD SET VAFZPD=$$EN1^VAFHLZPD(DFN,VAFSTR)
+1 DO SETPOW^SCMSVUT0(DFN,.VAFZPD,HL("Q"),HL("FS"))
+2 QUIT
BLDPV1 DO SETID^SCMSVUT0(ENCPTR,DELPTR)
+1 SET VAFPV1=$$EN^VAFHLPV1(ENCPTR,DELPTR,VAFSTR,1,HL("Q"),HL("FS"))
+2 QUIT
BLDDG1 KILL @VAFARRY
+1 DO EN^VAFHLDG1(ENCPTR,VAFSTR,HL("Q"),HL("FS"),VAFARRY)
+2 QUIT
BLDPR1 KILL @VAFARRY
+1 DO SETPRTY^SCMSVUT0(ENCPTR)
+2 DO EN^VAFHLPR1(ENCPTR,VAFSTR,HL("Q"),HL("FS"),HL("ECH"),VAFARRY)
+3 QUIT
BLDZEL NEW ELCOD,ELIGENC,I,VAFMSTDT
+1 SET VAFMSTDT=ENCDT
+2 DO EN1^VAFHLZEL(DFN,VAFSTR,1,.VAFZEL)
+3 SET ELCOD=$PIECE($GET(^SCE(ENCPTR,0)),"^",13)
SET ELIGENC=$PIECE($GET(^DIC(8,+ELCOD,0)),"^",9)
+4 SET $PIECE(VAFZEL(1),HL("FS"),3)=ELIGENC
+5 QUIT
BLDZIR KILL DGREL,DGINC,DGINR,DGDEP
+1 DO ALL^DGMTU21(DFN,"V",ENCDT,"R")
+2 SET VAFZIR=$$EN^VAFHLZIR(+$GET(DGINR("V")),VAFSTR,1,ENCPTR)
+3 KILL DGREL,DGINC,DGINR,DGDEP
+4 QUIT
BLDZCL KILL @VAFARRY
+1 DO EN^VAFHLZCL(DFN,ENCPTR,VAFSTR,HL("Q"),HL("FS"),VAFARRY)
+2 QUIT
BLDZSC KILL @VAFARRY
+1 DO EN^VAFHLZSC(ENCPTR,VAFSTR,HL("Q"),HL("FS"),VAFARRY)
+2 QUIT
BLDZSP SET VAFZSP=$$EN^VAFHLZSP(DFN,1,1)
+1 SET VAFZSP=$$SETVSI^SCMSVUT0(DFN,$GET(VAFZSP),HL("Q"),HL("FS"))
+2 QUIT
BLDROL KILL @VAFARRY
+1 NEW SCDXPRV,SCDXPAR,SCDXROL,PTRPRV,NODE,PRVNUM,TMP
+2 DO GETPRV^SDOE(ENCPTR,"SCDXPRV")
+3 SET PTRPRV=0
+4 FOR PRVNUM=1:1
SET PTRPRV=+$ORDER(SCDXPRV(PTRPRV))
if ('PTRPRV)
QUIT
Begin DoDot:1
+5 KILL SCDXPAR,SCDXROL
+6 SET NODE=SCDXPRV(PTRPRV)
+7 SET SCDXPAR("PTR200")=+NODE
+8 SET SCDXPAR("INSTID")=$$VID4XMIT^SCDXFU11(XMITPTR)_"-"_(+NODE)_"*"_PRVNUM
+9 SET SCDXPAR("ACTION")="CO"
+10 SET SCDXPAR("ALTROLE")=($TRANSLATE($PIECE(NODE,"^",4),"PS","10"))_$EXTRACT(HL("ECH"),1)_HL("Q")_$EXTRACT(HL("ECH"),1)_"VA01"
+11 SET SCDXPAR("CODEONLY")=0
+12 SET SCDXPAR("RDATE")=ENCDT
+13 DO OUTPAT^VAFHLROL("SCDXPAR","SCDXROL",VAFSTR,HL("FS"),HL("ECH"),HL("Q"),240)
+14 KILL SCDXROL("ERROR"),SCDXROL("WARNING")
+15 MERGE @VAFARRY@(PRVNUM)=SCDXROL
End DoDot:1
+16 QUIT
BLDPD1 SET VAFPD1=$$EN^VAFHLPD1(DFN,VAFSTR)
+1 QUIT
BLDZEN SET VAFZEN=$$EN^VAFHLZEN(DFN,VAFSTR,1,HL("Q"),HL("FS"))
+1 QUIT
+2 ;
+3 ;-- Line tags for validating HL7 segments
VLDEVN SET ERROR=$$EN^SCMSVEVN(VAFEVN,HL("Q"),HL("FS"),VALERR)
+1 if (ERROR>0)
SET ERROR=0
+2 QUIT
VLDPID SET ERROR=$$EN^SCMSVPID(.VAFPID,HL("Q"),HL("FS"),HL("ECH"),VALERR,ENCDT,EVNTHL7)
+1 if (ERROR>0)
SET ERROR=0
+2 QUIT
VLDZPD SET ERROR=$$EN^SCMSVZPD(.VAFZPD,HL("Q"),HL("FS"),VALERR,ENCDT,NODE)
+1 if (ERROR>0)
SET ERROR=0
+2 QUIT
VLDPV1 SET ERROR=$$EN^SCMSVPV1(VAFPV1,HL("Q"),HL("FS"),VALERR,NODE,EVNTHL7,ENCNDT)
+1 if (ERROR>0)
SET ERROR=0
+2 QUIT
VLDDG1 SET ERROR=$$EN^SCMSVDG1(VAFARRY,HL("Q"),HL("FS"),ENCPTR,VALERR,ENCDT)
+1 if (ERROR>0)
SET ERROR=0
+2 QUIT
VLDPR1 SET ERROR=$$EN^SCMSVPR1(VAFARRY,HL("Q"),HL("FS"),HL("ECH"),VALERR,ENCDT)
+1 if (ERROR>0)
SET ERROR=0
+2 QUIT
VLDZEL NEW VAFZELSV
MERGE VAFZELSV=VAFZEL
+1 SET ERROR=$$EN^SCMSVZEL(.VAFZELSV,HL("Q"),HL("FS"),VALERR,DFN)
+2 if (ERROR>0)
SET ERROR=0
+3 QUIT
VLDZIR SET ERROR=$$EN^SCMSVZIR(VAFZIR,HL("Q"),HL("FS"),VALERR)
+1 if (ERROR>0)
SET ERROR=0
+2 QUIT
VLDZCL SET ERROR=$$EN^SCMSVZCL(VAFARRY,HL("Q"),HL("FS"),VALERR,DFN)
+1 if (ERROR>0)
SET ERROR=0
+2 QUIT
VLDZSC SET ERROR=$$EN^SCMSVZSC(VAFARRY,HL("Q"),HL("FS"),VALERR,ENCPTR)
+1 if (ERROR>0)
SET ERROR=0
+2 QUIT
VLDZSP SET ERROR=$$EN^SCMSVZSP(VAFZSP,HL("Q"),HL("FS"),VALERR,DFN)
+1 if (ERROR>0)
SET ERROR=0
+2 QUIT
VLDROL SET ERROR=$$EN^SCMSVROL(VAFARRY,HL("Q"),HL("FS"),HL("ECH"),VALERR)
+1 if (ERROR>0)
SET ERROR=0
+2 QUIT
VLDPD1 SET ERROR=0
+1 QUIT
VLDZEN SET ERROR=0
+1 QUIT
+2 ;
+3 ;-- Line tags for copying HL7 segments into HL7 message
CPYEVN NEW I
+1 SET @XMITARRY@(CURLINE)=VAFEVN
+2 SET LINESADD=LINESADD+1
+3 SET I=""
+4 FOR
SET I=+$ORDER(VAFEVN(I))
if ('I)
QUIT
Begin DoDot:1
+5 SET @XMITARRY@(CURLINE,I)=VAFEVN(I)
+6 SET LINESADD=LINESADD+1
End DoDot:1
+7 QUIT
CPYPID NEW I
+1 SET @XMITARRY@(CURLINE)=VAFPID
+2 SET LINESADD=LINESADD+1
+3 SET I=""
+4 FOR
SET I=+$ORDER(VAFPID(I))
if ('I)
QUIT
Begin DoDot:1
+5 SET @XMITARRY@(CURLINE,I)=VAFPID(I)
+6 SET LINESADD=LINESADD+1
End DoDot:1
+7 QUIT
CPYZPD NEW I
+1 SET @XMITARRY@(CURLINE)=VAFZPD
+2 SET LINESADD=LINESADD+1
+3 SET I=""
+4 FOR
SET I=+$ORDER(VAFZPD(I))
if ('I)
QUIT
Begin DoDot:1
+5 SET @XMITARRY@(CURLINE,I)=VAFZPD(I)
+6 SET LINESADD=LINESADD+1
End DoDot:1
+7 QUIT
CPYPV1 NEW I
+1 SET @XMITARRY@(CURLINE)=VAFPV1
+2 SET LINESADD=LINESADD+1
+3 SET I=""
+4 FOR
SET I=+$ORDER(VAFPV1(I))
if ('I)
QUIT
Begin DoDot:1
+5 SET @XMITARRY@(CURLINE,I)=VAFPV1(I)
+6 SET LINESADD=LINESADD+1
End DoDot:1
+7 QUIT
CPYDG1 NEW I,J,K
+1 SET I=""
+2 FOR K=0:1
SET I=+$ORDER(@VAFARRY@(I))
if ('I)
QUIT
Begin DoDot:1
+3 SET J=""
+4 FOR
SET J=$ORDER(@VAFARRY@(I,J))
if (J="")
QUIT
Begin DoDot:2
+5 if ('J)
SET @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J)
+6 if (J)
SET @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J)
+7 SET LINESADD=LINESADD+1
End DoDot:2
End DoDot:1
+8 SET CURLINE=CURLINE+K-1
+9 QUIT
CPYPR1 NEW I,J,K
+1 SET I=""
+2 FOR K=0:1
SET I=+$ORDER(@VAFARRY@(I))
if ('I)
QUIT
Begin DoDot:1
+3 SET J=""
+4 FOR
SET J=$ORDER(@VAFARRY@(I,J))
if (J="")
QUIT
Begin DoDot:2
+5 if ('J)
SET @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J)
+6 if (J)
SET @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J)
+7 SET LINESADD=LINESADD+1
End DoDot:2
End DoDot:1
+8 SET CURLINE=CURLINE+K-1
+9 QUIT
CPYZEL NEW I
+1 SET @XMITARRY@(CURLINE)=VAFZEL(1)
+2 SET LINESADD=LINESADD+1
+3 SET I=""
+4 FOR
SET I=+$ORDER(VAFZEL(1,I))
if ('I)
QUIT
Begin DoDot:1
+5 SET @XMITARRY@(CURLINE,I)=VAFZEL(1,I)
+6 SET LINESADD=LINESADD+1
End DoDot:1
+7 QUIT
CPYZIR NEW I
+1 SET @XMITARRY@(CURLINE)=VAFZIR
+2 SET LINESADD=LINESADD+1
+3 NEW I
+4 SET I=""
+5 FOR
SET I=+$ORDER(VAFZIR(I))
if ('I)
QUIT
Begin DoDot:1
+6 SET @XMITARRY@(CURLINE,I)=VAFZIR(I)
+7 SET LINESADD=LINESADD+1
End DoDot:1
+8 QUIT
CPYZCL NEW I,J,K
+1 SET I=""
+2 FOR K=0:1
SET I=+$ORDER(@VAFARRY@(I))
if ('I)
QUIT
Begin DoDot:1
+3 SET J=""
+4 FOR
SET J=$ORDER(@VAFARRY@(I,J))
if (J="")
QUIT
Begin DoDot:2
+5 if ('J)
SET @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J)
+6 if (J)
SET @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J)
+7 SET LINESADD=LINESADD+1
End DoDot:2
End DoDot:1
+8 SET CURLINE=CURLINE+K-1
+9 QUIT
CPYZSC NEW I,J,K
+1 SET I=""
+2 FOR K=0:1
SET I=+$ORDER(@VAFARRY@(I))
if ('I)
QUIT
Begin DoDot:1
+3 SET J=""
+4 FOR
SET J=$ORDER(@VAFARRY@(I,J))
if (J="")
QUIT
Begin DoDot:2
+5 if ('J)
SET @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J)
+6 if (J)
SET @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J)
+7 SET LINESADD=LINESADD+1
End DoDot:2
End DoDot:1
+8 SET CURLINE=CURLINE+K-1
+9 QUIT
CPYZSP NEW I
+1 SET @XMITARRY@(CURLINE)=VAFZSP
+2 SET LINESADD=LINESADD+1
+3 SET I=""
+4 FOR
SET I=+$ORDER(VAFZSP(I))
if ('I)
QUIT
Begin DoDot:1
+5 SET @XMITARRY@(CURLINE,I)=VAFZSP(I)
+6 SET LINESADD=LINESADD+1
End DoDot:1
+7 QUIT
CPYROL NEW I,J,K
+1 SET I=""
+2 FOR K=0:1
SET I=+$ORDER(@VAFARRY@(I))
if ('I)
QUIT
Begin DoDot:1
+3 SET J=""
+4 FOR
SET J=$ORDER(@VAFARRY@(I,J))
if (J="")
QUIT
Begin DoDot:2
+5 if ('J)
SET @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J)
+6 if (J)
SET @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J)
+7 SET LINESADD=LINESADD+1
End DoDot:2
End DoDot:1
+8 SET CURLINE=CURLINE+K-1
+9 QUIT
CPYPD1 NEW I
+1 SET @XMITARRY@(CURLINE)=VAFPD1
+2 SET LINESADD=LINESADD+1
+3 SET I=""
+4 FOR
SET I=+$ORDER(VAFPD1(I))
if ('I)
QUIT
Begin DoDot:1
+5 SET @XMITARRY@(CURLINE,I)=VAFPD1(I)
+6 SET LINESADD=LINESADD+1
End DoDot:1
+7 QUIT
CPYZEN NEW I
+1 SET @XMITARRY@(CURLINE)=VAFZEN
+2 SET LINESADD=LINESADD+1
+3 SET I=""
+4 FOR
SET I=+$ORDER(VAFZEN(I))
if ('I)
QUIT
Begin DoDot:1
+5 SET @XMITARRY@(CURLINE,I)=VAFZEN(I)
+6 SET LINESADD=LINESADD+1
End DoDot:1
+7 QUIT
+8 ;
+9 ;-- Line tags for deleting HL7 segments
DELEVN KILL VAFEVN
+1 QUIT
DELPID KILL VAFPID
+1 QUIT
DELZPD KILL VAFZPD
+1 QUIT
DELPV1 KILL VAFPV1
+1 QUIT
DELDG1 KILL @VAFARRY
+1 QUIT
DELPR1 KILL @VAFARRY
+1 QUIT
DELZEL KILL VAFZEL
+1 QUIT
DELZIR KILL VAFZIR
+1 QUIT
DELZCL KILL @VAFARRY
+1 QUIT
DELZSC KILL @VAFARRY
+1 QUIT
DELZSP KILL VAFZSP
+1 QUIT
DELROL KILL @VAFARRY
+1 QUIT
DELPD1 KILL VAFPD1
+1 QUIT
DELZEN KILL VAFZEN
+1 QUIT
+2 ;
+3 ;
SEGMENTS(EVNTTYPE,SEGARRY) ;Build list of HL7 segments for a given
+1 ; event type
+2 ;
+3 ;Input : EVNTTYPE - Event type to build list for
+4 ; A08 & A23 are the only types currently supported
+5 ; (Defaults to A08)
+6 ; SEGARRY - Array to place output in (full global reference)
+7 ; (Defaults to ^TMP("SCDX SEGMENTS",$J))
+8 ;Output : None
+9 ; SEGARRY(Seq,Name) = Fields
+10 ; Seq - Sequencing number to order the segments as
+11 ; they should be placed in the HL7 message
+12 ; Name - Name of HL7 segment
+13 ; Fields - List of fields used by Ambulatory Care
+14 ; VAFSTR would be set to this value
+15 ; : MSH segment is not included
+16 ;
+17 ;Check input
+18 SET EVNTTYPE=$GET(EVNTTYPE)
+19 if (EVNTTYPE'="A23")
SET EVNTTYPE="A08"
+20 SET SEGARRY=$GET(SEGARRY)
+21 if (SEGARRY="")
SET SEGARRY="^TMP(""SCDX SEGMENTS"","_$JOB_")"
+22 ;Segments used by A08 & A23
+23 SET @SEGARRY@(1,"EVN")="1,2"
+24 SET @SEGARRY@(2,"PID")="1,2,3,4,5,6,7,8,10,11,13,14,16,17,19,22"
+25 SET @SEGARRY@(3,"PD1")="3,4"
+26 SET @SEGARRY@(4,"PV1")="1,2,4,14,19,39,44,50"
+27 ;Building list for A23 - add ZPD segment and quit
+28 IF (EVNTTYPE="A23")
Begin DoDot:1
+29 SET @SEGARRY@(5,"ZPD")="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,40"
End DoDot:1
QUIT
+30 SET @SEGARRY@(5,"DG1")="1,2,3,4,5,15"
+31 SET @SEGARRY@(6,"PR1")="1,3,16"
+32 SET @SEGARRY@(7,"ROL")="1,2,3,4"
+33 SET @SEGARRY@(8,"ZPD")="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,40"
+34 SET @SEGARRY@(9,"ZEL")="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,29,37,38,40"
+35 SET @SEGARRY@(10,"ZIR")="1,2,3,4,5,6,7,8,9,10,11,12,13"
+36 SET @SEGARRY@(11,"ZCL")="1,2,3"
+37 SET @SEGARRY@(12,"ZSC")="1,2,3"
+38 SET @SEGARRY@(13,"ZSP")="1,2,3,4"
+39 SET @SEGARRY@(14,"ZEN")="1,2,3,4,5,6,7,8,9,10"
+40 QUIT
+41 ;
UNWIND(XMITARRY,INSRTPNT) ;Remove all data that was put into HL7 message
+1 ;
+2 ;Input : XMITARRY - Array containing HL7 message (full global ref)
+3 ; (Defaults to ^TMP("HLS",$J))
+4 ; INSRTPNT - Where to begin deletion from (Defaults to 1)
+5 ;Output : None
+6 ;
+7 ;Check input
+8 SET XMITARRY=$GET(XMITARRY)
+9 if (XMITARRY="")
SET XMITARRY="^TMP(""HLS"","_$JOB_")"
+10 SET INSRTPNT=$GET(INSRTPNT)
+11 if (INSRTPNT="")
SET INSRTPNT=1
+12 ;Remove insertion point from array
+13 KILL @XMITARRY@(INSRTPNT)
+14 ;Remove everything from insertion point to end of array
+15 FOR
SET INSRTPNT=$ORDER(@XMITARRY@(INSRTPNT))
if (INSRTPNT="")
QUIT
KILL @XMITARRY@(INSRTPNT)
+16 ;Done
+17 QUIT
