| 1 | IBDFDE22 ;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 | ;
|
|---|
| 6 | CHK ; -- 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
|
|---|
| 47 | CHKQ Q
|
|---|
| 48 | ;
|
|---|
| 49 | DELQLF ; -- 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 | ;
|
|---|
| 54 | RULES ; -- 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
|
|---|
