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

PXSELDS.m

Go to the documentation of this file.
  1. PXSELDS ;ALB/RBD - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST ; 19 Mar 2013 10:43 AM
  1. ;;1.0;PCE PATIENT CARE ENCOUNTER;**199**;Aug 12, 1996;Build 51
  1. ;
  1. ; Copied from SROICDL and customized for PCE
  1. ;
  1. SEL(PXSRL,X) ; Select from List
  1. ;
  1. ;
  1. ; Input
  1. ;
  1. ; X Length of list to display (default 5)
  1. ; .PXSRL Local array passed by reference
  1. ;
  1. ; PXSRL() Input Array from ICDSRCH^LEX10CS
  1. ;
  1. ; PXSRL(0)=# found ^ Pruning Indicator
  1. ; PXSRL(1,0)=Code ^ Code IEN ^ date
  1. ; PXSRL(1,"IDL")=ICD-9/10 Description, Long
  1. ; PXSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
  1. ; PXSRL(1,"IDS")=ICD-9/10 Description, Short
  1. ; PXSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
  1. ; PXSRL(1,"LEX")=Lexicon Description
  1. ; PXSRL(1,"LEX",1)=Expression IEN ^ date
  1. ; PXSRL(1,"SYN",1)=Synonym #1
  1. ; PXSRL(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. ; PXSRL Local array passed by reference
  1. ;
  1. ; PXSRL(0)=Code ^ Code IEN ^ date
  1. ; PXSRL("IDL")=ICD-9/10 Description, Long
  1. ; PXSRL("IDL",1)=ICD-9/10 IEN ^ date
  1. ; PXSRL("IDS")=ICD-9/10 Description, Short
  1. ; PXSRL("IDS",1)=ICD-9/10 IEN ^ date
  1. ; PXSRL("LEX")=Lexicon Description
  1. ; PXSRL("LEX",1)=Expression IEN ^ date
  1. ;
  1. ; or ^ on error
  1. ; or -1 for non-selection
  1. ;
  1. S X=+($G(X)) S:X'>0 X=5 S X=$$ASK(.PXSRL,X)
  1. Q X
  1. ASK(PXSRL,X) ; Ask for Selection
  1. N PXSRLIT,PXSRLL,PXSRLTOT S PXSRLL=+($G(X)) S:PXSRLL'>0 PXSRLL=5
  1. S PXSRLIT=0,PXSRLTOT=$O(PXSRL(" "),-1) Q:+PXSRLTOT'>0 "^"
  1. K X S:+PXSRLTOT=1 X=$$ONE(PXSRLL,.PXSRL) S:+PXSRLTOT>1 X=$$MUL(.PXSRL,PXSRLL)
  1. I "D@"[X Q "@" ; user wants to delete the existing entry
  1. S:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(X))'>0) X=-1
  1. Q X
  1. ONE(X,PXSRL) ; One Entry Found
  1. Q:+($G(PXSRLIT))>0 "^^"
  1. N DIR,PXNXTLIN,PXSRLC,PXSRLEX,PXSRLFI,PXSRLIT,PXSRLNC,PXSRLSO,PXSRLSP,PXSRLTX,Y
  1. S PXSRLFI=$O(PXSRL(0)) Q:+PXSRLFI'>0 "^" S PXSRLSP=$J(" ",11)
  1. S PXSRLSO=$P(PXSRL(1,0),"^",1),PXSRLNC=$P(PXSRL(1,0),"^",3)
  1. S:+PXSRLNC>0 PXSRLNC=" ("_PXSRLNC_")" S PXSRLEX=$G(PXSRL(1,"MENU"))
  1. S PXSRLC=$S($D(PXSRL(1,"CAT")):"-",1:"")
  1. S PXSRLTX(1)=PXSRLSO_PXSRLC_$J(" ",(9-$L(PXSRLSO)))_" "_PXSRLEX_PXSRLNC
  1. D PR(.PXSRLTX,64) S DIR("A",1)=" One code found",DIR("A",2)=" "
  1. S DIR("A",3)=" "_$G(PXSRLTX(1)),PXSRLC=3 I $L($G(PXSRLTX(2))) D
  1. . F PXNXTLIN=2:1 Q:$G(PXSRLTX(PXNXTLIN))="" D
  1. .. S PXSRLC=PXSRLC+1,DIR("A",PXSRLC)=PXSRLSP_$G(PXSRLTX(PXNXTLIN))
  1. S PXSRLC=PXSRLC+1,DIR("A",PXSRLC)=" ",PXSRLC=PXSRLC+1
  1. D SET1:$D(PXDEF),SET2:'$D(PXDEF)
  1. D ^DIR S Y=Y="Y"
  1. I X'="","Dd@"[X Q "@" ; user wants to delete the existing entry
  1. Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&((+$G(Y))'>0) -1
  1. S:X["^^"!($D(DTOUT)) PXSRLIT=1
  1. I X["^^"!(+($G(PXSRLIT))>0) K PXSRL Q "^^"
  1. S X=$S(+Y>0:$$X(1,.PXSRL),1:-1)
  1. Q X
  1. MUL(PXSRL,Y) ; Multiple Entries Found
  1. Q:+($G(PXSRLIT))>0 "^^" N PXSRLE,PXSRLL,PXSRLMAX,PXSRLSS,PXSRLX,X
  1. S (PXSRLMAX,PXSRLSS,PXSRLIT)=0,PXSRLL=+($G(Y)),U="^" S:+($G(PXSRLL))'>0 PXSRLL=5
  1. S PXSRLX=$O(PXSRL(" "),-1),PXSRLSS=0
  1. G:+PXSRLX=0 MULQ W ! W:+PXSRLX>1 !," ",PXSRLX," matches found"
  1. F PXSRLE=1:1:PXSRLX Q:((PXSRLSS>0)&(PXSRLSS<(PXSRLE+1))) Q:PXSRLIT D Q:PXSRLIT
  1. . W:PXSRLE#PXSRLL=1 ! D MULW
  1. . S PXSRLMAX=PXSRLE W:PXSRLE#PXSRLL=0 !
  1. . S:PXSRLE#PXSRLL=0 PXSRLSS=$$MULS(PXSRLMAX,PXSRLE,.PXSRL) S:PXSRLSS["^" PXSRLIT=1
  1. I PXSRLE#PXSRLL'=0,+PXSRLSS<=0 D
  1. . W ! S PXSRLSS=$$MULS(PXSRLMAX,PXSRLE,.PXSRL) S:PXSRLSS["^" PXSRLIT=1
  1. G MULQ
  1. Q X
  1. MULW ; Write Multiple
  1. N PXSRLEX,PXSRLI,PXSRLSO,PXSRLNC,PXSRLT,PXSRLTX S PXSRLSO=$P(PXSRL(+PXSRLE,0),"^",1)
  1. S PXSRLNC=$P(PXSRL(+PXSRLE,0),"^",3) S:+PXSRLNC>0 PXSRLNC=" ("_PXSRLNC_")"
  1. S PXSRLEX=$G(PXSRL(+PXSRLE,"MENU")),PXSRLTX(1)=PXSRLSO
  1. S PXSRLTX(1)=PXSRLTX(1)_$S($D(PXSRL(+PXSRLE,"CAT")):"-",1:" ")_$J(" ",(9-$L(PXSRLSO)))_" "_PXSRLEX_PXSRLNC
  1. D PR(.PXSRLTX,60) W !,$J(PXSRLE,5),". ",$G(PXSRLTX(1))
  1. F PXSRLI=2:1:5 S PXSRLT=$G(PXSRLTX(PXSRLI)) W:$L(PXSRLT) !,$J(" ",19),PXSRLT
  1. Q
  1. MULS(X,Y,PXSRL) ; Select from Multiple Entries
  1. N DIR,DIRB,PXSRLFI,PXSRLHLP,PXSLLAST,PXSRLMAX,PXSRLS
  1. Q:+($G(PXSRLIT))>0 "^^" S PXSRLMAX=+($G(X)),PXSLLAST=+($G(Y))
  1. Q:PXSRLMAX=0 -1 S PXSRLFI=$O(PXSRL(0)) Q:+PXSRLFI'>0 -1
  1. I +($O(PXSRL(+PXSLLAST)))>0 D
  1. . S DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
  1. . S DIR("A")=DIR("A")_PXSRLMAX_": "
  1. I +($O(PXSRL(+PXSLLAST)))'>0 D
  1. . S DIR("A")=" Select 1-"_PXSRLMAX_": "
  1. S PXSRLHLP=" Answer must be from 1 to "
  1. S PXSRLHLP=PXSRLHLP_PXSRLMAX_", or <Return> to continue"
  1. S DIR("PRE")="S:X[""?"" X=""??"""
  1. S (DIR("?"),DIR("??"))="^D MULSH^PXSELDS"
  1. S DIR(0)="NAO^1:"_PXSRLMAX_":0" D ^DIR
  1. Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
  1. S:X["^^"!($D(DTOUT)) PXSRLIT=1,X="^^" I X["^^"!(+($G(PXSRLIT))>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(PXSRLHLP)) W !,$G(PXSRLHLP) Q
  1. Q
  1. MULQ ; Quit Multiple
  1. I +PXSRLSS'>0,$G(PXSRLSS)="^" Q "^"
  1. S X=-1 S:+($G(PXSRLIT))'>0 X=$$X(+PXSRLSS,.PXSRL)
  1. Q X
  1. X(X,PXSRL) ; Set X and Output Array
  1. N PXSRLEX,PXSRFI,PXSRLIEN,PXSRLN,PXSRLNC,PXSRLNN,PXSRLRN,PXSRLS,PXSRLSO
  1. S PXSRLS=+($G(X)) S PXSRFI=$O(PXSRL(0))
  1. S PXSRLSO=$P($G(PXSRL(PXSRLS,0)),"^",1),PXSRLEX=$G(PXSRL(PXSRLS,"MENU"))
  1. S PXSRLIEN=$S($D(PXSRL(PXSRLS,"CAT")):"99:CAT;"_$P($G(PXSRL(PXSRLS,0)),"^"),1:$P($G(PXSRL(PXSRLS,"LEX",1)),"^")_";"_$P($G(PXSRL(PXSRLS,0)),"^")) Q:'$L(PXSRLSO) "^"
  1. Q:'$L(PXSRLEX) "^" Q:+PXSRLIEN'>0 "^" S X=PXSRLIEN_"^"_PXSRLEX
  1. S PXSRLNN="PXSRL("_+PXSRLS_")",PXSRLNC="PXSRL("_+PXSRLS_","
  1. F S PXSRLNN=$Q(@PXSRLNN) Q:'$L(PXSRLNN)!(PXSRLNN'[PXSRLNC) D
  1. . S PXSRLRN="PXSRLN("_$P(PXSRLNN,"(",2,299) S @PXSRLRN=@PXSRLNN
  1. K PXSRL S PXSRLNN="PXSRLN("_+PXSRLS_")",PXSRLNC="PXSRLN("_+PXSRLS_","
  1. F S PXSRLNN=$Q(@PXSRLNN) Q:'$L(PXSRLNN)!(PXSRLNN'[PXSRLNC) D
  1. . S PXSRLRN="PXSRL("_$P(PXSRLNN,"(",2,299),@PXSRLRN=@PXSRLNN
  1. Q X
  1. ;
  1. ; Miscellaneous
  1. CL ; Clear
  1. K PXSRLIT
  1. Q
  1. ;
  1. PR(PXSRL,X) ; Parse Array
  1. N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,%D,PXSRLC,PXSRLI,PXSRLL
  1. K ^UTILITY($J,"W") Q:'$D(PXSRL) S PXSRLL=+($G(X)) S:+PXSRLL'>0 PXSRLL=79
  1. S PXSRLC=+($G(PXSRL)) S:+($G(PXSRLC))'>0 PXSRLC=$O(PXSRL(" "),-1) Q:+PXSRLC'>0
  1. S DIWL=1,DIWF="C"_+PXSRLL S PXSRLI=0
  1. F S PXSRLI=$O(PXSRL(PXSRLI)) Q:+PXSRLI=0 S X=$G(PXSRL(PXSRLI)) D ^DIWP
  1. K PXSRL S (PXSRLC,PXSRLI)=0
  1. F S PXSRLI=$O(^UTILITY($J,"W",1,PXSRLI)) Q:+PXSRLI=0 D
  1. . S PXSRL(PXSRLI)=$$TM($G(^UTILITY($J,"W",1,PXSRLI,0))," "),PXSRLC=PXSRLC+1
  1. S:$L(PXSRLC) PXSRL=PXSRLC K ^UTILITY($J,"W")
  1. Q
  1. ;
  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
  1. ;
  1. SET1 ; Use this if a default ICD-10 code was supplied
  1. S DIR("A")="OK? ",DIR("B")="YES",DIR(0)="SAOB^Y:Yes;N:No;D:Delete;@:Delete"
  1. S DIR("L",1)=" Y - Yes | @ - Delete"
  1. S DIR("L",2)=" N - No | ? - Help"
  1. S DIR("L",3)=" D - Delete | ?? - Extra Help"
  1. S DIR("L")=" | ^ - Exit"
  1. Q
  1. ;
  1. SET2 ; Use this if no default ICD-10 code was supplied
  1. S DIR("A")="OK? ",DIR("B")="YES",DIR(0)="SAOB^Y:Yes;N:No"
  1. S DIR("L",1)=" Y - Yes | ? - Help"
  1. S DIR("L",2)=" N - No | ?? - Extra Help"
  1. S DIR("L")=" | ^ - Exit"
  1. Q