ICDDICA ;SLC/KER - ICD DIC Lookup Prototype ;04/21/2014
;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7
;
; Global Variables
; ^ICDS( N/A
; ^XTMP("ICDID") SACC 2.3.2.5.2
;
; External References
; ^%DT ICR 10003
; ^DIC ICR 10006
; $$GET1^DIQ ICR 2056
; ^DIR ICR 10026
; $$DT^XLFDT ICR 10103
; $$FMADD^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed in ICDDIC
; ICDCS,ICDDP,ICDFI,ICDFM,ICDOA,ICDVD,ICDVR
;
EN ;
W:$L($G(IOF)) @IOF
W ! S ICDDP=$$DP,ICDCS="" Q:ICDDP["^" Q:$D(DTOUT)!($D(DUOUT))
S ICDFI=$S(ICDDP="D":"80^ICD DIAGNOSIS",ICDDP="P":"80.1^ICD OPERATION/PROCEDURE",1:"")
Q:+ICDFI'>0 S ICDOA=$$OA(+ICDFI) Q:ICDOA["^" Q:$D(DTOUT)!($D(DUOUT))
S:ICDOA="O" ICDCS=$$CS(+ICDFI) Q:$D(DTOUT)!($D(DUOUT))
S ICDVR=$$VR(+ICDFI) Q:$D(DTOUT)!($D(DUOUT))
S ICDVD="" S:ICDVR>0 ICDVD=$$VD(+ICDFI) Q:$D(DTOUT)!($D(DUOUT))
N ICD10D S ICD10D=$$IMP^ICDEX(30) S ICDSRC=+ICDCS
S:+ICDCS'>0&(+ICDFI=80) ICDSRC=$S(+ICDVD<+ICD10D:1,1:30)
S:+ICDCS'>0&(+ICDFI=80.1) ICDSRC=$S(+ICDVD<+ICD10D:2,1:31)
S ICDFM=$$FM Q:$D(DTOUT)!($D(DUOUT))
N ICDTEST
Q
DP(X) ; Diagnosis or Procedure
N ICD,DIR,ICDB,ICDN,Y K ICD K DTOUT,DUOUT,DIRUT,DIROUT
S ICD="",DIR(0)="SAO^D:Diagnosis;P:Procedures"
S DIR("B")=$$RET("DP") S:'$L(DIR("B")) DIR("B")="Diagnosis"
S (DIR("?"),DIR("??"))="^D DPH^ICDDICA"
S DIR("PRE")="S X=$$DPP^ICDDICA($G(X))"
S DIR("A")=" Search ICD Diagnosis or Procedures (D/P): "
D ^DIR S X=Y
S ICDN="" S:X="D" ICDN="Diagnosis" S:X="P" ICDN="Procedures"
D:$L(ICDN) SAV("DP",ICDN)
Q X
DPP(X) ; Diagnosis or Procedure - Pre-process
Q:'$L($G(X)) "" Q:X["?" "??" Q:X["^^" "^^" Q:X["^" "^"
S X=$$UP^XLFSTR(X) Q:$E("OPERATIONS",1,$L(X))=X "Procedures"
Q:$E("PROCEDURES",1,$L(X))=X "Procedures" Q:$E("DIAGNOSIS",1,$L(X))=X "Diagnosis"
Q X
DPH ; Diagnosis or Procedure - Help
W !,?5,"Enter 'D' or 'Diagnosis' to search the ICD DIAGNOSIS file #80"
W !,?5,"Enter 'P' or 'Procedures' to search the ICD PROCEDURE file #80.1"
W !,?5,"Enter '^' to quit, and 'Return' to accept the default value."
Q
OA(X) ; One or All Coding System
N ICD,DIR,ICDB,ICDN,ICDF,Y K ICD K DTOUT,DUOUT,DIRUT,DIROUT
S ICDF=+($G(X)) Q:'$D(^ICDS("F",+ICDF)) "A"
S ICD="",DIR(0)="SAO^O:One System;A:All Systems"
S DIR("B")=$$RET("OA") S:'$L(DIR("B")) DIR("B")="All Coding Systems"
S (DIR("?"),DIR("??"))="^D OAH^ICDDICA"
S DIR("PRE")="S X=$$OAP^ICDDICA($G(X))"
S DIR("A")=" Search One or All Coding Systems in file "_ICDF_" (O/A): "
S DIR("A")=" Search One or All Coding Systems (O/A): "
D ^DIR S X=Y
S ICDN="" S:X="O" ICDN="One System" S:X="A" ICDN="All Systems"
D:$L(ICDN) SAV("OA",ICDN)
Q X
OAP(X) ; One or All Coding System - Pre-process
Q:'$L($G(X)) "" Q:X["?" "??" Q:X["^^" "^^" Q:X["^" "^" S X=$$UP^XLFSTR(X)
Q:$E("ONE CODING SYSTEM",1,$L(X))=X "One System"
Q:$E("ONE SYSTEM",1,$L(X))=X "One System"
Q:$E("ALL CODING SYSTEMS",1,$L(X))=X "All Systems"
Q:$E("ALL SYSTEMS",1,$L(X))=X "All Systems"
S:"^O^A"'[("^"_$E(X,1)_"^") X="??"
Q X
OAH ; One or All Coding System - Help
W !,?5,"Enter 'O' to search one coding system " W:+($G(ICDF))>0 "in file ",$G(ICDF)
W !,?5,"Enter 'A' to search all coding systems " W:+($G(ICDF))>0 "in file ",$G(ICDF)
I $D(^ICDS("F",+($G(ICDF)))) D
. N ICDI,ICDC S (ICDI,ICDC)=0 F S ICDI=$O(^ICDS("F",+($G(ICDF)),ICDI)) Q:ICDI'>0 D
. . N ICDS S ICDS=$P($G(^ICDS(ICDI,0)),"^",1) Q:'$L(ICDS) S ICDC=ICDC+1 W:ICDC=1 !
. . W !,?15,ICDS
Q
CS(X) ; Coding System
N ICD,DIC,ICDB,ICDBI,ICDN,ICDF,ICDI,ICDD,Y K ICD K DTOUT,DUOUT,DIRUT,DIROUT
S ICDF=+($G(X)) Q:'$D(^ICDS("F",+ICDF)) "^" S ICDI=$O(^ICDS("F",+ICDF," "),-1) Q:+ICDI'>0 "^"
S ICDD=$P($G(^ICDS(+ICDI,0)),"^",1) Q:'$L(ICDD) "^" S ICD="",DIC="^ICDS(",DIC(0)="AEQM"
S ICDB=$$RET("CS"),ICDBI=0 S:$L(ICDB) ICDBI=$O(^ICDS("B",ICDB,0))
S:$L(ICDB)&(+($G(ICDBI))'>0) ICDBI=$O(^ICDS("C",ICDB,0))
S:ICDBI>0&($P($G(^ICDS(+ICDBI,0)),"^",3)'=+ICDF) ICDB=""
S:$L(ICDB) DIC("B")=ICDB S:'$L($G(DIC("B")))&($L(ICDD)) DIC("B")=ICDD
S DIC("A")=" Select Coding Systems: "
S DIC("S")="I $G(ICDF)>0&($P($G(^ICDS(+Y,0)),""^"",3)=$G(ICDF))"
S (DIC("?"),DIC("??"))="^D CSH^ICDDICA"
D ^DIC I +Y>0 S ICDD=$P($G(^ICDS(+Y,0)),"^",1) D:$L(ICDD) SAV("CS",ICDD)
S X=Y
Q X
CSH ; One or All Coding System - Help
W !,?5,"Answer with ICD CODING SYSTEMS (i.e., "
W $S(+ICDF=80:"ICD-10-CM",+ICDF=80.1:"ICD-10-PCS",1:"ICD-10-CM")
W " or ICD CODING SYSTEM NOMENCLATURE, or"
W ?5,"CODING SYSTEM ABBREVIATION"
Q
I $D(^ICDS("F",+($G(ICDF)))) D
. N ICDI,ICDC S (ICDI,ICDC)=0 F S ICDI=$O(^ICDS("F",+($G(ICDF)),ICDI)) Q:ICDI'>0 D
. . N ICDS S ICDS=$P($G(^ICDS(ICDI,0)),"^",1) Q:'$L(ICDS) S ICDC=ICDC+1 W:ICDC=1 !
. . W !,?15,ICDS
Q
VR(X) ; Versioned Search
N ICD,DIR,ICDB,ICDN,Y K ICD K DTOUT,DUOUT,DIRUT,DIROUT
S ICD="",DIR(0)="YAO" S DIR("B")=$$RET("VR") S:'$L(DIR("B")) DIR("B")="Yes"
S (DIR("?"),DIR("??"))="^D VRH^ICDDICA"
S DIR("PRE")="S X=$$VRP^ICDDICA($G(X))"
S DIR("A")=" Conduct a versioned (date sensitive) Search (Y/N): "
D ^DIR S X=Y
S ICDN="" S:X="1" ICDN="Yes" S:X="0" ICDN="No"
D:$L(ICDN) SAV("VR",ICDN)
Q X
VRP(X) ; Diagnosis or Procedure - Pre-process
Q:'$L($G(X)) "" Q:X["?" "??" Q:X["^^" "^^" Q:X["^" "^"
S X=$$UP^XLFSTR(X) Q:$E("YES",1,$L(X))=X "Yes" Q:$E("NO",1,$L(X))=X "No"
S X="??"
Q X
VRH ; Diagnosis or Procedure - Help
W !,?5,"Enter 'Yes' to conduct a versioned search (date sensitive) or"
W !,?5,"enter 'No' to contuct an unversioned search.",!
W !,?5,"NOTE: Inactive codes will NOT be displayed during a versioned"
W !,?5," search (date sensitive) and will be displayed during an "
W !,?5," unversioned search (date doesn't matter)."
Q
VD(X) ; Versioned Date
N ICD,DIR,ICDB,ICDN,ICDTD,ICDD1,ICDD2,Y K ICD K DTOUT,DUOUT,DIRUT,DIROUT
S ICDTD=$$DT^XLFDT,ICDD1=2781001,ICDD2=$$FMADD^XLFDT(ICDTD,(365*5))
S DIR(0)="DAO^"_ICDD1_":"_ICDD2_":"
S DIR("B")=$$RET("VD") S:'$L(DIR("B")) DIR("B")=$$FMTE^XLFDT(ICDTD)
S (DIR("?"),DIR("??"))="^D VDH^ICDDICA"
S DIR("PRE")="S X=$$VDP^ICDDICA($G(X))"
S DIR("A")=" Enter a versioning date: "
S DIR("A")=" Enter a date from "_$$FMTE^XLFDT($G(ICDD1),"5Z")_" to "_$$FMTE^XLFDT($G(ICDD2),"5Z")_": "
D ^DIR S X=Y
S ICDN="" S:$P(X,".",1)?7N ICDN=$$UP^XLFSTR($$FMTE^XLFDT($P(X,".",1)))
D:$L(ICDN) SAV("VD",ICDN)
Q X
VDP(X) ; Diagnosis or Procedure - Pre-process
S X=$$UP^XLFSTR($G(X)) Q:'$L($G(X)) "" Q:X["?" "??" Q:X["^^" "^^" Q:X["^" "^"
N ICDI,ICDA,ICDO S (ICDA,ICDI)=$$EFM(X) S:ICDA#10000=0 ICDA=ICDA+101 S:ICDA#100=0 ICDA=ICDA+1
S:$E(ICDA,4,5)="00" ICDA=$E(ICDA,1,3)_"01"_$E(ICDA,6,7) S:$E(ICDA,6,7)="00" ICDA=$E(ICDA,1,5)_"01"
S ICDA=$P(ICDA,".",1) S ICDO=$$UP^XLFSTR($$FMTE^XLFDT(ICDA)) Q:ICDA?7N ICDO S X="??"
Q X
VDH ; Diagnosis or Procedure - Help
W !,?5,"Enter a date from ",$$FMTE^XLFDT($G(ICDD1))," to ",$$FMTE^XLFDT($G(ICDD2)),". Time is"
W !,?5,"allowed but not required. Code Set Business rules apply"
W !,?5,"for imprecise dates:",!
W !,?5," Month is missing: Use January"
W !,?5," Day is missing: Use the 1st"
Q
FM(X) ; Diagnosis or Procedure
N ICD,DIR,ICDB,ICDN,ICDSRC,Y K ICD K DTOUT,DUOUT,DIRUT,DIROUT S ICDSRC=$G(X) S ICD=""
S DIR(0)="SAO^1:FileMan Format;2:Modified FileMan Format;3:Short Lexicon Format;4:Long Lexicon Format"
S DIR("B")=$$RET("FM") S:'$L(DIR("B")) DIR("B")="FileMan Format"
S (DIR("?"),DIR("??"))="^D FMH^ICDDICA"
S DIR("PRE")="S X=$$FMP^ICDDICA($G(X))"
S DIR("A")=" Select Display Format (1-4): "
D ^DIR S X=Y S ICDN="" S:$L($G(Y(0))) ICDN=$G(Y(0))
D:$L(ICDN) SAV("FM",ICDN)
Q X
FMP(X) ; Diagnosis or Procedure - Pre-process
S X=$$UP^XLFSTR($G(X)) Q:'$L($G(X)) "" Q:X["?" "??" Q:X["^^" "^^" Q:X["^" "^"
Q:X=1 "FileMan Format" Q:X=2 "Modified FileMan Format" Q:X=3 "Short Lexicon Format" Q:X=4 "Long Lexicon Format"
Q:$E("FILEMAN FORMAT",1,$L(X))=X "FileMan Format"
Q:$E("MODIFIED FILEMAN FORMAT",1,$L(X))=X "Modified FileMan Format"
Q:$E("SHORT LEXICON FORMAT",1,$L(X))=X "Short Lexicon Format"
Q:$E("LONG LEXICON FORMAT",1,$L(X))=X "Long Lexicon Format"
S X="??"
Q X
FMH ; Display Format - Help
N ICDCOD,ICDSHRT,ICDLONG,ICDMIX
I $G(ICDSRC)=1!("^1^2^30^31^"'[("^"_+($G(ICDSRC))_"^")) D
. S ICDCOD="275.1"
. S ICDSHRT="DIS COPPER METABOLISM"
. S ICDLONG="DISORDERS OF COPPER METABOLISM"
. S ICDMIX="Disorders of Copper Metabolism"
I $G(ICDSRC)=2 D
. S ICDCOD="01.21"
. S ICDSHRT="CRANIAL SINUS I D"
. S ICDLONG="INCISION AND DRAINAGE OF CRANIAL SINUS"
. S ICDMIX="Incision and Drainage of Cranial Sinus"
I $G(ICDSRC)=30 D
. S ICDCOD="T36.0X1S"
. S ICDSHRT="Penicillin poisoning , acc, sequela"
. S ICDLONG="POISONING BY PENICILLINS, ACCIDENTAL, SEQUELA"
. S ICDMIX="Poisoning by Penicillins, Accidental, Sequela"
I $G(ICDSRC)=31 D
. S ICDCOD="0BQ37ZZ"
. S ICDSHRT="Repair Right Bronchus, Opening"
. S ICDLONG="REPAIR RIGHT BRONCHUS, VIA NATURAL/ARTIFICIAL OPENING"
. S ICDMIX="Repair right Bronchus, via Natural/Artificial Opening"
W !,?5,"Enter "
W !,?5," 1 FileMan format, code followed by short text (default):"
W !,?5,""
W !,?5," ",ICDCOD," ",ICDSHRT
W !,?5,""
W !,?5," 2 Modified FileMan format, code followed by description:"
W !,?5,""
W !,?5," ",ICDCOD," ",ICDLONG
W !,?5,""
W !,?5," 3 Short Lexicon format, short text followed by code:"
W !,?5,""
W !,?5," ",ICDSHRT," (",ICDCOD,")"
W !,?5,""
W !,?5," 4 Long Lexicon format, description followed by code:"
W !,?5," "
W !,?5," ",ICDMIX," (",ICDCOD,")"
W !,?5," "
Q
SAV(X,ICDV) ; Save Defaults
N ICDR,ICDT,ICDU,ICDC,ICDVAL,ICDN,ICDID,ICDD,ICDF,ICDK,Y S ICDR=$P($T(+1)," ",1) Q:$L(ICDR)'>1 Q:$L(ICDR)>8
S ICDT=$G(X) Q:'$L(ICDT) S ICDC=$T(@(ICDT_"^"_ICDR)) Q:'$L(ICDC) S ICDU=+($G(DUZ)) Q:+ICDU'>0
S ICDN=$$GET1^DIQ(200,(ICDU_","),.01) Q:'$L(ICDN) S ICDVAL=$G(ICDV) Q:ICDU'>0 Q:'$L(ICDVAL)
S ICDC=$$TM($P(ICDC,";",2)) Q:'$L(ICDC) S ICDK=$E(ICDC,1,13) F Q:$L(ICDK)>12 S ICDK=ICDK_" "
S ICDD=$$DT^XLFDT,ICDF=$$FMADD^XLFDT(ICDD,30),ICDID=ICDR_" "_ICDU_" "_ICDK
S ^XTMP(ICDID,0)=ICDF_"^"_ICDD_"^"_ICDC,^XTMP(ICDID,ICDT)=ICDVAL
Q
RET(X) ; Retrieve Defaults
N ICDR,ICDT,ICDU,ICDC,ICDN,ICDID,ICDD,ICDF,ICDK S ICDR=$P($T(+1)," ",1) Q:$L(ICDR)'>1 Q:$L(ICDR)>8
S ICDT=$G(X) Q:'$L(ICDT) S ICDC=$T(@(ICDT_"^"_ICDR)) Q:'$L(ICDC) S ICDU=+($G(DUZ)) Q:+ICDU'>0
S ICDN=$$GET1^DIQ(200,(ICDU_","),.01) Q:'$L(ICDN) S ICDC=$$TM($P(ICDC,";",2)) Q:'$L(ICDC)
S ICDK=$E(ICDC,1,13) F Q:$L(ICDK)>12 S ICDK=ICDK_" "
S ICDD=$$DT^XLFDT,ICDF=$$FMADD^XLFDT(ICDD,30),ICDID=ICDR_" "_ICDU_" "_ICDK
S X=$G(^XTMP(ICDID,ICDT))
Q X
EFM(X) ; Convert External Date to FM
N Y,%DT D ^%DT S X=Y K %DT
Q X
TM(X,Y) ; Trim Character Y - Default " "
S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" " Q:X'[Y X
F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
Q X
ICDDICA ;SLC/KER - ICD DIC Lookup Prototype ;04/21/2014
+1 ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7
+2 ;
+3 ; Global Variables
+4 ; ^ICDS( N/A
+5 ; ^XTMP("ICDID") SACC 2.3.2.5.2
+6 ;
+7 ; External References
+8 ; ^%DT ICR 10003
+9 ; ^DIC ICR 10006
+10 ; $$GET1^DIQ ICR 2056
+11 ; ^DIR ICR 10026
+12 ; $$DT^XLFDT ICR 10103
+13 ; $$FMADD^XLFDT ICR 10103
+14 ; $$FMTE^XLFDT ICR 10103
+15 ; $$UP^XLFSTR ICR 10104
+16 ;
+17 ; Local Variables NEWed or KILLed in ICDDIC
+18 ; ICDCS,ICDDP,ICDFI,ICDFM,ICDOA,ICDVD,ICDVR
+19 ;
EN ;
+1 IF $LENGTH($GET(IOF))
WRITE @IOF
+2 WRITE !
SET ICDDP=$$DP
SET ICDCS=""
IF ICDDP["^"
QUIT
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+3 SET ICDFI=$SELECT(ICDDP="D":"80^ICD DIAGNOSIS",ICDDP="P":"80.1^ICD OPERATION/PROCEDURE",1:"")
+4 IF +ICDFI'>0
QUIT
SET ICDOA=$$OA(+ICDFI)
IF ICDOA["^"
QUIT
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+5 IF ICDOA="O"
SET ICDCS=$$CS(+ICDFI)
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+6 SET ICDVR=$$VR(+ICDFI)
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+7 SET ICDVD=""
IF ICDVR>0
SET ICDVD=$$VD(+ICDFI)
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+8 NEW ICD10D
SET ICD10D=$$IMP^ICDEX(30)
SET ICDSRC=+ICDCS
+9 IF +ICDCS'>0&(+ICDFI=80)
SET ICDSRC=$SELECT(+ICDVD<+ICD10D:1,1:30)
+10 IF +ICDCS'>0&(+ICDFI=80.1)
SET ICDSRC=$SELECT(+ICDVD<+ICD10D:2,1:31)
+11 SET ICDFM=$$FM
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+12 NEW ICDTEST
+13 QUIT
DP(X) ; Diagnosis or Procedure
+1 NEW ICD,DIR,ICDB,ICDN,Y
KILL ICD
KILL DTOUT,DUOUT,DIRUT,DIROUT
+2 SET ICD=""
SET DIR(0)="SAO^D:Diagnosis;P:Procedures"
+3 SET DIR("B")=$$RET("DP")
IF '$LENGTH(DIR("B"))
SET DIR("B")="Diagnosis"
+4 SET (DIR("?"),DIR("??"))="^D DPH^ICDDICA"
+5 SET DIR("PRE")="S X=$$DPP^ICDDICA($G(X))"
+6 SET DIR("A")=" Search ICD Diagnosis or Procedures (D/P): "
+7 DO ^DIR
SET X=Y
+8 SET ICDN=""
IF X="D"
SET ICDN="Diagnosis"
IF X="P"
SET ICDN="Procedures"
+9 IF $LENGTH(ICDN)
DO SAV("DP",ICDN)
+10 QUIT X
DPP(X) ; Diagnosis or Procedure - Pre-process
+1 IF '$LENGTH($GET(X))
QUIT ""
IF X["?"
QUIT "??"
IF X["^^"
QUIT "^^"
IF X["^"
QUIT "^"
+2 SET X=$$UP^XLFSTR(X)
IF $EXTRACT("OPERATIONS",1,$LENGTH(X))=X
QUIT "Procedures"
+3 IF $EXTRACT("PROCEDURES",1,$LENGTH(X))=X
QUIT "Procedures"
IF $EXTRACT("DIAGNOSIS",1,$LENGTH(X))=X
QUIT "Diagnosis"
+4 QUIT X
DPH ; Diagnosis or Procedure - Help
+1 WRITE !,?5,"Enter 'D' or 'Diagnosis' to search the ICD DIAGNOSIS file #80"
+2 WRITE !,?5,"Enter 'P' or 'Procedures' to search the ICD PROCEDURE file #80.1"
+3 WRITE !,?5,"Enter '^' to quit, and 'Return' to accept the default value."
+4 QUIT
OA(X) ; One or All Coding System
+1 NEW ICD,DIR,ICDB,ICDN,ICDF,Y
KILL ICD
KILL DTOUT,DUOUT,DIRUT,DIROUT
+2 SET ICDF=+($GET(X))
IF '$DATA(^ICDS("F",+ICDF))
QUIT "A"
+3 SET ICD=""
SET DIR(0)="SAO^O:One System;A:All Systems"
+4 SET DIR("B")=$$RET("OA")
IF '$LENGTH(DIR("B"))
SET DIR("B")="All Coding Systems"
+5 SET (DIR("?"),DIR("??"))="^D OAH^ICDDICA"
+6 SET DIR("PRE")="S X=$$OAP^ICDDICA($G(X))"
+7 SET DIR("A")=" Search One or All Coding Systems in file "_ICDF_" (O/A): "
+8 SET DIR("A")=" Search One or All Coding Systems (O/A): "
+9 DO ^DIR
SET X=Y
+10 SET ICDN=""
IF X="O"
SET ICDN="One System"
IF X="A"
SET ICDN="All Systems"
+11 IF $LENGTH(ICDN)
DO SAV("OA",ICDN)
+12 QUIT X
OAP(X) ; One or All Coding System - Pre-process
+1 IF '$LENGTH($GET(X))
QUIT ""
IF X["?"
QUIT "??"
IF X["^^"
QUIT "^^"
IF X["^"
QUIT "^"
SET X=$$UP^XLFSTR(X)
+2 IF $EXTRACT("ONE CODING SYSTEM",1,$LENGTH(X))=X
QUIT "One System"
+3 IF $EXTRACT("ONE SYSTEM",1,$LENGTH(X))=X
QUIT "One System"
+4 IF $EXTRACT("ALL CODING SYSTEMS",1,$LENGTH(X))=X
QUIT "All Systems"
+5 IF $EXTRACT("ALL SYSTEMS",1,$LENGTH(X))=X
QUIT "All Systems"
+6 IF "^O^A"'[("^"_$EXTRACT(X,1)_"^")
SET X="??"
+7 QUIT X
OAH ; One or All Coding System - Help
+1 WRITE !,?5,"Enter 'O' to search one coding system "
IF +($GET(ICDF))>0
WRITE "in file ",$GET(ICDF)
+2 WRITE !,?5,"Enter 'A' to search all coding systems "
IF +($GET(ICDF))>0
WRITE "in file ",$GET(ICDF)
+3 IF $DATA(^ICDS("F",+($GET(ICDF))))
Begin DoDot:1
+4 NEW ICDI,ICDC
SET (ICDI,ICDC)=0
FOR
SET ICDI=$ORDER(^ICDS("F",+($GET(ICDF)),ICDI))
IF ICDI'>0
QUIT
Begin DoDot:2
+5 NEW ICDS
SET ICDS=$PIECE($GET(^ICDS(ICDI,0)),"^",1)
IF '$LENGTH(ICDS)
QUIT
SET ICDC=ICDC+1
IF ICDC=1
WRITE !
+6 WRITE !,?15,ICDS
End DoDot:2
End DoDot:1
+7 QUIT
CS(X) ; Coding System
+1 NEW ICD,DIC,ICDB,ICDBI,ICDN,ICDF,ICDI,ICDD,Y
KILL ICD
KILL DTOUT,DUOUT,DIRUT,DIROUT
+2 SET ICDF=+($GET(X))
IF '$DATA(^ICDS("F",+ICDF))
QUIT "^"
SET ICDI=$ORDER(^ICDS("F",+ICDF," "),-1)
IF +ICDI'>0
QUIT "^"
+3 SET ICDD=$PIECE($GET(^ICDS(+ICDI,0)),"^",1)
IF '$LENGTH(ICDD)
QUIT "^"
SET ICD=""
SET DIC="^ICDS("
SET DIC(0)="AEQM"
+4 SET ICDB=$$RET("CS")
SET ICDBI=0
IF $LENGTH(ICDB)
SET ICDBI=$ORDER(^ICDS("B",ICDB,0))
+5 IF $LENGTH(ICDB)&(+($GET(ICDBI))'>0)
SET ICDBI=$ORDER(^ICDS("C",ICDB,0))
+6 IF ICDBI>0&($PIECE($GET(^ICDS(+ICDBI,0)),"^",3)'=+ICDF)
SET ICDB=""
+7 IF $LENGTH(ICDB)
SET DIC("B")=ICDB
IF '$LENGTH($GET(DIC("B")))&($LENGTH(ICDD))
SET DIC("B")=ICDD
+8 SET DIC("A")=" Select Coding Systems: "
+9 SET DIC("S")="I $G(ICDF)>0&($P($G(^ICDS(+Y,0)),""^"",3)=$G(ICDF))"
+10 SET (DIC("?"),DIC("??"))="^D CSH^ICDDICA"
+11 DO ^DIC
IF +Y>0
SET ICDD=$PIECE($GET(^ICDS(+Y,0)),"^",1)
IF $LENGTH(ICDD)
DO SAV("CS",ICDD)
+12 SET X=Y
+13 QUIT X
CSH ; One or All Coding System - Help
+1 WRITE !,?5,"Answer with ICD CODING SYSTEMS (i.e., "
+2 WRITE $SELECT(+ICDF=80:"ICD-10-CM",+ICDF=80.1:"ICD-10-PCS",1:"ICD-10-CM")
+3 WRITE " or ICD CODING SYSTEM NOMENCLATURE, or"
+4 WRITE ?5,"CODING SYSTEM ABBREVIATION"
+5 QUIT
+6 IF $DATA(^ICDS("F",+($GET(ICDF))))
Begin DoDot:1
+7 NEW ICDI,ICDC
SET (ICDI,ICDC)=0
FOR
SET ICDI=$ORDER(^ICDS("F",+($GET(ICDF)),ICDI))
IF ICDI'>0
QUIT
Begin DoDot:2
+8 NEW ICDS
SET ICDS=$PIECE($GET(^ICDS(ICDI,0)),"^",1)
IF '$LENGTH(ICDS)
QUIT
SET ICDC=ICDC+1
IF ICDC=1
WRITE !
+9 WRITE !,?15,ICDS
End DoDot:2
End DoDot:1
+10 QUIT
VR(X) ; Versioned Search
+1 NEW ICD,DIR,ICDB,ICDN,Y
KILL ICD
KILL DTOUT,DUOUT,DIRUT,DIROUT
+2 SET ICD=""
SET DIR(0)="YAO"
SET DIR("B")=$$RET("VR")
IF '$LENGTH(DIR("B"))
SET DIR("B")="Yes"
+3 SET (DIR("?"),DIR("??"))="^D VRH^ICDDICA"
+4 SET DIR("PRE")="S X=$$VRP^ICDDICA($G(X))"
+5 SET DIR("A")=" Conduct a versioned (date sensitive) Search (Y/N): "
+6 DO ^DIR
SET X=Y
+7 SET ICDN=""
IF X="1"
SET ICDN="Yes"
IF X="0"
SET ICDN="No"
+8 IF $LENGTH(ICDN)
DO SAV("VR",ICDN)
+9 QUIT X
VRP(X) ; Diagnosis or Procedure - Pre-process
+1 IF '$LENGTH($GET(X))
QUIT ""
IF X["?"
QUIT "??"
IF X["^^"
QUIT "^^"
IF X["^"
QUIT "^"
+2 SET X=$$UP^XLFSTR(X)
IF $EXTRACT("YES",1,$LENGTH(X))=X
QUIT "Yes"
IF $EXTRACT("NO",1,$LENGTH(X))=X
QUIT "No"
+3 SET X="??"
+4 QUIT X
VRH ; Diagnosis or Procedure - Help
+1 WRITE !,?5,"Enter 'Yes' to conduct a versioned search (date sensitive) or"
+2 WRITE !,?5,"enter 'No' to contuct an unversioned search.",!
+3 WRITE !,?5,"NOTE: Inactive codes will NOT be displayed during a versioned"
+4 WRITE !,?5," search (date sensitive) and will be displayed during an "
+5 WRITE !,?5," unversioned search (date doesn't matter)."
+6 QUIT
VD(X) ; Versioned Date
+1 NEW ICD,DIR,ICDB,ICDN,ICDTD,ICDD1,ICDD2,Y
KILL ICD
KILL DTOUT,DUOUT,DIRUT,DIROUT
+2 SET ICDTD=$$DT^XLFDT
SET ICDD1=2781001
SET ICDD2=$$FMADD^XLFDT(ICDTD,(365*5))
+3 SET DIR(0)="DAO^"_ICDD1_":"_ICDD2_":"
+4 SET DIR("B")=$$RET("VD")
IF '$LENGTH(DIR("B"))
SET DIR("B")=$$FMTE^XLFDT(ICDTD)
+5 SET (DIR("?"),DIR("??"))="^D VDH^ICDDICA"
+6 SET DIR("PRE")="S X=$$VDP^ICDDICA($G(X))"
+7 SET DIR("A")=" Enter a versioning date: "
+8 SET DIR("A")=" Enter a date from "_$$FMTE^XLFDT($GET(ICDD1),"5Z")_" to "_$$FMTE^XLFDT($GET(ICDD2),"5Z")_": "
+9 DO ^DIR
SET X=Y
+10 SET ICDN=""
IF $PIECE(X,".",1)?7N
SET ICDN=$$UP^XLFSTR($$FMTE^XLFDT($PIECE(X,".",1)))
+11 IF $LENGTH(ICDN)
DO SAV("VD",ICDN)
+12 QUIT X
VDP(X) ; Diagnosis or Procedure - Pre-process
+1 SET X=$$UP^XLFSTR($GET(X))
IF '$LENGTH($GET(X))
QUIT ""
IF X["?"
QUIT "??"
IF X["^^"
QUIT "^^"
IF X["^"
QUIT "^"
+2 NEW ICDI,ICDA,ICDO
SET (ICDA,ICDI)=$$EFM(X)
IF ICDA#10000=0
SET ICDA=ICDA+101
IF ICDA#100=0
SET ICDA=ICDA+1
+3 IF $EXTRACT(ICDA,4,5)="00"
SET ICDA=$EXTRACT(ICDA,1,3)_"01"_$EXTRACT(ICDA,6,7)
IF $EXTRACT(ICDA,6,7)="00"
SET ICDA=$EXTRACT(ICDA,1,5)_"01"
+4 SET ICDA=$PIECE(ICDA,".",1)
SET ICDO=$$UP^XLFSTR($$FMTE^XLFDT(ICDA))
IF ICDA?7N
QUIT ICDO
SET X="??"
+5 QUIT X
VDH ; Diagnosis or Procedure - Help
+1 WRITE !,?5,"Enter a date from ",$$FMTE^XLFDT($GET(ICDD1))," to ",$$FMTE^XLFDT($GET(ICDD2)),". Time is"
+2 WRITE !,?5,"allowed but not required. Code Set Business rules apply"
+3 WRITE !,?5,"for imprecise dates:",!
+4 WRITE !,?5," Month is missing: Use January"
+5 WRITE !,?5," Day is missing: Use the 1st"
+6 QUIT
FM(X) ; Diagnosis or Procedure
+1 NEW ICD,DIR,ICDB,ICDN,ICDSRC,Y
KILL ICD
KILL DTOUT,DUOUT,DIRUT,DIROUT
SET ICDSRC=$GET(X)
SET ICD=""
+2 SET DIR(0)="SAO^1:FileMan Format;2:Modified FileMan Format;3:Short Lexicon Format;4:Long Lexicon Format"
+3 SET DIR("B")=$$RET("FM")
IF '$LENGTH(DIR("B"))
SET DIR("B")="FileMan Format"
+4 SET (DIR("?"),DIR("??"))="^D FMH^ICDDICA"
+5 SET DIR("PRE")="S X=$$FMP^ICDDICA($G(X))"
+6 SET DIR("A")=" Select Display Format (1-4): "
+7 DO ^DIR
SET X=Y
SET ICDN=""
IF $LENGTH($GET(Y(0)))
SET ICDN=$GET(Y(0))
+8 IF $LENGTH(ICDN)
DO SAV("FM",ICDN)
+9 QUIT X
FMP(X) ; Diagnosis or Procedure - Pre-process
+1 SET X=$$UP^XLFSTR($GET(X))
IF '$LENGTH($GET(X))
QUIT ""
IF X["?"
QUIT "??"
IF X["^^"
QUIT "^^"
IF X["^"
QUIT "^"
+2 IF X=1
QUIT "FileMan Format"
IF X=2
QUIT "Modified FileMan Format"
IF X=3
QUIT "Short Lexicon Format"
IF X=4
QUIT "Long Lexicon Format"
+3 IF $EXTRACT("FILEMAN FORMAT",1,$LENGTH(X))=X
QUIT "FileMan Format"
+4 IF $EXTRACT("MODIFIED FILEMAN FORMAT",1,$LENGTH(X))=X
QUIT "Modified FileMan Format"
+5 IF $EXTRACT("SHORT LEXICON FORMAT",1,$LENGTH(X))=X
QUIT "Short Lexicon Format"
+6 IF $EXTRACT("LONG LEXICON FORMAT",1,$LENGTH(X))=X
QUIT "Long Lexicon Format"
+7 SET X="??"
+8 QUIT X
FMH ; Display Format - Help
+1 NEW ICDCOD,ICDSHRT,ICDLONG,ICDMIX
+2 IF $GET(ICDSRC)=1!("^1^2^30^31^"'[("^"_+($GET(ICDSRC))_"^"))
Begin DoDot:1
+3 SET ICDCOD="275.1"
+4 SET ICDSHRT="DIS COPPER METABOLISM"
+5 SET ICDLONG="DISORDERS OF COPPER METABOLISM"
+6 SET ICDMIX="Disorders of Copper Metabolism"
End DoDot:1
+7 IF $GET(ICDSRC)=2
Begin DoDot:1
+8 SET ICDCOD="01.21"
+9 SET ICDSHRT="CRANIAL SINUS I D"
+10 SET ICDLONG="INCISION AND DRAINAGE OF CRANIAL SINUS"
+11 SET ICDMIX="Incision and Drainage of Cranial Sinus"
End DoDot:1
+12 IF $GET(ICDSRC)=30
Begin DoDot:1
+13 SET ICDCOD="T36.0X1S"
+14 SET ICDSHRT="Penicillin poisoning , acc, sequela"
+15 SET ICDLONG="POISONING BY PENICILLINS, ACCIDENTAL, SEQUELA"
+16 SET ICDMIX="Poisoning by Penicillins, Accidental, Sequela"
End DoDot:1
+17 IF $GET(ICDSRC)=31
Begin DoDot:1
+18 SET ICDCOD="0BQ37ZZ"
+19 SET ICDSHRT="Repair Right Bronchus, Opening"
+20 SET ICDLONG="REPAIR RIGHT BRONCHUS, VIA NATURAL/ARTIFICIAL OPENING"
+21 SET ICDMIX="Repair right Bronchus, via Natural/Artificial Opening"
End DoDot:1
+22 WRITE !,?5,"Enter "
+23 WRITE !,?5," 1 FileMan format, code followed by short text (default):"
+24 WRITE !,?5,""
+25 WRITE !,?5," ",ICDCOD," ",ICDSHRT
+26 WRITE !,?5,""
+27 WRITE !,?5," 2 Modified FileMan format, code followed by description:"
+28 WRITE !,?5,""
+29 WRITE !,?5," ",ICDCOD," ",ICDLONG
+30 WRITE !,?5,""
+31 WRITE !,?5," 3 Short Lexicon format, short text followed by code:"
+32 WRITE !,?5,""
+33 WRITE !,?5," ",ICDSHRT," (",ICDCOD,")"
+34 WRITE !,?5,""
+35 WRITE !,?5," 4 Long Lexicon format, description followed by code:"
+36 WRITE !,?5," "
+37 WRITE !,?5," ",ICDMIX," (",ICDCOD,")"
+38 WRITE !,?5," "
+39 QUIT
SAV(X,ICDV) ; Save Defaults
+1 NEW ICDR,ICDT,ICDU,ICDC,ICDVAL,ICDN,ICDID,ICDD,ICDF,ICDK,Y
SET ICDR=$PIECE($TEXT(+1)," ",1)
IF $LENGTH(ICDR)'>1
QUIT
IF $LENGTH(ICDR)>8
QUIT
+2 SET ICDT=$GET(X)
IF '$LENGTH(ICDT)
QUIT
SET ICDC=$TEXT(@(ICDT_"^"_ICDR))
IF '$LENGTH(ICDC)
QUIT
SET ICDU=+($GET(DUZ))
IF +ICDU'>0
QUIT
+3 SET ICDN=$$GET1^DIQ(200,(ICDU_","),.01)
IF '$LENGTH(ICDN)
QUIT
SET ICDVAL=$GET(ICDV)
IF ICDU'>0
QUIT
IF '$LENGTH(ICDVAL)
QUIT
+4 SET ICDC=$$TM($PIECE(ICDC,";",2))
IF '$LENGTH(ICDC)
QUIT
SET ICDK=$EXTRACT(ICDC,1,13)
FOR
IF $LENGTH(ICDK)>12
QUIT
SET ICDK=ICDK_" "
+5 SET ICDD=$$DT^XLFDT
SET ICDF=$$FMADD^XLFDT(ICDD,30)
SET ICDID=ICDR_" "_ICDU_" "_ICDK
+6 SET ^XTMP(ICDID,0)=ICDF_"^"_ICDD_"^"_ICDC
SET ^XTMP(ICDID,ICDT)=ICDVAL
+7 QUIT
RET(X) ; Retrieve Defaults
+1 NEW ICDR,ICDT,ICDU,ICDC,ICDN,ICDID,ICDD,ICDF,ICDK
SET ICDR=$PIECE($TEXT(+1)," ",1)
IF $LENGTH(ICDR)'>1
QUIT
IF $LENGTH(ICDR)>8
QUIT
+2 SET ICDT=$GET(X)
IF '$LENGTH(ICDT)
QUIT
SET ICDC=$TEXT(@(ICDT_"^"_ICDR))
IF '$LENGTH(ICDC)
QUIT
SET ICDU=+($GET(DUZ))
IF +ICDU'>0
QUIT
+3 SET ICDN=$$GET1^DIQ(200,(ICDU_","),.01)
IF '$LENGTH(ICDN)
QUIT
SET ICDC=$$TM($PIECE(ICDC,";",2))
IF '$LENGTH(ICDC)
QUIT
+4 SET ICDK=$EXTRACT(ICDC,1,13)
FOR
IF $LENGTH(ICDK)>12
QUIT
SET ICDK=ICDK_" "
+5 SET ICDD=$$DT^XLFDT
SET ICDF=$$FMADD^XLFDT(ICDD,30)
SET ICDID=ICDR_" "_ICDU_" "_ICDK
+6 SET X=$GET(^XTMP(ICDID,ICDT))
+7 QUIT X
EFM(X) ; Convert External Date to FM
+1 NEW Y,%DT
DO ^%DT
SET X=Y
KILL %DT
+2 QUIT X
TM(X,Y) ; Trim Character Y - Default " "
+1 SET X=$GET(X)
IF X=""
QUIT X
SET Y=$GET(Y)
IF '$LENGTH(Y)
SET Y=" "
IF X'[Y
QUIT X
+2 FOR
IF $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 FOR
IF $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 QUIT X
