IBDFDE2 ;ALB/AAS - AICS Data Entry, process selection lists ;02/24/96
;;3.0;AUTOMATED INFO COLLECTION SYS;**4,63**;APR 24, 1997;Build 80
;
;
% G ^IBDFDE
;
CHOICE(I) ; -- return ^tmp(ibd-lst,ibdfmien,ibdf(pi),ibdf(ien),i)
Q $G(^TMP("IBD-LST",$J,+$G(IBDFMIEN),+$G(IBDF("PI")),+$G(IBDF("IEN")),+$G(I)))
;
LIST(RESULT,IBDF,IBDASK) ; -- Procedure
; -- Manual Data entry routine for Visit Type input
; Input : Result := call by reference, used to output results
; IBDF("IEN") := pointer to selection list (357.2)
; IBDF("PI") := pointer to input package interface
; IBDF("DFN") := pointer to patient (required for dynamic lists only)
; IBDF("CLINIC") := pointer to hospital location (required for dynamic lists only)
;
; Output: Selections for input in IBDFDE1 (and eventually IBDFRPC4)
; RESULT(0) := count of selections (including previous)
; RESULT(n) $p1 := package interface
; $p2 := Code to send (usually ien)
; $p3 := Text to send (from form or additional text)
; $p4 := Header to send (from form) (optional)
; $p5 := Clinical lexicon pointer (from 357.2) (optional)
; $p6 := qualifier (optional)
; $p7 := ien of list (in 357.2)
; $p10 := external value (optional)
;
N I,J,X,Y,CHOICE,RULE,ROW,QLFR,TEXT,TEXTU,CODE,NUMBER,OVER,SELECT,ANS,DISPTXT,HDR,NEXT,NEXT1,PICK,DA,DR,DIE,DIC,DIR,DIRUT,DUOUT,DTOUT,IBDEFLT,CNTH,OVER,IBDP,SELAST,IOINHI,IOINORM,ARRAY,VAR
S X="IOINHI;IOINORM" D ENDR^%ZISS
S IBQUIT=0,ANS=""
I IBDF("TYPE")="MC" D MULT^IBDFDE4(.RESULT,.IBDF) G VSTQ
;
; -- check required variables
I '$D(IBDFMIEN)!('$D(IBDF("PI")))!('$D(IBDF("IEN"))) W !!,"Required variables not defined for this list:",!,"Form =",$G(IBDFMIEN),!,"Interface = ",$G(IBDF("PI")),!,"List = ",$G(IBDF("IEN")) G VSTQ
;
S VAR="^TMP(""IBD-LST"",$J,"_+$G(IBDFMIEN)_","_+$G(IBDF("PI"))_","_+$G(IBDF("IEN"))_")"
I $$CHOICE(0)="" D OBJLST^IBDFRPC1(VAR,.IBDF) D COMPLST^IBDFDE5
;
I '$D(^TMP("IBD-ASK",$J,IBDFMIEN,IBDASK)),$G(IBDF("IBDF")) S ^TMP("IBD-ASK",$J,IBDFMIEN,$$UP^XLFSTR(IBDASK),IBDF("IBDF"))=""
;
I +$$CHOICE(0)<1,+$G(IBDF("PROVIDER PI"))'=IBDF("PI") G VSTQ ;list is empty, don't ask, unless its provider
;
; -- look at zero node, find qualifiers and selection rule
D RULES^IBDFDE22
;
I $G(IBDREDIT) S ANS=" " D CHK^IBDFDE22 S ANS="" G:'OVER VSTQ N IBDREDIT
;
; -- set dir("b")
I $D(IBDPI(IBDF("PI")))>1 D DEFAULT^IBDFDE21
;
OVER ; -- ask or re-ask for selection(s) from list
S OVER=0
S CNTH=1,I=0 F S I=$O(RULE(I)) Q:'I D
. IF RULE(I)=0 S DIR("?",CNTH)="Any Number of "_$G(IOINHI)_QLFR(I)_$S(QLFR(I)'="":" ",1:"")_IBDASK_$G(IOINORM)_" allowed (including zero)." S CNTH=CNTH+1 Q
. IF RULE(I)=1 S DIR("?",CNTH)="Exactly one "_IOINHI_QLFR(I)_$S(QLFR(I)'="":" ",1:"")_IBDASK_$G(IOINORM)_" Required." S CNTH=CNTH+1 Q
. IF RULE(I)=2 S DIR("?",CNTH)="At most one "_$G(IOINHI)_QLFR(I)_$S(QLFR(I)'="":" ",1:"")_IBDASK_$G(IOINORM)_" allowed." S CNTH=CNTH+1 Q
. IF RULE(I)=3 S DIR("?",CNTH)="At least 1 (1 or more) "_$G(IOINHI)_QLFR(I)_$S(QLFR(I)'="":" ",1:"")_IBDASK_$G(IOINORM)_" Required." S CNTH=CNTH+1 Q
;
S DIR("?",CNTH)="",CNTH=CNTH+1
S DIR("?")="Select an item from the form, enter by name or number. Enter '??' to see the list of items on the form. When editing, press enter to accept, '@' to delete, or enter a new selection."
I $G(IBDF("OTHER")) S DIR("?")=DIR("?")_" Or enter an item written on the form."
;
S DIR("??")="^D LST^IBDFDE21"
;
; -- default provider is 1st provider
I +$G(IBDF("PROVIDER PI"))=IBDF("PI") D I $G(SELECT) D SEL^IBDFDE21(SELECT),CHK^IBDFDE22 K IBNAQLFR G VSTOVER
.S SELECT=0
.I $G(IBDF("PROVIDER")) Q
.I '$G(IBDREDIT),'$D(IBDPI(IBDF("PI"))),+$$CHOICE(0)=1,+$$PRDEF^IBDFRPC3(IBDF("CLINIC")) S ANS=" ",SELECT=1 W !!,IOINHI,"Using Default Provider : "_IBDPTPRI,IOINORM S IBNAQLFR=1 Q
.Q:$P(IBDF("PROVIDER PI"),"^",2) ;not on form don't ask if not default
.Q:$D(IBDPI(IBDF("PI"))) ;one already select
.I $$PRDEF^IBDFRPC3(IBDF("CLINIC")) S DIR("B")=$P($$CHOICE(1),"^")
;
S DIR(0)="FO^1:40^I $D(X),X="" "" K X W !!,$G(IOINHI),""Spacebar Return Not allowed!"",$G(IOINORM)"
S DIR("A")="Select "_$G(IBDASK)
I $G(^TMP("IBD-PI-CNT",$J,IBDF("PI")))>1 S DIR("A")=DIR("A")_" (Page "_IBDF("PAGE")_")"
D ^DIR K DIR
I $G(IBDEFLT(IBDF("PI")))'="",Y=IBDEFLT(IBDF("PI")) S Y="" ; on re-edit, accepting last entry same as entering nothing.
S ANS=$$UP^XLFSTR(Y)
I ANS="",$D(DIRUT),$G(IBDEFLT(IBDF("PI")))'="",$G(SELAST) K IBDPI(IBDF("PI"),SELAST),IBDSEL(SELAST) W " Deleted!" ;user type "@" at prompt
I ANS="" D CHK^IBDFDE22 G VSTOVER
I ANS["^",ANS'="^" D G VSTOVER
.S GOTO=$$UP^XLFSTR($P(ANS,"^",2))
.I GOTO="?"!(GOTO="??") X "W !!,""Valid Blocks to Jump to: "" S IBDX=0 F S IBDX=$O(^TMP(""IBD-ASK"",$J,IBDFMIEN,IBDX)) Q:IBDX="""" W !,?6,IBDX" S OVER=1 Q
.S X=$O(^TMP("IBD-ASK",$J,IBDFMIEN,GOTO))
.I X'="",X[GOTO W $E(X,$L(GOTO)+1,$L(X)) S IBDF("GOTO")=+$O(^TMP("IBD-ASK",$J,IBDFMIEN,X,""))-1,IBDREDIT=1 Q
.S IBQUIT=1
I $D(DIRUT) S IBQUIT=1 G VSTQ
S SELECT=0
;
; -- first check for exact code matches
I $G(NUMBER(ANS)) S SELECT=$G(NUMBER(ANS)) D SEL^IBDFDE21(SELECT),CHK^IBDFDE22 G VSTOVER
;
S ARRAY="^TMP(""IBD-LCODE"",$J,IBDFMIEN,IBDF(""PI""),IBDF(""IEN""))"
I $G(@ARRAY@(" "_ANS,1)),'$O(@ARRAY@(" "_ANS,1)) S SELECT=@ARRAY@(" "_ANS,1) D SEL^IBDFDE21(SELECT),CHK^IBDFDE22 G VSTOVER
I $G(@ARRAY@(" "_ANS,1)) D I $G(SELECT) D SEL^IBDFDE21(SELECT),CHK^IBDFDE22 G VSTOVER
.; -- more than one code the same number
.S SELECT=$$PARTLST^IBDFDE21(ARRAY," "_ANS," "_ANS)
;
; -- next check for partial code answers
S ANS1=" "_ANS
S NEXT=$O(@ARRAY@(ANS1)) D I SELECT D SEL^IBDFDE21(SELECT),CHK^IBDFDE22 G VSTOVER
.Q:NEXT=""!($E(NEXT,1,$L(ANS1))'=ANS1)
.I $O(@ARRAY@(NEXT,1)) S SELECT=$$PARTLST^IBDFDE21(ARRAY,NEXT,ANS1) Q
.S NEXT1=$O(@ARRAY@(NEXT)) I $E(NEXT1,1,$L(ANS1))=ANS1 S SELECT=$$PARTLST^IBDFDE21(ARRAY,NEXT,ANS1) Q ;Not Unique answer
.W $E(NEXT,($L(ANS1)+1),$L(NEXT))
.S SELECT=$G(@ARRAY@(NEXT,1))
;
; -- check for exact text matches
S ARRAY="^TMP(""IBD-LTEXT"",$J,IBDFMIEN,IBDF(""PI""),IBDF(""IEN""))"
I $G(@ARRAY@(ANS,1)),'$O(@ARRAY@(ANS,1)) S SELECT=@ARRAY@(ANS,1) D SEL^IBDFDE21(SELECT),CHK^IBDFDE22 G VSTOVER
I $G(@ARRAY@(ANS,1)) D I $G(SELECT) D SEL^IBDFDE21(SELECT),CHK^IBDFDE22 G VSTOVER
.; -- more than one description the same
.S SELECT=$$PARTLST^IBDFDE21(ARRAY,ANS,ANS)
;
; -- next check for partial text answers
S NEXT=$O(@ARRAY@(ANS)) D I SELECT D SEL^IBDFDE21(SELECT),CHK^IBDFDE22 G VSTOVER
.Q:NEXT=""!($E(NEXT,1,$L(ANS))'=ANS)
.I $O(@ARRAY@(NEXT,1)) S SELECT=$$PARTLST^IBDFDE21(ARRAY,NEXT,ANS) Q
.S NEXT1=$O(@ARRAY@(NEXT)) I $E(NEXT1,1,$L(ANS))=ANS S SELECT=$$PARTLST^IBDFDE21(ARRAY,NEXT,ANS) Q ;Not Unique answer
.W $E(NEXT,($L(ANS)+1),$L(NEXT))
.S SELECT=$G(@ARRAY@(NEXT,1))
;
I ANS'="" S SEL=$$OTHER^IBDFDE21(ANS) I SEL'="" D SEL^IBDFDE21(SEL),CHK^IBDFDE22 G VSTOVER
I ANS'="" W " ?? ",$C(7),"Not Found" G OVER
;
VSTOVER K SELAST G:OVER OVER
I $G(ASKOTHER) F S SEL=$$OTHER^IBDFDE21("") Q:SEL="" D SEL^IBDFDE21(SEL),CHK^IBDFDE22 Q:'$G(ASKOTHER)
;
VSTQ ; -- kill array for dynamic lists
I $P($G(^IBE(357.6,IBDF("PI"),0)),"^",14) S:IBDF("PI")'=$G(IBDF("PROVIDER PI")) IBDF("DYNAMIC")=1 K ^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI")),^TMP("IBD-LTEXT",$J,IBDFMIEN,IBDF("PI")),^TMP("IBD-LCODE",$J,IBDFMIEN,IBDF("PI"))
K ^TMP("IB",$J,"INTERFACES")
K IBDF("OTHER"),ASKOTHER
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFDE2 7709 printed Apr 09, 2024@21:19:39 Page 2
IBDFDE2 ;ALB/AAS - AICS Data Entry, process selection lists ;02/24/96
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**4,63**;APR 24, 1997;Build 80
+2 ;
+3 ;
% GOTO ^IBDFDE
+1 ;
CHOICE(I) ; -- return ^tmp(ibd-lst,ibdfmien,ibdf(pi),ibdf(ien),i)
+1 QUIT $GET(^TMP("IBD-LST",$JOB,+$GET(IBDFMIEN),+$GET(IBDF("PI")),+$GET(IBDF("IEN")),+$GET(I)))
+2 ;
LIST(RESULT,IBDF,IBDASK) ; -- Procedure
+1 ; -- Manual Data entry routine for Visit Type input
+2 ; Input : Result := call by reference, used to output results
+3 ; IBDF("IEN") := pointer to selection list (357.2)
+4 ; IBDF("PI") := pointer to input package interface
+5 ; IBDF("DFN") := pointer to patient (required for dynamic lists only)
+6 ; IBDF("CLINIC") := pointer to hospital location (required for dynamic lists only)
+7 ;
+8 ; Output: Selections for input in IBDFDE1 (and eventually IBDFRPC4)
+9 ; RESULT(0) := count of selections (including previous)
+10 ; RESULT(n) $p1 := package interface
+11 ; $p2 := Code to send (usually ien)
+12 ; $p3 := Text to send (from form or additional text)
+13 ; $p4 := Header to send (from form) (optional)
+14 ; $p5 := Clinical lexicon pointer (from 357.2) (optional)
+15 ; $p6 := qualifier (optional)
+16 ; $p7 := ien of list (in 357.2)
+17 ; $p10 := external value (optional)
+18 ;
+19 NEW I,J,X,Y,CHOICE,RULE,ROW,QLFR,TEXT,TEXTU,CODE,NUMBER,OVER,SELECT,ANS,DISPTXT,HDR,NEXT,NEXT1,PICK,DA,DR,DIE,DIC,DIR,DIRUT,DUOUT,DTOUT,IBDEFLT,CNTH,OVER,IBDP,SELAST,IOINHI,IOINORM,ARRAY,VAR
+20 SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
+21 SET IBQUIT=0
SET ANS=""
+22 IF IBDF("TYPE")="MC"
DO MULT^IBDFDE4(.RESULT,.IBDF)
GOTO VSTQ
+23 ;
+24 ; -- check required variables
+25 IF '$DATA(IBDFMIEN)!('$DATA(IBDF("PI")))!('$DATA(IBDF("IEN")))
WRITE !!,"Required variables not defined for this list:",!,"Form =",$GET(IBDFMIEN),!,"Interface = ",$GET(IBDF("PI")),!,"List = ",$GET(IBDF("IEN"))
GOTO VSTQ
+26 ;
+27 SET VAR="^TMP(""IBD-LST"",$J,"_+$GET(IBDFMIEN)_","_+$GET(IBDF("PI"))_","_+$GET(IBDF("IEN"))_")"
+28 IF $$CHOICE(0)=""
DO OBJLST^IBDFRPC1(VAR,.IBDF)
DO COMPLST^IBDFDE5
+29 ;
+30 IF '$DATA(^TMP("IBD-ASK",$JOB,IBDFMIEN,IBDASK))
IF $GET(IBDF("IBDF"))
SET ^TMP("IBD-ASK",$JOB,IBDFMIEN,$$UP^XLFSTR(IBDASK),IBDF("IBDF"))=""
+31 ;
+32 ;list is empty, don't ask, unless its provider
IF +$$CHOICE(0)<1
IF +$GET(IBDF("PROVIDER PI"))'=IBDF("PI")
GOTO VSTQ
+33 ;
+34 ; -- look at zero node, find qualifiers and selection rule
+35 DO RULES^IBDFDE22
+36 ;
+37 IF $GET(IBDREDIT)
SET ANS=" "
DO CHK^IBDFDE22
SET ANS=""
if 'OVER
GOTO VSTQ
NEW IBDREDIT
+38 ;
+39 ; -- set dir("b")
+40 IF $DATA(IBDPI(IBDF("PI")))>1
DO DEFAULT^IBDFDE21
+41 ;
OVER ; -- ask or re-ask for selection(s) from list
+1 SET OVER=0
+2 SET CNTH=1
SET I=0
FOR
SET I=$ORDER(RULE(I))
if 'I
QUIT
Begin DoDot:1
+3 IF RULE(I)=0
SET DIR("?",CNTH)="Any Number of "_$GET(IOINHI)_QLFR(I)_$SELECT(QLFR(I)'="":" ",1:"")_IBDASK_$GET(IOINORM)_" allowed (including zero)."
SET CNTH=CNTH+1
QUIT
+4 IF RULE(I)=1
SET DIR("?",CNTH)="Exactly one "_IOINHI_QLFR(I)_$SELECT(QLFR(I)'="":" ",1:"")_IBDASK_$GET(IOINORM)_" Required."
SET CNTH=CNTH+1
QUIT
+5 IF RULE(I)=2
SET DIR("?",CNTH)="At most one "_$GET(IOINHI)_QLFR(I)_$SELECT(QLFR(I)'="":" ",1:"")_IBDASK_$GET(IOINORM)_" allowed."
SET CNTH=CNTH+1
QUIT
+6 IF RULE(I)=3
SET DIR("?",CNTH)="At least 1 (1 or more) "_$GET(IOINHI)_QLFR(I)_$SELECT(QLFR(I)'="":" ",1:"")_IBDASK_$GET(IOINORM)_" Required."
SET CNTH=CNTH+1
QUIT
End DoDot:1
+7 ;
+8 SET DIR("?",CNTH)=""
SET CNTH=CNTH+1
+9 SET DIR("?")="Select an item from the form, enter by name or number. Enter '??' to see the list of items on the form. When editing, press enter to accept, '@' to delete, or enter a new selection."
+10 IF $GET(IBDF("OTHER"))
SET DIR("?")=DIR("?")_" Or enter an item written on the form."
+11 ;
+12 SET DIR("??")="^D LST^IBDFDE21"
+13 ;
+14 ; -- default provider is 1st provider
+15 IF +$GET(IBDF("PROVIDER PI"))=IBDF("PI")
Begin DoDot:1
+16 SET SELECT=0
+17 IF $GET(IBDF("PROVIDER"))
QUIT
+18 IF '$GET(IBDREDIT)
IF '$DATA(IBDPI(IBDF("PI")))
IF +$$CHOICE(0)=1
IF +$$PRDEF^IBDFRPC3(IBDF("CLINIC"))
SET ANS=" "
SET SELECT=1
WRITE !!,IOINHI,"Using Default Provider : "_IBDPTPRI,IOINORM
SET IBNAQLFR=1
QUIT
+19 ;not on form don't ask if not default
if $PIECE(IBDF("PROVIDER PI"),"^",2)
QUIT
+20 ;one already select
if $DATA(IBDPI(IBDF("PI")))
QUIT
+21 IF $$PRDEF^IBDFRPC3(IBDF("CLINIC"))
SET DIR("B")=$PIECE($$CHOICE(1),"^")
End DoDot:1
IF $GET(SELECT)
DO SEL^IBDFDE21(SELECT)
DO CHK^IBDFDE22
KILL IBNAQLFR
GOTO VSTOVER
+22 ;
+23 SET DIR(0)="FO^1:40^I $D(X),X="" "" K X W !!,$G(IOINHI),""Spacebar Return Not allowed!"",$G(IOINORM)"
+24 SET DIR("A")="Select "_$GET(IBDASK)
+25 IF $GET(^TMP("IBD-PI-CNT",$JOB,IBDF("PI")))>1
SET DIR("A")=DIR("A")_" (Page "_IBDF("PAGE")_")"
+26 DO ^DIR
KILL DIR
+27 ; on re-edit, accepting last entry same as entering nothing.
IF $GET(IBDEFLT(IBDF("PI")))'=""
IF Y=IBDEFLT(IBDF("PI"))
SET Y=""
+28 SET ANS=$$UP^XLFSTR(Y)
+29 ;user type "@" at prompt
IF ANS=""
IF $DATA(DIRUT)
IF $GET(IBDEFLT(IBDF("PI")))'=""
IF $GET(SELAST)
KILL IBDPI(IBDF("PI"),SELAST),IBDSEL(SELAST)
WRITE " Deleted!"
+30 IF ANS=""
DO CHK^IBDFDE22
GOTO VSTOVER
+31 IF ANS["^"
IF ANS'="^"
Begin DoDot:1
+32 SET GOTO=$$UP^XLFSTR($PIECE(ANS,"^",2))
+33 IF GOTO="?"!(GOTO="??")
XECUTE "W !!,""Valid Blocks to Jump to: "" S IBDX=0 F S IBDX=$O(^TMP(""IBD-ASK"",$J,IBDFMIEN,IBDX)) Q:IBDX="""" W !,?6,IBDX"
SET OVER=1
QUIT
+34 SET X=$ORDER(^TMP("IBD-ASK",$JOB,IBDFMIEN,GOTO))
+35 IF X'=""
IF X[GOTO
WRITE $EXTRACT(X,$LENGTH(GOTO)+1,$LENGTH(X))
SET IBDF("GOTO")=+$ORDER(^TMP("IBD-ASK",$JOB,IBDFMIEN,X,""))-1
SET IBDREDIT=1
QUIT
+36 SET IBQUIT=1
End DoDot:1
GOTO VSTOVER
+37 IF $DATA(DIRUT)
SET IBQUIT=1
GOTO VSTQ
+38 SET SELECT=0
+39 ;
+40 ; -- first check for exact code matches
+41 IF $GET(NUMBER(ANS))
SET SELECT=$GET(NUMBER(ANS))
DO SEL^IBDFDE21(SELECT)
DO CHK^IBDFDE22
GOTO VSTOVER
+42 ;
+43 SET ARRAY="^TMP(""IBD-LCODE"",$J,IBDFMIEN,IBDF(""PI""),IBDF(""IEN""))"
+44 IF $GET(@ARRAY@(" "_ANS,1))
IF '$ORDER(@ARRAY@(" "_ANS,1))
SET SELECT=@ARRAY@(" "_ANS,1)
DO SEL^IBDFDE21(SELECT)
DO CHK^IBDFDE22
GOTO VSTOVER
+45 IF $GET(@ARRAY@(" "_ANS,1))
Begin DoDot:1
+46 ; -- more than one code the same number
+47 SET SELECT=$$PARTLST^IBDFDE21(ARRAY," "_ANS," "_ANS)
End DoDot:1
IF $GET(SELECT)
DO SEL^IBDFDE21(SELECT)
DO CHK^IBDFDE22
GOTO VSTOVER
+48 ;
+49 ; -- next check for partial code answers
+50 SET ANS1=" "_ANS
+51 SET NEXT=$ORDER(@ARRAY@(ANS1))
Begin DoDot:1
+52 if NEXT=""!($EXTRACT(NEXT,1,$LENGTH(ANS1))'=ANS1)
QUIT
+53 IF $ORDER(@ARRAY@(NEXT,1))
SET SELECT=$$PARTLST^IBDFDE21(ARRAY,NEXT,ANS1)
QUIT
+54 ;Not Unique answer
SET NEXT1=$ORDER(@ARRAY@(NEXT))
IF $EXTRACT(NEXT1,1,$LENGTH(ANS1))=ANS1
SET SELECT=$$PARTLST^IBDFDE21(ARRAY,NEXT,ANS1)
QUIT
+55 WRITE $EXTRACT(NEXT,($LENGTH(ANS1)+1),$LENGTH(NEXT))
+56 SET SELECT=$GET(@ARRAY@(NEXT,1))
End DoDot:1
IF SELECT
DO SEL^IBDFDE21(SELECT)
DO CHK^IBDFDE22
GOTO VSTOVER
+57 ;
+58 ; -- check for exact text matches
+59 SET ARRAY="^TMP(""IBD-LTEXT"",$J,IBDFMIEN,IBDF(""PI""),IBDF(""IEN""))"
+60 IF $GET(@ARRAY@(ANS,1))
IF '$ORDER(@ARRAY@(ANS,1))
SET SELECT=@ARRAY@(ANS,1)
DO SEL^IBDFDE21(SELECT)
DO CHK^IBDFDE22
GOTO VSTOVER
+61 IF $GET(@ARRAY@(ANS,1))
Begin DoDot:1
+62 ; -- more than one description the same
+63 SET SELECT=$$PARTLST^IBDFDE21(ARRAY,ANS,ANS)
End DoDot:1
IF $GET(SELECT)
DO SEL^IBDFDE21(SELECT)
DO CHK^IBDFDE22
GOTO VSTOVER
+64 ;
+65 ; -- next check for partial text answers
+66 SET NEXT=$ORDER(@ARRAY@(ANS))
Begin DoDot:1
+67 if NEXT=""!($EXTRACT(NEXT,1,$LENGTH(ANS))'=ANS)
QUIT
+68 IF $ORDER(@ARRAY@(NEXT,1))
SET SELECT=$$PARTLST^IBDFDE21(ARRAY,NEXT,ANS)
QUIT
+69 ;Not Unique answer
SET NEXT1=$ORDER(@ARRAY@(NEXT))
IF $EXTRACT(NEXT1,1,$LENGTH(ANS))=ANS
SET SELECT=$$PARTLST^IBDFDE21(ARRAY,NEXT,ANS)
QUIT
+70 WRITE $EXTRACT(NEXT,($LENGTH(ANS)+1),$LENGTH(NEXT))
+71 SET SELECT=$GET(@ARRAY@(NEXT,1))
End DoDot:1
IF SELECT
DO SEL^IBDFDE21(SELECT)
DO CHK^IBDFDE22
GOTO VSTOVER
+72 ;
+73 IF ANS'=""
SET SEL=$$OTHER^IBDFDE21(ANS)
IF SEL'=""
DO SEL^IBDFDE21(SEL)
DO CHK^IBDFDE22
GOTO VSTOVER
+74 IF ANS'=""
WRITE " ?? ",$CHAR(7),"Not Found"
GOTO OVER
+75 ;
VSTOVER KILL SELAST
if OVER
GOTO OVER
+1 IF $GET(ASKOTHER)
FOR
SET SEL=$$OTHER^IBDFDE21("")
if SEL=""
QUIT
DO SEL^IBDFDE21(SEL)
DO CHK^IBDFDE22
if '$GET(ASKOTHER)
QUIT
+2 ;
VSTQ ; -- kill array for dynamic lists
+1 IF $PIECE($GET(^IBE(357.6,IBDF("PI"),0)),"^",14)
if IBDF("PI")'=$GET(IBDF("PROVIDER PI"))
SET IBDF("DYNAMIC")=1
KILL ^TMP("IBD-LST",$JOB,IBDFMIEN,IBDF("PI")),^TMP("IBD-LTEXT",$JOB,IBDFMIEN,IBDF("PI")),^TMP("IBD-LCODE",$JOB,IBDFMIEN,IBDF("PI"))
+2 KILL ^TMP("IB",$JOB,"INTERFACES")
+3 KILL IBDF("OTHER"),ASKOTHER
+4 QUIT
