PXSELDS ;ALB/RBD - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST ; 19 Mar 2013 10:43 AM
;;1.0;PCE PATIENT CARE ENCOUNTER;**199**;Aug 12, 1996;Build 51
;
; Copied from SROICDL and customized for PCE
;
SEL(PXSRL,X) ; Select from List
;
;
; Input
;
; X Length of list to display (default 5)
; .PXSRL Local array passed by reference
;
; PXSRL() Input Array from ICDSRCH^LEX10CS
;
; PXSRL(0)=# found ^ Pruning Indicator
; PXSRL(1,0)=Code ^ Code IEN ^ date
; PXSRL(1,"IDL")=ICD-9/10 Description, Long
; PXSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
; PXSRL(1,"IDS")=ICD-9/10 Description, Short
; PXSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
; PXSRL(1,"LEX")=Lexicon Description
; PXSRL(1,"LEX",1)=Expression IEN ^ date
; PXSRL(1,"SYN",1)=Synonym #1
; PXSRL(1,"SYN",m)=Synonym #m
; ...
;
; Output
;
; $$SEL Two Piece "^" delimited string same as
; Fileman's Y output variable
;
; 1 Lexicon IEN
; 2 Lexicon Term
;
; PXSRL Local array passed by reference
;
; PXSRL(0)=Code ^ Code IEN ^ date
; PXSRL("IDL")=ICD-9/10 Description, Long
; PXSRL("IDL",1)=ICD-9/10 IEN ^ date
; PXSRL("IDS")=ICD-9/10 Description, Short
; PXSRL("IDS",1)=ICD-9/10 IEN ^ date
; PXSRL("LEX")=Lexicon Description
; PXSRL("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(.PXSRL,X)
Q X
ASK(PXSRL,X) ; Ask for Selection
N PXSRLIT,PXSRLL,PXSRLTOT S PXSRLL=+($G(X)) S:PXSRLL'>0 PXSRLL=5
S PXSRLIT=0,PXSRLTOT=$O(PXSRL(" "),-1) Q:+PXSRLTOT'>0 "^"
K X S:+PXSRLTOT=1 X=$$ONE(PXSRLL,.PXSRL) S:+PXSRLTOT>1 X=$$MUL(.PXSRL,PXSRLL)
I "D@"[X Q "@" ; user wants to delete the existing entry
S:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(X))'>0) X=-1
Q X
ONE(X,PXSRL) ; One Entry Found
Q:+($G(PXSRLIT))>0 "^^"
N DIR,PXNXTLIN,PXSRLC,PXSRLEX,PXSRLFI,PXSRLIT,PXSRLNC,PXSRLSO,PXSRLSP,PXSRLTX,Y
S PXSRLFI=$O(PXSRL(0)) Q:+PXSRLFI'>0 "^" S PXSRLSP=$J(" ",11)
S PXSRLSO=$P(PXSRL(1,0),"^",1),PXSRLNC=$P(PXSRL(1,0),"^",3)
S:+PXSRLNC>0 PXSRLNC=" ("_PXSRLNC_")" S PXSRLEX=$G(PXSRL(1,"MENU"))
S PXSRLC=$S($D(PXSRL(1,"CAT")):"-",1:"")
S PXSRLTX(1)=PXSRLSO_PXSRLC_$J(" ",(9-$L(PXSRLSO)))_" "_PXSRLEX_PXSRLNC
D PR(.PXSRLTX,64) S DIR("A",1)=" One code found",DIR("A",2)=" "
S DIR("A",3)=" "_$G(PXSRLTX(1)),PXSRLC=3 I $L($G(PXSRLTX(2))) D
. F PXNXTLIN=2:1 Q:$G(PXSRLTX(PXNXTLIN))="" D
.. S PXSRLC=PXSRLC+1,DIR("A",PXSRLC)=PXSRLSP_$G(PXSRLTX(PXNXTLIN))
S PXSRLC=PXSRLC+1,DIR("A",PXSRLC)=" ",PXSRLC=PXSRLC+1
D SET1:$D(PXDEF),SET2:'$D(PXDEF)
D ^DIR S Y=Y="Y"
I X'="","Dd@"[X Q "@" ; user wants to delete the existing entry
Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&((+$G(Y))'>0) -1
S:X["^^"!($D(DTOUT)) PXSRLIT=1
I X["^^"!(+($G(PXSRLIT))>0) K PXSRL Q "^^"
S X=$S(+Y>0:$$X(1,.PXSRL),1:-1)
Q X
MUL(PXSRL,Y) ; Multiple Entries Found
Q:+($G(PXSRLIT))>0 "^^" N PXSRLE,PXSRLL,PXSRLMAX,PXSRLSS,PXSRLX,X
S (PXSRLMAX,PXSRLSS,PXSRLIT)=0,PXSRLL=+($G(Y)),U="^" S:+($G(PXSRLL))'>0 PXSRLL=5
S PXSRLX=$O(PXSRL(" "),-1),PXSRLSS=0
G:+PXSRLX=0 MULQ W ! W:+PXSRLX>1 !," ",PXSRLX," matches found"
F PXSRLE=1:1:PXSRLX Q:((PXSRLSS>0)&(PXSRLSS<(PXSRLE+1))) Q:PXSRLIT D Q:PXSRLIT
. W:PXSRLE#PXSRLL=1 ! D MULW
. S PXSRLMAX=PXSRLE W:PXSRLE#PXSRLL=0 !
. S:PXSRLE#PXSRLL=0 PXSRLSS=$$MULS(PXSRLMAX,PXSRLE,.PXSRL) S:PXSRLSS["^" PXSRLIT=1
I PXSRLE#PXSRLL'=0,+PXSRLSS<=0 D
. W ! S PXSRLSS=$$MULS(PXSRLMAX,PXSRLE,.PXSRL) S:PXSRLSS["^" PXSRLIT=1
G MULQ
Q X
MULW ; Write Multiple
N PXSRLEX,PXSRLI,PXSRLSO,PXSRLNC,PXSRLT,PXSRLTX S PXSRLSO=$P(PXSRL(+PXSRLE,0),"^",1)
S PXSRLNC=$P(PXSRL(+PXSRLE,0),"^",3) S:+PXSRLNC>0 PXSRLNC=" ("_PXSRLNC_")"
S PXSRLEX=$G(PXSRL(+PXSRLE,"MENU")),PXSRLTX(1)=PXSRLSO
S PXSRLTX(1)=PXSRLTX(1)_$S($D(PXSRL(+PXSRLE,"CAT")):"-",1:" ")_$J(" ",(9-$L(PXSRLSO)))_" "_PXSRLEX_PXSRLNC
D PR(.PXSRLTX,60) W !,$J(PXSRLE,5),". ",$G(PXSRLTX(1))
F PXSRLI=2:1:5 S PXSRLT=$G(PXSRLTX(PXSRLI)) W:$L(PXSRLT) !,$J(" ",19),PXSRLT
Q
MULS(X,Y,PXSRL) ; Select from Multiple Entries
N DIR,DIRB,PXSRLFI,PXSRLHLP,PXSLLAST,PXSRLMAX,PXSRLS
Q:+($G(PXSRLIT))>0 "^^" S PXSRLMAX=+($G(X)),PXSLLAST=+($G(Y))
Q:PXSRLMAX=0 -1 S PXSRLFI=$O(PXSRL(0)) Q:+PXSRLFI'>0 -1
I +($O(PXSRL(+PXSLLAST)))>0 D
. S DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
. S DIR("A")=DIR("A")_PXSRLMAX_": "
I +($O(PXSRL(+PXSLLAST)))'>0 D
. S DIR("A")=" Select 1-"_PXSRLMAX_": "
S PXSRLHLP=" Answer must be from 1 to "
S PXSRLHLP=PXSRLHLP_PXSRLMAX_", or <Return> to continue"
S DIR("PRE")="S:X[""?"" X=""??"""
S (DIR("?"),DIR("??"))="^D MULSH^PXSELDS"
S DIR(0)="NAO^1:"_PXSRLMAX_":0" D ^DIR
Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
S:X["^^"!($D(DTOUT)) PXSRLIT=1,X="^^" I X["^^"!(+($G(PXSRLIT))>0) Q "^^"
K DIR Q:$D(DTOUT)!(X[U) "^^"
Q $S(+Y>0:+Y,1:"-1")
MULSH ; Select from Multiple Entries Help
I $L($G(PXSRLHLP)) W !,$G(PXSRLHLP) Q
Q
MULQ ; Quit Multiple
I +PXSRLSS'>0,$G(PXSRLSS)="^" Q "^"
S X=-1 S:+($G(PXSRLIT))'>0 X=$$X(+PXSRLSS,.PXSRL)
Q X
X(X,PXSRL) ; Set X and Output Array
N PXSRLEX,PXSRFI,PXSRLIEN,PXSRLN,PXSRLNC,PXSRLNN,PXSRLRN,PXSRLS,PXSRLSO
S PXSRLS=+($G(X)) S PXSRFI=$O(PXSRL(0))
S PXSRLSO=$P($G(PXSRL(PXSRLS,0)),"^",1),PXSRLEX=$G(PXSRL(PXSRLS,"MENU"))
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) "^"
Q:'$L(PXSRLEX) "^" Q:+PXSRLIEN'>0 "^" S X=PXSRLIEN_"^"_PXSRLEX
S PXSRLNN="PXSRL("_+PXSRLS_")",PXSRLNC="PXSRL("_+PXSRLS_","
F S PXSRLNN=$Q(@PXSRLNN) Q:'$L(PXSRLNN)!(PXSRLNN'[PXSRLNC) D
. S PXSRLRN="PXSRLN("_$P(PXSRLNN,"(",2,299) S @PXSRLRN=@PXSRLNN
K PXSRL S PXSRLNN="PXSRLN("_+PXSRLS_")",PXSRLNC="PXSRLN("_+PXSRLS_","
F S PXSRLNN=$Q(@PXSRLNN) Q:'$L(PXSRLNN)!(PXSRLNN'[PXSRLNC) D
. S PXSRLRN="PXSRL("_$P(PXSRLNN,"(",2,299),@PXSRLRN=@PXSRLNN
Q X
;
; Miscellaneous
CL ; Clear
K PXSRLIT
Q
;
PR(PXSRL,X) ; Parse Array
N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,%D,PXSRLC,PXSRLI,PXSRLL
K ^UTILITY($J,"W") Q:'$D(PXSRL) S PXSRLL=+($G(X)) S:+PXSRLL'>0 PXSRLL=79
S PXSRLC=+($G(PXSRL)) S:+($G(PXSRLC))'>0 PXSRLC=$O(PXSRL(" "),-1) Q:+PXSRLC'>0
S DIWL=1,DIWF="C"_+PXSRLL S PXSRLI=0
F S PXSRLI=$O(PXSRL(PXSRLI)) Q:+PXSRLI=0 S X=$G(PXSRL(PXSRLI)) D ^DIWP
K PXSRL S (PXSRLC,PXSRLI)=0
F S PXSRLI=$O(^UTILITY($J,"W",1,PXSRLI)) Q:+PXSRLI=0 D
. S PXSRL(PXSRLI)=$$TM($G(^UTILITY($J,"W",1,PXSRLI,0))," "),PXSRLC=PXSRLC+1
S:$L(PXSRLC) PXSRL=PXSRLC 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
;
SET1 ; Use this if a default ICD-10 code was supplied
S DIR("A")="OK? ",DIR("B")="YES",DIR(0)="SAOB^Y:Yes;N:No;D:Delete;@:Delete"
S DIR("L",1)=" Y - Yes | @ - Delete"
S DIR("L",2)=" N - No | ? - Help"
S DIR("L",3)=" D - Delete | ?? - Extra Help"
S DIR("L")=" | ^ - Exit"
Q
;
SET2 ; Use this if no default ICD-10 code was supplied
S DIR("A")="OK? ",DIR("B")="YES",DIR(0)="SAOB^Y:Yes;N:No"
S DIR("L",1)=" Y - Yes | ? - Help"
S DIR("L",2)=" N - No | ?? - Extra Help"
S DIR("L")=" | ^ - Exit"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXSELDS 7607 printed Dec 13, 2024@02:31:26 Page 2
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
+2 ;
+3 ; Copied from SROICDL and customized for PCE
+4 ;
SEL(PXSRL,X) ; Select from List
+1 ;
+2 ;
+3 ; Input
+4 ;
+5 ; X Length of list to display (default 5)
+6 ; .PXSRL Local array passed by reference
+7 ;
+8 ; PXSRL() Input Array from ICDSRCH^LEX10CS
+9 ;
+10 ; PXSRL(0)=# found ^ Pruning Indicator
+11 ; PXSRL(1,0)=Code ^ Code IEN ^ date
+12 ; PXSRL(1,"IDL")=ICD-9/10 Description, Long
+13 ; PXSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
+14 ; PXSRL(1,"IDS")=ICD-9/10 Description, Short
+15 ; PXSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
+16 ; PXSRL(1,"LEX")=Lexicon Description
+17 ; PXSRL(1,"LEX",1)=Expression IEN ^ date
+18 ; PXSRL(1,"SYN",1)=Synonym #1
+19 ; PXSRL(1,"SYN",m)=Synonym #m
+20 ; ...
+21 ;
+22 ; Output
+23 ;
+24 ; $$SEL Two Piece "^" delimited string same as
+25 ; Fileman's Y output variable
+26 ;
+27 ; 1 Lexicon IEN
+28 ; 2 Lexicon Term
+29 ;
+30 ; PXSRL Local array passed by reference
+31 ;
+32 ; PXSRL(0)=Code ^ Code IEN ^ date
+33 ; PXSRL("IDL")=ICD-9/10 Description, Long
+34 ; PXSRL("IDL",1)=ICD-9/10 IEN ^ date
+35 ; PXSRL("IDS")=ICD-9/10 Description, Short
+36 ; PXSRL("IDS",1)=ICD-9/10 IEN ^ date
+37 ; PXSRL("LEX")=Lexicon Description
+38 ; PXSRL("LEX",1)=Expression IEN ^ date
+39 ;
+40 ; or ^ on error
+41 ; or -1 for non-selection
+42 ;
+43 SET X=+($GET(X))
if X'>0
SET X=5
SET X=$$ASK(.PXSRL,X)
+44 QUIT X
ASK(PXSRL,X) ; Ask for Selection
+1 NEW PXSRLIT,PXSRLL,PXSRLTOT
SET PXSRLL=+($GET(X))
if PXSRLL'>0
SET PXSRLL=5
+2 SET PXSRLIT=0
SET PXSRLTOT=$ORDER(PXSRL(" "),-1)
if +PXSRLTOT'>0
QUIT "^"
+3 KILL X
if +PXSRLTOT=1
SET X=$$ONE(PXSRLL,.PXSRL)
if +PXSRLTOT>1
SET X=$$MUL(.PXSRL,PXSRLL)
+4 ; user wants to delete the existing entry
IF "D@"[X
QUIT "@"
+5 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(X))'>0)
SET X=-1
+6 QUIT X
ONE(X,PXSRL) ; One Entry Found
+1 if +($GET(PXSRLIT))>0
QUIT "^^"
+2 NEW DIR,PXNXTLIN,PXSRLC,PXSRLEX,PXSRLFI,PXSRLIT,PXSRLNC,PXSRLSO,PXSRLSP,PXSRLTX,Y
+3 SET PXSRLFI=$ORDER(PXSRL(0))
if +PXSRLFI'>0
QUIT "^"
SET PXSRLSP=$JUSTIFY(" ",11)
+4 SET PXSRLSO=$PIECE(PXSRL(1,0),"^",1)
SET PXSRLNC=$PIECE(PXSRL(1,0),"^",3)
+5 if +PXSRLNC>0
SET PXSRLNC=" ("_PXSRLNC_")"
SET PXSRLEX=$GET(PXSRL(1,"MENU"))
+6 SET PXSRLC=$SELECT($DATA(PXSRL(1,"CAT")):"-",1:"")
+7 SET PXSRLTX(1)=PXSRLSO_PXSRLC_$JUSTIFY(" ",(9-$LENGTH(PXSRLSO)))_" "_PXSRLEX_PXSRLNC
+8 DO PR(.PXSRLTX,64)
SET DIR("A",1)=" One code found"
SET DIR("A",2)=" "
+9 SET DIR("A",3)=" "_$GET(PXSRLTX(1))
SET PXSRLC=3
IF $LENGTH($GET(PXSRLTX(2)))
Begin DoDot:1
+10 FOR PXNXTLIN=2:1
if $GET(PXSRLTX(PXNXTLIN))=""
QUIT
Begin DoDot:2
+11 SET PXSRLC=PXSRLC+1
SET DIR("A",PXSRLC)=PXSRLSP_$GET(PXSRLTX(PXNXTLIN))
End DoDot:2
End DoDot:1
+12 SET PXSRLC=PXSRLC+1
SET DIR("A",PXSRLC)=" "
SET PXSRLC=PXSRLC+1
+13 if $DATA(PXDEF)
DO SET1
if '$DATA(PXDEF)
DO SET2
+14 DO ^DIR
SET Y=Y="Y"
+15 ; user wants to delete the existing entry
IF X'=""
IF "Dd@"[X
QUIT "@"
+16 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&((+$GET(Y))'>0)
QUIT -1
+17 if X["^^"!($DATA(DTOUT))
SET PXSRLIT=1
+18 IF X["^^"!(+($GET(PXSRLIT))>0)
KILL PXSRL
QUIT "^^"
+19 SET X=$SELECT(+Y>0:$$X(1,.PXSRL),1:-1)
+20 QUIT X
MUL(PXSRL,Y) ; Multiple Entries Found
+1 if +($GET(PXSRLIT))>0
QUIT "^^"
NEW PXSRLE,PXSRLL,PXSRLMAX,PXSRLSS,PXSRLX,X
+2 SET (PXSRLMAX,PXSRLSS,PXSRLIT)=0
SET PXSRLL=+($GET(Y))
SET U="^"
if +($GET(PXSRLL))'>0
SET PXSRLL=5
+3 SET PXSRLX=$ORDER(PXSRL(" "),-1)
SET PXSRLSS=0
+4 if +PXSRLX=0
GOTO MULQ
WRITE !
if +PXSRLX>1
WRITE !," ",PXSRLX," matches found"
+5 FOR PXSRLE=1:1:PXSRLX
if ((PXSRLSS>0)&(PXSRLSS<(PXSRLE+1)))
QUIT
if PXSRLIT
QUIT
Begin DoDot:1
+6 if PXSRLE#PXSRLL=1
WRITE !
DO MULW
+7 SET PXSRLMAX=PXSRLE
if PXSRLE#PXSRLL=0
WRITE !
+8 if PXSRLE#PXSRLL=0
SET PXSRLSS=$$MULS(PXSRLMAX,PXSRLE,.PXSRL)
if PXSRLSS["^"
SET PXSRLIT=1
End DoDot:1
if PXSRLIT
QUIT
+9 IF PXSRLE#PXSRLL'=0
IF +PXSRLSS<=0
Begin DoDot:1
+10 WRITE !
SET PXSRLSS=$$MULS(PXSRLMAX,PXSRLE,.PXSRL)
if PXSRLSS["^"
SET PXSRLIT=1
End DoDot:1
+11 GOTO MULQ
+12 QUIT X
MULW ; Write Multiple
+1 NEW PXSRLEX,PXSRLI,PXSRLSO,PXSRLNC,PXSRLT,PXSRLTX
SET PXSRLSO=$PIECE(PXSRL(+PXSRLE,0),"^",1)
+2 SET PXSRLNC=$PIECE(PXSRL(+PXSRLE,0),"^",3)
if +PXSRLNC>0
SET PXSRLNC=" ("_PXSRLNC_")"
+3 SET PXSRLEX=$GET(PXSRL(+PXSRLE,"MENU"))
SET PXSRLTX(1)=PXSRLSO
+4 SET PXSRLTX(1)=PXSRLTX(1)_$SELECT($DATA(PXSRL(+PXSRLE,"CAT")):"-",1:" ")_$JUSTIFY(" ",(9-$LENGTH(PXSRLSO)))_" "_PXSRLEX_PXSRLNC
+5 DO PR(.PXSRLTX,60)
WRITE !,$JUSTIFY(PXSRLE,5),". ",$GET(PXSRLTX(1))
+6 FOR PXSRLI=2:1:5
SET PXSRLT=$GET(PXSRLTX(PXSRLI))
if $LENGTH(PXSRLT)
WRITE !,$JUSTIFY(" ",19),PXSRLT
+7 QUIT
MULS(X,Y,PXSRL) ; Select from Multiple Entries
+1 NEW DIR,DIRB,PXSRLFI,PXSRLHLP,PXSLLAST,PXSRLMAX,PXSRLS
+2 if +($GET(PXSRLIT))>0
QUIT "^^"
SET PXSRLMAX=+($GET(X))
SET PXSLLAST=+($GET(Y))
+3 if PXSRLMAX=0
QUIT -1
SET PXSRLFI=$ORDER(PXSRL(0))
if +PXSRLFI'>0
QUIT -1
+4 IF +($ORDER(PXSRL(+PXSLLAST)))>0
Begin DoDot:1
+5 SET DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
+6 SET DIR("A")=DIR("A")_PXSRLMAX_": "
End DoDot:1
+7 IF +($ORDER(PXSRL(+PXSLLAST)))'>0
Begin DoDot:1
+8 SET DIR("A")=" Select 1-"_PXSRLMAX_": "
End DoDot:1
+9 SET PXSRLHLP=" Answer must be from 1 to "
+10 SET PXSRLHLP=PXSRLHLP_PXSRLMAX_", or <Return> to continue"
+11 SET DIR("PRE")="S:X[""?"" X=""??"""
+12 SET (DIR("?"),DIR("??"))="^D MULSH^PXSELDS"
+13 SET DIR(0)="NAO^1:"_PXSRLMAX_":0"
DO ^DIR
+14 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
QUIT -1
+15 if X["^^"!($DATA(DTOUT))
SET PXSRLIT=1
SET X="^^"
IF X["^^"!(+($GET(PXSRLIT))>0)
QUIT "^^"
+16 KILL DIR
if $DATA(DTOUT)!(X[U)
QUIT "^^"
+17 QUIT $SELECT(+Y>0:+Y,1:"-1")
MULSH ; Select from Multiple Entries Help
+1 IF $LENGTH($GET(PXSRLHLP))
WRITE !,$GET(PXSRLHLP)
QUIT
+2 QUIT
MULQ ; Quit Multiple
+1 IF +PXSRLSS'>0
IF $GET(PXSRLSS)="^"
QUIT "^"
+2 SET X=-1
if +($GET(PXSRLIT))'>0
SET X=$$X(+PXSRLSS,.PXSRL)
+3 QUIT X
X(X,PXSRL) ; Set X and Output Array
+1 NEW PXSRLEX,PXSRFI,PXSRLIEN,PXSRLN,PXSRLNC,PXSRLNN,PXSRLRN,PXSRLS,PXSRLSO
+2 SET PXSRLS=+($GET(X))
SET PXSRFI=$ORDER(PXSRL(0))
+3 SET PXSRLSO=$PIECE($GET(PXSRL(PXSRLS,0)),"^",1)
SET PXSRLEX=$GET(PXSRL(PXSRLS,"MENU"))
+4 SET PXSRLIEN=$SELECT($DATA(PXSRL(PXSRLS,"CAT")):"99:CAT;"_$PIECE($GET(PXSRL(PXSRLS,0)),"^"),1:$PIECE($GET(PXSRL(PXSRLS,"LEX",1)),"^")_";"_$PIECE($GET(PXSRL(PXSRLS,0)),"^"))
if '$LENGTH(PXSRLSO)
QUIT "^"
+5 if '$LENGTH(PXSRLEX)
QUIT "^"
if +PXSRLIEN'>0
QUIT "^"
SET X=PXSRLIEN_"^"_PXSRLEX
+6 SET PXSRLNN="PXSRL("_+PXSRLS_")"
SET PXSRLNC="PXSRL("_+PXSRLS_","
+7 FOR
SET PXSRLNN=$QUERY(@PXSRLNN)
if '$LENGTH(PXSRLNN)!(PXSRLNN'[PXSRLNC)
QUIT
Begin DoDot:1
+8 SET PXSRLRN="PXSRLN("_$PIECE(PXSRLNN,"(",2,299)
SET @PXSRLRN=@PXSRLNN
End DoDot:1
+9 KILL PXSRL
SET PXSRLNN="PXSRLN("_+PXSRLS_")"
SET PXSRLNC="PXSRLN("_+PXSRLS_","
+10 FOR
SET PXSRLNN=$QUERY(@PXSRLNN)
if '$LENGTH(PXSRLNN)!(PXSRLNN'[PXSRLNC)
QUIT
Begin DoDot:1
+11 SET PXSRLRN="PXSRL("_$PIECE(PXSRLNN,"(",2,299)
SET @PXSRLRN=@PXSRLNN
End DoDot:1
+12 QUIT X
+13 ;
+14 ; Miscellaneous
CL ; Clear
+1 KILL PXSRLIT
+2 QUIT
+3 ;
PR(PXSRL,X) ; Parse Array
+1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,%D,PXSRLC,PXSRLI,PXSRLL
+2 KILL ^UTILITY($JOB,"W")
if '$DATA(PXSRL)
QUIT
SET PXSRLL=+($GET(X))
if +PXSRLL'>0
SET PXSRLL=79
+3 SET PXSRLC=+($GET(PXSRL))
if +($GET(PXSRLC))'>0
SET PXSRLC=$ORDER(PXSRL(" "),-1)
if +PXSRLC'>0
QUIT
+4 SET DIWL=1
SET DIWF="C"_+PXSRLL
SET PXSRLI=0
+5 FOR
SET PXSRLI=$ORDER(PXSRL(PXSRLI))
if +PXSRLI=0
QUIT
SET X=$GET(PXSRL(PXSRLI))
DO ^DIWP
+6 KILL PXSRL
SET (PXSRLC,PXSRLI)=0
+7 FOR
SET PXSRLI=$ORDER(^UTILITY($JOB,"W",1,PXSRLI))
if +PXSRLI=0
QUIT
Begin DoDot:1
+8 SET PXSRL(PXSRLI)=$$TM($GET(^UTILITY($JOB,"W",1,PXSRLI,0))," ")
SET PXSRLC=PXSRLC+1
End DoDot:1
+9 if $LENGTH(PXSRLC)
SET PXSRL=PXSRLC
KILL ^UTILITY($JOB,"W")
+10 QUIT
+11 ;
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
+5 ;
SET1 ; Use this if a default ICD-10 code was supplied
+1 SET DIR("A")="OK? "
SET DIR("B")="YES"
SET DIR(0)="SAOB^Y:Yes;N:No;D:Delete;@:Delete"
+2 SET DIR("L",1)=" Y - Yes | @ - Delete"
+3 SET DIR("L",2)=" N - No | ? - Help"
+4 SET DIR("L",3)=" D - Delete | ?? - Extra Help"
+5 SET DIR("L")=" | ^ - Exit"
+6 QUIT
+7 ;
SET2 ; Use this if no default ICD-10 code was supplied
+1 SET DIR("A")="OK? "
SET DIR("B")="YES"
SET DIR(0)="SAOB^Y:Yes;N:No"
+2 SET DIR("L",1)=" Y - Yes | ? - Help"
+3 SET DIR("L",2)=" N - No | ?? - Extra Help"
+4 SET DIR("L")=" | ^ - Exit"
+5 QUIT
