DGPTFVC1 ;ALB/AS/ADL,HIOFO/FT - Expanded PTF Close-Out Edits ;10/21/14 2:33pm
;;5.3;Registration;**52,58,79,114,164,400,342,466,415,493,512,510,544,629,817,850,884**;Aug 13, 1993;Build 31
;;ADL;Updated for CSV Project;;Mar 26, 2003
;
; XLFDT APIs - #10103
; ICDEX APIs - #5747
; ICDXCODE APIs - #5699
; VADPT APIs - #10061
;
;Called from Q+2^DGPTFTR. Variable must be passed in: PTF
;Variable returned: DGERR. DGERR <-- 1 if record fails to pass a check; DGERR <-- "" if record passes all checks
;
Q:'$D(PTF)
S DGERR="",DGV(701)=$S($D(^DGPT(PTF,70)):^(70),1:""),DGV(101)=^(0),DGSUFFIX=$P(DGV(101),"^",5),DGV("FEE")=$P(DGV(101),"^",4),DFN=$P(DGV(101),"^",1)
;
I $P(DGV(101),"^",2)>2820700 D AO
;
I DGRTY=1,DGV("FEE") D MT
;
; DG*512, sck/Remove 101-Means Test indicator = 'U' xmit block
;
; 850 - aas - hard coded ICD codes, diagnosis values, different for ICD-9 and ICD-10
N SYS,EFFDATE,IMPDATE,DGPTDAT
D EFFDATE^DGPTIC10($G(PTF))
S SYS=$$SYS^ICDEX("DIAG",EFFDATE)
I $D(^DPT(DFN,57)),$P(^(57),"^",4)>0,SYS=1 S S0=$P(^(57),"^",4),DGDX=$S(S0=1!(S0=3):"344.1",1:"344.0"),DGSCI="" F DGX=0:0 S DGX=$O(^DGPT(PTF,"M",DGX)) Q:DGX'>0 S DGNODE(0)=^(DGX,0),DGNODE=$$STR501^DGPTFUT(PTF,DGX),DGSCI="" D SCI
I $D(^DPT(DFN,57)),$P(^(57),"^",4)>0,SYS=30 S S0=$P(^(57),"^",4),DGDX=$S(S0=1!(S0=3):"G82.2",1:"G82.5"),DGSCI="" F DGX=0:0 S DGX=$O(^DGPT(PTF,"M",DGX)) Q:DGX'>0 S DGNODE(0)=^(DGX,0),DGNODE=$$STR501^DGPTFUT(PTF,DGX),DGSCI="" D SCI
;
S DGDP="",DGDISPO=$P(DGV(701),"^",6),DGRECSUF=$P(DGV(701),"^",13)
I DGRTY=1 D
.S DGSTATYP=$S(DGDISPO=12!(DGDISPO=13):30,DGDISPO=10:42,DGDISPO=8:40,1:"")
.I DGSTATYP]"" D
..D NUMACT^DGPTSUF(DGSTATYP)
..I DGANUM>0 F I=1:1:DGANUM I DGSUFFIX=DGSUFNAM(I) D
...I DGDISPO'=8 I DGRECSUF=DGSUFNAM(DGANUM) S DGDP=5 D DP
...I DGDISPO=8 N DGANUM,DGSUFNAM D NUMACT^DGPTSUF(42) I DGRECSUF=DGSUFNAM(DGANUM) S DGDP=5 D DP
.K DGANUM,DGSTATYP,DGSUFNAM,I
;
I DGRTY=1 S %=$P(DGV(701),"^",3) I %=4!(%=6)!(%=7) S DGDP="" D OP I $P(DGV(701),"^",5)=1 S DGERR=1 W !,"701 VA AUSPICES",?23," value inconsistent for discharge"
;
;If PRRTP treating specialty, must have valid PRRTP suffix
;Fee records would not contain PRRTP specialties
I 'DGV("FEE"),"^25^26^27^28^29^38^39^"[(U_$P(DGV(701),U,2)_U) D
.I DGSUFFIX'="PA",(DGSUFFIX'="PB"),(DGSUFFIX'="PC"),(DGSUFFIX'="PD") D
..S DGERR=1
..W !,"101 SUFFIX",?23,"value must be set to a valid PRRTP suffix."
;
D RACETHNC
K DGDISPO,DGRECSUF,DGV,DGDP,DGDX,DGSCI,DGSUFFIX,DGNODE,DGX,%,S0,I,X
I DGERR H 4
Q
;
SCI ;
N EFFDATE,IMPDATE
D EFFDATE^DGPTIC10(PTF)
F X=1:1:25 I $P(DGNODE,"^",X) S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$P(DGNODE,"^",X),EFFDATE) D
. I +DGPTTMP>0&($P(DGPTTMP,U,10)) S:$E($P(DGPTTMP,"^",2),1,5)=DGDX DGSCI=10 Q:DGSCI
I 'DGSCI S DGERR=1,%=$P(DGNODE(0),"^",10),X=$TR($$FMTE^XLFDT(%,"5DF")," ","0") W !,"501 ",X," SCI of ",S0,?23," requires an ICD Diagnosis code beginning with",!?12," or equal to ",DGDX
Q
;
MT S DGVMT=$P(DGV(101),"^",10),DGX=999 G DGX:DGVMT']"" I +$P(DGV(101),"^",2)<2860700!(DGSUFFIX="BU") S DGX="X" G DGX
S DGZEC=$P($G(^DGPT(PTF,101)),U,8),DGZEC=$S($D(^DIC(8,+DGZEC,0)):^(0),1:"") I $P(DGZEC,U,5)="N" S DGX="N" G DGX
S DGT=$P(DGV(701),".") G AS:'$O(^DGMT(408.31,"AD",1,DFN,0)) S DGZ1=$$LST^DGMTU(DFN,DGT) K:DGZ1']"" DGZ1
I DGVMT="X" K DGX,DGVMT Q
S DGX=$S('$D(DGZ1):"U",1:$P(DGZ1,U,4))
; Determine if the Pending Adjudication is for MT(C) or GMT(G)
I DGX="P" D G DGX
. I '+$P($G(DGZ1),U) S DGX="U" Q
. S DGX=$$PA^DGMTUTL($P(DGZ1,U)),DGX=$S('$D(DGX):"U",DGX="MT":"C",DGX="GMT":"G",1:"U")
I DGX="A",$P(DGZEC,U,4)=3,$$SC^DGMTR(DFN),$$ANYSC^DGPTSCAN(PTF) S DGX="AS" G DGX
I DGX="A","^1^3^"[("^"_$P(DGZEC,U,4)_"^"),$P($G(^DPT(DFN,.3)),U,2)>0 S DGX="AS" G DGX
S DGX=$S(DGX="A":"AN","BCGN"[DGX:DGX,1:"U") G AS:DGX="U" G DGX:DGX'="N"
AS S DGZ=$S($D(^DPT(DFN,.321)):^(.321),1:0) I $P(DGZ,U,2)="Y"!($P(DGZ,U,3)="Y") S DGX="AS" G DGX
S DGZ=$S($D(^DPT(DFN,.322)):^(.322),1:0) I $P(DGZ,U,13)="Y" S DGX="AS" G DGX
N DGNTARR S DGZ=$S($$GETCUR^DGNTAPI(DFN,"DGNTARR")>0:DGNTARR("NTR"),1:"") I $P(DGZ,U)="Y" S DGX="AS" G DGX
S DGZ=$$GETSTAT^DGMSTAPI(DFN) I $P(DGZ,U,2)="Y" S DGX="AS" G DGX
I $P(DGZEC,U,5)="Y",$P(DGZEC,U,4)<4,"^2^15^"'[(U_$P(DGZEC,U,9)_U) S DGX="AS" G DGX
S DGX="AN"
DGX ;DG*5.3*817/Remove 101-Means Test indicator = 'U' xmit block for FEE BASIS PTF
I DGVMT'=DGX,DGVMT'="U" S DGERR=1 W !,"101 ","MEANS TEST",?23," value ",DGVMT,$S(DGVMT']"":"blank",DGVMT="X":" only for admissions prior to 7/1/86 or domicilliary use",1:" inconsistent with eligibility data")
K DGZEC,DGZ,DGZ1,DGT,DGX,DGVMT Q
;
DP I $P(DGV(701),"^",3)'=5 S DGERR=1 W !,"701 ",$E("TYPE OF DISPOSITION",1,18),?23," value inconsistent for discharge"
OP I $P(DGV(701),"^",4)=1 S DGERR=1 W !,"701 ",$E("OUTPATIENT TREATMENT",1,18),?23," value inconsistent for discharge" Q:DGDP=""
I $P(DGV(701),"^",5)=2 S DGERR=1 W !,"701 VA AUSPICES",?23," value inconsistent for discharge"
Q
;
AO I DGPTFMT<2 D Q
.S %=$S($D(^DGPT(PTF,101)):$P(^(101),"^",4),1:"")
.S %=$S($D(^DIC(45.82,+%,0)):$P(^(0),"^",1),1:"")
.S I=$S($D(^DPT(DFN,.321)):^(.321),1:"")
.S:$P(I,"^",2)="Y"&(%'=6) DGERR=1,DGV("E")=1
.W:$D(DGV("E")) !,"101 AGENT ORANGE",?23," value ",$S(DGV("E"):"can only be used with COB of '6'",1:"is inconsistent with Vietnam Service and/or COB")
;
N AO,AOL,TMP
S TMP=$G(^DPT(DFN,.321))
S AO=$S($P(TMP,"^",2)="Y":1,1:0)
S AOL=$P(TMP,"^",13)
Q:('AO)
Q:(AOL'="")
S DGERR=1,DGV("E")=1
W !,"101 AGENT ORANGE LOCATION",?23,"value required if exposure to Agent Orange claimed"
Q
RACETHNC ;Race and ethnicity check
;Ensure that a value for ethnicity and at least one race is on file.
;Ensure all active race/ethnicity values have a valid PTF value and an
;associated collection method. Ensure all collection methods have a
;valid PTF value. Ignore race/ethnicity entries that are inactive or
;invalid pointers. Note: PTF sends first active ethnicity and first
;six active races.
N REF,IEN,TYPE,TEXT,PTRVAL,PTRMTHD,NUM,MAX
N VALIDVAL,VALIDMTH,VALUE,VADM
D DEM^VADPT
F REF=11,12 D
.I REF=12 D
..S MAX=6
..S TYPE=1
..S VALIDVAL=",3,8,9,A,B,C,D,"
..S VALIDMTH=",S,P,O,U,"
..S TEXT="RACE"
.I REF=11 D
..S MAX=1
..S TYPE=2
..S TEXT="ETHNICITY"
..S VALIDVAL=",H,N,D,U,"
..S VALIDMTH=",S,P,O,U,"
.S NUM=1
.S IEN=0
.F S IEN=+$O(VADM(REF,IEN)) Q:'IEN D Q:NUM>MAX
..S PTRVAL=+VADM(REF,IEN)
..S PTRMTHD=+$G(VADM(REF,IEN,1))
..Q:'PTRVAL
..Q:$$INACTIVE^DGUTL4(PTRVAL,TYPE)
..S NUM=NUM+1
..S VALUE=$$PTR2CODE^DGUTL4(PTRVAL,TYPE,4)
..I (VALUE="")!(VALIDVAL'[VALUE) D Q
...W !,"701 ",TEXT,?23,"missing/invalid xmit value"
...S DGERR=1
..I ('PTRMTHD) D Q
...W !,"701 ",TEXT,?23,"method of collection missing/invalid"
...S DGERR=1
..S VALUE=$$PTR2CODE^DGUTL4(PTRMTHD,3,4)
..I (VALUE="")!(VALIDMTH'[VALUE) D Q
...W !,"701 ",TEXT,?23,"missing/invalid xmit value for method of collection"
...S DGERR=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFVC1 7005 printed Apr 09, 2024@21:49:03 Page 2
DGPTFVC1 ;ALB/AS/ADL,HIOFO/FT - Expanded PTF Close-Out Edits ;10/21/14 2:33pm
+1 ;;5.3;Registration;**52,58,79,114,164,400,342,466,415,493,512,510,544,629,817,850,884**;Aug 13, 1993;Build 31
+2 ;;ADL;Updated for CSV Project;;Mar 26, 2003
+3 ;
+4 ; XLFDT APIs - #10103
+5 ; ICDEX APIs - #5747
+6 ; ICDXCODE APIs - #5699
+7 ; VADPT APIs - #10061
+8 ;
+9 ;Called from Q+2^DGPTFTR. Variable must be passed in: PTF
+10 ;Variable returned: DGERR. DGERR <-- 1 if record fails to pass a check; DGERR <-- "" if record passes all checks
+11 ;
+12 if '$DATA(PTF)
QUIT
+13 SET DGERR=""
SET DGV(701)=$SELECT($DATA(^DGPT(PTF,70)):^(70),1:"")
SET DGV(101)=^(0)
SET DGSUFFIX=$PIECE(DGV(101),"^",5)
SET DGV("FEE")=$PIECE(DGV(101),"^",4)
SET DFN=$PIECE(DGV(101),"^",1)
+14 ;
+15 IF $PIECE(DGV(101),"^",2)>2820700
DO AO
+16 ;
+17 IF DGRTY=1
IF DGV("FEE")
DO MT
+18 ;
+19 ; DG*512, sck/Remove 101-Means Test indicator = 'U' xmit block
+20 ;
+21 ; 850 - aas - hard coded ICD codes, diagnosis values, different for ICD-9 and ICD-10
+22 NEW SYS,EFFDATE,IMPDATE,DGPTDAT
+23 DO EFFDATE^DGPTIC10($GET(PTF))
+24 SET SYS=$$SYS^ICDEX("DIAG",EFFDATE)
+25 IF $DATA(^DPT(DFN,57))
IF $PIECE(^(57),"^",4)>0
IF SYS=1
SET S0=$PIECE(^(57),"^",4)
SET DGDX=$SELECT(S0=1!(S0=3):"344.1",1:"344.0")
SET DGSCI=""
FOR DGX=0:0
SET DGX=$ORDER(^DGPT(PTF,"M",DGX))
if DGX'>0
QUIT
SET DGNODE(0)=^(DGX,0)
SET DGNODE=$$STR501^DGPTFUT(PTF,DGX)
SET DGSCI=""
DO SCI
+26 IF $DATA(^DPT(DFN,57))
IF $PIECE(^(57),"^",4)>0
IF SYS=30
SET S0=$PIECE(^(57),"^",4)
SET DGDX=$SELECT(S0=1!(S0=3):"G82.2",1:"G82.5")
SET DGSCI=""
FOR DGX=0:0
SET DGX=$ORDER(^DGPT(PTF,"M",DGX))
if DGX'>0
QUIT
SET DGNODE(0)=^(DGX,0)
SET DGNODE=$$STR501^DGPTFUT(PTF,DGX)
SET DGSCI=""
DO SCI
+27 ;
+28 SET DGDP=""
SET DGDISPO=$PIECE(DGV(701),"^",6)
SET DGRECSUF=$PIECE(DGV(701),"^",13)
+29 IF DGRTY=1
Begin DoDot:1
+30 SET DGSTATYP=$SELECT(DGDISPO=12!(DGDISPO=13):30,DGDISPO=10:42,DGDISPO=8:40,1:"")
+31 IF DGSTATYP]""
Begin DoDot:2
+32 DO NUMACT^DGPTSUF(DGSTATYP)
+33 IF DGANUM>0
FOR I=1:1:DGANUM
IF DGSUFFIX=DGSUFNAM(I)
Begin DoDot:3
+34 IF DGDISPO'=8
IF DGRECSUF=DGSUFNAM(DGANUM)
SET DGDP=5
DO DP
+35 IF DGDISPO=8
NEW DGANUM,DGSUFNAM
DO NUMACT^DGPTSUF(42)
IF DGRECSUF=DGSUFNAM(DGANUM)
SET DGDP=5
DO DP
End DoDot:3
End DoDot:2
+36 KILL DGANUM,DGSTATYP,DGSUFNAM,I
End DoDot:1
+37 ;
+38 IF DGRTY=1
SET %=$PIECE(DGV(701),"^",3)
IF %=4!(%=6)!(%=7)
SET DGDP=""
DO OP
IF $PIECE(DGV(701),"^",5)=1
SET DGERR=1
WRITE !,"701 VA AUSPICES",?23," value inconsistent for discharge"
+39 ;
+40 ;If PRRTP treating specialty, must have valid PRRTP suffix
+41 ;Fee records would not contain PRRTP specialties
+42 IF 'DGV("FEE")
IF "^25^26^27^28^29^38^39^"[(U_$PIECE(DGV(701),U,2)_U)
Begin DoDot:1
+43 IF DGSUFFIX'="PA"
IF (DGSUFFIX'="PB")
IF (DGSUFFIX'="PC")
IF (DGSUFFIX'="PD")
Begin DoDot:2
+44 SET DGERR=1
+45 WRITE !,"101 SUFFIX",?23,"value must be set to a valid PRRTP suffix."
End DoDot:2
End DoDot:1
+46 ;
+47 DO RACETHNC
+48 KILL DGDISPO,DGRECSUF,DGV,DGDP,DGDX,DGSCI,DGSUFFIX,DGNODE,DGX,%,S0,I,X
+49 IF DGERR
HANG 4
+50 QUIT
+51 ;
SCI ;
+1 NEW EFFDATE,IMPDATE
+2 DO EFFDATE^DGPTIC10(PTF)
+3 FOR X=1:1:25
IF $PIECE(DGNODE,"^",X)
SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$PIECE(DGNODE,"^",X),EFFDATE)
Begin DoDot:1
+4 IF +DGPTTMP>0&($PIECE(DGPTTMP,U,10))
if $EXTRACT($PIECE(DGPTTMP,"^",2),1,5)=DGDX
SET DGSCI=10
if DGSCI
QUIT
End DoDot:1
+5 IF 'DGSCI
SET DGERR=1
SET %=$PIECE(DGNODE(0),"^",10)
SET X=$TRANSLATE($$FMTE^XLFDT(%,"5DF")," ","0")
WRITE !,"501 ",X," SCI of ",S0,?23," requires an ICD Diagnosis code beginning with",!?12," or equal to ",DGDX
+6 QUIT
+7 ;
MT SET DGVMT=$PIECE(DGV(101),"^",10)
SET DGX=999
if DGVMT']""
GOTO DGX
IF +$PIECE(DGV(101),"^",2)<2860700!(DGSUFFIX="BU")
SET DGX="X"
GOTO DGX
+1 SET DGZEC=$PIECE($GET(^DGPT(PTF,101)),U,8)
SET DGZEC=$SELECT($DATA(^DIC(8,+DGZEC,0)):^(0),1:"")
IF $PIECE(DGZEC,U,5)="N"
SET DGX="N"
GOTO DGX
+2 SET DGT=$PIECE(DGV(701),".")
if '$ORDER(^DGMT(408.31,"AD",1,DFN,0))
GOTO AS
SET DGZ1=$$LST^DGMTU(DFN,DGT)
if DGZ1']""
KILL DGZ1
+3 IF DGVMT="X"
KILL DGX,DGVMT
QUIT
+4 SET DGX=$SELECT('$DATA(DGZ1):"U",1:$PIECE(DGZ1,U,4))
+5 ; Determine if the Pending Adjudication is for MT(C) or GMT(G)
+6 IF DGX="P"
Begin DoDot:1
+7 IF '+$PIECE($GET(DGZ1),U)
SET DGX="U"
QUIT
+8 SET DGX=$$PA^DGMTUTL($PIECE(DGZ1,U))
SET DGX=$SELECT('$DATA(DGX):"U",DGX="MT":"C",DGX="GMT":"G",1:"U")
End DoDot:1
GOTO DGX
+9 IF DGX="A"
IF $PIECE(DGZEC,U,4)=3
IF $$SC^DGMTR(DFN)
IF $$ANYSC^DGPTSCAN(PTF)
SET DGX="AS"
GOTO DGX
+10 IF DGX="A"
IF "^1^3^"[("^"_$PIECE(DGZEC,U,4)_"^")
IF $PIECE($GET(^DPT(DFN,.3)),U,2)>0
SET DGX="AS"
GOTO DGX
+11 SET DGX=$SELECT(DGX="A":"AN","BCGN"[DGX:DGX,1:"U")
if DGX="U"
GOTO AS
if DGX'="N"
GOTO DGX
AS SET DGZ=$SELECT($DATA(^DPT(DFN,.321)):^(.321),1:0)
IF $PIECE(DGZ,U,2)="Y"!($PIECE(DGZ,U,3)="Y")
SET DGX="AS"
GOTO DGX
+1 SET DGZ=$SELECT($DATA(^DPT(DFN,.322)):^(.322),1:0)
IF $PIECE(DGZ,U,13)="Y"
SET DGX="AS"
GOTO DGX
+2 NEW DGNTARR
SET DGZ=$SELECT($$GETCUR^DGNTAPI(DFN,"DGNTARR")>0:DGNTARR("NTR"),1:"")
IF $PIECE(DGZ,U)="Y"
SET DGX="AS"
GOTO DGX
+3 SET DGZ=$$GETSTAT^DGMSTAPI(DFN)
IF $PIECE(DGZ,U,2)="Y"
SET DGX="AS"
GOTO DGX
+4 IF $PIECE(DGZEC,U,5)="Y"
IF $PIECE(DGZEC,U,4)<4
IF "^2^15^"'[(U_$PIECE(DGZEC,U,9)_U)
SET DGX="AS"
GOTO DGX
+5 SET DGX="AN"
DGX ;DG*5.3*817/Remove 101-Means Test indicator = 'U' xmit block for FEE BASIS PTF
+1 IF DGVMT'=DGX
IF DGVMT'="U"
SET DGERR=1
WRITE !,"101 ","MEANS TEST",?23," value ",DGVMT,$SELECT(DGVMT']"":"blank",DGVMT="X":" only for admissions prior to 7/1/86 or domicilliary use",1:" inconsistent with eligibility data")
+2 KILL DGZEC,DGZ,DGZ1,DGT,DGX,DGVMT
QUIT
+3 ;
DP IF $PIECE(DGV(701),"^",3)'=5
SET DGERR=1
WRITE !,"701 ",$EXTRACT("TYPE OF DISPOSITION",1,18),?23," value inconsistent for discharge"
OP IF $PIECE(DGV(701),"^",4)=1
SET DGERR=1
WRITE !,"701 ",$EXTRACT("OUTPATIENT TREATMENT",1,18),?23," value inconsistent for discharge"
if DGDP=""
QUIT
+1 IF $PIECE(DGV(701),"^",5)=2
SET DGERR=1
WRITE !,"701 VA AUSPICES",?23," value inconsistent for discharge"
+2 QUIT
+3 ;
AO IF DGPTFMT<2
Begin DoDot:1
+1 SET %=$SELECT($DATA(^DGPT(PTF,101)):$PIECE(^(101),"^",4),1:"")
+2 SET %=$SELECT($DATA(^DIC(45.82,+%,0)):$PIECE(^(0),"^",1),1:"")
+3 SET I=$SELECT($DATA(^DPT(DFN,.321)):^(.321),1:"")
+4 if $PIECE(I,"^",2)="Y"&(%'=6)
SET DGERR=1
SET DGV("E")=1
+5 if $DATA(DGV("E"))
WRITE !,"101 AGENT ORANGE",?23," value ",$SELECT(DGV("E"):"can only be used with COB of '6'",1:"is inconsistent with Vietnam Service and/or COB")
End DoDot:1
QUIT
+6 ;
+7 NEW AO,AOL,TMP
+8 SET TMP=$GET(^DPT(DFN,.321))
+9 SET AO=$SELECT($PIECE(TMP,"^",2)="Y":1,1:0)
+10 SET AOL=$PIECE(TMP,"^",13)
+11 if ('AO)
QUIT
+12 if (AOL'="")
QUIT
+13 SET DGERR=1
SET DGV("E")=1
+14 WRITE !,"101 AGENT ORANGE LOCATION",?23,"value required if exposure to Agent Orange claimed"
+15 QUIT
RACETHNC ;Race and ethnicity check
+1 ;Ensure that a value for ethnicity and at least one race is on file.
+2 ;Ensure all active race/ethnicity values have a valid PTF value and an
+3 ;associated collection method. Ensure all collection methods have a
+4 ;valid PTF value. Ignore race/ethnicity entries that are inactive or
+5 ;invalid pointers. Note: PTF sends first active ethnicity and first
+6 ;six active races.
+7 NEW REF,IEN,TYPE,TEXT,PTRVAL,PTRMTHD,NUM,MAX
+8 NEW VALIDVAL,VALIDMTH,VALUE,VADM
+9 DO DEM^VADPT
+10 FOR REF=11,12
Begin DoDot:1
+11 IF REF=12
Begin DoDot:2
+12 SET MAX=6
+13 SET TYPE=1
+14 SET VALIDVAL=",3,8,9,A,B,C,D,"
+15 SET VALIDMTH=",S,P,O,U,"
+16 SET TEXT="RACE"
End DoDot:2
+17 IF REF=11
Begin DoDot:2
+18 SET MAX=1
+19 SET TYPE=2
+20 SET TEXT="ETHNICITY"
+21 SET VALIDVAL=",H,N,D,U,"
+22 SET VALIDMTH=",S,P,O,U,"
End DoDot:2
+23 SET NUM=1
+24 SET IEN=0
+25 FOR
SET IEN=+$ORDER(VADM(REF,IEN))
if 'IEN
QUIT
Begin DoDot:2
+26 SET PTRVAL=+VADM(REF,IEN)
+27 SET PTRMTHD=+$GET(VADM(REF,IEN,1))
+28 if 'PTRVAL
QUIT
+29 if $$INACTIVE^DGUTL4(PTRVAL,TYPE)
QUIT
+30 SET NUM=NUM+1
+31 SET VALUE=$$PTR2CODE^DGUTL4(PTRVAL,TYPE,4)
+32 IF (VALUE="")!(VALIDVAL'[VALUE)
Begin DoDot:3
+33 WRITE !,"701 ",TEXT,?23,"missing/invalid xmit value"
+34 SET DGERR=1
End DoDot:3
QUIT
+35 IF ('PTRMTHD)
Begin DoDot:3
+36 WRITE !,"701 ",TEXT,?23,"method of collection missing/invalid"
+37 SET DGERR=1
End DoDot:3
QUIT
+38 SET VALUE=$$PTR2CODE^DGUTL4(PTRMTHD,3,4)
+39 IF (VALUE="")!(VALIDMTH'[VALUE)
Begin DoDot:3
+40 WRITE !,"701 ",TEXT,?23,"missing/invalid xmit value for method of collection"
+41 SET DGERR=1
End DoDot:3
QUIT
End DoDot:2
if NUM>MAX
QUIT
End DoDot:1
+42 QUIT
