DGPT501 ;ALB/MTC,HIOFO/FT - Set up process 501 transmission ;11/5/14 4:35pm
;;5.3;Registration;**64,164,529,729,884**;Aug 13, 1993;Build 31
;
;no external references
;
EN ;
N ERROR
S DGPTEDFL=0
PARSE ; Set up record string, parse record
S DGPTSTR=^TMP("AEDIT",$J,NODE,SEQ)
D SET^DGPT501P
DATE ;date/time of movement
S DGPTMDT=$E(DGPTSTR,31,40),(X,DGPTMDTS)=$$FMDT^DGPT101($E(DGPTMDT,1,6))_"."_$E(DGPTMDT,7,10) S %DT="XT" D ^%DT K %DT I Y<0 S DGPTERC=505 D ERR G:DGPTEDFL EXIT G ELAPS
D DD^%DT S DGPTMDT=$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")
I DGPTMDT'?1.2N1"-"3U1"-"4N1" "2N1":"2N S DGPTERC=505 D ERR G:DGPTEDFL EXIT G TSPEC
I DGPTMDTS<DGPTDTS S DGPTERC=537 D ERR G:DGPTEDFL EXIT
I DGPTMDTS>DGPTDDS S DGPTERC=540 D ERR G:DGPTEDFL EXIT
ELAPS ;elapsed days between movement & leave days & pass days
S DGPTERC=0 S X1=DGPTMDTS D 501^DGPTAE03 I DGPTERC D ERR G:DGPTEDFL EXIT
TSPEC ;treating specialty
N DGPTMSC1
I DGPTMSC'?2AN S DGPTERC=506 D ERR G:DGPTEDFL EXIT G LEAV
S DGPTSP1=$E(DGPTMSC,1),DGPTSP2=$E(DGPTMSC,2),DGPTERC=0
D CHECK^DGPTAE02 I DGPTERC S DGPTERC=506 D ERR G:DGPTEDFL EXIT G LEAV
;-- Active treating specialty edit check
I $E(DGPTMSC,1)=0!($E(DGPTMSC,1)=" ") S DGPTMSC=$E(DGPTMSC,2)
; DGPTMSC := ptf code (alpha-numeric) value (file:42.4,field:7)
; DGPTMSC1 := dinum value (ien, file:42.4,field:001)
S DGPTMSC1=+$O(^DIC(42.4,"C",DGPTMSC,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,DGPTMSC1,DGPTMDTS) S DGPTERC=506,DGPTSER(DGPTMDTS_501)=1 D ERR G:DGPTEDFL EXIT
LEAV ;
I DGPTMPD'?1.3N S DGPTERC=508 D ERR G:DGPTEDFL EXIT
SPINL ;spinal cord injury
D SP^DGPTAE03 I DGPTERC D ERR G:DGPTEDFL EXIT
LOCCDR ;physical location cdr
I DGPTMLR'?6N S DGPTERC=575 D ERR G:DGPTEDFL EXIT G LOCTRS
;
LOCTRS ;physical location
I DGPTMLC'?2AN&(DGPTMLC'=" ") S DGPTERC=576 D ERR G:DGPTEDFL EXIT G DIAG
I DGPTMLC=" "&(DGPTMLR="000000") G DIAG
S DGPTSP1=$E(DGPTMLC,1),DGPTSP2=$E(DGPTMLC,2),DGPTERC=0
D CHECK^DGPTAE02 I DGPTERC S DGPTERC=576 D ERR G:DGPTEDFL EXIT
DIAG ;diagnosis
D ^DGPT50DI G:DGPTEDFL EXIT
BSTAT ;bed status
I "12345 "'[DGPTMBS S DGPTERC=515 D ERR G:DGPTEDFL EXIT
FY92 ;
I DGPTDDS<2911001 G GOOD
LEG ; Legionnaires disease
;S DGPTERC=0 D LEG^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT //no longer used because of DG*5.3*683 (7/1/06). ft 10/30/14
I DGPTFMT=2 D ;DGPTMLG is still set with ICD9, but will not be set when ICD10 becomes active.
.I DGPTMLG'=" " S DGPTERC=531 D ERR
SUI ; Suicide indicator
;DGPTMSU is set with ICD9, but not set when ICD10 becomes active.
I DGPTFMT=2 S DGPTERC=0 D SUI^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT
DRUG ; Drug indicator
;DGPTMDG is set with ICD9, but not set when ICD10 becomes active.
;However, this field was made inactive with DG*5.3*683 (7/1/06). ft (10/30/14)
;S DGPTERC=0 D DRUG^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT
I DGPTFMT=2 I DGPTMDG'=" " S DGPTERC=533 D ERR G:DGPTEDFL EXIT
AXES ;Axis 4 and 5
;DGPTMXIV,DGPTMXV1 & DGPTMXV2 are set with ICD9, but will not be set when ICD10 becomes active. ft (10/30/14)
I DGPTFMT=2 D
.I '$P($G(^DIC(42.4,+DGPTMSC1,0)),U,4) S (DGPTMXIV,DGPTMXV1,DGPTMXV2)=" " Q ;why one space apiece? ft 11/5/14
.S DGPTERC=0 D AXIV^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT
.S DGPTERC=0 D AXV1^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT
.S DGPTERC=0 D AXV2^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT
SERVC ; Service connected indicator
;DGPT50SR is set with ICD9, but will not be set when ICD10 becomes active. ft (10/30/14)
I DGPTFMT=2 S DGPTERC=0 D SRVC^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT
APSSN ;attending physician ssn
;new with new record layout in DG*5.3*884. ft (10/30/14)
I DGPTFMT=3 D APSSN^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT
GOOD ;
W:'$D(ERROR) "."
EXIT ;
K DGPTMD1,DGPTMD2,DGPTMD3,DGPTMD4,DGPTMD5,DGPTMD6,DGPTMD7,DGPTMD8,DGPTMD9,DGPTMD10,DGPTMD11,DGPTMD12,DGPTMD13,DGPTMD14,DGPTMD15
K DGPTMD16,DGPTMD17,DGPTMD18,DGPTMD19,DGPTMD20,DGPTMD21,DGPTMD22,DGPTMD23,DGPTMD24,DGPTMD25
K DGPTMDT,DGPTMDTS,DGPTMLC,DGPTMLD,DGPTMLR,DGPTMPD,DGPTMSC,DGPTMSI,DGPTMSR,DGPTMXX,DGPTSTR,DGPTS,DGPTSP1,DGPTSP2
K DGPTMLG,DGPTMSU,DGPTMDG,DGPTMXIV,DGPTMXV1,DGPTMXV2,DGPT50SR,DGPTMBS,DGPTAPSSN
Q
ERR ;
D WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
S ERROR=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPT501 4422 printed Sep 23, 2025@20:27:10 Page 2
DGPT501 ;ALB/MTC,HIOFO/FT - Set up process 501 transmission ;11/5/14 4:35pm
+1 ;;5.3;Registration;**64,164,529,729,884**;Aug 13, 1993;Build 31
+2 ;
+3 ;no external references
+4 ;
EN ;
+1 NEW ERROR
+2 SET DGPTEDFL=0
PARSE ; Set up record string, parse record
+1 SET DGPTSTR=^TMP("AEDIT",$JOB,NODE,SEQ)
+2 DO SET^DGPT501P
DATE ;date/time of movement
+1 SET DGPTMDT=$EXTRACT(DGPTSTR,31,40)
SET (X,DGPTMDTS)=$$FMDT^DGPT101($EXTRACT(DGPTMDT,1,6))_"."_$EXTRACT(DGPTMDT,7,10)
SET %DT="XT"
DO ^%DT
KILL %DT
IF Y<0
SET DGPTERC=505
DO ERR
if DGPTEDFL
GOTO EXIT
GOTO ELAPS
+2 DO DD^%DT
SET DGPTMDT=$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")
+3 IF DGPTMDT'?1.2N1"-"3U1"-"4N1" "2N1":"2N
SET DGPTERC=505
DO ERR
if DGPTEDFL
GOTO EXIT
GOTO TSPEC
+4 IF DGPTMDTS<DGPTDTS
SET DGPTERC=537
DO ERR
if DGPTEDFL
GOTO EXIT
+5 IF DGPTMDTS>DGPTDDS
SET DGPTERC=540
DO ERR
if DGPTEDFL
GOTO EXIT
ELAPS ;elapsed days between movement & leave days & pass days
+1 SET DGPTERC=0
SET X1=DGPTMDTS
DO 501^DGPTAE03
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
TSPEC ;treating specialty
+1 NEW DGPTMSC1
+2 IF DGPTMSC'?2AN
SET DGPTERC=506
DO ERR
if DGPTEDFL
GOTO EXIT
GOTO LEAV
+3 SET DGPTSP1=$EXTRACT(DGPTMSC,1)
SET DGPTSP2=$EXTRACT(DGPTMSC,2)
SET DGPTERC=0
+4 DO CHECK^DGPTAE02
IF DGPTERC
SET DGPTERC=506
DO ERR
if DGPTEDFL
GOTO EXIT
GOTO LEAV
+5 ;-- Active treating specialty edit check
+6 IF $EXTRACT(DGPTMSC,1)=0!($EXTRACT(DGPTMSC,1)=" ")
SET DGPTMSC=$EXTRACT(DGPTMSC,2)
+7 ; DGPTMSC := ptf code (alpha-numeric) value (file:42.4,field:7)
+8 ; DGPTMSC1 := dinum value (ien, file:42.4,field:001)
+9 SET DGPTMSC1=+$ORDER(^DIC(42.4,"C",DGPTMSC,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,DGPTMSC1,DGPTMDTS)
SET DGPTERC=506
SET DGPTSER(DGPTMDTS_501)=1
DO ERR
if DGPTEDFL
GOTO EXIT
LEAV ;
+1 IF DGPTMPD'?1.3N
SET DGPTERC=508
DO ERR
if DGPTEDFL
GOTO EXIT
SPINL ;spinal cord injury
+1 DO SP^DGPTAE03
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
LOCCDR ;physical location cdr
+1 IF DGPTMLR'?6N
SET DGPTERC=575
DO ERR
if DGPTEDFL
GOTO EXIT
GOTO LOCTRS
+2 ;
LOCTRS ;physical location
+1 IF DGPTMLC'?2AN&(DGPTMLC'=" ")
SET DGPTERC=576
DO ERR
if DGPTEDFL
GOTO EXIT
GOTO DIAG
+2 IF DGPTMLC=" "&(DGPTMLR="000000")
GOTO DIAG
+3 SET DGPTSP1=$EXTRACT(DGPTMLC,1)
SET DGPTSP2=$EXTRACT(DGPTMLC,2)
SET DGPTERC=0
+4 DO CHECK^DGPTAE02
IF DGPTERC
SET DGPTERC=576
DO ERR
if DGPTEDFL
GOTO EXIT
DIAG ;diagnosis
+1 DO ^DGPT50DI
if DGPTEDFL
GOTO EXIT
BSTAT ;bed status
+1 IF "12345 "'[DGPTMBS
SET DGPTERC=515
DO ERR
if DGPTEDFL
GOTO EXIT
FY92 ;
+1 IF DGPTDDS<2911001
GOTO GOOD
LEG ; Legionnaires disease
+1 ;S DGPTERC=0 D LEG^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT //no longer used because of DG*5.3*683 (7/1/06). ft 10/30/14
+2 ;DGPTMLG is still set with ICD9, but will not be set when ICD10 becomes active.
IF DGPTFMT=2
Begin DoDot:1
+3 IF DGPTMLG'=" "
SET DGPTERC=531
DO ERR
End DoDot:1
SUI ; Suicide indicator
+1 ;DGPTMSU is set with ICD9, but not set when ICD10 becomes active.
+2 IF DGPTFMT=2
SET DGPTERC=0
DO SUI^DGPT50MS
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
DRUG ; Drug indicator
+1 ;DGPTMDG is set with ICD9, but not set when ICD10 becomes active.
+2 ;However, this field was made inactive with DG*5.3*683 (7/1/06). ft (10/30/14)
+3 ;S DGPTERC=0 D DRUG^DGPT50MS I DGPTERC D ERR G:DGPTEDFL EXIT
+4 IF DGPTFMT=2
IF DGPTMDG'=" "
SET DGPTERC=533
DO ERR
if DGPTEDFL
GOTO EXIT
AXES ;Axis 4 and 5
+1 ;DGPTMXIV,DGPTMXV1 & DGPTMXV2 are set with ICD9, but will not be set when ICD10 becomes active. ft (10/30/14)
+2 IF DGPTFMT=2
Begin DoDot:1
+3 ;why one space apiece? ft 11/5/14
IF '$PIECE($GET(^DIC(42.4,+DGPTMSC1,0)),U,4)
SET (DGPTMXIV,DGPTMXV1,DGPTMXV2)=" "
QUIT
+4 SET DGPTERC=0
DO AXIV^DGPT50MS
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
+5 SET DGPTERC=0
DO AXV1^DGPT50MS
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
+6 SET DGPTERC=0
DO AXV2^DGPT50MS
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
End DoDot:1
SERVC ; Service connected indicator
+1 ;DGPT50SR is set with ICD9, but will not be set when ICD10 becomes active. ft (10/30/14)
+2 IF DGPTFMT=2
SET DGPTERC=0
DO SRVC^DGPT50MS
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
APSSN ;attending physician ssn
+1 ;new with new record layout in DG*5.3*884. ft (10/30/14)
+2 IF DGPTFMT=3
DO APSSN^DGPT50MS
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
GOOD ;
+1 if '$DATA(ERROR)
WRITE "."
EXIT ;
+1 KILL DGPTMD1,DGPTMD2,DGPTMD3,DGPTMD4,DGPTMD5,DGPTMD6,DGPTMD7,DGPTMD8,DGPTMD9,DGPTMD10,DGPTMD11,DGPTMD12,DGPTMD13,DGPTMD14,DGPTMD15
+2 KILL DGPTMD16,DGPTMD17,DGPTMD18,DGPTMD19,DGPTMD20,DGPTMD21,DGPTMD22,DGPTMD23,DGPTMD24,DGPTMD25
+3 KILL DGPTMDT,DGPTMDTS,DGPTMLC,DGPTMLD,DGPTMLR,DGPTMPD,DGPTMSC,DGPTMSI,DGPTMSR,DGPTMXX,DGPTSTR,DGPTS,DGPTSP1,DGPTSP2
+4 KILL DGPTMLG,DGPTMSU,DGPTMDG,DGPTMXIV,DGPTMXV1,DGPTMXV2,DGPT50SR,DGPTMBS,DGPTAPSSN
+5 QUIT
ERR ;
+1 DO WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
+2 SET ERROR=1
+3 QUIT
