DGPTAE04 ;ALB/MTC/ADL,HIOFO/FT - 401 Edit Checks Cont ;6/11/15 11:10am
;;5.3;Registration;**510,744,870,850,884**;Aug 13, 1993;Build 31
;;ADL;Updated for CSV Project;;Mar 24, 2003
;
; ICDEX APIs - #5747
; ICDXCODE APIs - #5699
;
TRAN ;-- verify transplant status
Q:DGPTFMT=3 ;transplant status is not used with ICD-10
I " 12"'[DGPT40PT S DGPTERC=417
Q
;
CHIEF ;chief surgeon
N FLAG,I
Q:"VMN"[DGPTSCS
I "1234567"'[DGPTSCS S DGPTERC=407 Q
S FLAG=1 F I=10,11,30,40,42 I DGPTSTTY["^"_I_"^" S FLAG=0 Q
S:FLAG DGPTERC=407
Q
FAST ;first assistant
N FLAG,I
Q:DGPTSFA=" "
S FLAG=0 F I=20:1:26 I DGPTSTTY["^"_I_"^" S FLAG=1,DGPTSFA=" " Q
I FLAG Q
I "12345678"'[DGPTSFA S DGPTERC=408 Q
Q
ANES ;anesthesia technique
N FLAG,I
Q:DGPTSAT=" "
S FLAG=0 F I=20:1:26 I DGPTSTTY["^"_I_"^" S FLAG=1,DGPTSAT=" " Q
I FLAG Q
I "0123456789RX"'[DGPTSAT S DGPTERC=409 Q
S DGPTERC=409 F I=10,11,30,40,42 I DGPTSTTY["^"_I_"^" S DGPTERC=0 Q
Q
;
FIRST ;-- Edit surgeries - present in ICD0 OPERATIONS, current, gender ok
;
; -- 850 - aas - hard coded ICD codes
; -- 39.610, 39.611, 39.612 inactive 10/1/79
I (DGPTSO1="1371 ")!(DGPTSO1="39610 ")!(DGPTSO1="39611 ")!(DGPTSO1="39612 ") S DGPTERC=450 D ERR G:DGPTEDFL EXIT
LOOP ;check surgery procedure codes
I DGPTFMT=2 F DGPTL3=1:1:5 S DGPTERC=0 D CHKOPC I DGPTERC D ERR G:DGPTEDFL EXIT
I DGPTFMT=3 F DGPTL3=1:1:25 S DGPTERC=0 D CHKOPC I DGPTERC D ERR G:DGPTEDFL EXIT
Q
CHKOPC ;
N SYS,EFFDATE,IMPDATE,DGPTDAT
D EFFDATE^DGPTIC10($G(PTF))
S SYS=$$SYS^ICDEX("PROC",EFFDATE)
S DGPTOC=@("DGPTSO"_DGPTL3),DGPTOC=$P(DGPTOC," ",1) Q:DGPTOC=""
S DGPTERC=$S(DGPTL3<6:410+DGPTL3,DGPTL3<23:412+DGPTL3,1:423+DGPTL3)
I SYS=2 S DGPTOC=$E(DGPTOC_" ",1,2)_"."_$E(DGPTOC,3,7)
S DGPTOPP=+$$CODEN^ICDEX(DGPTOC,80.1) I $P(DGPTOPP,U,1)'=-1 S DGPTERC=0 D GEN Q
Q
GEN ;check patient's gender - 884 no longer flags a gender error
N EFFDATE,IMPDATE,DGPTDAT
D EFFDATE^DGPTIC10($G(PTF))
; DG*5.3*850
S DGPTOPP=+$$CODEN^ICDEX(DGPTOC,80.1) I $P(DGPTOPP,U,1)=-1 S DGPTERC=$S(DGPTL3<6:410+DGPTL3,DGPTL3<23:412+DGPTL3,1:423+DGPTL3) Q
S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",DGPTOPP,EFFDATE)
; DG*744 - check against discharge date
I DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGPTERC=$S(DGPTL3<6:410+DGPTL3,DGPTL3<23:412+DGPTL3,1:423+DGPTL3) N DGPTDAT S DGPTDAT=+$G(^DGPT(PTF,70)) I DGPTDAT S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",DGPTOPP,EFFDATE) I $P(DGPTTMP,U,10)=1 S DGPTERC=0
;I DGPTERC=451 Q
;I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=451 Q
CURR ;current procedure. check procedure status, inactive date and surgery date
S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",DGPTOPP,EFFDATE)
I ($P(DGPTTMP,U,10)=0)&($P(DGPTSDD,1,7)>$P(DGPTTMP,U,12)) S DGPTERC=$S(DGPTL3<6:410+DGPTL3,DGPTL3<23:412+DGPTL3,1:423+DGPTL3) Q
SAVE ;
S @("DGPTSO"_DGPTL3)=DGPTOC
ARRAY ;
S DGPTOPAR(DGPTSDD)=$S($D(DGPTOPAR(DGPTSDD)):DGPTOPAR(DGPTSDD)_U_DGPTOPP,1:DGPTOPP_U)
Q
EXIT ;
K DGPTL3,DGPTOC,DGPTOC1,DGPTOPP
Q
ERR ;
D WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTAE04 3057 printed Oct 16, 2024@18:52:07 Page 2
DGPTAE04 ;ALB/MTC/ADL,HIOFO/FT - 401 Edit Checks Cont ;6/11/15 11:10am
+1 ;;5.3;Registration;**510,744,870,850,884**;Aug 13, 1993;Build 31
+2 ;;ADL;Updated for CSV Project;;Mar 24, 2003
+3 ;
+4 ; ICDEX APIs - #5747
+5 ; ICDXCODE APIs - #5699
+6 ;
TRAN ;-- verify transplant status
+1 ;transplant status is not used with ICD-10
if DGPTFMT=3
QUIT
+2 IF " 12"'[DGPT40PT
SET DGPTERC=417
+3 QUIT
+4 ;
CHIEF ;chief surgeon
+1 NEW FLAG,I
+2 if "VMN"[DGPTSCS
QUIT
+3 IF "1234567"'[DGPTSCS
SET DGPTERC=407
QUIT
+4 SET FLAG=1
FOR I=10,11,30,40,42
IF DGPTSTTY["^"_I_"^"
SET FLAG=0
QUIT
+5 if FLAG
SET DGPTERC=407
+6 QUIT
FAST ;first assistant
+1 NEW FLAG,I
+2 if DGPTSFA=" "
QUIT
+3 SET FLAG=0
FOR I=20:1:26
IF DGPTSTTY["^"_I_"^"
SET FLAG=1
SET DGPTSFA=" "
QUIT
+4 IF FLAG
QUIT
+5 IF "12345678"'[DGPTSFA
SET DGPTERC=408
QUIT
+6 QUIT
ANES ;anesthesia technique
+1 NEW FLAG,I
+2 if DGPTSAT=" "
QUIT
+3 SET FLAG=0
FOR I=20:1:26
IF DGPTSTTY["^"_I_"^"
SET FLAG=1
SET DGPTSAT=" "
QUIT
+4 IF FLAG
QUIT
+5 IF "0123456789RX"'[DGPTSAT
SET DGPTERC=409
QUIT
+6 SET DGPTERC=409
FOR I=10,11,30,40,42
IF DGPTSTTY["^"_I_"^"
SET DGPTERC=0
QUIT
+7 QUIT
+8 ;
FIRST ;-- Edit surgeries - present in ICD0 OPERATIONS, current, gender ok
+1 ;
+2 ; -- 850 - aas - hard coded ICD codes
+3 ; -- 39.610, 39.611, 39.612 inactive 10/1/79
+4 IF (DGPTSO1="1371 ")!(DGPTSO1="39610 ")!(DGPTSO1="39611 ")!(DGPTSO1="39612 ")
SET DGPTERC=450
DO ERR
if DGPTEDFL
GOTO EXIT
LOOP ;check surgery procedure codes
+1 IF DGPTFMT=2
FOR DGPTL3=1:1:5
SET DGPTERC=0
DO CHKOPC
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
+2 IF DGPTFMT=3
FOR DGPTL3=1:1:25
SET DGPTERC=0
DO CHKOPC
IF DGPTERC
DO ERR
if DGPTEDFL
GOTO EXIT
+3 QUIT
CHKOPC ;
+1 NEW SYS,EFFDATE,IMPDATE,DGPTDAT
+2 DO EFFDATE^DGPTIC10($GET(PTF))
+3 SET SYS=$$SYS^ICDEX("PROC",EFFDATE)
+4 SET DGPTOC=@("DGPTSO"_DGPTL3)
SET DGPTOC=$PIECE(DGPTOC," ",1)
if DGPTOC=""
QUIT
+5 SET DGPTERC=$SELECT(DGPTL3<6:410+DGPTL3,DGPTL3<23:412+DGPTL3,1:423+DGPTL3)
+6 IF SYS=2
SET DGPTOC=$EXTRACT(DGPTOC_" ",1,2)_"."_$EXTRACT(DGPTOC,3,7)
+7 SET DGPTOPP=+$$CODEN^ICDEX(DGPTOC,80.1)
IF $PIECE(DGPTOPP,U,1)'=-1
SET DGPTERC=0
DO GEN
QUIT
+8 QUIT
GEN ;check patient's gender - 884 no longer flags a gender error
+1 NEW EFFDATE,IMPDATE,DGPTDAT
+2 DO EFFDATE^DGPTIC10($GET(PTF))
+3 ; DG*5.3*850
+4 SET DGPTOPP=+$$CODEN^ICDEX(DGPTOC,80.1)
IF $PIECE(DGPTOPP,U,1)=-1
SET DGPTERC=$SELECT(DGPTL3<6:410+DGPTL3,DGPTL3<23:412+DGPTL3,1:423+DGPTL3)
QUIT
+5 SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",DGPTOPP,EFFDATE)
+6 ; DG*744 - check against discharge date
+7 IF DGPTTMP=-1!('$PIECE(DGPTTMP,U,10))
SET DGPTERC=$SELECT(DGPTL3<6:410+DGPTL3,DGPTL3<23:412+DGPTL3,1:423+DGPTL3)
NEW DGPTDAT
SET DGPTDAT=+$GET(^DGPT(PTF,70))
IF DGPTDAT
SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",DGPTOPP,EFFDATE)
IF $PIECE(DGPTTMP,U,10)=1
SET DGPTERC=0
+8 ;I DGPTERC=451 Q
+9 ;I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=451 Q
CURR ;current procedure. check procedure status, inactive date and surgery date
+1 SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",DGPTOPP,EFFDATE)
+2 IF ($PIECE(DGPTTMP,U,10)=0)&($PIECE(DGPTSDD,1,7)>$PIECE(DGPTTMP,U,12))
SET DGPTERC=$SELECT(DGPTL3<6:410+DGPTL3,DGPTL3<23:412+DGPTL3,1:423+DGPTL3)
QUIT
SAVE ;
+1 SET @("DGPTSO"_DGPTL3)=DGPTOC
ARRAY ;
+1 SET DGPTOPAR(DGPTSDD)=$SELECT($DATA(DGPTOPAR(DGPTSDD)):DGPTOPAR(DGPTSDD)_U_DGPTOPP,1:DGPTOPP_U)
+2 QUIT
EXIT ;
+1 KILL DGPTL3,DGPTOC,DGPTOC1,DGPTOPP
+2 QUIT
ERR ;
+1 DO WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
+2 QUIT
