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

YSLXDG2.m

Go to the documentation of this file.
  1. YSLXDG2 ;ALB/RBD - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST;10 May 2013 9:46 AM
  1. ;;5.01;MENTAL HEALTH;**107**;Dec 30, 1994;Build 23
  1. ;
  1. ; Based on ZZLXDG2
  1. ;
  1. ; Input
  1. ;
  1. ; X Length of list to display (default 5)
  1. ; .YSSRL Local array passed by reference
  1. ;
  1. ; YSSRL() Input Array from ICDSRCH^LEX10CS
  1. ;
  1. ; YSSRL(0)=# found ^ Pruning Indicator
  1. ; YSSRL(1,0)=Code ^ Code IEN ^ date
  1. ; YSSRL(1,"IDL")=ICD-9/10 Description, Long
  1. ; YSSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
  1. ; YSSRL(1,"IDS")=ICD-9/10 Description, Short
  1. ; YSSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
  1. ; YSSRL(1,"LEX")=Lexicon Description
  1. ; YSSRL(1,"LEX",1)=Expression IEN ^ date
  1. ; YSSRL(1,"SYN",1)=Synonym #1
  1. ; YSSRL(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. ; YSSRL Local array passed by reference
  1. ;
  1. ; YSSRL(0)=Code ^ Code IEN ^ date
  1. ; YSSRL("IDL")=ICD-9/10 Description, Long
  1. ; YSSRL("IDL",1)=ICD-9/10 IEN ^ date
  1. ; YSSRL("IDS")=ICD-9/10 Description, Short
  1. ; YSSRL("IDS",1)=ICD-9/10 IEN ^ date
  1. ; YSSRL("LEX")=Lexicon Description
  1. ; YSSRL("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(YSSRL,X) ; Select from List
  1. N YSGOUP S YSGOUP=0
  1. S X=+($G(X))
  1. S:X'>0 X=5
  1. S X=$$ASK(.YSSRL,X)
  1. I YSGOUP=1 Q -2
  1. Q X
  1. ;
  1. ASK(YSSRL,X) ; Ask for Selection
  1. N DTOUT,DUOUT,DIROUT
  1. N YSLIT,YSLL,YSLTOT
  1. S YSLL=+($G(X))
  1. S:YSLL'>0 YSLL=5
  1. S YSLIT=0,YSLTOT=$O(YSSRL(" "),-1)
  1. Q:+YSLTOT'>0 "^"
  1. K X
  1. S:+YSLTOT=1 X=$$ONE(YSLL,.YSSRL)
  1. S:+YSLTOT>1 X=$$MUL(.YSSRL,YSLL)
  1. S:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(X))'>0) X=-1
  1. Q X
  1. ONE(X,YSSRL) ; One Entry Found
  1. Q:+($G(YSLIT))>0 "^^"
  1. N DIR,YSLC,YSLEX,YSLFI,YSLIT,YSLSO,YSLNC
  1. N YSLSP,YSLTX,YSLC,YSNXTLIN,Y
  1. S YSLFI=$O(YSSRL(0)) Q:+YSLFI'>0 "^" S YSLSP=$J(" ",11)
  1. S YSLSO=$P(YSSRL(1,0),"^",1),YSLNC=$P(YSSRL(1,0),"^",3)
  1. S:+YSLNC>0 YSLNC=" ("_YSLNC_")" S YSLEX=$G(YSSRL(1,"MENU"))
  1. S YSLC=$S($D(YSSRL(1,"CAT")):"-",1:"")
  1. S YSLTX(1)=YSLSO_YSLC_$J(" ",(9-$L(YSLSO)))_" "_YSLEX_YSLNC
  1. D PR(.YSLTX,64) S DIR("A",1)=" One match found",DIR("A",2)=" "
  1. S DIR("A",3)=" "_$G(YSLTX(1)),YSLC=3 I $L($G(YSLTX(2))) D
  1. . F YSNXTLIN=2:1 Q:$G(YSLTX(YSNXTLIN))="" D
  1. .. S YSLC=YSLC+1,DIR("A",YSLC)=YSLSP_$G(YSLTX(YSNXTLIN))
  1. S YSLC=YSLC+1,DIR("A",YSLC)=" ",YSLC=YSLC+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)) YSLIT=1
  1. I X["^^"!(+($G(YSLIT))>0) K YSSRL Q "^^"
  1. S X=$S(+Y>0:$$X(1,.YSSRL),1:-1)
  1. Q X
  1. MUL(YSSRL,Y) ; Multiple Entries Found
  1. Q:+($G(YSLIT))>0 "^^"
  1. N YSSRLE,YSLL,YSLMAX,YSLSS,YSLX,X
  1. S (YSLMAX,YSLSS,YSLIT)=0,YSLL=+($G(Y)),U="^" S:+($G(YSLL))'>0 YSLL=5
  1. S YSLX=$O(YSSRL(" "),-1),YSLSS=0
  1. G:+YSLX=0 MULQ W ! W:+YSLX>1 !," ",YSLX," matches found"
  1. F YSSRLE=1:1:YSLX Q:((YSLSS>0)&(YSLSS<(YSSRLE+1))) Q:YSLIT D Q:YSLIT
  1. . W:YSSRLE#YSLL=1 ! D MULW
  1. . S YSLMAX=YSSRLE W:YSSRLE#YSLL=0 !
  1. . S:YSSRLE#YSLL=0 YSLSS=$$MULS(YSLMAX,YSSRLE,.YSSRL) S:YSLSS["^" YSLIT=1
  1. I YSSRLE#YSLL'=0,+YSLSS<=0 D
  1. . W ! S YSLSS=$$MULS(YSLMAX,YSSRLE,.YSSRL) S:YSLSS["^" YSLIT=1
  1. G MULQ
  1. Q X
  1. MULW ; Write Multiple
  1. N YSLEX,YSLI1,YSLSO,YSLNC,YSLT2,YSLTX S YSLSO=$P(YSSRL(+YSSRLE,0),"^",1)
  1. S YSLNC=$P(YSSRL(+YSSRLE,0),"^",3) S:+YSLNC>0 YSLNC=" ("_YSLNC_")"
  1. S YSLEX=$G(YSSRL(+YSSRLE,"MENU")),YSLTX(1)=YSLSO
  1. S YSLTX(1)=YSLTX(1)_$S($D(YSSRL(+YSSRLE,"CAT")):"-",1:" ")_$J(" ",(9-$L(YSLSO)))_" "_YSLEX_YSLNC
  1. D PR(.YSLTX,60) W !,$J(YSSRLE,5),". ",$G(YSLTX(1))
  1. F YSLI1=2:1:5 S YSLT2=$G(YSLTX(YSLI1)) W:$L(YSLT2) !,$J(" ",19),YSLT2
  1. Q
  1. MULS(X,Y,YSSRL) ; Select from Multiple Entries
  1. N DIR,DIRB,YSLFI,YSLHLP,YSLLST,YSLMAX,YSLS1 ;@#$ not sure YSLS1 is needed here
  1. Q:+($G(YSLIT))>0 "^^" S YSLMAX=+($G(X)),YSLLST=+($G(Y))
  1. Q:YSLMAX=0 -1 S YSLFI=$O(YSSRL(0)) Q:+YSLFI'>0 -1
  1. I +($O(YSSRL(+YSLLST)))>0 D
  1. . S DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
  1. . S DIR("A")=DIR("A")_YSLMAX_": "
  1. I +($O(YSSRL(+YSLLST)))'>0 D
  1. . S DIR("A")=" Select 1-"_YSLMAX_": "
  1. S YSLHLP=" Answer must be from 1 to "
  1. S YSLHLP=YSLHLP_YSLMAX_", or <Return> to continue"
  1. S DIR("PRE")="S:X[""?"" X=""??"""
  1. S (DIR("?"),DIR("??"))="^D MULSH^YSLXDG2"
  1. S DIR(0)="NAO^1:"_YSLMAX_":0" D ^DIR
  1. S:X="^" YSGOUP=1
  1. Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
  1. S:X["^^"!($D(DTOUT)) YSLIT=1,X="^^" I X["^^"!(+($G(YSLIT))>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(YSLHLP)) W !,$G(YSLHLP) Q
  1. Q
  1. MULQ ; Quit Multiple
  1. I +YSLSS'>0,$G(YSLSS)="^" Q "^"
  1. S X=-1 S:+($G(YSLIT))'>0 X=$$X(+YSLSS,.YSSRL)
  1. Q X
  1. X(X,YSSRL) ; Set X and Output Array
  1. N YSLEX,YSSRFI,YSLIEN,YSLN1,YSLNC,YSLNN,YSLRN,YSLS1,YSLSO
  1. S YSLS1=+($G(X))
  1. S YSSRFI=$O(YSSRL(0)) ;@#$ not used?
  1. S YSLSO=$P($G(YSSRL(YSLS1,0)),"^",1),YSLEX=$G(YSSRL(YSLS1,"MENU"))
  1. S YSLIEN=$S($D(YSSRL(YSLS1,"CAT")):"99:CAT;"_$P($G(YSSRL(YSLS1,0)),"^"),1:$P($G(YSSRL(YSLS1,"LEX",1)),"^")_";"_$P($G(YSSRL(YSLS1,0)),"^")) Q:'$L(YSLSO) "^"
  1. Q:'$L(YSLEX) "^" Q:+YSLIEN'>0 "^" S X=YSLIEN_"^"_YSLEX
  1. S YSLNN="YSSRL("_+YSLS1_")",YSLNC="YSSRL("_+YSLS1_","
  1. F S YSLNN=$Q(@YSLNN) Q:'$L(YSLNN)!(YSLNN'[YSLNC) D
  1. . S YSLRN="YSLN1("_$P(YSLNN,"(",2,299) S @YSLRN=@YSLNN
  1. K YSSRL S YSLNN="YSLN1("_+YSLS1_")",YSLNC="YSLN1("_+YSLS1_","
  1. F S YSLNN=$Q(@YSLNN) Q:'$L(YSLNN)!(YSLNN'[YSLNC) D
  1. . S YSLRN="YSSRL("_$P(YSLNN,"(",2,299),@YSLRN=@YSLNN
  1. Q X
  1. ;
  1. ; Miscellaneous
  1. CL ; Clear
  1. K YSLIT
  1. Q
  1. PR(YSSRL,X) ; Parse Array
  1. N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,%D,YSLC,YSLI1,YSLL
  1. K ^UTILITY($J,"W")
  1. Q:'$D(YSSRL)
  1. S YSLL=+($G(X))
  1. S:+YSLL'>0 YSLL=79
  1. S YSLC=+($G(YSSRL))
  1. S:+($G(YSLC))'>0 YSLC=$O(YSSRL(" "),-1)
  1. Q:+YSLC'>0
  1. S DIWL=1,DIWF="C"_+YSLL
  1. S YSLI1=0
  1. F S YSLI1=$O(YSSRL(YSLI1)) Q:+YSLI1=0 S X=$G(YSSRL(YSLI1)) D ^DIWP
  1. K YSSRL
  1. S (YSLC,YSLI1)=0
  1. F S YSLI1=$O(^UTILITY($J,"W",1,YSLI1)) Q:+YSLI1=0 D
  1. . S YSSRL(YSLI1)=$$TM($G(^UTILITY($J,"W",1,YSLI1,0))," "),YSLC=YSLC+1
  1. S:$L(YSLC) YSSRL=YSLC
  1. K ^UTILITY($J,"W")
  1. Q
  1. TM(X,Y) ; Trim Character Y - Default " "
  1. S X=$G(X) Q:X="" X 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