- 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 Feb 18, 2025@23:17:10 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