IBDFDE42 ;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
S (MATCH,OVER,ASKOTHER)=0
;
; -- find all matches
S MATCH=0
S IBDY=0 F S IBDY=$O(IBDPI(IBDF("PI"),IBDY)) Q:'IBDY S MATCH=MATCH+1
;
; -- any number allowed
I RULE=0 D
.I ANS="" S OVER=0 Q ;nothing selected, don't reask
.I ANS'="" S OVER=1 Q ;something selected, reask
;
; -- exactly one required
I RULE=1 D
.I MATCH>1 S OVER=2 W:'$G(IBDREDIT) !,"More than one selected, you must delete one" Q
.I MATCH=1 S OVER=0 Q ;exactly one selected
.I MATCH<1 S OVER=1 W:'$G(IBDREDIT) !!,"A ",IOINHI,IBDASK,IOINORM," selection is required.",! Q
;
; -- at most one required
I RULE=2 D
.I MATCH>1 S OVER=2 W:'$G(IBDREDIT) !,"More than one selected, you must delete one" Q
.I MATCH=1 S OVER=0 Q ;exactly one selected
.I ANS'="",MATCH<1 S OVER=1 ;if match = 0 thats okay but ask
;
; -- at least one required
I RULE=3 D
.S OVER=1
.I MATCH<1 S OVER=1 W:'$G(IBDREDIT) !!,"A ",IOINHI,IBDASK,IOINORM," selection is required.",! Q
.I MATCH>1,ANS="" S OVER=0 Q ;more than one selected
.I MATCH=1,ANS="" S OVER=0 Q ;exactly one selected
;
I OVER=2 D DEL^IBDFDE1
D DELQLF
CHKQ Q
;
DELQLF ; -- delete choices if selected
Q:(+$G(SEL)=0)
K ^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),+$G(SEL))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFDE42 1605 printed Dec 13, 2024@02:52:21 Page 2
IBDFDE42 ;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
+6 SET (MATCH,OVER,ASKOTHER)=0
+7 ;
+8 ; -- find all matches
+9 SET MATCH=0
+10 SET IBDY=0
FOR
SET IBDY=$ORDER(IBDPI(IBDF("PI"),IBDY))
if 'IBDY
QUIT
SET MATCH=MATCH+1
+11 ;
+12 ; -- any number allowed
+13 IF RULE=0
Begin DoDot:1
+14 ;nothing selected, don't reask
IF ANS=""
SET OVER=0
QUIT
+15 ;something selected, reask
IF ANS'=""
SET OVER=1
QUIT
End DoDot:1
+16 ;
+17 ; -- exactly one required
+18 IF RULE=1
Begin DoDot:1
+19 IF MATCH>1
SET OVER=2
if '$GET(IBDREDIT)
WRITE !,"More than one selected, you must delete one"
QUIT
+20 ;exactly one selected
IF MATCH=1
SET OVER=0
QUIT
+21 IF MATCH<1
SET OVER=1
if '$GET(IBDREDIT)
WRITE !!,"A ",IOINHI,IBDASK,IOINORM," selection is required.",!
QUIT
End DoDot:1
+22 ;
+23 ; -- at most one required
+24 IF RULE=2
Begin DoDot:1
+25 IF MATCH>1
SET OVER=2
if '$GET(IBDREDIT)
WRITE !,"More than one selected, you must delete one"
QUIT
+26 ;exactly one selected
IF MATCH=1
SET OVER=0
QUIT
+27 ;if match = 0 thats okay but ask
IF ANS'=""
IF MATCH<1
SET OVER=1
End DoDot:1
+28 ;
+29 ; -- at least one required
+30 IF RULE=3
Begin DoDot:1
+31 SET OVER=1
+32 IF MATCH<1
SET OVER=1
if '$GET(IBDREDIT)
WRITE !!,"A ",IOINHI,IBDASK,IOINORM," selection is required.",!
QUIT
+33 ;more than one selected
IF MATCH>1
IF ANS=""
SET OVER=0
QUIT
+34 ;exactly one selected
IF MATCH=1
IF ANS=""
SET OVER=0
QUIT
End DoDot:1
+35 ;
+36 IF OVER=2
DO DEL^IBDFDE1
+37 DO DELQLF
CHKQ QUIT
+1 ;
DELQLF ; -- delete choices if selected
+1 if (+$GET(SEL)=0)
QUIT
+2 KILL ^TMP("IBD-LST",$JOB,IBDFMIEN,IBDF("PI"),IBDF("IEN"),+$GET(SEL))
+3 QUIT
