source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFDE22.m@ 619

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

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1IBDFDE22 ;ALB/AAS - AICS Data Entry, check selection rules ; 24-FEB-96
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4% G ^IBDFDE
5 ;
6CHK ; -- see if rules allow for more or less than one
7 ; rules 0 := select any number
8 ; 1 := exactly 1
9 ; 2 := at most 1
10 ; 3 := at least 1 (1 or more)
11 N I,IBDY,MATCH,OVERSAV
12 S (MATCH,OVER,OVERSAV,ASKOTHER)=0
13 ;
14 ; -- check all rules for list and enforce
15 S I=0 F S I=$O(RULE(I)) Q:I="" D I OVER S:OVER>OVERSAV OVERSAV=OVER
16 .;
17 .; -- find all matches for list, and qualifier
18 .S MATCH=0
19 .S IBDY=0 F S IBDY=$O(IBDPI(IBDF("PI"),IBDY)) Q:'IBDY I $P(IBDPI(IBDF("PI"),IBDY),"^",6)=QLFR(I) S MATCH=MATCH+1
20 .;
21 .; -- any number allowed
22 .I $G(RULE(+I))=0 D Q
23 ..I ANS="" S OVER=0 Q ;nothing selected, don't reask
24 ..I ANS'="" S OVER=1 Q ;something selected, reask
25 .;
26 .; -- exactly one required
27 .I $G(RULE(+I))=1 D Q
28 ..I MATCH>1 S OVER=2 W:'$G(IBDREDIT) !,"More than one selected, you must delete one" Q
29 ..I MATCH=1 S OVER=0 D DELQLF Q ;exactly one selected
30 ..I MATCH<1 S OVER=1 W:'$G(IBDREDIT) !!,"A ",IOINHI,IBDASK,IOINORM," selection is required"_$S(QLFR(I)="":"",1:" for "_IOINHI_QLFR(I)_IOINORM),".",! Q
31 .;
32 .; -- at most one required
33 .I $G(RULE(+I))=2 D Q
34 ..I MATCH>1 S OVER=2 W:'$G(IBDREDIT) !,"More than one selected, you must delete one" Q
35 ..I MATCH=1 S OVER=0 D DELQLF Q ;exactly one selected
36 ..I ANS'="",MATCH<1 S OVER=1 ;if match = 0 thats okay but ask
37 .;
38 .; -- at least one required
39 .I $G(RULE(+I))=3 D Q
40 ..S OVER=1
41 ..I MATCH<1 S OVER=1 W:'$G(IBDREDIT) !!,"A ",IOINHI,IBDASK,IOINORM," selection is required"_$S(QLFR(I)="":"",1:" for "_IOINHI_QLFR(I)_IOINORM),".",! Q
42 ..I MATCH>1,ANS="" S OVER=0 Q ;more than one selected
43 ..I MATCH=1,ANS="" S OVER=0 Q ;exactly one selected
44 ;
45 S OVER=OVERSAV
46 I OVER=2 D DEL^IBDFDE1
47CHKQ Q
48 ;
49DELQLF ; -- delete rule, qualifier
50 Q:RULE<2 ;must leave the last or only rule
51 I MATCH=1 S OVER=0 K RULE(I),QLFR(I) S RULE=RULE-1
52 Q
53 ;
54RULES ; -- look at zero node, find qualifiers and selection rule
55 N Q,R,CNT
56 S RULE=$P($$CHOICE^IBDFDE2(0),"^",3),QLFR="",CNT=0
57 ;
58 ; -- go thru rules, if primary then make #1
59 F IBD=1:1 S ROW=$P(RULE,"::",IBD) Q:ROW="" D
60 .S Q(IBD)=$P(ROW,";;",1),R(IBD)=$P(ROW,";;",2)
61 .I Q(IBD)="PRIMARY" D
62 ..S R(IBD)=$S(R(IBD)=3:1,R(IBD)=0:2,1:R(IBD))
63 ..S RULE(1)=R(IBD),QLFR(1)=Q(IBD),CNT=CNT+1 K R(IBD),Q(IBD)
64 S RULE=IBD-1
65 ;
66 ; -- make secondary #2 if primary exists, else #1
67 S IBD="" F S IBD=$O(R(IBD)) Q:'IBD I Q(IBD)="SECONDARY" S CNT=CNT+1,RULE(CNT)=R(IBD),QLFR(CNT)=Q(IBD) K R(IBD),Q(IBD) Q
68 ;
69 ; -- take the rest as they come
70 S IBD="" F S IBD=$O(R(IBD)) Q:'IBD S CNT=CNT+1,RULE(CNT)=R(IBD),QLFR(CNT)=Q(IBD)
71 ;
72 ;F IBD=1:1 S ROW=$P(RULE,"::",IBD) Q:ROW="" S QLFR(IBD)=$P(ROW,";;",1),RULE(IBD)=$P(ROW,";;",2) I QLFR(IBD)="PRIMARY" D
73 ;.S RULE(IBD)=$S(RULE(IBD)=3:1,RULE(IBD)=0:2,1:RULE(IBD))
74 ;S RULE=IBD-1
75 Q
Note: See TracBrowser for help on using the repository browser.