DGPT701 ;ALB/MTC,HIOFO/FT - Process 701 Transaction ;11/5/14 1:27pm
;;5.3;Registration;**64,164,251,415,729,850,884**;Aug 13, 1993;Build 31
; 10/06/1999 ACS - Removed Place of Disposition codes M,Y,Z from the list of invalid codes.
;
;no external references
;
EN ;
Q
SET ;
S DGPTSTR=$G(^TMP("AEDIT",$J,"N701",DGPTAL7))
;S DGPTSTR=$G(^TMP("AEDIT",$J,"N701",SEQ))
D PARSE^DGPT701P
DTE ;
S (X,DGPTDDS)=$$FMDT^DGPT101($E(DGPTDDTD,1,6))_"."_$E(DGPTDDTD,7,10)
S %DT="XT" D ^%DT I Y<0 S DGPTERC=705 D ERR G:DGPTEDFL EXIT
I Y>0 D DD^%DT S DGPTDTD=$E(Y,5,6)_"-"_$E(Y,1,3)_"-"_$E(Y,9,12)_" "_$S($P(Y,"@",2)]"":$E($P(Y,"@",2),1,5),1:"00:00")
S X1=DGPTNOW,X2=+DGPTDDS D ^%DTC I X<0 S DGPTERC=740 D ERR G:DGPTEDFL EXIT
S X1=+DGPTDDS,X2=+DGPTDTS D ^%DTC S DGPTELP=X I X<0 S DGPTERC=737 D ERR G:DGPTEDFL EXIT
CHECK ;
TSPEC ; CHECK TREATING SPECIALTY CODE
N DGPTDSP1
I DGPTDSP'?2AN S DGPTERC=706 D ERR G:DGPTEDFL EXIT G DISPTY
S DGPTSP1=$E(DGPTDSP,1),DGPTSP2=$E(DGPTDSP,2),DGPTERC=0
D CHECK^DGPTAE02 I DGPTERC S DGPTERC=706 D ERR G:DGPTEDFL EXIT G DISPTY
;-- Active treating specialty edit check
I $E(DGPTDSP,1)=0!($E(DGPTDSP,1)=" ") S DGPTDSP=$E(DGPTDSP,2)
; DGPTDSP := ptf code (alpha-numeric) value (file:42.4,field:7)
; DGPTDSP1 := dinum value (ien, file:42.4,field:.001)
S DGPTDSP1=+$O(^DIC(42.4,"C",DGPTDSP,0))
;-- If not active treat spec, set flag to print error msg during
;-- PTF Close-out Error display at WRER^DGPTAEE
I '$$ACTIVE^DGACT(42.4,DGPTDSP1,DGPTDDS) S DGPTERC=706,DGPTSER(DGPTDDS_701)=1 D ERR G:DGPTEDFL EXIT
;
DISPTY ;type of disposition
I (DGPTDTY<1)!(DGPTDTY>7) S DGPTERC=707 D ERR G:DGPTEDFL EXIT G OPCAR
S DGPTERC=0 D DISPTY^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
OPCAR ;outpatient care status
I "13 "'[DGPTDOP S DGPTERC=708 D ERR G:DGPTEDFL EXIT G VA
I DGPTDOP'=" " S DGPTERC=0 D OP^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
VA ;under va auspices
I "12 "'[DGPTDVA S DGPTERC=709 D ERR G:DGPTEDFL EXIT
;
VAOP ;check for inconsistencies between outpatient care and va auspices
I DGPTDVA=2,DGPTDOP=1 D G:DGPTEDFL EXIT
. S DGPTERC=708 D ERR
. S DGPTERC=709 D ERR
CDR ;physical location cdr code
I DGPTDLR'?6" "&(DGPTDLR'?." "6N) S DGPTERC=775 D ERR G:DGPTEDFL EXIT
POD ;place of disposition
I "68EINOQSVW"[DGPTDPD S DGPTERC=710 D ERR G:DGPTEDFL EXIT G RECF
S DGPTERC=0 D POD^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
RECF ;receiving facility number & suffix
I DGPTDVA'=1!(DGPTDRF=" ") G ASIH
I DGPTDRF[" " S DGPTDRF=$P(DGPTDRF," ",1)
I DGPTDRF="" S DGPTERC=711 D ERR G:DGPTEDFL EXIT
ASIH ;extended care days - absent sick in hospital
I DGPTDAS'=" ",DGPTDAS'?2E1N S DGPTERC=712 D ERR G:DGPTEDFL EXIT
;
LEAVE ;check leave days+pass days with total length of stay
S DGPTERC=0 D LEAVE^DGPTAE02 D:DGPTERC ERR G:DGPTEDFL EXIT
SC ;percentage of service connected
G:DGPTFMT=3 CP ;not set or checked after icd10 turned on. ft 10/30/14
I DGPTDSC'=" "&(DGPTDSC'?3N) S DGPTERC=730 D ERR G:DGPTEDFL EXIT G CP
S DGPTDSC=+DGPTDSC
CP ;compensation & pension status
S DGPTERC=0 D CANDP^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
DIAG ;check diagnostic code
S DGPTERC=0 D ^DGPT70DX I DGPTERC D ERR G:DGPTEDFL EXIT
DXLSPOA ;check dxls poa value ;new field & check with 884 ft 11/3/14
I DGPTFMT=3 S DGPTERC=0 D DXLSPOA^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
OVER ; Pass FY92 edits for earlier data
I DGPTDDS'>2911001 G ONED
LEG ; LEGIONNAIRE'S DISEASE
;S DGPTERC=0 D LEG^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT //no longer used because of DG*5.3*683 (7/1/06). ft 11/5/14
;DGPT70LG is still set with ICD9 & ICD10, so check for space. ft 10/30/14
;I DGPT70LG'=" " S DGPTERC=7__ D ERR G:DGPTEDFL EXIT
SUI ; Suicide indicator
;no longer used because of dg*5.3*683 (71/06). ft 11/5/14
;S DGPTERC=0 D SUI^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
;I DGPT70SU'=" " S DGPTERC=7__ D ERR G:DGPTEDFL EXIT
DRUG ;drug/substance abuse
;no longer used as of DG*5.3*683 (7/1/06). ft 11/5/14
;S DGPTERC=0 D DRUG^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
;I DGPT70DR'?4" " S DGPTERC=7__ D ERR G:DGPTEDFL EXIT
AXES ; Psych axises
;no longer used when ICD10 is turned on, but still in the record so check for spaces. ft 11/5/14
I DGPTFMT=3 D G ONED
.I DGPT70X4'=" " S DGPTERC=734 D ERR
.I DGPTDXV2'?4" " S DGPTERC=735 D ERR
I '$P($G(^DIC(42.4,+$G(DGPTDSP1),0)),U,4) S (DGPT70X4,DGPT7X51,DGPT7X52)=" " G ONED ;don't think DGPT7X51/52 are ever used, just set & killed. ft 11/5/14
S DGPTERC=0 D AXIV^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
S DGPTERC=0 D AXV1^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
S DGPTERC=0 D AXV2^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
ONED ;check if one diagnostic code only
I (DGPTDDXO=" ")&('$D(^TMP("AEDIT",$J,"N702"))&'$D(^TMP("AEDIT",$J,"N703"))) S DGPTERC=718 D ERR G:DGPTEDFL EXIT
I (DGPTDDXO="X")&($D(^TMP("AEDIT",$J,"N702"))) S DGPTERC=719 D ERR G:DGPTEDFL EXIT
RACE ;race
I DGPTFMT=3 S DGPTERC=0 D RACE^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
TSC ;treated for service condition
I DGPTFMT=3 S DGPTERC=0 D TSC^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
AO ;agent orange condition
I DGPTFMT=3 S DGPTERC=0 D AO^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
IR ;ionizing radiation condition
I DGPTFMT=3 S DGPTERC=0 D IR^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
SWA ;sw asia condition
I DGPTFMT=3 S DGPTERC=0 D SWA^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
MST ;military sexual trauma
I DGPTFMT=3 S DGPTERC=0 D MST^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
HNC ;head & neck care
I DGPTFMT=3 S DGPTERC=0 D HNC^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
ETHNIC ;ethnicity
I DGPTFMT=3 S DGPTERC=0 D ETHNIC^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
RACE16 ;race 1-6
I DGPTFMT=3 D
.F DGLOOP=1:1:6 S DGPTRACE16=@("DGPT70RACE"_DGLOOP)
.Q:DGPTRACE16=" " ;two spaces
.S DGPTERC=0 D RACE16^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
K DGLOOP,DGPTRACE16
CV ;combat vet
I DGPTFMT=3 S DGPTERC=0 D CV^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
SHAD ;shad
I DGPTFMT=3 S DGPTERC=0 D SHAD^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
EXIT ;
Q
ERR ;
D WRTERR^DGPTAE(DGPTERC,"N701",DGPTAL7)
;D WRTERR^DGPTAE(DGPTERC,"N701",SEQ)
S ERROR=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPT701 6228 printed Sep 23, 2025@20:27:17 Page 2
DGPT701 ;ALB/MTC,HIOFO/FT - Process 701 Transaction ;11/5/14 1:27pm
+1 ;;5.3;Registration;**64,164,251,415,729,850,884**;Aug 13, 1993;Build 31
+2 ; 10/06/1999 ACS - Removed Place of Disposition codes M,Y,Z from the list of invalid codes.
+3 ;
+4 ;no external references
+5 ;
EN ;
+1 QUIT
SET ;
+1 SET DGPTSTR=$GET(^TMP("AEDIT",$JOB,"N701",DGPTAL7))
+2 ;S DGPTSTR=$G(^TMP("AEDIT",$J,"N701",SEQ))
+3 DO PARSE^DGPT701P
DTE ;
+1 SET (X,DGPTDDS)=$$FMDT^DGPT101($EXTRACT(DGPTDDTD,1,6))_"."_$EXTRACT(DGPTDDTD,7,10)
+2 SET %DT="XT"
DO ^%DT
IF Y<0
SET DGPTERC=705
DO ERR
if DGPTEDFL
GOTO EXIT
+3 IF Y>0
DO DD^%DT
SET DGPTDTD=$EXTRACT(Y,5,6)_"-"_$EXTRACT(Y,1,3)_"-"_$EXTRACT(Y,9,12)_" "_$SELECT($PIECE(Y,"@",2)]"":$EXTRACT($PIECE(Y,"@",2),1,5),1:"00:00")
+4 SET X1=DGPTNOW
SET X2=+DGPTDDS
DO ^%DTC
IF X<0
SET DGPTERC=740
DO ERR
if DGPTEDFL
GOTO EXIT
+5 SET X1=+DGPTDDS
SET X2=+DGPTDTS
DO ^%DTC
SET DGPTELP=X
IF X<0
SET DGPTERC=737
DO ERR
if DGPTEDFL
GOTO EXIT
CHECK ;
TSPEC ; CHECK TREATING SPECIALTY CODE
+1 NEW DGPTDSP1
+2 IF DGPTDSP'?2AN
SET DGPTERC=706
DO ERR
if DGPTEDFL
GOTO EXIT
GOTO DISPTY
+3 SET DGPTSP1=$EXTRACT(DGPTDSP,1)
SET DGPTSP2=$EXTRACT(DGPTDSP,2)
SET DGPTERC=0
+4 DO CHECK^DGPTAE02
IF DGPTERC
SET DGPTERC=706
DO ERR
if DGPTEDFL
GOTO EXIT
GOTO DISPTY
+5 ;-- Active treating specialty edit check
+6 IF $EXTRACT(DGPTDSP,1)=0!($EXTRACT(DGPTDSP,1)=" ")
SET DGPTDSP=$EXTRACT(DGPTDSP,2)
+7 ; DGPTDSP := ptf code (alpha-numeric) value (file:42.4,field:7)
+8 ; DGPTDSP1 := dinum value (ien, file:42.4,field:.001)
+9 SET DGPTDSP1=+$ORDER(^DIC(42.4,"C",DGPTDSP,0))
+10 ;-- If not active treat spec, set flag to print error msg during
+11 ;-- PTF Close-out Error display at WRER^DGPTAEE
+12 IF '$$ACTIVE^DGACT(42.4,DGPTDSP1,DGPTDDS)
SET DGPTERC=706
SET DGPTSER(DGPTDDS_701)=1
DO ERR
if DGPTEDFL
GOTO EXIT
+13 ;
DISPTY ;type of disposition
+1 IF (DGPTDTY<1)!(DGPTDTY>7)
SET DGPTERC=707
DO ERR
if DGPTEDFL
GOTO EXIT
GOTO OPCAR
+2 SET DGPTERC=0
DO DISPTY^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
OPCAR ;outpatient care status
+1 IF "13 "'[DGPTDOP
SET DGPTERC=708
DO ERR
if DGPTEDFL
GOTO EXIT
GOTO VA
+2 IF DGPTDOP'=" "
SET DGPTERC=0
DO OP^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
VA ;under va auspices
+1 IF "12 "'[DGPTDVA
SET DGPTERC=709
DO ERR
if DGPTEDFL
GOTO EXIT
+2 ;
VAOP ;check for inconsistencies between outpatient care and va auspices
+1 IF DGPTDVA=2
IF DGPTDOP=1
Begin DoDot:1
+2 SET DGPTERC=708
DO ERR
+3 SET DGPTERC=709
DO ERR
End DoDot:1
if DGPTEDFL
GOTO EXIT
CDR ;physical location cdr code
+1 IF DGPTDLR'?6" "&(DGPTDLR'?." "6N)
SET DGPTERC=775
DO ERR
if DGPTEDFL
GOTO EXIT
POD ;place of disposition
+1 IF "68EINOQSVW"[DGPTDPD
SET DGPTERC=710
DO ERR
if DGPTEDFL
GOTO EXIT
GOTO RECF
+2 SET DGPTERC=0
DO POD^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
RECF ;receiving facility number & suffix
+1 IF DGPTDVA'=1!(DGPTDRF=" ")
GOTO ASIH
+2 IF DGPTDRF[" "
SET DGPTDRF=$PIECE(DGPTDRF," ",1)
+3 IF DGPTDRF=""
SET DGPTERC=711
DO ERR
if DGPTEDFL
GOTO EXIT
ASIH ;extended care days - absent sick in hospital
+1 IF DGPTDAS'=" "
IF DGPTDAS'?2E1N
SET DGPTERC=712
DO ERR
if DGPTEDFL
GOTO EXIT
+2 ;
LEAVE ;check leave days+pass days with total length of stay
+1 SET DGPTERC=0
DO LEAVE^DGPTAE02
if DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
SC ;percentage of service connected
+1 ;not set or checked after icd10 turned on. ft 10/30/14
if DGPTFMT=3
GOTO CP
+2 IF DGPTDSC'=" "&(DGPTDSC'?3N)
SET DGPTERC=730
DO ERR
if DGPTEDFL
GOTO EXIT
GOTO CP
+3 SET DGPTDSC=+DGPTDSC
CP ;compensation & pension status
+1 SET DGPTERC=0
DO CANDP^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
DIAG ;check diagnostic code
+1 SET DGPTERC=0
DO ^DGPT70DX
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
DXLSPOA ;check dxls poa value ;new field & check with 884 ft 11/3/14
+1 IF DGPTFMT=3
SET DGPTERC=0
DO DXLSPOA^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
OVER ; Pass FY92 edits for earlier data
+1 IF DGPTDDS'>2911001
GOTO ONED
LEG ; LEGIONNAIRE'S DISEASE
+1 ;S DGPTERC=0 D LEG^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT //no longer used because of DG*5.3*683 (7/1/06). ft 11/5/14
+2 ;DGPT70LG is still set with ICD9 & ICD10, so check for space. ft 10/30/14
+3 ;I DGPT70LG'=" " S DGPTERC=7__ D ERR G:DGPTEDFL EXIT
SUI ; Suicide indicator
+1 ;no longer used because of dg*5.3*683 (71/06). ft 11/5/14
+2 ;S DGPTERC=0 D SUI^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
+3 ;I DGPT70SU'=" " S DGPTERC=7__ D ERR G:DGPTEDFL EXIT
DRUG ;drug/substance abuse
+1 ;no longer used as of DG*5.3*683 (7/1/06). ft 11/5/14
+2 ;S DGPTERC=0 D DRUG^DGPTAE02 I DGPTERC D ERR G:DGPTEDFL EXIT
+3 ;I DGPT70DR'?4" " S DGPTERC=7__ D ERR G:DGPTEDFL EXIT
AXES ; Psych axises
+1 ;no longer used when ICD10 is turned on, but still in the record so check for spaces. ft 11/5/14
+2 IF DGPTFMT=3
Begin DoDot:1
+3 IF DGPT70X4'=" "
SET DGPTERC=734
DO ERR
+4 IF DGPTDXV2'?4" "
SET DGPTERC=735
DO ERR
End DoDot:1
GOTO ONED
+5 ;don't think DGPT7X51/52 are ever used, just set & killed. ft 11/5/14
IF '$PIECE($GET(^DIC(42.4,+$GET(DGPTDSP1),0)),U,4)
SET (DGPT70X4,DGPT7X51,DGPT7X52)=" "
GOTO ONED
+6 SET DGPTERC=0
DO AXIV^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
+7 SET DGPTERC=0
DO AXV1^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
+8 SET DGPTERC=0
DO AXV2^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
ONED ;check if one diagnostic code only
+1 IF (DGPTDDXO=" ")&('$DATA(^TMP("AEDIT",$JOB,"N702"))&'$DATA(^TMP("AEDIT",$JOB,"N703")))
SET DGPTERC=718
DO ERR
if DGPTEDFL
GOTO EXIT
+2 IF (DGPTDDXO="X")&($DATA(^TMP("AEDIT",$JOB,"N702")))
SET DGPTERC=719
DO ERR
if DGPTEDFL
GOTO EXIT
RACE ;race
+1 IF DGPTFMT=3
SET DGPTERC=0
DO RACE^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
TSC ;treated for service condition
+1 IF DGPTFMT=3
SET DGPTERC=0
DO TSC^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
AO ;agent orange condition
+1 IF DGPTFMT=3
SET DGPTERC=0
DO AO^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
IR ;ionizing radiation condition
+1 IF DGPTFMT=3
SET DGPTERC=0
DO IR^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
SWA ;sw asia condition
+1 IF DGPTFMT=3
SET DGPTERC=0
DO SWA^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
MST ;military sexual trauma
+1 IF DGPTFMT=3
SET DGPTERC=0
DO MST^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
HNC ;head & neck care
+1 IF DGPTFMT=3
SET DGPTERC=0
DO HNC^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
ETHNIC ;ethnicity
+1 IF DGPTFMT=3
SET DGPTERC=0
DO ETHNIC^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
RACE16 ;race 1-6
+1 IF DGPTFMT=3
Begin DoDot:1
+2 FOR DGLOOP=1:1:6
SET DGPTRACE16=@("DGPT70RACE"_DGLOOP)
+3 ;two spaces
if DGPTRACE16=" "
QUIT
+4 SET DGPTERC=0
DO RACE16^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
End DoDot:1
+5 KILL DGLOOP,DGPTRACE16
CV ;combat vet
+1 IF DGPTFMT=3
SET DGPTERC=0
DO CV^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
SHAD ;shad
+1 IF DGPTFMT=3
SET DGPTERC=0
DO SHAD^DGPTAE02
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
EXIT ;
+1 QUIT
ERR ;
+1 DO WRTERR^DGPTAE(DGPTERC,"N701",DGPTAL7)
+2 ;D WRTERR^DGPTAE(DGPTERC,"N701",SEQ)
+3 SET ERROR=1
+4 QUIT
