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

ICDSELDS.m

Go to the documentation of this file.
  1. ICDSELDS ;ALB/SJA/SS/KUM - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST ;12/07/2011
  1. ;;18.0;DRG Grouper;**64,94**;Oct 20, 2000;Build 5
  1. ;
  1. ;
  1. ;
  1. ; Input
  1. ;
  1. ; X Length of list to display (default 5)
  1. ; .ICDSRL Local array passed by reference
  1. ;
  1. ; ICDSRL() Input Array from ICDSRCH^LEX10CS
  1. ;
  1. ; ICDSRL(0)=# found ^ Pruning Indicator
  1. ; ICDSRL(1,0)=Code ^ Code IEN ^ date
  1. ; ICDSRL(1,"IDL")=ICD-9/10 Description, Long
  1. ; ICDSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
  1. ; ICDSRL(1,"IDS")=ICD-9/10 Description, Short
  1. ; ICDSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
  1. ; ICDSRL(1,"LEX")=Lexicon Description
  1. ; ICDSRL(1,"LEX",1)=Expression IEN ^ date
  1. ; ICDSRL(1,"SYN",1)=Synonym #1
  1. ; ICDSRL(1,"SYN",m)=Synonym #m
  1. ; ...
  1. ;
  1. ; Output
  1. ;
  1. ; $$SEL Two Piece "^" delimited string same as
  1. ; Fileman's Y output variable
  1. ;
  1. ; 1 Lexicon IEN
  1. ; 2 Lexicon Term
  1. ;
  1. ; ICDSRL Local array passed by reference
  1. ;
  1. ; ICDSRL(0)=Code ^ Code IEN ^ date
  1. ; ICDSRL("IDL")=ICD-9/10 Description, Long
  1. ; ICDSRL("IDL",1)=ICD-9/10 IEN ^ date
  1. ; ICDSRL("IDS")=ICD-9/10 Description, Short
  1. ; ICDSRL("IDS",1)=ICD-9/10 IEN ^ date
  1. ; ICDSRL("LEX")=Lexicon Description
  1. ; ICDSRL("LEX",1)=Expression IEN ^ date
  1. ;
  1. ; or ^ on error
  1. ; or -1 for non-selection
  1. ; or -2 if "^" was entered
  1. ;
  1. SEL(ICDSRL,X) ; Select from List
  1. N ICDGOUP S ICDGOUP=0
  1. S X=+($G(X))
  1. S:X'>0 X=5
  1. S X=$$ASK(.ICDSRL,X)
  1. I ICDGOUP=1 Q -2
  1. Q X
  1. ;
  1. ASK(ICDSRL,X) ; Ask for Selection
  1. N DTOUT,DUOUT,DIROUT
  1. N ICDLIT,ICDLL,ICDLTOT
  1. S ICDLL=+($G(X))
  1. S:ICDLL'>0 ICDLL=5
  1. S ICDLIT=0,ICDLTOT=$O(ICDSRL(" "),-1)
  1. Q:+ICDLTOT'>0 "^"
  1. K X
  1. S:+ICDLTOT=1 X=$$ONE(ICDLL,.ICDSRL)
  1. S:+ICDLTOT>1 X=$$MUL(.ICDSRL,ICDLL)
  1. S:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(X))'>0) X=-1
  1. Q X
  1. ONE(X,ICDSRL) ; One Entry Found
  1. Q:+($G(ICDLIT))>0 "^^"
  1. N DIR,ICDLC,ICDLEX,ICDLFI,ICDLIT,ICDLSO,ICDLNC
  1. N ICDLSP,ICDLTX,ICDLC,Y,ICDCNT1
  1. S ICDLFI=$O(ICDSRL(0)) Q:+ICDLFI'>0 "^" S ICDLSP=$J(" ",11)
  1. S ICDLSO=$P(ICDSRL(1,0),"^",1),ICDLNC=$P(ICDSRL(1,0),"^",3)
  1. S:+ICDLNC>0 ICDLNC=" ("_ICDLNC_")" S ICDLEX=$G(ICDSRL(1,"MENU"))
  1. S ICDLC=$S($D(ICDSRL(1,"CAT")):"-",1:"")
  1. S ICDLTX(1)=ICDLSO_ICDLC_$J(" ",(9-$L(ICDLSO)))_" "_ICDLEX_ICDLNC
  1. D PR(.ICDLTX,64) S DIR("A",1)=" One match found",DIR("A",2)=" "
  1. S DIR("A",3)=" "_$G(ICDLTX(1))
  1. S ICDLC=3
  1. F ICDCNT1=2:1 Q:$G(ICDLTX(ICDCNT1))="" S ICDLC=ICDLC+1,DIR("A",ICDLC)=ICDLSP_$G(ICDLTX(ICDCNT1))
  1. S ICDLC=ICDLC+1,DIR("A",ICDLC)=" ",ICDLC=ICDLC+1
  1. S DIR("A")=" OK? (Yes/No) ",DIR("B")="Yes",DIR(0)="YAO" W !
  1. D ^DIR Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
  1. S:X["^^"!($D(DTOUT)) ICDLIT=1
  1. I X["^^"!(+($G(ICDLIT))>0) K ICDSRL Q "^^"
  1. S X=$S(+Y>0:$$X(1,.ICDSRL),1:-1)
  1. Q X
  1. MUL(ICDSRL,Y) ; Multiple Entries Found
  1. Q:+($G(ICDLIT))>0 "^^"
  1. N ICDSRLE,ICDLL,ICDLMAX,ICDLSS,ICDLX,X
  1. S (ICDLMAX,ICDLSS,ICDLIT)=0,ICDLL=+($G(Y)),U="^" S:+($G(ICDLL))'>0 ICDLL=5
  1. S ICDLX=$O(ICDSRL(" "),-1),ICDLSS=0
  1. G:+ICDLX=0 MULQ W ! W:+ICDLX>1 !," ",ICDLX," matches found"
  1. F ICDSRLE=1:1:ICDLX Q:((ICDLSS>0)&(ICDLSS<(ICDSRLE+1))) Q:ICDLIT D Q:ICDLIT
  1. . W:ICDSRLE#ICDLL=1 ! D MULW
  1. . S ICDLMAX=ICDSRLE W:ICDSRLE#ICDLL=0 !
  1. . S:ICDSRLE#ICDLL=0 ICDLSS=$$MULS(ICDLMAX,ICDSRLE,.ICDSRL) S:ICDLSS["^" ICDLIT=1
  1. I ICDSRLE#ICDLL'=0,+ICDLSS<=0 D
  1. . W ! S ICDLSS=$$MULS(ICDLMAX,ICDSRLE,.ICDSRL) S:ICDLSS["^" ICDLIT=1
  1. G MULQ
  1. Q X
  1. MULW ; Write Multiple
  1. N ICDLEX,ICDLI1,ICDLSO,ICDLNC,ICDLT2,ICDLTX S ICDLSO=$P(ICDSRL(+ICDSRLE,0),"^",1)
  1. S ICDLNC=$P(ICDSRL(+ICDSRLE,0),"^",3) S:+ICDLNC>0 ICDLNC=" ("_ICDLNC_")"
  1. S ICDLEX=$G(ICDSRL(+ICDSRLE,"MENU")),ICDLTX(1)=ICDLSO
  1. S ICDLTX(1)=ICDLTX(1)_$S($D(ICDSRL(+ICDSRLE,"CAT")):"-",1:" ")_$J(" ",(9-$L(ICDLSO)))_" "_ICDLEX_ICDLNC
  1. D PR(.ICDLTX,60) W !,$J(ICDSRLE,5),". ",$G(ICDLTX(1))
  1. F ICDLI1=2:1:5 S ICDLT2=$G(ICDLTX(ICDLI1)) W:$L(ICDLT2) !,$J(" ",19),ICDLT2
  1. Q
  1. MULS(X,Y,ICDSRL) ; Select from Multiple Entries
  1. N DIR,DIRB,ICDLFI,ICDLHLP,ICDLLST,ICDLMAX,ICDLS1 ;@#$ not sure ICDLS1 is needed here
  1. Q:+($G(ICDLIT))>0 "^^" S ICDLMAX=+($G(X)),ICDLLST=+($G(Y))
  1. Q:ICDLMAX=0 -1 S ICDLFI=$O(ICDSRL(0)) Q:+ICDLFI'>0 -1
  1. I +($O(ICDSRL(+ICDLLST)))>0 D
  1. . S DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
  1. . S DIR("A")=DIR("A")_ICDLMAX_": "
  1. I +($O(ICDSRL(+ICDLLST)))'>0 D
  1. . S DIR("A")=" Select 1-"_ICDLMAX_": "
  1. S ICDLHLP=" Answer must be from 1 to "
  1. S ICDLHLP=ICDLHLP_ICDLMAX_", or <Return> to continue"
  1. S DIR("PRE")="S:X[""?"" X=""??"""
  1. S (DIR("?"),DIR("??"))="^D MULSH^ICDSELDS"
  1. S DIR(0)="NAO^1:"_ICDLMAX_":0" D ^DIR
  1. S:X="^" ICDGOUP=1
  1. Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
  1. S:X["^^"!($D(DTOUT)) ICDLIT=1,X="^^" I X["^^"!(+($G(ICDLIT))>0) Q "^^"
  1. K DIR Q:$D(DTOUT)!(X[U) "^^"
  1. Q $S(+Y>0:+Y,1:"-1")
  1. MULSH ; Select from Multiple Entries Help
  1. I $L($G(ICDLHLP)) W !,$G(ICDLHLP) Q
  1. Q
  1. MULQ ; Quit Multiple
  1. I +ICDLSS'>0,$G(ICDLSS)="^" Q "^"
  1. S X=-1 S:+($G(ICDLIT))'>0 X=$$X(+ICDLSS,.ICDSRL)
  1. Q X
  1. X(X,ICDSRL) ; Set X and Output Array
  1. N ICDLEX,ICDSRFI,ICDLIEN,ICDLN1,ICDLNC,ICDLNN,ICDLRN,ICDLS1,ICDLSO
  1. S ICDLS1=+($G(X))
  1. S ICDSRFI=$O(ICDSRL(0)) ;@#$ not used?
  1. S ICDLSO=$P($G(ICDSRL(ICDLS1,0)),"^",1),ICDLEX=$G(ICDSRL(ICDLS1,"MENU"))
  1. S ICDLIEN=$S($D(ICDSRL(ICDLS1,"CAT")):"99:CAT;"_$P($G(ICDSRL(ICDLS1,0)),"^"),1:$P($G(ICDSRL(ICDLS1,"LEX",1)),"^")_";"_$P($G(ICDSRL(ICDLS1,0)),"^")) Q:'$L(ICDLSO) "^"
  1. Q:'$L(ICDLEX) "^" Q:+ICDLIEN'>0 "^" S X=ICDLIEN_"^"_ICDLEX
  1. S ICDLNN="ICDSRL("_+ICDLS1_")",ICDLNC="ICDSRL("_+ICDLS1_","
  1. F S ICDLNN=$Q(@ICDLNN) Q:'$L(ICDLNN)!(ICDLNN'[ICDLNC) D
  1. . S ICDLRN="ICDLN1("_$P(ICDLNN,"(",2,299) S @ICDLRN=@ICDLNN
  1. K ICDSRL S ICDLNN="ICDLN1("_+ICDLS1_")",ICDLNC="ICDLN1("_+ICDLS1_","
  1. F S ICDLNN=$Q(@ICDLNN) Q:'$L(ICDLNN)!(ICDLNN'[ICDLNC) D
  1. . S ICDLRN="ICDSRL("_$P(ICDLNN,"(",2,299),@ICDLRN=@ICDLNN
  1. Q X
  1. ;
  1. ; Miscellaneous
  1. CL ; Clear
  1. K ICDLIT
  1. Q
  1. PR(ICDSRL,X) ; Parse Array
  1. N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,ICDDN,I,Z,%,%D,ICDLC,ICDLI1,ICDLL
  1. K ^UTILITY($J,"W")
  1. Q:'$D(ICDSRL)
  1. S ICDLL=+($G(X))
  1. S:+ICDLL'>0 ICDLL=79
  1. S ICDLC=+($G(ICDSRL))
  1. S:+($G(ICDLC))'>0 ICDLC=$O(ICDSRL(" "),-1)
  1. Q:+ICDLC'>0
  1. S DIWL=1,DIWF="C"_+ICDLL
  1. S ICDLI1=0
  1. F S ICDLI1=$O(ICDSRL(ICDLI1)) Q:+ICDLI1=0 S X=$G(ICDSRL(ICDLI1)) D ^DIWP
  1. K ICDSRL
  1. S (ICDLC,ICDLI1)=0
  1. F S ICDLI1=$O(^UTILITY($J,"W",1,ICDLI1)) Q:+ICDLI1=0 D
  1. . S ICDSRL(ICDLI1)=$$TM($G(^UTILITY($J,"W",1,ICDLI1,0))," "),ICDLC=ICDLC+1
  1. S:$L(ICDLC) ICDSRL=ICDLC
  1. K ^UTILITY($J,"W")
  1. Q
  1. TM(ICDX,ICDY) ; Trim Character Y - Default " "
  1. S ICDX=$G(ICDX) Q:ICDX="" ICDX S ICDY=$G(ICDY) S:'$L(ICDY) ICDY=" "
  1. F Q:$E(ICDX,1)'=ICDY S ICDX=$E(ICDX,2,$L(ICDX))
  1. F Q:$E(ICDX,$L(ICDX))'=ICDY S ICDX=$E(ICDX,1,($L(ICDX)-1))
  1. Q ICDX