VAFHLZMH ;BAY/JAT,PJH,DJS - Create HL7 Military History seg. (ZMH) ;2 Nov 2017 7:16pm
;;5.3;Registration;**190,314,673,797,935**;Aug 13, 1993;Build 53
;
; This routine creates HL7 VA-specific Military History ("ZMH") segments
Q
;
EN(DFN,VAFHMIEN,VAFSTR) ; RAI/MDS Reserved entry point!!
; !!!!!!!!!! don't enter here !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
;DFN - Patient Internal Entry Number
;VAFHMIEN - Patient Movement Internal Entry Number
;VAFSTR - Sequence numbers to be included
;
N VAFHLREC,VAFHA,VAFHSUB,VAFHADD,VAFHLOC S VAFHSUB="" ;Initialize variables
S $P(VAFHLREC,HL("FS"))="ZMH" ;Set segment ID to ZMH
S $P(VAFHLREC,HL("FS"),2)=1 ;Set Set ID to 1
I VAFSTR[",4," D
.N EDATE,SDATE
.I '$D(^DPT(DFN,.3216)) D
..S EDATE=$$HLDATE^HLFNC($$GET1^DIQ(2,DFN,".326","I"))
..S SDATE=$$HLDATE^HLFNC($$GET1^DIQ(2,DFN,".327","I"))
.E D MSDSD
.S $P(VAFHLREC,HL("FS"),5)=EDATE_$E(HL("ECH"))_SDATE
Q VAFHLREC ;Quit and return formatted segment
;
MSDSD ;Returns last service separation date from ESR sourced data
N DA,DONE,EDATA
S EDATE="",SDATE="",DONE=0
F S EDATE=$O(^DPT(DFN,.3216,"B",""),-1) Q:'EDATE D Q:DONE
.S DA=$O(^DPT(DFN,.3216,"B",EDATE,0)) Q:'DA
.S EDATA=$G(^DPT(DFN,.3216,DA,0)) Q:EDATA=""
.S DONE=1
;
Q:'DONE
S EDATE=$$HLDATE^HLFNC(EDATE)
S SDATE=$$HLDATE^HLFNC($P(EDATA,U,2))
Q
;
ENTER(DFN,VAFARRAY,VAFTYPE,VAFSTR,VAFHLS,VAFHLC,VAFHLQ) ;
; DFN is the only required parameter. Defaults are used if no
; values are passed for the other parameters.
; Output:
; VAFARRAY = array name to hold the "ZMH" segments.
; Default is ^TMP("VAFHLZMH",$J)
; Input:
; DFN = internal entry number (IEN) of Patient (#2) file
; VAFTYPE = Military History type desired (separated by commas) where
; 1=Last Service branch (SL)
; 2=Next to last Service branch (SNL)
; 3=Next to next to last Service branch (SNNL)
; 4=Prisoner of War Status indicated? (POW)
; 5=Combat Service indicated? (COMB)
; 6=Vietnam Service indicated? (VIET)
; 7=Lebanon Service indicated? (LEBA)
; 8=Grenada Service indicated? (GREN)
; 9=Panama Service indicated? (PANA)
; 10=Persian Gulf Service indicated? (GULF)
; 11=Somalia Service indicated? (SOMA)
; 12=Yugoslavia Service indicated? (YUGO)
; 13=Purple Heart Receipient? (PH)
; 14=Operation Enduring/Iraqi Freedom (OEIF)
; A range of numbers separated by colons can be sent
; (e.g. 1:4,8,10:12)
; Default is all(1,2,3...)
;
; OR
;
; If value '*' is passed into the routine then the default
; is to return all military history and all military service
; episodes for the vet. Rather than using SL, SNL AND SNNL
; the ZMH type will be 'MSD'.
;
;
; VAFSTR = Fields (sequence numbers) desired (separated by comma) where
; 3=qualifier #1 (Service branch if VAFTYPE is 1,2 or 3
; or Yes/No response if VAFTYPE is 4 thru 13)
; qualifier #2 (Service number if VAFTYPE is 1,2 or 3
; or Location if VAFTYPE is 4 or 5)
; or
; qualifier #3 (Service discharge type if VAFTYPE is 1,2
; or 3)
; 4=From/To Date range for each VAFTYPE
; 5=Service Component
; Default is 3,4,5
; VAFHLS = HL7 field separator (1 character)
; Default is ^ (carrot)
; VAFHLC = HL7 encoding characters (4 characters must be supplied)
; Default is ~|\& (tilde bar backslash ampersand)
; VAFHLQ = HL7 null designation
; Default is "" (quote quote)
;
; Check input and apply default values as needed
S VAFARRAY=$G(VAFARRAY) I VAFARRAY="" S VAFARRAY=$NA(^TMP("VAFHLZMH",$J))
K @VAFARRAY
S VAFTYPE=$G(VAFTYPE)
I VAFTYPE="" S VAFTYPE="1,2,3,4,5,6,7,8,9,10,11,12,13,14"
S VAFSTR=$G(VAFSTR) I VAFSTR="" S VAFSTR="3,4,5"
S VAFHLS=$G(VAFHLS) I VAFHLS="" S VAFHLS="^"
S:($L(VAFHLS)'=1) VAFHLS="^"
S VAFHLC=$G(VAFHLC) I VAFHLC="" S VAFHLC="~|\&"
S:($L(VAFHLC)'=4) VAFHLC="~|\&"
S:('$D(VAFHLQ)) VAFHLQ=$C(34,34)
I '$G(DFN) D NOGO Q
I '$D(^DPT(DFN,0)) D NOGO Q
S VAFSTR=$TR(VAFSTR,":",",")
I VAFSTR'=3,VAFSTR'=4,VAFSTR'=5,VAFSTR'="3,4",VAFSTR'="3,5",VAFSTR'="4,5",VAFSTR'="3,4,5" D NOGO Q
S VAFSTR=","_VAFSTR_","
I VAFTYPE="*" S VAFTYPE="*,4,5,6,7,8,9,10,11,12,13,14"
E I '$$EDIT(VAFTYPE) D NOGO Q
I VAFTYPE[":" D UNCRUNCH
; it's a Go
N VAFY,VAFX,VAFZ,VAFINDX,VAFTAG
S VAFINDX=0
; set all the Patient file nodes that may be needed
N VAF32N,VAF321N,VAF322N,VAF52N,VAF53N,VAF3291N
S VAF321N=$G(^DPT(DFN,.321)) ; used for Vietnam
S VAF322N=$G(^DPT(DFN,.322)) ; used for minor skirmishes
S VAF52N=$G(^DPT(DFN,.52)) ; used for POW and Combat
S VAF53N=$G(^DPT(DFN,.53)) ;used for Purple Heart
I '$D(^DPT(DFN,.3216)) D
.S VAF32N=$G(^DPT(DFN,.32)) ; used for Service branches
.S VAF3291N=$G(^DPT(DFN,.3291)) ;used for service component
I $D(^DPT(DFN,.3216)),VAFTYPE'["*" D MSDS
;used for Operation Enduring/Iraqi Freedom
N VAFOPS,VAFREC,VAFSUB
S (VAFREC,VAFSUB)=0
;set operations into local array since there may be mult OEIF episodes
F S VAFREC=$O(^DPT(DFN,.3215,VAFREC)) Q:'$G(VAFREC) D
. S VAFSUB=VAFSUB+1
. S VAFOPS(VAFSUB)=$G(^DPT(DFN,.3215,VAFREC,0))
;
D ENTER^VAFHLZM1
;
Q
;
MSDS ;Returns latest service episodes from ESR sourced data
;
;*** the number of episodes is unlimited ****
;
N BRANCH,COUNT,COMP,DA,DONE,DTYP,EDATA,EDATE,SDATE,SERVNO,SUB
S COUNT=0,EDATE="",VAF32N="",VAF3291N=""
;Scan back for three most recent service episodes
F S EDATE=$O(^DPT(DFN,.3216,"B",EDATE),-1) Q:'EDATE D Q:COUNT'<3
.S DA=$O(^DPT(DFN,.3216,"B",EDATE,0)) Q:'DA
.S EDATA=$G(^DPT(DFN,.3216,DA,0)) Q:EDATA=""
.;DJS, skip an MSE that has a Future Discharge Date; DG*5.3*935
.Q:$P(EDATA,U,8)'=""
.S COUNT=COUNT+1,SDATE=$P(EDATA,U,2)
.S BRANCH=$P(EDATA,U,3),COMP=$P(EDATA,U,4)
.S SERVNO=$P(EDATA,U,5),DTYP=$P(EDATA,U,6)
.;SL = 4, SNL = 9 or SNNL = 14
.S SUB=(COUNT*5)-1
.S $P(VAF32N,U,SUB)=DTYP
.S $P(VAF32N,U,SUB+1)=BRANCH
.S $P(VAF32N,U,SUB+2)=EDATE
.S $P(VAF32N,U,SUB+3)=SDATE
.S $P(VAF32N,U,SUB+4)=SERVNO
.S $P(VAF3291N,U,COUNT)=COMP
Q
;
EDIT(X) ; function validates VAFTYP (returns 1 if valid)
N P,Q,R,CNT,Z,Z1,Z2,ERR S ERR=0
S X=$G(X)
I X>0,X<15,X?.N Q 1 ; only 1 number and between 1-14
I X'[":",X'["," Q 0 ; comma not used as separator
I X'?.NP Q 0 ; contains letters or control characters
; contains punctuation other than comma/colon
S P="!#$%&'()*+-./;<=>?@[\]^_`{|]~"
F CNT=1:1 S Z=$E(X,CNT) Q:Z="" I P[Z S ERR=1 Q
I ERR=1 Q 0
S Q="",R=""""
I Q[X!R[X Q 0
; checks that numbers are >0<15
F CNT=1:1 S Z=$P(X,",",CNT) Q:Z="" D
.I Z'[":",Z>0,Z<15 Q
.S Z1=$P(Z,":",1),Z2=$P(Z,":",2)
.I Z1>0,Z1<15,Z2>0,Z2<15 Q
.S ERR=1
I ERR=1 Q 0
Q 1
;
UNCRUNCH ; reformat VAFTYPE by translating any range of numbers,
; for example replace "1:3,6,9:11" by "1,2,3,6,9,10,11,"
N X,Y,Z,A,B S Y=""
F X=1:1 S Z=$P(VAFTYPE,",",X) Q:Z="" D
.I Z'[":" S Y=Y_Z_"," Q
.S A=$P(Z,":",1),B=$P(Z,":",2)
.S Y=Y_A_","
.F S A=A+1 Q:A>B S Y=Y_A_","
S VAFTYPE=Y
Q
NOGO ;
S @VAFARRAY@(1,0)="ZMH"_VAFHLS_1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFHLZMH 7461 printed Apr 09, 2024@21:53:35 Page 2
VAFHLZMH ;BAY/JAT,PJH,DJS - Create HL7 Military History seg. (ZMH) ;2 Nov 2017 7:16pm
+1 ;;5.3;Registration;**190,314,673,797,935**;Aug 13, 1993;Build 53
+2 ;
+3 ; This routine creates HL7 VA-specific Military History ("ZMH") segments
+4 QUIT
+5 ;
EN(DFN,VAFHMIEN,VAFSTR) ; RAI/MDS Reserved entry point!!
+1 ; !!!!!!!!!! don't enter here !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+2 ;DFN - Patient Internal Entry Number
+3 ;VAFHMIEN - Patient Movement Internal Entry Number
+4 ;VAFSTR - Sequence numbers to be included
+5 ;
+6 ;Initialize variables
NEW VAFHLREC,VAFHA,VAFHSUB,VAFHADD,VAFHLOC
SET VAFHSUB=""
+7 ;Set segment ID to ZMH
SET $PIECE(VAFHLREC,HL("FS"))="ZMH"
+8 ;Set Set ID to 1
SET $PIECE(VAFHLREC,HL("FS"),2)=1
+9 IF VAFSTR[",4,"
Begin DoDot:1
+10 NEW EDATE,SDATE
+11 IF '$DATA(^DPT(DFN,.3216))
Begin DoDot:2
+12 SET EDATE=$$HLDATE^HLFNC($$GET1^DIQ(2,DFN,".326","I"))
+13 SET SDATE=$$HLDATE^HLFNC($$GET1^DIQ(2,DFN,".327","I"))
End DoDot:2
+14 IF '$TEST
DO MSDSD
+15 SET $PIECE(VAFHLREC,HL("FS"),5)=EDATE_$EXTRACT(HL("ECH"))_SDATE
End DoDot:1
+16 ;Quit and return formatted segment
QUIT VAFHLREC
+17 ;
MSDSD ;Returns last service separation date from ESR sourced data
+1 NEW DA,DONE,EDATA
+2 SET EDATE=""
SET SDATE=""
SET DONE=0
+3 FOR
SET EDATE=$ORDER(^DPT(DFN,.3216,"B",""),-1)
if 'EDATE
QUIT
Begin DoDot:1
+4 SET DA=$ORDER(^DPT(DFN,.3216,"B",EDATE,0))
if 'DA
QUIT
+5 SET EDATA=$GET(^DPT(DFN,.3216,DA,0))
if EDATA=""
QUIT
+6 SET DONE=1
End DoDot:1
if DONE
QUIT
+7 ;
+8 if 'DONE
QUIT
+9 SET EDATE=$$HLDATE^HLFNC(EDATE)
+10 SET SDATE=$$HLDATE^HLFNC($PIECE(EDATA,U,2))
+11 QUIT
+12 ;
ENTER(DFN,VAFARRAY,VAFTYPE,VAFSTR,VAFHLS,VAFHLC,VAFHLQ) ;
+1 ; DFN is the only required parameter. Defaults are used if no
+2 ; values are passed for the other parameters.
+3 ; Output:
+4 ; VAFARRAY = array name to hold the "ZMH" segments.
+5 ; Default is ^TMP("VAFHLZMH",$J)
+6 ; Input:
+7 ; DFN = internal entry number (IEN) of Patient (#2) file
+8 ; VAFTYPE = Military History type desired (separated by commas) where
+9 ; 1=Last Service branch (SL)
+10 ; 2=Next to last Service branch (SNL)
+11 ; 3=Next to next to last Service branch (SNNL)
+12 ; 4=Prisoner of War Status indicated? (POW)
+13 ; 5=Combat Service indicated? (COMB)
+14 ; 6=Vietnam Service indicated? (VIET)
+15 ; 7=Lebanon Service indicated? (LEBA)
+16 ; 8=Grenada Service indicated? (GREN)
+17 ; 9=Panama Service indicated? (PANA)
+18 ; 10=Persian Gulf Service indicated? (GULF)
+19 ; 11=Somalia Service indicated? (SOMA)
+20 ; 12=Yugoslavia Service indicated? (YUGO)
+21 ; 13=Purple Heart Receipient? (PH)
+22 ; 14=Operation Enduring/Iraqi Freedom (OEIF)
+23 ; A range of numbers separated by colons can be sent
+24 ; (e.g. 1:4,8,10:12)
+25 ; Default is all(1,2,3...)
+26 ;
+27 ; OR
+28 ;
+29 ; If value '*' is passed into the routine then the default
+30 ; is to return all military history and all military service
+31 ; episodes for the vet. Rather than using SL, SNL AND SNNL
+32 ; the ZMH type will be 'MSD'.
+33 ;
+34 ;
+35 ; VAFSTR = Fields (sequence numbers) desired (separated by comma) where
+36 ; 3=qualifier #1 (Service branch if VAFTYPE is 1,2 or 3
+37 ; or Yes/No response if VAFTYPE is 4 thru 13)
+38 ; qualifier #2 (Service number if VAFTYPE is 1,2 or 3
+39 ; or Location if VAFTYPE is 4 or 5)
+40 ; or
+41 ; qualifier #3 (Service discharge type if VAFTYPE is 1,2
+42 ; or 3)
+43 ; 4=From/To Date range for each VAFTYPE
+44 ; 5=Service Component
+45 ; Default is 3,4,5
+46 ; VAFHLS = HL7 field separator (1 character)
+47 ; Default is ^ (carrot)
+48 ; VAFHLC = HL7 encoding characters (4 characters must be supplied)
+49 ; Default is ~|\& (tilde bar backslash ampersand)
+50 ; VAFHLQ = HL7 null designation
+51 ; Default is "" (quote quote)
+52 ;
+53 ; Check input and apply default values as needed
+54 SET VAFARRAY=$GET(VAFARRAY)
IF VAFARRAY=""
SET VAFARRAY=$NAME(^TMP("VAFHLZMH",$JOB))
+55 KILL @VAFARRAY
+56 SET VAFTYPE=$GET(VAFTYPE)
+57 IF VAFTYPE=""
SET VAFTYPE="1,2,3,4,5,6,7,8,9,10,11,12,13,14"
+58 SET VAFSTR=$GET(VAFSTR)
IF VAFSTR=""
SET VAFSTR="3,4,5"
+59 SET VAFHLS=$GET(VAFHLS)
IF VAFHLS=""
SET VAFHLS="^"
+60 if ($LENGTH(VAFHLS)'=1)
SET VAFHLS="^"
+61 SET VAFHLC=$GET(VAFHLC)
IF VAFHLC=""
SET VAFHLC="~|\&"
+62 if ($LENGTH(VAFHLC)'=4)
SET VAFHLC="~|\&"
+63 if ('$DATA(VAFHLQ))
SET VAFHLQ=$CHAR(34,34)
+64 IF '$GET(DFN)
DO NOGO
QUIT
+65 IF '$DATA(^DPT(DFN,0))
DO NOGO
QUIT
+66 SET VAFSTR=$TRANSLATE(VAFSTR,":",",")
+67 IF VAFSTR'=3
IF VAFSTR'=4
IF VAFSTR'=5
IF VAFSTR'="3,4"
IF VAFSTR'="3,5"
IF VAFSTR'="4,5"
IF VAFSTR'="3,4,5"
DO NOGO
QUIT
+68 SET VAFSTR=","_VAFSTR_","
+69 IF VAFTYPE="*"
SET VAFTYPE="*,4,5,6,7,8,9,10,11,12,13,14"
+70 IF '$TEST
IF '$$EDIT(VAFTYPE)
DO NOGO
QUIT
+71 IF VAFTYPE[":"
DO UNCRUNCH
+72 ; it's a Go
+73 NEW VAFY,VAFX,VAFZ,VAFINDX,VAFTAG
+74 SET VAFINDX=0
+75 ; set all the Patient file nodes that may be needed
+76 NEW VAF32N,VAF321N,VAF322N,VAF52N,VAF53N,VAF3291N
+77 ; used for Vietnam
SET VAF321N=$GET(^DPT(DFN,.321))
+78 ; used for minor skirmishes
SET VAF322N=$GET(^DPT(DFN,.322))
+79 ; used for POW and Combat
SET VAF52N=$GET(^DPT(DFN,.52))
+80 ;used for Purple Heart
SET VAF53N=$GET(^DPT(DFN,.53))
+81 IF '$DATA(^DPT(DFN,.3216))
Begin DoDot:1
+82 ; used for Service branches
SET VAF32N=$GET(^DPT(DFN,.32))
+83 ;used for service component
SET VAF3291N=$GET(^DPT(DFN,.3291))
End DoDot:1
+84 IF $DATA(^DPT(DFN,.3216))
IF VAFTYPE'["*"
DO MSDS
+85 ;used for Operation Enduring/Iraqi Freedom
+86 NEW VAFOPS,VAFREC,VAFSUB
+87 SET (VAFREC,VAFSUB)=0
+88 ;set operations into local array since there may be mult OEIF episodes
+89 FOR
SET VAFREC=$ORDER(^DPT(DFN,.3215,VAFREC))
if '$GET(VAFREC)
QUIT
Begin DoDot:1
+90 SET VAFSUB=VAFSUB+1
+91 SET VAFOPS(VAFSUB)=$GET(^DPT(DFN,.3215,VAFREC,0))
End DoDot:1
+92 ;
+93 DO ENTER^VAFHLZM1
+94 ;
+95 QUIT
+96 ;
MSDS ;Returns latest service episodes from ESR sourced data
+1 ;
+2 ;*** the number of episodes is unlimited ****
+3 ;
+4 NEW BRANCH,COUNT,COMP,DA,DONE,DTYP,EDATA,EDATE,SDATE,SERVNO,SUB
+5 SET COUNT=0
SET EDATE=""
SET VAF32N=""
SET VAF3291N=""
+6 ;Scan back for three most recent service episodes
+7 FOR
SET EDATE=$ORDER(^DPT(DFN,.3216,"B",EDATE),-1)
if 'EDATE
QUIT
Begin DoDot:1
+8 SET DA=$ORDER(^DPT(DFN,.3216,"B",EDATE,0))
if 'DA
QUIT
+9 SET EDATA=$GET(^DPT(DFN,.3216,DA,0))
if EDATA=""
QUIT
+10 ;DJS, skip an MSE that has a Future Discharge Date; DG*5.3*935
+11 if $PIECE(EDATA,U,8)'=""
QUIT
+12 SET COUNT=COUNT+1
SET SDATE=$PIECE(EDATA,U,2)
+13 SET BRANCH=$PIECE(EDATA,U,3)
SET COMP=$PIECE(EDATA,U,4)
+14 SET SERVNO=$PIECE(EDATA,U,5)
SET DTYP=$PIECE(EDATA,U,6)
+15 ;SL = 4, SNL = 9 or SNNL = 14
+16 SET SUB=(COUNT*5)-1
+17 SET $PIECE(VAF32N,U,SUB)=DTYP
+18 SET $PIECE(VAF32N,U,SUB+1)=BRANCH
+19 SET $PIECE(VAF32N,U,SUB+2)=EDATE
+20 SET $PIECE(VAF32N,U,SUB+3)=SDATE
+21 SET $PIECE(VAF32N,U,SUB+4)=SERVNO
+22 SET $PIECE(VAF3291N,U,COUNT)=COMP
End DoDot:1
if COUNT'<3
QUIT
+23 QUIT
+24 ;
EDIT(X) ; function validates VAFTYP (returns 1 if valid)
+1 NEW P,Q,R,CNT,Z,Z1,Z2,ERR
SET ERR=0
+2 SET X=$GET(X)
+3 ; only 1 number and between 1-14
IF X>0
IF X<15
IF X?.N
QUIT 1
+4 ; comma not used as separator
IF X'[":"
IF X'[","
QUIT 0
+5 ; contains letters or control characters
IF X'?.NP
QUIT 0
+6 ; contains punctuation other than comma/colon
+7 SET P="!#$%&'()*+-./;<=>?@[\]^_`{|]~"
+8 FOR CNT=1:1
SET Z=$EXTRACT(X,CNT)
if Z=""
QUIT
IF P[Z
SET ERR=1
QUIT
+9 IF ERR=1
QUIT 0
+10 SET Q=""
SET R=""""
+11 IF Q[X!R[X
QUIT 0
+12 ; checks that numbers are >0<15
+13 FOR CNT=1:1
SET Z=$PIECE(X,",",CNT)
if Z=""
QUIT
Begin DoDot:1
+14 IF Z'[":"
IF Z>0
IF Z<15
QUIT
+15 SET Z1=$PIECE(Z,":",1)
SET Z2=$PIECE(Z,":",2)
+16 IF Z1>0
IF Z1<15
IF Z2>0
IF Z2<15
QUIT
+17 SET ERR=1
End DoDot:1
+18 IF ERR=1
QUIT 0
+19 QUIT 1
+20 ;
UNCRUNCH ; reformat VAFTYPE by translating any range of numbers,
+1 ; for example replace "1:3,6,9:11" by "1,2,3,6,9,10,11,"
+2 NEW X,Y,Z,A,B
SET Y=""
+3 FOR X=1:1
SET Z=$PIECE(VAFTYPE,",",X)
if Z=""
QUIT
Begin DoDot:1
+4 IF Z'[":"
SET Y=Y_Z_","
QUIT
+5 SET A=$PIECE(Z,":",1)
SET B=$PIECE(Z,":",2)
+6 SET Y=Y_A_","
+7 FOR
SET A=A+1
if A>B
QUIT
SET Y=Y_A_","
End DoDot:1
+8 SET VAFTYPE=Y
+9 QUIT
NOGO ;
+1 SET @VAFARRAY@(1,0)="ZMH"_VAFHLS_1
+2 QUIT
