SCMSVUT0 ;ALB/ESD HL7 Segment Validation Utilities ; 7/8/04 5:06pm
;;5.3;PIMS;**44,55,66,132,245,254,293,345,472,441,551,1015,1016**;JUN 30, 2012;Build 20
;
;
CONVERT(SEG,HLFS,HLQ) ; Convert HLQ ("") to null in segment
; Input: SEG = HL7 segment
; HLFS = HL7 field separator
; HLQ = HL7 "" character
;
; Output: SEG = Segment where HLQ replaced with null
;
;
N I
F I=1:1:55 I $P(SEG,HLFS,I)=HLQ S $P(SEG,HLFS,I)=""
Q SEG
;
SETID(SDOE,SDDELOE) ; Set PCE Unique Visit Number in field #.2 of #409.68
; Input: SDOE = IEN of Outpatient Encounter (#409.68) file
; SDDELOE = IEN of Deleted Outpatient Encounter (#409.74) file
;
; Output: Unique Visit Number set in field #.2 of #409.68
; or field #.2 of #409.74
;
;
N SDOEC,SDARRY
S SDOEC=0
S SDOE=+$G(SDOE)
S SDDELOE=+$G(SDDELOE)
;
;-Outpatient Enc pointer passed in; use file #409.68
S SDARRY="^SCE("_SDOE_",0)"
;
;-Deleted Outpatient Enc pointer passed in; use file #409.74
S:(SDDELOE) SDARRY="^SD(409.74,"_SDDELOE_",1)"
;
;-Quit if no encounter record or deleted encounter record
Q:($G(@SDARRY)="")
;-Add unique ID to parent
D GETID
;
;-Add unique ID to children for Outpatient Enc only (quit if no child encounter record)
I (SDOE) F S SDOEC=+$O(^SCE("APAR",SDOE,SDOEC)) Q:'SDOEC S SDARRY="^SCE("_SDOEC_",0)" Q:($G(@SDARRY)="") D GETID
Q
;
GETID ;Get unique visit ID
S:$P($G(@SDARRY),"^",20)="" $P(@SDARRY,"^",20)=$$IEN2VID^VSIT($P(@SDARRY,"^",5))
Q
;
SETPRTY(SDOE) ;Set outpatient provider type in field #.06 of V PROVIDER
; Input: SDOE = IEN of Outpatient Encounter (#409.68) file
;
; Output: Provider Type set in field #.06 of V PROVIDER
;
;
N SDPRTYP,SDVPRV,SDPRVS
S SDOE=+$G(SDOE),SDVPRV=0
;
;- Get all provider IENs for encounter
D GETPRV^SDOE(SDOE,"SDPRVS")
F S SDVPRV=+$O(SDPRVS(SDVPRV)) Q:'SDVPRV D
. S SDPRTYP=0
. ;
. ;- If no prov type, call API and add provider type to record
. S:$P(SDPRVS(SDVPRV),"^",6)="" SDPRTYP=$$GET^XUA4A72(+SDPRVS(SDVPRV),+$G(^SCE(SDOE,0)))
. I +$G(SDPRTYP)>0 D PCLASS^PXAPIOE(SDVPRV)
Q
;
SETMAR(PIDSEG,HLQ,HLFS,HLECH) ; Set marital status prior to PID segment validation
;Input: PIDSEG = Array containing PID segment (pass by reference)
; PIDSEG = First 245 characters
; PIDSEG(1..n) = Continuation nodes
; HLQ = HL7 null variable
; HLFS = HL7 field separator
; HLECH = HL7 encoding characters (VAFCQRY1 call)
;Output: Marital status changed from null to "U" (UNKNOWN) prior to
; validation of PID segment and transmittal to AAC
;Note: Assumes all input exists and is valid
;
;Declare variables
N REBLD,TMPARR,X,TMPARR3,TMPARR5,TMPARR11
;Parse segment
D SEGPRSE^SCMSVUT5($NA(PIDSEG),"TMPARR",HLFS)
;Change marital status (if needed)
S REBLD=0
S X=$G(TMPARR(16))
I ((X="")!(X=HLQ)) S TMPARR(16)="U",REBLD=1
I $D(HLECH) D Q ;from SCDXMSG1 (VAFCQRY call)
. ;Change religion (if needed)
. S X=$G(TMPARR(17))
. I ((X="")!(X=HLQ)) S TMPARR(17)=29
. ;Rebuild segment (due to VAFCQRY call building seg. array)
. ;VAFCQRY Seqs 3,5,11 needs to be broken down - too long for rebuild
. K TMPARR(0),PIDSEG
. D SEQPRSE^SCMSVUT5($NA(TMPARR(3)),"TMPARR3",HLECH)
. D SEQPRSE^SCMSVUT5($NA(TMPARR(5)),"TMPARR5",HLECH)
. D SEQPRSE^SCMSVUT5($NA(TMPARR(11)),"TMPARR11",HLECH)
. K TMPARR(3) M TMPARR(3)=TMPARR3
. K TMPARR(5) M TMPARR(5)=TMPARR5
. K TMPARR(11) M TMPARR(11)=TMPARR11
. D MAKEIT^VAFHLU("PID",.TMPARR,.PIDSEG,.PIDSEG)
I REBLD K TMPARR(0),PIDSEG D MAKEIT^VAFHLU("PID",.TMPARR,.PIDSEG,.PIDSEG)
Q
;
SETPOW(DFN,ZPDSEG,HLQ,HLFS) ; Set POW Status Indicated field prior to ZPD segment validation
;
; Input: DFN = IEN of Patient (#2) file
; ZPDSEG = Array containing ZPD segment (pass by reference)
; ZPDSEG = First 245 characters
; ZPDSEG(1..n) = Continuation nodes
; HLQ = HL7 null variable
; HLFS = HL7 field separator
;
; Output: If Veteran and POW Status Indicated field = null, set to
; U (Unknown)
; If Non-Veteran, set to null
;
S DFN=$G(DFN)
G SETPOWQ:(DFN="")!($G(ZPDSEG)="")
;Declare variables
N REBLD,TMPARR,X
;Parse segment
D SEGPRSE^SCMSVUT5($NA(ZPDSEG),"TMPARR",HLFS)
;Change POW status (if needed)
S REBLD=0
S X=$G(TMPARR(17))
I $P($G(^DPT(DFN,"VET")),"^")="Y",(X=""!(X=HLQ)) S TMPARR(17)="U",REBLD=1
I $P($G(^DPT(DFN,"VET")),"^")="N" S TMPARR(17)=HLQ,REBLD=1
;Rebuild segment (if needed)
I REBLD K TMPARR(0),ZPDSEG D MAKEIT^VAFHLU("ZPD",.TMPARR,.ZPDSEG,.ZPDSEG)
;
SETPOWQ Q
;
;
SETVSI(DFN,ZSPSEG,HLQ,HLFS) ;Set Vietnam Service Indicated field prior to ZSP segment validation
;
; Input: DFN = IEN of Patient (#2) file
; ZSPSEG = HL7 ZSP segment
; HLQ = HL7 null variable
; HLFS = HL7 field separator
;
; Output: If Veteran and Vietnam Service Indicated field = null,
; set to U (Unknown)
; If Non-Veteran, set to null
;
S DFN=$G(DFN),ZSPSEG=$G(ZSPSEG)
G SETVSIQ:(DFN="")!(ZSPSEG="")
I $P($G(^DPT(DFN,"VET")),"^")="Y",($P(ZSPSEG,HLFS,6)=""!($P(ZSPSEG,HLFS,6)=HLQ)) S $P(ZSPSEG,HLFS,6)="U"
I $P($G(^DPT(DFN,"VET")),"^")="N" S $P(ZSPSEG,HLFS,6)=HLQ
;
SETVSIQ Q ZSPSEG
;
;
;
;The following subroutines all have to do with the validation of
;data using the same edit checks that are used by Austin.
;
HL7SEGNM(SEG,DATA) ;checks the validity of the HL7 segment name passed in.
;INPUT SEG - the HL7 segment name
; DATA - the data to compare. In this case the HL7 segment name.
;
;OUTPUT 0 (ZERO) if not validate
; 1 if validated
;
I '$D(SEG)!('$D(DATA)) Q 0
Q $S(SEG=DATA:1,1:0)
;
EVTTYP(SEG,DATA) ;checks the event type of the segment passed in.
;INPUT SEG - The HL7 segment name in question
; DATA - The event type from the HL7 segment in question.
;
;OUTPUT 0 (ZERO) if not validate
; 1 if validated
;
I '$D(SEG)!('$D(DATA)) Q 0
I SEG="EVN"&(DATA="A08"!(DATA="A23")) Q 1
Q 0
;
EVTDTTM(DATA) ;Checks the date and time to ensure it is correct.
;INPUT DATA - this is the date and time in quesiton.
;
;OUTPUT 0 (ZERO) if not validate
; 1 if validated
;
I '$D(DATA) Q 0
N STRTDT,%DT,X,Y
S STRTDT=+$O(^SD(404.91,0))
S STRTDT=$P($G(^SD(404.91,STRTDT,"AMB")),U,2)
I 'STRTDT Q 0
S %DT="T",%DT(0)=STRTDT,X=DATA
D ^%DT
Q $S(Y=-1:0,1:1)
;
VALIDATE(SEG,DATA,ERRCOD,VALERR,CTR) ;
;
N ERRIEN,ERRCHK,RES
S ERRIEN=+$O(^SD(409.76,"B",ERRCOD,""))
I 'ERRIEN S @VALERR@(SEG,CTR)=ERRCOD D INCR Q
S ERRCHK=$G(^SD(409.76,ERRIEN,"CHK"))
I ERRCHK="" S @VALERR@(SEG,CTR)=ERRCOD D INCR Q
X ERRCHK
I 'RES S @VALERR@(SEG,CTR)=ERRCOD D INCR
Q
;
DFN(DATA) ;
;INPUT DATA - the DFN of the patient
;
I '$D(DATA) Q 0
I DATA=""!(DATA=0) Q 0
I DATA'?1.N.".".N Q 0
Q 1
;
PATNM(DATA) ;
;INPUT DATA - The name of the patient
;
I '$D(DATA) Q 0
I DATA="" Q 0
I DATA?.N.",".N Q 0
I DATA?1.C Q 0
Q 1
;
DOB(DATA,ENCDT) ;
;INPUT DATA - The DOB to be tested.
; ENCDT - The date/time of the encounter
;
N %DT,X,Y
I '$D(DATA) Q 0
I '$D(ENCDT) Q 0
I DATA'?1.N Q 0
S %DT="T",%DT(0)=-ENCDT,X=DATA
D ^%DT
Q $S(Y=-1:0,1:1)
;
SEX(DATA) ;
;INPUT DATA - The sex code to be validated
;
I '$D(DATA) Q 0
I "FMUO"'[DATA Q 0
Q 1
;
RACE(DATA) ;
;INPUT DATA - the race code to be validated (NNNN-C-XXX)
;
N VAL,MTHD
I '$D(DATA) Q 0
I DATA="" Q 1
S VAL=$P(DATA,"-",1,2)
S MTHD=$P(DATA,"-",3)
I VAL'?4N1"-"1N Q 0
I ",SLF,UNK,PRX,OBS,"'[MTHD Q 0
Q 1
;
STR1(DATA) ;
;INPUT DATA - Street address line 1
;
N LP,VAR
I '$D(DATA) Q 0
I DATA="" Q 0
I DATA?1.N Q 0
I DATA=" " Q 0
F LP=1:1:$L(DATA) S VAR=$E(DATA,LP,LP) I $A(VAR)>32,($A(VAR)<127) S LP="Y" Q
Q $S(LP="Y":1,1:0)
;
STR2(DATA) ;
;INPUT DATA - Street address line 2
I DATA?1.N Q 0
Q 1
;
CITY(DATA) ;
;INPUT DATA - The city code to be validated
;
I DATA="" Q 0
I DATA?1.N Q 0
Q 1
;
STATE(DATA) ;
;INPUT DATA - State code to be validated.
;
I '$D(DATA) Q 0
I DATA="" Q 0
I '$D(^DIC(5,"C",DATA)) Q 0
Q 1
;
ZIP(DATA) ;
;INPUT DATA - The zipo code to be validated
;
I '$D(DATA) Q 0
I $E(DATA,1,5)="00000" Q 0
I DATA'?5N."-".4N Q 0
Q 1
;
COUNTY(DATA,STATE) ;
;INPUT DATA - The county code to be validated
; STATE - STATE file IEN
;
I DATA="" Q 0
I STATE="" Q 0
I '$D(^DIC(5,+$G(STATE),1,"C",DATA)) Q 0
Q 1
;
MARITAL(DATA) ;
;INPUT DATA - The marital status code to be validated.
;
I $L(DATA)>1 Q 0
I "ADMSWU"'[DATA Q 0
Q 1
;
REL(DATA) ;
;INPUT DATA - The religion abbreviation to the validated
;
I '$D(DATA) Q 0
I DATA="" Q 0
I '$D(^DIC(13,"C",+DATA)) Q 0
Q 1
;
SSN(DATA,NOPCHK,NULLOK) ; SD*5.3*345 added optional parameter NULLOK
;INPUT DATA - The SSN to be validated
; NOPCHK - O = Check pseudo indicator (default)
; 1 = Don't check pseudo indicator
; NULLOK (optional) - 1 = Allow SSN to be null
; 2 = Don't allow null SSNs (default)
;
I $G(DATA)="" Q +$G(NULLOK) ; SD*5.3*345
I '$D(DATA) Q 0
N SSN,PSD
S SSN=$E(DATA,1,9),PSD=$E(DATA,10)
I SSN'?9N Q 0
I '$G(NOPCHK) I (PSD'=" "),(PSD'=""),(PSD'="P") Q 0
I $E(SSN,1,5)="00000" Q 0
Q 1
;
INCR ;increases the counter
S CTR=CTR+1
Q
;
REMOVE(SEG,ERR,VALERR,CNT) ;
;INPUT SEG - The segment being worked on
; VALERR - The array holding the information
; CNT - the counter to use
; ERR - error code to remove
;
N LP
F LP=1:1:CNT I $G(@VALERR@(SEG,LP))=ERR K @VALERR@(SEG,LP)
Q
;
DECR(CNT) ;
S CNT=CNT-1
Q
;
SCMSVUT0 ;ALB/ESD HL7 Segment Validation Utilities ; 7/8/04 5:06pm
+1 ;;5.3;PIMS;**44,55,66,132,245,254,293,345,472,441,551,1015,1016**;JUN 30, 2012;Build 20
+2 ;
+3 ;
CONVERT(SEG,HLFS,HLQ) ; Convert HLQ ("") to null in segment
+1 ; Input: SEG = HL7 segment
+2 ; HLFS = HL7 field separator
+3 ; HLQ = HL7 "" character
+4 ;
+5 ; Output: SEG = Segment where HLQ replaced with null
+6 ;
+7 ;
+8 NEW I
+9 FOR I=1:1:55
IF $PIECE(SEG,HLFS,I)=HLQ
SET $PIECE(SEG,HLFS,I)=""
+10 QUIT SEG
+11 ;
SETID(SDOE,SDDELOE) ; Set PCE Unique Visit Number in field #.2 of #409.68
+1 ; Input: SDOE = IEN of Outpatient Encounter (#409.68) file
+2 ; SDDELOE = IEN of Deleted Outpatient Encounter (#409.74) file
+3 ;
+4 ; Output: Unique Visit Number set in field #.2 of #409.68
+5 ; or field #.2 of #409.74
+6 ;
+7 ;
+8 NEW SDOEC,SDARRY
+9 SET SDOEC=0
+10 SET SDOE=+$GET(SDOE)
+11 SET SDDELOE=+$GET(SDDELOE)
+12 ;
+13 ;-Outpatient Enc pointer passed in; use file #409.68
+14 SET SDARRY="^SCE("_SDOE_",0)"
+15 ;
+16 ;-Deleted Outpatient Enc pointer passed in; use file #409.74
+17 IF (SDDELOE)
SET SDARRY="^SD(409.74,"_SDDELOE_",1)"
+18 ;
+19 ;-Quit if no encounter record or deleted encounter record
+20 IF ($GET(@SDARRY)="")
QUIT
+21 ;-Add unique ID to parent
+22 DO GETID
+23 ;
+24 ;-Add unique ID to children for Outpatient Enc only (quit if no child encounter record)
+25 IF (SDOE)
FOR
SET SDOEC=+$ORDER(^SCE("APAR",SDOE,SDOEC))
IF 'SDOEC
QUIT
SET SDARRY="^SCE("_SDOEC_",0)"
IF ($GET(@SDARRY)="")
QUIT
DO GETID
+26 QUIT
+27 ;
GETID ;Get unique visit ID
+1 IF $PIECE($GET(@SDARRY),"^",20)=""
SET $PIECE(@SDARRY,"^",20)=$$IEN2VID^VSIT($PIECE(@SDARRY,"^",5))
+2 QUIT
+3 ;
SETPRTY(SDOE) ;Set outpatient provider type in field #.06 of V PROVIDER
+1 ; Input: SDOE = IEN of Outpatient Encounter (#409.68) file
+2 ;
+3 ; Output: Provider Type set in field #.06 of V PROVIDER
+4 ;
+5 ;
+6 NEW SDPRTYP,SDVPRV,SDPRVS
+7 SET SDOE=+$GET(SDOE)
SET SDVPRV=0
+8 ;
+9 ;- Get all provider IENs for encounter
+10 DO GETPRV^SDOE(SDOE,"SDPRVS")
+11 FOR
SET SDVPRV=+$ORDER(SDPRVS(SDVPRV))
IF 'SDVPRV
QUIT
Begin DoDot:1
+12 SET SDPRTYP=0
+13 ;
+14 ;- If no prov type, call API and add provider type to record
+15 IF $PIECE(SDPRVS(SDVPRV),"^",6)=""
SET SDPRTYP=$$GET^XUA4A72(+SDPRVS(SDVPRV),+$GET(^SCE(SDOE,0)))
+16 IF +$GET(SDPRTYP)>0
DO PCLASS^PXAPIOE(SDVPRV)
End DoDot:1
+17 QUIT
+18 ;
SETMAR(PIDSEG,HLQ,HLFS,HLECH) ; Set marital status prior to PID segment validation
+1 ;Input: PIDSEG = Array containing PID segment (pass by reference)
+2 ; PIDSEG = First 245 characters
+3 ; PIDSEG(1..n) = Continuation nodes
+4 ; HLQ = HL7 null variable
+5 ; HLFS = HL7 field separator
+6 ; HLECH = HL7 encoding characters (VAFCQRY1 call)
+7 ;Output: Marital status changed from null to "U" (UNKNOWN) prior to
+8 ; validation of PID segment and transmittal to AAC
+9 ;Note: Assumes all input exists and is valid
+10 ;
+11 ;Declare variables
+12 NEW REBLD,TMPARR,X,TMPARR3,TMPARR5,TMPARR11
+13 ;Parse segment
+14 DO SEGPRSE^SCMSVUT5($NAME(PIDSEG),"TMPARR",HLFS)
+15 ;Change marital status (if needed)
+16 SET REBLD=0
+17 SET X=$GET(TMPARR(16))
+18 IF ((X="")!(X=HLQ))
SET TMPARR(16)="U"
SET REBLD=1
+19 ;from SCDXMSG1 (VAFCQRY call)
IF $DATA(HLECH)
Begin DoDot:1
+20 ;Change religion (if needed)
+21 SET X=$GET(TMPARR(17))
+22 IF ((X="")!(X=HLQ))
SET TMPARR(17)=29
+23 ;Rebuild segment (due to VAFCQRY call building seg. array)
+24 ;VAFCQRY Seqs 3,5,11 needs to be broken down - too long for rebuild
+25 KILL TMPARR(0),PIDSEG
+26 DO SEQPRSE^SCMSVUT5($NAME(TMPARR(3)),"TMPARR3",HLECH)
+27 DO SEQPRSE^SCMSVUT5($NAME(TMPARR(5)),"TMPARR5",HLECH)
+28 DO SEQPRSE^SCMSVUT5($NAME(TMPARR(11)),"TMPARR11",HLECH)
+29 KILL TMPARR(3)
MERGE TMPARR(3)=TMPARR3
+30 KILL TMPARR(5)
MERGE TMPARR(5)=TMPARR5
+31 KILL TMPARR(11)
MERGE TMPARR(11)=TMPARR11
+32 DO MAKEIT^VAFHLU("PID",.TMPARR,.PIDSEG,.PIDSEG)
End DoDot:1
QUIT
+33 IF REBLD
KILL TMPARR(0),PIDSEG
DO MAKEIT^VAFHLU("PID",.TMPARR,.PIDSEG,.PIDSEG)
+34 QUIT
+35 ;
SETPOW(DFN,ZPDSEG,HLQ,HLFS) ; Set POW Status Indicated field prior to ZPD segment validation
+1 ;
+2 ; Input: DFN = IEN of Patient (#2) file
+3 ; ZPDSEG = Array containing ZPD segment (pass by reference)
+4 ; ZPDSEG = First 245 characters
+5 ; ZPDSEG(1..n) = Continuation nodes
+6 ; HLQ = HL7 null variable
+7 ; HLFS = HL7 field separator
+8 ;
+9 ; Output: If Veteran and POW Status Indicated field = null, set to
+10 ; U (Unknown)
+11 ; If Non-Veteran, set to null
+12 ;
+13 SET DFN=$GET(DFN)
+14 IF (DFN="")!($GET(ZPDSEG)="")
GOTO SETPOWQ
+15 ;Declare variables
+16 NEW REBLD,TMPARR,X
+17 ;Parse segment
+18 DO SEGPRSE^SCMSVUT5($NAME(ZPDSEG),"TMPARR",HLFS)
+19 ;Change POW status (if needed)
+20 SET REBLD=0
+21 SET X=$GET(TMPARR(17))
+22 IF $PIECE($GET(^DPT(DFN,"VET")),"^")="Y"
IF (X=""!(X=HLQ))
SET TMPARR(17)="U"
SET REBLD=1
+23 IF $PIECE($GET(^DPT(DFN,"VET")),"^")="N"
SET TMPARR(17)=HLQ
SET REBLD=1
+24 ;Rebuild segment (if needed)
+25 IF REBLD
KILL TMPARR(0),ZPDSEG
DO MAKEIT^VAFHLU("ZPD",.TMPARR,.ZPDSEG,.ZPDSEG)
+26 ;
SETPOWQ QUIT
+1 ;
+2 ;
SETVSI(DFN,ZSPSEG,HLQ,HLFS) ;Set Vietnam Service Indicated field prior to ZSP segment validation
+1 ;
+2 ; Input: DFN = IEN of Patient (#2) file
+3 ; ZSPSEG = HL7 ZSP segment
+4 ; HLQ = HL7 null variable
+5 ; HLFS = HL7 field separator
+6 ;
+7 ; Output: If Veteran and Vietnam Service Indicated field = null,
+8 ; set to U (Unknown)
+9 ; If Non-Veteran, set to null
+10 ;
+11 SET DFN=$GET(DFN)
SET ZSPSEG=$GET(ZSPSEG)
+12 IF (DFN="")!(ZSPSEG="")
GOTO SETVSIQ
+13 IF $PIECE($GET(^DPT(DFN,"VET")),"^")="Y"
IF ($PIECE(ZSPSEG,HLFS,6)=""!($PIECE(ZSPSEG,HLFS,6)=HLQ))
SET $PIECE(ZSPSEG,HLFS,6)="U"
+14 IF $PIECE($GET(^DPT(DFN,"VET")),"^")="N"
SET $PIECE(ZSPSEG,HLFS,6)=HLQ
+15 ;
SETVSIQ QUIT ZSPSEG
+1 ;
+2 ;
+3 ;
+4 ;The following subroutines all have to do with the validation of
+5 ;data using the same edit checks that are used by Austin.
+6 ;
HL7SEGNM(SEG,DATA) ;checks the validity of the HL7 segment name passed in.
+1 ;INPUT SEG - the HL7 segment name
+2 ; DATA - the data to compare. In this case the HL7 segment name.
+3 ;
+4 ;OUTPUT 0 (ZERO) if not validate
+5 ; 1 if validated
+6 ;
+7 IF '$DATA(SEG)!('$DATA(DATA))
QUIT 0
+8 QUIT $SELECT(SEG=DATA:1,1:0)
+9 ;
EVTTYP(SEG,DATA) ;checks the event type of the segment passed in.
+1 ;INPUT SEG - The HL7 segment name in question
+2 ; DATA - The event type from the HL7 segment in question.
+3 ;
+4 ;OUTPUT 0 (ZERO) if not validate
+5 ; 1 if validated
+6 ;
+7 IF '$DATA(SEG)!('$DATA(DATA))
QUIT 0
+8 IF SEG="EVN"&(DATA="A08"!(DATA="A23"))
QUIT 1
+9 QUIT 0
+10 ;
EVTDTTM(DATA) ;Checks the date and time to ensure it is correct.
+1 ;INPUT DATA - this is the date and time in quesiton.
+2 ;
+3 ;OUTPUT 0 (ZERO) if not validate
+4 ; 1 if validated
+5 ;
+6 IF '$DATA(DATA)
QUIT 0
+7 NEW STRTDT,%DT,X,Y
+8 SET STRTDT=+$ORDER(^SD(404.91,0))
+9 SET STRTDT=$PIECE($GET(^SD(404.91,STRTDT,"AMB")),U,2)
+10 IF 'STRTDT
QUIT 0
+11 SET %DT="T"
SET %DT(0)=STRTDT
SET X=DATA
+12 DO ^%DT
+13 QUIT $SELECT(Y=-1:0,1:1)
+14 ;
VALIDATE(SEG,DATA,ERRCOD,VALERR,CTR) ;
+1 ;
+2 NEW ERRIEN,ERRCHK,RES
+3 SET ERRIEN=+$ORDER(^SD(409.76,"B",ERRCOD,""))
+4 IF 'ERRIEN
SET @VALERR@(SEG,CTR)=ERRCOD
DO INCR
QUIT
+5 SET ERRCHK=$GET(^SD(409.76,ERRIEN,"CHK"))
+6 IF ERRCHK=""
SET @VALERR@(SEG,CTR)=ERRCOD
DO INCR
QUIT
+7 XECUTE ERRCHK
+8 IF 'RES
SET @VALERR@(SEG,CTR)=ERRCOD
DO INCR
+9 QUIT
+10 ;
DFN(DATA) ;
+1 ;INPUT DATA - the DFN of the patient
+2 ;
+3 IF '$DATA(DATA)
QUIT 0
+4 IF DATA=""!(DATA=0)
QUIT 0
+5 IF DATA'?1.N.".".N
QUIT 0
+6 QUIT 1
+7 ;
PATNM(DATA) ;
+1 ;INPUT DATA - The name of the patient
+2 ;
+3 IF '$DATA(DATA)
QUIT 0
+4 IF DATA=""
QUIT 0
+5 IF DATA?.N.",".N
QUIT 0
+6 IF DATA?1.C
QUIT 0
+7 QUIT 1
+8 ;
DOB(DATA,ENCDT) ;
+1 ;INPUT DATA - The DOB to be tested.
+2 ; ENCDT - The date/time of the encounter
+3 ;
+4 NEW %DT,X,Y
+5 IF '$DATA(DATA)
QUIT 0
+6 IF '$DATA(ENCDT)
QUIT 0
+7 IF DATA'?1.N
QUIT 0
+8 SET %DT="T"
SET %DT(0)=-ENCDT
SET X=DATA
+9 DO ^%DT
+10 QUIT $SELECT(Y=-1:0,1:1)
+11 ;
SEX(DATA) ;
+1 ;INPUT DATA - The sex code to be validated
+2 ;
+3 IF '$DATA(DATA)
QUIT 0
+4 IF "FMUO"'[DATA
QUIT 0
+5 QUIT 1
+6 ;
RACE(DATA) ;
+1 ;INPUT DATA - the race code to be validated (NNNN-C-XXX)
+2 ;
+3 NEW VAL,MTHD
+4 IF '$DATA(DATA)
QUIT 0
+5 IF DATA=""
QUIT 1
+6 SET VAL=$PIECE(DATA,"-",1,2)
+7 SET MTHD=$PIECE(DATA,"-",3)
+8 IF VAL'?4N1"-"1N
QUIT 0
+9 IF ",SLF,UNK,PRX,OBS,"'[MTHD
QUIT 0
+10 QUIT 1
+11 ;
STR1(DATA) ;
+1 ;INPUT DATA - Street address line 1
+2 ;
+3 NEW LP,VAR
+4 IF '$DATA(DATA)
QUIT 0
+5 IF DATA=""
QUIT 0
+6 IF DATA?1.N
QUIT 0
+7 IF DATA=" "
QUIT 0
+8 FOR LP=1:1:$LENGTH(DATA)
SET VAR=$EXTRACT(DATA,LP,LP)
IF $ASCII(VAR)>32
IF ($ASCII(VAR)<127)
SET LP="Y"
QUIT
+9 QUIT $SELECT(LP="Y":1,1:0)
+10 ;
STR2(DATA) ;
+1 ;INPUT DATA - Street address line 2
+2 IF DATA?1.N
QUIT 0
+3 QUIT 1
+4 ;
CITY(DATA) ;
+1 ;INPUT DATA - The city code to be validated
+2 ;
+3 IF DATA=""
QUIT 0
+4 IF DATA?1.N
QUIT 0
+5 QUIT 1
+6 ;
STATE(DATA) ;
+1 ;INPUT DATA - State code to be validated.
+2 ;
+3 IF '$DATA(DATA)
QUIT 0
+4 IF DATA=""
QUIT 0
+5 IF '$DATA(^DIC(5,"C",DATA))
QUIT 0
+6 QUIT 1
+7 ;
ZIP(DATA) ;
+1 ;INPUT DATA - The zipo code to be validated
+2 ;
+3 IF '$DATA(DATA)
QUIT 0
+4 IF $EXTRACT(DATA,1,5)="00000"
QUIT 0
+5 IF DATA'?5N."-".4N
QUIT 0
+6 QUIT 1
+7 ;
COUNTY(DATA,STATE) ;
+1 ;INPUT DATA - The county code to be validated
+2 ; STATE - STATE file IEN
+3 ;
+4 IF DATA=""
QUIT 0
+5 IF STATE=""
QUIT 0
+6 IF '$DATA(^DIC(5,+$GET(STATE),1,"C",DATA))
QUIT 0
+7 QUIT 1
+8 ;
MARITAL(DATA) ;
+1 ;INPUT DATA - The marital status code to be validated.
+2 ;
+3 IF $LENGTH(DATA)>1
QUIT 0
+4 IF "ADMSWU"'[DATA
QUIT 0
+5 QUIT 1
+6 ;
REL(DATA) ;
+1 ;INPUT DATA - The religion abbreviation to the validated
+2 ;
+3 IF '$DATA(DATA)
QUIT 0
+4 IF DATA=""
QUIT 0
+5 IF '$DATA(^DIC(13,"C",+DATA))
QUIT 0
+6 QUIT 1
+7 ;
SSN(DATA,NOPCHK,NULLOK) ; SD*5.3*345 added optional parameter NULLOK
+1 ;INPUT DATA - The SSN to be validated
+2 ; NOPCHK - O = Check pseudo indicator (default)
+3 ; 1 = Don't check pseudo indicator
+4 ; NULLOK (optional) - 1 = Allow SSN to be null
+5 ; 2 = Don't allow null SSNs (default)
+6 ;
+7 ; SD*5.3*345
IF $GET(DATA)=""
QUIT +$GET(NULLOK)
+8 IF '$DATA(DATA)
QUIT 0
+9 NEW SSN,PSD
+10 SET SSN=$EXTRACT(DATA,1,9)
SET PSD=$EXTRACT(DATA,10)
+11 IF SSN'?9N
QUIT 0
+12 IF '$GET(NOPCHK)
IF (PSD'=" ")
IF (PSD'="")
IF (PSD'="P")
QUIT 0
+13 IF $EXTRACT(SSN,1,5)="00000"
QUIT 0
+14 QUIT 1
+15 ;
INCR ;increases the counter
+1 SET CTR=CTR+1
+2 QUIT
+3 ;
REMOVE(SEG,ERR,VALERR,CNT) ;
+1 ;INPUT SEG - The segment being worked on
+2 ; VALERR - The array holding the information
+3 ; CNT - the counter to use
+4 ; ERR - error code to remove
+5 ;
+6 NEW LP
+7 FOR LP=1:1:CNT
IF $GET(@VALERR@(SEG,LP))=ERR
KILL @VALERR@(SEG,LP)
+8 QUIT
+9 ;
DECR(CNT) ;
+1 SET CNT=CNT-1
+2 QUIT
+3 ;
