- 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 Jan 18, 2025@03:53:32 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