- 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 Mar 13, 2025@21:57:17 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
