DGICPL ;ALB/KUM - Select ICD PROCEDURE FROM A LEXICON UTILITY LIST ;12/07/2011
;;5.3;Registration;**850**;Aug 13, 1993;Build 171
;
;
SEL(ICDSRL,X) ; Select from List
;
; Input
;
; X Length of list to display (default 5)
; .ICDSRL Local array passed by reference
;
; ICDSRL() Input Array from ICDSRCH^LEX10CS
;
; ICDSRL(0)=# found ^ Pruning Indicator
; ICDSRL(1,0)=Code ^ Code IEN ^ date
; ICDSRL(1,"IDL")=ICD-9/10 Description, Long
; ICDSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
; ICDSRL(1,"IDS")=ICD-9/10 Description, Short
; ICDSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
; ICDSRL(1,"LEX")=Lexicon Description
; ICDSRL(1,"LEX",1)=Expression IEN ^ date
; ICDSRL(1,"SYN",1)=Synonym #1
; ICDSRL(1,"SYN",m)=Synonym #m
; ...
;
; Output
;
; $$SEL Two Piece "^" delimited string same as
; Fileman's Y output variable
;
; 1 Lexicon IEN
; 2 Lexicon Term
;
; ICDSRL Local array passed by reference
;
; ICDSRL(0)=Code ^ Code IEN ^ date
; ICDSRL("IDL")=ICD-9/10 Description, Long
; ICDSRL("IDL",1)=ICD-9/10 IEN ^ date
; ICDSRL("IDS")=ICD-9/10 Description, Short
; ICDSRL("IDS",1)=ICD-9/10 IEN ^ date
; ICDSRL("LEX")=Lexicon Description
; ICDSRL("LEX",1)=Expression IEN ^ date
;
; or ^ on error
; or -1 for non-selection
;
S X=+($G(X)) S:X'>0 X=5 S X=$$ASK(.ICDSRL,X)
Q X
ASK(ICDSRL,X) ; Ask for Selection
K X N ICDSRLIT,ICDSRLL,ICDSRTOT S ICDSRLL=+($G(X)) S:ICDSRLL'>0 ICDSRLL=5
S ICDSRLIT=0,ICDSRTOT=$O(ICDSRL(" "),-1) Q:+ICDSRTOT'>0 "^"
K X S:+ICDSRTOT=1 X=$$ONE(ICDSRLL,.ICDSRL) S:+ICDSRTOT>1 X=$$MUL(.ICDSRL,ICDSRLL)
Q X
ONE(X,ICDSRL) ; One Entry Found
Q:+($G(ICDSRLIT))>0 "^^" N DIR,DTOUT,ICDSRLC,ICDSRLEX,ICDSRLFI,ICDSRLIT,ICDSRLSO
N ICDSRLSP,ICDSRLTX,Y
S ICDSRLFI=$O(ICDSRL(0)) Q:+ICDSRLFI'>0 "^" S ICDSRLSP=$J(" ",25)
S ICDSRLSO=$P(ICDSRL(1,0),"^",1),ICDSRLEX=$G(ICDSRL(1,"LEX"))
S ICDSRLTX(1)=ICDSRLSO_$J(" ",(9-$L(ICDSRLSO)))_" "_ICDSRLEX
D PR(.ICDSRLTX,64) S DIR("A",1)=" One code found for character "_($L($G(ICDPRC))+1)_".",DIR("A",2)=" "
S DIR("A",3)=" "_$G(ICDSRLTX(1)),ICDSRLC=3 I $L($G(ICDSRLTX(2))) D
. S ICDSRLC=ICDSRLC+1,DIR("A",ICDSRLC)=ICDSRLSP_$G(ICDSRLTX(2))
S ICDSRLC=ICDSRLC+1,DIR("A",ICDSRLC)=" ",ICDSRLC=ICDSRLC+1
S DIR("A")=" OK? (Yes/No) ",DIR("B")="Yes",DIR(0)="YAO" W !
D ^DIR S:X["^^"!($D(DTOUT)) ICDSRLIT=1
I X["^^"!(+($G(ICDSRLIT))>0) K ICDSRL Q "^^"
S X=$S(+Y>0:$$X(1,.ICDSRL),1:-1)
Q X
MUL(ICDSRL,Y) ; Multiple Entries Found
Q:+($G(ICDSRLIT))>0 "^^" N ICDSRLE,ICDSRLL,ICDSRMAX,ICDSRLSS,ICDSRLX,X
S (ICDSRMAX,ICDSRLSS,ICDSRLIT)=0,ICDSRLL=+($G(Y)),U="^" S:+($G(ICDSRLL))'>0 ICDSRLL=5
S ICDSRLX=$O(ICDSRL(" "),-1),ICDSRLSS=0
G:+ICDSRLX=0 MULQ W ! W:+ICDSRLX>1 !," ",ICDSRLX," matches found for character ",$L($G(ICDPRC))+1,"."
F ICDSRLE=1:1:ICDSRLX Q:((ICDSRLSS>0)&(ICDSRLSS<(ICDSRLE+1))) Q:ICDSRLIT D Q:ICDSRLIT
. W:ICDSRLE#ICDSRLL=1 ! D MULW
. S ICDSRMAX=ICDSRLE W:ICDSRLE#ICDSRLL=0 !
. S:ICDSRLE#ICDSRLL=0 ICDSRLSS=$$MULS(ICDSRMAX,ICDSRLE,.ICDSRL) S:ICDSRLSS["^" ICDSRLIT=1
I ICDSRLE#ICDSRLL'=0,+ICDSRLSS<=0 D
. W ! S ICDSRLSS=$$MULS(ICDSRMAX,ICDSRLE,.ICDSRL) S:ICDSRLSS["^" ICDSRLIT=1
G MULQ
Q X
MULW ; Write Multiple
N ICDSRLEX,ICDSRLI,ICDSRLSO,ICDSRLT,ICDSRLTX S ICDSRLSO=$P(ICDSRL(+ICDSRLE,0),"^",1)
S ICDSRLEX=$G(ICDSRL(+ICDSRLE,"LEX")),ICDSRLTX(1)=ICDSRLSO
S ICDSRLTX(1)=ICDSRLTX(1)_$J(" ",(9-$L(ICDSRLSO)))_" "_ICDSRLEX
D PR(.ICDSRLTX,63) W !,$J(ICDSRLE,5),". ",$G(ICDSRLTX(1))
F ICDSRLI=2:1:5 S ICDSRLT=$G(ICDSRLTX(ICDSRLI)) W:$L(ICDSRLT) !,$J(" ",18),ICDSRLT
Q
MULS(X,Y,ICDSRL) ; Select from Multiple Entries
N DIR,DIRB,DIROUT,DIRUT,DTOUT,DUOUT,ICDSRLFI,ICDSRHLP,ICDSRLAST,ICDSRMAX,ICDSRLS
Q:+($G(ICDSRLIT))>0 "^^" S ICDSRMAX=+($G(X)),ICDSRLAST=+($G(Y))
Q:ICDSRMAX=0 -1 S ICDSRLFI=$O(ICDSRL(0)) Q:+ICDSRLFI'>0 -1
I +($O(ICDSRL(+ICDSRLAST)))>0 D
. S DIR("A")=" Press <RETURN> for more, '^' to quit selection, or Select 1-"
. S DIR("A")=DIR("A")_ICDSRMAX_": "
I +($O(ICDSRL(+ICDSRLAST)))'>0 D
. S DIR("A")=" Select 1-"_ICDSRMAX_": "
S ICDSRHLP=" Answer must be from 1 to "
S ICDSRHLP=ICDSRHLP_ICDSRMAX_", or <Return> to continue"
S DIR("PRE")="S:X[""?"" X=""??"""
S (DIR("?"),DIR("??"))="^D MULSH^ICDSELPS"
S DIR(0)="NAO^1:"_ICDSRMAX_":0" D ^DIR
I X["^^"!($D(DTOUT)) S ICDSRLIT=1,X="^^" Q "^^"
K DIR Q:$D(DTOUT)!(X[U) "^"
Q $S(+Y>0:+Y,1:"-1")
MULSH ; Select from Multiple Entries Help
I $L($G(ICDSRHLP)) W !,$G(ICDSRHLP) Q
Q
MULQ ; Quit Multiple Entries Selection
Q:+($G(ICDSRLSS))'>0 -1 S X=-1 S:+($G(ICDSRLIT))'>0 X=$$X(+ICDSRLSS,.ICDSRL)
Q X
X(X,ICDSRL) ; Set X and Outpot Array
N ICDSRLEX,LEXFI,ICDSRLIEN,ICDSRLN,ICDSRLNC,ICDSRLNN,ICDSRLRN,ICDSRLS,ICDSRLSO
S ICDSRLS=+($G(X)) S LEXFI=$O(LEX(0))
S ICDSRLSO=$P($G(ICDSRL(ICDSRLS,0)),"^",1)
S ICDSRLEX=$G(ICDSRL(ICDSRLS,"LEX"))
Q:'$L(ICDSRLEX) "^" S X=ICDSRLSO_"^"_ICDSRLEX
Q X
;
; Miscellaneous
CL ; Clear
K ICDSRLIT
Q
PR(ICDSRL,X) ; Parse Array
N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,ICDSRLC,ICDSRLI,ICDSRLL
K ^UTILITY($J,"W") Q:'$D(ICDSRL) S ICDSRLL=+($G(X)) S:+ICDSRLL'>0 ICDSRLL=79
S ICDSRLC=+($G(ICDSRL)) S:+($G(ICDSRLC))'>0 ICDSRLC=$O(ICDSRL(" "),-1) Q:+ICDSRLC'>0
S DIWL=1,DIWF="C"_+ICDSRLL S ICDSRLI=0
F S ICDSRLI=$O(ICDSRL(ICDSRLI)) Q:+ICDSRLI=0 S X=$G(ICDSRL(ICDSRLI)) D ^DIWP
K ICDSRL S (ICDSRLC,ICDSRLI)=0
F S ICDSRLI=$O(^UTILITY($J,"W",1,ICDSRLI)) Q:+ICDSRLI=0 D
. S ICDSRL(ICDSRLI)=$$TM($G(^UTILITY($J,"W",1,ICDSRLI,0))," "),ICDSRLC=ICDSRLC+1
S:$L(ICDSRLC) ICDSRL=ICDSRLC K ^UTILITY($J,"W")
Q
TM(X,Y) ; Trim Character Y - Default " "
S X=$G(X) Q:X="" X 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[HDGICPL 6229 printed Oct 16, 2024@18:44:34 Page 2
DGICPL ;ALB/KUM - Select ICD PROCEDURE FROM A LEXICON UTILITY LIST ;12/07/2011
+1 ;;5.3;Registration;**850**;Aug 13, 1993;Build 171
+2 ;
+3 ;
SEL(ICDSRL,X) ; Select from List
+1 ;
+2 ; Input
+3 ;
+4 ; X Length of list to display (default 5)
+5 ; .ICDSRL Local array passed by reference
+6 ;
+7 ; ICDSRL() Input Array from ICDSRCH^LEX10CS
+8 ;
+9 ; ICDSRL(0)=# found ^ Pruning Indicator
+10 ; ICDSRL(1,0)=Code ^ Code IEN ^ date
+11 ; ICDSRL(1,"IDL")=ICD-9/10 Description, Long
+12 ; ICDSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
+13 ; ICDSRL(1,"IDS")=ICD-9/10 Description, Short
+14 ; ICDSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
+15 ; ICDSRL(1,"LEX")=Lexicon Description
+16 ; ICDSRL(1,"LEX",1)=Expression IEN ^ date
+17 ; ICDSRL(1,"SYN",1)=Synonym #1
+18 ; ICDSRL(1,"SYN",m)=Synonym #m
+19 ; ...
+20 ;
+21 ; Output
+22 ;
+23 ; $$SEL Two Piece "^" delimited string same as
+24 ; Fileman's Y output variable
+25 ;
+26 ; 1 Lexicon IEN
+27 ; 2 Lexicon Term
+28 ;
+29 ; ICDSRL Local array passed by reference
+30 ;
+31 ; ICDSRL(0)=Code ^ Code IEN ^ date
+32 ; ICDSRL("IDL")=ICD-9/10 Description, Long
+33 ; ICDSRL("IDL",1)=ICD-9/10 IEN ^ date
+34 ; ICDSRL("IDS")=ICD-9/10 Description, Short
+35 ; ICDSRL("IDS",1)=ICD-9/10 IEN ^ date
+36 ; ICDSRL("LEX")=Lexicon Description
+37 ; ICDSRL("LEX",1)=Expression IEN ^ date
+38 ;
+39 ; or ^ on error
+40 ; or -1 for non-selection
+41 ;
+42 SET X=+($GET(X))
if X'>0
SET X=5
SET X=$$ASK(.ICDSRL,X)
+43 QUIT X
ASK(ICDSRL,X) ; Ask for Selection
+1 KILL X
NEW ICDSRLIT,ICDSRLL,ICDSRTOT
SET ICDSRLL=+($GET(X))
if ICDSRLL'>0
SET ICDSRLL=5
+2 SET ICDSRLIT=0
SET ICDSRTOT=$ORDER(ICDSRL(" "),-1)
if +ICDSRTOT'>0
QUIT "^"
+3 KILL X
if +ICDSRTOT=1
SET X=$$ONE(ICDSRLL,.ICDSRL)
if +ICDSRTOT>1
SET X=$$MUL(.ICDSRL,ICDSRLL)
+4 QUIT X
ONE(X,ICDSRL) ; One Entry Found
+1 if +($GET(ICDSRLIT))>0
QUIT "^^"
NEW DIR,DTOUT,ICDSRLC,ICDSRLEX,ICDSRLFI,ICDSRLIT,ICDSRLSO
+2 NEW ICDSRLSP,ICDSRLTX,Y
+3 SET ICDSRLFI=$ORDER(ICDSRL(0))
if +ICDSRLFI'>0
QUIT "^"
SET ICDSRLSP=$JUSTIFY(" ",25)
+4 SET ICDSRLSO=$PIECE(ICDSRL(1,0),"^",1)
SET ICDSRLEX=$GET(ICDSRL(1,"LEX"))
+5 SET ICDSRLTX(1)=ICDSRLSO_$JUSTIFY(" ",(9-$LENGTH(ICDSRLSO)))_" "_ICDSRLEX
+6 DO PR(.ICDSRLTX,64)
SET DIR("A",1)=" One code found for character "_($LENGTH($GET(ICDPRC))+1)_"."
SET DIR("A",2)=" "
+7 SET DIR("A",3)=" "_$GET(ICDSRLTX(1))
SET ICDSRLC=3
IF $LENGTH($GET(ICDSRLTX(2)))
Begin DoDot:1
+8 SET ICDSRLC=ICDSRLC+1
SET DIR("A",ICDSRLC)=ICDSRLSP_$GET(ICDSRLTX(2))
End DoDot:1
+9 SET ICDSRLC=ICDSRLC+1
SET DIR("A",ICDSRLC)=" "
SET ICDSRLC=ICDSRLC+1
+10 SET DIR("A")=" OK? (Yes/No) "
SET DIR("B")="Yes"
SET DIR(0)="YAO"
WRITE !
+11 DO ^DIR
if X["^^"!($DATA(DTOUT))
SET ICDSRLIT=1
+12 IF X["^^"!(+($GET(ICDSRLIT))>0)
KILL ICDSRL
QUIT "^^"
+13 SET X=$SELECT(+Y>0:$$X(1,.ICDSRL),1:-1)
+14 QUIT X
MUL(ICDSRL,Y) ; Multiple Entries Found
+1 if +($GET(ICDSRLIT))>0
QUIT "^^"
NEW ICDSRLE,ICDSRLL,ICDSRMAX,ICDSRLSS,ICDSRLX,X
+2 SET (ICDSRMAX,ICDSRLSS,ICDSRLIT)=0
SET ICDSRLL=+($GET(Y))
SET U="^"
if +($GET(ICDSRLL))'>0
SET ICDSRLL=5
+3 SET ICDSRLX=$ORDER(ICDSRL(" "),-1)
SET ICDSRLSS=0
+4 if +ICDSRLX=0
GOTO MULQ
WRITE !
if +ICDSRLX>1
WRITE !," ",ICDSRLX," matches found for character ",$LENGTH($GET(ICDPRC))+1,"."
+5 FOR ICDSRLE=1:1:ICDSRLX
if ((ICDSRLSS>0)&(ICDSRLSS<(ICDSRLE+1)))
QUIT
if ICDSRLIT
QUIT
Begin DoDot:1
+6 if ICDSRLE#ICDSRLL=1
WRITE !
DO MULW
+7 SET ICDSRMAX=ICDSRLE
if ICDSRLE#ICDSRLL=0
WRITE !
+8 if ICDSRLE#ICDSRLL=0
SET ICDSRLSS=$$MULS(ICDSRMAX,ICDSRLE,.ICDSRL)
if ICDSRLSS["^"
SET ICDSRLIT=1
End DoDot:1
if ICDSRLIT
QUIT
+9 IF ICDSRLE#ICDSRLL'=0
IF +ICDSRLSS<=0
Begin DoDot:1
+10 WRITE !
SET ICDSRLSS=$$MULS(ICDSRMAX,ICDSRLE,.ICDSRL)
if ICDSRLSS["^"
SET ICDSRLIT=1
End DoDot:1
+11 GOTO MULQ
+12 QUIT X
MULW ; Write Multiple
+1 NEW ICDSRLEX,ICDSRLI,ICDSRLSO,ICDSRLT,ICDSRLTX
SET ICDSRLSO=$PIECE(ICDSRL(+ICDSRLE,0),"^",1)
+2 SET ICDSRLEX=$GET(ICDSRL(+ICDSRLE,"LEX"))
SET ICDSRLTX(1)=ICDSRLSO
+3 SET ICDSRLTX(1)=ICDSRLTX(1)_$JUSTIFY(" ",(9-$LENGTH(ICDSRLSO)))_" "_ICDSRLEX
+4 DO PR(.ICDSRLTX,63)
WRITE !,$JUSTIFY(ICDSRLE,5),". ",$GET(ICDSRLTX(1))
+5 FOR ICDSRLI=2:1:5
SET ICDSRLT=$GET(ICDSRLTX(ICDSRLI))
if $LENGTH(ICDSRLT)
WRITE !,$JUSTIFY(" ",18),ICDSRLT
+6 QUIT
MULS(X,Y,ICDSRL) ; Select from Multiple Entries
+1 NEW DIR,DIRB,DIROUT,DIRUT,DTOUT,DUOUT,ICDSRLFI,ICDSRHLP,ICDSRLAST,ICDSRMAX,ICDSRLS
+2 if +($GET(ICDSRLIT))>0
QUIT "^^"
SET ICDSRMAX=+($GET(X))
SET ICDSRLAST=+($GET(Y))
+3 if ICDSRMAX=0
QUIT -1
SET ICDSRLFI=$ORDER(ICDSRL(0))
if +ICDSRLFI'>0
QUIT -1
+4 IF +($ORDER(ICDSRL(+ICDSRLAST)))>0
Begin DoDot:1
+5 SET DIR("A")=" Press <RETURN> for more, '^' to quit selection, or Select 1-"
+6 SET DIR("A")=DIR("A")_ICDSRMAX_": "
End DoDot:1
+7 IF +($ORDER(ICDSRL(+ICDSRLAST)))'>0
Begin DoDot:1
+8 SET DIR("A")=" Select 1-"_ICDSRMAX_": "
End DoDot:1
+9 SET ICDSRHLP=" Answer must be from 1 to "
+10 SET ICDSRHLP=ICDSRHLP_ICDSRMAX_", or <Return> to continue"
+11 SET DIR("PRE")="S:X[""?"" X=""??"""
+12 SET (DIR("?"),DIR("??"))="^D MULSH^ICDSELPS"
+13 SET DIR(0)="NAO^1:"_ICDSRMAX_":0"
DO ^DIR
+14 IF X["^^"!($DATA(DTOUT))
SET ICDSRLIT=1
SET X="^^"
QUIT "^^"
+15 KILL DIR
if $DATA(DTOUT)!(X[U)
QUIT "^"
+16 QUIT $SELECT(+Y>0:+Y,1:"-1")
MULSH ; Select from Multiple Entries Help
+1 IF $LENGTH($GET(ICDSRHLP))
WRITE !,$GET(ICDSRHLP)
QUIT
+2 QUIT
MULQ ; Quit Multiple Entries Selection
+1 if +($GET(ICDSRLSS))'>0
QUIT -1
SET X=-1
if +($GET(ICDSRLIT))'>0
SET X=$$X(+ICDSRLSS,.ICDSRL)
+2 QUIT X
X(X,ICDSRL) ; Set X and Outpot Array
+1 NEW ICDSRLEX,LEXFI,ICDSRLIEN,ICDSRLN,ICDSRLNC,ICDSRLNN,ICDSRLRN,ICDSRLS,ICDSRLSO
+2 SET ICDSRLS=+($GET(X))
SET LEXFI=$ORDER(LEX(0))
+3 SET ICDSRLSO=$PIECE($GET(ICDSRL(ICDSRLS,0)),"^",1)
+4 SET ICDSRLEX=$GET(ICDSRL(ICDSRLS,"LEX"))
+5 if '$LENGTH(ICDSRLEX)
QUIT "^"
SET X=ICDSRLSO_"^"_ICDSRLEX
+6 QUIT X
+7 ;
+8 ; Miscellaneous
CL ; Clear
+1 KILL ICDSRLIT
+2 QUIT
PR(ICDSRL,X) ; Parse Array
+1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,ICDSRLC,ICDSRLI,ICDSRLL
+2 KILL ^UTILITY($JOB,"W")
if '$DATA(ICDSRL)
QUIT
SET ICDSRLL=+($GET(X))
if +ICDSRLL'>0
SET ICDSRLL=79
+3 SET ICDSRLC=+($GET(ICDSRL))
if +($GET(ICDSRLC))'>0
SET ICDSRLC=$ORDER(ICDSRL(" "),-1)
if +ICDSRLC'>0
QUIT
+4 SET DIWL=1
SET DIWF="C"_+ICDSRLL
SET ICDSRLI=0
+5 FOR
SET ICDSRLI=$ORDER(ICDSRL(ICDSRLI))
if +ICDSRLI=0
QUIT
SET X=$GET(ICDSRL(ICDSRLI))
DO ^DIWP
+6 KILL ICDSRL
SET (ICDSRLC,ICDSRLI)=0
+7 FOR
SET ICDSRLI=$ORDER(^UTILITY($JOB,"W",1,ICDSRLI))
if +ICDSRLI=0
QUIT
Begin DoDot:1
+8 SET ICDSRL(ICDSRLI)=$$TM($GET(^UTILITY($JOB,"W",1,ICDSRLI,0))," ")
SET ICDSRLC=ICDSRLC+1
End DoDot:1
+9 if $LENGTH(ICDSRLC)
SET ICDSRL=ICDSRLC
KILL ^UTILITY($JOB,"W")
+10 QUIT
TM(X,Y) ; Trim Character Y - Default " "
+1 SET X=$GET(X)
if X=""
QUIT X
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
