source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFDE41.m@ 1608

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

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1IBDFDE41 ;ALB/AAS - AICS Data Entry, process selection lists ; 24-FEB-96 [ 11/13/96 3:58 PM ]
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4% G ^IBDFDE
5 ;
6SEL(SEL) ; -- Build results array
7 N IBDX,DSPTXT,IBQUIT,IBDQL,QCNT,IBDQLFR
8 S IBQUIT=0
9 ;
10 I +SEL=SEL S CHOICE=$G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),SEL))
11 I +SEL'=SEL S CHOICE=SEL
12 Q:IBQUIT
13 ;
14 ; -- build selections
15 S RESULT(0)=$G(RESULT(0))+1
16 W " ",$P(CHOICE,"^")," ",$P(CHOICE,"^",3)
17 ;
18 S RESULT(RESULT(0))=IBDF("PI")_"^"_$P(CHOICE,"^",4)_"^"_$P(CHOICE,"^")_"^^^"_$P(CHOICE,"^",3)_"^"_$G(IBDF("IEN"))
19 S IBDPI(IBDF("PI"),RESULT(0))=RESULT(RESULT(0))
20 ;
21 ; --validate code for active problem list
22 I $P($G(^IBE(357.6,IBDF("PI"),0)),"^")="PX INPUT PATIENT ACTIVE PROBLEM" D
23 .N X S X=$P(CHOICE,"^",2) Q:X=""
24 .I X=799.9 W !,$C(7),$G(IOINHI),"Warning: The ICD9 Diagnosis associated with this problem needs to be updated!",$G(IOINORM) Q
25 .D TESTICD^IBDFN7
26 .I '$D(X) W !,$C(7),$G(IOINHI),"Warning: The ICD9 code associated with this problem is inactive.",$G(IOINORM)
27 ;
28 Q
29 ;
30LST ; -- List previous selections and selections to choose from.
31 N I,CNT,IBQUIT,NUM
32 ;
33 ; -- list previous selections
34 D PREVSEL
35 ;
36 ; -- list available choices
37 S (IBQUIT,CNT)=0
38 S NUM=+$G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),0))
39 W !!,"Choose from: "
40 S I=0 F S I=$O(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),I)) Q:'I!(IBQUIT) D
41 .S CHOICE=$G(^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),I))
42 .S CNT=CNT+1,NUMBER(CNT)=I
43 .W !?3,CNT,?7,$S($P(CHOICE,"^",2)'="":$P(CHOICE,"^",2),1:$P(CHOICE,"^")),?20," ",$P(CHOICE,"^",3)
44 .I NUM>15,NUM>I,'(CNT#15) D PAUSE^IBDFDE I 'IBQUIT W $C(13),$J("",55),$C(13)
45 Q
46 ;
47PREVSEL ; -- List previous selections
48 N I,CNT
49 S CNT=0
50 ;
51 ; -- list previous selections
52 I $D(IBDPI(IBDF("PI")))>1 S I=0 F S I=$O(IBDPI(IBDF("PI"),I)) Q:'I D
53 .Q:$P(IBDPI(IBDF("PI"),I),"^",7)'=IBDF("IEN") ; not the same list
54 .S CNT=CNT+1
55 .W:CNT=1 !!,IOINHI," You have previously selected: ",IOINORM
56 .W !,?7,$S($P($G(^IBE(357.6,+IBDPI(IBDF("PI"),I),0)),"^")="GMP INPUT CLINIC COMMON PROBLEMS":$$LEX^IBDFDE1($P(IBDPI(IBDF("PI"),I),"^",2)),1:$P(IBDPI(IBDF("PI"),I),"^",2))
57 .W ?16,$P(IBDPI(IBDF("PI"),I),"^",3),?50,$P(IBDPI(IBDF("PI"),I),"^",6)
58 W !
59 Q
60 ;
61DEFAULT ; -- compute default answer
62 N CNT,SEL,NAME,PIECE,SELAST
63 S (CNT,SEL,SELAST)=0
64 S NAME=$P($G(^IBE(357.6,+IBDF("PI"),0)),"^")
65 S PIECE=$S(NAME["INPUT PROCEDURE CODE":2,NAME["INPUT DIAGNOSIS CODE":2,NAME["INPUT VISIT TYPE":2,1:3)
66 F S SEL=$O(IBDPI(IBDF("PI"),SEL)) Q:'SEL D
67 .Q:$P(IBDPI(IBDF("PI"),SEL),"^",7)'=IBDF("IEN") ; not the same list
68 .S CNT=CNT+1,SELAST=SEL
69 I $G(SELAST) S DIR("B")=$P(IBDPI(IBDF("PI"),SELAST),"^",PIECE),IBDEFLT(IBDF("PI"))=DIR("B")
70 D PREVSEL
71 Q
72 ;
73PARTLST(ARY,NEXT,ANS) ; -- input has more than one match, prompt for which one
74 N I,J,K,N,IBD,ANS2,SEL,CHOICE
75 S SEL=0
76 S NEXT=$E(NEXT,1,$L(NEXT)-1)_$C($A($E(NEXT,$L(NEXT)))-1)_"~"
77 ;
78 S J=0,K=NEXT F S K=$O(@ARY@(K)) Q:$E(K,1,$L(ANS))'=ANS D
79 .S N=0 F S N=$O(@ARY@(K,N)) Q:'N D
80 ..S J=J+1,IBD(J)=@ARY@(K,N),CHOICE=$$CHOICE^IBDFDE2(IBD(J))
81 ..W !?6,J,?10,$S($P(CHOICE,"^",2)'="":$P(CHOICE,"^",2),1:$P(CHOICE,"^",3)),?20,$P(CHOICE,"^",1),?50," ",$P(CHOICE,"^",8)," ",$P(CHOICE,"^",4)
82 ;
83ASKNUM I J<1 G PARTLQ
84 W !," Choose 1-",J,": " R ANS2:DTIME
85 I '$T!($E(ANS2,1)="^")!(ANS2="") S SEL="" G PARTLQ
86 I $E(ANS2,1)="?" W !,"Enter a number from 1 - ",J G ASKNUM
87 S ANS2=+ANS2
88 I ANS2<1!(ANS2>J) G ASKNUM
89 I $G(IBD(ANS2))="" G ASKNUM
90 W !
91 S SEL=$G(IBD(ANS2))
92PARTLQ Q SEL
Note: See TracBrowser for help on using the repository browser.