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

BGUCND.m

Go to the documentation of this file.
BGUCND ; IHS/OIT/MJL - CONDITION HANDLER ; [ 12/01/2005  3:27 PM ]
 ;;1.5;BGU;**2**;MAY 26, 2005
 ;
 ; BLDCND BUILDS THE CONDITION ARRAY THAT IS USED BY CND TO SET A TRUTH
 ; VALUE.  CALL BLDCND DURING THE CALLING APPLICATIONS INIT OR WHENEVER
 ; A NEW CONDITON IS NEEDED.
 ;
 ; DO INIT FIRST IF TESTING SEPARATELY
 ;
 ; USE FOR TESTING -- D INIT,BLDCND,CND
 D INIT,BLDCND,CND,KILL
 Q
 ;
KILL ;EP Called by BGULIST
 K BGUCARY,BGUCC,BGUCEXP,BGUCEXP1,BGUCF,BGUCFID,BGUCLCNJ,BGUCLSEG,BGUCLV,BGUCMXL,BGUCN,BGUCN1,BGUCN2,BGUCN3,BGUCN4,BGUCND,BGUCNDS1,BGUCNJN,BGUCNJP,BGUCNOT,BGUCONJ,BGUCQ,BGUCSBJ,BGUCSBS,BGUCSEG,BGUCSUB,BGUCTV,BGUCVAL,BGUCWRDS
 K BGUCX,BGUTV(1)
 Q
 ;
INIT ;
 S U="^",BGUFILE=2
 ;S BGUCNDS="SEX=""M"" OR (AGE .GT. 64 AND (S>139 OR D >89) AND W<300) AND SEX .PM. 1""M"""
 S BGUCNDS=".02=""M"" AND .033 .GT. 64"
 ;S BGUV(BGUFILE,"SEX")="M",BGUV(BGUFILE,"AGE")=65,BGUV(BGUFILE,"S")=140,BGUV(BGUFILE,"D")=89,BGUV(BGUFILE,"W")=300
 ;S BGUV(5,".02")="M",BGUV(BGUFILE,"AGE")=65,BGUV(BGUFILE,"S")=140,BGUV(BGUFILE,"D")=89,BGUV(BGUFILE,"W")=300
 Q
 ;
 ; Input  : BGUCNDS
 ; Output : BGUCND
