135 lines
7.4 KiB
Mathematica
135 lines
7.4 KiB
Mathematica
IBDFDE2 ;ALB/AAS - AICS Data Entry, process selection lists ; 24-FEB-96
|
|
;;3.0;AUTOMATED INFO COLLECTION SYS;**4**;APR 24, 1997
|
|
;
|
|
% 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 dyamic 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 paritial 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 paritial 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
|