source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFDE4.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 4.9 KB
Line 
1IBDFDE4 ;ALB/AAS - AICS Manual Data Entry, process multiple choice fields ; 29-APR-96IOIN
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4% G ^IBDFDE
5 ;
6MULT(RESULT,IBDF) ; -- Procedure
7 ; -- Manual Data entry routine for Multiple Choice Fields
8 ; Input : Result := call by reference, used to output results
9 ; IBDF("IEN") := pointer to hand print file (359.94)
10 ; IBDF("PI") := pointer to input package interface
11 ; IBDF("DFN") := pointer to patient
12 ; IBDF("CLINIC") := pointer to hospital location
13 ;
14 ; output: Result(n) $p1 := pointer to package interface
15 ;
16 N I,J,X,Y,ANS,DISPTXT,HDR,DIR,DIRUT,DUOUT,DTOUT,IBDX,QLFR,CHOICE,OVER
17 S X="IOINHI;IOINORM" D ENDR^%ZISS
18 S (IBQUIT,OVER)=0,(ANS,QLFR)=""
19 I $G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),0))="" D
20 .D OBJLST^IBDFRPC1(.CHOICE,.IBDF)
21 .M ^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"))=CHOICE
22 .K CHOICE
23 .D COMPLST^IBDFDE5
24 I +$G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),0))<1 G MULTQ
25 S IBDASK=$P($P($G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),0)),"^",3),":")
26 I '$D(^TMP("IBD-ASK",$J,IBDFMIEN,IBDASK)) S ^TMP("IBD-ASK",$J,IBDFMIEN,$$UP^XLFSTR(IBDASK),IBDF("IBDF"))=""
27 S RULE=+$P($G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),0)),"^",4)
28 ;
29OVER ; -- ask or re-ask for selection(s) from list
30 IF RULE=0 S DIR("?",1)="Any Number of "_$G(IOINHI)_IBDASK_$G(IOINORM)_" allowed (including zero)."
31 IF RULE=1 S DIR("?",1)="Exactly one "_$G(IOINHI)_IBDASK_$G(IOINORM)_" Required."
32 IF RULE=2 S DIR("?",1)="At most one "_$G(IOINHI)_IBDASK_$G(IOINORM)_" allowed."
33 IF RULE=3 S DIR("?")="At least 1 (1 or more) "_$G(IOINHI)_IBDASK_$G(IOINORM)_" Required."
34 ;
35 S DIR("?",2)=""
36 S DIR("?")="Select an item from the form, enter by name or number. Enter '??' to see the choices. When editing, press enter to accept, '@' to delete, or enter a new selection."
37 ;
38 S DIR("??")="^D LST^IBDFDE41"
39 ;
40 S DIR(0)="FO^1:40^I $D(X),X="" "" K X W !!,$G(IOINHI),""Spacebar Return Not allowed!"",$G(IOINORM)"
41 I IBDASK[":" S $P(DIR(0),"^")="FOA"
42 S DIR("A")="Select "_$G(IBDASK)
43 D ^DIR K DIR
44 I $G(IBDEFLT(IBDF("PI")))'="",Y=IBDEFLT(IBDF("PI")) S Y="" ; on re-edit, accepting last entry same as entering nothing.
45 S ANS=$$UP^XLFSTR(Y)
46 I ANS="",$D(DIRUT),$G(IBDEFLT(IBDF("PI")))'="",$G(SELAST) K IBDPI(IBDF("PI"),SELAST),IBDSEL(SELAST) W " Deleted!" ;user type "@" at prompt
47 I ANS="" D CHK^IBDFDE42 G MCOVER
48 I ANS["^",ANS'="^" D G MCOVER
49 .S GOTO=$$UP^XLFSTR($P(ANS,"^",2))
50 .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
51 .S X=$O(^TMP("IBD-ASK",$J,IBDFMIEN,GOTO))
52 .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
53 .S IBQUIT=1
54 I $D(DIRUT) S IBQUIT=1 G MULTQ
55 S SELECT=0
56 ;
57 ;
58 ; -- first check for exact code matches
59 I $G(NUMBER(ANS)) S SELECT=$G(NUMBER(ANS)) D SEL^IBDFDE41(SELECT),CHK^IBDFDE42 G MCOVER
60 ;
61 ; -- check for exact text matches
62 S ARRAY="^TMP(""IBD-LTEXT"",$J,IBDFMIEN,IBDF(""PI""),IBDF(""IEN""))"
63 I $G(@ARRAY@(ANS,1)),'$O(@ARRAY@(ANS,1)) S SELECT=@ARRAY@(ANS,1) D SEL^IBDFDE41(SELECT),CHK^IBDFDE42 G MCOVER
64 I $G(@ARRAY@(ANS,1)) D I $G(SELECT) D SEL^IBDFDE41(SELECT),CHK^IBDFDE42 G MCOVER
65 .; -- more than one description the same
66 .S SELECT=$$PARTLST^IBDFDE41(ARRAY,ANS,ANS)
67 ;
68 ; -- next check for paritial text answers
69 S NEXT=$O(@ARRAY@(ANS)) D I SELECT D SEL^IBDFDE41(SELECT),CHK^IBDFDE42 G MCOVER
70 .Q:NEXT=""!($E(NEXT,1,$L(ANS))'=ANS)
71 .I $O(@ARRAY@(NEXT,1)) S SELECT=$$PARTLST^IBDFDE41(ARRAY,NEXT,ANS) Q
72 .S NEXT1=$O(@ARRAY@(NEXT)) I $E(NEXT1,1,$L(ANS))=ANS S SELECT=$$PARTLST^IBDFDE41(ARRAY,NEXT,ANS) Q ;Not Unique answer
73 .W $E(NEXT,($L(ANS)+1),$L(NEXT))
74 .S SELECT=$G(@ARRAY@(NEXT,1))
75 ;
76 I ANS'="" W " ?? ",$C(7),"Not Found" G OVER
77 ;
78MCOVER ;
79 G:OVER OVER
80 ;
81MULTQ ;
82 K ^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"))
83 K ^TMP("IBD-LTEXT",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"))
84 K ^TMP("IBD-LCODE",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"))
85 K ^TMP("IB",$J,"INTERFACES")
86 K IBDF("OTHER"),ASKOTHER
87 Q
88 ;
89ASKYN(DIR) ; -- input dir
90 N ANS,X
91 D ^DIR
92 I $G(IBDREDIT),Y=$G(DIR("B")) S ANS=DIR("B") G ASKYNQ
93 K DIR
94 S ANS=$$UP^XLFSTR(Y)
95 I ANS="" G ASKYNQ
96 I ANS["^",ANS'="^" D G ASKYNQ
97 .S GOTO=$$UP^XLFSTR($P(ANS,"^",2))
98 .S X=$O(^TMP("IBD-ASK",$J,IBDFMIEN,GOTO))
99 .;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
100 .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
101 .S IBQUIT=1
102 I $D(DIRUT) S IBQUIT=1
103ASKYNQ Q $G(ANS)
104 ;
105 Q
106TEST ;
107 S IBDFMIEN=9999
108 S IBDF("APPT")=2970331.1014
109 S IBDF("CLINIC")=300
110 S IBDF("DFN")=7169761
111 S IBDF("FORM")=33154
112 S IBDF("FRMDEF")=747
113 S IBDF("IBDF")=9
114 S IBDF("IEN")=213
115 S IBDF("TYPE")="MC"
116 S IBDF("PI")=92
117 D MULT(.RESULT,.IBDF)
118 Q
Note: See TracBrowser for help on using the repository browser.