BLDCND ;EP Called by BGULIST2
 K BGUCND
 S BGUCLV=0,BGUCMXL=0,BGUCARY="BGUCND"
 S BGUCOND="LT:<,LE:<=,GT:>,GE:>=,EQ:=,NE:<>,CT:[,NC:'[,PM:?,NP:'?"
 F BGUCN=1:1:$L(BGUCOND,",") S BGUCOND1=$P(BGUCOND,",",BGUCN),BGUCOND($P(BGUCOND1,":",1))=$P(BGUCOND1,":",2)
 S BGUCOND="" K BGUCOND1
 F BGUCN=1:1:$L(BGUCNDS,"(") S BGUCNDS1=$P(BGUCNDS,"(",BGUCN) D:BGUCNDS1'?." "
 .S BGUCLV=BGUCLV+1 S:BGUCLV=1 BGUCARY=$P(BGUCARY,"(") I BGUCLV>1 S:BGUCLV=2 BGUCARY=BGUCARY_"(" S BGUCARY=$P(BGUCARY,")") S:BGUCLV>2 BGUCARY=BGUCARY_"," S BGUCARY=BGUCARY_BGUCSUB(BGUCLV-1)_")"
 .S BGUCEXP=$P(BGUCNDS1,")") D BLDEXP
 .I BGUCNDS1[")" F BGUCN2=2:1:$L(BGUCNDS1,")") S BGUCLV=BGUCLV-1,BGUCEXP=$P(BGUCNDS1,")",BGUCN2) I BGUCEXP'?." " S BGUCARY=$S(BGUCLV>1:$P(BGUCARY,",",1,BGUCLV-1)_")",1:$P(BGUCARY,"(")) D BLDEXP
 S BGUCMXL=BGUCMXL*2
 K BGUCARY,BGUCC,BGUCEXP,BGUCEXP1,BGUCLCNJ,BGUCLSEG,BGUCLV,BGUCN,BGUCN1,BGUCN2,BGUCN3,BGUCN4,BGUCNDS1,BGUCNJN,BGUCNJP,BGUCOND,BGUCSBJ,BGUCSBJL,BGUCSEG,BGUCSUB,BGUCVAL,BGUCWRDS
 Q
 ;
BLDEXP ;
 S (BGUCSEG,BGUCNJP,BGUCNJN,BGUCLCNJ)="",BGUCWRDS=$L(BGUCEXP," ")
 F BGUCN3=1:1:BGUCWRDS S BGUCEXP1=$P(BGUCEXP," ",BGUCN3) D
 .I " AND OR NOT "[(" "_BGUCEXP1_" ") D  Q
 ..I BGUCSEG="" S BGUCNJP=$S(BGUCEXP1="NOT":"N"_BGUCNJP,1:BGUCEXP1) Q
 ..S BGUCNJN=$S(BGUCEXP1="NOT":"N"_BGUCNJN,1:BGUCEXP1)
 .I BGUCNJN'="" D BLDEXP1 S (BGUCSEG,BGUCNJP,BGUCNJN)=""
 .;S:BGUCN3>1 BGUCSEG=BGUCSEG_" " S BGUCSEG=BGUCSEG_BGUCEXP1
 .S BGUCSEG=BGUCSEG_BGUCEXP1 S:$L(BGUCSEG,"""")#2=0 BGUCSEG=BGUCSEG_" "
 D:BGUCSEG'="" BLDEXP1
 Q
 ;
BLDEXP1 ;
 S:BGUCNJP="" BGUCNJP=BGUCLCNJ
 S BGUCLSEG=$L(BGUCSEG),(BGUCSBJ,BGUCND,BGUCVAL)=""
 S BGUCQ=0 F BGUCN4=1:1:BGUCLSEG S BGUCC=$E(BGUCSEG,BGUCN4) D  Q:BGUCQ  S BGUCSBJ=BGUCSBJ_BGUCC
 .Q:BGUCC?1AN  Q:"!;"[BGUCC
 .I BGUCC=".",$E(BGUCSEG,BGUCN4+1)?1N Q
 .I BGUCC="-",$E(BGUCSEG,BGUCN4+1)="P" Q
 .S BGUCQ=1
 F BGUCN4=BGUCN4:1:BGUCLSEG S BGUCC=$E(BGUCSEG,BGUCN4) Q:"<>=[?"'[BGUCC  S BGUCND=BGUCND_BGUCC
 S:BGUCC="." BGUCND=$P($E(BGUCSEG,BGUCN4,BGUCLSEG),".",2),BGUCND=$G(BGUCOND(BGUCND)),BGUCN4=$F(BGUCSEG,".",BGUCN4+1)
 S BGUCSBJL=$L(BGUCSBJ,"!") S:BGUCSBJ[";" BGUCSBJL=BGUGLEV($P(BGUCSBJ,";"),$P(BGUCSBJ,";",2))/2 S:BGUCSBJL>BGUCMXL BGUCMXL=BGUCSBJL
 S BGUCVAL=$E(BGUCSEG,BGUCN4,BGUCLSEG),BGUCSEG=BGUCSBJ_"~"_BGUCND_"~"_BGUCVAL
 S BGUCSUB(BGUCLV)=$O(@BGUCARY@(""),-1)+1,@BGUCARY@(BGUCSUB(BGUCLV))=BGUCNJP_U_BGUCSEG_U_BGUCNJN
 S BGUCLCNJ=BGUCNJN
 Q
 ;
 ; Input  : BGUCND,BGUV
 ; Output : BGUTV
CND ;EP Called by BGULIST1
 ;W !,BGUCNDS,!
 S BGUCARY="BGUCND",(BGUCLV,BGUCF)=1,(BGUCSUB,BGUCSBS,BGUCSKP)=""
 F  S BGUCSUB(BGUCLV)=$O(@BGUCARY@($G(BGUCSUB(BGUCLV)))),BGUCSUB=BGUCSUB(BGUCLV) Q:BGUCSUB=""!'BGUCF&(BGUCLV=1)  D
 .I BGUCSUB=""!'BGUCF S BGUCLV=BGUCLV-1,BGUCF=1 D  D:$D(BGUTV(BGUCLV+1)) CKUPTV Q
 ..I BGUCLV=1 S BGUCARY=$P(BGUCARY,"("),BGUCSBS="" Q
 ..S BGUCSBS=$P(BGUCSBS,",",1,BGUCLV-1),BGUCARY=$P(BGUCARY,"(")_"("_BGUCSBS_")"
 .D EVAL Q:'BGUCF
 .I BGUCSKP S BGUCSKP=0 Q
 .S BGUCLV=BGUCLV+1 S:BGUCLV>2 BGUCSBS=BGUCSBS_"," S BGUCSBS=BGUCSBS_BGUCSUB
 .S BGUCARY=$P(BGUCARY,"(")_"("_BGUCSBS_")"
 .;W !,BGUCARY,?10+(BGUCLV*5),@BGUCARY
 S BGUTV=BGUTV(1)
 K BGUCARY,BGUCEXP,BGUCF,BGUCLV,BGUCNJN,BGUCNJP,BGUCNOT,BGUCSBJ,BGUCSBS,BGUCSKP,BGUCSUB,BGUCTV,BGUCVAL,BGUCX,BGUTV(1)
 ;W ! ZW BGUV,BGUTV
 Q
 ;
CKUPTV ;
 S BGUCNJN=$P(@BGUCARY@(BGUCSUB(BGUCLV)),U,3),BGUCTV=$$CONJ(BGUCNJN,BGUTV(BGUCLV+1))
 D
 .I BGUCTV D  Q
 ..I BGUCNJN'["AND" S BGUTV(BGUCLV)=1 Q
 ..I $G(BGUTV(BGUCLV))=0 S BGUTV(BGUCLV)=0 Q
 ..S BGUTV(BGUCLV)=1
 .S BGUTV(BGUCLV)=0
 K BGUTV(BGUCLV+1)
 Q
 ;
EVAL ;
 S BGUCX=@BGUCARY@(BGUCSUB(BGUCLV)),BGUCNJP=$P(BGUCX,U),BGUCEXP=$P(BGUCX,U,2),BGUCNJN=$P(BGUCX,U,3),BGUCSBJ=$P(BGUCEXP,"~"),BGUCND=$P(BGUCEXP,"~",2),BGUCVAL=$P(BGUCEXP,"~",3)
 S BGUCFID=BGUFILE S:BGUCSBJ[";" BGUCFID=$P(BGUCSBJ,";"),BGUCSBJ=$P(BGUCSBJ,";",2) S BGUCSBJ=$G(BGUV(BGUCFID,BGUCSBJ))
 D:BGUCND'["?"
 .I BGUCVAL?1N.E S BGUCFID=BGUFILE S:BGUCVAL[";" BGUCFID=$P(BGUCVAL,";"),BGUCVAL=$P(BGUCVAL,";",2) S BGUCVAL=$G(BGUV(BGUCFID,BGUCVAL)) Q
 .S:$E(BGUCVAL)="""" BGUCVAL=$P(BGUCVAL,"""",2)
 ;W !,"Subject: ",BGUCSBJ," Conditon: ",BGUCND," Value: ",BGUCVAL
 D
 .I BGUCND["=" D  Q
 ..I BGUCND="=" S BGUTV=BGUCSBJ=BGUCVAL Q
 ..I BGUCND["<" S BGUTV=BGUCSBJ'>BGUCVAL Q
 ..I BGUCND[">" S BGUTV=BGUCSBJ'<BGUCVAL Q
 .I BGUCND["<" D  Q
 ..I BGUCND="<" S BGUTV=BGUCSBJ<BGUCVAL Q
 ..I BGUCND[">" S BGUTV=BGUCSBJ'=BGUCVAL Q
 .I BGUCND=">" S BGUTV=BGUCSBJ>BGUCVAL Q
 .I BGUCND["[" D  Q
 ..I BGUCND="[" S BGUTV=BGUCSBJ[BGUCVAL Q
 ..S BGUTV=BGUCSBJ'[BGUCVAL Q
 .I BGUCND["?" D  Q
 ..I BGUCND="?" S BGUTV=BGUCSBJ?@BGUCVAL Q
 ..S BGUTV=BGUCSBJ'?@BGUCVAL Q
 S BGUCTV=$S(BGUCNJP'="":$$CONJ(BGUCNJP,BGUTV),1:BGUTV)
 I BGUCTV D  Q
 .I BGUCNJP["AND",$G(BGUTV(BGUCLV))=0 Q
 .S BGUTV(BGUCLV)=1
 .S:BGUCNJN["OR" BGUCSKP=1
 I BGUCNJP["OR",$G(BGUTV(BGUCLV)) Q
 S BGUTV(BGUCLV)=0
 I BGUCNJP["AND",BGUCNJN="" S BGUCF=0
 S:BGUCNJN["AND" BGUCSKP=1
 Q
 ;
CONJ(BGUCONJ,BGUTVX) ;
 S BGUCNOT=0 S:$E(BGUCONJ)="N" BGUCONJ=$E(BGUCONJ,2,4),BGUCNOT=1
 Q:BGUCNOT 'BGUTVX
 Q BGUTVX