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

ICDEXLK6.m

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