- IBDFDE22 ;ALB/AAS - AICS Data Entry, check selection rules ; 24-FEB-96
- ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
- ;
- % G ^IBDFDE
- ;
- CHK ; -- see if rules allow for more or less than one
- ; rules 0 := select any number
- ; 1 := exactly 1
- ; 2 := at most 1
- ; 3 := at least 1 (1 or more)
- N I,IBDY,MATCH,OVERSAV
- S (MATCH,OVER,OVERSAV,ASKOTHER)=0
- ;
- ; -- check all rules for list and enforce
- S I=0 F S I=$O(RULE(I)) Q:I="" D I OVER S:OVER>OVERSAV OVERSAV=OVER
- .;
- .; -- find all matches for list, and qualifier
- .S MATCH=0
- .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
- .;
- .; -- any number allowed
- .I $G(RULE(+I))=0 D Q
- ..I ANS="" S OVER=0 Q ;nothing selected, don't reask
- ..I ANS'="" S OVER=1 Q ;something selected, reask
- .;
- .; -- exactly one required
- .I $G(RULE(+I))=1 D Q
- ..I MATCH>1 S OVER=2 W:'$G(IBDREDIT) !,"More than one selected, you must delete one" Q
- ..I MATCH=1 S OVER=0 D DELQLF Q ;exactly one selected
- ..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
- .;
- .; -- at most one required
- .I $G(RULE(+I))=2 D Q
- ..I MATCH>1 S OVER=2 W:'$G(IBDREDIT) !,"More than one selected, you must delete one" Q
- ..I MATCH=1 S OVER=0 D DELQLF Q ;exactly one selected
- ..I ANS'="",MATCH<1 S OVER=1 ;if match = 0 thats okay but ask
- .;
- .; -- at least one required
- .I $G(RULE(+I))=3 D Q
- ..S OVER=1
- ..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
- ..I MATCH>1,ANS="" S OVER=0 Q ;more than one selected
- ..I MATCH=1,ANS="" S OVER=0 Q ;exactly one selected
- ;
- S OVER=OVERSAV
- I OVER=2 D DEL^IBDFDE1
- CHKQ Q
- ;
- DELQLF ; -- delete rule, qualifier
- Q:RULE<2 ;must leave the last or only rule
- I MATCH=1 S OVER=0 K RULE(I),QLFR(I) S RULE=RULE-1
- Q
- ;
- RULES ; -- look at zero node, find qualifiers and selection rule
- N Q,R,CNT
- S RULE=$P($$CHOICE^IBDFDE2(0),"^",3),QLFR="",CNT=0
- ;
- ; -- go thru rules, if primary then make #1
- F IBD=1:1 S ROW=$P(RULE,"::",IBD) Q:ROW="" D
- .S Q(IBD)=$P(ROW,";;",1),R(IBD)=$P(ROW,";;",2)
- .I Q(IBD)="PRIMARY" D
- ..S R(IBD)=$S(R(IBD)=3:1,R(IBD)=0:2,1:R(IBD))
- ..S RULE(1)=R(IBD),QLFR(1)=Q(IBD),CNT=CNT+1 K R(IBD),Q(IBD)
- S RULE=IBD-1
- ;
- ; -- make secondary #2 if primary exists, else #1
- 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
- ;
- ; -- take the rest as they come
- S IBD="" F S IBD=$O(R(IBD)) Q:'IBD S CNT=CNT+1,RULE(CNT)=R(IBD),QLFR(CNT)=Q(IBD)
- ;
- ;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
- ;.S RULE(IBD)=$S(RULE(IBD)=3:1,RULE(IBD)=0:2,1:RULE(IBD))
- ;S RULE=IBD-1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFDE22 2968 printed Feb 19, 2025@00:18:42 Page 2
- IBDFDE22 ;ALB/AAS - AICS Data Entry, check selection rules ; 24-FEB-96
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
- +2 ;
- % GOTO ^IBDFDE
- +1 ;
- CHK ; -- see if rules allow for more or less than one
- +1 ; rules 0 := select any number
- +2 ; 1 := exactly 1
- +3 ; 2 := at most 1
- +4 ; 3 := at least 1 (1 or more)
- +5 NEW I,IBDY,MATCH,OVERSAV
- +6 SET (MATCH,OVER,OVERSAV,ASKOTHER)=0
- +7 ;
- +8 ; -- check all rules for list and enforce
- +9 SET I=0
- FOR
- SET I=$ORDER(RULE(I))
- if I=""
- QUIT
- Begin DoDot:1
- +10 ;
- +11 ; -- find all matches for list, and qualifier
- +12 SET MATCH=0
- +13 SET IBDY=0
- FOR
- SET IBDY=$ORDER(IBDPI(IBDF("PI"),IBDY))
- if 'IBDY
- QUIT
- IF $PIECE(IBDPI(IBDF("PI"),IBDY),"^",6)=QLFR(I)
- SET MATCH=MATCH+1
- +14 ;
- +15 ; -- any number allowed
- +16 IF $GET(RULE(+I))=0
- Begin DoDot:2
- +17 ;nothing selected, don't reask
- IF ANS=""
- SET OVER=0
- QUIT
- +18 ;something selected, reask
- IF ANS'=""
- SET OVER=1
- QUIT
- End DoDot:2
- QUIT
- +19 ;
- +20 ; -- exactly one required
- +21 IF $GET(RULE(+I))=1
- Begin DoDot:2
- +22 IF MATCH>1
- SET OVER=2
- if '$GET(IBDREDIT)
- WRITE !,"More than one selected, you must delete one"
- QUIT
- +23 ;exactly one selected
- IF MATCH=1
- SET OVER=0
- DO DELQLF
- QUIT
- +24 IF MATCH<1
- SET OVER=1
- if '$GET(IBDREDIT)
- WRITE !!,"A ",IOINHI,IBDASK,IOINORM," selection is required"_$SELECT(QLFR(I)="":"",1:" for "_IOINHI_QLFR(I)_IOINORM),".",!
- QUIT
- End DoDot:2
- QUIT
- +25 ;
- +26 ; -- at most one required
- +27 IF $GET(RULE(+I))=2
- Begin DoDot:2
- +28 IF MATCH>1
- SET OVER=2
- if '$GET(IBDREDIT)
- WRITE !,"More than one selected, you must delete one"
- QUIT
- +29 ;exactly one selected
- IF MATCH=1
- SET OVER=0
- DO DELQLF
- QUIT
- +30 ;if match = 0 thats okay but ask
- IF ANS'=""
- IF MATCH<1
- SET OVER=1
- End DoDot:2
- QUIT
- +31 ;
- +32 ; -- at least one required
- +33 IF $GET(RULE(+I))=3
- Begin DoDot:2
- +34 SET OVER=1
- +35 IF MATCH<1
- SET OVER=1
- if '$GET(IBDREDIT)
- WRITE !!,"A ",IOINHI,IBDASK,IOINORM," selection is required"_$SELECT(QLFR(I)="":"",1:" for "_IOINHI_QLFR(I)_IOINORM),".",!
- QUIT
- +36 ;more than one selected
- IF MATCH>1
- IF ANS=""
- SET OVER=0
- QUIT
- +37 ;exactly one selected
- IF MATCH=1
- IF ANS=""
- SET OVER=0
- QUIT
- End DoDot:2
- QUIT
- End DoDot:1
- IF OVER
- if OVER>OVERSAV
- SET OVERSAV=OVER
- +38 ;
- +39 SET OVER=OVERSAV
- +40 IF OVER=2
- DO DEL^IBDFDE1
- CHKQ QUIT
- +1 ;
- DELQLF ; -- delete rule, qualifier
- +1 ;must leave the last or only rule
- if RULE<2
- QUIT
- +2 IF MATCH=1
- SET OVER=0
- KILL RULE(I),QLFR(I)
- SET RULE=RULE-1
- +3 QUIT
- +4 ;
- RULES ; -- look at zero node, find qualifiers and selection rule
- +1 NEW Q,R,CNT
- +2 SET RULE=$PIECE($$CHOICE^IBDFDE2(0),"^",3)
- SET QLFR=""
- SET CNT=0
- +3 ;
- +4 ; -- go thru rules, if primary then make #1
- +5 FOR IBD=1:1
- SET ROW=$PIECE(RULE,"::",IBD)
- if ROW=""
- QUIT
- Begin DoDot:1
- +6 SET Q(IBD)=$PIECE(ROW,";;",1)
- SET R(IBD)=$PIECE(ROW,";;",2)
- +7 IF Q(IBD)="PRIMARY"
- Begin DoDot:2
- +8 SET R(IBD)=$SELECT(R(IBD)=3:1,R(IBD)=0:2,1:R(IBD))
- +9 SET RULE(1)=R(IBD)
- SET QLFR(1)=Q(IBD)
- SET CNT=CNT+1
- KILL R(IBD),Q(IBD)
- End DoDot:2
- End DoDot:1
- +10 SET RULE=IBD-1
- +11 ;
- +12 ; -- make secondary #2 if primary exists, else #1
- +13 SET IBD=""
- FOR
- SET IBD=$ORDER(R(IBD))
- if 'IBD
- QUIT
- IF Q(IBD)="SECONDARY"
- SET CNT=CNT+1
- SET RULE(CNT)=R(IBD)
- SET QLFR(CNT)=Q(IBD)
- KILL R(IBD),Q(IBD)
- QUIT
- +14 ;
- +15 ; -- take the rest as they come
- +16 SET IBD=""
- FOR
- SET IBD=$ORDER(R(IBD))
- if 'IBD
- QUIT
- SET CNT=CNT+1
- SET RULE(CNT)=R(IBD)
- SET QLFR(CNT)=Q(IBD)
- +17 ;
- +18 ;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
- +19 ;.S RULE(IBD)=$S(RULE(IBD)=3:1,RULE(IBD)=0:2,1:RULE(IBD))
- +20 ;S RULE=IBD-1
- +21 QUIT
