DGICD ;BIR/SJA - CODE SET VERSIONING UTILITY ;01/30/12 05:50 PM
;;5.3;Registration;**850**;Aug 13, 1993;Build 171
;
;Reference to $$ICDDATA^ICDXCODE supported by DBIA #5699
;
ASKOK(TOTAL) ;
Q:$G(TOTAL)<100
;
; -- See default setting of DGASK at LEX+17
I $G(DGASK)=1 D Q
. D EN^DDIOL("A total of "_$G(TOTAL)_" Entries found for this search.","","!!")
. D EN^DDIOL("Please refine your Search!")
. D EN^DDIOL(" ")
. H 3 S DGOK=0
. Q
;
I $G(DGASK)=2 D Q
. W !!," Searching for """_ICDTXT_""" requires inspecting "_$G(TOTAL)_" records to determine"
. W !," if they match the search criteria. This could take quite some time. Suggest"
. W !," refining the search by further specifying """_ICDTXT_""".",!
. ;
. N DIR,X,Y
. S DIR(0)="Y",DIR("A")=" Do you wish to continue (Y/N)"
. S DIR("B")="No"
. S DIR("?")=" Answer 'Y' for 'Yes' to continue searching on "_ICDTXT_" or 'N' for 'No' to refine search criteria."
. D ^DIR
. I $D(DIROUT)!($D(DIRUT))!($D(DTOUT))!($D(DTOUT)) S DGOK=0 Q
. S DGOK=Y
. I DGOK=1 W !," Searching...."
. W !
Q
LEX ; -- Called indirectly out of input transforms
; -- INPUT
; X := the value to be search for (required)
; EFFDATE := the date of interest for the search (required)
;
N %DT,DIROUT,DUOUT,DTOUT,ICDEXIT,ICDDT,ICDTXT,ICDUP,ICDY,XX,DGTOT,DGOK,DGZZONE
S ICDTXT=$G(X) Q:'$L(ICDTXT)
;
I ICDTXT["?" D K X,Y Q ; - added here for calls that bypass ^DGICDGT
. N TAG,FORMAT
. S TAG=$S(X["???":"D3^DGICDGT",X["??":"D2^DGICDGT",X["?":"D1^DGICDGT",1:"D1^DGICDGT")
. D @TAG
. Q
;
I $L(ICDTXT)<2 D S X="" Q
. D EN^DDIOL("Please enter at least the first two characters of the ICD-10","","!!?5")
. D EN^DDIOL("code or code description to start the search.","","!?5")
. D EN^DDIOL(" ")
. Q
;
I '$G(DGASK) S DGASK=2 ;1:= Do not ask to continue, just quit, 2:=ask to continue
S DGTOT=$$FREQ^LEXU(ICDTXT) ;IA 5679
I DGTOT>$$MAX^LEXU(30) D ASKOK(DGTOT) Q:'$G(DGOK)
;
S ICDDT=$G(EFFDATE),ICDEXIT=0
K DGASK,DGOK
; Begin Recursive Loop
LOOK ; Lookup
Q:+($G(ICDEXIT))>0 K ICDY
S ICDY=$$DIAGSRCH^LEX10CS(ICDTXT,.ICDY,ICDDT,30)
S:$O(ICDY(" "),-1)>0 ICDY=+ICDY
I +ICDY'>0 D:'$D(DA) EN^DDIOL(" ??") K X,Y Q
S XX=$$SEL^DGICDL(.ICDY,8)
I $D(DUOUT)&('$D(DIROUT)) K:'$D(ICDNT) X Q
I $D(DTOUT)&('$D(DIROUT)) S ICDEXIT=1 K X Q
I $D(DIROUT) S ICDEXIT=1 K X Q
; Abort if timed out or user enters "^^"
I $D(DTOUT)!($D(DIROUT)) S ICDEXIT=1 K X Q
; Up one level (ICDUP) if user enters "^"
; Quit if already at top level and user enters "^"
I $D(DUOUT),'$D(DIROUT),$L($G(ICDUP)) K X Q
; No Selection
I '$D(DUOUT),XX=-1 S ICDEXIT=1
; Code Found and Selected
I $P(XX,";")'="99:CAT" S Y=+$$ICDDATA^ICDXCODE("10D",$P($P(XX,"^"),";",2)) S ICDEXIT=1 D Q
. W:'$D(DGZZONE) " ",$P(XX,";",2)," ICD-10 ",$$VST^ICDEX(80,Y)
; Category Found and Selected
D NXT G:+($G(ICDEXIT))'>0 LOOK
Q
NXT ; Next
Q:+($G(ICDEXIT))>0 N ICDNT,ICDND,ICDX
S ICDNT=$G(ICDTXT),ICDND=$G(ICDDT),ICDX=$G(XX)
N ICDTXT,ICDDT S ICDTXT=$P($P(ICDX,"^"),";",2),ICDDT=ICDND
G LOOK
Q
MW(X) ; Multiple Words
; returns 0 if 1 word
; 1 if more than 1 word
N INP,CHR,PSN,STR,P1,P2,CT S INP=$G(X) Q:'$L(INP) -1
S CT=0,STR=" ()_-{}[]\:;,<>" F PSN=1:1:$L(STR) S CHR=$E(STR,PSN) S CT=0 D Q:CT>1
. S P1=$P(INP,CHR,1),P2=$P(INP,CHR,2,299) S:$L(P1)&(P1'?1N.N) CT=CT+1 S:$L(P2)&(P2'?1N.N) CT=CT+1
Q:CT'>1 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGICD 3477 printed Oct 16, 2024@18:44:30 Page 2
DGICD ;BIR/SJA - CODE SET VERSIONING UTILITY ;01/30/12 05:50 PM
+1 ;;5.3;Registration;**850**;Aug 13, 1993;Build 171
+2 ;
+3 ;Reference to $$ICDDATA^ICDXCODE supported by DBIA #5699
+4 ;
ASKOK(TOTAL) ;
+1 if $GET(TOTAL)<100
QUIT
+2 ;
+3 ; -- See default setting of DGASK at LEX+17
+4 IF $GET(DGASK)=1
Begin DoDot:1
+5 DO EN^DDIOL("A total of "_$GET(TOTAL)_" Entries found for this search.","","!!")
+6 DO EN^DDIOL("Please refine your Search!")
+7 DO EN^DDIOL(" ")
+8 HANG 3
SET DGOK=0
+9 QUIT
End DoDot:1
QUIT
+10 ;
+11 IF $GET(DGASK)=2
Begin DoDot:1
+12 WRITE !!," Searching for """_ICDTXT_""" requires inspecting "_$GET(TOTAL)_" records to determine"
+13 WRITE !," if they match the search criteria. This could take quite some time. Suggest"
+14 WRITE !," refining the search by further specifying """_ICDTXT_""".",!
+15 ;
+16 NEW DIR,X,Y
+17 SET DIR(0)="Y"
SET DIR("A")=" Do you wish to continue (Y/N)"
+18 SET DIR("B")="No"
+19 SET DIR("?")=" Answer 'Y' for 'Yes' to continue searching on "_ICDTXT_" or 'N' for 'No' to refine search criteria."
+20 DO ^DIR
+21 IF $DATA(DIROUT)!($DATA(DIRUT))!($DATA(DTOUT))!($DATA(DTOUT))
SET DGOK=0
QUIT
+22 SET DGOK=Y
+23 IF DGOK=1
WRITE !," Searching...."
+24 WRITE !
End DoDot:1
QUIT
+25 QUIT
LEX ; -- Called indirectly out of input transforms
+1 ; -- INPUT
+2 ; X := the value to be search for (required)
+3 ; EFFDATE := the date of interest for the search (required)
+4 ;
+5 NEW %DT,DIROUT,DUOUT,DTOUT,ICDEXIT,ICDDT,ICDTXT,ICDUP,ICDY,XX,DGTOT,DGOK,DGZZONE
+6 SET ICDTXT=$GET(X)
if '$LENGTH(ICDTXT)
QUIT
+7 ;
+8 ; - added here for calls that bypass ^DGICDGT
IF ICDTXT["?"
Begin DoDot:1
+9 NEW TAG,FORMAT
+10 SET TAG=$SELECT(X["???":"D3^DGICDGT",X["??":"D2^DGICDGT",X["?":"D1^DGICDGT",1:"D1^DGICDGT")
+11 DO @TAG
+12 QUIT
End DoDot:1
KILL X,Y
QUIT
+13 ;
+14 IF $LENGTH(ICDTXT)<2
Begin DoDot:1
+15 DO EN^DDIOL("Please enter at least the first two characters of the ICD-10","","!!?5")
+16 DO EN^DDIOL("code or code description to start the search.","","!?5")
+17 DO EN^DDIOL(" ")
+18 QUIT
End DoDot:1
SET X=""
QUIT
+19 ;
+20 ;1:= Do not ask to continue, just quit, 2:=ask to continue
IF '$GET(DGASK)
SET DGASK=2
+21 ;IA 5679
SET DGTOT=$$FREQ^LEXU(ICDTXT)
+22 IF DGTOT>$$MAX^LEXU(30)
DO ASKOK(DGTOT)
if '$GET(DGOK)
QUIT
+23 ;
+24 SET ICDDT=$GET(EFFDATE)
SET ICDEXIT=0
+25 KILL DGASK,DGOK
+26 ; Begin Recursive Loop
LOOK ; Lookup
+1 if +($GET(ICDEXIT))>0
QUIT
KILL ICDY
+2 SET ICDY=$$DIAGSRCH^LEX10CS(ICDTXT,.ICDY,ICDDT,30)
+3 if $ORDER(ICDY(" "),-1)>0
SET ICDY=+ICDY
+4 IF +ICDY'>0
if '$DATA(DA)
DO EN^DDIOL(" ??")
KILL X,Y
QUIT
+5 SET XX=$$SEL^DGICDL(.ICDY,8)
+6 IF $DATA(DUOUT)&('$DATA(DIROUT))
if '$DATA(ICDNT)
KILL X
QUIT
+7 IF $DATA(DTOUT)&('$DATA(DIROUT))
SET ICDEXIT=1
KILL X
QUIT
+8 IF $DATA(DIROUT)
SET ICDEXIT=1
KILL X
QUIT
+9 ; Abort if timed out or user enters "^^"
+10 IF $DATA(DTOUT)!($DATA(DIROUT))
SET ICDEXIT=1
KILL X
QUIT
+11 ; Up one level (ICDUP) if user enters "^"
+12 ; Quit if already at top level and user enters "^"
+13 IF $DATA(DUOUT)
IF '$DATA(DIROUT)
IF $LENGTH($GET(ICDUP))
KILL X
QUIT
+14 ; No Selection
+15 IF '$DATA(DUOUT)
IF XX=-1
SET ICDEXIT=1
+16 ; Code Found and Selected
+17 IF $PIECE(XX,";")'="99:CAT"
SET Y=+$$ICDDATA^ICDXCODE("10D",$PIECE($PIECE(XX,"^"),";",2))
SET ICDEXIT=1
Begin DoDot:1
+18 if '$DATA(DGZZONE)
WRITE " ",$PIECE(XX,";",2)," ICD-10 ",$$VST^ICDEX(80,Y)
End DoDot:1
QUIT
+19 ; Category Found and Selected
+20 DO NXT
if +($GET(ICDEXIT))'>0
GOTO LOOK
+21 QUIT
NXT ; Next
+1 if +($GET(ICDEXIT))>0
QUIT
NEW ICDNT,ICDND,ICDX
+2 SET ICDNT=$GET(ICDTXT)
SET ICDND=$GET(ICDDT)
SET ICDX=$GET(XX)
+3 NEW ICDTXT,ICDDT
SET ICDTXT=$PIECE($PIECE(ICDX,"^"),";",2)
SET ICDDT=ICDND
+4 GOTO LOOK
+5 QUIT
MW(X) ; Multiple Words
+1 ; returns 0 if 1 word
+2 ; 1 if more than 1 word
+3 NEW INP,CHR,PSN,STR,P1,P2,CT
SET INP=$GET(X)
if '$LENGTH(INP)
QUIT -1
+4 SET CT=0
SET STR=" ()_-{}[]\:;,<>"
FOR PSN=1:1:$LENGTH(STR)
SET CHR=$EXTRACT(STR,PSN)
SET CT=0
Begin DoDot:1
+5 SET P1=$PIECE(INP,CHR,1)
SET P2=$PIECE(INP,CHR,2,299)
if $LENGTH(P1)&(P1'?1N.N)
SET CT=CT+1
if $LENGTH(P2)&(P2'?1N.N)
SET CT=CT+1
End DoDot:1
if CT>1
QUIT
+6 if CT'>1
QUIT 0
+7 QUIT 1
