source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFDE2.m@ 1504

Last change on this file since 1504 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 7.4 KB
Line 
1IBDFDE2 ;ALB/AAS - AICS Data Entry, process selection lists ; 24-FEB-96
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**4**;APR 24, 1997
3 ;
4% G ^IBDFDE
5 ;
6CHOICE(I) ; -- return ^tmp(ibd-lst,ibdfmien,ibdf(pi),ibdf(ien),i)
7 Q $G(^TMP("IBD-LST",$J,+$G(IBDFMIEN),+$G(IBDF("PI")),+$G(IBDF("IEN")),+$G(I)))
8 ;
9LIST(RESULT,IBDF,IBDASK) ; -- Procedure
10 ; -- Manual Data entry routine for Visit Type input
11 ; Input : Result := call by reference, used to output results
12 ; IBDF("IEN") := pointer to selection list (357.2)
13 ; IBDF("PI") := pointer to input package interface
14 ; IBDF("DFN") := pointer to patient (required for dynamic lists only)
15 ; IBDF("CLINIC") := pointer to hospital location (required for dyamic lists only)
16 ;
17 ; Output: Selections for input in IBDFDE1 (and eventually IBDFRPC4)
18 ; RESULT(0) := count of selections (including previous)
19 ; RESULT(n) $p1 := package interface
20 ; $p2 := Code to send (usually ien)
21 ; $p3 := Text to send (from form or additional text)
22 ; $p4 := Header to send (from form) (optional)
23 ; $p5 := Clinical lexicon pointer (from 357.2) (optional)
24 ; $p6 := qualifier (optional)
25 ; $p7 := ien of list (in 357.2)
26 ; $p10 := external value (optional)
27 ;
28 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
29 S X="IOINHI;IOINORM" D ENDR^%ZISS
30 S IBQUIT=0,ANS=""
31 I IBDF("TYPE")="MC" D MULT^IBDFDE4(.RESULT,.IBDF) G VSTQ
32 ;
33 ; -- check required variables
34 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
35 ;
36 S VAR="^TMP(""IBD-LST"",$J,"_+$G(IBDFMIEN)_","_+$G(IBDF("PI"))_","_+$G(IBDF("IEN"))_")"
37 I $$CHOICE(0)="" D OBJLST^IBDFRPC1(VAR,.IBDF) D COMPLST^IBDFDE5
38 ;
39 I '$D(^TMP("IBD-ASK",$J,IBDFMIEN,IBDASK)),$G(IBDF("IBDF")) S ^TMP("IBD-ASK",$J,IBDFMIEN,$$UP^XLFSTR(IBDASK),IBDF("IBDF"))=""
40 ;
41 I +$$CHOICE(0)<1,+$G(IBDF("PROVIDER PI"))'=IBDF("PI") G VSTQ ;list is empty, don't ask, unless its provider
42 ;
43 ; -- look at zero node, find qualifiers and selection rule
44 D RULES^IBDFDE22
45 ;
46 I $G(IBDREDIT) S ANS=" " D CHK^IBDFDE22 S ANS="" G:'OVER VSTQ N IBDREDIT
47 ;
48 ; -- set dir("b")
49 I $D(IBDPI(IBDF("PI")))>1 D DEFAULT^IBDFDE21
50 ;
51OVER ; -- ask or re-ask for selection(s) from list
52 S OVER=0
53 S CNTH=1,I=0 F S I=$O(RULE(I)) Q:'I D
54 . 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
55 . 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
56 . 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
57 . 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
58 ;
59 S DIR("?",CNTH)="",CNTH=CNTH+1
60 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."
61 I $G(IBDF("OTHER")) S DIR("?")=DIR("?")_" Or enter an item written on the form."
62 ;
63 S DIR("??")="^D LST^IBDFDE21"
64 ;
65 ; -- default provider is 1st provider
66 I +$G(IBDF("PROVIDER PI"))=IBDF("PI") D I $G(SELECT) D SEL^IBDFDE21(SELECT),CHK^IBDFDE22 K IBNAQLFR G VSTOVER
67 .S SELECT=0
68 .I $G(IBDF("PROVIDER")) Q
69 .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
70 .Q:$P(IBDF("PROVIDER PI"),"^",2) ;not on form don't ask if not default
71 .Q:$D(IBDPI(IBDF("PI"))) ;one already select
72 .I $$PRDEF^IBDFRPC3(IBDF("CLINIC")) S DIR("B")=$P($$CHOICE(1),"^")
73 ;
74 S DIR(0)="FO^1:40^I $D(X),X="" "" K X W !!,$G(IOINHI),""Spacebar Return Not allowed!"",$G(IOINORM)"
75 S DIR("A")="Select "_$G(IBDASK)
76 I $G(^TMP("IBD-PI-CNT",$J,IBDF("PI")))>1 S DIR("A")=DIR("A")_" (Page "_IBDF("PAGE")_")"
77 D ^DIR K DIR
78 I $G(IBDEFLT(IBDF("PI")))'="",Y=IBDEFLT(IBDF("PI")) S Y="" ; on re-edit, accepting last entry same as entering nothing.
79 S ANS=$$UP^XLFSTR(Y)
80 I ANS="",$D(DIRUT),$G(IBDEFLT(IBDF("PI")))'="",$G(SELAST) K IBDPI(IBDF("PI"),SELAST),IBDSEL(SELAST) W " Deleted!" ;user type "@" at prompt
81 I ANS="" D CHK^IBDFDE22 G VSTOVER
82 I ANS["^",ANS'="^" D G VSTOVER
83 .S GOTO=$$UP^XLFSTR($P(ANS,"^",2))
84 .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
85 .S X=$O(^TMP("IBD-ASK",$J,IBDFMIEN,GOTO))
86 .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
87 .S IBQUIT=1
88 I $D(DIRUT) S IBQUIT=1 G VSTQ
89 S SELECT=0
90 ;
91 ; -- first check for exact code matches
92 I $G(NUMBER(ANS)) S SELECT=$G(NUMBER(ANS)) D SEL^IBDFDE21(SELECT),CHK^IBDFDE22 G VSTOVER
93 ;
94 S ARRAY="^TMP(""IBD-LCODE"",$J,IBDFMIEN,IBDF(""PI""),IBDF(""IEN""))"
95 I $G(@ARRAY@(" "_ANS,1)),'$O(@ARRAY@(" "_ANS,1)) S SELECT=@ARRAY@(" "_ANS,1) D SEL^IBDFDE21(SELECT),CHK^IBDFDE22 G VSTOVER
96 I $G(@ARRAY@(" "_ANS,1)) D I $G(SELECT) D SEL^IBDFDE21(SELECT),CHK^IBDFDE22 G VSTOVER
97 .; -- more than one code the same number
98 .S SELECT=$$PARTLST^IBDFDE21(ARRAY," "_ANS," "_ANS)
99 ;
100 ; -- next check for paritial code answers
101 S ANS1=" "_ANS
102 S NEXT=$O(@ARRAY@(ANS1)) D I SELECT D SEL^IBDFDE21(SELECT),CHK^IBDFDE22 G VSTOVER
103 .Q:NEXT=""!($E(NEXT,1,$L(ANS1))'=ANS1)
104 .I $O(@ARRAY@(NEXT,1)) S SELECT=$$PARTLST^IBDFDE21(ARRAY,NEXT,ANS1) Q
105 .S NEXT1=$O(@ARRAY@(NEXT)) I $E(NEXT1,1,$L(ANS1))=ANS1 S SELECT=$$PARTLST^IBDFDE21(ARRAY,NEXT,ANS1) Q ;Not Unique answer
106 .W $E(NEXT,($L(ANS1)+1),$L(NEXT))
107 .S SELECT=$G(@ARRAY@(NEXT,1))
108 ;
109 ; -- check for exact text matches
110 S ARRAY="^TMP(""IBD-LTEXT"",$J,IBDFMIEN,IBDF(""PI""),IBDF(""IEN""))"
111 I $G(@ARRAY@(ANS,1)),'$O(@ARRAY@(ANS,1)) S SELECT=@ARRAY@(ANS,1) D SEL^IBDFDE21(SELECT),CHK^IBDFDE22 G VSTOVER
112 I $G(@ARRAY@(ANS,1)) D I $G(SELECT) D SEL^IBDFDE21(SELECT),CHK^IBDFDE22 G VSTOVER
113 .; -- more than one description the same
114 .S SELECT=$$PARTLST^IBDFDE21(ARRAY,ANS,ANS)
115 ;
116 ; -- next check for paritial text answers
117 S NEXT=$O(@ARRAY@(ANS)) D I SELECT D SEL^IBDFDE21(SELECT),CHK^IBDFDE22 G VSTOVER
118 .Q:NEXT=""!($E(NEXT,1,$L(ANS))'=ANS)
119 .I $O(@ARRAY@(NEXT,1)) S SELECT=$$PARTLST^IBDFDE21(ARRAY,NEXT,ANS) Q
120 .S NEXT1=$O(@ARRAY@(NEXT)) I $E(NEXT1,1,$L(ANS))=ANS S SELECT=$$PARTLST^IBDFDE21(ARRAY,NEXT,ANS) Q ;Not Unique answer
121 .W $E(NEXT,($L(ANS)+1),$L(NEXT))
122 .S SELECT=$G(@ARRAY@(NEXT,1))
123 ;
124 I ANS'="" S SEL=$$OTHER^IBDFDE21(ANS) I SEL'="" D SEL^IBDFDE21(SEL),CHK^IBDFDE22 G VSTOVER
125 I ANS'="" W " ?? ",$C(7),"Not Found" G OVER
126 ;
127VSTOVER K SELAST G:OVER OVER
128 I $G(ASKOTHER) F S SEL=$$OTHER^IBDFDE21("") Q:SEL="" D SEL^IBDFDE21(SEL),CHK^IBDFDE22 Q:'$G(ASKOTHER)
129 ;
130VSTQ ; -- kill array for dynamic lists
131 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"))
132 K ^TMP("IB",$J,"INTERFACES")
133 K IBDF("OTHER"),ASKOTHER
134 Q
Note: See TracBrowser for help on using the repository browser.