- ICDSELDS ;ALB/SJA/SS/KUM - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST ;12/07/2011
- ;;18.0;DRG Grouper;**64,94**;Oct 20, 2000;Build 5
- ;
- ;
- ;
- ; 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
- ; or -2 if "^" was entered
- ;
- SEL(ICDSRL,X) ; Select from List
- N ICDGOUP S ICDGOUP=0
- S X=+($G(X))
- S:X'>0 X=5
- S X=$$ASK(.ICDSRL,X)
- I ICDGOUP=1 Q -2
- Q X
- ;
- ASK(ICDSRL,X) ; Ask for Selection
- N DTOUT,DUOUT,DIROUT
- N ICDLIT,ICDLL,ICDLTOT
- S ICDLL=+($G(X))
- S:ICDLL'>0 ICDLL=5
- S ICDLIT=0,ICDLTOT=$O(ICDSRL(" "),-1)
- Q:+ICDLTOT'>0 "^"
- K X
- S:+ICDLTOT=1 X=$$ONE(ICDLL,.ICDSRL)
- S:+ICDLTOT>1 X=$$MUL(.ICDSRL,ICDLL)
- S:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(X))'>0) X=-1
- Q X
- ONE(X,ICDSRL) ; One Entry Found
- Q:+($G(ICDLIT))>0 "^^"
- N DIR,ICDLC,ICDLEX,ICDLFI,ICDLIT,ICDLSO,ICDLNC
- N ICDLSP,ICDLTX,ICDLC,Y,ICDCNT1
- S ICDLFI=$O(ICDSRL(0)) Q:+ICDLFI'>0 "^" S ICDLSP=$J(" ",11)
- S ICDLSO=$P(ICDSRL(1,0),"^",1),ICDLNC=$P(ICDSRL(1,0),"^",3)
- S:+ICDLNC>0 ICDLNC=" ("_ICDLNC_")" S ICDLEX=$G(ICDSRL(1,"MENU"))
- S ICDLC=$S($D(ICDSRL(1,"CAT")):"-",1:"")
- S ICDLTX(1)=ICDLSO_ICDLC_$J(" ",(9-$L(ICDLSO)))_" "_ICDLEX_ICDLNC
- D PR(.ICDLTX,64) S DIR("A",1)=" One match found",DIR("A",2)=" "
- S DIR("A",3)=" "_$G(ICDLTX(1))
- S ICDLC=3
- F ICDCNT1=2:1 Q:$G(ICDLTX(ICDCNT1))="" S ICDLC=ICDLC+1,DIR("A",ICDLC)=ICDLSP_$G(ICDLTX(ICDCNT1))
- S ICDLC=ICDLC+1,DIR("A",ICDLC)=" ",ICDLC=ICDLC+1
- S DIR("A")=" OK? (Yes/No) ",DIR("B")="Yes",DIR(0)="YAO" W !
- D ^DIR Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
- S:X["^^"!($D(DTOUT)) ICDLIT=1
- I X["^^"!(+($G(ICDLIT))>0) K ICDSRL Q "^^"
- S X=$S(+Y>0:$$X(1,.ICDSRL),1:-1)
- Q X
- MUL(ICDSRL,Y) ; Multiple Entries Found
- Q:+($G(ICDLIT))>0 "^^"
- N ICDSRLE,ICDLL,ICDLMAX,ICDLSS,ICDLX,X
- S (ICDLMAX,ICDLSS,ICDLIT)=0,ICDLL=+($G(Y)),U="^" S:+($G(ICDLL))'>0 ICDLL=5
- S ICDLX=$O(ICDSRL(" "),-1),ICDLSS=0
- G:+ICDLX=0 MULQ W ! W:+ICDLX>1 !," ",ICDLX," matches found"
- F ICDSRLE=1:1:ICDLX Q:((ICDLSS>0)&(ICDLSS<(ICDSRLE+1))) Q:ICDLIT D Q:ICDLIT
- . W:ICDSRLE#ICDLL=1 ! D MULW
- . S ICDLMAX=ICDSRLE W:ICDSRLE#ICDLL=0 !
- . S:ICDSRLE#ICDLL=0 ICDLSS=$$MULS(ICDLMAX,ICDSRLE,.ICDSRL) S:ICDLSS["^" ICDLIT=1
- I ICDSRLE#ICDLL'=0,+ICDLSS<=0 D
- . W ! S ICDLSS=$$MULS(ICDLMAX,ICDSRLE,.ICDSRL) S:ICDLSS["^" ICDLIT=1
- G MULQ
- Q X
- MULW ; Write Multiple
- N ICDLEX,ICDLI1,ICDLSO,ICDLNC,ICDLT2,ICDLTX S ICDLSO=$P(ICDSRL(+ICDSRLE,0),"^",1)
- S ICDLNC=$P(ICDSRL(+ICDSRLE,0),"^",3) S:+ICDLNC>0 ICDLNC=" ("_ICDLNC_")"
- S ICDLEX=$G(ICDSRL(+ICDSRLE,"MENU")),ICDLTX(1)=ICDLSO
- S ICDLTX(1)=ICDLTX(1)_$S($D(ICDSRL(+ICDSRLE,"CAT")):"-",1:" ")_$J(" ",(9-$L(ICDLSO)))_" "_ICDLEX_ICDLNC
- D PR(.ICDLTX,60) W !,$J(ICDSRLE,5),". ",$G(ICDLTX(1))
- F ICDLI1=2:1:5 S ICDLT2=$G(ICDLTX(ICDLI1)) W:$L(ICDLT2) !,$J(" ",19),ICDLT2
- Q
- MULS(X,Y,ICDSRL) ; Select from Multiple Entries
- N DIR,DIRB,ICDLFI,ICDLHLP,ICDLLST,ICDLMAX,ICDLS1 ;@#$ not sure ICDLS1 is needed here
- Q:+($G(ICDLIT))>0 "^^" S ICDLMAX=+($G(X)),ICDLLST=+($G(Y))
- Q:ICDLMAX=0 -1 S ICDLFI=$O(ICDSRL(0)) Q:+ICDLFI'>0 -1
- I +($O(ICDSRL(+ICDLLST)))>0 D
- . S DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
- . S DIR("A")=DIR("A")_ICDLMAX_": "
- I +($O(ICDSRL(+ICDLLST)))'>0 D
- . S DIR("A")=" Select 1-"_ICDLMAX_": "
- S ICDLHLP=" Answer must be from 1 to "
- S ICDLHLP=ICDLHLP_ICDLMAX_", or <Return> to continue"
- S DIR("PRE")="S:X[""?"" X=""??"""
- S (DIR("?"),DIR("??"))="^D MULSH^ICDSELDS"
- S DIR(0)="NAO^1:"_ICDLMAX_":0" D ^DIR
- S:X="^" ICDGOUP=1
- Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
- S:X["^^"!($D(DTOUT)) ICDLIT=1,X="^^" I X["^^"!(+($G(ICDLIT))>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(ICDLHLP)) W !,$G(ICDLHLP) Q
- Q
- MULQ ; Quit Multiple
- I +ICDLSS'>0,$G(ICDLSS)="^" Q "^"
- S X=-1 S:+($G(ICDLIT))'>0 X=$$X(+ICDLSS,.ICDSRL)
- Q X
- X(X,ICDSRL) ; Set X and Output Array
- N ICDLEX,ICDSRFI,ICDLIEN,ICDLN1,ICDLNC,ICDLNN,ICDLRN,ICDLS1,ICDLSO
- S ICDLS1=+($G(X))
- S ICDSRFI=$O(ICDSRL(0)) ;@#$ not used?
- S ICDLSO=$P($G(ICDSRL(ICDLS1,0)),"^",1),ICDLEX=$G(ICDSRL(ICDLS1,"MENU"))
- S ICDLIEN=$S($D(ICDSRL(ICDLS1,"CAT")):"99:CAT;"_$P($G(ICDSRL(ICDLS1,0)),"^"),1:$P($G(ICDSRL(ICDLS1,"LEX",1)),"^")_";"_$P($G(ICDSRL(ICDLS1,0)),"^")) Q:'$L(ICDLSO) "^"
- Q:'$L(ICDLEX) "^" Q:+ICDLIEN'>0 "^" S X=ICDLIEN_"^"_ICDLEX
- S ICDLNN="ICDSRL("_+ICDLS1_")",ICDLNC="ICDSRL("_+ICDLS1_","
- F S ICDLNN=$Q(@ICDLNN) Q:'$L(ICDLNN)!(ICDLNN'[ICDLNC) D
- . S ICDLRN="ICDLN1("_$P(ICDLNN,"(",2,299) S @ICDLRN=@ICDLNN
- K ICDSRL S ICDLNN="ICDLN1("_+ICDLS1_")",ICDLNC="ICDLN1("_+ICDLS1_","
- F S ICDLNN=$Q(@ICDLNN) Q:'$L(ICDLNN)!(ICDLNN'[ICDLNC) D
- . S ICDLRN="ICDSRL("_$P(ICDLNN,"(",2,299),@ICDLRN=@ICDLNN
- Q X
- ;
- ; Miscellaneous
- CL ; Clear
- K ICDLIT
- Q
- PR(ICDSRL,X) ; Parse Array
- N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,ICDDN,I,Z,%,%D,ICDLC,ICDLI1,ICDLL
- K ^UTILITY($J,"W")
- Q:'$D(ICDSRL)
- S ICDLL=+($G(X))
- S:+ICDLL'>0 ICDLL=79
- S ICDLC=+($G(ICDSRL))
- S:+($G(ICDLC))'>0 ICDLC=$O(ICDSRL(" "),-1)
- Q:+ICDLC'>0
- S DIWL=1,DIWF="C"_+ICDLL
- S ICDLI1=0
- F S ICDLI1=$O(ICDSRL(ICDLI1)) Q:+ICDLI1=0 S X=$G(ICDSRL(ICDLI1)) D ^DIWP
- K ICDSRL
- S (ICDLC,ICDLI1)=0
- F S ICDLI1=$O(^UTILITY($J,"W",1,ICDLI1)) Q:+ICDLI1=0 D
- . S ICDSRL(ICDLI1)=$$TM($G(^UTILITY($J,"W",1,ICDLI1,0))," "),ICDLC=ICDLC+1
- S:$L(ICDLC) ICDSRL=ICDLC
- K ^UTILITY($J,"W")
- Q
- TM(ICDX,ICDY) ; Trim Character Y - Default " "
- S ICDX=$G(ICDX) Q:ICDX="" ICDX S ICDY=$G(ICDY) S:'$L(ICDY) ICDY=" "
- F Q:$E(ICDX,1)'=ICDY S ICDX=$E(ICDX,2,$L(ICDX))
- F Q:$E(ICDX,$L(ICDX))'=ICDY S ICDX=$E(ICDX,1,($L(ICDX)-1))
- Q ICDX
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDSELDS 7115 printed Dec 13, 2024@01:51:03 Page 2
- ICDSELDS ;ALB/SJA/SS/KUM - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST ;12/07/2011
- +1 ;;18.0;DRG Grouper;**64,94**;Oct 20, 2000;Build 5
- +2 ;
- +3 ;
- +4 ;
- +5 ; Input
- +6 ;
- +7 ; X Length of list to display (default 5)
- +8 ; .ICDSRL Local array passed by reference
- +9 ;
- +10 ; ICDSRL() Input Array from ICDSRCH^LEX10CS
- +11 ;
- +12 ; ICDSRL(0)=# found ^ Pruning Indicator
- +13 ; ICDSRL(1,0)=Code ^ Code IEN ^ date
- +14 ; ICDSRL(1,"IDL")=ICD-9/10 Description, Long
- +15 ; ICDSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
- +16 ; ICDSRL(1,"IDS")=ICD-9/10 Description, Short
- +17 ; ICDSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
- +18 ; ICDSRL(1,"LEX")=Lexicon Description
- +19 ; ICDSRL(1,"LEX",1)=Expression IEN ^ date
- +20 ; ICDSRL(1,"SYN",1)=Synonym #1
- +21 ; ICDSRL(1,"SYN",m)=Synonym #m
- +22 ; ...
- +23 ;
- +24 ; Output
- +25 ;
- +26 ; $$SEL Two Piece "^" delimited string same as
- +27 ; Fileman's Y output variable
- +28 ;
- +29 ; 1 Lexicon IEN
- +30 ; 2 Lexicon Term
- +31 ;
- +32 ; ICDSRL Local array passed by reference
- +33 ;
- +34 ; ICDSRL(0)=Code ^ Code IEN ^ date
- +35 ; ICDSRL("IDL")=ICD-9/10 Description, Long
- +36 ; ICDSRL("IDL",1)=ICD-9/10 IEN ^ date
- +37 ; ICDSRL("IDS")=ICD-9/10 Description, Short
- +38 ; ICDSRL("IDS",1)=ICD-9/10 IEN ^ date
- +39 ; ICDSRL("LEX")=Lexicon Description
- +40 ; ICDSRL("LEX",1)=Expression IEN ^ date
- +41 ;
- +42 ; or ^ on error
- +43 ; or -1 for non-selection
- +44 ; or -2 if "^" was entered
- +45 ;
- SEL(ICDSRL,X) ; Select from List
- +1 NEW ICDGOUP
- SET ICDGOUP=0
- +2 SET X=+($GET(X))
- +3 if X'>0
- SET X=5
- +4 SET X=$$ASK(.ICDSRL,X)
- +5 IF ICDGOUP=1
- QUIT -2
- +6 QUIT X
- +7 ;
- ASK(ICDSRL,X) ; Ask for Selection
- +1 NEW DTOUT,DUOUT,DIROUT
- +2 NEW ICDLIT,ICDLL,ICDLTOT
- +3 SET ICDLL=+($GET(X))
- +4 if ICDLL'>0
- SET ICDLL=5
- +5 SET ICDLIT=0
- SET ICDLTOT=$ORDER(ICDSRL(" "),-1)
- +6 if +ICDLTOT'>0
- QUIT "^"
- +7 KILL X
- +8 if +ICDLTOT=1
- SET X=$$ONE(ICDLL,.ICDSRL)
- +9 if +ICDLTOT>1
- SET X=$$MUL(.ICDSRL,ICDLL)
- +10 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(X))'>0)
- SET X=-1
- +11 QUIT X
- ONE(X,ICDSRL) ; One Entry Found
- +1 if +($GET(ICDLIT))>0
- QUIT "^^"
- +2 NEW DIR,ICDLC,ICDLEX,ICDLFI,ICDLIT,ICDLSO,ICDLNC
- +3 NEW ICDLSP,ICDLTX,ICDLC,Y,ICDCNT1
- +4 SET ICDLFI=$ORDER(ICDSRL(0))
- if +ICDLFI'>0
- QUIT "^"
- SET ICDLSP=$JUSTIFY(" ",11)
- +5 SET ICDLSO=$PIECE(ICDSRL(1,0),"^",1)
- SET ICDLNC=$PIECE(ICDSRL(1,0),"^",3)
- +6 if +ICDLNC>0
- SET ICDLNC=" ("_ICDLNC_")"
- SET ICDLEX=$GET(ICDSRL(1,"MENU"))
- +7 SET ICDLC=$SELECT($DATA(ICDSRL(1,"CAT")):"-",1:"")
- +8 SET ICDLTX(1)=ICDLSO_ICDLC_$JUSTIFY(" ",(9-$LENGTH(ICDLSO)))_" "_ICDLEX_ICDLNC
- +9 DO PR(.ICDLTX,64)
- SET DIR("A",1)=" One match found"
- SET DIR("A",2)=" "
- +10 SET DIR("A",3)=" "_$GET(ICDLTX(1))
- +11 SET ICDLC=3
- +12 FOR ICDCNT1=2:1
- if $GET(ICDLTX(ICDCNT1))=""
- QUIT
- SET ICDLC=ICDLC+1
- SET DIR("A",ICDLC)=ICDLSP_$GET(ICDLTX(ICDCNT1))
- +13 SET ICDLC=ICDLC+1
- SET DIR("A",ICDLC)=" "
- SET ICDLC=ICDLC+1
- +14 SET DIR("A")=" OK? (Yes/No) "
- SET DIR("B")="Yes"
- SET DIR(0)="YAO"
- WRITE !
- +15 DO ^DIR
- if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
- QUIT -1
- +16 if X["^^"!($DATA(DTOUT))
- SET ICDLIT=1
- +17 IF X["^^"!(+($GET(ICDLIT))>0)
- KILL ICDSRL
- QUIT "^^"
- +18 SET X=$SELECT(+Y>0:$$X(1,.ICDSRL),1:-1)
- +19 QUIT X
- MUL(ICDSRL,Y) ; Multiple Entries Found
- +1 if +($GET(ICDLIT))>0
- QUIT "^^"
- +2 NEW ICDSRLE,ICDLL,ICDLMAX,ICDLSS,ICDLX,X
- +3 SET (ICDLMAX,ICDLSS,ICDLIT)=0
- SET ICDLL=+($GET(Y))
- SET U="^"
- if +($GET(ICDLL))'>0
- SET ICDLL=5
- +4 SET ICDLX=$ORDER(ICDSRL(" "),-1)
- SET ICDLSS=0
- +5 if +ICDLX=0
- GOTO MULQ
- WRITE !
- if +ICDLX>1
- WRITE !," ",ICDLX," matches found"
- +6 FOR ICDSRLE=1:1:ICDLX
- if ((ICDLSS>0)&(ICDLSS<(ICDSRLE+1)))
- QUIT
- if ICDLIT
- QUIT
- Begin DoDot:1
- +7 if ICDSRLE#ICDLL=1
- WRITE !
- DO MULW
- +8 SET ICDLMAX=ICDSRLE
- if ICDSRLE#ICDLL=0
- WRITE !
- +9 if ICDSRLE#ICDLL=0
- SET ICDLSS=$$MULS(ICDLMAX,ICDSRLE,.ICDSRL)
- if ICDLSS["^"
- SET ICDLIT=1
- End DoDot:1
- if ICDLIT
- QUIT
- +10 IF ICDSRLE#ICDLL'=0
- IF +ICDLSS<=0
- Begin DoDot:1
- +11 WRITE !
- SET ICDLSS=$$MULS(ICDLMAX,ICDSRLE,.ICDSRL)
- if ICDLSS["^"
- SET ICDLIT=1
- End DoDot:1
- +12 GOTO MULQ
- +13 QUIT X
- MULW ; Write Multiple
- +1 NEW ICDLEX,ICDLI1,ICDLSO,ICDLNC,ICDLT2,ICDLTX
- SET ICDLSO=$PIECE(ICDSRL(+ICDSRLE,0),"^",1)
- +2 SET ICDLNC=$PIECE(ICDSRL(+ICDSRLE,0),"^",3)
- if +ICDLNC>0
- SET ICDLNC=" ("_ICDLNC_")"
- +3 SET ICDLEX=$GET(ICDSRL(+ICDSRLE,"MENU"))
- SET ICDLTX(1)=ICDLSO
- +4 SET ICDLTX(1)=ICDLTX(1)_$SELECT($DATA(ICDSRL(+ICDSRLE,"CAT")):"-",1:" ")_$JUSTIFY(" ",(9-$LENGTH(ICDLSO)))_" "_ICDLEX_ICDLNC
- +5 DO PR(.ICDLTX,60)
- WRITE !,$JUSTIFY(ICDSRLE,5),". ",$GET(ICDLTX(1))
- +6 FOR ICDLI1=2:1:5
- SET ICDLT2=$GET(ICDLTX(ICDLI1))
- if $LENGTH(ICDLT2)
- WRITE !,$JUSTIFY(" ",19),ICDLT2
- +7 QUIT
- MULS(X,Y,ICDSRL) ; Select from Multiple Entries
- +1 ;@#$ not sure ICDLS1 is needed here
- NEW DIR,DIRB,ICDLFI,ICDLHLP,ICDLLST,ICDLMAX,ICDLS1
- +2 if +($GET(ICDLIT))>0
- QUIT "^^"
- SET ICDLMAX=+($GET(X))
- SET ICDLLST=+($GET(Y))
- +3 if ICDLMAX=0
- QUIT -1
- SET ICDLFI=$ORDER(ICDSRL(0))
- if +ICDLFI'>0
- QUIT -1
- +4 IF +($ORDER(ICDSRL(+ICDLLST)))>0
- Begin DoDot:1
- +5 SET DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
- +6 SET DIR("A")=DIR("A")_ICDLMAX_": "
- End DoDot:1
- +7 IF +($ORDER(ICDSRL(+ICDLLST)))'>0
- Begin DoDot:1
- +8 SET DIR("A")=" Select 1-"_ICDLMAX_": "
- End DoDot:1
- +9 SET ICDLHLP=" Answer must be from 1 to "
- +10 SET ICDLHLP=ICDLHLP_ICDLMAX_", or <Return> to continue"
- +11 SET DIR("PRE")="S:X[""?"" X=""??"""
- +12 SET (DIR("?"),DIR("??"))="^D MULSH^ICDSELDS"
- +13 SET DIR(0)="NAO^1:"_ICDLMAX_":0"
- DO ^DIR
- +14 if X="^"
- SET ICDGOUP=1
- +15 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
- QUIT -1
- +16 if X["^^"!($DATA(DTOUT))
- SET ICDLIT=1
- SET X="^^"
- IF X["^^"!(+($GET(ICDLIT))>0)
- QUIT "^^"
- +17 KILL DIR
- if $DATA(DTOUT)!(X[U)
- QUIT "^^"
- +18 QUIT $SELECT(+Y>0:+Y,1:"-1")
- MULSH ; Select from Multiple Entries Help
- +1 IF $LENGTH($GET(ICDLHLP))
- WRITE !,$GET(ICDLHLP)
- QUIT
- +2 QUIT
- MULQ ; Quit Multiple
- +1 IF +ICDLSS'>0
- IF $GET(ICDLSS)="^"
- QUIT "^"
- +2 SET X=-1
- if +($GET(ICDLIT))'>0
- SET X=$$X(+ICDLSS,.ICDSRL)
- +3 QUIT X
- X(X,ICDSRL) ; Set X and Output Array
- +1 NEW ICDLEX,ICDSRFI,ICDLIEN,ICDLN1,ICDLNC,ICDLNN,ICDLRN,ICDLS1,ICDLSO
- +2 SET ICDLS1=+($GET(X))
- +3 ;@#$ not used?
- SET ICDSRFI=$ORDER(ICDSRL(0))
- +4 SET ICDLSO=$PIECE($GET(ICDSRL(ICDLS1,0)),"^",1)
- SET ICDLEX=$GET(ICDSRL(ICDLS1,"MENU"))
- +5 SET ICDLIEN=$SELECT($DATA(ICDSRL(ICDLS1,"CAT")):"99:CAT;"_$PIECE($GET(ICDSRL(ICDLS1,0)),"^"),1:$PIECE($GET(ICDSRL(ICDLS1,"LEX",1)),"^")_";"_$PIECE($GET(ICDSRL(ICDLS1,0)),"^"))
- if '$LENGTH(ICDLSO)
- QUIT "^"
- +6 if '$LENGTH(ICDLEX)
- QUIT "^"
- if +ICDLIEN'>0
- QUIT "^"
- SET X=ICDLIEN_"^"_ICDLEX
- +7 SET ICDLNN="ICDSRL("_+ICDLS1_")"
- SET ICDLNC="ICDSRL("_+ICDLS1_","
- +8 FOR
- SET ICDLNN=$QUERY(@ICDLNN)
- if '$LENGTH(ICDLNN)!(ICDLNN'[ICDLNC)
- QUIT
- Begin DoDot:1
- +9 SET ICDLRN="ICDLN1("_$PIECE(ICDLNN,"(",2,299)
- SET @ICDLRN=@ICDLNN
- End DoDot:1
- +10 KILL ICDSRL
- SET ICDLNN="ICDLN1("_+ICDLS1_")"
- SET ICDLNC="ICDLN1("_+ICDLS1_","
- +11 FOR
- SET ICDLNN=$QUERY(@ICDLNN)
- if '$LENGTH(ICDLNN)!(ICDLNN'[ICDLNC)
- QUIT
- Begin DoDot:1
- +12 SET ICDLRN="ICDSRL("_$PIECE(ICDLNN,"(",2,299)
- SET @ICDLRN=@ICDLNN
- End DoDot:1
- +13 QUIT X
- +14 ;
- +15 ; Miscellaneous
- CL ; Clear
- +1 KILL ICDLIT
- +2 QUIT
- PR(ICDSRL,X) ; Parse Array
- +1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,ICDDN,I,Z,%,%D,ICDLC,ICDLI1,ICDLL
- +2 KILL ^UTILITY($JOB,"W")
- +3 if '$DATA(ICDSRL)
- QUIT
- +4 SET ICDLL=+($GET(X))
- +5 if +ICDLL'>0
- SET ICDLL=79
- +6 SET ICDLC=+($GET(ICDSRL))
- +7 if +($GET(ICDLC))'>0
- SET ICDLC=$ORDER(ICDSRL(" "),-1)
- +8 if +ICDLC'>0
- QUIT
- +9 SET DIWL=1
- SET DIWF="C"_+ICDLL
- +10 SET ICDLI1=0
- +11 FOR
- SET ICDLI1=$ORDER(ICDSRL(ICDLI1))
- if +ICDLI1=0
- QUIT
- SET X=$GET(ICDSRL(ICDLI1))
- DO ^DIWP
- +12 KILL ICDSRL
- +13 SET (ICDLC,ICDLI1)=0
- +14 FOR
- SET ICDLI1=$ORDER(^UTILITY($JOB,"W",1,ICDLI1))
- if +ICDLI1=0
- QUIT
- Begin DoDot:1
- +15 SET ICDSRL(ICDLI1)=$$TM($GET(^UTILITY($JOB,"W",1,ICDLI1,0))," ")
- SET ICDLC=ICDLC+1
- End DoDot:1
- +16 if $LENGTH(ICDLC)
- SET ICDSRL=ICDLC
- +17 KILL ^UTILITY($JOB,"W")
- +18 QUIT
- TM(ICDX,ICDY) ; Trim Character Y - Default " "
- +1 SET ICDX=$GET(ICDX)
- if ICDX=""
- QUIT ICDX
- SET ICDY=$GET(ICDY)
- if '$LENGTH(ICDY)
- SET ICDY=" "
- +2 FOR
- if $EXTRACT(ICDX,1)'=ICDY
- QUIT
- SET ICDX=$EXTRACT(ICDX,2,$LENGTH(ICDX))
- +3 FOR
- if $EXTRACT(ICDX,$LENGTH(ICDX))'=ICDY
- QUIT
- SET ICDX=$EXTRACT(ICDX,1,($LENGTH(ICDX)-1))
- +4 QUIT ICDX