- FBICDP ;AISC/JAS - ICD-9 & 10 PROCEDURE CODE UTILITIES ;9/26/2013
- ;;3.5;FEE BASIS;**139**;JAN 30, 1995;Build 127
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ; References to API $$IMPDATE^LEXU supported by ICR #5679
- ; Reference to API $$FILE^ICDEX supported by ICR #5747
- ; Reference to API $$ROOT^ICDEX supported by ICR #5747
- ; Reference to API $$SYS^ICDEX supported by ICR #5747
- ; Reference to API $$ICDOP^ICDEX supported by ICR #5747
- ;
- ;THIS ROUTINE WAS CLONED FROM FBICD9, BUT HAS BEEN MODIFIED TO BE USED FOR ICD-9 AND ICD-10 PROCEDURE CODES.
- ; Input - FBIDT= date of interest to check FBPRMT= user prompt FBALW= allow user to early exit if set to Y
- ; ALDEL= allow deletion of Proc field? (optional) -if this is set to "Y", @ is an acceptable entry
- ; ALFREQ= allow forcing a field to be required (optional) -if this is set to "Y", the field will be forced to be required
- ; FBDFLT= default values for the search string (can be a code by default)
- ; Output- Y = IEN^Proc code OR -1^inactive code"
- ENICD9(FBIDT,FBPRMT,FBALW,ALDEL,ALFREQ,FBDFLT) ; prompt user for ICD procedure code and test if code is inactive
- N Y,DIC,FBICDCD,FBIMPDT K X
- S:'$D(FBALW) FBALW="N" ; early exit allow flag
- S:'$D(ALDEL) ALDEL="N" ; delete allow flag
- S:'$D(ALFREQ) ALFREQ="N" ; force required allow flag
- S FBICDCD=31,FBIMPDT=$$IMPDATE^FBCSV1("10D")
- S:FBIDT<FBIMPDT FBICDCD=2
- SRCH1 ;
- S Y=$$SEARCH(FBIDT)
- I (Y>0)&('$$ICD9ACT(+Y,FBIDT)) D
- . W !!,*7,"ICD Proc Code "_"("_$P(Y,U,2)_")"_" inactive on date of service ("_$$FMTE^XLFDT(FBIDT)_").",!
- . S Y="-1^inactive code"
- . Q
- Q Y
- ;
- ; Input -FBINDT = ICD versioning date
- ; Output -Y = IEN^Proc code
- SEARCH(FBINDT) ;
- I $G(FBDFLT)>0 S DIR("A")=FBPRMT_": "_$P($$ICDOP^ICDEX(FBDFLT,FBIDT,FBICDCD,"I"),"^",2)_"// "
- E S DIR("A")=FBPRMT_": "
- S DIR(0)="FAOr^0:245"
- S DIR("?")="Answer with ICD OPERATION/PROCEDURE CODE NUMBER, or DESCRIPTION"
- D ^DIR K DIR
- I ((X="@")&(ALFREQ="Y")) W "?? REQUIRED" G SRCH1
- I X="@",ALDEL="Y",$G(FBDFLT)="" S ALDEL="N"
- I X="@",ALDEL="Y" N FBYN D Q:FBYN=1 "@" G SRCH1
- . S FBYN=$$QUESTION^FBASF(2,"SURE YOU WANT TO DELETE")
- . I FBYN'=1 W " <NOTHING DELETED>"
- I X="@" W "??" G SRCH1
- I X="^",FBALW="Y" Q -1
- I X="^" W !,?4,"EXIT NOT ALLOWED ??" G SRCH1
- N ROOT,FILE,SYS,ICDVDT,FILEID,SCREEN,DISFIL
- S FILEID=80.1,SCREEN="I $$CHKVERS^FBICDP(+Y,FBINDT)",DISFIL="EIMQ"
- S FILE=$$FILE^ICDEX($G(FILEID)) Q:+FILE'>0 -1
- S (DIC,ROOT)=$$ROOT^ICDEX(FILE) Q:'$L(ROOT) -1
- S DIC("S")=$S($L($G(SCREEN)):$G(SCREEN),1:"I 1")
- S:$G(FBINDT) ICDVDT=$G(FBINDT)
- S SYS=$$SYS^ICDEX(FILE,$G(ICDVDT)) S:+SYS>0 ICDSYS=+SYS
- S DISFIL=$G(DISFIL,"EMQZ") S DISFIL=$TR(DISFIL,"L","") K DLAYGO
- S DIC(0)=DISFIL D ^DIC K DIC,ICDSYS,ICDFMT
- S:+($G(Y))'>0 Y=-1
- G:((Y=-1)&($L(X)>0)) SRCH1
- Q Y
- ;
- ;Input : Y (ien of file 80.1), (date of interest)
- ;Output: 1 (true) or 0 (false)
- CHKVERS(FBDIRY,FBDT) ; return true (1) if procedure code is a current versioned Proc code, otherwise return false (0)
- N FBICDSYS,FBINF,FBIC9SYS
- S FBICDSYS=$S(FBDT<$$IMPDATE^LEXU(31):2,1:31) ; 2 = icd-9 version 31 = icd-10 version
- S FBIC9SYS=$P($$ICDOP^ICDEX(FBDIRY,FBDT,"","I"),U,15) ; 2 = icd-9 version 31 = icd-10 version
- Q:FBICDSYS=FBIC9SYS 1 ; returns true
- Q 0 ; returns false
- ;
- ICD9ACT(IEN,FBDT) ;Is the given code active for the date? (default-today)
- N FBINF,FBRES
- I '$G(FBDT) S FBDT=DT
- S FBRES=0
- S FBINF=$$ICDOP^ICDEX(IEN,FBDT,"","I")
- I FBINF'<0,$P(FBINF,U,10) S FBRES=1
- Q FBRES
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBICDP 3577 printed Mar 13, 2025@21:03:28 Page 2
- FBICDP ;AISC/JAS - ICD-9 & 10 PROCEDURE CODE UTILITIES ;9/26/2013
- +1 ;;3.5;FEE BASIS;**139**;JAN 30, 1995;Build 127
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ; References to API $$IMPDATE^LEXU supported by ICR #5679
- +5 ; Reference to API $$FILE^ICDEX supported by ICR #5747
- +6 ; Reference to API $$ROOT^ICDEX supported by ICR #5747
- +7 ; Reference to API $$SYS^ICDEX supported by ICR #5747
- +8 ; Reference to API $$ICDOP^ICDEX supported by ICR #5747
- +9 ;
- +10 ;THIS ROUTINE WAS CLONED FROM FBICD9, BUT HAS BEEN MODIFIED TO BE USED FOR ICD-9 AND ICD-10 PROCEDURE CODES.
- +11 ; Input - FBIDT= date of interest to check FBPRMT= user prompt FBALW= allow user to early exit if set to Y
- +12 ; ALDEL= allow deletion of Proc field? (optional) -if this is set to "Y", @ is an acceptable entry
- +13 ; ALFREQ= allow forcing a field to be required (optional) -if this is set to "Y", the field will be forced to be required
- +14 ; FBDFLT= default values for the search string (can be a code by default)
- +15 ; Output- Y = IEN^Proc code OR -1^inactive code"
- ENICD9(FBIDT,FBPRMT,FBALW,ALDEL,ALFREQ,FBDFLT) ; prompt user for ICD procedure code and test if code is inactive
- +1 NEW Y,DIC,FBICDCD,FBIMPDT
- KILL X
- +2 ; early exit allow flag
- if '$DATA(FBALW)
- SET FBALW="N"
- +3 ; delete allow flag
- if '$DATA(ALDEL)
- SET ALDEL="N"
- +4 ; force required allow flag
- if '$DATA(ALFREQ)
- SET ALFREQ="N"
- +5 SET FBICDCD=31
- SET FBIMPDT=$$IMPDATE^FBCSV1("10D")
- +6 if FBIDT<FBIMPDT
- SET FBICDCD=2
- SRCH1 ;
- +1 SET Y=$$SEARCH(FBIDT)
- +2 IF (Y>0)&('$$ICD9ACT(+Y,FBIDT))
- Begin DoDot:1
- +3 WRITE !!,*7,"ICD Proc Code "_"("_$PIECE(Y,U,2)_")"_" inactive on date of service ("_$$FMTE^XLFDT(FBIDT)_").",!
- +4 SET Y="-1^inactive code"
- +5 QUIT
- End DoDot:1
- +6 QUIT Y
- +7 ;
- +8 ; Input -FBINDT = ICD versioning date
- +9 ; Output -Y = IEN^Proc code
- SEARCH(FBINDT) ;
- +1 IF $GET(FBDFLT)>0
- SET DIR("A")=FBPRMT_": "_$PIECE($$ICDOP^ICDEX(FBDFLT,FBIDT,FBICDCD,"I"),"^",2)_"// "
- +2 IF '$TEST
- SET DIR("A")=FBPRMT_": "
- +3 SET DIR(0)="FAOr^0:245"
- +4 SET DIR("?")="Answer with ICD OPERATION/PROCEDURE CODE NUMBER, or DESCRIPTION"
- +5 DO ^DIR
- KILL DIR
- +6 IF ((X="@")&(ALFREQ="Y"))
- WRITE "?? REQUIRED"
- GOTO SRCH1
- +7 IF X="@"
- IF ALDEL="Y"
- IF $GET(FBDFLT)=""
- SET ALDEL="N"
- +8 IF X="@"
- IF ALDEL="Y"
- NEW FBYN
- Begin DoDot:1
- +9 SET FBYN=$$QUESTION^FBASF(2,"SURE YOU WANT TO DELETE")
- +10 IF FBYN'=1
- WRITE " <NOTHING DELETED>"
- End DoDot:1
- if FBYN=1
- QUIT "@"
- GOTO SRCH1
- +11 IF X="@"
- WRITE "??"
- GOTO SRCH1
- +12 IF X="^"
- IF FBALW="Y"
- QUIT -1
- +13 IF X="^"
- WRITE !,?4,"EXIT NOT ALLOWED ??"
- GOTO SRCH1
- +14 NEW ROOT,FILE,SYS,ICDVDT,FILEID,SCREEN,DISFIL
- +15 SET FILEID=80.1
- SET SCREEN="I $$CHKVERS^FBICDP(+Y,FBINDT)"
- SET DISFIL="EIMQ"
- +16 SET FILE=$$FILE^ICDEX($GET(FILEID))
- if +FILE'>0
- QUIT -1
- +17 SET (DIC,ROOT)=$$ROOT^ICDEX(FILE)
- if '$LENGTH(ROOT)
- QUIT -1
- +18 SET DIC("S")=$SELECT($LENGTH($GET(SCREEN)):$GET(SCREEN),1:"I 1")
- +19 if $GET(FBINDT)
- SET ICDVDT=$GET(FBINDT)
- +20 SET SYS=$$SYS^ICDEX(FILE,$GET(ICDVDT))
- if +SYS>0
- SET ICDSYS=+SYS
- +21 SET DISFIL=$GET(DISFIL,"EMQZ")
- SET DISFIL=$TRANSLATE(DISFIL,"L","")
- KILL DLAYGO
- +22 SET DIC(0)=DISFIL
- DO ^DIC
- KILL DIC,ICDSYS,ICDFMT
- +23 if +($GET(Y))'>0
- SET Y=-1
- +24 if ((Y=-1)&($LENGTH(X)>0))
- GOTO SRCH1
- +25 QUIT Y
- +26 ;
- +27 ;Input : Y (ien of file 80.1), (date of interest)
- +28 ;Output: 1 (true) or 0 (false)
- CHKVERS(FBDIRY,FBDT) ; return true (1) if procedure code is a current versioned Proc code, otherwise return false (0)
- +1 NEW FBICDSYS,FBINF,FBIC9SYS
- +2 ; 2 = icd-9 version 31 = icd-10 version
- SET FBICDSYS=$SELECT(FBDT<$$IMPDATE^LEXU(31):2,1:31)
- +3 ; 2 = icd-9 version 31 = icd-10 version
- SET FBIC9SYS=$PIECE($$ICDOP^ICDEX(FBDIRY,FBDT,"","I"),U,15)
- +4 ; returns true
- if FBICDSYS=FBIC9SYS
- QUIT 1
- +5 ; returns false
- QUIT 0
- +6 ;
- ICD9ACT(IEN,FBDT) ;Is the given code active for the date? (default-today)
- +1 NEW FBINF,FBRES
- +2 IF '$GET(FBDT)
- SET FBDT=DT
- +3 SET FBRES=0
- +4 SET FBINF=$$ICDOP^ICDEX(IEN,FBDT,"","I")
- +5 IF FBINF'<0
- IF $PIECE(FBINF,U,10)
- SET FBRES=1
- +6 QUIT FBRES
- +7 ;
