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

IBDFN7.m

Go to the documentation of this file.
  1. IBDFN7 ;ALB/CJM - ENCOUNTER FORM - validate logic for data ;05/10/95
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;**38,51,64,63**;APR 24, 1997;Build 80
  1. ;
  1. ;
  1. TESTCPT ;does X point to a valid CPT4 code? Kills X if not.
  1. ;
  1. ;;change to api cpt;dhh
  1. N XX
  1. S Y=""
  1. I $G(X)="" K X Q
  1. S XX=$$CPT^ICPTCOD($G(X))
  1. I +XX=-1 K X Q
  1. I $P(XX,U,7)'=1 K X S Y=$P(XX,U,3) Q
  1. S X=$P(XX,U) ;set X equal ien of cpt code
  1. Q
  1. ;
  1. TESTICD ; -- does X point to a valid ICD-9 code? Kills X if not.
  1. ; -- input the icd code in X
  1. ;
  1. N IBDCODE,IBDSTAT
  1. I $G(X)="" K X S Y="" Q
  1. ;S:$E(X,$L(X))'=" " X=X_" " ; use ba xref, add space to end for lookup.
  1. ;S X=$O(^ICD9("BA",X,0)) I 'X K X S Y="" Q
  1. ;I '$D(^ICD9(X,0)) K X S Y="" Q
  1. ;;I $P($G(^ICD9(X,0)),"^",9) S Y=$P(^ICD9(X,0),"^",3) K X
  1. ;S IBDCODE=$$ICDDX^ICDCODE(X)
  1. S IBDCODE=$$ICDDATA^ICDXCODE("ICD9",X,DT) S X=$P(IBDCODE,U) I 'X!(X<1) K X S Y="" Q
  1. S IBDSTAT=$P(IBDCODE,U,10) I IBDSTAT'=1 S Y=$P(IBDCODE,U,4) K X
  1. S IBDY=$P(IBDCODE,U,4)
  1. Q
  1. ;
  1. TESTICD0 ;
  1. ;-- does X point to a valid ICD-10 code? Kills X if not.
  1. ;-- input the icd code in X
  1. ;
  1. ;DT = Today's date
  1. ;
  1. ;STATUS:
  1. ; 0 = Inactive - ICD-10 Code is Inactive due to today's date being less than Active date.
  1. ; Example: Today's date = 10/01/2013; ICD-10 code Active date = 10/01/2014
  1. ; 10/01/2013 is less than 10/01/2014
  1. ;
  1. ; 1 = Active - ICD-10 Code is Active due to today's date being greater than or equal to Active date.
  1. ; Example: Today's date = 10/02/2014; ICD-10 code Active date = 10/01/2014
  1. ; 10/02/2014 is greater than 10/01/2014
  1. ; Example: Today's date = 10/01/2014; ICD-10 code Active date = 10/01/2014
  1. ; 10/01/2014 is equal to Active date 10/01/2014
  1. ;
  1. ; 2 = Inactive - ICD-10 Code is Inactive due to today's date being less than Implementation date.
  1. ; Example: Today's date = 09/30/2013; ICD-10 code Implementation date = 10/01/2013;
  1. ; 09/30/2013 is less than 10/01/2013
  1. ;
  1. N IBDCODE,IBDSTAT,IBDTEMPY
  1. I $G(X)="" K X S Y="" Q
  1. ;S IBDCODE=$$ICDDATA^ICDXCODE("10D",X,DT) S X=$P(IBDCODE,U) I 'X!(X<1) K X S Y="" Q
  1. ;S IBDSTAT=$P(IBDCODE,U,10) I IBDSTAT'=1 S Y=$P(IBDCODE,U,4) K X
  1. S IBDCODE=$$ICDDATA^ICDXCODE("10D",X,DT) S X=$P(IBDCODE,U) I 'X!(X<1) K X S Y="" Q
  1. S IBDSTAT=$$STATCHK^IBDUTICD("10D",$P(IBDCODE,U,2),DT)
  1. I IBDSTAT'=1 S Y=$P(IBDCODE,U,4) K X
  1. S IBDY=$P(IBDCODE,U,4)
  1. Q
  1. ;
  1. ;
  1. TESTVST ;does X point to a valid visit code? If not, kills X.
  1. ;checks that X is a valid CPT4 code and that there is a corresponding entry in the TYPE OF VISIT file that is active
  1. N IEN,XX
  1. I $G(X)="" K X S Y="" Q
  1. ;;change to api cpt;dhh
  1. S XX=$$CPT^ICPTCOD(X)
  1. I +XX=-1 K X S Y="" Q
  1. I $P(XX,U,7)'=1 K X S Y=$P(XX,U,3) Q
  1. S X=$P(XX,U) ;set X equal ien of cpt code
  1. Q:'$D(X)
  1. S IEN=$O(^IBE(357.69,"B",X,0)) K:'IEN X I IEN K:$P($G(^IBE(357.69,IEN,0)),"^",4) X
  1. Q
  1. ;
  1. TESTLEX ; -- Is clinical lexicon pointer valid and does icdone, not return 799.9
  1. N IBDIMP,IBDIBX
  1. S IBDIMP=$$IMPDATE^IBDUTICD("10D"),IBDIBX=799.9
  1. I DT'<IBDIMP S IBDIBX="R69."
  1. S IBDLEXV=1
  1. I $D(^LEX)>1 S X="LEXSET" X ^%ZOSF("TEST") I $T S IBDLEXV=2
  1. I IBDLEXV=1 D
  1. .I $G(X)="" K X S Y="" Q
  1. .I '$D(^GMP(757.01,+X,0)) K X S Y="" Q
  1. .S VAL=$$ICDONE^GMPTU(X)
  1. .I VAL="" K X S Y="No ICD"_$S(DT'<IBDIMP:"10",1:"9")_" code" Q
  1. .I VAL=IBDIBX K X S Y="ICD"_$S(DT'<IBDIMP:"10",1:"9")_" code "_IBDIBX Q
  1. .I $G(X)="" K X S Y="" Q
  1. .Q
  1. I IBDLEXV>1 D
  1. .I $G(X)="" K X S Y="" Q
  1. .I '$D(^LEX(757.01,+X,0)) K X S Y="" Q
  1. .S VAL=$$ICDONE^LEXU(X)
  1. .I VAL="" K X S Y="No ICD"_$S(DT'<IBDIMP:"10",1:"9")_" code" Q
  1. .I VAL=IBDIBX K X S Y="ICD"_$S(DT'<IBDIMP:"10",1:"9")_" code "_IBDIBX Q
  1. .Q
  1. Q