Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDFDE42

IBDFDE42.m

Go to the documentation of this file.
  1. IBDFDE42 ;ALB/AAS - AICS Data Entry, check selection rules ; 24-FEB-96
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
  1. ;
  1. % G ^IBDFDE
  1. ;
  1. CHK ; -- see if rules allow for more or less than one
  1. ; rules 0 := select any number
  1. ; 1 := exactly 1
  1. ; 2 := at most 1
  1. ; 3 := at least 1 (1 or more)
  1. N I,IBDY,MATCH
  1. S (MATCH,OVER,ASKOTHER)=0
  1. ;
  1. ; -- find all matches
  1. S MATCH=0
  1. S IBDY=0 F S IBDY=$O(IBDPI(IBDF("PI"),IBDY)) Q:'IBDY S MATCH=MATCH+1
  1. ;
  1. ; -- any number allowed
  1. I RULE=0 D
  1. .I ANS="" S OVER=0 Q ;nothing selected, don't reask
  1. .I ANS'="" S OVER=1 Q ;something selected, reask
  1. ;
  1. ; -- exactly one required
  1. I RULE=1 D
  1. .I MATCH>1 S OVER=2 W:'$G(IBDREDIT) !,"More than one selected, you must delete one" Q
  1. .I MATCH=1 S OVER=0 Q ;exactly one selected
  1. .I MATCH<1 S OVER=1 W:'$G(IBDREDIT) !!,"A ",IOINHI,IBDASK,IOINORM," selection is required.",! Q
  1. ;
  1. ; -- at most one required
  1. I RULE=2 D
  1. .I MATCH>1 S OVER=2 W:'$G(IBDREDIT) !,"More than one selected, you must delete one" Q
  1. .I MATCH=1 S OVER=0 Q ;exactly one selected
  1. .I ANS'="",MATCH<1 S OVER=1 ;if match = 0 thats okay but ask
  1. ;
  1. ; -- at least one required
  1. I RULE=3 D
  1. .S OVER=1
  1. .I MATCH<1 S OVER=1 W:'$G(IBDREDIT) !!,"A ",IOINHI,IBDASK,IOINORM," selection is required.",! Q
  1. .I MATCH>1,ANS="" S OVER=0 Q ;more than one selected
  1. .I MATCH=1,ANS="" S OVER=0 Q ;exactly one selected
  1. ;
  1. I OVER=2 D DEL^IBDFDE1
  1. D DELQLF
  1. CHKQ Q
  1. ;
  1. DELQLF ; -- delete choices if selected
  1. Q:(+$G(SEL)=0)
  1. K ^TMP("IBD-LST",$J,IBDFMIEN,IBDF("PI"),IBDF("IEN"),+$G(SEL))
  1. Q