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

ICDEXC4.m

Go to the documentation of this file. 
  1. ICDEXC4 ;SLC/KER - ICD Extractor - Code APIs (cont) ;12/19/2014
  1.  ;;18.0;DRG Grouper;**57,67**;Oct 20, 2000;Build 1
  1.  ;               
  1.  ; Global Variables
  1.  ;    None
  1.  ;               
  1.  ; External References
  1.  ;    None
  1.  ;               
  1.  Q
  1. SDH(FILE,IEN,ARY) ; Short Description History
  1.  ;            
  1.  ; Input:
  1.  ; 
  1.  ;   FILE    File Number (Required)
  1.  ;   IEN     Internal Entry Number (Required)
  1.  ;  .ARY     Array Passed by Reference (Optional)
  1.  ;   
  1.  ; Output:
  1.  ; 
  1.  ;   $$SDH   This is a three piece "^" delimited 
  1.  ;           string containing:
  1.  ;           
  1.  ;              1   Number of short descriptions found
  1.  ;              2   The earliest date found
  1.  ;              3   The latest date found
  1.  ;              
  1.  ;           OR -1 ^ Error Message
  1.  ;           
  1.  ;   ARY     Short Descriptions by date
  1.  ;   
  1.  ;              ARY(0)= # ^ Earliest Date ^ Latest Date
  1.  ;              ARY(DATE)=Long Description
  1.  ;   
  1.  K ARY N EFF,TXT,HIS,ROOT,CNT,FD,LD,BEG,END S IEN=+($G(IEN)),LD=0,FD=9999999
  1.  S FILE=$$FILE^ICDEX($G(FILE)) Q:"^80^80.1^"'[("^"_FILE_"^") "-1^File not found"
  1.  S ROOT=$S(FILE=80:"^ICD9(",FILE=80.1:"^ICD0(",1:"")
  1.  Q:'$L(ROOT) "-1^File not found"  S CNT=0
  1.  S HIS=0 F  S HIS=$O(@(ROOT_+IEN_",67,"_+HIS_")")) Q:+HIS'>0  D
  1.  . N NOD,EFF,TXT S NOD=$G(@(ROOT_+IEN_",67,"_+HIS_",0)"))
  1.  . S EFF=$P(NOD,"^",1),TXT=$P(NOD,"^",2) Q:EFF'?7N  Q:'$L(TXT)
  1.  . S:EFF<FD FD=EFF  S:EFF>LD LD=EFF
  1.  . S CNT=CNT+1,ARY(0)=CNT,ARY(EFF)=TXT
  1.  S (BEG,END)="" S:FD?7N&(FD'=9999999)&(FD'>LD) BEG=FD S:LD?7N&(LD'<FD) END=LD
  1.  S:BEG?7N&(END?7N)&(CNT>0) ARY(0)=CNT_"^"_BEG_"^"_END S CNT=ARY(0)
  1.  I +CNT'>0 D  Q ERR
  1.  . N TYP S TYP=$S(FILE=80:"Diagnosis",FILE=80.1:"Operation/Procedure",1:"")
  1.  . S:$L(TYP) ERR="-1^No "_TYP_" Short Descriptions found"
  1.  . S:'$L(TYP) ERR="-1^No Short Descriptions found"
  1.  Q CNT
  1. LDH(FILE,IEN,ARY) ; Long Description History
  1.  ;            
  1.  ; Input:
  1.  ; 
  1.  ;   FILE    File Number (Required)
  1.  ;   IEN     Internal Entry Number (Required)
  1.  ;  .ARY     Array Passed by Reference (Optional)
  1.  ;  
  1.  ; Output:
  1.  ; 
  1.  ;   $$LDH   This is a three piece "^" delimited 
  1.  ;           string containing:
  1.  ;           
  1.  ;             1   Number of long descriptions found
  1.  ;             2   The earliest date found
  1.  ;             3   The latest date found
  1.  ;              
  1.  ;           OR -1 ^ Error Message
  1.  ;           
  1.  ;   ARY     Long Descriptions by date
  1.  ;   
  1.  ;             ARY(0)= # ^ Earliest Date ^ Latest Date
  1.  ;             ARY(DATE)=Long Description
  1.  ;              
  1.  K ARY N EFF,TXT,HIS,ROOT,CNT,FD,LD,BEG,END S IEN=+($G(IEN)),LD=0,FD=9999999
  1.  S FILE=$$FILE^ICDEX($G(FILE)) Q:"^80^80.1^"'[("^"_FILE_"^") "-1^File not found"
  1.  S ROOT=$S(FILE=80:"^ICD9(",FILE=80.1:"^ICD0(",1:"")
  1.  Q:'$L(ROOT) "-1^File not found"  S CNT=0
  1.  S HIS=0 F  S HIS=$O(@(ROOT_+IEN_",68,"_+HIS_")")) Q:+HIS'>0  D
  1.  . N NOD,EFF,TXT S EFF=$P($G(@(ROOT_+IEN_",68,"_+HIS_",0)")),"^",1)
  1.  . S TXT=$P($G(@(ROOT_+IEN_",68,"_+HIS_",1)")),"^",1)
  1.  . Q:EFF'?7N  Q:'$L(TXT)
  1.  . S:EFF<FD FD=EFF  S:EFF>LD LD=EFF
  1.  . S CNT=CNT+1,ARY(0)=CNT,ARY(EFF)=TXT
  1.  S (BEG,END)="" S:FD?7N&(FD'=9999999)&(FD'>LD) BEG=FD S:LD?7N&(LD'<FD) END=LD
  1.  S:BEG?7N&(END?7N)&(CNT>0) ARY(0)=CNT_"^"_BEG_"^"_END S CNT=ARY(0)
  1.  I +CNT'>0 D  Q ERR
  1.  . N TYP S TYP=$S(FILE=80:"Diagnosis",FILE=80.1:"Operation/Procedure",1:"")
  1.  . S:$L(TYP) ERR="-1^No "_TYP_" Long Descriptions found"
  1.  . S:'$L(TYP) ERR="-1^No Long Descriptions found"
  1.  Q CNT
  1. RDX(CODE,CDT) ; Resolve Diagnosis Code Fragment
  1.  ;
  1.  ; Input
  1.  ; 
  1.  ;    X         Code or Code Fragment (Required)
  1.  ;    CDT       Versioning Date (Optional, Default TODAY)
  1.  ;    
  1.  ; Output
  1.  ; 
  1.  ;    $$RDX     Code if resolved
  1.  ;              -1 ^ error message if not resolved
  1.  ;    
  1.  ; Example: 
  1.  ;    
  1.  ;    Fragment    Oct 1, 2014     Oct 1, 2015
  1.  ;    E8310         E831.0           E83.10
  1.  ;    311           311.             311.
  1.  ;    A870          A87.0            A87.0
  1.  ;    A0201         -1^Could not resolve code fragment
  1.  ;    
  1.  N ICD1,ICD2,ICDC,ICDCD,ICDID,ICDIN,ICDND,ICDNX,ICDO,ICDON,ICDOP,ICDPR,ICDR,ICDS,ICDT,ICDX
  1.  S (ICDO,ICDX)=$$UP^XLFSTR(CODE),ICDC=$E(ICDO,1),ICDR="^ICD9(" Q:'$L(ICDX) "-1^Invalid input"  S ICDCD=$P($G(CDT),".",1)
  1.  S:'$L(ICDCD) ICDCD=$$DT^XLFDT S ICDID=$$IMP^ICDEX(30) S ICDS="" S:ICDCD?7N ICDS=$S((ICDCD+.001)>ICDID:30,1:1)
  1.  S:ICDS=1&("ABCDFGHIJKLMNOPQRSTUWXYZ"[ICDC) ICDS=30 S:ICDS=30&(ICDC?1N) ICDS=1
  1.  Q:'$L(ICDS)!(ICDS'?1N.N) "-1^Invalid system"  I $D(@(ICDR_"""ABA"","_+ICDS_","""_ICDX_" "")")) S CODE=ICDX Q CODE
  1.  F ICDT=".",".0",".00","0","00" D
  1.  . S:$E(ICDX,1)?1N&($D(@(ICDR_"""ABA"","_+ICDS_","""_ICDX_ICDT_" "")"))) ICDX=ICDX_ICDT
  1.  . S:$E(ICDX,1)="E"&($E(ICDX,2,4)?3N)&($D(@(ICDR_"""ABA"","_+ICDS_","""_ICDX_ICDT_" "")"))) ICDX=ICDX_ICDT
  1.  . S:$E(ICDX,1)?1U&($E(ICDX,2,3)?2N)&($D(@(ICDR_"""ABA"","_+ICDS_","""_ICDX_ICDT_" "")"))) ICDX=ICDX_ICDT
  1.  I ICDX'=ICDO,$D(@(ICDR_"""ABA"","_+ICDS_","""_ICDX_" "")")) S CODE=ICDX Q CODE
  1.  I ICDX=ICDO,ICDX'["." D
  1.  . N ICD1,ICD2 S ICD1=$E(ICDX,1,3),ICD2=$E(ICDX,4,$L(ICDX)) S:$E(ICDX,1)="E"&(ICDS=1) ICD1=$E(ICDX,1,4),ICD2=$E(ICDX,5,$L(ICDX))
  1.  . S:$E(ICDX,1)="E"&(ICDS=30) ICD1=$E(ICDX,1,3),ICD2=$E(ICDX,4,$L(ICDX)) Q:$E(ICDX,1)="E"&(ICDS=1)&($L(ICD1)'=4)
  1.  . Q:$E(ICDX,1)="E"&(ICDS=30)&($L(ICD1)'=3)  Q:$E(ICDX,1)'="E"&($L(ICD1)'=3)  S ICDX=ICD1_"."_ICD2
  1.  I ICDX'=ICDO,$D(@(ICDR_"""ABA"","_+ICDS_","""_ICDX_" "")")) S CODE=ICDX Q CODE
  1.  I ICDX=ICDO D
  1.  . F ICDT=".",".0",".00","0","00" D
  1.  . . S:$E(ICDX,1)?1N&($D(@(ICDR_"""BA"","""_ICDX_ICDT_" "")"))) ICDX=ICDX_ICDT
  1.  . . S:$E(ICDX,1)="E"&($E(ICDX,2,4)?3N)&($D(@(ICDR_"""BA"","""_ICDX_ICDT_" "")"))) ICDX=ICDX_ICDT
  1.  . . S:$E(ICDX,1)?1U&($E(ICDX,2,3)?2N)&($D(@(ICDR_"""BA"","""_ICDX_ICDT_" "")"))) ICDX=ICDX_ICDT
  1.  S CODE="-1^Could not resolve code fragment" S:$D(@(ICDR_"""BA"","""_ICDX_" "")")) CODE=ICDX
  1.  Q CODE
  1. TRIM(X,Y) ; Trim Character
  1.  ;
  1.  ; Input:
  1.  ;
  1.  ;   X     Input String
  1.  ;   Y     Character to Trim (default " ")
  1.  ;
  1.  ; Output:
  1.  ; 
  1.  ;   X     String without Leading/Trailing character Y
  1.  ;
  1.  S X=$G(X) Q:X="" X  S Y=$G(Y) S:'$L(Y) Y=" "
  1.  F  Q:$E(X,1)'=Y  S X=$E(X,2,$L(X))
  1.  F  Q:$E(X,$L(X))'=Y  S X=$E(X,1,($L(X)-1))
  1.  Q X