ICDEXLK6 ;SLC/KER - ICD Extractor - Lookup, Miscellaneous ;12/19/2014
;;18.0;DRG Grouper;**57,67**;Oct 20, 2000;Build 1
;
; Global Variables
; ^DISV( ICR 510
; ^ICDS( N/A
; ^ICDS("F" N/A
; ^UTILITY($J ICR 10011
; ^XTMP( SACC 2.3.2.5.2
;
; External References
; ^DIM ICR 10016
; $$GET1^DIQ ICR 2056
; ^DIR ICR 10026
; ^DIWP ICR 10011
; $$DT^XLFDT ICR 10103
; $$FMADD^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed in ICDEXLK
; ICDDIC0,ICDDIC00,ICDDICA,ICDDICB,ICDDICS,ICDDICW,ICDX
;
DX9 ; Fileman Lookup ICD-9 Diagnosis (interactive)
;
; This API forces the lookup in file 80 to use the ICD-9-CM
; coding system only by presetting the special variable ICDSYS
; to 1 (Coding System = ICD-9-CM)
;
N ICDSYS S ICDSYS=1 D DX
Q
DX10 ; Fileman Lookup ICD-10 Diagnosis (interactive)
;
; This API forces the lookup in file 80 to use the ICD-10-CM
; coding system only by presetting the special variable ICDSYS
; to 30 (Coding System = ICD-10-CM)
;
N ICDSYS S ICDSYS=30 D DX
Q
DX ; Fileman Lookup Diagnosis (interactive)
;
; Variables that may be preset:
;
; ICDVDT Versioning Date (Fileman format)
; ICDSYS Coding System 1 = ICD-9-CM, 30 = ICD-10-CM
; ICDFMT Display Format 1-4 (see above)
; DIC("S") Fileman Screen
; DIC("W") Executable write command
;
K X N SNAM,OVDT,OSYS,OFMT,SYSD S DIC="^ICD9(",DIC(0)="AQEM",(SYSD,SNAM)=""
S OSYS=+($G(ICDSYS)) N ICDSYS S:$D(^ICDS("F",80,+($G(OSYS)))) ICDSYS=OSYS
S OFMT=$G(ICDFMT) N ICDFMT S ICDFMT=OFMT S:+ICDFMT<1 ICDFMT=1 S:+ICDFMT>4 ICDFMT=1
S OVDT=$G(ICDVDT) S:OVDT'?7N OVDT=$$DT^XLFDT N ICDVDT S ICDVDT=OVDT S:SYSD?7N&(SYSD>ICDVDT) ICDVDT=SYSD
S:+($G(ICDSYS))>0 SNAM=$$SNAM^ICDEX(+($G(ICDSYS))),SYSD=$P($G(^ICDS(+$G(ICDSYS),0)),"^",4) S ICDSYS=+($G(ICDSYS))
S SNAM=$P(SNAM," ",1),SNAM=$P(SNAM,"-",1,2)
S DIC("A")="Select ICD Diagnosis: " S:$L(SNAM) DIC("A")="Select "_SNAM_" Diagnosis: "
K:$$DIM($G(DIC("S")))'>0 DIC("S") K:$$DIM($G(DIC("W")))'>0 DIC("W")
D LK^ICDEXLK K DIC
Q
PR9 ; Fileman Lookup ICD-9 Procedures (interactive)
;
; This API forces the lookup in file 80 to use the ICD-9 Proc
; coding system only by presetting the special variable ICDSYS
; to 2 (Coding System = ICD-9 Proc)
;
N ICDSYS S ICDSYS=2 D PR
Q
PR10 ; Fileman Lookup ICD-10 Procedures (interactive)
;
; This API forces the lookup in file 80 to use the ICD-10-PCS
; coding system only by presetting the special variable ICDSYS
; to 31 (Coding System = ICD-10-PCS)
;
N ICDSYS S ICDSYS=31 D PR
Q
PR ; Fileman Lookup Procedure (interactive)
;
; Variables that may be preset:
;
; ICDVDT Versioning Date (Fileman format)
; ICDSYS Coding System 2 = ICD-9 Proc, 31 = ICD-10-PCS
; ICDFMT Display Format 1-4 (see above)
; DIC("S") Fileman Screen
; DIC("W") Executable Write command
;
K X N SNAM,OVDT,OSYS,OFMT,SYSD S DIC="^ICD0(",DIC(0)="AQEM",(SYSD,SNAM)=""
S OSYS=+($G(ICDSYS)) N ICDSYS S:$D(^ICDS("F",80.1,+($G(OSYS)))) ICDSYS=OSYS
S OFMT=$G(ICDFMT) N ICDFMT S ICDFMT=OFMT S:+ICDFMT<1 ICDFMT=1 S:+ICDFMT>4 ICDFMT=1
S OVDT=$G(ICDVDT) S:OVDT'?7N OVDT=$$DT^XLFDT N ICDVDT S ICDVDT=OVDT S:SYSD?7N&(SYSD>ICDVDT) ICDVDT=SYSD
S:+($G(ICDSYS))>0 SNAM=$$SNAM^ICDEX(+($G(ICDSYS))),SYSD=$P($G(^ICDS(+$G(ICDSYS),0)),"^",4) S ICDSYS=+($G(ICDSYS))
S SNAM=$P(SNAM," ",1),SNAM=$P(SNAM,"-",1,2)
S DIC("A")="Select ICD Procedure: " S:$L(SNAM) DIC("A")="Select "_SNAM_" Procedure: "
K:$$DIM($G(DIC("S")))'>0 DIC("S") K:$$DIM($G(DIC("W")))'>0 DIC("W")
D LK^ICDEXLK K DIC
Q
DIM(X) ; Check MUMPS Code
S X=$G(X) Q:'$L(X) 0 D ^DIM Q:'$D(X) 0
Q 1
;
FILE(FILE,SYS) ; File
N ROOT,TMP,Y S ROOT=$G(FILE),TMP=$$FILE^ICDEX(ROOT) Q:$D(^ICDS("F",+TMP)) TMP
S SYS=$$SYS^ICDEX($G(SYS)),TMP=$$FILE^ICDEX(+SYS) Q:$D(^ICDS("F",+TMP)) TMP
S TMP=$$FILN($G(FILE)) Q:$D(^ICDS("F",+TMP)) TMP
N DIR,DTOUT,DUOUT,DIROUT,DIRUT S DIR(0)="SAO^DX:ICD DIAGNOSIS;PR:ICD OPERATION/PROCEDURE"
S DIR("A")=" Select ICD File: ",DIR("PRE")="S X=$$FILT^ICDEXLK6(X)" S (DIR("?"),DIR("??"))="^D FILH^ICDEXLK6"
D ^DIR S Y=$S(Y="DX":80,Y="PR":80.1,1:-1)
Q Y
FILT(X) ; File Transform
S X=$$UP^XLFSTR(X) S:X["ICD9" X="DX" S:X["ICD0" X="PR" Q:X["^^" "^^" Q:X["^" "^" S:X["?" X="??" Q:X["?" X
S:X["DI"!(X["DX")!(X=80) X="DX" Q:X="DX" X S:X["PR"!(X["OP")!(X=80.1) X="PR" Q:X="PR" X
Q "??"
FILN(X) ; File Number
N NUM,TMP S NUM=0,TMP=$$UP^XLFSTR(X) S:TMP["DI"!(TMP["DX")!(TMP["ICD9")!(TMP=80) NUM=80
S:TMP["PR"!(TMP["OP")!(TMP["ICD0")!(TMP=80.1) NUM=80.1 Q:$D(^ICDS("F",+NUM)) NUM
Q X
FILH ; File Help
W:$O(^ICDS("F",0))>0 !,?4,"Select from:",!
N FI S FI=0 F S FI=$O(^ICDS("F",FI)) Q:+FI'>0 D
. N CD,RT,NM S (CD,RT)="" S:FI=80 CD="DX",RT="^ICD9(" S:FI=80.1 CD="PR",RT="^ICD0("
. S NM=$$GET1^DIQ(1,(+FI_","),.01) S:$E(NM,1,4)="ICD " NM=$P(NM,"ICD ",2)
. W !,?10,FI,?16,CD,?20,NM,?41,RT
Q
;
SYS(FILE,SYS) ; System
N DIR,DTOUT,DUOUT,DIROUT,DIRUT,ROOT,TMP,Y S ROOT=$G(FILE),TMP=$$FILE^ICDEX(ROOT),SYS=$$SYS^ICDEX($G(SYS))
S:'$D(^ICDS("F",+TMP)) TMP=$$FILE^ICDEX(+SYS) S:'$D(^ICDS("F",+TMP)) TMP=$$FILN($G(FILE))
S FILE="" S:$D(^ICDS("F",+TMP)) FILE=TMP Q:$D(^ICDS("F",+($G(FILE)),+($G(SYS)))) +($G(SYS))
S SYS=$$CS^ICDEX($G(FILE)) Q:$D(^ICDS(+SYS,0)) +SYS
Q -1
;
CDT(CDT,SYS) ; Date
N DIR,DTOUT,DUOUT,DIROUT,DIRUT,ROOT,LO,NX,HI,TD,TMP,Y
S CDT=$G(CDT),SYS=$$SYS^ICDEX($G(SYS)),LO=$$IMP^ICDEX(1)
S NX=$$IMP^ICDEX(+($G(SYS))) S:LO?7N&(NX?7N)&(NX>LO) LO=NX S HI=$$DT^XLFDT,HI=$$FMADD^XLFDT(HI,(365*3))
I CDT?7N S:LO?7N&(CDT<LO) CDT=LO Q:CDT=LO CDT S:HI?7N&(CDT>HI) CDT=HI Q:CDT=HI CDT
Q:CDT?7N&(CDT'<LO)&(CDT'>HI) CDT
S TD=$$DT^XLFDT,TMP=$TR($$UP^XLFSTR($$FMTE^XLFDT(TD)),",","") S:TD>LO&(TD<HI) DIR("B")=TMP
S DIR(0)="DAO^"_LO_":"_HI_":EX"
S DIR("A")=" Enter a Versioning Date: "
S DIR("PRE")="S X=$$CDTT^ICDEXLK6(X)" S (DIR("?"),DIR("??"))="^D CDTH^ICDEXLK6"
D ^DIR
Q Y
CDTT(X) ; Date Transform
S X=$$UP^XLFSTR(X) S:X["?" X="??" Q:X["?" X
Q X
CDTH ; Date Help
W !,?5,"Enter a date to be used to determine the appropriate codes"
W !,?5,"and terms that were in use on the date specified. ",!
I $G(LO)?7N,$G(HI)?7N D
. N BEG,END,MO,DY,YR S BEG=$$UP^XLFSTR($$FMTE^XLFDT($G(LO))),END=$$UP^XLFSTR($$FMTE^XLFDT($G(HI)))
. S MO=$P(BEG," ",1),DY=+($TR($P(BEG," ",2),",","")),YR=$P(BEG," ",3)
. W !,?5,"Date must be from ",BEG," to ",END,!
. W !,?5,"Examples of Valid Dates:",!
. W !,?9,MO," ",DY," ",YR," or "
. W DY," ",MO," ",$S($L(YR)=2:YR,$L(YR)=4:$E(YR,3,4),1:"")," or "
. W +($E(LO,6,7)),"/",$E(LO,4,5),"/",$E((1700+$E(LO,1,3)),3,4)," or "
. W $E(LO,4,5),$E(LO,6,7),$E((1700+$E(LO,1,3)),3,4)
I $G(LO)'?7N!($G(HI)'?7N) D
. W !,?5,"Examples of Valid Dates:",!
. W !,?9,"JAN 20 1957 or 20 JAN 57 or 1/20/57 or 012057"
W !,?9," T (for TODAY), T+1 (for TOMORROW), T+2, T+7, etc."
W !,?9," T-1 (for YESTERDAY), T-3W (for 3 WEEKS AGO), etc.",!
W !,?5,"This date is sometimes called the 'versioning date' (VistA) or"
W !,?5,"the 'date service was provided to the patient' (HIPAA)"
Q
;
DIC0(X) ; Correct DIC(0) for a versioned file
;
; Not used B - There are no pointer/variable pointers
; in index fields
; C - Cross-Reference suppression not allowed,
; entries must be unique
; I - If FileMan passes control to ICDEXLK,
; then "I"gnore no longer applies
; K - There is no primary Key (may change in
; the future)
; L - "Learn-As-You-Go" not allowed LAYGO is killed
; n - Only Codes, Text and IENs are allowed. "n"
; Returns too many values
; U - Only Codes, Text and IENs are allowed.
; V - Verify is always required when one entry is
; found
K LAYGO S X=$G(X) K DINUM,DLAYGO N CHR,STR F CHR="C","B","K","L","n","U","T","V","I" D
. F Q:X'[CHR S X=$P(X,CHR,1)_$P(X,CHR,2,299)
S STR="" F CHR="A","E","Q","M","F","N","O","S","X","Z" S:X[CHR STR=STR_CHR
;
; If non-numeric, and you are going to "A" ask
; then you are going to "E" echo
S:STR["A"&(STR'["E")&(STR'["N") STR=STR_"E"
;
; If you are going to "E" echo, and X does not
; exist, then you will "A" ask
S:STR["E"&(STR'["A")&('$L($G(X))) STR=STR_"A"
S:STR'["A"&(STR'["E")&(STR'["X") STR=STR_"X"
S X=STR
Q X
DICU ; Undo DIC
S:$L($G(ICDDICW)) DIC("W")=$G(ICDDICW)
S:$L($G(ICDDICA)) DIC("A")=$G(ICDDICA)
S:$L($G(ICDDICB)) DIC("B")=$G(ICDDICB)
S:$L($G(ICDDICS)) DIC("S")=$G(ICDDICS)
S:$L($G(ICDDIC0)) DIC(0)=$G(ICDDIC0)
S:$L($G(ICDDIC00)) DIC(0)=$G(ICDDIC00)
Q
DIE ; Set for DIE call
Q:'$L($G(DIE)) S:'$L($G(DIC("A")))&($L($G(DIP))) DIC("A")=$G(DIP)
S:$L($G(DIC("A")))&($G(DIC("A"))'[": ") DIC("A")=$G(DIC("A"))_": "
N DIE,DIP,DZ,X1
Q
DICS(ICDS) ; Check DIC("S")
N ICDT1,ICDT2,ICDTS S ICDT1=$D(X),ICDT2=$G(X) Q:'$L($G(ICDS)) ""
S (ICDTS,X)=$G(ICDS) D ^DIM I '$D(X) S:ICDT1>0 X=$G(ICDT2) Q ""
S ICDS=$G(ICDTS) S:ICDT1>0 X=$G(ICDT2) S:$L($G(ICDX)) X=$G(ICDX)
Q ICDS
;
SAV(X,DIC) ; Save Defaults
N NUM,COM,VAL,ID,CUR,FUT,FILE,ROOT,SUB Q:+($G(DUZ))'>0 Q:'$L($G(DIC)) Q:+($G(Y))'>0
S ROOT=$$ROOT^ICDEX(DIC) Q:'$L(ROOT) S SUB=$TR(ROOT,"^(,","") Q:'$L(SUB)
S FILE=$$FILE^ICDEX(ROOT) Q:+FILE'>0 Q:"^80^80.1^"'[("^"_FILE_"^")
S NUM=+($G(DUZ)) Q:+NUM'>0 Q:'$L($$GET1^DIQ(200,(NUM_","),.01)) S VAL=$G(Y) Q:'$L(VAL)
S COM=$S(FILE=80:"DX",FILE=80.1:"PR",1:""),ID=$$TM(("ICDEXLK "_NUM_" "_COM))
S CUR=$$DT^XLFDT,FUT=$$FMADD^XLFDT(CUR,60)
S ^XTMP(ID,0)=FUT_"^"_CUR_"^"_"ICD "_$S(COM="DX":"Diagnosis",COM="PR":"Procedures",1:"")
S ^XTMP(ID,SUB)=VAL S:$D(@(ROOT_+($G(Y))_",0)")) ^DISV(DUZ,ROOT)=+($G(Y))
Q
RET(DIC) ; Retrieve Defaults
N NUM,COM,ID,CUR,FUT,FILE,ROOT,SUB Q:+($G(DUZ))'>0 "" Q:'$L($G(DIC)) ""
S ROOT=$$ROOT^ICDEX($G(DIC)) Q:'$L(ROOT) "" S SUB=$TR(ROOT,"^(,","") Q:'$L(SUB) ""
S FILE=$$FILE^ICDEX(ROOT) Q:+FILE'>0 "" Q:"^80^80.1^"'[("^"_FILE_"^") ""
S NUM=+($G(DUZ)) Q:+NUM'>0 "" Q:'$L($$GET1^DIQ(200,(NUM_","),.01)) ""
S COM=$S(FILE=80:"DX",FILE=80.1:"PR",1:""),ID=$$TM(("ICDEXLK "_NUM_" "_COM))
S X=$G(^XTMP(ID,SUB)) S:+X'>0&(+($G(^DISV(NUM,ROOT)))>0) X=+($G(^DISV(NUM,ROOT)))
Q X
PA(ICD,X) ; Parse Array
N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,ICDI,ICDLEN,ICDC K ^UTILITY($J,"W") Q:'$D(ICD)
S ICDLEN=+($G(X)) S:+ICDLEN'>0 ICDLEN=79 S ICDC=+($G(ICD)) S:+($G(ICDC))'>0 ICDC=$O(ICD(" "),-1) Q:+ICDC'>0
S DIWL=1,DIWF="C"_+ICDLEN S ICDI=0 F S ICDI=$O(ICD(ICDI)) Q:+ICDI=0 S X=$G(ICD(ICDI)) D ^DIWP
K ICD S (ICDC,ICDI)=0 F S ICDI=$O(^UTILITY($J,"W",1,ICDI)) Q:+ICDI=0 D
. S ICD(ICDI)=$$TM($G(^UTILITY($J,"W",1,ICDI,0))," "),ICDC=ICDC+1
S:$L(ICDC) ICD=ICDC K ^UTILITY($J,"W")
Q
OUT(X,Y,Z,ARY) ; Output Array
K ARY N FILE,TERM,ROOT,IEN,FMT S ROOT=$G(X),IEN=+($G(Y)) Q:'$L(ROOT) S FMT=$G(Z)
Q:"^ICD9(^ICD0(^"'[("^"_$E(ROOT,2,$L(ROOT))_"^")
S FILE=$$FILE^ICDEX(ROOT) Q:"^80^80.1^"'[("^"_FILE_"^")
S:FMT'>0 FMT=1 S:FMT>4 FMT=1 Q:'$D(@(ROOT_IEN_",0)"))
I +($G(FMT))=1!(+($G(FMT))=3) S TERM=$$SD^ICDEX(FILE,IEN,CDT)
I +($G(FMT))=2!(+($G(FMT))=4) S TERM=$$LD^ICDEX(FILE,IEN,CDT)
Q:'$L(TERM) Q:$P(TERM,"^",1)=-1 S ARY(1)=TERM Q:+($G(FMT))=1!(+($G(FMT))=3)
D:+($G(FMT))=2 PAR^ICDEX(.ARY,60) D:+($G(FMT))=4 PAR^ICDEX(.ARY,70)
Q
XT(X) ; Input Transform for X
S X=$TR($G(X),"""","") S:X="#" X="" S X=$$TM(X,"#")
Q X
TM(X,Y) ; Trim Y
S Y=$G(Y) S:'$L(Y) Y=" "
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDEXLK6 11962 printed Dec 13, 2024@01:50:48 Page 2
ICDEXLK6 ;SLC/KER - ICD Extractor - Lookup, Miscellaneous ;12/19/2014
+1 ;;18.0;DRG Grouper;**57,67**;Oct 20, 2000;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^DISV( ICR 510
+5 ; ^ICDS( N/A
+6 ; ^ICDS("F" N/A
+7 ; ^UTILITY($J ICR 10011
+8 ; ^XTMP( SACC 2.3.2.5.2
+9 ;
+10 ; External References
+11 ; ^DIM ICR 10016
+12 ; $$GET1^DIQ ICR 2056
+13 ; ^DIR ICR 10026
+14 ; ^DIWP ICR 10011
+15 ; $$DT^XLFDT ICR 10103
+16 ; $$FMADD^XLFDT ICR 10103
+17 ; $$FMTE^XLFDT ICR 10103
+18 ; $$UP^XLFSTR ICR 10104
+19 ;
+20 ; Local Variables NEWed in ICDEXLK
+21 ; ICDDIC0,ICDDIC00,ICDDICA,ICDDICB,ICDDICS,ICDDICW,ICDX
+22 ;
DX9 ; Fileman Lookup ICD-9 Diagnosis (interactive)
+1 ;
+2 ; This API forces the lookup in file 80 to use the ICD-9-CM
+3 ; coding system only by presetting the special variable ICDSYS
+4 ; to 1 (Coding System = ICD-9-CM)
+5 ;
+6 NEW ICDSYS
SET ICDSYS=1
DO DX
+7 QUIT
DX10 ; Fileman Lookup ICD-10 Diagnosis (interactive)
+1 ;
+2 ; This API forces the lookup in file 80 to use the ICD-10-CM
+3 ; coding system only by presetting the special variable ICDSYS
+4 ; to 30 (Coding System = ICD-10-CM)
+5 ;
+6 NEW ICDSYS
SET ICDSYS=30
DO DX
+7 QUIT
DX ; Fileman Lookup Diagnosis (interactive)
+1 ;
+2 ; Variables that may be preset:
+3 ;
+4 ; ICDVDT Versioning Date (Fileman format)
+5 ; ICDSYS Coding System 1 = ICD-9-CM, 30 = ICD-10-CM
+6 ; ICDFMT Display Format 1-4 (see above)
+7 ; DIC("S") Fileman Screen
+8 ; DIC("W") Executable write command
+9 ;
+10 KILL X
NEW SNAM,OVDT,OSYS,OFMT,SYSD
SET DIC="^ICD9("
SET DIC(0)="AQEM"
SET (SYSD,SNAM)=""
+11 SET OSYS=+($GET(ICDSYS))
NEW ICDSYS
if $DATA(^ICDS("F",80,+($GET(OSYS))))
SET ICDSYS=OSYS
+12 SET OFMT=$GET(ICDFMT)
NEW ICDFMT
SET ICDFMT=OFMT
if +ICDFMT<1
SET ICDFMT=1
if +ICDFMT>4
SET ICDFMT=1
+13 SET OVDT=$GET(ICDVDT)
if OVDT'?7N
SET OVDT=$$DT^XLFDT
NEW ICDVDT
SET ICDVDT=OVDT
if SYSD?7N&(SYSD>ICDVDT)
SET ICDVDT=SYSD
+14 if +($GET(ICDSYS))>0
SET SNAM=$$SNAM^ICDEX(+($GET(ICDSYS)))
SET SYSD=$PIECE($GET(^ICDS(+$GET(ICDSYS),0)),"^",4)
SET ICDSYS=+($GET(ICDSYS))
+15 SET SNAM=$PIECE(SNAM," ",1)
SET SNAM=$PIECE(SNAM,"-",1,2)
+16 SET DIC("A")="Select ICD Diagnosis: "
if $LENGTH(SNAM)
SET DIC("A")="Select "_SNAM_" Diagnosis: "
+17 if $$DIM($GET(DIC("S")))'>0
KILL DIC("S")
if $$DIM($GET(DIC("W")))'>0
KILL DIC("W")
+18 DO LK^ICDEXLK
KILL DIC
+19 QUIT
PR9 ; Fileman Lookup ICD-9 Procedures (interactive)
+1 ;
+2 ; This API forces the lookup in file 80 to use the ICD-9 Proc
+3 ; coding system only by presetting the special variable ICDSYS
+4 ; to 2 (Coding System = ICD-9 Proc)
+5 ;
+6 NEW ICDSYS
SET ICDSYS=2
DO PR
+7 QUIT
PR10 ; Fileman Lookup ICD-10 Procedures (interactive)
+1 ;
+2 ; This API forces the lookup in file 80 to use the ICD-10-PCS
+3 ; coding system only by presetting the special variable ICDSYS
+4 ; to 31 (Coding System = ICD-10-PCS)
+5 ;
+6 NEW ICDSYS
SET ICDSYS=31
DO PR
+7 QUIT
PR ; Fileman Lookup Procedure (interactive)
+1 ;
+2 ; Variables that may be preset:
+3 ;
+4 ; ICDVDT Versioning Date (Fileman format)
+5 ; ICDSYS Coding System 2 = ICD-9 Proc, 31 = ICD-10-PCS
+6 ; ICDFMT Display Format 1-4 (see above)
+7 ; DIC("S") Fileman Screen
+8 ; DIC("W") Executable Write command
+9 ;
+10 KILL X
NEW SNAM,OVDT,OSYS,OFMT,SYSD
SET DIC="^ICD0("
SET DIC(0)="AQEM"
SET (SYSD,SNAM)=""
+11 SET OSYS=+($GET(ICDSYS))
NEW ICDSYS
if $DATA(^ICDS("F",80.1,+($GET(OSYS))))
SET ICDSYS=OSYS
+12 SET OFMT=$GET(ICDFMT)
NEW ICDFMT
SET ICDFMT=OFMT
if +ICDFMT<1
SET ICDFMT=1
if +ICDFMT>4
SET ICDFMT=1
+13 SET OVDT=$GET(ICDVDT)
if OVDT'?7N
SET OVDT=$$DT^XLFDT
NEW ICDVDT
SET ICDVDT=OVDT
if SYSD?7N&(SYSD>ICDVDT)
SET ICDVDT=SYSD
+14 if +($GET(ICDSYS))>0
SET SNAM=$$SNAM^ICDEX(+($GET(ICDSYS)))
SET SYSD=$PIECE($GET(^ICDS(+$GET(ICDSYS),0)),"^",4)
SET ICDSYS=+($GET(ICDSYS))
+15 SET SNAM=$PIECE(SNAM," ",1)
SET SNAM=$PIECE(SNAM,"-",1,2)
+16 SET DIC("A")="Select ICD Procedure: "
if $LENGTH(SNAM)
SET DIC("A")="Select "_SNAM_" Procedure: "
+17 if $$DIM($GET(DIC("S")))'>0
KILL DIC("S")
if $$DIM($GET(DIC("W")))'>0
KILL DIC("W")
+18 DO LK^ICDEXLK
KILL DIC
+19 QUIT
DIM(X) ; Check MUMPS Code
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT 0
DO ^DIM
if '$DATA(X)
QUIT 0
+2 QUIT 1
+3 ;
FILE(FILE,SYS) ; File
+1 NEW ROOT,TMP,Y
SET ROOT=$GET(FILE)
SET TMP=$$FILE^ICDEX(ROOT)
if $DATA(^ICDS("F",+TMP))
QUIT TMP
+2 SET SYS=$$SYS^ICDEX($GET(SYS))
SET TMP=$$FILE^ICDEX(+SYS)
if $DATA(^ICDS("F",+TMP))
QUIT TMP
+3 SET TMP=$$FILN($GET(FILE))
if $DATA(^ICDS("F",+TMP))
QUIT TMP
+4 NEW DIR,DTOUT,DUOUT,DIROUT,DIRUT
SET DIR(0)="SAO^DX:ICD DIAGNOSIS;PR:ICD OPERATION/PROCEDURE"
+5 SET DIR("A")=" Select ICD File: "
SET DIR("PRE")="S X=$$FILT^ICDEXLK6(X)"
SET (DIR("?"),DIR("??"))="^D FILH^ICDEXLK6"
+6 DO ^DIR
SET Y=$SELECT(Y="DX":80,Y="PR":80.1,1:-1)
+7 QUIT Y
FILT(X) ; File Transform
+1 SET X=$$UP^XLFSTR(X)
if X["ICD9"
SET X="DX"
if X["ICD0"
SET X="PR"
if X["^^"
QUIT "^^"
if X["^"
QUIT "^"
if X["?"
SET X="??"
if X["?"
QUIT X
+2 if X["DI"!(X["DX")!(X=80)
SET X="DX"
if X="DX"
QUIT X
if X["PR"!(X["OP")!(X=80.1)
SET X="PR"
if X="PR"
QUIT X
+3 QUIT "??"
FILN(X) ; File Number
+1 NEW NUM,TMP
SET NUM=0
SET TMP=$$UP^XLFSTR(X)
if TMP["DI"!(TMP["DX")!(TMP["ICD9")!(TMP=80)
SET NUM=80
+2 if TMP["PR"!(TMP["OP")!(TMP["ICD0")!(TMP=80.1)
SET NUM=80.1
if $DATA(^ICDS("F",+NUM))
QUIT NUM
+3 QUIT X
FILH ; File Help
+1 if $ORDER(^ICDS("F",0))>0
WRITE !,?4,"Select from:",!
+2 NEW FI
SET FI=0
FOR
SET FI=$ORDER(^ICDS("F",FI))
if +FI'>0
QUIT
Begin DoDot:1
+3 NEW CD,RT,NM
SET (CD,RT)=""
if FI=80
SET CD="DX"
SET RT="^ICD9("
if FI=80.1
SET CD="PR"
SET RT="^ICD0("
+4 SET NM=$$GET1^DIQ(1,(+FI_","),.01)
if $EXTRACT(NM,1,4)="ICD "
SET NM=$PIECE(NM,"ICD ",2)
+5 WRITE !,?10,FI,?16,CD,?20,NM,?41,RT
End DoDot:1
+6 QUIT
+7 ;
SYS(FILE,SYS) ; System
+1 NEW DIR,DTOUT,DUOUT,DIROUT,DIRUT,ROOT,TMP,Y
SET ROOT=$GET(FILE)
SET TMP=$$FILE^ICDEX(ROOT)
SET SYS=$$SYS^ICDEX($GET(SYS))
+2 if '$DATA(^ICDS("F",+TMP))
SET TMP=$$FILE^ICDEX(+SYS)
if '$DATA(^ICDS("F",+TMP))
SET TMP=$$FILN($GET(FILE))
+3 SET FILE=""
if $DATA(^ICDS("F",+TMP))
SET FILE=TMP
if $DATA(^ICDS("F",+($GET(FILE)),+($GET(SYS))))
QUIT +($GET(SYS))
+4 SET SYS=$$CS^ICDEX($GET(FILE))
if $DATA(^ICDS(+SYS,0))
QUIT +SYS
+5 QUIT -1
+6 ;
CDT(CDT,SYS) ; Date
+1 NEW DIR,DTOUT,DUOUT,DIROUT,DIRUT,ROOT,LO,NX,HI,TD,TMP,Y
+2 SET CDT=$GET(CDT)
SET SYS=$$SYS^ICDEX($GET(SYS))
SET LO=$$IMP^ICDEX(1)
+3 SET NX=$$IMP^ICDEX(+($GET(SYS)))
if LO?7N&(NX?7N)&(NX>LO)
SET LO=NX
SET HI=$$DT^XLFDT
SET HI=$$FMADD^XLFDT(HI,(365*3))
+4 IF CDT?7N
if LO?7N&(CDT<LO)
SET CDT=LO
if CDT=LO
QUIT CDT
if HI?7N&(CDT>HI)
SET CDT=HI
if CDT=HI
QUIT CDT
+5 if CDT?7N&(CDT'<LO)&(CDT'>HI)
QUIT CDT
+6 SET TD=$$DT^XLFDT
SET TMP=$TRANSLATE($$UP^XLFSTR($$FMTE^XLFDT(TD)),",","")
if TD>LO&(TD<HI)
SET DIR("B")=TMP
+7 SET DIR(0)="DAO^"_LO_":"_HI_":EX"
+8 SET DIR("A")=" Enter a Versioning Date: "
+9 SET DIR("PRE")="S X=$$CDTT^ICDEXLK6(X)"
SET (DIR("?"),DIR("??"))="^D CDTH^ICDEXLK6"
+10 DO ^DIR
+11 QUIT Y
CDTT(X) ; Date Transform
+1 SET X=$$UP^XLFSTR(X)
if X["?"
SET X="??"
if X["?"
QUIT X
+2 QUIT X
CDTH ; Date Help
+1 WRITE !,?5,"Enter a date to be used to determine the appropriate codes"
+2 WRITE !,?5,"and terms that were in use on the date specified. ",!
+3 IF $GET(LO)?7N
IF $GET(HI)?7N
Begin DoDot:1
+4 NEW BEG,END,MO,DY,YR
SET BEG=$$UP^XLFSTR($$FMTE^XLFDT($GET(LO)))
SET END=$$UP^XLFSTR($$FMTE^XLFDT($GET(HI)))
+5 SET MO=$PIECE(BEG," ",1)
SET DY=+($TRANSLATE($PIECE(BEG," ",2),",",""))
SET YR=$PIECE(BEG," ",3)
+6 WRITE !,?5,"Date must be from ",BEG," to ",END,!
+7 WRITE !,?5,"Examples of Valid Dates:",!
+8 WRITE !,?9,MO," ",DY," ",YR," or "
+9 WRITE DY," ",MO," ",$SELECT($LENGTH(YR)=2:YR,$LENGTH(YR)=4:$EXTRACT(YR,3,4),1:"")," or "
+10 WRITE +($EXTRACT(LO,6,7)),"/",$EXTRACT(LO,4,5),"/",$EXTRACT((1700+$EXTRACT(LO,1,3)),3,4)," or "
+11 WRITE $EXTRACT(LO,4,5),$EXTRACT(LO,6,7),$EXTRACT((1700+$EXTRACT(LO,1,3)),3,4)
End DoDot:1
+12 IF $GET(LO)'?7N!($GET(HI)'?7N)
Begin DoDot:1
+13 WRITE !,?5,"Examples of Valid Dates:",!
+14 WRITE !,?9,"JAN 20 1957 or 20 JAN 57 or 1/20/57 or 012057"
End DoDot:1
+15 WRITE !,?9," T (for TODAY), T+1 (for TOMORROW), T+2, T+7, etc."
+16 WRITE !,?9," T-1 (for YESTERDAY), T-3W (for 3 WEEKS AGO), etc.",!
+17 WRITE !,?5,"This date is sometimes called the 'versioning date' (VistA) or"
+18 WRITE !,?5,"the 'date service was provided to the patient' (HIPAA)"
+19 QUIT
+20 ;
DIC0(X) ; Correct DIC(0) for a versioned file
+1 ;
+2 ; Not used B - There are no pointer/variable pointers
+3 ; in index fields
+4 ; C - Cross-Reference suppression not allowed,
+5 ; entries must be unique
+6 ; I - If FileMan passes control to ICDEXLK,
+7 ; then "I"gnore no longer applies
+8 ; K - There is no primary Key (may change in
+9 ; the future)
+10 ; L - "Learn-As-You-Go" not allowed LAYGO is killed
+11 ; n - Only Codes, Text and IENs are allowed. "n"
+12 ; Returns too many values
+13 ; U - Only Codes, Text and IENs are allowed.
+14 ; V - Verify is always required when one entry is
+15 ; found
+16 KILL LAYGO
SET X=$GET(X)
KILL DINUM,DLAYGO
NEW CHR,STR
FOR CHR="C","B","K","L","n","U","T","V","I"
Begin DoDot:1
+17 FOR
if X'[CHR
QUIT
SET X=$PIECE(X,CHR,1)_$PIECE(X,CHR,2,299)
End DoDot:1
+18 SET STR=""
FOR CHR="A","E","Q","M","F","N","O","S","X","Z"
if X[CHR
SET STR=STR_CHR
+19 ;
+20 ; If non-numeric, and you are going to "A" ask
+21 ; then you are going to "E" echo
+22 if STR["A"&(STR'["E")&(STR'["N")
SET STR=STR_"E"
+23 ;
+24 ; If you are going to "E" echo, and X does not
+25 ; exist, then you will "A" ask
+26 if STR["E"&(STR'["A")&('$LENGTH($GET(X)))
SET STR=STR_"A"
+27 if STR'["A"&(STR'["E")&(STR'["X")
SET STR=STR_"X"
+28 SET X=STR
+29 QUIT X
DICU ; Undo DIC
+1 if $LENGTH($GET(ICDDICW))
SET DIC("W")=$GET(ICDDICW)
+2 if $LENGTH($GET(ICDDICA))
SET DIC("A")=$GET(ICDDICA)
+3 if $LENGTH($GET(ICDDICB))
SET DIC("B")=$GET(ICDDICB)
+4 if $LENGTH($GET(ICDDICS))
SET DIC("S")=$GET(ICDDICS)
+5 if $LENGTH($GET(ICDDIC0))
SET DIC(0)=$GET(ICDDIC0)
+6 if $LENGTH($GET(ICDDIC00))
SET DIC(0)=$GET(ICDDIC00)
+7 QUIT
DIE ; Set for DIE call
+1 if '$LENGTH($GET(DIE))
QUIT
if '$LENGTH($GET(DIC("A")))&($LENGTH($GET(DIP)))
SET DIC("A")=$GET(DIP)
+2 if $LENGTH($GET(DIC("A")))&($GET(DIC("A"))'["
SET DIC("A")=$GET(DIC("A"))_": "
+3 NEW DIE,DIP,DZ,X1
+4 QUIT
DICS(ICDS) ; Check DIC("S")
+1 NEW ICDT1,ICDT2,ICDTS
SET ICDT1=$DATA(X)
SET ICDT2=$GET(X)
if '$LENGTH($GET(ICDS))
QUIT ""
+2 SET (ICDTS,X)=$GET(ICDS)
DO ^DIM
IF '$DATA(X)
if ICDT1>0
SET X=$GET(ICDT2)
QUIT ""
+3 SET ICDS=$GET(ICDTS)
if ICDT1>0
SET X=$GET(ICDT2)
if $LENGTH($GET(ICDX))
SET X=$GET(ICDX)
+4 QUIT ICDS
+5 ;
SAV(X,DIC) ; Save Defaults
+1 NEW NUM,COM,VAL,ID,CUR,FUT,FILE,ROOT,SUB
if +($GET(DUZ))'>0
QUIT
if '$LENGTH($GET(DIC))
QUIT
if +($GET(Y))'>0
QUIT
+2 SET ROOT=$$ROOT^ICDEX(DIC)
if '$LENGTH(ROOT)
QUIT
SET SUB=$TRANSLATE(ROOT,"^(,","")
if '$LENGTH(SUB)
QUIT
+3 SET FILE=$$FILE^ICDEX(ROOT)
if +FILE'>0
QUIT
if "^80^80.1^"'[("^"_FILE_"^")
QUIT
+4 SET NUM=+($GET(DUZ))
if +NUM'>0
QUIT
if '$LENGTH($$GET1^DIQ(200,(NUM_","),.01))
QUIT
SET VAL=$GET(Y)
if '$LENGTH(VAL)
QUIT
+5 SET COM=$SELECT(FILE=80:"DX",FILE=80.1:"PR",1:"")
SET ID=$$TM(("ICDEXLK "_NUM_" "_COM))
+6 SET CUR=$$DT^XLFDT
SET FUT=$$FMADD^XLFDT(CUR,60)
+7 SET ^XTMP(ID,0)=FUT_"^"_CUR_"^"_"ICD "_$SELECT(COM="DX":"Diagnosis",COM="PR":"Procedures",1:"")
+8 SET ^XTMP(ID,SUB)=VAL
if $DATA(@(ROOT_+($GET(Y))_",0)"))
SET ^DISV(DUZ,ROOT)=+($GET(Y))
+9 QUIT
RET(DIC) ; Retrieve Defaults
+1 NEW NUM,COM,ID,CUR,FUT,FILE,ROOT,SUB
if +($GET(DUZ))'>0
QUIT ""
if '$LENGTH($GET(DIC))
QUIT ""
+2 SET ROOT=$$ROOT^ICDEX($GET(DIC))
if '$LENGTH(ROOT)
QUIT ""
SET SUB=$TRANSLATE(ROOT,"^(,","")
if '$LENGTH(SUB)
QUIT ""
+3 SET FILE=$$FILE^ICDEX(ROOT)
if +FILE'>0
QUIT ""
if "^80^80.1^"'[("^"_FILE_"^")
QUIT ""
+4 SET NUM=+($GET(DUZ))
if +NUM'>0
QUIT ""
if '$LENGTH($$GET1^DIQ(200,(NUM_","),.01))
QUIT ""
+5 SET COM=$SELECT(FILE=80:"DX",FILE=80.1:"PR",1:"")
SET ID=$$TM(("ICDEXLK "_NUM_" "_COM))
+6 SET X=$GET(^XTMP(ID,SUB))
if +X'>0&(+($GET(^DISV(NUM,ROOT)))>0)
SET X=+($GET(^DISV(NUM,ROOT)))
+7 QUIT X
PA(ICD,X) ; Parse Array
+1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,ICDI,ICDLEN,ICDC
KILL ^UTILITY($JOB,"W")
if '$DATA(ICD)
QUIT
+2 SET ICDLEN=+($GET(X))
if +ICDLEN'>0
SET ICDLEN=79
SET ICDC=+($GET(ICD))
if +($GET(ICDC))'>0
SET ICDC=$ORDER(ICD(" "),-1)
if +ICDC'>0
QUIT
+3 SET DIWL=1
SET DIWF="C"_+ICDLEN
SET ICDI=0
FOR
SET ICDI=$ORDER(ICD(ICDI))
if +ICDI=0
QUIT
SET X=$GET(ICD(ICDI))
DO ^DIWP
+4 KILL ICD
SET (ICDC,ICDI)=0
FOR
SET ICDI=$ORDER(^UTILITY($JOB,"W",1,ICDI))
if +ICDI=0
QUIT
Begin DoDot:1
+5 SET ICD(ICDI)=$$TM($GET(^UTILITY($JOB,"W",1,ICDI,0))," ")
SET ICDC=ICDC+1
End DoDot:1
+6 if $LENGTH(ICDC)
SET ICD=ICDC
KILL ^UTILITY($JOB,"W")
+7 QUIT
OUT(X,Y,Z,ARY) ; Output Array
+1 KILL ARY
NEW FILE,TERM,ROOT,IEN,FMT
SET ROOT=$GET(X)
SET IEN=+($GET(Y))
if '$LENGTH(ROOT)
QUIT
SET FMT=$GET(Z)
+2 if "^ICD9(^ICD0(^"'[("^"_$EXTRACT(ROOT,2,$LENGTH(ROOT))_"^")
QUIT
+3 SET FILE=$$FILE^ICDEX(ROOT)
if "^80^80.1^"'[("^"_FILE_"^")
QUIT
+4 if FMT'>0
SET FMT=1
if FMT>4
SET FMT=1
if '$DATA(@(ROOT_IEN_",0)"))
QUIT
+5 IF +($GET(FMT))=1!(+($GET(FMT))=3)
SET TERM=$$SD^ICDEX(FILE,IEN,CDT)
+6 IF +($GET(FMT))=2!(+($GET(FMT))=4)
SET TERM=$$LD^ICDEX(FILE,IEN,CDT)
+7 if '$LENGTH(TERM)
QUIT
if $PIECE(TERM,"^",1)=-1
QUIT
SET ARY(1)=TERM
if +($GET(FMT))=1!(+($GET(FMT))=3)
QUIT
+8 if +($GET(FMT))=2
DO PAR^ICDEX(.ARY,60)
if +($GET(FMT))=4
DO PAR^ICDEX(.ARY,70)
+9 QUIT
XT(X) ; Input Transform for X
+1 SET X=$TRANSLATE($GET(X),"""","")
if X="#"
SET X=""
SET X=$$TM(X,"#")
+2 QUIT X
TM(X,Y) ; Trim Y
+1 SET Y=$GET(Y)
if '$LENGTH(Y)
SET Y=" "
+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
