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 Dec 13, 2024@02:52:17 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
