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

IBDUTICD.m

Go to the documentation of this file.
  1. IBDUTICD ;ALB/SS - ICD10 UTILITIES ;07/20/11
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
  1. ;
  1. ;a wrapper for IMPDATE API
  1. IMPDATE(IBDCDSYS) ;
  1. Q $$IMPDATE^LEXU(IBDCDSYS)
  1. ;
  1. ;
  1. ;A wrapper for CODELIST API
  1. ;IBDCSYS - coding system (see #80.4)
  1. ;IBDSPEC - wild card search string
  1. ;IBDSUB - subscript for the ^TMP global
  1. ;IBDATE - date of interest
  1. ;IBDLEN - number of returned values
  1. ;IBDFMT - list format
  1. ;example:
  1. ;W $$CODELIST^LEX10CS("10D","E80*","ZZX",3150101,"",1)
  1. ;1^10
  1. ;Global ^TMP(,$J
  1. ;^TMP("IBDFN4_SS",543733994,0)=10
  1. ; 1)="E80.0"
  1. ;^TMP("IBDFN4_SS",543733994,1,1)="503506;ICD9(^E80.0^3131001"
  1. ; 2)="5002981^Hereditary Erythropoietic Porphyria"
  1. CODELIST(IBDCSYS,IBDSPEC,IBDSUB,IBDATE,IBDLEN,IBDFMT) ;
  1. N IBDRETV
  1. K ^TMP("IBDCODLST",$J)
  1. S IBDATE=$S($G(IBDATE)<$$IMPDATE(IBDCSYS):$$IMPDATE(IBDCSYS),1:$G(IBDATE))
  1. ;don't pass the date to perform the "unversioned lookup"
  1. S IBDRETV=$$CODELIST^LEX10CS(IBDCSYS,IBDSPEC,"IBDCODLST",,$G(IBDLEN),$G(IBDFMT))
  1. I $P(IBDRETV,U,1)<1!($P(IBDRETV,U,2)=0) Q IBDRETV
  1. ;cleanup the output array:
  1. ; - leave codes if the last status entry is ACTIVE
  1. ; - leave codes if the last status entry is INACTIVE but the last INACTIVE status date is greater than the current date
  1. S IBDRETV=$$REMINTMP("IBDCODLST",IBDSUB,IBDATE)
  1. K ^TMP("IBDCODLST",$J)
  1. Q IBDRETV
  1. ;
  1. ;for $$CODELIST^LEX10CS
  1. ; - leave codes if the last status entry is ACTIVE
  1. ; - leave codes if the last status entry is INACTIVE but the last INACTIVE status date is greater than the current date
  1. ; - remove all other codes
  1. ;and move results to another ^TMP
  1. REMINTMP(IBDSUB,IBDSUBOU,IBDDT) ;
  1. N IBDCOUNT,IBDZ1,IBDCODEV
  1. S IBDCOUNT=0
  1. S IBDZ1=0 F S IBDZ1=$O(^TMP(IBDSUB,$J,IBDZ1)) Q:+IBDZ1=0 D
  1. . S IBDCODEV=$G(^TMP(IBDSUB,$J,IBDZ1))
  1. . I $$FILTER(IBDCODEV,IBDDT)=1 S IBDCOUNT=IBDCOUNT+1 M ^TMP(IBDSUBOU,$J,IBDCOUNT)=^TMP(IBDSUB,$J,IBDZ1)
  1. ;set 0th node
  1. S:IBDCOUNT>0 ^TMP(IBDSUBOU,$J,0)=IBDCOUNT
  1. Q "1^"_(+IBDCOUNT)
  1. ;
  1. ;IBDCODEV - external value of the code
  1. ;IBDDATE - date of interest
  1. ;return 1:
  1. ; if the last status entry for the ICD is ACTIVE
  1. ; if the last status entry for the ICD is INACTIVE but the date of interest is less than the last status date
  1. ;return 0:
  1. ; if the last status entry for the ICD is INACTIVE but the date of interest greater or equal to the last status date
  1. ; if the status values is not valid
  1. FILTER(IBDCODEV,IBDDATE) ;
  1. N IBDARR,IBSTAT
  1. I $$HIST^ICDEX(IBDCODEV,.IBDARR,30)=-1 Q 0
  1. S IBSTAT=$$LASTSTAT(.IBDARR)
  1. I +IBSTAT=1 Q 1
  1. I +IBSTAT=0 I $P(IBSTAT,U,2)>IBDDATE Q 1
  1. Q 0
  1. ;
  1. ;return the date of the last active status (if there is only one then it is the last too)
  1. ;IBDCODEV - external value of the code
  1. ;return 0 if error
  1. ; date of the 1st activation status (doesn't matter active or inactive)
  1. LSTACTST(IBDCODEV) ;
  1. N IBDARR,IBSTAT,IBDT1
  1. I $$HIST^ICDEX(IBDCODEV,.IBDARR,30)=-1 Q 0
  1. S IBDT1=99999999
  1. F S IBDT1=$O(IBDARR(IBDT1),-1) Q:+IBDT1=0 I IBDARR(IBDT1)=1 Q
  1. Q +IBDT1
  1. ;for $$DIAGSRCH^LEX10CS in IBDLXDG
  1. ; - leave codes if the last status entry is ACTIVE
  1. ; - leave codes if the last status entry is INACTIVE but the last INACTIVE status date is greater than the current date
  1. ; - remove all other codes
  1. ;and move results to another local array
  1. REMINARR(IBDINOUT,IBDDT) ;
  1. Q:(+IBDINOUT)=-1 IBDINOUT
  1. N IBDCOUNT,IBDZ1,IBDCODEV,IBDINARR,IBD2PIEC
  1. S IBD2PIEC=+$P($G(IBDINOUT),U,2)
  1. M IBDINARR=IBDINOUT
  1. K IBDINOUT
  1. S IBDCOUNT=0
  1. S IBDZ1=0 F S IBDZ1=$O(IBDINARR(IBDZ1)) Q:+IBDZ1=0 D
  1. . S IBDCODEV=$P($G(IBDINARR(IBDZ1,0)),U)
  1. . I $$FILTER(IBDCODEV,IBDDT)=1 S IBDCOUNT=IBDCOUNT+1 M IBDINOUT(IBDCOUNT)=IBDINARR(IBDZ1)
  1. ;set 0th node
  1. I IBDCOUNT>0 S IBDINOUT(0)=IBDCOUNT_$S(IBD2PIEC>0:U_IBD2PIEC,1:""),IBDINOUT=IBDINOUT(0) Q IBDINOUT
  1. Q "-1"
  1. ;
  1. ;get the last status in the history of status changes
  1. LASTSTAT(IBDARR) ;
  1. N IBDX1,IBDX2
  1. S IBDX1=$O(IBDARR(99999999),-1)
  1. I +IBDX1=0 Q "-1"
  1. S IBDX2=$G(IBDARR(IBDX1))
  1. Q IBDX2_U_IBDX1
  1. ;
  1. ;A wrapper for the status check API
  1. ;input:
  1. ; IBDCDSYS - coding system like 1,30,"10D"
  1. ; IBDCOD - code value or IEN of files 80 or 80.1
  1. ; IBDDATE - the date we are checking the status against
  1. ;output:
  1. ; -1 - invalid code
  1. ; 0 - inactive
  1. ; 1 - active
  1. ; 2 - Before implementation date
  1. STATCHK(IBDCDSYS,IBDCOD,IBDDATE) ;
  1. N IBDRET
  1. ;if ICD10 diag or ICD-10 proced
  1. ;I IBDCDSYS=30!(IBDCDSYS=31)!(IBDCDSYS="10D")!(IBDCDSYS="10P"),IBDDATE<$$IMPDATE(IBDCDSYS) Q 2
  1. I IBDDATE<$$IMPDATE(IBDCDSYS) Q 2
  1. S IBDRET=$$ICDDATA^ICDXCODE(IBDCDSYS,IBDCOD,IBDDATE)
  1. I +IBDRET<0 Q IBDRET
  1. Q $P(IBDRET,U,10)
  1. ;
  1. ;set CODING SYSTEM UPDATE fields in #357
  1. ;Examples:
  1. ; ICD10 to incomplete
  1. ;W $$CSUPD357^IBDUTICD(21,30,"@")
  1. ; ICD9 to REVIEW
  1. ;W $$CSUPD357^IBDUTICD(21,1,"R")
  1. ; create a new ICD10 entry if doesn't exist with incomplete status
  1. ;W $$CSUPD357^IBDUTICD(21,30,"")
  1. ; update just date and user
  1. ;W $$CSUPD357^IBDUTICD(21,30,"",3150101,.5)
  1. ;
  1. ;IBD357I - ien in the file #357
  1. ;IBDCODS - ien of the coding system file #80.4
  1. ;IBDSTAT - status like "C" or "R" (use "@" to delete the value and make it INCOMPLETE)
  1. ;IBDDAT - date of the update
  1. ;IBDUSER - DUZ of the user (ptr to the file #200)
  1. CSUPD357(IBD357I,IBDCODS,IBDSTAT,IBDDAT,IBDUSER) ;
  1. N IBD35703
  1. S IBDSTAT=$G(IBDSTAT)
  1. S IBDDAT=+$G(IBDDAT) S IBDDAT=$S(IBDDAT>0:IBDDAT,1:DT)
  1. S IBDUSER=+$G(IBDUSER) S IBDUSER=$S(IBDUSER>0:IBDUSER,1:$S($G(DUZ)="":.5,1:+DUZ))
  1. S IBD35703=+$O(^IBE(357,IBD357I,3,"B",IBDCODS,0))
  1. I IBD35703=0 S IBD35703=$$NEW35703(IBD357I,IBDCODS,IBDSTAT,IBDDAT,IBDUSER) Q:IBD35703<0 Q $$UPD35703(IBD357I,IBD35703,"",IBDSTAT,IBDDAT,IBDUSER)
  1. Q $$UPD35703(IBD357I,IBD35703,IBDCODS,IBDSTAT,IBDDAT,IBDUSER)
  1. ;
  1. ;update the multiple with the status
  1. UPD35703(IBD357I,IBD35703,IBDCODS,IBDSTAT,IBDDAT,IBDUSER) ;
  1. N IBDVALAR,IBDCURST
  1. S:$G(IBDSTAT)'="" IBDVALAR(.02)=IBDSTAT
  1. I $G(IBDVALAR(.02))="@" K:$P($G(^IBE(357,IBD357I,3,IBD35703,0)),U,2)="" IBDVALAR(.02)
  1. S:$G(IBDCODS)'="" IBDVALAR(.01)=IBDCODS
  1. S:$G(IBDDAT)'="" IBDVALAR(.03)=IBDDAT
  1. S:$G(IBDUSER)'="" IBDVALAR(.04)=IBDUSER
  1. Q $$MULTFLDS^IBDUTIL1(357.03,IBD35703_","_IBD357I,.IBDVALAR,"I")
  1. ;
  1. ;W $$UPD35703^IBDUTICD(21,1,30,"C",DT,+DUZ)
  1. NEW35703(IBD357I,IBDCODS,IBDSTAT,IBDDAT,IBDUSER) ;
  1. N IBD35703
  1. I +$O(^IBE(357,IBD357I,3,"B",IBDCODS,0)) Q 0
  1. S IBD35703=$$INSREC01^IBDUTIL1(357.03,IBD357I,IBDCODS,"I")
  1. Q IBD35703
  1. ;
  1. ;if date is before the ICD-10 eff date then make it ICD-10 eff date
  1. ;if greater then leave it as is.
  1. ICD10DT(IBDATE) ;
  1. N IBD10DT
  1. S IBD10DT=$$IMPDATE(30)
  1. S IBDATE=$S($G(IBDATE)<IBD10DT:IBD10DT,1:$G(IBDATE))
  1. Q IBDATE
  1. ;
  1. ;prompt
  1. ACTPRMT() ;
  1. N DTOUT,DUOUT,DIRUT,DIROUT,DIR
  1. S DIR("B")="ACTIVE"
  1. S DIR(0)="SA^A:ACTIVE;I:INACTIVE"
  1. S DIR("A")="Display codes [A]ctive, [I]nactive: "
  1. D ^DIR
  1. I $D(DIRUT) Q -1
  1. I $D(DUOUT) Q -2
  1. I $D(DIROUT) Q -3
  1. Q $G(Y)
  1. ;
  1. ;IBDFICD