Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPTAE04

DGPTAE04.m

Go to the documentation of this file.
  1. 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
  1. ;;ADL;Updated for CSV Project;;Mar 24, 2003
  1. ;
  1. ; ICDEX APIs - #5747
  1. ; ICDXCODE APIs - #5699
  1. ;
  1. TRAN ;-- verify transplant status
  1. Q:DGPTFMT=3 ;transplant status is not used with ICD-10
  1. I " 12"'[DGPT40PT S DGPTERC=417
  1. Q
  1. ;
  1. CHIEF ;chief surgeon
  1. N FLAG,I
  1. Q:"VMN"[DGPTSCS
  1. I "1234567"'[DGPTSCS S DGPTERC=407 Q
  1. S FLAG=1 F I=10,11,30,40,42 I DGPTSTTY["^"_I_"^" S FLAG=0 Q
  1. S:FLAG DGPTERC=407
  1. Q
  1. FAST ;first assistant
  1. N FLAG,I
  1. Q:DGPTSFA=" "
  1. S FLAG=0 F I=20:1:26 I DGPTSTTY["^"_I_"^" S FLAG=1,DGPTSFA=" " Q
  1. I FLAG Q
  1. I "12345678"'[DGPTSFA S DGPTERC=408 Q
  1. Q
  1. ANES ;anesthesia technique
  1. N FLAG,I
  1. Q:DGPTSAT=" "
  1. S FLAG=0 F I=20:1:26 I DGPTSTTY["^"_I_"^" S FLAG=1,DGPTSAT=" " Q
  1. I FLAG Q
  1. I "0123456789RX"'[DGPTSAT S DGPTERC=409 Q
  1. S DGPTERC=409 F I=10,11,30,40,42 I DGPTSTTY["^"_I_"^" S DGPTERC=0 Q
  1. Q
  1. ;
  1. FIRST ;-- Edit surgeries - present in ICD0 OPERATIONS, current, gender ok
  1. ;
  1. ; -- 850 - aas - hard coded ICD codes
  1. ; -- 39.610, 39.611, 39.612 inactive 10/1/79
  1. I (DGPTSO1="1371 ")!(DGPTSO1="39610 ")!(DGPTSO1="39611 ")!(DGPTSO1="39612 ") S DGPTERC=450 D ERR G:DGPTEDFL EXIT
  1. LOOP ;check surgery procedure codes
  1. I DGPTFMT=2 F DGPTL3=1:1:5 S DGPTERC=0 D CHKOPC I DGPTERC D ERR G:DGPTEDFL EXIT
  1. I DGPTFMT=3 F DGPTL3=1:1:25 S DGPTERC=0 D CHKOPC I DGPTERC D ERR G:DGPTEDFL EXIT
  1. Q
  1. CHKOPC ;
  1. N SYS,EFFDATE,IMPDATE,DGPTDAT
  1. D EFFDATE^DGPTIC10($G(PTF))
  1. S SYS=$$SYS^ICDEX("PROC",EFFDATE)
  1. S DGPTOC=@("DGPTSO"_DGPTL3),DGPTOC=$P(DGPTOC," ",1) Q:DGPTOC=""
  1. S DGPTERC=$S(DGPTL3<6:410+DGPTL3,DGPTL3<23:412+DGPTL3,1:423+DGPTL3)
  1. I SYS=2 S DGPTOC=$E(DGPTOC_" ",1,2)_"."_$E(DGPTOC,3,7)
  1. S DGPTOPP=+$$CODEN^ICDEX(DGPTOC,80.1) I $P(DGPTOPP,U,1)'=-1 S DGPTERC=0 D GEN Q
  1. Q
  1. GEN ;check patient's gender - 884 no longer flags a gender error
  1. N EFFDATE,IMPDATE,DGPTDAT
  1. D EFFDATE^DGPTIC10($G(PTF))
  1. ; DG*5.3*850
  1. 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
  1. S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",DGPTOPP,EFFDATE)
  1. ; DG*744 - check against discharge date
  1. 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
  1. ;I DGPTERC=451 Q
  1. ;I $P(DGPTTMP,U,11)]""&(DGPTGEN'=$P(DGPTTMP,U,11)) S DGPTERC=451 Q
  1. CURR ;current procedure. check procedure status, inactive date and surgery date
  1. S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",DGPTOPP,EFFDATE)
  1. 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
  1. SAVE ;
  1. S @("DGPTSO"_DGPTL3)=DGPTOC
  1. ARRAY ;
  1. S DGPTOPAR(DGPTSDD)=$S($D(DGPTOPAR(DGPTSDD)):DGPTOPAR(DGPTSDD)_U_DGPTOPP,1:DGPTOPP_U)
  1. Q
  1. EXIT ;
  1. K DGPTL3,DGPTOC,DGPTOC1,DGPTOPP
  1. Q
  1. ERR ;
  1. D WRTERR^DGPTAE(DGPTERC,NODE,SEQ)
  1. Q