- 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 Jan 18, 2025@03:32: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